      FUNCTION AITLAG ( X, STPINV, TABLE, NTABLE, NAIT )                
C                                                                       
C     AITKEN-LAGRANGE INTERPOLATION FOR THE DWBA                        
C                                                                       
C     PERFORMS AITKENS LAGRANGE INTERPOLATION.  THIS ROUTINE IS         
C     SPECIFICALLY DESIGNED FOR THE DWBA CODE.  IT MAKES NO ERROR       
C     CHECKS AND IS SPECIALIAZED IN A NUMBER OF PLACES                  
C                                                                       
C     X - VALUE TO BE INTERPOLATED TO.                                  
C     STPINV - INVERSE OF THE TABLE STEP SIZE.                          
C     TABLE - THE TABLE OF GIVEN FUNCTION VALUES.                       
C          TABLE(I+1) = F( I/STPINV )                                   
C          NOTE THAT TABLE(1) ALWAYS CORRESPONDS TO X = 0.              
C     NTABLE - THE NUMBER OF ENTRIES IN TABLE.                          
C     NAIT - THE ORDER OF INTERPOLATION TO USE.  NAIT+1 POINTS          
C            WILL BE USED.                                              
C                                                                       
C     2/14/75 - FIRST VERSION, S. PIEPER                                
C     2/24/75 - CORRECT ERROR FOR INTERPOLATION AT ENDPOINT             
C     12/26/79 - STANDARD PREFIXES - RPG                                
C     1/14/80 - CORRECT ABOVE: CHARACTER TO REAL - RPG                  
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL TABLE                                               
C                                                                       
      DIMENSION TABLE(NTABLE)                                           
C                                                                       
      REAL*8 FS(16), DELS(16)                                           
C                                                                       
CIB      REAL*8  HOLD / Z 4E800000 00000000 /                           
CIB      INTEGER ITABL2(2)                                              
CIB      EQUIVALENCE ( ITABL2(1), DITABL )                              
CIB      INTEGER NO8 / Z 4E000000 /                                     
CIB      REAL*8  DZERO / Z 00000000 00000000 /                          
C                                                                       
CDC%';DATA' = '";DATA"' ;                                               
C                                                                       
C     FOLLOWING ARE INVERSES OF INTEGERS                                
C                                                                       
      REAL*8 INVERS(16)                                                 
C                                                                       
      DATA INVERS( 1) / 0.100000000000000000 0D+01 /                    
      DATA INVERS( 2) / 0.500000000000000000 0D+00 /                    
      DATA INVERS( 3) / 0.333333333333333329 0D+00 /                    
      DATA INVERS( 4) / 0.250000000000000000 0D+00 /                    
      DATA INVERS( 5) / 0.199999999999999997 0D+00 /                    
      DATA INVERS( 6) / 0.166666666666666671 0D+00 /                    
      DATA INVERS( 7) / 0.142857142857142863 0D+00 /                    
      DATA INVERS( 8) / 0.125000000000000000 0D+00 /                    
      DATA INVERS( 9) / 0.111111111111111105 0D+00 /                    
      DATA INVERS(10) / 0.100000000000000006 0D+00 /                    
      DATA INVERS(11) / 0.909090909090909116 0D-01 /                    
      DATA INVERS(12) / 0.833333333333333287 0D-01 /                    
      DATA INVERS(13) / 0.769230769230769273 0D-01 /                    
      DATA INVERS(14) / 0.714285714285714246 0D-01 /                    
      DATA INVERS(15) / 0.666666666666666657 0D-01 /                    
      DATA INVERS(16) / 0.625000000000000000 0D-01 /                    
C                                                                       
C     FIND THE LOCATION OF X IN THE TABLE                               
C                                                                       
      IF ( X .LT. 0 ) GO TO 900                                         
      XBYH = X*STPINV                                                   
CIB      DITABL = XBYH + HOLD                                           
CIB      ITABL2(1) = NO8                                                
CIB      ITABLE = ITABL2(2)                                             
      ITABLE = XBYH                                                     
C     FOLLOWING TEST ALLOWS US TO GO ONE STEPSIZE BEYOND TABLE          
      IF ( ITABLE .GE. NTABLE ) GO TO 920                               
C                                                                       
C     GET RANGE OF TABLE TO USE                                         
C                                                                       
      NAIT2 = NAIT/2                                                    
      NSTART = ITABLE - NAIT2                                           
      IF ( NSTART .LT. 0 ) NSTART = 0                                   
      NEND = NSTART + NAIT                                              
      IF ( NEND .GE. NTABLE ) NEND = NTABLE - 1                         
      NSTART = NEND - NAIT                                              
C                                                                       
C     GET FIRST VALUE                                                   
C                                                                       
      FS(1) = TABLE(NSTART+1)                                           
CIB      ITABL2(2) = NSTART                                             
CIB      DEL1 = (DZERO-DITABL) + XBYH                                   
      DEL1 = XBYH-NSTART                                                
      DELS(1) = DEL1                                                    
C                                                                       
C     NOW DO THE AITKEN LOOP                                            
C                                                                       
      DO 199 I = 1, NAIT                                                
      F = TABLE(NSTART+1+I)                                             
      DEL1 = DEL1 - 1                                                   
C                                                                       
      DO 189 J = 1, I                                                   
      F = ( F*DELS(J) - FS(J)*DEL1 ) * INVERS(I+1-J)                    
 189  CONTINUE                                                          
      DELS(I+1) = DEL1                                                  
      FS(I+1) = F                                                       
 199  CONTINUE                                                          
C                                                                       
 300  AITLAG = F                                                        
      RETURN                                                            
C                                                                       
C     ERROR ... X OUT OF BOUNDS                                         
C                                                                       
 900  WRITE(6,903) X
 903  FORMAT ('0****** AITLAG - X < 0:', G15.5 )                        
      AITLAG = TABLE(1)                                                 
      RETURN                                                            
C                                                                       
 920  WRITE(6,923) X, ITABLE, NTABLE                                      
 923  FORMAT ('0***** AITLAG - X TOO LARGE:', G15.5, 2I10 )             
      AITLAG = TABLE(NTABLE)                                            
      RETURN                                                            
      END
      
      SUBROUTINE AKFCR(L1,J1,L2,J2,LXX2,J,AKREST)                       
C                                                                       
C     CONSTRUCTION OF KINEMATICAL FACTORS  W(1,2)                       
C     SEE THE NOTES, EQN 21                                             
C                                                                       
C     7/2/80 FIRST VERSION MRB                                          
C     1/11/81 - BOHR & MOTTELSON CONVENTIONS - S.P.                     
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      REAL*4 AKREST                                                     
C                                                                       
      IF((L1.LT.0).OR.(L2.LT.0))GO TO 10                                
      RME=CLEBSH(L1,LXX2,0,0,L2,0)*SIXJ(J1,L1,J,L2,J2,LXX2)*(-1)**((J1
     *+L1+J)/2)/RT4PI  *DSQRT((LXX2+1.0D0)*(L1+1.0D0))                  
      AKREST=RME                                                        
      GO TO 20                                                          
 10   AKREST=0.                                                         
20    RETURN                                                            
      END 
      
      SUBROUTINE ALSORT(A,IX,N)                                         
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -   
C   SUBROUTINE ALSORT: ALPHABETIZES THE R*8 ARRAY A..RETURNS IX         
C       ALSORT ALPHABETIZES THE 8-BYTE LITERAL VARIABLES IN THE         
C   ARRAY 'A'.  IT RETURNS AN INDEX ARRAY IX SUCH THAT THE ALPHABETICAL 
C   ORDER OF 'A' IS                                                     
C     A(IX(1)) , A(IX(2)) , ... , A(IX(N))                              
C  A  - AN N-ELEMENT ARRAY OF 8-BYTE LITERALS                           
C  IX - AN N-ELEMENT INTEGER*4 ARRAY RETURNED BY ALSORT                 
C  N  - THE NUMBER OF ELEMENTS OF A AND IX                              
C  THIS ROUTINE USES A VERY CRUDE SORTING TECHNIQUE AND IT SHOULD NOT   
C  BE USED FOR ARRAYS WITH MORE THAN A FEW HUNDRED ELEMENTS. THE ONLY   
C  #ADVANTAGE' OF THIS PROGRAM IS THAT IT TAKES UP SOMEWHAT LESS CORE   
C  THAN ROUTINES THAT USE MUCH FASTER SORTING ALGORITHMS                
C       CAUTION:  IF THIS PROGRAM IS GIVEN AN ARRAY OF NUMBERS, IT WILL 
C                 RETURN THEM IN --DECREASING-- ORDER.  THIS IS BECAUSE 
C                 'NUMERICALLY' IN FORTRAN.....A>B>...>Z.               
C     THE ABOVE CAUTION APPLIES TO THE IBM VERSION ONLY.                
C - - - - - - - - - - - - - - - - -   FRANK SERDUKE  10/15/73           
C     12/26/79 - STANDARD PREFIXES, NON-INVERTED SORT - RPG             
C                                                                       
      REAL*8 A(N)   
C      CHARACTER*8 A(N)
CDC      INTEGER A(N)                                                   
      INTEGER*4 IX(N)                                                   
C -- INITIALIZE THE INDEX ARRAY                                         
      DO 10 I=1,N                                                       
10    IX(I) = I                                                         
C                                                                       
      IF ( N .LE. 1 ) GO TO 40                                          
C                                                                       
C --- BEGIN THE BUBBLE SORT ON THE INDICES                              
      JLIM = N                                                          
      ILIM = N-1                                                        
C                                                                       
      DO 30 I=1,ILIM                                                    
      JLIM = JLIM - 1                                                   
      IEX = 0                                                           
      DO 20 J=1,JLIM                                                    
      II = IX(J)                                                        
      JJ = IX(J+1)                                                      
CIB            IF ( A(II) .GE. A(JJ) ) GO TO 20                         
CDC            IAII = AND( SHIFT(A(II),-1), 37777777777777777777B )     
CDC            IAJJ = AND( SHIFT(A(JJ),-1), 37777777777777777777B )     
CDC            IF ( IAII .LE. IAJJ ) GO TO 20                           
      IF ( A(II) .LE. A(JJ) ) GO TO 20                                  
      IEX = IEX + 1                                                     
      ITEMP = IX(J)                                                     
      IX(J) = IX(J+1)                                                   
      IX(J+1) = ITEMP                                                   
20    CONTINUE                                                          
      IF ( IEX .EQ. 0 ) GO TO 40                                        
30    CONTINUE                                                          
40    RETURN                                                            
      END
      
      SUBROUTINE AMPCAL (ANGLE,ELSW,NSPL,LMN,LMX,LSKP,LXMX,IDNPAR,ETA, 
     * UK, SIGZRO, LOHISW, LHI,  JTOCS, BETAS, ALOWFC,  F, FLO, 
     * FHI,FERROR, FCOUL, PLM, CONTR, CONTI,  LEBACK, FEPSLO, NFLOP )   
C                                                                       
C     CALCULATES THE TRANSITION AMPLITUDES F AT ONE ANGLE.              
C                                                                       
C     INPUT SCALARS:                                                    
C                                                                       
C     ANGLE = C.M. ANGLE (DEGREES).                                     
C     ELSW = .TRUE. FOR ELASTIC SCATTERING.                             
C     NSPL = NUMBER OF AMPLITUDES F.                                    
C     LMN, LMX, LSKP = MINIMUM, MAXIMUM, INCREMENT IN INCOMING L.       
C     LXMX = MAXIMUM LX.                                                
C     IDNPAR = 0 IF THERE ARE NO IDENTICAL PARTICLES                    
C            = 1 IF ONLY ONE PAIR (IN OR OUT) IS IDENTICAL              
C            = 2 IF BOTH PAIRS ARE IDENTICAL                            
C     ETA = COULOMB PARAMETER (ELASTIC ONLY).                           
C     UK = INCIDENT WAVENUMBER (ELASTIC ONLY).                          
C     SIGZRO = L=0 COULOMB PHASE (ELASTIC ONLY).                        
C     LOHISW = .TRUE. IF FLO AND FHI ARE TO BE RETURNED.                
C     LHI = MAXIMUM L TO BE INCLUDED IN FHI.                            
C     LEBACK - NUMBER OF L VALUES TO USE IN THE EPSILON                 
C              ALGORITHM;  0 MEANS NOT TO BE USED.                      
C                                                                       
C     OUTPUT SCALAR                                                     
C                                                                       
C     NFLOP - APPROX NUMBER OF FLOATING OPS IN THIS CALL                
C                                                                       
C     INPUT ARRAYS (AND DIMENSIONS)):                                   
C                                                                       
C     JTOCS(4,NSPL) = TABLE-OF-CONTENTS FOR S AND F (SEE ANGSET).       
C     BETAS(2,NSPL,LMX-LBASE+1) = (R*4) BETA (SEE BETCAL).              
C     ALOWFC(2,2) = BETA CONTRIBUTIONS FROM LX=0, L=LMN,LMN+1 FROM      
C        NONZERO S (ELASTIC ONLY).  (SEE BETCAL.)                       
C                                                                       
C     OUTPUT ARRAYS:                                                    
C                                                                       
C     F(2,NSPL) = TRANSITION AMPLITUDES SUMMED FROM LMN TO LHI          
C     FLO(2,NSPL) = F CONTRIBUTIONS FROM LMN+2 <= LO <= LMX.            
C     FHI(2,NSPL) = F CONTRIBUTIONS FROM LMN <= LO <= LHI.              
C     IF LEBACK > 0, THE ABOVE THREE ARRAYS ARE ALL EPSILON ACCELERATED 
C     FERROR(NSPLI) = THE RELATIVE ERRORS IN !F! AS DETERMINED          
C           BY THE EPSILON ALGORITHM OR FROM THE LAST TWO ELEMENTS.     
C           FOR ELASTIC SCAT IT IS THE RELATIVE ERROR IN !F-FCOUL!.     
C     FCOUL(2,3) = COULOMB AMPLITUDES (ELASTIC ONLY).                   
C     PLM(LMX+1+((2*LMX+1-LXMX)*LXMX)/2) = ASSOCIATED LEGENDRE          
C        FUNCTIONS.  INDEX = LO+1 + MX* (2*LMX+1-MX )/2 .               
C     CONTR, CONTI - WORK ARRAYS OF DIMENSION LMX+1                     
C     FEPSLO - WORK ARRAY OF DIMENSION 2*LEBACK                         
C                                                                       
C     NOTE:  FOR ELASTIC SCATTERING OF IDENTICAL PARTICLES, ARRAYS      
C     F, FLO, FHI, AND FCOUL ARE DIMENSIONED (2,3), AND WILL CONTAIN    
C     SYMMETRIC, ANTISYMMETRIC, AND UNSYMMETRIZED COMBINATIONS          
C     OF AMPLITUDES.                                                    
C                                                                       
C                                                                       
C     8/31/79 - NEW ROUTINE, FROM XSECTN AND ELDCS - RPG                
C     1/31/80 - CHECK COULOMB AMPLITUDE AGAINST BIGNUM - RPG            
C     4/3/80 - REAL*4 BETAS - S.P.                                      
C     7/28/80 - REARRANGED TO ALLOW PARALLEL PROCESSING - S.P.          
C     7/30/80 - USE THE BLA SSUM IN THE CRAY VERSION - S.P.             
C     9/11/80 - FIX BUGS FOR LSKP=2 - S.P.                              
C     9/26/80 - DON'T CONSIDER LO < MX - S.P.                           
C     9/29/80 - FIX BUGS FOR LMAX=LIMOST - S.P.                         
C     6/12/81 - FIX BUG FOR LMIN=LIMOST - S.P.                          
C     9/17/81 - USE EPSILON ALGORITHM - S.P.                            
C     10/9/81 - FIX MANY BUGS FOR LSKIP=2 - S.P.                        
C     10/27/81 - EXTRA ROOT 2 NEEDED FOR IDENTICAL MUTUAL - S.P.        
C                                                                       
C******* ELAS NOT YET DONE FOR IDENTICAL PARTICLES EFFICENTLY ********  
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      COMMON /CNSTNT/PI,RT4PI,PIINV,RADIAN,DEGREE,HBARC,AMUMEV,AFINE, 
     * BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      LOGICAL ELSW, IDENSW, LOHISW                                      
      REAL*4 BETAS                                                      
      DIMENSION JTOCS(4,1), BETAS(2,NSPL,1), ALOWFC(2,2),  F(2,1), FLO(2
     *,1), FHI(2,1), FCOUL(2,3), PLM(1), CONTR(1),  CONTI(1), FERROR(1),
     * FEPSLO(2, 1)                                                     
C                                                                       
      LOGICAL IDELSW                                                    
      DIMENSION FT(2), FTS(2), FTC(2), FTSC(2), FOUT(2)                 
C                                                                       
CDC      ALLOCLEVEL  JTOCS, BETAS, F, FLO, FHI, PLM, CONTR, CONTI       
C                                                                       
C     INITIALIZATION                                                    
C                                                                       
      NFLOP = 0                                                         
      NNFLOP = 0                                                        
      IODD = MOD( IABS( JTOCS(1,1) ), 2 )                               
      LOMN = LMN                                                        
      IF ( LSKP .EQ. 2 ) LOMN = LOMN + IODD                             
      LOMX = LMX                                                        
      IF ( LSKP .EQ. 2 ) LOMX = LOMX - MOD(LOMX+IODD, 2)                
      LOHI = LHI                                                        
      IF ( LSKP .EQ. 2 ) LOHI = LOHI - MOD(LOHI+IODD, 2)                
      LBASE = LMN                                                       
      IDENSW = IDNPAR .NE. 0                                            
      FACMBL = 1                                                        
      IF ( IDENSW .AND. .NOT. ELSW ) FACMBL = DSQRT( 2.0D0 )            
      IF ( IDNPAR .EQ. 2 .AND. .NOT. ELSW ) FACMBL = 2                  
      IDELSW = IDENSW .AND. ELSW                                        
      N = 2*NSPL                                                        
      IF ( IDELSW ) N = 6                                               
      DO 39 K = 1, N                                                    
      F(K,1) = 0                                                        
      IF ( .NOT. LOHISW ) GO TO 39                                      
      FLO(K,1) = 0                                                      
      FHI(K,1) = 0                                                      
 39   CONTINUE                                                          
C                                                                       
C     CALCULATE THE LEGENDRE FUNCTIONS.                                 
C                                                                       
      AN = DEGREE*ANGLE                                                 
      AACOS = DCOS( AN )  
      CALL PLMSUB( LMX, LXMX, AACOS, PLM )
      NFLOP = 16 + 7*(LMX+1)*(LXMX+1)                                   
C                                                                       
C     ELASTIC:  CALCULATE THE COULOMB AMPLITUDE.                        
C     IDENTICAL PARTICLES NEED IT FOR BOTH ANGLE AND PI-ANGLE.          
C                                                                       
      IF ( .NOT. ELSW ) GO TO 100                                       
      LOMN = 0                                                          
      LBASE = 0                                                         
      TEMP = DSIN( 0.5*AN )                                             
      TEMP = DMAX1( TEMP, 1.0D-10 )                                     
      PHASE = 2*( SIGZRO - ETA*DLOG( TEMP ) )                           
      TEMP = -0.5*ETA/(UK*TEMP**2)                                      
      IF ( DABS(TEMP) .GT. BIGNUM ) TEMP = DSIGN( BIGNUM, TEMP )        
      FTC(1) = TEMP*DCOS( PHASE )                                       
      FTC(2) = TEMP*DSIN( PHASE )                                       
      FTSC(1) = 0                                                       
      FTSC(2) = 0                                                       
      NFLOP = NFLOP + 72                                                
      IF ( .NOT. IDENSW ) GO TO 80                                      
      AN = PI - AN                                                      
      TEMP = DSIN( 0.5*AN )                                             
      TEMP = DMAX1( TEMP, 1.0D-10 )                                     
      PHASE = 2*( SIGZRO - ETA*DLOG( TEMP ) )                           
      TEMP = -0.5*ETA/(UK*TEMP**2)                                      
      IF ( DABS(TEMP) .GT. BIGNUM ) TEMP = DSIGN( BIGNUM, TEMP )        
      FTSC(1) = TEMP*DCOS( PHASE )                                      
      FTSC(2) = TEMP*DSIN( PHASE )                                      
      NFLOP = NFLOP + 72                                                
      FTS(1) = 0                                                        
      FTS(2) = 0                                                        
C                                                                       
C     STILL ELASTIC:  STORE SYMMETRIC, ANTISYMMETRIC, AND               
C     UNSYMMETRIZED COULOMB AMPLITUDES.                                 
C                                                                       
 80   DO 89 IRI = 1, 2                                                  
      FCOUL(IRI,1) = FTC(IRI) + FTSC(IRI)                               
      FCOUL(IRI,2) = FTC(IRI) - FTSC(IRI)                               
      FCOUL(IRI,3) = FTC(IRI)                                           
 89   CONTINUE                                                          
      NFLOP = NFLOP + 4                                                 
C                                                                       
C     LOOP THROUGH KOFFS = JT, JP, LX, MX.                              
C                                                                       
 100  DO 299 KOFFS = 1, NSPL                                            
      IF ( JTOCS(4,KOFFS) .LT. 0 ) GO TO 299                            
      LX = JTOCS(2,KOFFS)                                               
      MX = ( JTOCS(1,KOFFS) + LX + 1 )/2                                
      LOMNMX = MAX0( LOMN, MX )                                         
      IF ( LSKP .EQ. 2 ) LOMNMX = LOMNMX + MOD( LOMNMX+IODD, 2 )        
      FT(1) = 0                                                         
      FT(2) = 0                                                         
      LPLM = MX*(2*LMX+1-MX)/2 + 1                                      
C                                                                       
C        SUM OVER LO.                                                   
C                                                                       
C     FLO = AMPLITUDE FROM LO = LOMN, LOMN+1.                           
C     FOR ELASTIC AND LX=0, IT DOES NOT INCLUDE THE 1 IN 1-S(L)         
C                                                                       
      IF ( LX .NE. 0 .OR. .NOT. ELSW ) GO TO 110                        
      IF ( .NOT. LOHISW ) GO TO 110                                     
      LTEMP = LOMN + 1                                                  
      DO 109 LO = LOMN, LTEMP, LSKP                                     
      PLMFAC = FACMBL*PLM(LO+1)                                         
      LPARIT = MOD( LO, 2 ) + 1                                         
      FLO(1,1) = FLO(1,1) + PLMFAC*ALOWFC(1,LPARIT)                     
      FLO(2,1) = FLO(2,1) + PLMFAC*ALOWFC(2,LPARIT)                     
 109  CONTINUE                                                          
      NNFLOP = 5*(2+LSKP)                                               
C                                                                       
C     COMPUTE ALL CONTRIBUTIONS FROM NON-ZERO S-MATIRCES                
C                                                                       
 110  DO 119 LO = LOMNMX, LOMX, LSKP                                    
      PLMFAC = FACMBL*PLM(LO+LPLM)                                      
      CONTR(LO+1) = PLMFAC*BETAS(1,KOFFS,LO-LBASE+1)                    
      CONTI(LO+1) = PLMFAC*BETAS(2,KOFFS,LO-LBASE+1)                    
 119  CONTINUE                                                          
      NNFLOP = NNFLOP + 5*(LOMX-LOMNMX+LSKP)                            
C                                                                       
C     FIRST SUM AMPLITUDE UP TO LMIN+1 TO GET FLO                       
C                                                                       
      LTEMP = MIN0( LOMN+1, LOMX )                                      
      IF ( LTEMP .LT. LOMNMX ) GO TO 125                                
      DO 124 LO = LOMNMX, LTEMP, LSKP                                   
      FT(1) = FT(1) + CONTR(LO+1)                                       
      FT(2) = FT(2) + CONTI(LO+1)                                       
 124  CONTINUE                                                          
C                                                                       
CRA      NUM = (LTEMP-LOMNMX)/LSKP + 1                                  
CRA      FT(1) = FT(1) + SSUM( NUM, CONTR(LOMNMX+1), LSKP )             
CRA      FT(2) = FT(2) + SSUM( NUM, CONTI(LOMNMX+1), LSKP )             
C                                                                       
 125  IF ( .NOT. LOHISW ) GO TO 130                                     
      IF ( ELSW .AND. LX .EQ. 0 ) GO TO 130                             
      FLO(1,KOFFS) = FT(1)                                              
      FLO(2,KOFFS) = FT(2)                                              
C                                                                       
C     SUM CONTRIBUTION FOR LMIN+2 TO LMAX  (LMAX-2 FOR ELASTIC)         
C                                                                       
 130  LTEMP = MAX0( LOMN+2, LOMNMX )                                    
      IF ( LTEMP .GT. LOHI ) GO TO 140                                  
      DO 139 LO = LTEMP, LOHI, LSKP                                     
      FT(1) = FT(1) + CONTR(LO+1)                                       
      FT(2) = FT(2) + CONTI(LO+1)                                       
 139  CONTINUE                                                          
C                                                                       
CRA      NUM = (LOHI-LTEMP)/LSKP + 1                                    
CRA      FT(1) = FT(1) + SSUM( NUM, CONTR(LTEMP+1), LSKP )              
CRA      FT(2) = FT(2) + SSUM( NUM, CONTI(LTEMP+1), LSKP )              
C                                                                       
C     FHI = AMPLITUDE FROM  LO <= LOHI.                                 
C                                                                       
 140  FHI(1,KOFFS) = FT(1)                                              
      FHI(2,KOFFS) = FT(2)                                              
C                                                                       
C     NOW THE LAST TERMS > LMAX OR LMAX-1                               
C                                                                       
      LTEMP = LOHI+LSKP                                                 
      IF ( LTEMP .GT. LOMX ) GO TO 150                                  
      DO 149 LO = LTEMP, LOMX, LSKP                                     
      FT(1) = FT(1) + CONTR(LO+1)                                       
      FT(2) = FT(2) + CONTI(LO+1)                                       
 149  CONTINUE                                                          
C                                                                       
CRA      NUM = (LOMX-LTEMP)/LSKP + 1                                    
CRA      FT(1) = FT(1) + SSUM( NUM, CONTR(LTEMP+1), LSKP )              
CRA      FT(2) = FT(2) + SSUM( NUM, CONTI(LTEMP+1), LSKP )              
C                                                                       
C                                                                       
C     IF NECESSARY APPLY EPSILON ALGORITHM                              
C                                                                       
 150  FERROR(KOFFS) = ( DABS(CONTR(LOMX+1))+DABS(CONTI(LOMX+1)) )  / ( D
     *ABS(FT(1))+DABS(FT(2)) + SMLNUM )                                 
      IF ( LEBACK .LE. 0 ) GO TO 200                                    
      N = MIN0( (LOMX-LOMNMX)/LSKP, LEBACK-1 )                          
      IF ( N .LE. 5 ) GO TO 200                                         
      NN = N+1                                                          
      FEPSLO(1,NN) = FT(1)                                              
      FEPSLO(2,NN) = FT(2)                                              
      DO 159 I = 1, N                                                   
      II = NN-I                                                         
      FEPSLO(1,II) = FEPSLO(1,II+1) - CONTR(LOMX+1-LSKP*(I-1))          
      FEPSLO(2,II) = FEPSLO(2,II+1) - CONTI(LOMX+1-LSKP*(I-1))          
 159  CONTINUE                                                          
      CALL EPSLON ( FEPSLO, NN, FT, 1.D-5, FERROR(KOFFS), IER )         
C                                                                       
      N = MIN0( (LOHI-LOMNMX)/LSKP, LEBACK-1 )                          
      IF ( N .LE. 5 ) GO TO 200                                         
      NN = N+1                                                          
      FEPSLO(1,NN) = FHI(1,KOFFS)                                       
      FEPSLO(2,NN) = FHI(2,KOFFS)                                       
      DO 169 I = 1, N                                                   
      II = NN-I                                                         
      FEPSLO(1,II) = FEPSLO(1,II+1) - CONTR(LOHI+1-LSKP*(I-1))          
      FEPSLO(2,II) = FEPSLO(2,II+1) - CONTI(LOHI+1-LSKP*(I-1))          
 169  CONTINUE                                                          
      CALL EPSLON ( FEPSLO, NN, FOUT, 1.D-5, DUMMY, IER )               
      FHI(1,KOFFS) = FOUT(1)                                            
      FHI(2,KOFFS) = FOUT(2)                                            
C                                                                       
C           FOR ELASTIC SCATTERING OF IDENTICAL PARTICLES,              
C           DO IT AGAIN FOR PI - ANGLE.                                 
C                                                                       
C     ****  THIS COULD ALSO BE DONE MORE EFFICENTLY ****                
C                                                                       
 200  IF ( .NOT. IDELSW ) GO TO 270                                     
      DO 259 LO = LOMNMX, LOMX, LSKP                                    
      CONR = CONTR(LO+1)                                                
      CONI = CONTI(LO+1)                                                
      IF ( MOD( LO, 2 ) .EQ. 0 ) GO TO 220                              
      CONR = -CONR                                                      
      CONI = -CONI                                                      
 220  FTS(1) = FTS(1) + CONR                                            
      FTS(2) = FTS(2) + CONI                                            
      IF ( .NOT. LOHISW ) GO TO 259                                     
      IF ( LO .GT. LOMN+1 ) GO TO 250                                   
      LPARIT = MOD( LO, 2 ) + 1                                         
      PLMFAC = FACMBL*PLM(LO+LPLM)                                      
      IF ( LPARIT .EQ. 2 ) PLMFAC = -PLMFAC                             
      FLO(1,2) = FLO(1,2) + PLMFAC*ALOWFC(1,LPARIT)                     
      FLO(2,2) = FLO(2,2) + PLMFAC*ALOWFC(2,LPARIT)                     
 250  IF ( LO .NE. LOHI ) GO TO 259                                     
      FHI(1,2) = FTS(1)                                                 
      FHI(2,2) = FTS(2)                                                 
C                                                                       
 259  CONTINUE                                                          
      NNFLOP = NNFLOP + 5*(LOMX-LOMNMX+LSKP)                            
C                                                                       
C        END OF LO SUM.  TRANSFER TO OUTPUT ARRAYS.                     
C        FLO IS ALL EXCEPT THE FIRST 2 L'S.                             
C                                                                       
 270  F(1,KOFFS) = FT(1)                                                
      F(2,KOFFS) = FT(2)                                                
C                                                                       
      IF ( .NOT. LOHISW ) GO TO 299                                     
      FLO(1,KOFFS) = FT(1) - FLO(1,KOFFS)                               
      FLO(2,KOFFS) = FT(2) - FLO(2,KOFFS)                               
 299  CONTINUE                                                          
C                                                                       
C     END OF KOFFS LOOP.                                                
C                                                                       
      NFLOP = NFLOP + NNFLOP/LSKP                                       
C                                                                       
C     FOR ELASTIC SCATTERING, ADD THE COULOMB AMPLITUDES.               
C                                                                       
      IF ( .NOT. ELSW ) RETURN                                          
      DO 359 IRI = 1, 2                                                 
      F(IRI,1) = F(IRI,1) + FTC(IRI)                                    
      IF ( .NOT. LOHISW ) GO TO 330                                     
      FHI(IRI,1) = FHI(IRI,1) + FTC(IRI)                                
      FLO(IRI,1) = FLO(IRI,1) + FTC(IRI)                                
C                                                                       
C        FOR ELASTIC SCATTERING OF IDENTICAL PARTICLES,                 
C        FORM SYMMETRIC, ANTISYMMETRIC, AND UNSYMMETRIZED               
C        COMBINATIONS.                                                  
C                                                                       
 330  IF ( .NOT. IDELSW ) GO TO 359                                     
C                                                                       
      FTS(IRI) = FTS(IRI) + FTSC(IRI)                                   
      F(IRI,3) = F(IRI,1)                                               
      F(IRI,1) = F(IRI,3) + FTS(IRI)                                    
      F(IRI,2) = F(IRI,3) - FTS(IRI)                                    
      IF ( .NOT. LOHISW ) GO TO 359                                     
      FLO(IRI,2) = FTS(IRI) - FLO(IRI,2)                                
      FLO(IRI,3) = FLO(IRI,1)                                           
      FLO(IRI,1) = FLO(IRI,3) + FLO(IRI,2)                              
      FLO(IRI,2) = FLO(IRI,3) - FLO(IRI,2)                              
      FHI(IRI,2) = FHI(IRI,2) + FTSC(IRI)                               
      FHI(IRI,3) = FHI(IRI,1)                                           
      FHI(IRI,1) = FHI(IRI,3) + FHI(IRI,2)                              
      FHI(IRI,2) = FHI(IRI,3) - FHI(IRI,2)                              
 359  CONTINUE                                                          
      NFLOP = NFLOP+6                                                   
      RETURN                                                            
      END                                                               
      SUBROUTINE ANAPOW ( ANGMIN, ANGMAX, ANGSTP, JA, JB, JBIGA, JBIGB, 
     * NSPL, IPARIT, PRNTSW, PBUGSW, APNAME, ELAB, CHNM,  IF, ITOCS, IAP
     *OW )                                                              
C                                                                       
C                                                                       
C     COMPUTES AND PRINTS ANALYZING POWERS (REACTION OR SCATTERING ).   
C                                                                       
C                                                                       
C     THE ANALYZING POWERS ARE RETURNED IN AN ALLOCATOR ARRAY POINTED   
C     TO BY ARGUMENT IAPOW AND NAMED BY ARGUMENT  APNAME.  THE          
C     ANGLE VARIES MOST RAPIDLY, THE ANALYZING POWER TYPE LEAST RAPIDLY.
C     THE TYPES INCLUDE ONLY POSITIVE, ALLOWED VALUES OF Q.             
C     IMAGINARY ANALYZING POWERS ARE RETURNED AS THE REAL PART OF       
C     I* THE ANALYZING POWER;  I.E. THE ORDER IS IT11, T20, T21, T22,   
C     IT31, IT32, IT33, ETC.  K GOES FROM 1 TO 2*JA.                    
C                                                                       
C           THE ANALYZING POWERS ARE RELATED TO THE MUELLER MATRIX Z    
C     BY THE EQUATION                                                   
C        T(K,Q) = (-1)**Q * Z(K,-Q,0,0,0,0,0,0).                        
C     CHANGING -Q TO Q INTRODUCES (-1)**(K+Q).  FOR ODD K, Z IS         
C     IMAGINARY, AND I*T(K,Q) = IM( Z(K,Q,ETC.) ), BECAUSE THE          
C     MULTIPLTCATION BY I CANCELS THE (-1)**K.                          
C                                                                       
C                                                                       
C     INPUT SCALARS:                                                    
C                                                                       
C     ANGMIN, ANGMAX, ANGSTP = MINIMUM, MAXIMUM, STEP IN ANGLE.         
C     JA, JB, JBIGA, JBIGB = 2 * SPINS OF THE PARTICLES.                
C     NSPL = THE NUMBER OF AMPLITUDES (F) AT EACH ANGLE.                
C     IPARIT = THE PARITY CHANGE OF THE REACTION (+1 OR -1).            
C     PRNTSW = .TRUE. IF ANALYZING POWERS ARE TO BE PRINTED.            
C     PBUGSW = .TRUE. IF DEBUGGING STUFF IS TO BE PRINTED.              
C     APNAME = 8-CHARACTER NAME TO BE ASSIGNED TO THE ANALYZING         
C        POWER ARRAY ('ANPOW', 'ANPOWA', 'ANPOWB').                     
C     ELAB = LAB ENERGY ( FOR PRINTING ONLY ).                          
C     CHNM = 8-CHARACTER NAME IDENTIFYING THE CHANNEL                   
C        ('REACTION', 'ELASTIC', 'INCOMING', 'OUTGOING').               
C                                                                       
C     INPUT POINTERS (NALLOC'S TO INPUT ARRAYS IN THE ALLOCATOR):       
C                                                                       
C     IF = REACTION AMPLITUDES.                                         
C     ITOCS = TABLE OF CONTENTS FOR F.                                  
C                                                                       
C     RETURNED POINTER (NALLOC TO RETURNED ARRAY):                      
C                                                                       
C     IAPOW = ANALYZING POWERS.                                         
C                                                                       
C                                                                       
C     11/2/79 - NEW ROUTINE - RPG                                       
C     6/26/80 - PASS PBUGSW TO MUELCO - S.P.                            
C     8/4/80 - CALL SETLOG - S.P.                                       
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
C                                                                       
      LOGICAL PRNTSW, PBUGSW, SKIPSW                                    
      CHARACTER*8 APNAME, CHNM                                          
      INTEGER QMIN, Q                                                   
      DIMENSION LSTK(12), LSTQ(12)                                      
      CHARACTER*1 LSTI(12), ILABL(2)                                    
      DATA ILABL / ' ', 'I' /, LINEMX / 57 /                            
C                                                                       
C     COUNT AND ALLOCATE THE ANALYZING POWER ARRAY, AND CLEAR IT.       
C                                                                       
      NUMANG = ( ANGMAX - ANGMIN )/ANGSTP + 1.5                         
      NUMAP = ( (JA+2)*JA )/2                                           
      IAPOW = NALLOC( NUMANG*NUMAP, APNAME )                            
      CALL INIT8 (IAPOW, 0.D0 )                                         
C                                                                       
C     "APCO" AND "APSCR" ARE THE COEFFICIENT AND SCRATCH ARRAYS USED BY 
C     SUBROUTINE MUELCO.  "FTIMESF' IS THE PRODUCT OF AMPLITUDES, AND   
C     "TEMPCROS" IS THE CROSS SECTION.                                  
C                                                                       
      NQ = JA + MOD( JA+1, 2 )                                          
      N = NSPL**2 * NQ                                                  
      IAPCO = NALLOC( N, 'APCO    ' )                                   
      N = NQ + 2*JA + 3                                                 
      IAPSCR = NALLOC( N, 'APSCR   ' )                                  
      IFTF = NALLOC( NUMANG, 'FTIMESF ' )                               
      ICROS = NALLOC( NUMANG, 'TEMPCROS' )                              
      CALL INIT8 ( ICROS, SMLNUM )                                      
      KCROS = MIN0( JA, 2 )                                             
C                                                                       
C     ALLOCATIONS ARE FINISHED.  GET ADDRESSES.                         
C                                                                       
      CALL SETLOG ( 1 )                                                 
C                                                                       
      LCOEP = Z(IAPSCR)                                                 
      LCOET = LCOEP + NQ                                                
      LCOEX = LCOET + 1                                                 
      LTERMK = LCOEX + JA + 1                                           
      LTOCS = Z(ITOCS)*FACFR4 - FACFR4                                  
      LF = Z(IF) - 2*NSPL - 2                                           
      LFTF = Z(IFTF) - 1                                                
      LCROS = Z(ICROS) - 1                                              
C                                                                       
C     LOOP THROUGH K (1=VECTOR, 2=TENSOR, ETC.).                        
C                                                                       
      DO 309 K = 1, JA                                                  
C                                                                       
      QMIN = MOD( K, 2 )                                                
      NQ = K + 1 - QMIN                                                 
      ASSIGN 180 TO JUMPIM                                              
      IF ( QMIN .EQ. 0 ) ASSIGN 170 TO JUMPIM                           
      LAPOW = ( (K+1)*(K-1) + QMIN )/2 - QMIN                           
      LAPOW = Z(IAPOW) - 1 + NUMANG*LAPOW                               
C                                                                       
C     SUBROUTINE MUELCO CALCULATES THE ANGLE-INDEPENDENT COEFFICIENTS   
C     OF F * F'*  FOR ALL F, F', Q, FOR FIXED K.                        
C                                                                       
      CALL MUELCO ( K, 0, 0, 0, JA, JB, JBIGA, JBIGB,  NQ, 1, 1, 1, NSPL
     *, IPARIT,  ILLOC(LTOCS+1), ALLOC(Z(IAPCO)), ALLOC(LCOEP),  ALLOC(L
     *COET), ALLOC(LCOEX), ALLOC(LTERMK), PBUGSW )                      
C                                                                       
C     NOW LOOP THROUGH ALL POSSIBLE F, F'* COMBINATIONS.                
C                                                                       
      DO 289 KOFFP = 1, NSPL                                            
      IF ( ILLOC(LTOCS+4*KOFFP) .LT. 0 ) GO TO 289                      
      DO 269 KOFF = 1, NSPL                                             
      IF ( ILLOC(LTOCS+4*KOFF) .LT. 0 ) GO TO 269                       
      SKIPSW = .FALSE.                                                  
      LAPCO = Z(IAPCO) - QMIN + NQ*( KOFF-1 + NSPL*(KOFFP-1) )          
C                                                                       
C     IF THIS IS A DIAGONAL TERM AND K = MAX( JA, 2 ), INCREMENT THE    
C     CROSS SECTION AND FILL IN "FTIMESF".                              
C                                                                       
      IF ( KOFF .NE. KOFFP .OR. K .NE. KCROS ) GO TO 150                
      T = 2.                                                            
      MX = ( ILLOC(LTOCS+4*KOFF-3)+ILLOC(LTOCS+4*KOFF-2)+1 )/2          
      IF ( MX .EQ. 0 ) T = 1.                                           
      DO 139 NANG = 1, NUMANG                                           
      I = LF + 2*( NANG*NSPL + KOFF )                                   
      ALLOC(LFTF+NANG) = ALLOC(I)**2 + ALLOC(I+1)**2                    
      ALLOC(LCROS+NANG) = ALLOC(LCROS+NANG)  + T*ALLOC(LFTF+NANG)       
 139  CONTINUE                                                          
C                                                                       
C     PRINT THE COEFFICIENTS IF REQUESTED.                              
C                                                                       
 150  IF ( PBUGSW ) WRITE(6,153) KOFF,KOFFP,(ALLOC(LAPCO+Q),Q=QMIN,
     * K )                                                              
 153  FORMAT ( ' APCO', 2I2, ( T11, 10G12.5 ) )                         
C                                                                       
C     LOOP THROUGH THE Q'S, LOOKING FOR A NONZERO COEFFICIENT.          
C                                                                       
      DO 249 Q = QMIN, K                                                
      IF ( ALLOC(LAPCO+Q) .EQ. 0 ) GO TO 249                            
C                                                                       
C     IF NECESSARY, CALCULATE THE F * F'* PRODUCTS AT ALL ANGLES.       
C     WE NEED THE REAL PART FOR EVEN K, THE IMAGINARY PART FOR ODD K.   
C                                                                       
      IF ( SKIPSW ) GO TO 200                                           
      DO 189 NANG = 1, NUMANG                                           
      I = LF + 2*NANG*NSPL + 2*KOFF                                     
      II = LF + 2*NANG*NSPL + 2*KOFFP                                   
      GO TO JUMPIM, ( 170, 180 )                                        
 170  ALLOC(LFTF+NANG) = ALLOC(I)*ALLOC(II)  + ALLOC(I+1)*ALLOC(II+1)   
      GO TO 189                                                         
 180  ALLOC(LFTF+NANG) = ALLOC(II)*ALLOC(I+1)  - ALLOC(I)*ALLOC(II+1)   
 189  CONTINUE                                                          
      SKIPSW = .TRUE.                                                   
C                                                                       
C     NOW INCREMENT THE ANALYZING POWERS.                               
C                                                                       
 200  LAP = LAPOW + NUMANG*Q                                            
      T = ALLOC(LAPCO+Q)                                                
      DO 229 NANG = 1, NUMANG                                           
      ALLOC(LAP+NANG) = ALLOC(LAP+NANG)  + T*ALLOC(LFTF+NANG)           
 229  CONTINUE                                                          
C                                                                       
 249  CONTINUE                                                          
C     END OF Q LOOP.                                                    
C                                                                       
 269  CONTINUE                                                          
C     END OF KOFF LOOP                                                  
C                                                                       
 289  CONTINUE                                                          
C     END OF KOFFP LOOP                                                 
C                                                                       
 309  CONTINUE                                                          
C     END OF K LOOP                                                     
C                                                                       
C     FINALLY, DIVIDE THEM ALL BY THE CROSS SECTION.                    
C                                                                       
      I = Z(IAPOW)                                                      
      DO 339 II = 1, NUMAP                                              
      DO 329 NANG = 1, NUMANG                                           
      ALLOC(I) = ALLOC(I)/ALLOC(LCROS+NANG)                             
      I = I + 1                                                         
 329  CONTINUE                                                          
 339  CONTINUE                                                          
C                                                                       
C     ALL ANALYZING POWERS ARE COMPUTED.                                
C     FREE THE TEMPORARY ARRAYS.                                        
C                                                                       
      Z(IAPCO) = -Z(IAPCO)                                              
      Z(IAPSCR) = -Z(IAPSCR)                                            
      Z(IFTF) = -Z(IFTF)                                                
      Z(ICROS) = -Z(ICROS)                                              
C                                                                       
C     NOW PRINT THEM IF REQUESTED.                                      
C                                                                       
      IF ( .NOT. PRNTSW ) RETURN                                        
C                                                                       
C     MAKE SPACES TO MATCH THE CROSS SECTION PRINTOUT.                  
C                                                                       
      ANGBLK = 300                                                      
      IF ( NUMANG .LE. 40 ) GO TO 500                                   
      ANGBLK = 10                                                       
      IF ( ANGSTP .GE. .99 ) GO TO 500                                  
      ANGBLK = 5                                                        
      IF ( ANGSTP .GT. .201 ) GO TO 500                                 
      ANGBLK = 1                                                        
 500  NUMBLK = ANGBLK/ANGSTP + .5                                       
C                                                                       
C     PRINT AS MANY ANALYZING POWERS ON EACH PAGE AS WILL FIT           
C     WITHOUT SPLITTING A K.                                            
C                                                                       
      IIS = Z(IAPOW) - 1                                                
      KS = 1                                                            
 550  KE = MIN0( JA, 4 )                                                
      IF ( KS .EQ. 5 ) KE = MIN0( JA, 6 )                               
      IF ( KS .GT. 5 ) KE = KS                                          
C                                                                       
C     CONSTRUCT THE COLUMN LABELS FOR THIS PAGE.                        
C                                                                       
      N = 0                                                             
      DO 589 K = KS, KE                                                 
      QMIN = MOD( K, 2 )                                                
      DO 579 Q = QMIN, K                                                
      N = N + 1                                                         
      LSTK(N) = K                                                       
      LSTQ(N) = Q                                                       
      LSTI(N) = ILABL(QMIN+1)                                           
 579  CONTINUE                                                          
 589  CONTINUE                                                          
      IIE = IIS + (N-1)*NUMANG                                          
      LINECT = 1000                                                     
      ANGLE = ANGMIN - ANGSTP                                           
C                                                                       
C     LOOP THROUGH ANGLES, PRINTING.                                    
C                                                                       
      DO 699 NANG = 1, NUMANG                                           
      ANGLE = ANGLE + ANGSTP                                            
C                                                                       
C     DO WE NEED A HEADER?                                              
C                                                                       
      IF ( LINECT .LT. LINEMX ) GO TO 620                               
      WRITE(6,603) CHNM, REACT, ELAB, HEADER                              
 603  FORMAT ( X, T56, 'P T O L E M Y' /  10X, 'ANALYZING POWERS FOR T
     *HE  >>>> ', A8,  ' <<<<  CHANNEL' /  X, 45A1, F7.2, ' MEV', 5X, 
     *65A1 )                                                            
      WRITE(6,613) ( LSTI(I), LSTK(I), LSTQ(I), I = 1, N )                
 613  FORMAT ( '  ANGLE ', 12( 6X, A1, 'T', 2I1 ) / 1X )                
      LINECT = 7                                                        
C                                                                       
C     PRINT IT, WITH OCCATIONAL SPACES.                                 
C                                                                       
 620  WRITE(6,633) ANGLE,(ALLOC(II+NANG), II = IIS, IIE, NUMANG )       
 633  FORMAT ( 1X, F6.2, 2X, 12F10.5 )                                  
      LINECT = LINECT + 1                                               
      IF ( DMOD( ANGLE+ANGSTP+1.D-7, ANGBLK ) .GT. 1.D-5 )  GO TO 699   
      WRITE(6,633)
      LINECT = LINECT + 1                                               
      IF ( LINECT+NUMBLK .GT. LINEMX ) LINECT = 1000                    
 699  CONTINUE                                                          
C     END OF LOOP THROUGH ANGLES.                                       
C                                                                       
C     IF THERE ARE MORE ANALYZING POWERS, GO PRINT THEM.                
C                                                                       
      IIS = IIE + NUMANG                                                
      KS = KE + 1                                                       
      IF ( KS .LE. JA ) GO TO 550                                       
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE ANGSET ( IRTN )                                        
C                                                                       
C     SETS UP ARRAYS FOR THE ANGULAR TRANSFORMS IN THE RADIAL INTS.     
C                                                                       
C     THIS ROUTINE IS CALLED AFTER THE WAVPOT CALLS AND BEFORE INELDC.  
C     IT ALLOCATES ARRAYS USED BY A12 AND OTHER ARRAYS USED BY          
C     INELDC.  IT MUST BE CALLED AFTER WAVPOT TO ALLOW THE COULOMB      
C     ROUTINE IN WAVPOT TO USE LOTS OF ALLOCATOR AS TEMPORARY SCRATCH.  
C                                                                       
C     IRTN IS SET TO 0 IF AN ERROR OCCURS, 1 OTHERWISE.                 
C                                                                       
C     FOR THE HISTORY PRIOR TO THE SPLIT, SEE GRDSET.                   
C                                                                       
C     5/28/75 - SPLIT OFF FROM GRDSET.                                  
C     6/11/75 - SAVEHS/USEHS                                            
C     7/20/75 - ALLOW DIFFERENT L'S ON USEHS;  H  ARRAYS                
C     8/26/75 - SMALLER ILILOLX TABLES                                  
C     9/10/75 - FIX MSTOP                                               
C     2/25/76 - NOTATION OF CHAPTER 2 OF THE PTOLEMY MANUAL             
C     5/27/76 - ARRAYS FOR INTERPOLATION                                
C     12/20/76 - INELASTIC SCATTERING                                   
C     5/7/77 - FIX BUG WHEN INELASTIC LOMOST < LMAX                     
C     4/20/78 - ALLOW DEEXCITATION - S.P.                               
C               DO NOT GENERATE COULOMB STUFF FOR BETA(COULOMB)=0.      
C     4/24/78 - LI AND LO INTERCHANGED - S.P.                           
C     7/12/78 - CORRECT CHECK FOR DEFINED L'S IN USEHS RUNS             
C     5/12/79 - CLINTS TIME DONE SEPARATELY - S.P.                      
C     6/1/79 - SPIN-ORBIT AND TENSOR POTENTIALS - RPG                   
C     6/8/79 - STANDARD PREFIXES, CHARACTER TYPE - RPG                  
C     7/21/79 - FREE EXTRA AREAS ON PASS >=2 - RPG                      
C     8/7/79 - CHANGE S-MATRIX STRUCTURE - RPG                          
C     11/3/79 - COULOMB AND DIAG-COULOMB INTO BOB'S VERSION - S.P.      
C     11/20/79 - S-MATRICES STORED BY LO-LI - S.P.                      
C                STORE ALL DIAGONAL FF3'S - S.P.                        
C     12/27/79 - COUPLED CHANNELS ADDED - S.P.                          
C     2/7/80 - SMALL FIX IN ABOVE - S.P.                                
C     3/26/80 - GET IT STRAIGHT FOR NEGATIVE PARITY - S.P.              
C     4/7/80 - FILL IN LI'S FOR LMIN < LXMAX - S.P.                     
C     4/22/80 - ALLOCATE ELCOUPS (IELCUP) FOR C.C. - S.P.               
C     4/25/80 - PBUGSW LOCAL; PASS TO SETSPT - S.P.                     
C     5/1/80 - FIX 4/7/80 FOR LSKIP=2 - S.P.                            
C     6/12/81 - MAKE ENOUGH DINTS FOR SMALL LOMOST - S.P.               
C     7/12/81 - COMPUTE EXTRAPOLATION OVERLAP REGION - S.P.             
C     10/26/81 - SETSPT NOW NEEDS THE BASDEF ARRAY - S.P.               
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
      COMMON /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
C                                                                       
      COMMON /FORMF/ IBDS(2), NPOTS(2), LBP, LBT, NBP, NBT, JBP, JBT, BN
     *DMAX(2), BNDSTP(2), NSTPBD(2), RBNDS(2), ABNDS(2), RCBNDS(2), BNDM
     *AS(2), BRATMS(2), RSOBDS(2), ASOBDS(2), VBNDS(2), VSOBDS(2), TAUBD
     *S(2), LNKADB(6,2,12)                                              
      DIMENSION R2S(4)                                                  
      EQUIVALENCE ( R2S(1), RBNDS(1) )                                  
C                                                                       
      REAL*8 JACOB                                                      
      COMMON /GRIDCM/ JACOB, STPINV, COSSTP, IMSVAL, IINTS, INTOFF, IA12
     *VL, ICOSIN, IPHIT, IPHIP, IPHI, LOGIC, LOCTRP, IRI, IRO, ILOR, ILO
     *I, ILIR, ILII, IWIO, NOFLO, NRIROI, NCRIT, IXLAM, INLAM, IA12N, MS
     *KCOS, MAXCNT, ISMHPT, ISMIPT, ICOSS4, IJA12S, IHS, IIINDX, IA12TM,
     * IDW, IHINT, IHABS, IABS1, IGRDC1, NPSUMI, RVRLIM, ISMHWK, ISMHVL,
     * ISMIVL, IRIOEX, NUMHS, IGRDC2(4), IWFII, IWFIO, NWFI, NWFO, IDWI 
      LOGICAL ONELSW, IDENSW                                            
      COMMON /INELCM/ JBPF,JBTF,LXMIN,LXMAX,ILILOR,ILILOI,MSTOP,IA12M, 
     *NMLOLX,ONELSW,NUMLX,IRDINT,IELCUP,LILOSZ,NUMLIS,ILIS,IBETAS(4), 
     *ICL2FF,LXSTEP,IDENSW,LSKIP,JPMIN,JPMAX,JPBASE,NJP,JTMIN,JTMAX, 
     *JTBASE,NJT,IINDXS,ISMATR,ISMATI,NSMAT,NLX,NSPLI,ITOCS,NASPLI, 
     *IUNITR,LIFIT,ILIFIT,NOLFIT,IDELSR,IDELSI
      INTEGER INDXJS(4,2)                                               
      EQUIVALENCE ( INDXJS(1,1), JPMIN )                                
      COMMON /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
C                                                                       
      LOGICAL PBUGSW, PINFSW, COULSW, MULTSW, COUPSW                    
      CHARACTER*8 NAMER(2)                                              
      DATA NAMER/'WAVSAVIR', 'WAVSAVOR'/                                
      CHARACTER*8 NAMEI(2)                                              
      DATA NAMEI/'WAVSAVII', 'WAVSAVOI'/                                
C                                                                       
      INTEGERNUMFRE                                                     
      DATA NUMFRE / 21 /                                                
      CHARACTER*8 FRENAM(21)                                            
      DATA FRENAM/'TORUTHIN','SMAG','SPHASE','SINMAG','SINPHASE', 
     *'SOUTMAG','SOUTPHAS','TORUTHOT','CROSSSEC','LXCROSSS','LXTOTS',
     *'MXTOTS','BETAS','FIN','FOUT','F','LABCROSS','MXCROSSS',
     *'ANPOW','ANPOWA','ANPOWB'/                                        
C                                                                       
      DIMENSION DUMMY(1)                                                
C                                                                       
      IRTN = 0                                                          
C                                                                       
      IPRNT = MOD( IPRINT, 10 )                                         
      PBUGSW = IPRNT .GE. 3                                             
      PINFSW = IPRNT .GE. 2                                             
C                                                                       
      COUPSW = PROBLM .EQ. 24                                           
C                                                                       
C     ON PASS>=2, FREE AREAS NO LONGER NEEDED.                          
C                                                                       
      IF ( IBSPAS .LE. 1 ) GO TO 300                                    
      DO 259 K = 1, NUMFRE                                              
      I = NAMLOC(FRENAM(K))                                             
      IF ( I .GT. 0 ) Z(I) = -Z(I)                                      
  259 CONTINUE                                                          
C                                                                       
C     WE DO NOT NECESSARILY COMPUTE EVERY I( LI, LO, LX ).  RATHER      
C     WE FIND ONLY THOSE FOR                                            
C        LI = LMIN, LMIN+LSTEP, LMIN+2LSTEP, ..., LMAX                  
C     AND                                                               
C        LI = LMIN, LMIN+1, ..., LXMAX                                  
C     WHERE THE SERIES TERMINATES AT OR BEFORE LMAX.  ALL LO AND LX     
C     FOR THE ABOVE LI'S ARE FOUND.  THE ARRAY "LIS" CONTAINS THOSE     
C     LI'S FORWHICH THE CALCULATION IS TO BE DONE                       
C     NOTE THAT IF LMIN < LXMAX, WE EFFECTIVELY START OUT WITH          
C     LSTEP=1 TO POVIDE A SMOOTH STARTING POINT FOR INTERPOLATION       
C**************************************************                     
C     NOTE:  FOR COUPLED CHANNELS CALCULATIONS THESE ARE                
C            REALLY THE TOTAL J VALUES.  HOWEVER WE DO                  
C            NOT YET DOUBLE THEM.                                       
C**************************************************                     
C
 300  IF ( LSTEP .NE. 1 .AND. TCSWS(1) ) WRITE(6,307)
 307  FORMAT ( '0***** WARNING:  LSTEP MUST = 1 FOR TR OR TP POTENTIALS'
     * ' IN INCIDENT CHANNEL.' )                                        
      IF ( TCSWS(1) ) LSTEP = 1                                         
C                                                                       
C     COMPUTE THE NUMBER OF LI'S INCLUDING THE LI<LXMAX PART            
C                                                                       
      NUMLIS = (LMAX-LMIN+LSTEP)/LSTEP
      N = 0                                                             
      IF ( LXMAX.GT.LMIN ) N =(LXMAX-LMIN)/LSKIP-(LXMAX-LMIN)/LSTEP
      NUMLIS = NUMLIS+N                                                 
      ILIS = NALLOC( (NUMLIS+1)/FACFR4, 'LIS ' )                        
      DO 309 I = 1, NUMLIS                                              
      L = LMIN + (I-1)*LSKIP                                            
      IF ( L .GT. LXMAX ) L = (I-N-1)*LSTEP + LMIN                      
      ILLOC(FACFR4*Z(ILIS)-FACFR4+I) = L                                
  309 CONTINUE                                                          
C                                                                       
      IF ( IHSAVE .EQ. 1 ) WRITE (1, ERR=9950) NUMLIS                   
      IF ( IHSAVE .EQ. 1 ) WRITE (1, ERR=9950)  ( ILLOC(FACFR4*Z(ILIS)-F
     *ACFR4+I), I = 1, NUMLIS )                                         
      IF ( IHSAVE .NE. 2 ) GO TO 400                                    
C                                                                       
C     RECOVER LI'S FROM THE H'S FILE AND MAKE SURE THE PRESENT SET      
C     IS A SUBSET.                                                      
C                                                                       
      READ ( 1, ERR=9950, END=9950 ) NUMLIH                             
      ITEMP = IALLOC( (NUMLIH+1)/FACFR4 )                               
      READ ( 1, ERR=9950, END=9950 )  ( ILLOC(FACFR4*Z(ITEMP)-FACFR4+I),
     * I = 1, NUMLIH )                                                  
      ILIH = 1                                                          
      DO 359 ILI = 1, NUMLIS                                            
      LI = ILLOC(FACFR4*Z(ILIS)-FACFR4+ILI)                             
  330 LIH = ILLOC(FACFR4*Z(ITEMP)-FACFR4+ILIH)                          
      IF ( LI - LIH ) 380, 359, 340                                     
  340 ILIH = ILIH + 1                                                   
      IF ( ILIH .LE. NUMLIH ) GO TO 330                                 
      GO TO 380                                                         
  359 CONTINUE                                                          
      Z(ITEMP) = -Z(ITEMP)                                              
      GO TO 400                                                         
  380 WRITE(6,383) LMIN,LSTEP,LMAX,(ILLOC(FACFR4*Z(ILIS)-FACFR4+ILI),
     * ILI = 1, NUMLIS )                                                
  383 FORMAT ( '0***** ERROR: THIS SPECIFICATION OF LMIN, LSTEP,',  ' LM
     *AX (', 3I5, ' ) REQUIRES LI  S THAT WERE NOT SAVED',  ' IN THE SAV
     *EHS RUN.' /  '0***** REQUIRED LI  S -' / (15X, 20I5 ) )           
      WRITE(6,387) (ILLOC(FACFR4*Z(ITEMP)-FACFR4+ILI),ILI=1,NUMLIH)
  387 FORMAT ( '0***** AVAILABLE LI  S -' / (15X, 20I5) )               
      IRTN = 0                                                          
      RETURN                                                            
C                                                                       
C     DETERMINE THE RANGE OF LI'S TO BE USED FOR EXTRAPOLATION.         
C                                                                       
 400  LLIS = FACFR4*Z(ILIS)-FACFR4                                      
      IF ( LBACK .EQ. NOTDEF )  LBACK = LMAX - ILLOC(LLIS+NUMLIS-3)     
      LIFIT = LMAX - LBACK                                              
      DO 429 ILI = 1, NUMLIS                                            
      IF ( LIFIT .LT. ILLOC(LLIS+ILI) ) GO TO 430                       
 429  CONTINUE                                                          
 430  ILIFIT = ILI - 1                                                  
      LIFIT = ILLOC(LLIS+ILIFIT)                                        
      NOLFIT = NUMLIS - ILIFIT + 1                                      
C                                                                       
C     "INDXS" WILL CONTAIN ALL INFORMATION NECESSARY TO FIND A          
C     GIVEN S-MATRIX ELEMENT.  IT HAS 3 VALUES FOR EACH                 
C     (LX, JP, JT) TRIPLE, INDEXED BY                                   
C        K = 1 + LX + NLX*( JP-JPBASE + NJP*(JT-JTBASE) )/2             
C                                                                       
C        (3*K-2) = KOFFS = OFFSET INTO S-MATRIX (=0 IF NONEXISTENT).    
C        (3*K-1) = LDELMN = MINIMUM (LO-LI).                            
C        (3*K  ) = NDEL = NUMBER OF (LO-LI) VALUES.                     
C                                                                       
C     "TOCS" WILL CONTAIN A TABLE OF CONTENTS FOR THE S MATRIX.         
C     IT HAS 4 VALUES IDENTIFYING EACH S-MATRIX ELEMENT USED, INDEXED   
C     BY ITS POSITION (KOFFS + (LO-LI+LDELMN)/2 ) IN THE S MATRIX:      
C                                                                       
C        (4*KOFFS-3) = LO - LI                                          
C        (4*KOFFS-2) = LX                                               
C        (4*KOFFS-1) = JP                                               
C        (4*KOFFS  ) = JT                                               
C                                                                       
C     "SMATR", "SMATI" WILL HOLD THE CALCULATED (NOT INTERPOLATED)      
C     REACTION S MATRIX.  FOR A GIVEN (LO, LX, JP, JT, LI), THE         
C     S MATRIX IS INDEXED AS                                            
C                                                                       
C        (LI-LMIN)*NSPLI/LSTEP + KOFFS + ( LO - LI - LDELMN )/2         
C                                                                       
C     WHERE KOFFS AND LDELMN ARE TAKED FROM "INDXS" AS DESCRIBED ABOVE. 
C                                                                       
C     FIRST PASS, ALLOCATE "INDXS" AND "TOCS" AND INITIALIZE POINTERS.  
C                                                                       
      IF ( IBSPAS .GT. 1 ) GO TO 1450                                   
C                                                                       
C     FIRST FIND INDXS SIZE                                             
C                                                                       
      ISIZE = 0                                                         
      IF ( COUPSW ) GO TO 1410                                          
      CALL SETSPT (ISIZE,LOC,1,JS(4),JS(2),PBUGSW,DUMMY,1,1) 
      GO TO 1420                                                        
C                                                                       
 1410 LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      NCHNDF = ILLOC(LCHNDF)                                            
      MCHNDF = ILLOC(LCHNDF+1)                                          
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2)                                 
      DO 1419 I = 2, NCHNDF                                             
      LCHNDF = LCHNDF + MCHNDF                                          
      ILLOC(LCHNDF+11) = ISIZE                                          
      CALL SETSPT (ISIZE,LOC,1,IABS(ILLOC(LCHNDF+1)),
     *IABS(ILLOC(LCHNDF+3)),PBUGSW,DUMMY,1,1)
 1419 CONTINUE                                                          
C                                                                       
C     DEFINE THE INDXS ARRAY                                            
C                                                                       
 1420 IINDXS = NALLOC((ISIZE+1)/FACFR4,'INDXS   ')                  
      CALL INIT4 ( IINDXS, 0 )                                          
      LINDXS = Z(IINDXS)*FACFR4 - FACFR4                                
C     NASPLI IS NSPLI SUMMED OVER ALL CHANNELS                          
      NASPLI = 0
C                                                                       
C     NOW FILL IN "INDXS" FOR ALL S-MATRIX ELEMENTS NEEDED ON THIS      
C     AND SUBSEQUENT PASSES.                                            
C                                                                       
      IF ( COUPSW ) GO TO 1430                                          
      CALL SETSPT (NASPLI,LINDXS,2,JS(4),JS(2),PBUGSW,DUMMY,1,1) 
      GO TO 1440                                                        
C                                                                       
 1430 LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2)                                 
      LBASDF = FACFR4*(Z(IBASDF)-1) + 1                                 
      MBASDF = ILLOC(LBASDF+1)                                          
      LBASDF = LBASDF + ILLOC(LBASDF+2)                                 
      DO 1439 I = 2, NCHNDF                                             
      LCHNDF = LCHNDF + MCHNDF                                          
      IB = ILLOC(LCHNDF+7)                                              
      NBASDF = ILLOC(LCHNDF+8)                                          
      ILLOC(LCHNDF+9) = NUMLIS*NASPLI                                   
      ILLOC(LCHNDF+12) = 4*NASPLI                                       
      CALL SETSPT (NASPLI,LINDXS+ILLOC(LCHNDF+11),2,IABS(ILLOC(LCHNDF
     *+1)),IABS(ILLOC(LCHNDF+3)),PBUGSW,ILLOC(LBASDF+MBASDF*(IB-1)), 
     *MBASDF,NBASDF)                                               
      ILLOC(LCHNDF+10) = NSPLI                                          
 1439 CONTINUE                                                          
C                                                                       
C     ALLOCATE AND INITIALIZE THE S-MATRIX AND ITS TABLE OF CONTENTS.   
C     DELTASR, DELTASI  ARE FOR S - S(BORN).  WE START OUT WITH         
C     THEM DEFINED AS THE FULL S-MATRIX ARRAYS.                         
C                                                                       
 1440 NSMAT = NASPLI*NUMLIS                                             
      ISMATR = NALLOC (NSMAT,'SMATR   ')                             
      ISMATI = NALLOC (NSMAT,'SMATI   ')                             
      IDELSR = ISMATR                                                   
      IDELSI = ISMATI                                                   
      ITOCS = NALLOC (4*NASPLI/FACFR4,'TOCS    ')                    
      CALL INIT8 ( ISMATR, 0.D0 )                                       
      CALL INIT8 ( ISMATI, 0.D0 )                                       
      CALL INIT4 ( ITOCS, -1 )                                          
      IF ( PROBLM .GE. 23 ) IELCUP = NALLOC( 2*NUMLIS, 'ELCOUPS' )      
C                                                                       
C                                                                       
C     ALL PASSES:  FILL IN "TOCS" FOR THOSE S-MATRIX ELEMENTS WHICH     
C     ARE USED ON THIS PASS.                                            
C                                                                       
 1450 LINDXS = Z(IINDXS)*FACFR4 - FACFR4                                
      LTOCS = Z(ITOCS)*FACFR4 - FACFR4                                  
      IF ( COUPSW ) GO TO 1460                                          
      CALL SETSPT (LTOCS,LINDXS,3,JS(4),JS(2),PBUGSW,DUMMY,1,1)
C                                                                       
C     THIS IS THE NUMBER OF (LO', LX') PAIRS PER LI IN THE INNER        
C     INTEGRATION LOOPS.  LX'S DUE ONLY TO SPIN-ORBIT DISTORTIONS       
C     ARE NOT INCLUDED.                                                 
C                                                                       
      NMLOLX =((LXMAX+LXMIN+1)*(LXMAX-LXMIN+1)+MOD(LXMIN+LBP+LBT+1,
     * 2) )/2                                                           
      GO TO 1500                                                        
C                                                                       
 1460 LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2)                                 
      DO 1469 I = 2, NCHNDF                                             
      LCHNDF = LCHNDF + MCHNDF                                          
      CALL SETSPT (LTOCS+ILLOC(LCHNDF+12),LINDXS+ILLOC(LCHNDF+11),3,
     *IABS(ILLOC(LCHNDF+1)),IABS(ILLOC(LCHNDF+3)),PBUGSW,DUMMY,1,1)
 1469 CONTINUE                                                          
C                                                                       
C     FOR C.C. WE USE NMLOLX = NASPLI                                   
C                                                                       
      NMLOLX = NASPLI                                                   
C                                                                       
C     STORAGE FOR THE H'S (TRANSFER ONLY)                               
C                                                                       
 1500 IHS = 0                                                           
      IHINT = 0                                                         
      IHABS = 0                                                         
      INLAM = 0                                                         
      IXLAM = 0                                                         
      IA12VL = 0                                                        
      IMSVAL = 0                                                        
      IJA12S = 0                                                        
      IA12TM = 0                                                        
      IF ( ISTRIP .EQ. 0 ) GO TO 1800                                   
      IA12TM = (3*NUMLX+1)/FACFR4                                       
      IF ( IHSAVE .EQ. 2 ) GO TO 1750                                   
C                                                                       
      IHS = NALLOC ( NMLOLX, 'H ' )                                     
      IHINT = NALLOC ( NMLOLX, 'HINTEGRL' )                             
      IHABS = NALLOC ( NMLOLX, 'HABSINT ' )                             
C                                                                       
C     ALLOCATE ARRAYS FOR  A12                                          
C                                                                       
      MSTOP = MAX0( LXMAX+LBP, LXMAX+LBT, LBP+LBT+1, 2*LXMAX )          
      MSTOP = 2*(MSTOP/2)                                               
      INEED = (MSTOP/2+1) * (LOMOST+1)                                  
      INLAM = NALLOC ( (LOMOST+1)/FACFR4+1, 'NLAMBDA ' )                
      IXLAM = NALLOC ( INEED, 'XLAMBDA ' )                              
C                                                                       
C     FOLLOWING IS AN UPPER LIMIT ON THE NUMBER OF TERMS IN THE         
C     A12 SUMS.                                                         
C     FIRST THE MAXIMUM NUMBER OF M1 AND M2                             
C     COMBINATIONS.  WE USE                                             
C        M1  <= (LBP, LX+LBT)    M2  <= (LBT, LX+LBP)                   
C        MX  <= (LX,LBP+LBT)   M1+LBP AND M2+LBT  EVEN                  
C                                                                       
      IA12M = (MIN0(LXMAX,LBP+LBT)+1) * (MIN0(LBP,LBT)+1)               
C                                                                       
C     THEN FOR EACH OF THE ABOVE MU TAKES ON VALUES SUCH THAT           
C       0 <= MU <= LO <= LOMOST,    MU+LO EVEN                          
C     AND WE HAVE  NMLOLX  SETS OF SUCH A12 VALUES.                     
C                                                                       
      IA12N = IA12M * (LOMOST/2+1) * NMLOLX                             
C                                                                       
C                                                                       
C     FOR EACH (M1, M2) PAIR WE HAVE UP TO FIVE ITEMS TO STORE          
C                                                                       
      IA12M = 5*IA12M                                                   
      IA12VL = NALLOC( IA12N, 'A12VALS ' )                              
      IMSVAL = NALLOC( IA12M, 'A12MSVAL' )                              
      IJA12S = NALLOC( (IA12M+1)/FACFR4, 'JA12S ' )                     
C                                                                       
C     FOLLOWING IS 3 ARRAYS; ONLY THE THIRD IS USED FOR USEHS RUNS.     
C     REAL*8   NUMLX                                                    
C     REAL*8   2*LXMAX+2                                                
C     INTEGER  3*NUMLX  ( WE TREAT AS REAL*8 TO ALLOW FOR CDC )         
C                                                                       
      IA12TM = 4*NUMLX + 2*LXMAX + 2                                    
 1750 IA12TM = NALLOC( IA12TM, 'A12TEMPS' )                             
C                                                                       
C     "IDWFI" WILL CONTAIN INFORMATION ABOUT THE INCIDENT               
C     SCATTERING WAVE FUNCTIONS, FOR A GIVEN LI:                        
C                                                                       
C        (3*K-2) = LASI - LI                                            
C        (3*K-1) = JPI - 2*LI  (MAX. VALUE IF NO S. O.)                 
C        (3*K  ) = INDEX TO BASE OF WF IN ALLOCATOR                     
C                                                                       
 1800 IWFII = NALLOC ( (3*NUMJS(1)+1)/FACFR4, 'IDWFI   ' )              
      LWFII = Z(IWFII)*FACFR4 - FACFR4                                  
      I = 0                                                             
      IF ( TCSWS(1) ) I = JSPS(1)                                       
      LASMIN = -I                                                       
      LASMAX = I                                                        
      NWFI = 0                                                          
C     THE OUTER LOOP IS OVER LAS = ASYMPTOTIC L (TENSOR ONLY).          
      DO 1819 LAS = LASMIN, LASMAX, 2                                   
C        THE INNER LOOP IS OVER JP = TOTAL PROJECTILE J                 
      JPMX = MIN0(2*LAS,0) + JSPS(1)                                    
      JPMN = JPMX                                                       
      IF ( SOSWS(1) ) JPMN = MAX0(2*LAS,0) - JSPS(1)                    
      DO 1809 JPI = JPMN, JPMX, 2                                       
      NWFI = NWFI + 1                                                   
      ILLOC(LWFII+3*NWFI-2) = LAS                                       
      ILLOC(LWFII+3*NWFI-1) = JPI                                       
      ILLOC(LWFII+3*NWFI) = (NWFI-1)*NRIROI                             
 1809 CONTINUE                                                          
 1819 CONTINUE                                                          
      I = 3*NWFI                                                        
      IF ( PBUGSW ) WRITE(6,1823)(ILLOC(LWFII+K), K = 1, I )            
 1823 FORMAT ( ' IDWFI', 3I10 )                                         
C                                                                       
      IF ( COUPSW ) GO TO 2100                                          
C                                                                       
C     "IDWFO" WILL CONTAIN INFORMATION ABOUT THE OUTGOING               
C     SCATTERING WAVE FUNCTIONS, FOR A GIVEN LI:                        
C                                                                       
C        (4*K-3) = LO - LI                                              
C        (4*K-2) = LASO - LI                                            
C        (4*K-1) = JPO - 2*LI                                           
C        (4*K  ) = INDEX TO BASE OF WF ARRAY (SET IN INELDC).           
C                                                                       
      I = 0                                                             
      IF ( ISTRIP .NE. 0 ) I = MOD ( LBP+LBT+LXMAX, 2 )                 
      NOFLO = LXMAX + 1 - I                                             
      IWFIO = NALLOC ( 4*NOFLO*NUMJS(2)/FACFR4, 'IDWFO   ' )            
      LWFIO = Z(IWFIO)*FACFR4 - FACFR4                                  
      LOMAX = NOFLO - 1                                                 
      LOMIN = -LOMAX                                                    
      LASR = 0                                                          
      IF ( TCSWS(2) ) LASR = JSPS(2)                                    
      NWFO = 0                                                          
      DO 1869 LO = LOMIN, LOMAX, 2                                      
      LASMIN = LO - LASR                                                
      LASMAX = LO + LASR                                                
      DO 1859 LAS = LASMIN, LASMAX, 2                                   
      JPMX = 2*MIN0(LO,LAS) + JSPS(2)                                   
      JPMN = JPMX                                                       
      IF ( SOSWS(2) ) JPMN = 2*MAX0(LO,LAS) - JSPS(2)                   
      DO 1849 JPO = JPMN, JPMX, 2                                       
C     ELIMINATE INITIAL JPO'S TOO LOW TO COUPLE TO LI.                  
      IF ( SOSWS(2) .AND. NWFO .EQ. 0 .AND. JPO+JSPS(1)+JBT .LT. 0 ) GO 
     *TO 1849                                                           
      NWFO = NWFO + 1                                                   
      ILLOC(LWFIO+4*NWFO-3) = LO                                        
      ILLOC(LWFIO+4*NWFO-2) = LAS                                       
      ILLOC(LWFIO+4*NWFO-1) = JPO                                       
 1849 CONTINUE                                                          
 1859 CONTINUE                                                          
 1869 CONTINUE                                                          
C     ELIMINATE FINAL JP'S TOO LARGE TO COUPLE TO LI.                   
      IF ( .NOT. SOSWS(2) ) GO TO 1900                                  
      I = NWFO                                                          
      DO 1879 K = 1, I                                                  
      IF ( ILLOC(LWFIO+4*NWFO-1) .LE. JSPS(1)+JBT ) GO TO 1890          
      NWFO = NWFO - 1                                                   
 1879 CONTINUE                                                          
 1890 IF ( NWFO .LT. NOFLO*NUMJS(2) )  CALL IREDEF ( 4*NWFO/FACFR4, IWFI
     *O )                                                               
 1900 I = 4*NWFO                                                        
      IF ( PBUGSW ) WRITE(6,1903)(ILLOC(LWFIO+K), K = 1, I )            
 1903 FORMAT ( ' IDWFO', 4I10 )                                         
C                                                                       
C     NOW ALLOCATE SPACE FOR THE WAVE FUNCTIONS (AT GAUSS POINTS)       
C                                                                       
      I = (NWFI*NRIROI+1)/FACFR4                                        
      ILIR = NALLOC ( I, 'WAVEAR  ' )                                   
      ILII = NALLOC ( I, 'WAVEAI  ' )                                   
      I = (NWFO*NRIROI+1)/FACFR4                                        
      ILOR = NALLOC ( I, 'WAVEBR  ' )                                   
      ILOI = NALLOC ( I, 'WAVEBI  ' )                                   
C     FOR TENSOR COUPLING, WAVETC NEEDS SOME SCRATCH STORAGE SPACE.     
      I = 4*NRIROI/FACFR4                                               
      DO 1909 K = 1, 2                                                  
      IF ( .NOT. TCSWS(K) ) GO TO 1909                                  
      IWAVRS(K) = NALLOC ( I, NAMER(K) )                                
      IWAVIS(K) = NALLOC ( I, NAMEI(K) )                                
 1909 CONTINUE                                                          
C     THIS POINTER CONTROLS WF STORAGE IN THE CIRCULAR BUFFER.          
      NCRIT = NWFO*NRIROI - NRIROI                                      
C                                                                       
C     "DW" WILL CONTAIN PRODUCTS OF SCATTERING WAVE FUNCTIONS.          
C     "INDXDW" WILL CONTAIN POINTERS USED TO CALCULATE AND USE "DW".    
C                                                                       
      IDW = NALLOC ( NWFI*NWFO*2, 'DW      ' )                          
      IDWI = NALLOC ( NWFI*NWFO*4/FACFR4, 'INDXDW  ' )                  
      GO TO 2200                                                        
C                                                                       
C     FOR C.C. THERE ARE NO OUTGOING WAVE ARRAYS BUT WE                 
C     STILL STORE INCOMING S SEPARATELY.                                
C                                                                       
 2100 LCHNDF = FACFR4*(Z(ICHNDF)-1)+1                                   
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2)                                 
      ILLOC(LCHNDF+9) = -1                                              
      ILLOC(LCHNDF+10) = NWFI                                           
      ILLOC(LCHNDF+11) = 0                                              
      ILLOC(LCHNDF+12) = 0                                              
C                                                                       
C     COMPUTE MAX NUMBER OF H'S THAT WILL EVER OCCUR.                   
C     THE SPACE PREVIOUSLY WASTED HAS BEEN ELIMINATED.                  
C                                                                       
 2200 NUMHS = NMLOLX                                                    
C                                                                       
      IF ( COUPSW ) GO TO 3000                                          
      I = NUMHS*NUMJS(1)*NUMJS(2)                                       
C                                                                       
C     "RIROABS" WILL CONTAIN INTEGRAL(RI,RO) ! INTEGRAL(X) INTEGRAND !, 
C     WHICH IS USED TO CHECK FOR EXCESSIVE ROUND-OFF ERRORS DUE TO      
C     CANCELLATIONS.                                                    
C                                                                       
      IABS1 = NALLOC ( I, 'RIROABS ' )                                  
C                                                                       
      IF ( ISTRIP .EQ. 0 ) GO TO 3000                                   
C                                                                       
C     "SUMHVALS" AND "SUMIVALS" ARE THE H'S (AFTER X INTEGRATION)       
C     BEFORE AND AFTER INTERPOLATION IN (RO+RI)/2, RESPECTIVELY.        
C                                                                       
      ISMHVL = NALLOC( NPSUM*NUMHS, 'SUMHVALS' )                        
      ISMIVL = NALLOC( NPSUMI*NUMHS, 'SUMIVALS' )                       
C                                                                       
C     "I1REAL" AND "I1IMAG" WILL CONTAIN THE FINAL 3-DIMENSIONAL        
C     INTEGRALS, FOR A FIXED VALUE OF LI.                               
C     "IINDEX" WILL CONTAIN POINTERS INTO H ("SUMIVAL") AND INTO        
C     "DW" (WF PRODUCTS) FOR EACH INTEGRAL.                             
C                                                                       
      ILILOR = NALLOC ( I, 'I1REAL  ' )                                 
      ILILOI = NALLOC ( I, 'I1IMAG  ' )                                 
      IIINDX = NALLOC ( 4*I/FACFR4, 'IINDEX  ' )                        
C                                                                       
      IF ( IHSAVE .EQ. 2 ) GO TO 3000                                   
C                                                                       
C     SETUP FOR HIGH SPEED COSINE                                       
C                                                                       
C     OUR ALGORITHM REQUIRES THAT THE SIZE OF THE TABLE BE A            
C     POWER OF TWO.  SO WE FORCE IT.                                    
C                                                                       
      I = DLOG( DFLOAT(NCOSIN) ) / DLOG(2.D0) + .5                      
      NCOSIN = 2**I                                                     
      DICOSS = NCOSIN                                                   
      COSSTP = 2*PI/DICOSS                                              
      ICOSS4 = NCOSIN/4                                                 
      STPINV = DICOSS/(2*PI)                                            
      MSKCOS = NCOSIN-1                                                 
      ICOSSP = NCOSIN+1                                                 
      ICOSIN = NALLOC( ICOSSP, 'COSINES ' )                             
      X = -COSSTP                                                       
      DO 2559 II = 1, ICOSSP                                            
      X = X + COSSTP                                                    
2559  ALLOC(Z(ICOSIN)+II-1)=DCOS(X)                                     
C                                                                       
C     WE USE A TABLE OF INTEGERS IN DOUBLE PRECISION FORM TO AVOID      
C     FREQUENT CONVERSIONS FROM I TO R .                                
C                                                                       
C     WE SET THAT TABLE UP HERE                                         
C                                                                       
      IMIN = MAX0 ( LOMOST, 2*(LBP+LBT)+20 )                            
      INTOFF = IMIN + 1                                                 
      IMAX = MAX0( IMIN, 2*LOMOST+2 )                                   
      IINTS = NALLOC( IMAX+IMIN+1, 'INTEGERS' )                         
      LINTS = Z(IINTS)-1+INTOFF                                         
      IMIN = -IMIN                                                      
      X = IMIN                                                          
      DO 2659 I = IMIN, IMAX                                            
      ALLOC(LINTS+I) = X                                                
      X = X + 1                                                         
 2659 CONTINUE                                                          
C                                                                       
 3000 IRTN = 1                                                          
C                                                                       
      RETURN                                                            
 9950 WRITE(6,9953)
 9953 FORMAT ( '0**** ERROR IN READING OR WRITING H  S FILE.' )         
      RETURN                                                            
      END                                                               
C----------------------------------------------------------------------
      SUBROUTINE AZCODE ( SIN, IZ, IA, SYMBOL, IRTN )                   
C----------------------------------------------------------------------
C DECODES STRING 'S' TO FIND Z,A,SYM:  EG: S=CA40 Z=20,A=40,SYM=CA      
C                                                                       
C  DESCRIPTION OF PARAMETERS:                                           
C   SIN R*8  STRING THAT CONTAINS ELEMENT SYMBOL AND ATOMIC WEIGHT.     
C            STRINGS OF THE FORM  'CA40'  OR  '40CA' ARE ACCEPTABLE.    
C   IZ  I*4  THE RETURNED VALUE OF Z                                    
C   IA  I*4  THE RETURNED VALUE OF A                                    
C SYMBOL I*2 IN TWO BYTES...THE ATOMIC SYMBOL THAT APPEARED IN STRING   
C                                                                       
C   ERROR CONDITIONS:                                                   
C   IRTN=0     NORMAL COMPLETION                                        
C   IRTN=-1    MEANS NO ATOMIC WEIGHT IN STRING...ONLY SYMBOL           
C   IRTN=-2    COULD NOT FIND SYMBOL AMONG KNOWN ELEMENTS               
C   IRTN=-3    THE FORM OF STRING WAS NOT  'CA40' OR '40CA'             
C            E.G.  IT MAY HAVE BEEN 40CA40  OR CA40CA                   
C                                                                       
C  NOTE: THE SYMBOL 'N' IS ACCEPTABLE EITHER FOR THE NEUTRON            
C     OR FOR NITROGEN.  NEUTRON IS ASSUMED WHEN A<=9                    
C                                                                       
C                                                                       
C     ***NOTE*** IF   IZ.NE.999 ON ENTRY...THE FOLLOWING SUBSTITUTIONS A
C                 ACCEPTED AS ONE BYTE STRINGS 'S':                     
C        G - GAMMA      RETURNS IZ=0 IA=0                               
C        N - NEUTRON -  RETURNS IZ=0 IA=1                               
C        P - PROTON  -  RETURNS IZ=1 IA=1                               
C        D - DEUTERON   RETURNS IZ=1 IA=2                               
C        T - TRITON  -  RETURNS IZ=1 IA=3                               
C        H - HELIUM-3   RETURNS IZ=2 IA=3                               
C        A - ALPHA      RETURNS IZ=2 IA=4                               
C                                                                       
C  THIS ROUTINE HAS A SEPARATE ENTRY: CODEZ                             
C     CALL CODEZ(IZ,SYMBOL)  RETURNS THE SYMBOL FOR ELEMENT Z=IZ        
C     IF IZ<0 OR IZ>104  SYMBOL=BLANK   SYMBOL,AS ABOVE, IS TWO BYTES   
C                                                                       
C     CODED BY F. SERDUKE                                               
C     5/8/75 - COMPILED FOR PTOLEMY;  ALLOW NP FOR N <= 9               
C     9/27/75 - FIX ERROR IN NP CASE.                                   
C     8/23/76 - CDC/IBM VERSION                                         
C     12/26/79 - STANDARD MORTRAN - RPG                                 
C     1/14/79 - INTEGER*2'S TO CHARACTER*2 - RPG                        
C     5/30/80 - REMOVE MULTIPLE COLONS FROM COMMENT - S.P.              
C     7/10/80 - CHR, CWD PREFIXES - S.P.                                
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
C                                                                       
C     DATA FOR SYMBOLS OF THE ELEMENTS                                  
      CHARACTER*2 ELEMNT(104)                                           
      DATA ELEMNT/'H ', 'HE', 'LI', 'BE', 'B ', 'C ', 'N ', 'O ', 'F ', 
     *'NE', 'NA', 'MG', 'AL', 'SI', 'P ', 'S ', 'CL', 'AR', 'K ', 'CA', 
     *'SC', 'TI', 'V ', 'CR', 'MN', 'FE', 'CO', 'NI', 'CU', 'ZN', 'GA', 
     *'GE', 'AS', 'SE', 'BR', 'KR', 'RB', 'SR', 'Y ', 'ZR', 'NB', 'MO', 
     *'TC', 'RU', 'RH', 'PD', 'AG', 'CD', 'IN', 'SN', 'SB', 'TE', 'I ', 
     *'XE', 'CS', 'BA', 'LA', 'CE', 'PR', 'ND', 'PM', 'SM', 'EU', 'GD', 
     *'TB', 'DY', 'HO', 'ER', 'TM', 'YB', 'LU', 'HF', 'TA', 'W ', 'RE', 
     *'OS', 'IR', 'PT', 'AU', 'HG', 'TL', 'PB', 'BI', 'PO', 'AT', 'RN', 
     *'FR', 'RA', 'AC', 'TH', 'PA', 'U ', 'NP', 'PU', 'AM', 'CM', 'BK', 
     *'CF', 'ES', 'FM', 'MD', 'NO', 'LW', 'XX'/                         
      CHARACTER*2 SYM, SYMBOL, AP, AN, BLANK2                           
      DATABLANK2/' '/                                                   
      DATAAN/'N'/                                                       
      DATAAP/'P'/                                                       
      CHARACTER*1 SYM1(2),S(8)                                          
      CHARACTER*1 BLNK1                                                 
      DATA BLNK1 / ' ' /                                                
      CHARACTER*1 SIN(8)                                                
CWD      INTEGER SIN                                                    
      INTEGER SVAL(5)                                                   
      CHARACTER*1 ZSYM(2)                                               
      EQUIVALENCE(SYM,SYM1(1))                                          
C --- DEFINE THE SPECIAL CASES OF ONE-BYTE STRINGS                      
      INTEGERNCASE                                                      
      DATA NCASE / 7 /                                                  
      CHARACTER*2 SCASE(7)                                              
      DATA SCASE/'G', 'N', 'P', 'D', 'T', 'H', 'A'/                     
      INTEGERIZSC (7)                                                   
      DATAIZSC/0,0,1,1,1,2,2/                                           
      INTEGERIASC (7)                                                   
      DATAIASC/0,1,1,2,3,3,4/                                           
C                                                                       
C                                                                       
C                                                                       
C  SET SYMBOL=BLANK...IDCODE IS NUMBER OF FIELDS DECODED..J POINTS      
C  TO THE CURRENT BYTE BEING DECODED                                    
      IDCODE=0                                                          
      IRTN = 0                                                          
      SYM1(2) = BLNK1                                                   
      SYM = BLANK2                                                      
      SYMBOL = BLANK2                                                   
      J=1                                                               
      DO 23 I = 1, 8                                                    
  23  S(I) = SIN(I)                                                     
CWD      DECODE ( 8, 23, SIN ) S                                        
CWD  23  FORMAT (8A1)                                                   
      DO 53 I = 1, 5                                                    
 53   SVAL(I) = ICHAR(S(I)) - 48                                        
C                                                                       
C -- LOOK AT FIRST BYTE...IF NUMERIC..STRING IS OF FORM '40CA'          
      IF ( SVAL(1).GE. 0 .AND. SVAL(1).LE. 9 ) GO TO 200                
C                                                                       
C -- J POINTS TO A NON-NUMERIC SYMBOL...                                
100   SYM1(1) = S(J)                                                    
CWD      SYM = S(J)                                                     
      J = J+1                                                           
C -- CHECK SPECIAL CASES ON G,N,P,D,T,H,A                               
      IF ( IDCODE.EQ.0 .AND. IZ.NE.999 .AND. S(J).EQ.BLNK1 ) GO TO 902  
C                                                                       
C -- CHECK NEXT CHARACTER..IF NUMERIC OR BLANK..END OF SYMBOL FIELD     
      IF ( SVAL(J).GE. 0 .AND. SVAL(J).LE. 9 .OR. S(J).EQ.BLNK1 )  GO TO
     * 110                                                              
C .......ELSE THIS IS A TWO CHARACTER SYMBOL                            
      SYM1(2) = S(J)                                                    
CWD      ENCODE ( 10, 23, SYM ) SYM1                                    
      J = J+1                                                           
C                                                                       
C .. NOW LOOK AT CHARACTER FOLLOWING SYMBOL....                         
110   IF ( IDCODE.EQ.0 .AND. (SVAL(J).LT. 0 .OR. SVAL(J).GT. 9) )  GO TO
     * 901                                                              
C                                                                       
C -- IF ELEMENT SYMBOL IS AT END..CHECK THAT NEXT CHAR IS BLANK..       
      IF ( IDCODE.EQ.1 .AND. S(J).NE.BLNK1 ) GO TO 9003                 
C                                                                       
C   NOW THE ELEMENT SYMBOL IS IN SYM...                                 
      IDCODE = IDCODE+1                                                 
C     ......IF BOTH FIELDS DECODED...GO FIND 'IZ'                       
      IF ( IDCODE.GE.2 ) GO TO 300                                      
C                                                                       
C -- DECODE ATOMIC MASS...J-TH CHARACTER IS GUARANTEED NUMERIC          
200   IA = SVAL(J)                                                      
210   J = J+1                                                           
C -- IF NEXT CHARACTER IS NUMERIC...PROCEED WITH 'IA' DECODE            
      IF ( SVAL(J).GE. 0 .AND. SVAL(J).LE. 9 ) GO TO 220                
C -- IF 2-ND FIELD AND NEXT CHAR IS BLANK...GO WRAP UP BY GETTING IZ    
      IF ( IDCODE.GE.1 .AND. S(J).EQ.BLNK1 ) GO TO 300                  
C -- IF 2-ND FIELD AND NEXT CHAR IS NON-NUMERIC...BUGGERED STRING       
      IF ( IDCODE.GE.1 .AND. (SVAL(J).LT. 0.OR.SVAL(J).GT. 9) )  GO TO 9
     *003                                                               
C --  FALL THRU MEANS WE ARE DONE WITH FIRST FIELD OF THE FORM '40CA'   
C     AND WE HAVE THE IA=40...NOW GO DECODE SYM                         
      IDCODE= IDCODE+1                                                  
      GO TO 100                                                         
C                                                                       
220   IA = 10*IA + SVAL(J)                                              
      GO TO 210                                                         
C                                                                       
C  HAVE SYM....GET ITS 'IZ'                                             
300   IZZ=0                                                             
      SYMBOL=SYM                                                        
C ... IF IT IS NP WITH N <= 9 THEN IT IS N PROTONS                      
      IF ( IA .LE. 9 .AND. SYM .EQ. AP ) GO TO 380                      
C ... IF SYM='N'...AND IA<=9...IT IS NEUTRON...ELSE NITROGEN            
      IF ( IA.LE.9 .AND. SYM.EQ.AN ) GO TO 390                          
C                                                                       
C .... LOOP ON ELEMNT TABLE TO GET Z OF SYM                             
      DO 310 IZZ=1,104                                                  
      IF ( SYM.EQ.ELEMNT(IZZ) ) GO TO 390                               
310   CONTINUE                                                          
C ---- FALL THRU MEANS SOME SNAFU...                                    
      GO TO 9002                                                        
C                                                                       
 380  IZ = IA                                                           
      RETURN                                                            
C                                                                       
390   IZ = IZZ                                                          
      RETURN                                                            
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
C    E N T R Y    F O R    C O D E Z:                                   
C   GIVEN  IZ,  IT RETURNS THE SYMBOL IN TWO BYTES                      
CDCC                                                                    
CDCC     WILL NOT FUNTION ON CDC BUT IS NOT USED BY PTOLEMY             
CDCC                                                                    
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
      ENTRY CODEZ(IZ,ZSYM)                                              
C                                                                       
      SYM = BLANK2                                                      
      IF ( IZ.LT.0 .OR. IZ.GT.104 ) GO TO 490                           
      SYM = AN                                                          
      IF ( IZ.EQ.0 ) GO TO 490                                          
      SYM = ELEMNT(IZ)                                                  
490   ZSYM(1) = SYM1(1)                                                 
      ZSYM(2) = SYM1(2)                                                 
      RETURN                                                            
C                                                                       
C -- ABNORMAL CONDITIONS                                                
901   IRTN = -1                                                         
C --- ONLY A SYMBOL WAS CODED...IZ IS RETURNED BUT IA=-1                
      GO TO 300                                                         
C -- HANDLE SPECIAL CASES HERE.....                                     
902   SYMBOL=SYM                                                        
      DO 909 N=1,NCASE                                                  
      IF ( SYM .EQ. SCASE(N) ) GO TO 911                                
909   CONTINUE                                                          
C --- IF NONE OF THESE...GO TO DECODE SYM WITH IA=-1 ON RETURN          
      GO TO 901                                                         
911   IA = IASC(N)                                                      
      IZ = IZSC(N)                                                      
      RETURN                                                            
C                                                                       
9002  IRTN = -2                                                         
      RETURN                                                            
9003  IRTN = -3                                                         
      RETURN                                                            
      END                                                               
      SUBROUTINE A12 ( LI, LXMIN, LXMAX, LMIN, LMAX, XLAM,  NLAM, A12VL,
     * DMSVAL, JA12S, JA12M, JA12N, JA12AN, IINDEX, IHMAX, LOMNMN, LOMXM
     *X,  DINTS, OUTTMP, XLOTMP, LXTMP, LHSM1, LA12VL, IPRINT, INIT,  IN
     *DXDW, NDW, NI, IDWFI, IDWFO )                                     
C                                                                       
C     COMPUTES THE ANGULAR MOMENTUM TRANSFORMATION FUNCTION A12.        
C                                                                       
C  THIS VERSION GOES WITH THE INELDC74. LARGE ARRAYS ARE USED AND       
C  CORE REQUIREMENTS ARE HIGH BUT IS FASTER THAT OLD VERSION            
C      THESE MODIFCATIONS  7/74    D.G.                                 
C     1/30/75 - M'S STORED IN REAL*8 ARRAY; USE DINTS; REMOVE UNUSED    
C               ARGUMENTS - S.P.                                        
C     3/8/75 - USE ONLY MU >= 0;  FACTOR OUT A 3-J - S.P.               
C     3/22/75 - SPLIT INTO (M,MM) AND MU SUMS; DON'T STORE ALL XLAMS    
C     3/27/75 - USE M' LOOP VARIABLE; M, M', MU IN ONE ARRAY;           
C               DECIDE WHICH INTERVAL TO HALVE.                         
C     4/6/75 - LI, LX LOOPS INTERNAL; LX, LBT, LBP NAMES                
C     4/23/75 - PBUGSW IN ARG LIST DUE TO NEW COMMONS                   
C     5/21/75 - DO ALL LI FOR GIVEN LO.                                 
C     5/30/75 - INTRODUCE (-)**LO TO GET SMOOTHER PHASES                
C     6/11/75 - USEHS                                                   
C     8/26/75 - SMALLER ILILOLX TABLE                                   
C     9/10/75 - FIX BUG FOR ODD L BOUNDSTATES                           
C     2/24/76 - SIGN CONVENTIONS AND NOTATION OF CHAPTER II OF MANUAL   
C     8/8/76 - USE IPRINT AND HAVE PMCHSW.                              
C     4/28/78 - INTERCHANGE LI AND LO - S.P.                            
C     6/30/78 - CHANGE IPRINT CONVENTION                                
C     3/6/79 - CHANGE TO S-MATRIX; CONSISTANT PICKUP AND STRIPING - S.P.
C     6/6/79 - ADD INDXDW-IDWFO, CHANGE IINDEX, USE MOD - RPG           
C     6/8/79 - STANDARD PREFIXES - RPG                                  
C     6/19/79 - REMOVE (-1)**LX FOR PICKUP - RPG                        
C     6/19/79 - INIT IN ARG LIST TO ALLOW NO OVERLAYS - S.P.            
C     7/21/79 - SOME DEVUG PRINT WHEN PRINT=50000 - RPG                 
C     10/6/80 - FIX TWO-YEAR OLD BUG FOR ONE ODD BOUND L - S.P.         
C     6/12/81 - FIX BUG FOR LBP,LBT < LMAX - S.P.                       
C                                                                       
C     COMPUTES THE ANGULAR FUNCTION A12(X) DEFINED AS PART OF GENERAL   
C     VECTOR TRANSFORM BY EQ.(II-41) OF THE PTOLEMY MANUAL.             
C                                                                       
C     IN THIS ROUTINE THE NON-X PART OF A12 IS COMPUTED AND IS STORED   
C     IN THE ARRAY A12VL.  THE CORRESPONDING INDICES  MP, MT AND MU ARE 
C     STORED IN ARRAYS ALSO.  JA12N WILL BE SET TO THE NUMBER OF A12    
C     TERMS.  JA12M WILL BE SET TO (THE NUMBER OF DIFFERENT MP, MT      
C     PAIRS)*5 - 4.                                                     
C     JA12AN IS SET TO THE NUMBER OF DIFFERENT (MP, MT, MU) TRIPLES.    
C     IHMAX IS SET TO THE MAXIMUM NUMBER OF (LO,LX) PAIRS FOR A         
C           GIVEN MP, MT, MU.                                           
C     (LOMNMN, LOMXMX) IS SET TO THE EXTREME RANGE OF LO FOR THIS LI.   
C          IF THERE IS NO RANGE THEN IMMEDIATE RETURN IS MADE           
C          WITH  LOMNMN > LOMXMX.                                       
C                                                                       
C     WE USE A SLIGHTLY DIFFERENT NOTATION HERE (SUBROUTINE = MANUAL):  
C        MP = MX - LITTLE M                                             
C        MT = LITTLE M                                                  
C        LO = LOUT                                                      
C                                                                       
C     THE INDEX (KA12M) OF THE DMSVAL AND JA12S ARRAYS GOES UP          
C     BY 5 FOR EACH PAIR OF (MT, MP).  THUS WE HAVE KA12M = 1, 6, ...   
C     FOR GIVEN KA12M THE FOLLOWING ARE STORED:                         
C       DMSVAL(KA12M)   = MT                                            
C       DMSVAL(KA12M+1) = MP                                            
C       DMSVAL(KA12M+2) = FIRST MU FOR THIS (MT,MP) - 2                 
C       JA12S(KA12M)   = OFFSET FROM FIRST H LOC TO CORRESPONDING       
C                        A12VAL.                                        
C       JA12S(KA12M+1) = NUMBER OF MU FOR THIS (MT,MP)                  
C       JA12S(KA12M+2) = FIRST IH LOCATION FOR THIS (MT,MP) AND EACH MU.
C       JA12S(KA12M+3) = NUMBER OF H'S FOR THIS (MP,MT) AND EACH MU.    
C                                                                       
C     THE IINDEX ARRAY WILL HAVE 4 ELEMENTS FOR EACH RADIAL INTEGRAL    
C     I(LX,JP,JT; LO,LASO,JPO; LI,LASI,JPI). FOR THIS LI.               
C        IINDEX(1,KI) = INDEX INTO H ARRAY                              
C           (INCL. BASE ADDRESS Z(ISMIVL), NOT IU).                     
C        IINDEX(2,KI) = INDEX INTO DW = FI*FO ARRAY                     
C           (EVEN, STARTS AT Z(IDW)+2).                                 
C        IINDEX(3,KI) = KDW = INDEX INTO "INDXDW" ARRAY                 
C           (1 <= KDW <= NDW).                                          
C        IINDEX(4,KI) = LX                                              
C     WHERE KI = INDEX INTO I ("I1REAL", "I1IMAG") ARRAYS.              
C     ALSO, NI = THE MAXIMUM VALUE OF II IS RETURNED.                   
C                                                                       
C     THE INDXDW ARRAY WILL HAVE 4 ELEMENTS FOR EACH DW = JI*FO,        
C     I. E. EACH PRODUCT OF INCIDENT AND OUTCOING DISTORTED WAVES.      
C        INDXDW(1,KDW) = KWI = POINTER INTO ARRAY WFINDXI.              
C        INDXDW(2,KDW) = KWO = POINTER INTO ARRAY WFINDXO.              
C        INDXDW(3,KDW) = INDEX TO BASE OF INCIDENT WF IN ARRAYS WAVEAR/I
C        INDXDW(4,KDW) = INDEX TO BASE OF OUTGOING WF IN ARRAYS WAVEBR/I
C     WHERE KDW = INDEX INTO ARRAY "DW".                                
C     ALSO, NDW = THE MAXIMUM VALUE OF KDW IS RETURNED.                 
C                                                                       
C     THE IDWFI AND IDWFO ARRAYS ARE INPUT TO A12, WHICH MUST CONTAIN   
C     INFORMATION ABOUT THE STORED INCIDENT AND OUTGOING WAVE           
C     FUNCTIONS RESPECTIVELY:                                           
C        IDWFI(1,KWI) = LASI - LI.                                      
C        IDWFI(2,KWI) = JPI - 2*LI  (MAX. VALUE IF NO S. O.).           
C        IDWFE(3,KWI) = INDEX TO BASE OF WF IN ARRAYS WAVEAR/I.         
C        IDWFO(1,KWO) = LO - LI.                                        
C        IDWFO(2,KWO) = LASO - LI.                                      
C        IDWFO(3,KWO) = JPO - 2*LI  (MAX. VALUE IF NO S. O.).           
C        IDWFO(4,KWO) = INDEX TO BASE OF WF IN ARRAYS WAVEBR/I.         
C                                                                       
C     IF A USEHS IS IN EFFECT, THEN ONLY THE LI, LX LIMITS AND INDICES  
C     ARE COMPUTED.                                                     
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL XLAM,NLAM,A12VL,DMSVAL,JA12S,IINDEX,DINTS,OUTTMP,   
CDC     1  XLOTMP,LXTMP,INDXDW,IDWFI,IDWFO                              
C                                                                       
      DIMENSION XLAM(1), NLAM(1), JA12S(1), IINDEX(4,1), OUTTMP(1),  XLO
     *TMP(1), LXTMP(1), INDXDW(4,1), IDWFI(3,1), IDWFO(4,1),  DMSVAL(1),
     * A12VL(1), DINTS(1)                                               
C                                                                       
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      REAL*8 JACOB                                                      
      COMMON /GRIDCM/ JACOB, STPINV, COSSTP, IMSVAL, IINTS, INTOFF, IA12
     *VL, ICOSIN, IPHIT, IPHIP, IPHI, LOGIC, LOCTRP, IRI, IRO, ILOR, ILO
     *I, ILIR, ILII, IWIO, NOFLO, NRIROI, NCRIT, IXLAM, INLAM, IA12N, MS
     *KCOS, MAXCNT, ISMHPT, ISMIPT, ICOSS4, IJA12S, IHS, IIINDX, IA12TM,
     * IDW, IHINT, IHABS, IABS1, IGRDC1, NPSUMI, RVRLIM, ISMHWK, ISMHVL,
     * ISMIVL, IRIOEX, NUMHS, IGRDC2(4), IWFII, IWFIO, NWFI, NWFO, IDWI 
      COMMON /FORMF/ IBDS(2), NPOTS(2), LBP, LBT, NBP, NBT, JBP, JBT, BN
     *DMAX(2), BNDSTP(2), NSTPBD(2), RBNDS(2), ABNDS(2), RCBNDS(2), BNDM
     *AS(2), BRATMS(2), RSOBDS(2), ASOBDS(2), VBNDS(2), VSOBDS(2), TAUBD
     *S(2), LNKADB(6,2,12)                                              
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
C                                                                       
      COMMON /INELCM/ I6SP(6), MSTOP, IA12M, NMLOLX                     
C                                                                       
      LOGICAL FRSTSW, HALFSW, LBUGSW, PMCHSW, MBUGSW                    
C                                                                       
      IF(INIT.NE.5) GO TO 500                                           
C                                                                       
      I = MOD(IPRINT/10 000 , 10)                                       
      LBUGSW = I .GE. 4 .OR. MOD(IPRINT, 10) .GE. 4                     
      MBUGSW = I .GE. 5                                                 
      PMCHSW = I .GE. 6                                                 
C                                                                       
C     IF LBT OR LBP IS ODD, WE HALVE THAT INTERVAL; ELSE WE HALVE THE   
C     LO INTERVAL.                                                      
C                                                                       
      HALFSW = .FALSE.                                                  
      MTMIN = -LBT                                                      
      MPMIN = -LBP                                                      
      IF ( MOD(LBT,2) .EQ. 0 ) GO TO 20                                 
C                                                                       
C     HALVE MT                                                          
C                                                                       
      HALFSW = .TRUE.                                                   
      MTMIN = 1                                                         
      GO TO 50                                                          
C                                                                       
 20   IF ( MOD(LBP,2) .EQ. 0 ) GO TO 50                                 
      HALFSW = .TRUE.                                                   
      MPMIN = 1                                                         
C                                                                       
 50   ICO=1                                                             
      LOMOST = LMAX + MAX0( LXMAX, LBP, LBT )                           
C                                                                       
      IF ( IHSAVE .EQ. 2 ) GO TO 500                                    
C                                                                       
      NLAM(1)=1                                                         
      XLAM(1)=1.D0                                                      
      M = 0                                                             
      OUTTER = 1                                                        
      IF ( LOMOST .EQ. 0 ) GO TO 200                                    
C                                                                       
C     IF WE HALVE THE MT OR MP INTERVAL, WE WILL NEED LAMBDA(L,L-M)     
C     WHILE IF WE HALVE LO INTERVAL WE NEED LAMBDA(L,M) WHERE IN BOTH   
C     CASES   M <= MSTOP.  WE GENERATE THESE HERE AND BIAS NLAM(L+1)    
C     SUCH THAT  XLAM(NLAM(L+1)+M/2) ALWAYS WORKS.                      
C                                                                       
      IF ( MBUGSW ) WRITE(6,53) LBT,LBP,LO,LXMIN,LXMAX,LMIN,LMAX,L
     *OMOST, MTMIN, MPMIN, MSTOP, IA12M, NMLOLX, HALFSW                 
 53   FORMAT ( ' START', 13I8, L5 )                                     
      IF ( HALFSW ) GO TO 160                                           
C                                                                       
      DO 149 LL = 1, LOMOST                                             
      M = 1-M                                                           
      OUTTER = OUTTER* DSQRT( DINTS(LL+M-1)/DINTS(LL+M) )               
      IF ( M .EQ. 1 ) OUTTER = -OUTTER                                  
      ICO = ICO + 1                                                     
      NLAM(LL+1) = ICO                                                  
      XLAM(ICO) = OUTTER                                                
      MU = MIN0( MSTOP, LL )                                            
      MMTMIN = M+2                                                      
      IF ( MMTMIN .GT. MU ) GO TO 149                                   
      DO 139 MM = MMTMIN, MU, 2                                         
      ICO = ICO + 1                                                     
      XLAM(ICO) = -XLAM(ICO-1) *  DSQRT( DINTS(LL-MM+2)*DINTS(LL+MM-1) /
     *  (DINTS(LL+MM)*DINTS(LL-MM+1)) )                                 
      IF ( MBUGSW ) WRITE(6,57) ICO,LL,M,MU,MM,NLAM(LO+1),XLAM(ICO)
     *, DINTS(LL+MM), DINTS(LL-MM+1)                                    
 57   FORMAT ( ' XLAM', 6I8, 3G15.5 )                                   
 139  CONTINUE                                                          
 149  CONTINUE                                                          
      GO TO 200                                                         
C                                                                       
C     HERE GENERATE  LAMBDA( L, L-M )                                   
C                                                                       
 160  DO 189 LL = 1, LOMOST                                             
      OUTTER = -DSQRT( DINTS(2*LL-1)/DINTS(2*LL) ) * OUTTER             
      LLEVEN = LL - MOD(LL, 2)                                          
      MLOW = MIN0( MSTOP, LLEVEN )                                      
      NUM = MLOW/2 + 1                                                  
      ICO = ICO + NUM                                                   
      XLAM(ICO) = OUTTER                                                
      NLAM(LL+1) = ICO-LL/2                                             
      IF ( NUM .EQ. 1 ) GO TO 189                                       
      MM = LL                                                           
      ICOO = ICO                                                        
      DO 169 I = 2, NUM                                                 
      MM = MM - 2                                                       
      ICOO = ICOO - 1                                                   
      XLAM(ICOO) = -XLAM(ICOO+1) * DSQRT( DINTS(LL-MM-1)  *DINTS(LL+MM+2
     *) / (DINTS(LL-MM)*DINTS(LL+MM+1)) )                               
 169  CONTINUE                                                          
 189  CONTINUE                                                          
C                                                                       
 200  INIT=0                                                            
      LLBT = 2*LBT                                                      
      LLBP = 2*LBP                                                      

C                                                                       
C                                                                       
 500  LLI=2*LI                                                          
      IF ( IHSAVE .EQ. 2 ) GO TO 510                                    
C                                                                       
      XN=DINTS(LLI+1)*DINTS(LLBT+1)*DINTS(LLBP+1)                       
      XN=.5*DSQRT(XN)                                                   
C                                                                       
C     FOR INTERNAL A12 USE WE STORE FOR EACH LX:                        
C     1)  INDEX TO THE H ARRAY OF FIRST ELEMENT FOR THIS LX             
C     2)  LOMIN FOR LX                                                  
C     3)  LOMAX FOR LX.                                                 
C     ALSO THE MINIMUM AND MAXIMUM LO OVER ALL LX  ARE FOUND ( LOMNMN,  
C     LOMXMX).                                                          
C                                                                       
 510  LOMNMN = LI+500                                                   
      IH = 0                                                            
      IX = 0                                                            
      DO 559 LX = LXMIN, LXMAX                                          
      LOMIN = IABS(LI-LX)                                               
      LOMAX = LI+LX                                                     
      LOMIN = LOMIN + MOD( LBT+LBP+LI+LOMIN, 2 )                        
      LOMAX = LOMAX - MOD( LBT+LBP+LI+LOMAX, 2 )                        
      LXTMP(IX+1) = IH+1                                                
      LXTMP(IX+2) = LOMIN                                               
      LXTMP(IX+3) = LOMAX                                               
      IX = IX + 3                                                       
      LOMNMN = MIN0( LOMIN, LOMNMN )                                    
      IF ( LOMIN .GT. LOMAX ) GO TO 559                                 
      IH = IH + (LOMAX-LOMIN)/2 + 1                                     
 559  CONTINUE                                                          
C                                                                       
      IHMAX = IH                                                        
      LOMXMX = LOMAX                                                    
C                                                                       
C     LOOP THROUGH ALL COMBINATIONS OF INCIDENT AND OUTGOING            
C     DISTORTED WAVES.  FOR EACH PAIR THAT CAN BE                       
C     COUPLED, STORE POINTERS IN ARRAY INDXDW.                          
C                                                                       
      NDW = 0                                                           
      JPOMIN = MAX0 ( 0, 2*LI-JSPS(1)-JBT)                              
      DO 659 KWI = 1, NWFI                                              
      LASI = IDWFI(1,KWI) + LI                                          
      IF ( LASI .LT. LMIN .OR. LASI .GT. LMAX ) GO TO 659               
      JPI = IDWFI(2,KWI) + 2*LI                                         
      IF ( JPI .LT. IABS(2*LI-JSPS(1)) ) GO TO 659                      
      JPOMAX = JPI + JBT                                                
      IF ( SOSWS(1) ) JPOMIN = IABS(JPI-JBT)                            
      DO 649 KWO = 1, NWFO                                              
      LO = IDWFO(2,KWO) + LI                                            
      IF ( LO .LT. LOMNMN ) GO TO 649                                   
      IF ( .NOT. SOSWS(2) ) GO TO 620                                   
      LASO = IDWFO(2,KWO) + LI                                          
      IF ( LASO .LT. 0 ) GO TO 649                                      
      JPO = IDWFO(3,KWO) + 2*LI                                         
      IF ( JPO .LT. IABS(2*LO-JSPS(2)) ) GO TO 649                      
      IF ( JPO .LT. JPOMIN .OR. JPO .GT. JPOMAX ) GO TO 649             
      GO TO 630                                                         
 620  IF ( 2*LO+JSPS(2) .LT. JPOMIN .OR. 2*LO-JSPS(2) .GT. JPOMAX ) GO T
     *O 649                                                             
C           WEEDING IS DONE, STORE POINTERS.                            
 630  NDW = NDW + 1                                                     
      INDXDW(1,NDW) = KWI                                               
      INDXDW(2,NDW) = KWO                                               
      INDXDW(3,NDW) = IDWFI(3,KWI)                                      
      INDXDW(4,NDW) = IDWFO(4,KWO)                                      
      IF ( MBUGSW ) WRITE(6,643) NDW,(INDXDW(I,NDW), I = 1, 4 )         
 643  FORMAT ( ' INDXDW', 5I8 )                                         
 649  CONTINUE                                                          
 659  CONTINUE                                                          
C                                                                       
C     IN IINDEX WE STORE POINTERS INTO THE H ("SUMIVAL") AND            
C     FI*FO ("DW") ARRAYS FOR EACH RADIAL INTEGRAL.                     
C                                                                       
      NI = 0                                                            
      IX = 0                                                            
      DO 759 LX = LXMIN, LXMAX                                          
      IH = LXTMP(IX+1) - 1                                              
      LOMIN = LXTMP(IX+2)                                               
      LOMAX = LXTMP(IX+3)                                               
      IX = IX + 3                                                       
      DO 749 KDW = 1, NDW                                               
      KWO = INDXDW(2,KDW)                                               
      LO = IDWFO(1,KWO) + LI                                            
      IF ( LO .LT. LOMIN .OR. LO .GT. LOMAX ) GO TO 749                 
      NI = NI + 1                                                       
      IINDEX(1,NI) = Z(ISMIVL) - 1 + ( IH + (LO-LOMIN)/2 )*NPSUMI       
      IINDEX(2,NI) = Z(IDW) - 1 + 2*KDW                                 
      IINDEX(3,NI) = KDW                                                
      IINDEX(4,NI) = LX                                                 
      IF ( MBUGSW ) WRITE(6,743) NI,( IINDEX(I,NI), I = 1, 4 )           
 743  FORMAT ( ' IINDEX', 5I8 )                                         
 749  CONTINUE                                                          
 759  CONTINUE                                                          
C                                                                       
      IF ( IHSAVE .EQ. 2 ) RETURN                                       
C                                                                       
      IZERCT = 0                                                        
C                                                                       
C     PREPARE FOR THE TRIPLE SUM ON  MP, MT, MU                         
C                                                                       
      MUSTRT = MOD( LI, 2 )                                             
      IF (HALFSW) MUSTRT = -LI                                          
C                                                                       
      JA12M = -4                                                        
      JA12N=0                                                           
      JA12AN = 0                                                        
      TEMPS=10.0D0                                                      
      TEMPL=0                                                           
      TEMPC=0                                                           
C                                                                       
      IF ( LOMNMN .GT. LOMXMX ) RETURN                                  
C                                                                       
      DO 899 MP = MPMIN, LBP, 2                                         
C                                                                       
      DO 859 MT = MTMIN, LBT, 2                                         
C                                                                       
      MX = MT+MP                                                        
      IF ( IABS(MX) .GT. LXMAX ) GO TO 859                              
      ILAMLT=NLAM(LBT+1)+IABS(MT)/2                                     
      ILAMLP=NLAM(LBP+1)+IABS(MP)/2                                     
      IP3 = 0                                                           
      IP4 = 0                                                           
      IF(MT.LT.0) IP3 = LBT                                             
      IF(MP.LT.0) IP4 = LBP                                             
C                                                                       
C     SETUP THE A12 FACTORS THAT DEPEND ONLY ON MT, MP, LX, MX.         
C     IF ALL ARE ZERO, SKIP THIS (MT,MP) PAIR.                          
C                                                                       
      FRSTSW = .FALSE.                                                  
      DO 329 LX = LXMIN, LXMAX                                          
      OUTTER = XLAM(ILAMLT)*XLAM(ILAMLP)*XN*  THREEJ( LLBT, LLBP, 2*LX, 
     *2*MT, 2*MP, -2*MX )                                               
      OUTTMP(LX-LXMIN+1) = OUTTER                                       
      IF ( OUTTER .NE. 0 ) FRSTSW = .TRUE.                              
      IF ( PMCHSW ) WRITE(6,323) MP,MT,LX,ILAMLT,ILAMLP,XLAM(ILAMLT)
     *, XLAM(ILAMLP), OUTTER                                            
 323  FORMAT ( ' OUTTMP', 5I8, 3G15.5 )                                 
 329  CONTINUE                                                          
      IF ( .NOT. FRSTSW ) GO TO 859                                     
C                                                                       
      FRSTSW = .TRUE.                                                   
      DO 799 MU = MUSTRT, LI, 2                                         
C                                                                       
      MUPOS=IABS(MX-MU)                                                 
      IF(MUPOS.GT.LOMXMX) GO TO 799                                     
C                                                                       
      IF ( .NOT. FRSTSW ) GO TO 340                                     
C                                                                       
C     FIRST VALID MU, MX-MU.  GET LAMBDA FROM TABLE                     
C                                                                       
      DO 339 LO = LOMNMN, LOMXMX                                        
      XLOTMP(LO-LOMNMN+1) = 0                                           
 339  CONTINUE                                                          
C                                                                       
 340  LOSTRT = MAX0( LOMNMN, MUPOS )                                    
C                                                                       
C     FIND THE A12 TERMS DEPENDANT ON LO, LI, AND MU BUT NOT LX.        
C                                                                       
      DO 359 LO = LOMNMN, LOMXMX, 2                                     
      OUTTER = 0                                                        
      IF ( LO .LT. LOSTRT ) GO TO 355                                   
      OUTTER = XLOTMP(LO-LOMNMN+1)                                      
      IF ( OUTTER .NE. 0 ) GO TO 350                                    
C                                                                       
C     FIRST MU VALID FOR THIS LO, LI - USE TABLE TO GET INITIAL         
C     LAMBDA'S.                                                         
C     ALSO SET UP THE SIGN DUE TO ANY NEGATIVE M'S IN THE LOT           
C     AS MU IS SUBSIQUENTLY INCREASED, (-1)**((...+MU+...+MX-MU)/2)     
C     DOES NOT CHANGE.                                                  
C                                                                       
      IP1 = 0                                                           
      IP2 = 0                                                           
      IF ( MU .LT. 0 ) IP1 = LI                                         
      IF((MX-MU).LT.0) IP2 = LOMNMN                                     
      ITES = IP4+IP3+IP2+IP1                                            
CDC                  ITES = ITES + 2                                    
      OUTTER = XLAM(NLAM(LI+1)+IABS(MU)/2) *  XLAM(NLAM(LO+1)+MUPOS/2) *
     *  DSQRT(DINTS(2*LO+1))                                            
      IF ( MOD(ITES, 2) .NE. 0 ) OUTTER = -OUTTER                       
      GO TO 355                                                         
C                                                                       
C     ON SUCCESIVE MU'S, ITERATE TO NEW LAMBDA'S                        
C     AGAIN WE ARE BUILDING THAT PART OF A12 THAT IS INDEPENDANT OF     
C     LX.                                                               
C                                                                       
 350  OUTTER = OUTTER * DSQRT( DINTS(LI-MU+2)  *DINTS(LI+MU-1)*DINTS(LO-
     *MX+MU-1)  *DINTS(LO+MX-MU+2) / (DINTS(LI+MU)  *DINTS(LI-MU+1)*DINT
     *S(LO-MX+MU)*DINTS(LO+MX-MU+1)) )                                  
 355  XLOTMP(LO-LOMNMN+1) = OUTTER                                      
      IF ( PMCHSW ) WRITE(6,358) MP,MT,MU,LI,LO,LOSTRT,XLAM(NLAM(LO
     *+1)+IABS(MU)/2),  DINTS(LO-MU+2), OUTTER                          
 358  FORMAT ( ' OUTTER', 6I8, 3G15.5 )                                 
 359  CONTINUE                                                          
C                                                                       
      LXONE = MAX0( IABS(MX), LXMIN )                                   
      JA12ON = JA12N+1                                                  
      DO 499 LX = LXONE, LXMAX                                          
      LOMIN = LXTMP(3*(LX-LXMIN)+2)                                     
      LOMAX = LXTMP(3*(LX-LXMIN)+3)                                     
      IF ( LOMIN .GT. LOMAX ) GO TO 499                                 
      DO 489 LO = LOMIN, LOMAX, 2                                       
      TTT = THREEJ(LLI, 2*LO, 2*LX, 2*MU, 2*(MX-MU),  -2*MX )           
      TEMP = XLOTMP(LO-LOMNMN+1)*OUTTMP(LX-LXMIN+1)*  TTT               
      IF ( PMCHSW ) WRITE(6,483) MP,MT,MU,LX,LO,LOMNMN,LXMIN,XLOTM
     *P(LO-LOMNMN+1), OUTTMP(LX-LXMIN+1), TTT, TEMP                     
 483  FORMAT ( ' ANSWER', 7I8, 4G15.5 )                                 
C                                                                       
      IF ( TEMP .EQ. 0 ) IZERCT = IZERCT+1                              
      IF(DABS(TEMP).GT.TEMPL)TEMPL=DABS(TEMP)                           
      IF(DABS(TEMP).LT.TEMPS.AND.DABS(TEMP).NE.0)  TEMPS = DABS(TEMP)   
      IF ( HALFSW .OR. MU .NE. 0 ) TEMP = TEMP+TEMP                     
      TEMPC=TEMPC+DABS(TEMP)                                            
      JA12N=JA12N+1                                                     
      A12VL(JA12N) = TEMP                                               
 489  CONTINUE                                                          
 499  CONTINUE                                                          
      MULAST = MU                                                       
      IF ( .NOT. FRSTSW ) GO TO 799                                     
      FRSTSW = .FALSE.                                                  
C                                                                       
C     FOR FIRST MU OF THIS (M,MM) PAIR, STORE STUFF                     
C                                                                       
      MUONE = MU                                                        
      JA12M = JA12M+5                                                   
      DMSVAL(JA12M) = DINTS(MT)                                         
      DMSVAL(JA12M+1) = DINTS(MP)                                       
      DMSVAL(JA12M+2) = DINTS(MU) - 2                                   
      JA12S(JA12M+2) = LXTMP(3*(LXONE-LXMIN)+1) + LHSM1                 
      JA12S(JA12M) = LA12VL+JA12ON-JA12S(JA12M+2)                       
      JA12S(JA12M+3) = IHMAX - LXTMP(3*(LXONE-LXMIN)+1) + 1             
C                                                                       
  799 CONTINUE                                                          
      IF ( .NOT. FRSTSW ) JA12S(JA12M+1) = (MULAST-MUONE)/2+1           
      IF ( .NOT. FRSTSW ) JA12AN = JA12AN + JA12S(JA12M+1)              
      IEND = JA12M+3                                                    
      IF ( PMCHSW ) WRITE(6,793) MUONE,JA12M,JA12AN,(DMSVAL(III),III
     * = JA12M, IEND ),  ( JA12S(III), III = JA12M, IEND )              
 793  FORMAT ( ' MS,JA', 3I5 / (T10, 4I15 ))                            
  859 CONTINUE                                                          
  899 CONTINUE                                                          
C                                                                       
C     NOTE:  THE FOLLOWING "AVERAGE" IS THE AVERAGE TERM AND NOT        
C            THE AVERAGE A12 VALUE (I.E. JA12N IS NOT A WEIGHTED        
C           DIVISOR).                                                   
C                                                                       
      TEMPC=TEMPC/JA12N                                                 
      IF (LBUGSW) WRITE(6, 933) LI, LOMNMN, LOMXMX, IHMAX, JA12M,  JA12A
     *N, JA12N, IZERCT, TEMPS, TEMPL, TEMPC                             
 933  FORMAT(' LI, LOMNMN, LOMXMX, IHMAX, JA12M, JA12AN, JA12N:', 5I4,  
     *2I8 /  ' NUM OF ZEROS; SMALLEST, LARGEST AND ',  'AVERAGE A12VAL:'
     *, I6, 3G15.5 )                                                    
      RETURN                                                            
      END                                                               
      SUBROUTINE BASCPL(IRET)                                           
C                                                                       
C     CONSTRUCTS BASIS COUPLING ARRAY                                   
C                                                                       
C     THIS SUBROUTINE SELECTS FROM INPUT DATA                           
C     ALL POSSIBLE POTENTIAL TERMS AND STORES THEM IN Z(IBASCP)         
C                                                                       
C     WE ASSUME USUAL PREFACE CONSTRUCTION                              
C     THE ARRAY HAS THE FORM                                            
C     +0 EQUATION NO. CORRESPONDING TO CHANNEL BEING COUPLED            
C     +1 EQUATION NO. COUPLED TO +0                                     
C     +2 ORDER OF COUPLING                                              
C     +3 TOTAL MULTIPOLE OF COUPLING FOR ORDER IN +2                    
C     +4 NUCLEAR;RADIAL INDEPENDANT COUPLING TERM                       
C     +5 COULOMB;RADIAL INDEPENDANT COUPLING TERM                       
C     +6 LABEL FOR TERM I**(L2-L1)   WE STORE                           
C        IFAC FOR I**(L2-L1)                                            
C         -2         -I                                                 
C         -1         -1                                                 
C         +1         +1                                                 
C         +2         +I                                                 
C        (ONLY AN ENGLISHMAN COULD THINK OF THIS)                       
C     +7 TOTAL J, ORBITAL ANGULAR MOMENTUM AND K DEPENDANT              
C       "KINEMATIC" FACTOR.  THIS FACTOR IS INDEPENDANT OF THE          
C        NUCLEAR MODEL USED TO DESCRIBE THE COUPLING.  THE FACTOR IS    
C        STORED BY COUPLN AS EACH VALUE OF THE TOTAL J IS PROCESSED.    
C        HERE WE STORE AN INDICATOR FOR INGRST AS FOLLOWS               
C           1 - 1ST DERIVATIVE                                          
C           2 - 2ND DERIVATIVE                                          
C           M+3 - DEFORMED PROJECTILE                                   
C           M+4 - DEFORMED TARGET                                       
C           M+5 - DEFORMED MUTUAL                                       
C        WHERE   M = 10000*LXT + 100*LXP                                
C     +8 POINTER TO BINDEX (NEG IF FLIPPED CHANNELS)  (SET BY COULST)   
C     +9 POINTER TO NUCLEAR COUPLING POTENTIAL    (SET BY INGRST)       
C     +10 POINTER TO COULOMB COUPLING POTENTIAL  (SET BY INGRST)        
C     + 9 AND + 10 CALCULATED IN INGRST                                 
C                                                                       
C     12/79 - FIRST VERSION - MRB                                       
C     1/16/80 - USE CCBLK - S.P.                                        
C     28/1/80 INTRODUCE TEMPORARY COUPLING TYPE IN +7                   
C          FOR RHS CALCULATION IN INGRST.FORT                           
C     7/2/80 - COMMENTS, IMPROVE DIAGNOSTICS - S.P.                     
C     7/3/80 - PRINT HEADER FOR BE, Q, GATHER LXTOP,                    
C              WHEN BETA IS DEFINED AND SEVERAL LX POSSIBLE,            
C              PRINT MSG AND USE ONLY FIRST - S.P.                      
C     7/7/80 - CONVERT BE TO BETA IN TRANS ARRAY, PASS LTRANS AS REAL   
C              START OF TRANS ARRAY, PASS  DEBUG PRINTOUT - S.P.        
C     7/8/80 - PASS E*'S TO POTRHS, COMBINE IRTN AND IET - S.P.         
C     9/11/80 - FIX BUG I INTRODUCED IN 2ND ORDER - S.P.                
C     9/16/80 - DO NOT STORE XN=XC=0; DO NOT ALLOW L1+L2+LAM ODD;       
C               STORE THE I**(L2-L1) FACTOR - S.P.                      
C     9/19/80 - NO LAMBDA=0 FOR 2ND ORDER AT ONE VERTEX; FIX            
C              IN CHOOSING LOWEST MULTIPOLE; MOVE TESTS FROM            
C              PORTRHS TO HERE - S.P.                                   
C     10/2/80 - MASSIVE REARRANGEMENT - S.P.                            
C     12/8/80 - PRINT R.M.E. - S.P.                                     
C     12/10/80 - USE K-QUANTUM NUMBERS - S.P.                           
C     1/8/81 - REVISED 2ND ORDER; CUPSPN, CUPAB CALLS - S.P.            
C     1/25/80 - SCALE FACTORS - S.P.                                    
C     7/9/81 - FIX BUG IN SPECIFIED LX FOR 2ND ORDER COULOMB - S.P.     
C     8/25/81 - MODIFED INGRST INDICATOR; ALLOW UNDEFINED BETAS - S.P.  
C     9/18/81 - DEFINE LOG(FACTORIAL) TABLE - S.P.                      
C     10/13/81 - ALLOW TOTAL LAMBDA=0 AT ONE VERTEX - S.P.              
C     10/16/81 - BUILD LX1 AND LX2 INTO IPT1 - S.P.                     
C     10/19/81 - PASS IPT TO BEBETA FOR MEBDEF - S.P.                   
C     10/22/81 - IDENTICAL PARTICLE PROCESSING - S.P.                   
C     11/10/81 - FIX GIESSEN BUG MAKING EVERYTHING SYM - S.P.           
C     3/20/82 - SOME SYMETRIES WERE MISSED IN GIESSEN - S.P.            
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
C                                                                       
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
C                                                                       
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      DIMENSION IZPT(2)                                                 
      EQUIVALENCE ( IZPT(1), IZS(2) )                                   
C                                                                       
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
C                                                                       
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
C                                                                       
      LOGICAL ONELSW, IDENSW                                            
      COMMON /INELCM/ JBPF,JBTF,LXMIN,LXMAX,ILILOR,ILILOI,MSTOP,IA12M, 
     *NMLOLX,ONELSW,NUMLX,IRDINT,IELCUP,LILOSZ,NUMLIS,ILIS,IBETAS(4), 
     *ICL2FF,LXSTEP,IDENSW,LSKIP,JPMIN,JPMAX,JPBASE,NJP,JTMIN,JTMAX, 
     *JTBASE,NJT,IINDXS,ISMATR,ISMATI,NSMAT,NLX,NSPLI,ITOCS,NASPLI, 
     *IUNITR,LIFIT,ILIFIT,NOLFIT,IDELSR,IDELSI
      INTEGER INDXJS(4,2)                                               
      EQUIVALENCE ( INDXJS(1,1), JPMIN )                                
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
C                                                                       
      REAL*8 NAME5                                                      
      DATA NAME5 / 'TEMPCUP' /                                          
	CHARACTER*8 NAME6 / 'TEMPCUP' /
      INTEGER GIVEAL,CHOPIT                                             
	CHARACTER*8 ANAMES
      COMMON /NAMCOM/ANAMES(1)                                          
	real*4 unde4
C                                                                       
      LOGICAL PBUGSW, SYMSW, FLIPSW                                     
      INTEGER IFACS(4)                                                   
      DATA IFACS/1, 2, -1, -2/                                           
C                                                                       
      DATA MBASCP/11/,LPL/3/                                            
C                                                                       
C     HERE WE STORE THE NUCLEAR J'S K-NUMBERS AND E*'S AS               
C       JNUC(IPT,I) AND ENUC(IPT,I)                                     
C     IPT = 1 FOR PROJECTILE AND 2 FOR TARGET;                          
C     I = 1 FOR LEFT SIDE AND 2 FOR RIGHT SIDE.                         
C     AND                                                               
C       SCHN(I)  FOR THE CHANNEL SPIN                                   
C                                                                       
      DIMENSION JNUC(2,2), ENUC(2,2), KNUC(2,2)                         
      INTEGER SCHN(2)                                                   
      EQUIVALENCE (JNUC(1,1), JP1), (JNUC(1,2), JP2),  (JNUC(2,1), JT1),
     * (JNUC(2,2), JT2)                                                 
      EQUIVALENCE (ENUC(1,1), EP1), (ENUC(1,2), EP2),  (ENUC(2,1), ET1),
     * (ENUC(2,2), ET2)                                                 
      DIMENSION JPT12(2,2), EPT12(2,2), KPT12(2,2)                      
C                                                                       
      DIMENSION NAME12(2)                                               
      EQUIVALENCE ( NAME1, NAME12(1) ), ( NAME2, NAME12(2) )            
C                                                                       
C     HERE WE STORE THE NUCLEAR RADII AS  RNUC(IPT)                     
C                                                                       
      DIMENSION RNUC(2), RCOUL(2)                                       
C                                                                       
C     HERE WE STORE LX'S, BETA'S, ETC FOR THE COUPLING BEING            
C     CONSIDERED.  FOR SECOND ORDER THERE ARE TWO OF THEM.              
C                                                                       
      DIMENSION LXX2S(2), BETACS(2), BETANS(2), IBETAC(2), IPTS(2)      
      DIMENSION LXS(2), IBETAN(2), RMENUC(2), RMECOU(2)                 
      DIMENSION SCLFAC(2)                                               
C                                                                       
C     VALS GETS ALL THE VARIATIONS ON THE COULOMB COUPLING DEFORMATION  
C                                                                       
      DIMENSION VALS(8,2), DELTAN(2)                                    
C                                                                       
	character*8 iptwrd(2)
      DATA IPTWRD/'PROJ', 'TARG'/                                       
      CHARACTER*8 ORDWRD(2)                                             
      DATA ORDWRD/'FIRST', 'SECOND'/                                    
      CHARACTER*8 MODNAM, MODELS(7)                                     
      DATA MODELS/'ROTATION','VIBRATIO','DEFORMED','ROTVIB','VIBROT',
     * 'MODEL6','MODEL7'/                                              
C                                                                       
      PBUGSW = MOD(IPRINT, 10) .GE. 5                                   
	unde4=undef
C                                                                       
C                                                                       
C     GET THE DEFORMATION RADII.  IF POINT AND SPHERE COULOMB IS BEING  
C     USED, THEN RCP IS ZERO AND WE MUST USE VALUES COMPUTED FROM RC0   
C                                                                       
      RCOUL(1) = RCP                                                    
      RCOUL(2) = RCT                                                    
      I = 0                                                             
      IF ( RCP .EQ. UNDEF .OR. RCP .EQ. 0 .OR. RCT .EQ. UNDEF ) I = 1   
      RNUC(1) = R0 * AMA**.333333333333333 0D0                          
      IF ( I .EQ. 1 )  RCOUL(1) = RC0 * AMA**.333333333333333 0D0       
      RNUC(2) = R0 * AMBIGA**.333333333333333 0D0                       
      IF ( I .EQ. 1 )  RCOUL(2) = RC0 * AMBIGA**.333333333333333 0D0    
      WRITE(6,13) ORDWRD(MEORD+1),( RNUC(I), RCOUL(I), I=1,2 )           
  13  FORMAT ( ' ELECTROMAGNETIC MATRIX ELEMENTS ARE RELATED',  ' TO BET
     *AS UP TO ', A6, ' ORDER.' /  X, T16, 'DEFORMED RADII' /  T15, 'N
     *UCLEAR   COULOMB' /  ' PROJECTILE', T12, 2F10.4 /  ' TARGET', T12,
     * 2F10.4 )                                                         
C                                                                       
C     WE NEED THE LOG(FACTORIAL) TABLE FOR VALUES                       
C       N < S(1)+S(2)+LX(1)+LX(2)+JP(1)+JT(2)                           
C         << 8*MAX(LIN-LOUT)                                            
C     MAX(LIN-LOUT)  HAS BEEN STORED IN LXMAX BY BASLBL                 
C                                                                       
      I = 8*LXMAX                                                       
      CALL SETLOG(I)                                                    
C                                                                       
C     IF THE OUTGOING NUCLEI ARE IDENTICAL WE WILL DOUBLE               
C     COUPLINGS TO CHANNELS CONTAINING IDENTICAL STATES IF              
C     THE COUPLING COMES FROM CHANNELS WITH NON-IDENTICAL STATES.       
C                                                                       
      SYMSW = ISTATS(2) .LT. 3                                          
      IF ( SYMSW ) WRITE(6,17)
  17  FORMAT ( ' SYMMETRIZED COUPLINGS ARE BEING GENERATED FOR',  ' IDEN
     *TICAL NUCLEAR STATES.' )                                          
C                                                                       
C     WE START OUT WITH A TEMPORARY ARRAY AND PUT STUFF INTO            
C     IT IN ANY ORDER AND LATER ON SORT THEM INTO THE                   
C     DESIRED ORDER                                                     
C                                                                       
      N5=NAMLOC(NAME6)                                                  
	IF(N5.NE.0)Z(N5)=-Z(N5)
      ITMPCP=GIVEAL(IWRDS)                                              
      LBASCP=Z(ITMPCP)                                                  
      ANAMES(ITMPCP)=NAME6                                              
      LBASCP=FACFR4*(LBASCP-1)+1                                        
C                                                                       
      CALL SETLOG(I)                                                    
      LCHNDF=Z(ICHNDF)                                                  
      LCHNDF=FACFR4*(LCHNDF-1)+1                                        
      NCHNDF=ILLOC(LCHNDF)                                              
      MCHNDF=ILLOC(LCHNDF+1)                                            
      LCHNDF=ILLOC(LCHNDF+2)+LCHNDF                                     
      LCHNCP=Z(ICHNCP)                                                  
      LCHNCP=FACFR4*(LCHNCP-1)+1                                        
      NCHNCP=ILLOC(LCHNCP)                                              
      MCHNCP=ILLOC(LCHNCP+1)                                            
      LCHNCP=ILLOC(LCHNCP+2)+LCHNCP                                     
      LBASDF=Z(IBASDF)                                                  
      LBASDF=FACFR4*(LBASDF-1)+1                                        
      NBASDF = ILLOC(LBASDF)                                            
      MBASDF=ILLOC(LBASDF+1)                                            
      LBASDF=LBASDF+ILLOC(LBASDF+2)                                     
      LTRANS = 0                                                        
      IF ( ITRANS.EQ.0 ) GO TO 20                                       
      LTRANS=Z(ITRANS)                                                  
      LTRANS=FACFR4*(LTRANS-1)+1                                        
      MTRANS = ILLOC(LTRANS+1)                                          
C                                                                       
C     THE PHILOSOPHY FOR SELECTING MULTIPOLES IS AS FOLLOWS:            
C     1 CALCULATE FULL RANGE OF POSSIBLE MULTIPOLES                     
C     2 SELECT FROM FULL RANGE THOSE SPECIFIED IN Z(ITRANS)             
C     3 IF VALUES ARE SPECIFIED IN Z(ICHNCP) USE IN                     
C     4 CONJUNCTION WITH CTRANS OR REPLACE CTRANS VALUES IF ALREADY GIVE
C     ANY MULTIPOLE VALUE NOT SPECIFIED IS SET TO ZERO                  
C                                                                       
C     FOR MUTUAL LXTOT=0 IS ALWAYS ALLOWED.  FOR 1ST OR 2ND ORDER       
C     AT ONE VERTEX, LXTOT=0 IS ALLOWED ONLY IF EITHER                  
C     1)  IT IS THE ONLY POSSIBILITY (COUPLING 0+ TO 0+)                
C     2)  IT IS EXPLICITLY SPECIFIED                                    
C     NOTE THAT THE STANDARD FORM FACTORS ARE NOT REALLY APPRORIATE     
C     FOR LXTOT = 0                                                     
C     COULOMB M.E. ARE ALWAYS SET TO 0 FOR LXTOT=0.                     
C                                                                       
  20  IORDX=1                                                           
C                                                                       
C                                                                       
C     LET US BEGIN THE GUTS OF THE CALCULATION                          
C                                                                       
      NBASCP = 0                                                        
      WRITE(6,23)
 23   FORMAT ( '-COUPLINGS USED IN THE CALCULATION:' /  '   CHANNEL', 4X
     *, 'MODEL ORDER NUC. LX', 4X, 'SCALE',  T47, 'BETAN', 2X, 'DELTAN',
     * 2X, 'R.M.E.',  7X, 'BETAC', 2X, 'DELTAC', T92, 'R.M.E.', T104, 'B
     *E UP',  T117, 'Q', T126, 'MEANLIFE' /  '  FROM   TO', T37, 'FACTOR
     *', T56, 'FM', T62, 'ALPHA',  T84, 'FM',  T91, 'E B**LX/2', T102, '
     *E**2 B**LX', T115, 'E BARN',  T128, 'SEC.' )                      
C                                                                       
C                                                                       
C     LOOP OVER ALL CHANNELS ON THE LEFT SIDE                           
C     THESE ARE THE CHANNELS BEING COUPLED TO.                          
C                                                                       
      DO 999 ICH1 = 1, NCHNDF                                           
      ICH1PT = (ICH1-1)*MCHNDF+LCHNDF                                   
      NAME1=ILLOC(ICH1PT)                                               
      JPT12(2,1) = IABS(ILLOC(ICH1PT+1))                                
      EPT12(2,1) = ALLOC4(ICH1PT+2)                                     
      JPT12(1,1) = IABS(ILLOC(ICH1PT+3))                                
      IPARI1 = ISIGN(1, ILLOC(ICH1PT+1)) * ISIGN(1, ILLOC(ICH1PT+3))    
      EPT12(1,1) = ALLOC4(ICH1PT+4)                                     
      IB1ST=ILLOC(ICH1PT+7)                                             
      IB1END = IB1ST-1 + ILLOC(ICH1PT+8)                                
      KPT12(2,1) = ILLOC(ICH1PT+15)                                     
      KPT12(1,1) = ILLOC(ICH1PT+16)                                     
      WRITE(6,73)
 73   FORMAT (1X)                                                       
C                                                                       
C     LOOP OVER CHANNELS ON THE RIGHT SIDE                              
C     THESE ARE THE CHANNELS BEING COUPLED FROM                         
C                                                                       
      DO 979 ICH2 = 1, NCHNDF                                           
      ICH2PT = (ICH2-1)*MCHNDF+LCHNDF                                   
      NAME2 = ILLOC(ICH2PT)                                             
      JPT12(2,2) = IABS(ILLOC(ICH2PT+1))                                
      EPT12(2,2) = ALLOC4(ICH2PT+2)                                     
      JPT12(1,2) = IABS(ILLOC(ICH2PT+3))                                
      IPARI2 = ISIGN(1, ILLOC(ICH2PT+1)) * ISIGN(1, ILLOC(ICH2PT+3))    
      EPT12(1,2) = ALLOC4(ICH2PT+4)                                     
      IB2ST=ILLOC(ICH2PT+7)                                             
      IB2END = IB2ST-1 + ILLOC(ICH2PT+8)                                
      KPT12(2,2) = ILLOC(ICH2PT+15)                                     
      KPT12(1,2) = ILLOC(ICH2PT+16)                                     
C                                                                       
C     IPARTY = 0 FOR NO PARITY CHANGE, = 1 FOR PARITY CHANGE.           
C     THAT IS    PARITY CHANGE = (-1)**IPARTY                           
C                                                                       
      IPARTY = 0                                                        
      IF ( IPARI1*IPARI2 .LT. 0 ) IPARTY = 1                            
C                                                                       
C     LOOP OVER ALL CHANNEL COUPLINGS                                   
C     AND FIND THE ONES THAT COUPLE THIS PAIR OF CHANNELS               
C                                                                       
      DO 949 ICP=1,NCHNCP                                               
      ICOUNT = 0                                                        
      ICNT2 = 0                                                         
      NAME1 = IABS(NAME1)                                               
      NAME2 = IABS(NAME2)                                               
      ICPPT=(ICP-1)*MCHNCP+LCHNCP                                       
      ICFLIP = 2                                                        
      IF ( IABS(ILLOC(ICPPT)) .EQ. NAME2 .AND. ILLOC(ICPPT+1) .EQ. NAME1
     * ) GO TO 150                                                      
      IF ( ILLOC(ICPPT+3) .EQ. 2 ) GO TO 949                            
      ICFLIP = 1                                                        
      IF ( IABS(ILLOC(ICPPT)) .NE. NAME1 .OR. ILLOC(ICPPT+1) .NE. NAME2 
     *) GO TO 949                                                       
C                                                                       
 150  IORDER=ILLOC(ICPPT+2)                                             
      ITYPE=ILLOC(ICPPT+3)                                              
      SCALE = 1                                                         
      DO 169 I = 1, IORDER                                              
      LXX2S(I) = ILLOC(ICPPT+3+I)                                       
      BETACS(I) = ALLOC4(ICPPT+5+I)                                     
      BETANS(I) = ALLOC4(ICPPT+7+I)                                     
      IBETAC(I) = ILLOC(ICPPT+10+I)                                     
      IBETAN(I) = ILLOC(ICPPT+14+I)                                     
      SCLFAC(I) = ALLOC4(ICPPT+16+I)                                    
      SCALE = SCALE*SCLFAC(I)                                           
 169  CONTINUE                                                          
      IMUL=ILLOC(ICPPT+4)                                               
      IF ( IORDER .GE. 2 ) IMUL = NOTDEF                                
      IPT = ILLOC(ICPPT+10)                                             
      ILLOC(ICPPT+13) = 1                                               
      MODEL = ILLOC(ICPPT+14)                                           
      MODNAM = MODELS(MODEL)                                            
      LXTOT = ILLOC(ICPPT+19)                                           
      LXTOP = ILLOC(ICPPT+20)                                           
C                                                                       
C     THE LEFTSIDE CHANNEL MAY HAVE BEEN REVERSED                       
C                                                                       
      FLIPSW = ILLOC(ICPPT) .LT. 0                                      
      IF ( FLIPSW ) NAME12(ICFLIP) = -NAME12(ICFLIP)                    
      DO 229 IC = 1, 2                                                  
      DO 229 I = 1, 2                                                   
      II = I                                                            
      IF ( FLIPSW .AND. IC .EQ. ICFLIP ) II = 3-I                       
      JNUC(II,IC) = JPT12(I,IC)                                         
      ENUC(II,IC) = EPT12(I,IC)                                         
      KNUC(II,IC) = KPT12(I,IC)                                         
 229  CONTINUE                                                          
C                                                                       
C     FOR FIRST ORDER DEFINE IPT TO BE 1 FOR PROJECTILE,                
C     AND 2 FOR TARGET.  FOR SECOND ORDER WE LEAVE IT UNTOUCHED         
C                                                                       
      IF ( IORDER .GE. 2 ) GO TO 500                                    
      IF ( IPT .NE. NOTDEF ) GO TO 450                                  
C                                                                       
C     WHICH NUCLEUS IS BEING COUPLED IN FIRST ORDER ?                   
C                                                                       
      IPT = 1                                                           
      IF ( JP1 .NE. JP2 .OR. EP1 .NE. EP2 ) GO TO 450                   
      IPT = 2                                                           
      IF ( JT1 .NE. JT2 .OR. ET1 .NE. ET2 ) GO TO 450                   
C                                                                       
C     IT IS DIAGONAL;  IF ONE IS THE G.S. OR 0+, THEN THE OTHER         
C     IS BEING COUPLED, ELSE WE CANNOT DECIDE.                          
C                                                                       
      IF ( EP1 .EQ. 0 .OR. JP1 .EQ. 0 ) GO TO 450                       
      IPT = 1                                                           
      IF ( ET1 .EQ. 0 .OR. JT1 .EQ. 0 ) GO TO 450                       
      WRITE(6,438)
 438  FORMAT ( ' **** CANNOT DETERMIN WHICH NUCLEUS (PROJECTILE ',  'OR 
     *TARGET) TO COUPLE IN FIRST ORDER.' )                              
 445  WRITE(6,448) NAME1,JP1,EP1,JT1,ET1,NAME2,JP2,EP2,JT2,ET2   
 448  FORMAT ( 6X, 'NUCLEI SPINS AND ENERGIES ARE:' /  6X, 'CHANNEL', I4
     *,  ', PROJ. AND TARGET:', 2( I4, '/2', F7.3, 2X ) /  6X, 'CHANNEL'
     *, I4,  ', PROJ. AND TARGET:', 2( I4, '/2', F7.3, 2X ) )           
      IRET=0                                                            
      GO TO 949                                                         
C                                                                       
C     MAKE SURE IT IS A LEGAL 1ST ORDER COUPLING                        
C                                                                       
 450  IF ( JNUC(3-IPT,1) .EQ. JNUC(3-IPT,2) .AND. ENUC(3-IPT,1) .EQ. ENU
     *C(3-IPT,2) ) GO TO 470                                            
      WRITE(6,453) IPTWRD(IPT)                                            
 453  FORMAT ( '0*** BOTH NUCLEII CANNOT CHANGE STATE IN A ',  ' FIRST O
     *RDER COUPLING.' /  6X, 'OR THE WRONG NUCLEUS (', A4,  ') WAS SPECI
     *FIED AS BEING EXCITED. ' )                                        
      GO TO 445                                                         
C                                                                       
C     IF BETAS WERE SPECIFIED WITHOUT THE MULTIPOLE, THEN               
C     WE MUST CHOOSE AN APPROPRIATE MULTIPOLE BASED ON THE              
C     COUPLED SPINS.  THIS IS STILL ONLY FIRST ORDER                    
C     ALSO SET THE POSSIBLE RANGE OF MULTIPOLARITIES.                   
C                                                                       
 470  ILLOC(ICPPT+10) = IPT                                             
      MINLAM = IABS( JNUC(IPT,1)-JNUC(IPT,2) )                          
      MAXLAM = JNUC(IPT,1)+JNUC(IPT,2)                                  
      IF ( LXTOP .NE. NOTDEF ) MAXLAM = MIN0( LXTOP, MAXLAM )           
C                                                                       
C  ********************************************************             
C     HERE WE SET MINLAM AND MAXLAM ASSUMING ONLY E(LX)                 
C     TRANSITIONS.
C                                                                       
      MINLAM = MINLAM + MOD( MINLAM+2*IPARTY, 4 )                       
      MAXLAM = MAXLAM - MOD( MAXLAM+2*IPARTY, 4 )                       
C ************************************************************          
C                                                                       
      IF ( MINLAM .LE. MAXLAM ) GO TO 475                               
      WRITE(6,473) NAME1, NAME2, MINLAM, MAXLAM                           
 473  FORMAT ( '0*** CHANNEL', I5, ' IS TO BE COUPLED TO', I5,  ' IN FIR
     *ST ORDER BUT SPINS AND PARITIES CANNOT BE.' /  6X, 'MINLAM, MAXLAM
     * =', 2( I5, '/2' ) )                                              
      GO TO 445                                                         
C                                                                       
 475  IF ( IMUL .NE. NOTDEF .OR. LXTOT .NE. NOTDEF ) GO TO 480          
C                                                                       
C     LX NOT EXPLICITLY GIVEN;  IF 0 IS ONLY POSSIBILITY,               
C     SO BE IT, ELSE START FROM LXMIN>0.                                
C                                                                       
      IF ( MINLAM .EQ. 0 .AND. MAXLAM .GE. 4 ) MINLAM = 4               
      IF ( BETACS(1) .EQ. unde4 .AND. BETANS(1) .EQ. unde4 ) GO TO 600  
      IF ( MINLAM .NE. MAXLAM ) WRITE(6,478) NAME1,NAME2,MINLAM,MAXLAM
 478  FORMAT ( '0*** WARNING, CHANNEL', I4,  ' CAN BE COUPLED TO CHANNEL
     *', I4,  ' IN FIRST ORDER WITH MULTIPOLES FROM', I4, '/2 TO',  I4, 
     *'/2.' /  6X, 'YOU HAVE SPECIFIED BETAS BUT NOT A PARTICULAR',  ' M
     *ULTIPOLE, ONLY THE LOWEST WILL BE USED.' / )                      
      MAXLAM = MINLAM                                                   
      IMUL = MINLAM                                                     
      GO TO 600                                                         
C                                                                       
C     IS THE SPECIFIED FIRST-ORDER MULTIPOLARITY O.K.                   
C                                                                       
 480  IF ( IMUL .EQ. NOTDEF ) IMUL = LXTOT                              
      IF ( IMUL .GE. MINLAM .AND. IMUL .LE. MAXLAM ) GO TO 485          
      WRITE(6,483) NAME1, NAME2, IMUL, MINLAM, MAXLAM                     
 483  FORMAT ( '0*** CHANNEL', I5, ' IS TO BE COUPLED TO', I5,  ' IN FIR
     *ST ORDER WITH MULTIPOLARITY', I3, '/2' /  6X, 'BUT ONLY', I3, '/2 
     *=< LX =<', I3,  '/2 IS POSSIBLE.' )                               
      GO TO 949                                                         
 485  MINLAM = IMUL                                                     
      MAXLAM = IMUL                                                     
      GO TO 600                                                         
C                                                                       
C     FOR SECOND ORDER COUPLING GET POSSIBLE RANGE OF                   
C     MULTIPOLARITIES                                                   
C                                                                       
 500  MINLAM = IABS( LXX2S(1)-LXX2S(2) )                                
      MAXLAM = LXX2S(1) + LXX2S(2)                                      
      IF ( LXTOP .NE. NOTDEF ) MAXLAM = MIN0( LXTOP, MAXLAM )           
C                                                                       
C     FOR MUTUAL EXCITATION BE SURE EACH LX IS O.K.                     
C                                                                       
      IF ( IPT .NE. 3 ) GO TO 550                                       
      DO 519 I = 1, 2                                                   
      IF ( LXX2S(I) .LT. IABS(JNUC(I,1)-JNUC(I,2))  .OR. LXX2S(I) .GT. J
     *NUC(I,1)+JNUC(I,2) ) GO TO 560                                    
 519  CONTINUE                                                          
      GO TO 600                                                         
C                                                                       
C     FOR NON-MUTUAL SECOND ORDER, TOTAL LX MUST COUPLE THE             
C     RELAVANT SPINS                                                    
C                                                                       
 550  MINLAM = MAX0( MINLAM, IABS(JNUC(IPT,1)-JNUC(IPT,2)) )            
      MAXLAM = MIN0( MAXLAM, JNUC(IPT,1)+JNUC(IPT,2) )                  
      IF ( MINLAM .LE. MAXLAM ) GO TO 570                               
 560  WRITE(6,563) NAME1, NAME2, LXX2S                                    
 563  FORMAT ( '0*** CHANNEL', I5, ' IS TO BE COUPLED TO', I5,  ' IN SEC
     *OND ORDER WITH MULTIPOLES', 2(I3, '/2') /  6X, 'BUT THESE CANNOT C
     *ONNECT THE NUCLEAR SPINS.' )                                      
      GO TO 445                                                         
C                                                                       
C     SEE IF A SPECIFIC MULTIPOLE HAS BEEN SPECIFIED                    
C                                                                       
 570  LXX2 = LXTOT                                                      
      IF ( LXX2 .NE. NOTDEF ) GO TO 572                                 
      LXX2 = 2*BETACS(1)                                                
      IF ( IBETAC(1) .EQ. 3 ) GO TO 572                                 
      IF ( IBETAN(1) .NE. 3 ) GO TO 580                                 
      LXX2 = 2*BETANS(1)                                                
 572  IF ( LXX2 .GE. MINLAM .AND. LXX2 .LE. MAXLAM  .AND. MOD(LXX2+MINLA
     *M,4) .EQ. 0 ) GO TO 575                                           
      WRITE(6,573) NAME1, NAME2, LXX2, MINLAM, MAXLAM                     
 573  FORMAT ( '0*** CHANNEL', I5, ' IS TO BE COUPLED TO', I5,  ' IN 2ND
     * ORDER WITH TOTAL LX =', I3, '/2' /  5X, 'WHICH IS OUTSIDE OF THE 
     *ALLOWED RANGE:', 2(I3, '/2') )                                    
      GO TO 445                                                         
 575  MINLAM = LXX2                                                     
      MAXLAM = LXX2                                                     
      GO TO 600                                                         
C                                                                       
C     ALLOW LXTOT=0 ONLY IF REQUIRED                                    
C                                                                       
 580  IF ( MINLAM .EQ. 0 .AND. MAXLAM .GE. 4 ) MINLAM = 4               
C                                                                       
C     LOOP OVER MULTIPOLARITIES                                         
C                                                                       
C     DUE TO PARITY WE CAN INCREMENT LX BY 2                            
C                                                                       
 600  DO 829 LXX2 = MINLAM, MAXLAM, 4                                   
C                                                                       
C     MUTUAL EXCITATION IS THE PRODUCT OF TWO FIRST-ORDER               
C     EXCITATION RME'S, WHICH NEED TO BE FOUND ONLY FOR THE FIRST       
C     TOTAL LAMBDA.                                                     
C                                                                       
      IF ( IPT .EQ. 3 .AND. LXX2 .GT. MINLAM ) GO TO 700                
C                                                                       
C     GET THE VALUES OF THE BETAS                                       
C                                                                       
      IF ( IORDER .EQ. 1 ) LXX2S(1) = LXX2                              
      RMESGN = +1                                                       
      DO 659 I = 1, IORDER                                              
      II = IPT                                                          
      IORD = IORDER                                                     
      IF ( IPT .EQ. 3 ) IORD = 1                                        
      IF ( IPT .EQ. 3 ) II = I                                          
      IPTS(I) = II                                                      
      LX = LXX2S(I)                                                     
      LXS(I) = LX/2                                                     
C                                                                       
C     FIRST, IF NECESSARY, MERGE IN STUFF FROM THE TRANSITIONS
C     TABLE.  NOTE THAT IN CONSULTING THIS TABLE, WE IGNOR              
C     K AND DELTA K.                                                    
C                                                                       
      IF ( BETACS(I) .NE. unde4 .AND. BETANS(I) .NE. unde4 )  GO TO 630 
      IF ( LTRANS .EQ. 0 ) GO TO 630                                    
      L1 = LTRANS + ILLOC(LTRANS+5-II)                                  
      IF ( L1 .EQ. LTRANS ) GO TO 630                                   
      L2 = L1 + MTRANS*(ILLOC(LTRANS+7-II)-1)                           
      DO 619 I2 = L1, L2, MTRANS                                        
      IF ( ILLOC(I2) .NE. LX ) GO TO 619                                
      IF ( BETACS(I) .NE. unde4 .OR. ALLOC4(I2+1) .EQ. unde4 ) GO TO 615
     *                                                                  
C                                                                       
C     CAN NOT ACCEPT BE FOR 2ND ORDER                                   
C                                                                       
      IF ( IORD .EQ. 2 .AND. ILLOC(LTRANS+9-II) .NE. 0 )  GO TO 615     
      IBETAC(I) = ILLOC(LTRANS+9-II)                                    
      BETACS(I) = ALLOC4(I2+1)                                          
 615  IF ( BETANS(I) .NE. unde4 .OR. ALLOC4(I2+2) .EQ. unde4 ) GO TO 630
     *                                                                  
      IBETAN(I) = 0                                                     
      BETANS(I) = ALLOC4(I2+2)                                          
      GO TO 630                                                         
 619  CONTINUE                                                          
C                                                                       
C     WE HAVE CONSULTED ALL SOURCES.  IF BOTH BETAS ARE STILL           
C     UNDEFINED, WE MUST ABANDON ALL HOPE FOR THIS LX.                  
C     IF ONLY ONE IS UNDEFINED, WE USE EQUAL DEFORMATION LENGTHS        
C     IF DELTA IS DEFINED, CONVERT TO BETA                              
C                                                                       
 630  IF ( BETANS(I) .EQ. unde4 ) GO TO 640                             
      IF ( IBETAN(I) .NE. 1 ) GO TO 635                                 
      BETANS(I) = BETANS(I)/RNUC(II)                                    
      IBETAN(I) = 0                                                     
 635  IF ( BETACS(I) .NE. unde4 ) GO TO 645                             
      BETACS(I) = RNUC(II)/RCOUL(II) * BETANS(I)                        
      IBETAC(I) = IBETAN(I)                                             
      GO TO 645                                                         
 640  IBETAN(I) = -99                                                   
      IF ( BETACS(I) .NE. unde4 ) GO TO 645                             
      IF ( IORD .EQ. 2 .AND. I .EQ. 1 ) GO TO 829                       
      IBETAC(I) = -99                                                   
      GO TO 650                                                         
 645  IF ( IBETAC(1) .NE. 1 ) GO TO 647                                 
      BETACS(I) = BETACS(I)/RCOUL(II)                                   
      IBETAC(I) = 0                                                     
 647  IF ( BETANS(I) .NE. unde4 .OR. IBETAC(I) .NE. 0 ) GO TO 650       
      BETANS(I) = RCOUL(II)/RNUC(II) * BETACS(I)                        
C                                                                       
C     PREPARE FOR POSSIBLE BETAC CONVERSION, AND IN ANY CASE            
C     GET THE REDUCED MATRIX ELEMENTS BETWEEN NUCLEAR STATES            
C     AND GET ALL THE OTHER COULOMB DEFORMATION SPECIFICATIONS          
C                                                                       
C     FOR 2ND ORDER AT ONE VERTEX THIS IS DONE ONLY ON THE 2ND PASS.    
C     MUTUTAL EXCITATION IS REALLY TWO FIRST ORDERS.                    
C                                                                       
C     NOTE THAT BEBETA RETURNS REDUCED MATRIX ELEMENTS FOR              
C        <HIGHER E* !! ... !! LOWER E*>                                 
C     RMESGN CONTAINS THE SIGN NECESSARY TO CONVERT TO                  
C        < 1 !! ... !! 2 >                                              
C                                                                       
C     IUP LABELS THE STATE OF THIS NUCLEUS WITH HIGHER ENERGY           
C                                                                       
 650  IF ( IORD .EQ. 2 .AND. I .EQ. 1 ) GO TO 659                       
      IUP = 1                                                           
      IF ( ENUC(II,2) .GT. ENUC(II,1) ) IUP = 2                         
      IF ( IUP .EQ. 2 ) RMESGN = RMESGN *  (-1)**((JNUC(II,1)-JNUC(II,2)
     *)/2)                                                              
      ITEMP = LXX2                                                      
      IF ( IORD .EQ. 1 ) ITEMP = LXX2S(I)                               
      TEMP = SCALE                                                      
      IF ( IORD .EQ. 1 ) TEMP = SCLFAC(I)                               
C                                                                       
C     FOR NON-MUTUAL WE CANNOT ALLOW COULOMB FOR LXTOT=0                
C                                                                       
      IF ( IPT .EQ. 3 ) GO TO 655                                       
      IF ( LXX2 .NE. 0 ) GO TO 655                                      
      BETACS(I) = 0                                                     
      IBETAC(I) = 2                                                     
 655  CALL BEBETA ( MODEL, IORD, I, IBETAC(I), MEORD, BETACS,  ITEMP, LX
     *X2S, IZPT(II),  AMS(2*II-1), RCOUL(II), ENUC(II,IUP)-ENUC(II,3-IUP
     *),  JNUC(II,IUP), JNUC(II,3-IUP), KNUC(II,IUP),  KNUC(II,3-IUP),  
     *IBETAN(I), BETANS, RNUC(II), TEMP, II,  RMENUC(I), RMECOU(I), IRTN
     *, VALS(1,I) )                                                     
      IF ( PBUGSW ) WRITE(6,658) NAME1,NAME2,I,II,IORD,IORDER,ITEMP
     *, IUP, LXX2, LXX2S, IBETAC(I), IBETAN(I),  IZPT(II),  BETACS, BETA
     *NS, RMENUC(I), RMECOU(I), IRTN                                    
 658  FORMAT ( ' BEBETA' , 14I3, 6G13.4, I2 )                           
      IF ( IRTN .NE. 0 ) GO TO 445                                      
C                                                                       
C     IF BOTH RME'S ARE STILL UNDEFINED, MUST GIVE UP                   
C                                                                       
      IF ( DABS(RMENUC(I))+DABS(RMECOU(I)) .EQ. 0 ) GO TO 829           
C                                                                       
C     NO MATTER WHAT THE INPUT WAS, BETANS AND BETACS                   
C     NOW CONTAIN BETA, UNLESS THIS IS 2ND ORDER AT ONE                 
C     VERTEX, IN WHICH CASE THEY HAVE BETA OR R.M.E. AND                
C     THE IBETAS ARE ALREADY CORRECT OR DON'T MATTER SINCE              
C     IF IT IS R.M.E., LX WAS GIVEN EXPLICITLY AND WE LOOP              
C     ONLY ONCE.                                                        
C                                                                       
      IF ( IORD .EQ. 2 ) GO TO 659                                      
      IBETAN(I) = 0                                                     
      IBETAC(I) = 0                                                     
C                                                                       
      DELTAN(I) = BETANS(I)*RNUC(II)                                    
C                                                                       
 659  CONTINUE                                                          
C                                                                       
C     PRINT SOMELINES ABOUT THE COUPLING                                
C                                                                       
      IF ( IORD .EQ. 2 ) GO TO 665                                      
      WRITE(6,663) NAME2,NAME1,MODNAM,IORDER,(IPTWRD(IPTS(I)),LXS(I
     *), SCLFAC(I), BETANS(I),  DELTAN(I), RMENUC(I),  BETACS(I), ( VALS
     *(II,I), II=1,5 ), I = 1, IORDER )                                 
 663  FORMAT ( 1X, 2I5, 1X, A8, I3,  ( T27, A4, I3, F9.4, F9.4, F8.4, G1
     *1.4,  F9.4, F8.4, G12.4, G12.4, F9.4, G13.4 ) )                   
      GO TO 700                                                         
 665  IF ( LXX2 .GT. MINLAM ) GO TO 670                                 
      WRITE(6,666) NAME2,NAME1,MODNAM,IORDER,IPTWRD(IPTS(1)),SCALE, 
     *LXS                                                               
 666  FORMAT ( 1X, 2I5, 1X, A8, I3, T27, A4, T34, F9.4, 3X,  'LX1 =', I2
     *, T93, 'LX2 =', I2 )                                              
      IF ( IBETAN(1) .EQ. 0 ) WRITE(6,667) BETANS                         
 667  FORMAT ( '+', T54, 'BETAN =', F7.4, T101, 'BETAN =', F7.4 )       
      IF ( IBETAC(1) .EQ. 0 ) WRITE(6,668) BETACS                         
 668  FORMAT ( '+', T70, 'BETAC =', F7.4, T117, 'BETAC =', F7.4 )       
 670  L = LXX2/2                                                        
      WRITE(6,671) L, RMENUC(2), ( VALS(II,2), II = 2, 5 )                
 671  FORMAT ( T31, I3, '  (TOTAL)', T60, G12.4, 16X,  G12.4,G12.4,F9.4,
     *G13.4)                                                            
C                                                                       
C     NOW GENERATE THE R.M.E. OF G AS DEFINED IN THE                    
C     NOTES 47, 70, 46, 71.                                             
C                                                                       
 700  CALL CUPAB ( IORDER, IPT, LXX2S, LXX2, RMENUC, RMECOU,  RNUC, IZPT
     *, RMEGN, RMEGC, IPT1 )                                            
C                                                                       
C     SETUP THE INGRST INDICATOR                                        
C     IT IS                                                             
C       1 OR 2 FOR 1ST OR 2ND ORDER DERIVATIVE COUPLING                 
C       10000*LXT + 100*LXP + N  FOR MODELS > 2                         
C     WHERE N = 3 FOR PROJECTILE, 4 FOR TARGET, 5 FOR MUTUAL            
C     LX1 AND LX2 ARE NOT MULTIPLIED BY 2                               
C                                                                       
      IPT1 = IORDER                                                     
      IF ( MODEL .LE. 2 ) GO TO 710                                     
      IF ( IPT .EQ. 1 ) IPT1 = 3 + 50*LXX2S(1)                          
      IF ( IPT .EQ. 2 ) IPT1 = 4 + 5000*LXX2S(1)                        
      IF ( IPT .EQ. 3 ) IPT1 = 5 + 50*LXX2S(1)+ 5000*LXX2S(2)           
 710  IF ( PBUGSW ) WRITE(6,713) RMENUC,RMECOU,RMEGN,RMEGC,RMESGN,IPT1
 713  FORMAT ( ' CUPAB', 7G15.4, I5 )                                   
C                                                                       
      RMEGN = RMESGN*RMEGN                                              
      RMEGC = RMESGN*RMEGC                                              
C                                                                       
C     LOOP OVER BASIS STATES FOR CHANNEL 1                              
C                                                                       
      DO 799 IB1 = IB1ST, IB1END                                        
      IB1PT = LBASDF + (IB1-1)*MBASDF                                   
      SCHN(1) = ILLOC(IB1PT+1)                                          
      L1 = ILLOC(IB1PT+2)                                               
C                                                                       
C     LOOP OVER ALL BASIS STATES COUPLED TO                             
C                                                                       
      DO 789 IB2 = IB2ST, IB2END                                        
      IB2PT = LBASDF + (IB2-1)*MBASDF                                   
      SCHN(2)=ILLOC(IB2PT+1)                                            
      L2=ILLOC(IB2PT+2)                                                 
C                                                                       
C     THE TOTAL LX MUST BE ABLE TO COUPLE THE CHANNEL SPINS AND         
C     THE ORBITAL ANGULAR MOMENTA                                       
C                                                                       
      LDIFX2 = L2-L1                                                    
      IF ( IABS(LDIFX2) .GT. LXX2 .OR. IABS(SCHN(1)-SCHN(2)) .GT. LXX2 )
     * GO TO 789                                                        
      IF ( SCHN(1)+SCHN(2) .LT. LXX2 ) GO TO 789                        
C                                                                       
C     SETUP THE SYMMETRY INDICATOR                                      
C                                                                       
      FAC = 1                                                           
      IF ( .NOT. SYMSW ) GO TO 740                                      
      IF ( ILLOC(IB1PT+6) .EQ. 2 ) GO TO 740                            
      IF ( ILLOC(IB2PT+6) .NE. 2 ) GO TO 730                            
      FAC = 2                                                           
      IF ( IPT .NE. 3 ) GO TO 740                                       
      I = LXX2S(1) + LXX2S(2) + SCHN(2)                                 
      IF ( MOD(I,4).GT.1 ) GO TO 789                                    
      GO TO 740                                                         
C                                                                       
C     WE COME HERE IF BOTH "FROM" AND "TO" STATES CONSIST OF            
C     NUCLEI IN IDENTICAL STATES.  IF THE COUPLING IS IN ONLY           
C     ONE NUCLEUS (ONLY POSSIBLE FOR REORIENTATION) OR IF THE           
C     COUPLING IS DIFFERENT IN P AND T, THEN WE DOUBLE.                 
C                                                                       
  730 IF ( IPT .NE. 3 .OR. ( IPT .EQ. 3 .AND. ( LXX2S(1) .NE. LXX2S(2) )
     * ) ) FAC = 2                                                      
C                                                                       
C     FLIPPED CHANNELS GET A (-1)**S                                    
C                                                                       
  740 IF ( .NOT. FLIPSW ) GO TO 750                                     
      I = SCHN(ICFLIP)                                                  
      IF ( MOD(I,4).GT.1 ) FAC = -FAC                                   
C                                                                       
C     COMPUTE THE I**(L2-L1) FACTOR                                     
C                                                                       
 750  LDIF = LDIFX2/2                                                   
      IFAC = MOD(LDIF+4000, 4) + 1                                      
      IFAC = IFACS(IFAC)                                                
C                                                                       
C     NOW GET THE MATRIX ELEMENTS                                       
C     REALLY THE MATRIX ELEMENTS GENERATED HERE DO NOT DEPEND           
C     ON L1 NOR L2, SO THIS CALL COULD BE DONE ONLY ONCE                
C     FOR EACH PAIR OF S1 AND S2.                                       
C                                                                       
      CALL CUPSPN ( IRTN, LXX2, IPT, SCHN,  LXX2S, JNUC, RMEGN, RMEGC, X
     *N, XC )                                                           
C                                                                       
      IF ( PBUGSW ) WRITE(6,763) NAME1,NAME2,IB1,IB2,L1,L2,JT1,JP1
     *, JT2, JP2, SCHN, IPARI1, IPARI2, ICP, IORDER,  LXX2S, LXX2, IRTN,
     * IPT1, XN, XC, FAC                                                
 763  FORMAT ( ' CUPSPN', 4I3, 8(I3, '/2'), 2I2, I3, I2,  3(I3,'/2'), 2I
     *3, 2G15.5, F3.0 )                                                 
      IF ( IRTN .NE. 0 ) GO TO 770                                      
      IRET = 0                                                          
      GO TO 789                                                         
 770  ICNT2 = ICNT2 + 1                                                 
      IF ( DABS(XN)+DABS(XC) .EQ. 0 ) GO TO 789                         
      ICOUNT=ICOUNT+1                                                   
      ILLOC(LBASCP)=IB1                                                 
      ILLOC(LBASCP+1)=IB2                                               
      ILLOC(LBASCP+2)=IORDER                                            
      ILLOC(LBASCP+3)=LXX2                                              
      ALLOC4(LBASCP+4) = FAC*XN                                         
      ALLOC4(LBASCP+5) = FAC*XC                                         
      ILLOC(LBASCP+6)=IFAC                                              
      ILLOC(LBASCP+7)=IPT1                                              
      ILLOC(LBASCP+8)=NOTDEF                                            
      ILLOC(LBASCP+9)=NOTDEF                                            
      ILLOC(LBASCP+10)=NOTDEF                                           
C                                                                       
C     ACCUMULATE MAXIMUM ORDER FOR INGRST                               
C                                                                       
      IF ( IORDER.EQ.2)IORDX=2                                          
C                                                                       
      LBASCP = LBASCP + MBASCP                                          
      NBASCP = NBASCP + 1                                               
C                                                                       
C     FOR C.C. WE WANT  LXTOP = MAX( LOUT-LIN, MULTIPOLE )              
C     BASLBL DID THE FIRST PART, WE DO THE SECOND PART HERE.            
C                                                                       
      LXTOP = MAX0( LXTOP, LXX2/2 )                                     
C                                                                       
C                                                                       
C     END OF LOOPS OVER BASIS STATES IN BOTH CHANNELS                   
C                                                                       
 789  CONTINUE                                                          
 799  CONTINUE                                                          
C                                                                       
      IF ( IORDER .NE. 1 ) GO TO 829                                    
C                                                                       
C     FOR FIRST ORDER, BETAS MUST BE FOUND AGAIN FOR EACH LX            
C                                                                       
      BETANS(1) = unde4                                                 
      BETACS(1) = unde4                                                 
C                                                                       
C     END OF LOOP OVER MULTIPOLARITIES                                  
C                                                                       
 829  CONTINUE                                                          
C                                                                       
      IF ( ICNT2 .NE. 0 ) GO TO 840                                     
      WRITE(6,833) NAME1, NAME2, IORDER, IMUL                             
 833  FORMAT ( '0**** CHANNEL', I5, ' IS TO BE COUPLED TO', I5,  ' BY OR
     *DER =', I2, ' AND MULTIPOLE =', I3, '/2' /  6X, '(****/2 MEANS MUL
     *TIPOLE WAS NOT SPECIFIED; ALL',  ' POSSIBILITIES WERE TRIED.)' /  
     *6X, 'BUT THERE IS NO DEFINITION OF THE REQUIRED BETAS,',  ' OR THE
     * SPECIFIED MULTIPOLE IS IMPOSSIBLE TO USE.' /  6X, '(CHECK TRANSIS
     *TIONS SPECIFICATIONS.)' /  6X, '(OR PERHAPS PARITY IS VIOLATED)' /
     *  6X, 'YOU NEVER KNOW FOR SURE.' )                                
      IRET = 0                                                          
      GO TO 949                                                         
 840  IF ( ICOUNT .NE. 0 ) GO TO 949                                    
      WRITE(6,843) NAME1, NAME2, IORDER, IMUL                             
 843  FORMAT ( '0**** CHANNEL', I5, ' IS TO BE COUPLED TO', I5,  ' BY OR
     *DER =', I2, ' AND MULTIPOLE =', I3, '/2' /  6X, '(****/2 MEANS MUL
     *TIPOLE WAS NOT SPECIFIED; ALL',  ' POSSIBILITIES WERE TRIED.)' /  
     *6X, 'BUT ALL COUPLING CONSTANTS WERE ZERO (SUSPISCOUS)' )         
C                                                                       
C     END OF LOOP OVER ALL SPECIFIED CHANNEL COUPLINGS                  
C                                                                       
 949  CONTINUE                                                          
C                                                                       
C                                                                       
C     END OF LOOPS OVER ALL CHANNELS                                    
C                                                                       
 979  CONTINUE                                                          
 999  CONTINUE                                                          
C                                                                       
      X = DFLOAT(NBASCP)/NBASDF                                          
      WRITE(6,1003) NBASCP, X                                             
 1003 FORMAT ( ' THERE ARE A TOTAL OF', I6,  ' COUPLINGS OF BASIS STATES
     * FOR AN AVERAGE OF', F6.1,  ' COUPLINGS PER BASIS STATE.' )       
C                                                                       
      IWRDS=(MBASCP*NBASCP)/FACFR4+1                                    
      IL=CHOPIT(IWRDS)                                                  
C                                                                       
C     WAS EVERY COUPLING SPECIFICATION USED                             
C                                                                       
      DO 1049 ICP = 1, NCHNCP                                           
      ICPPT = (ICP-1)*MCHNCP + LCHNCP                                   
      IF ( ILLOC(ICPPT+13) .NE. 0 ) GO TO 1049                          
      WRITE(6,1043) ILLOC(ICPPT), ILLOC(ICPPT+1)                          
 1043 FORMAT ( '0*** CHANNEL', I5, ' IS TO BE COUPLED TO', I5,  ' BUT ON
     *E OF THESE CHANNELS IS NOT DEFINED.' )                            
      IRET = 0                                                          
 1049 CONTINUE                                                          
C                                                                       
C     NOW PREPARE TO SORT THE BASIS COUPLING ARRAY                      
C                                                                       
      IF ( IRET .EQ. 0 ) RETURN                                         
      ITEMP = NALLOC( NBASCP, 'SORTINDX' )                              
      IBASCP = NALLOC( (NBASCP*MBASCP+LPL+1)/FACFR4, 'BASISCUP' )       
      LBASCP = FACFR4*(Z(IBASCP)-1)+1                                   
      ILLOC(LBASCP) = NBASCP                                            
      ILLOC(LBASCP+1) = MBASCP                                          
      ILLOC(LBASCP+2) = LPL                                             
      LBASCP = LBASCP+LPL                                               
      LTMPCP = FACFR4*(Z(ITMPCP)-1)+1                                   
      LTEMP = FACFR4*(Z(ITEMP)-1)                                       
      LTMP2 = (LBASCP+1)/FACFR4                                         
C                                                                       
C     CONSTRUCT THE SORT PARAMETER.  WE SORT INTO THE ORDER             
C     (MOST SLOWLY VARYING TO MOST RAPIDLY VARYING)                     
C       BASIS 1,  BASIS 2,  ORDER,  MULTIPOLARITY                       
C                                                                       
      DO 1299 IBC = 1, NBASCP                                           
      IBCPT = LTMPCP + (IBC-1)*MBASCP                                   
      ALLOC(LTMP2+IBC) = ILLOC(IBCPT+3)  + 100*( ILLOC(IBCPT+2) + 10*( I
     *LLOC(IBCPT+1)  + 5000*ILLOC(IBCPT) ) )                            
 1299 CONTINUE                                                          
C                                                                       
      CALL IXSORT ( ILLOC(LTEMP+1), ALLOC(LTMP2+1), NBASCP )            
C                                                                       
C     NOW STRAIGHTEN IT OUT, PUT POINTERS INTO BASISDEF,                
C     AND MAKE SURE EVERY BASIS STATE IS COUPLED.                       
C                                                                       
      LCHNDF=Z(ICHNDF)                                                  
      LCHNDF=FACFR4*(LCHNDF-1)+1                                        
      LCHNDF=ILLOC(LCHNDF+2)+LCHNDF                                     
      LBASDF=Z(IBASDF)                                                  
      LBASDF=FACFR4*(LBASDF-1)+1                                        
      LBASDF=LBASDF+ILLOC(LBASDF+2)                                     
      IB1 = 1                                                           
      ILLOC(LBASDF+3) = 1                                               
      DO 1379 IBC = 1, NBASCP                                           
      IBCPT = LTMPCP + (ILLOC(LTEMP+IBC)-1)*MBASCP                      
      DO 1349 I = 1, MBASCP                                             
      ILLOC(LBASCP+I-1) = ILLOC(IBCPT+I-1)                              
 1349 CONTINUE                                                          
      LBASCP = LBASCP + MBASCP                                          
C                                                                       
C     WHEN WE CHANGE BASIS STATES, UPDATE POINTERS                      
C                                                                       
      IF ( IB1 .EQ. ILLOC(IBCPT) ) GO TO 1379                           
      ILLOC(LBASDF+4) = IBC-ILLOC(LBASDF+3)                             
      IF ( ILLOC(LBASDF+4) .GT. 0 ) GO TO 1350                          
      WRITE(6,1353) IB1, ILLOC(LCHNDF+(ILLOC(LBASDF)-1)*MCHNDF)           
      IRET = 0                                                          
 1350 IB1 = IB1+1                                                       
      LBASDF = LBASDF+MBASDF                                            
      ILLOC(LBASDF+3) = IBC                                             
      IF ( IB1 .GE. ILLOC(IBCPT) ) GO TO 1379                           
      WRITE(6,1353) IB1, ILLOC(LCHNDF+(ILLOC(LBASDF)-1)*MCHNDF)           
 1353 FORMAT ('0*** BASIS STATE', I5, ' OF CHANNEL', I5,  ' IS NOT COUPL
     *ED TO ANYTHING.' )                                                
      IRET = 0                                                          
      GO TO 1350                                                        
 1379 CONTINUE                                                          
      ILLOC(LBASDF+4) = NBASCP-ILLOC(LBASDF+3)+1                        
      IF ( IB1 .EQ. NBASDF ) GO TO 1400                                 
      IB1 = IB1+1                                                       
      WRITE(6,1383) IB1, NBASDF                                           
 1383 FORMAT ( '0*** BASIS STATES', I5, ' THROUGH', I5,  ' ARE NOT COUPL
     *ED TO ANYTHING.' )                                                
      IRET = 0                                                          
C                                                                       
 1400 IF ( MOD(IPRINT/100,10) .GT. 0 ) RETURN                           
      Z(ITEMP) = -Z(ITEMP)                                              
      Z(ITMPCP) = -Z(ITMPCP)                                            
      RETURN                                                            
      END                                                               
      SUBROUTINE BASLBL                                                 
C                                                                       
C     CONSTRUCTS BASIS STATES DEFINITIONS                               
C                                                                       
C     WE CONSTRUCT CENTRAL LABELLING ARRAY FOR C.C.                     
C     WE ASSUME USUAL PREFACE STRUCTURE                                 
C     THIS ARRAY HAS THE STRUCTURE                                      
C     +0 CHANNEL INDEX                                                  
C     +1 J(PROJ)+J(TARG) = CHANNEL SPIN                                 
C     +2 L-J VALUES  (STORED FOR J=0; MAY BE < 0)                       
C     +3 POINTER TO CHANNELS                                            
C     +4 NUMBER OF CHANNELS COUPLED TO POINTER IN +3                    
C     +5 STARTING PARAMETER FOR HOMOGENEOUS/INHOMOGENEOUS               
C     +6 SYMMETRY INDICATOR:                                            
C        = 1 MEANS THE CHANNEL IS NOT TO BE SYMMETRIZED (EITHER         
C            THE NUCLEI ARE NOT IDENTICAL OR THE STATES ARE THE SAME)   
C        = 2 MEANS THE CHANNEL IS TO BE SYMMETRIZED, S MATRICES         
C            ARE TO BE MULTIPLIED BY ROOT 2.  THIS IS FOR IDENTICAL     
C            NUCLEI WITH NON-IDENTICAL STATES SO THERE ARE TWO          
C            SUCH BASIS STATES, ONLY ONE OF WHICH IS COMPUTED.          
C                                                                       
C     +3 AND +4 COMPUTED IN BASCPL                                      
C     +5 CALCULATED IN COUPLN.FORT                                      
C                                                                       
C        12/79 - FIRST VERSION - MRB                                    
C     1/16/80 - STORE ADDRESS IN CCBLK, USE CCBLK - S.P.                
C     12/9/80 - PRINT K-QUANTUM NUMBER - S.P.                           
C     10/19/81 - LEAVE OUT FORBIDDEN CHANNEL SPINS FOR IDEN. - S.P.     
C     10/26/81 - GENERATE AND STORE SYMMETRY INDICATORS - S.P.          
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      COMMON /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
      LOGICAL ONELSW, IDENSW                                            
      COMMON /INELCM/ JBPF,JBTF,LXMIN,LXMAX,ILILOR,ILILOI,MSTOP,IA12M, 
     *NMLOLX,ONELSW,NUMLX,IRDINT,IELCUP,LILOSZ,NUMLIS,ILIS,IBETAS(4), 
     *ICL2FF,LXSTEP,IDENSW,LSKIP,JPMIN,JPMAX,JPBASE,NJP,JTMIN,JTMAX, 
     *JTBASE,NJT,IINDXS,ISMATR,ISMATI,NSMAT,NLX,NSPLI,ITOCS,NASPLI, 
     *IUNITR,LIFIT,ILIFIT,NOLFIT,IDELSR,IDELSI
      INTEGER INDXJS(4,2)                                               
      EQUIVALENCE ( INDXJS(1,1), JPMIN )                                
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      COMMON /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI

     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
	CHARACTER*8 NAME9
      DATA NAME9 / 'BASISSTA' /                                         
      INTEGER GIVEAL                                                    
      COMMON/NAMCOM/ANAMES(1)                                           
      DATA LENDAT/7/,LPL/3/,JLTP/10000/                                 
      CHARACTER*1 SIGNS(2)                                              
      DATA SIGNS/'+', '-'/                                              
	REAL*8 NAME7 / 'BASISSTA' /
      LOGICAL TBIT                                                      
C                                                                       
      I=NAMLOC(NAME9)                                                   
      IF(I.NE.0)Z(I)=-Z(I)                                              
      IBASDF=GIVEAL(IWRDS)                                              
      NDATA=Z(IBASDF)                                                   
      ANAMES(IBASDF)=NAME7                                              
      NDATA4=FACFR4*(NDATA-1)+1+LPL                                     
      LDATA=Z(ICHNDF)                                                   
      LDATA4=FACFR4*(LDATA-1)+1                                         
      ICH=ILLOC(LDATA4)                                                 
      AWN=2.0*REDMI/(HBARC**2)                                          
      LABEL=ILLOC(LDATA4+1)                                             
      LABEL1=ILLOC(LDATA4+2)+LDATA4                                     
C                                                                       
C     WE ACCUMULATE MAX!LIN-LOUT!                                       
C                                                                       
      LXMAX = 0                                                         
      LXMIN = 0                                                         
C                                                                       
      DO 10 I=1,ICH                                                     
C     LABELS FOR ETA AND K IN Z(IDATA1) RESPECTIVELY                    
      I1=LABEL1+5+(I-1)*LABEL                                           
      I2=I1+1                                                           
C                                                                       
C     FIRST WE CALCULATE ETA AND K                                      
C     IN EACH CHANNEL AND STORE IN Z(IDATA1)                            
C                                                                       
      AKC=AWN*(ALLOC4(I1-1)+ALLOC4(I1-3))                               
      AKC=DSQRT(AKI*AKI-AKC)                                            
      ETAC=ETAS(1)*AKI/AKC                                              
      ALLOC4(I1)=ETAC                                                   
 10   ALLOC4(I2)=AKC                                                    
C     IN THIS VERSION WE WILL ASSUME G.S. SPINS=0+                      
C     AND HENCE ELASTICC HANNEL PARITIES =(-1)**L(EL)                   
      I1=0                                                              
      I3=0                                                              
      ILLOC(LABEL1+7)=1                                                 
C                                                                       
C     LOOP OVER CHANNELS                                                
C                                                                       
      DO 299 I=1,ICH                                                    
C     DONT FORGET NXHINT GIVES 2*JP(JT)                                 
      JP=IABS(ILLOC(LABEL1+(I-1)*LABEL+3))                              
      JT=IABS(ILLOC(LABEL1+(I-1)*LABEL+1))                              
      EP = ALLOC4(LABEL1+(I-1)*LABEL+4)                                 
      ET = ALLOC4(LABEL1+(I-1)*LABEL+2)                                 
      I1=I1+1                                                           
      I2=0                                                              
      J1=IABS(JP-JT)                                                    
      J2=JP+JT                                                          
      I5=0                                                              
      J4=J2/2                                                           
      IF(MOD(J4,2).NE.0)I5=1                                            
      I4=LABEL1+(I-1)*LABEL+8                                           
      LXMAX = MAX0( LXMAX, J2/2 )                                       
C                                                                       
C     LOOP OVER CHANNEL SPINS                                           
C                                                                       
      DO 259 J=J1,J2,2                                                  
      J3=J/2                                                            
C                                                                       
C     FOR IDENTICAL SPIN-0 BOSONS, WE CAN OMIT ODD CHANNEL SPINS        
C                                                                       
      IF ( LSKIPS(2) .NE. 2 ) GO TO 15                                  
      IF ( JP .NE. JT .OR. EP .NE. ET ) GO TO 15                        
      IF ( MOD(J3,2).NE.0 ) GO TO 259                                   
C                                                                       
C     SET UP SYMMETRY INDICATOR                                         
C                                                                       
 15   ISYM = 1                                                          
      IF ( ISTATS(2) .EQ. 3 ) GO TO 20                                  
      IF ( JP .NE. JT .OR. EP .NE. ET ) ISYM = 2                        
C                                                                       
 20   L1=IABS(JLTP-J)                                                   
      L2=JLTP+J                                                         
      IF(I5.EQ.1)GO TO 27                                               
      IF(MOD(J3,2).NE.0)L1=L1+2                                         
      IF(MOD(J3,2).NE.0)L2=L2-2                                         
      GO TO 28                                                          
27    J3=J3+1                                                           
      IF(MOD(J3,2).NE.0)L1=L1+2                                         
      IF(MOD(J3,2).NE.0)L2=L2-2                                         
C                                                                       
C     LOOP OVER L-J                                                     
C                                                                       
28    DO 199 L = L1, L2, 4                                              
      I2=I2+1                                                           
      I3=I3+1                                                           
      LABEL2=(I3-1)*LENDAT+NDATA4                                       
      ILLOC(LABEL2)=I1                                                  
      ILLOC(LABEL2+1)=J                                                 
      ILLOC(LABEL2+2) = L-JLTP                                          
      ILLOC(LABEL2+6) = ISYM                                            
 199  CONTINUE                                                          
      ILLOC(I4)=I2                                                      
      IF(I.EQ.ICH)GO TO 259                                             
      ILLOC(I4+LABEL-1)=I2+ILLOC(I4-1)                                  
 259  CONTINUE                                                          
 299  CONTINUE                                                          
C                                                                       
      LOMOST = LMAX + LXMAX                                             
C                                                                       
C     LET US WORK OUT TOTAL NUM. OF DIFF. EQNNS.                        
C                                                                       
      WRITE(6,333)
 333  FORMAT ( '-  CHANNEL', T19, 'PROJECTILE', T46, 'TARGET',  T65, 'Q'
     *, T73, 'ETA', T85, 'K', T93, 'NUMBER OF' /  8X, 2( 6X, 'E(MEV)', 4
     *X, 'J', 5X, 'K', 1X ),  T64, 'MEV', T84, '1/FM', T93, 'EQUATIONS' 
     */ )                                                               
 337  FORMAT ( 1X, I7, 2( F12.4, I4, '/2', A1, I3, '/2' ),  F12.3, 2F10.
     *3, I10 )                                                          
      L=0                                                               
      DO 369 I=1,ICH                                                    
      J=LABEL1+(I-1)*LABEL                                              
      J1=ILLOC(J)                                                       
      JP=ILLOC(J+3)                                                     
      IP = 1                                                            
      IF ( JP .LT. 0 ) IP = 2                                           
      JP = IABS(JP)                                                     
      JT=ILLOC(J+1)                                                     
      IT = 1                                                            
      IF ( JT .LT. 0 ) IT = 2                                           
      JT = IABS(JT)                                                     
      EP=ALLOC4(J+4)                                                    
      ET=ALLOC4(J+2)                                                    
      Q = -(EP+ET)                                                      
      N = ILLOC(J+8)                                                    
      L = L+N                                                           
      WRITE(6,337) J1,EP,JP,SIGNS(IP),ILLOC(J+16),ET,JT,SIGNS(IT),
     * ILLOC(J+15),  Q, ALLOC4(J+5), ALLOC4(J+6), N                     
 369  CONTINUE                                                          
      WRITE(6,380)L                                                     
 380  FORMAT(' WE MUST SOLVE',I5,' COUPLED EQUATIONS'/)                 
      ILLOC(NDATA4-LPL)=L                                               
      ILLOC(NDATA4-LPL+1)=LENDAT                                        
      ILLOC(NDATA4-LPL+2)=LPL                                           
      LABEL2=LABEL2+LENDAT                                              
      IWRDS=(LABEL2+LPL-NDATA4)/FACFR4+1                                
      IL=CHOPIT(IWRDS)                                                  
      RETURN                                                            
      END                                                               
      SUBROUTINE BEBETA ( MODEL, IORD, I12, IBETAC, MEORD,  XCS, LXX2, L
     *XX2S, IZ, AMVAL,  RC, DELTAE, J2, J1, K2, K1,  IBETAN, XNS, RNUC, 
     *SCALE, IPT,  RMENUC, RMECOU, IRTN, VALS )                         
C                                                                       
C     COMPUTES E(LX) MATRIX ELEMENTS AND RELATED PARAMETERS             
C                                                                       
C     DEPENDING ON THE INPUT QUANTITIES,  BETA OR A R.M.E.              
C     IS COMPUTED FOR BOTH COULOMB AND NUCLEAR.  FOR COULOMB            
C     THE R.M.E. IS OF E(LX); FOR NUCLEAR IT IS OF ALPHA.               
C     IN SECOND ORDER IT IS THE 2ND ORDER PART OF E(LX) OR              
C     OF ALPHA X ALPHA.  THE COMPUTED E(LX) IS ALSO USED TO             
C     FIND THINGS LIKE BE, Q, LIFETIME.                                 
C                                                                       
C     THIS PROGRAM IS COMPLETELY GENERAL.  THE RELATION OF              
C     BETA TO THE REDUCED MATRIX ELEMENT IS MODEL DEPENDANT             
C     AND IS DONE BY MEBROT FOR THE ROTATIONAL MODEL.                   
C                                                                       
C     ARGUMENTS:                                                        
C                                                                       
C     MODEL - 0 MEANS THE ROTATIONAL MODEL                              
C     IORD - ORDER OF THE COUPLING (1 FOR EACH PIECE OF MUTUAL)         
C     I12 - 1 OR 2 TO INDICATE WHICH ELEMENTS OF XNS, XCS TO USE        
C     IBETAC - DEFINES THE INPUT COULOMB QUANTITY (XCS):                
C           0 = BETA                                                    
C           1 = DELTA = RC*BETA (FM)                                    
C           2 = R.M.E. OF ALPHA                                         
C           3 = TOTAL LX FOR 2ND ORDER  ( NEVER RECIEVED HERE )         
C                 < J,M=J ! Q ! J,M=J >                                 
C           4 = HALF LIFE (SEC)                                         
C           5 = MEAN LIFE (SEC)                                         
C           6 = BE(DOWN)                                                
C           7 = REDUCED MATRIX ELEMENT (E BARN**LX/2), BOHR-MOTTELSON   
C               CONVENTIONS ARE USED.  THIS IS                          
C               <J2,K2!! E(LX) !!J1,K1> .                               
C           8 = BE(UP, WEISSKOPF UNITS)                                 
C           9 = BE(DOWN, WEISSKOPF UNITS)                               
C           10 = BE(UP)  (E**2 BARN**LX)                                
C           11 = Q (E BARN) THE QUADRUPOLE MOMENT (NOT Q0 BUT           
C                THE SPECTROSCOPIC QUADRUPOLE MOMENT.                   
C           12 = WIDTH IN MEV                                           
C           -1 = BE UP FROM J=0 TO J=LX.  J1 AND J2 ARE IGNORED FOR     
C               FINDING BETA.                                           
C           -99 = NOT DEFINED                                           
C     MEORD - =0 MEANS USE FIRST ORDER RELATION BETWEEN REDUCED MATRIX  
C                ELEMENT AND BETA.                                      
C             =1 MEANS USE SECOND ORDER RELATION.                       
C     XCS - THE INPUT COULOMB QUANTITIY.  IT IS REDEFINED TO BE         
C           BETA UNDER MOST CIRCUMSTANCES.                              
C     LXX2 - 2*MULTIPOLE                                                
C     LXX2S - 2* PIECES OF TOTAL LX FOR 2ND ORDER                       
C     IZ - (INTEGER)  THE ATOMIC NUMBER.                                
C     AMVAL - THE ATOMIC MASS                                           
C     RC - COULOMB RADIUS OF THE NUCLEUS                                
C     DELTAE - DIFFERENCE IN ENERGY OF THE TWO STATES (>0)              
C     J2 - 2*SPIN OF THE HIGHER STATE.                                  
C     J1 - 2*SPIN OF THE LOWER STATE                                    
C     K2, K1 - 2*(K-QUANTUM NUMBERS) OF HIGHER AND LOWER STATES.        
C     IBETAN - DEFINES INPUT NUCLEAR QUANTITY (XNS).  IT IS 0-3         
C           WITH THE SAME MEANINGS AS IBETAC, OR -99 IF NOT DEFINED.    
C     XNS - INPUT NUCLEAR QUANTITY.  IT IS REDEFINED TO BETA            
C           UNDER MOST CIRCUMSTANCES.                                   
C     RNUC - NUCLEAR RADIUS                                             
C     SCALE - SCALE FACTOR BY WHICH THE RME'S ARE TO BE MULTIPLIED.     
C     IPT - 1 FOR PROJECTILE, 2 FOR TARGET - NEVER 3.                   
C     RMENUC - SET TO < !!ALPHA!! >  ( OR ALPHA X ALPHA )               
C     RMECOU - SET TO < !!E(LX)!! >  (1ST OR 2ND ORDER PART)            
C     IRTN - SET TO 0 IF ALL O.K.; 1 IF RME'S COULD NOT BE FOUND        
C     VALS - A 5-ELEMENT OUTPUT ARRAY THAT IS SET AS FOLLOWS:           
C        1 - DELTA                                                      
C        2 - BE(UP)                                                     
C        3 - Q                                                          
C        4 - HALFLIFE                                                   
C        5 - MEAN LIFE.                                                 
C                                                                       
C     IF PARITY IS VIOLATED (OR SOMETHING SIMILAR) THEN                 
C     XCS, XNS AND VALS ARE ALL SET TO ZERO.                            
C                                                                       
C     10/8/80 - COMPLETE REWRITE - S.P.                                 
C     12/8/80 - SEPARATE OUT MEBROT; WEISSKOPF UNITS - S.P.             
C     12/11/80 - K-QUANTUM NUMBERS ADDED - S.P.                         
C     1/8/81 - ALSO PROCESSES NUCLEAR STUFF - S.P.                      
C     1/25/81 - SCALE FACTOR ADDED - S.P.                               
C     6/25/81 - FIX DIVIDE BY 0 IN LIFETIME - S.P.                      
C     6/28/81 - WIDTH ADDED - S.P.                                      
C     8/25/81 - ALLOW BOTH XCS AND XNS TO BE NOT DEFINED - S.P.         
C     10/13/81 - FIX FOR LX=0 - S.P.                                    
C     10/19/81 - IPT RECIEVED AND PASSED TO MEBDEF - S.P.               
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      DIMENSION XCS(2), XNS(2), VALS(5), LXX2S(2)                       
C                                                                       
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      IRTN = 1                                                          
C                                                                       
C     GET SOME COEFFICENTS.  THESE ARE GENERAL                          
C                                                                       
C     LIFETIME TO BE.  WE USE C = SPEED OF LIGHT IN FM/SEC = 3E23       
C                                                                       
      LX = LXX2/2                                                       
      TJ1P1 = J1+1                                                      
      TJ2P1 = J2+1                                                      
      ALIFE = 0                                                         
      IF ( LX .EQ. 0 ) GO TO 40                                         
      ALIFE = 1.D11*(10*DELTAE/HBARC)**LX                               
      DO 29 L = 1, LX                                                   
      ALIFE = ALIFE/(2*L+1)                                             
 29   CONTINUE                                                          
      ALIFE = 8*PI*(LX+1)*2.9979*10*DELTAE /  (LX*AFINE*HBARC) * ALIFE**
     *2                                                                 
 40   DLN2 = DLOG(2.D0)                                                 
C                                                                       
C     Q TO M.E. AND BE TO M.E.                                          
C                                                                       
      AQ = DSQRT( 16*PI/(5*TJ1P1) ) *  CLEBSH( J1, 4, J1, 0, J1, J1 )   
      ABE = TJ1P1                                                       
C                                                                       
C     NOW GET THE RME(E(LX)) IF NECESSARY                               
C                                                                       
C     THE CONVERSIONS TO RME THAT FOLLOW ARE ALL GENERAL                
C                                                                       
      IBC = -99                                                         
      IF ( IBETAC .EQ. -99 ) GO TO 520                                  
      IBC = 3                                                           
      X = XCS(I12)                                                      
      IGOTO = IBETAC+2                                                  
      GO TO ( 250, 390, 110, 350, 910, 150, 160, 200, 500, 230, 240,  21
     *0, 300, 260 ), IGOTO                                              
C                                                                       
C     DELTA INPUT                                                       
C                                                                       
 110  X = X/RC                                                          
      IBETAC = 0                                                        
      GO TO 390                                                         
C                                                                       
C     HALFLIFE INPUT; CONVERT TO MEAN LIFE                              
C                                                                       
 150  X = X/DLN2                                                        
C                                                                       
C     MEAN LIFE; CONVERT TO BE(DOWN)                                    
C                                                                       
 160  IF ( DELTAE .GT. 0 ) GO TO 170                                    
      WRITE(6,163)
 163  FORMAT ( '0*** LIFETIME MAY BE SPECIFIED ONLY FOR',  ' DIFFERENT N
     *UCLEAR STATES.' )                                                 
      RETURN                                                            
 170  X = 1/(ALIFE*X)                                                   
C                                                                       
C     BE(DOWN); CONVERT TO BE(UP)                                       
C                                                                       
 200  X = TJ2P1/TJ1P1 * X                                               
C                                                                       
C     BE(UP) FROM J1 TO J2; COMPUTE R.M.E                               
 210  RME = DSQRT( DABS(ABE*X) )                                        
 220  X = DSIGN( RME, X )                                               
      GO TO 500                                                         
C                                                                       
C     BE(UP) IN WEISSKOPF UNITS; CONVERT TO E**2 BARN**LX               
C                                                                       
 230  X = 1/(4*PI) * ( 3*(.12*AMVAL**.333333333333330D0)**LX  / (LX+3) )
     ***2                                                               
      GO TO 210                                                         
C                                                                       
C     BE(DOWN) IN W.U.                                                  
C                                                                       
 240  X = TJ2P1/TJ1P1 * X                                               
      GO TO 230                                                         
C                                                                       
C     BE(UP) FROM 0 TO LX;  CHANGE THE R.M.E. TO BETA FORMULA           
C     AND GET R.M.E.                                                    
C                                                                       
 250  RME = DSQRT(DABS(X))                                              
      IBC = 4                                                           
      GO TO 220                                                         
C                                                                       
C     WIDTH - CONVERT TO MEAN LIFE                                      
C                                                                       
 260  X = HBARC / (2.9979E23*X)                                         
      GO TO 160                                                         
C                                                                       
C     Q - COMPUTE R.M.E.                                                
C                                                                       
 300  IF ( J1 .EQ. J2 .AND. DELTAE .EQ. 0 ) GO TO 310                   
      WRITE(6,303)
 303  FORMAT ( '0*** CANNOT INPUT QUADRUPOLE MOMENT FOR',  ' OFF-DIAGONA
     *L TRANSITIONS.' )                                                
      RETURN                                                            
 310  IF ( LX .EQ. 2 ) GO TO 320                                        
      WRITE(6,313)
 313  FORMAT ( '0*** QUADRUPOLE MEOMENT MAY BE SPECIFIED ONLY FOR ',  ' 
     *LX = 2.' )                                                        
      RETURN                                                            
 320  X = X/AQ                                                          
      GO TO 500                                                         
C                                                                       
C     <!! ALPHA(COULOMB) !!>                                            
C                                                                       
 350  IBC = 2                                                           
      GO TO 500                                                         
C                                                                       
C     BETAC IS ALREADY KNOWN                                            
C                                                                       
 390  IBC = 1                                                           
C                                                                       
C     X IS NOW BETA, <!!M(ELX)!!>, OR <!!ALPHA!!>                       
C                                                                       
 500  XCS(I12) = X                                                      
      IF ( IBC .EQ. 2 ) IBETAC = 7                                      
C                                                                       
 520  IBN = 1                                                           
      IF ( IBETAN .EQ. 2 ) IBN = 2                                      
      IF ( IBETAN .EQ. -99 ) IBN = -99                                  
C                                                                       
C     NOW DO THE MODEL-DEPENDANT CNVERSIONS BETWEEN BETA AND RME        
C                                                                       
      GO TO ( 610, 620, 630 ), MODEL                                    
C                                                                       
 610  CALL MEBROT ( IORD, I12, IBN, XNS, IBC, XCS,  MEORD, LXX2, LXX2S, 
     *IZ,  RNUC, RC, DELTAE, J2, J1, K2, K1, RMENUC, RMECOU, IRTN )     
      GO TO 700                                                         
C                                                                       
 620  CALL MEBVIB ( IORD, I12, IBN, XNS, IBC, XCS,  MEORD, LXX2, LXX2S, 
     *IZ,  RNUC, RC, DELTAE, J2, J1, K2, K1, RMENUC, RMECOU, IRTN )     
      GO TO 700                                                         
C                                                                       
 630  CALL MEBDEF ( IORD, I12, IBN, XNS, IBC, XCS,  MEORD, LXX2, LXX2S, 
     *IZ,  RNUC, RC, DELTAE, J2, J1, K2, K1, RMENUC, RMECOU, IRTN,  IPT 
     *)                                                                 
      GO TO 700                                                         
C                                                                       
 700  IF ( DABS(RMENUC)+DABS(RMECOU) .EQ. 0 ) GO TO 900                 
      IF ( IRTN .NE. 0 ) GO TO 900                                      
C                                                                       
      RMENUC = SCALE*RMENUC                                             
      RMECOU = SCALE*RMECOU                                             
C                                                                       
C     NOW GET VARIOUS MODEL-INDEPENDANT STUFF                           
C                                                                       
      BEUP = RMECOU**2/ABE                                              
      BEDOWN = TJ1P1/TJ2P1 * BEUP                                       
      TMEAN = 0                                                         
      IF ( DELTAE .GT. 0 .AND. BEDOWN .NE. 0 )  TMEAN = 1/(ALIFE*BEDOWN)
     *                                                                  
      THALF = DLN2*TMEAN                                                
      Q = 0                                                             
      IF ( DELTAE .EQ. 0 .AND. J1 .EQ. J2 .AND. LXX2 .EQ. 4 ) Q = AQ*RME
     *COU                                                               
      DELTA = RC*XCS(I12)                                               
      VALS(1) = DELTA                                                   
      VALS(2) = RMECOU                                                  
      VALS(3) = BEUP                                                    
      VALS(4) = Q                                                       
      VALS(5) = TMEAN                                                   
C                                                                       
C     CONVERT RME E(LX) TO FM FOR CALCULATIONS                          
C                                                                       
      RMECOU = RMECOU * 10**LX                                          
      RETURN                                                            
C                                                                       
 900  X = 0                                                             
      DO 909 I = 1, 5                                                   
      VALS(I) = 0                                                       
 909  CONTINUE                                                          
      RETURN                                                            
 910  WRITE(6,913)
 913  FORMAT ( '0*** TOTAL LX INCORRECTLY PLACED IN INPUT' )            
      GO TO 900                                                         
C                                                                       
      END                                                               
      SUBROUTINE BETCAL ( ELSW, UK, JSP, NSPL, LMN, LMX, LSKP,  LXMN, LX
     *MX, LDELMX, NTEMPS, ISTAT, PRNTSW,  SIGTOT, SIGREA,  JTOCS, S, SMA
     *G, SPHASE, SIGIN, SIGOT,  BETAS, TOTLX, TOTMX, ALOWFC, TEMPS )    
C                                                                       
C                                                                       
C     CALCULATES THE ANGLE-INDEPENDENT PARTS (BETA) OF THE AMPLITUDES F.
C                                                                       
C                                                                       
C     INPUT SCALARS:                                                    
C                                                                       
C     ELSW = TRUE FOR ELASTIC SCATTERING.                               
C     UK = INCIDENT WAVENUMBER (FM**-1).                                
C     JSP = 2 * PROJECTILE SPIN (ELASTIC ONLY).                         
C     NSPL = NUMBER OF S-MATRIX ELEMENTS PER INCIDENT L.                
C     LMN, LMX, LSKP = MINIMUM, MAXIMUM, AND INCREMENT IN INCIDENT L.   
C     LXMN, LXMX = MINIMUM AND MAXIMUM LX.                              
C     LDELMX = MAXIMUM LI-LO (= ABS(MINIMUM)).                          
C     NTEMPS = LENGTH OF  TEMPS  ARRAY                                  
C        = ( LXMX+1 )*( LXMX-LXMN+1 )*( LDELMX+1 )                      
C     ISTAT = 1 IF INCIDENT CHANNEL HAS IDENTICAL POSONS, 2 IF IDENTICAL
C        FERMIONS, 3 IF NOT IDENTICAL.                                  
C     PRNTSW = TRUE IF BETAS ARE TO BE PRINTED.                         
C                                                                       
C     OUTPUT SCALARS:                                                   
C                                                                       
C     SIGTOT = TOTAL CROSS SECTION (NUCLEAR C.S. IF ELASTIC).           
C     SIGREA = TOTAL REACTION CROSS SECTION (ELASTIC ONLY).             
C                                                                       
C     INPUT ARRAYS (AND DIMENSIONS):                                    
C                                                                       
C     JTOCS(4,NSPL) = TABLE-OF-CONTENTS FOR S MATRIX (SEE ANGSET).      
C     S(2,NSPL,LMX+1) = S-MATRIX (ELASTIC ONLY).                        
C     SMAG(NSPL, LMX-LMN+1) = (R*4) MAGNITUDE OF S (NON-ELASTIC ONLY).  
C     SPHASE(NSPL,LMX-LMN+1) = (R*4) PHASE OF S (RADIANS)               
C              (NON-ELASTIC ONLY).                                      
C     SIGIN(LMX+1) = INCOMING COULOMB PHASES.                           
C     SIGOT(LMX+1) = OUTGOING COULOMB PHASES (NOT USED FOR ELASTICS).   
C                                                                       
C     OUTPUT ARRAYS                                                     
C                                                                       
C     BETAS(2,NSPL,LMX-LMN+1) = (R*4) BETA = (R*4) COEFFICIENTS         
C                 OF P(L,M) IN THE                                      
C        EXPRESSION FOR THE REACTION AMPLITUDES F.                      
C     TOTLX(LXMX+1) = TOTAL CROSS SECTION FOR EACH LX                   
C        (NON-ELASTIC ONLY).                                            
C     TOTMX(NSPL) = TOTAL CROSS SECTION FOR EACH JP, JT, LX, MX         
C        (NON-ELASTIC ONLY).                                            
C     ALOWFC(2,2) = THE CONTRIBUTION TO BETA FOR LX=0, L=LMN, LMN+1     
C        FROM NONZERO S (ELASTIC ONLY).  THE SECOND INDEX IS THE PARITY.
C                                                                       
C     SCRATCH ARRAY:                                                    
C                                                                       
C     TEMPS(NTEMPS) = SCRATCH ARRAY, USED BOTH FOR CLEBSCH-GORDAN       
C        FACTORS AND FOR SQUARE ROOTS OF FACTORIALS.                    
C                                                                       
C     11/14/79 - FIRST VERSION - RPG                                    
C     11/20/79 - S-MATRICES STORED BY LO-LI - S.P.                      
C     4/3/80 - REAL*4 SMAG, SPHASE, BETA - S.P.                         
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      LOGICAL ELSW, PRNTSW                                              
      REAL*4 SMAG, SPHASE, BETAS                                        
      DIMENSION JTOCS(4,1), S(2,NSPL,1), SMAG(NSPL,1), SPHASE(NSPL,1),  
     *SIGIN(1), SIGOT(1), BETAS(2,NSPL,1),  TOTLX(1), TOTMX(1), ALOWFC(2
     *,2), TEMPS(1)                                                     
C                                                                       
      DIMENSION FOPT(2), REACTN(2)                                      
      DATA IZERO / 0 /                                                  
C                                                                       
CDC      ALLOCLEVEL  JTOCS, S, SMAG, SPHASE, SIGIN, SIGOT, BETAS,       
CDC     1   TOTLX, TOLMX, TEMPS                                         
C                                                                       
C     INITIALIZATION                                                    
C                                                                       
      IODD = MOD( LDELMX, 2 )                                           
      FACTOR = 0.5/UK                                                   
      IF ( IODD .NE. 0 ) FACTOR = -FACTOR                               
      NMX = LXMX + 1                                                    
      NMLX = LXMX - LXMN + 1                                            
      IF (ELSW ) GO TO 30                                               
C     REACTION ONLY                                                     
      DO 19 KOFFS = 1, NSPL                                             
      TOTMX(KOFFS) = 0                                                  
 19   CONTINUE                                                          
      DO 29 LX = IZERO, LXMX                                            
      TOTLX(LX+1) = 0                                                   
 29   CONTINUE                                                          
      SIGTOT = 0                                                        
      LBASE = LMN                                                       
      LOMN = LMN                                                        
      IF ( LSKP .EQ. 2 ) LOMN = LOMN + IODD                             
      GO TO 40                                                          
C     ELASTIC SCATTERING ONLY                                           
 30   LBASE = 0                                                         
      LOMN = 0                                                          
      FOPT(1) = 0                                                       
      FOPT(2) = 0                                                       
      REACTN(1) = 0                                                     
      REACTN(2) = 0                                                     
      DO 39 I = 1, 4                                                    
      ALOWFC(I,1) = 0                                                   
 39   CONTINUE                                                          
C     BOTH ELASTIC AND REACTION                                         
 40   N = 2*NSPL*(LMX-LBASE+1)                                          
      DO 59 I = 1, N                                                    
      BETAS(I,1,1) = 0                                                  
 59   CONTINUE                                                          
C                                                                       
C     THE FOLLOWING FORCES THE COMMON BLOCKS USED BY CLEBSH TO BE       
C     LOADED INTO CORE.                                                 
C                                                                       
      CALL DUMMY1                                                       
C                                                                       
C                                                                       
C     THE OUTER LOOP IS OVER LO.                                        
C                                                                       
      DO 499 LO = LOMN, LMX, LSKP                                       
      DLO = LO                                                          
      D2L1 = 2*DLO + 1.                                                 
      ILO = LO - LBASE + 1                                              
      LPARIT = MOD( LO, 2 ) + 1                                         
      LIMN = LO - LDELMX                                                
      LIMX = LO + LDELMX                                                
      MXMX = MIN0( LXMX, LO )                                           
C                                                                       
C     INSERT CLEBSCH-GORDANS ETC. INTO THE TEMP ARRAY.                  
C                                                                       
      DO 159 I = 1, NTEMPS                                              
      TEMPS(I) = 0                                                      
 159  CONTINUE                                                          
      DO 189 LI = LIMN, LIMX, 2                                         
      IF ( LI .LT. LBASE ) GO TO 189                                    
      LX1 = MAX0( IABS( LI-LO ), LXMN )                                 
      DO 179 LX = LX1, LXMX                                             
      MXZ = MOD( LX+LI-LO, 2 )                                          
      I = 1 + NMX*( LX-LXMN + NMLX*(LI-LIMN)/2 )                        
      DO 169 MX = MXZ, LX                                               
      TEMPS(I+MX) = FACTOR * (2*LI+1)  * CLEBSH( 2*LI, 2*LX, 0, 2*MX, 2*
     *LO, 2*MX )                                                        
 169  CONTINUE                                                          
 179  CONTINUE                                                          
 189  CONTINUE                                                          
C                                                                       
C     START THE MAIN LOOP OVER JT, JP, LX, LI-LO.                       
C                                                                       
      LIPREV = -100000                                                  
      DO 299 KOFFS = 1, NSPL                                            
      IF ( JTOCS(4,KOFFS) .LT. 0 ) GO TO 299                            
      LX = JTOCS(2,KOFFS)                                               
      LI = LO - JTOCS(1,KOFFS)                                          
C                                                                       
C     A INCREASE OR NO CHANGE IN LI MEANS A NEW (JT,JP,LX) SET, AND     
C     HENCE A NEW SET OF MX VALUES TO INCLUDE IN THE SUM.               
C     SET UP POINTERS FOR THIS SET OF MX'S.                             
C     THE FIRST MX IS 0 OR 1 FOR NATURAL OR UNNATURAL PARITY.           
C                                                                       
      IF ( LI .LT. LIPREV ) GO TO 210                                   
      MXZ = LX + JTOCS(1,KOFFS)                                         
      KOFFZ = KOFFS - MXZ                                               
 210  LIPREV = LI                                                       
      IF ( LI .LT. LBASE .OR. LI .GT. LMX ) GO TO 299                   
C                                                                       
C     INSERT THE COULOMB PHASES INTO THE S-MATRIX ELEMENT, AND          
C     DIVIDE BY I.                                                      
C                                                                       
C     FOR REACTIONS, S COMES FROM SMAG AND SPHASE.                      
C                                                                       
      I = LI - LBASE + 1                                                
      IF ( ELSW ) GO TO 230                                             
      AMAG = SMAG(KOFFS,I)                                              
      IF ( AMAG .EQ. 0 ) GO TO 299                                      
      PHASE = SPHASE(KOFFS,I) + SIGIN(LI+1) + SIGOT(LO+1)               
      SMATR = AMAG * DSIN( PHASE )                                      
      SMATI = -AMAG * DCOS( PHASE )                                     
      GO TO 250                                                         
C                                                                       
C     FOR ELASTIC SCATTERING, S COMES FROM S.                           
C     ALSO UPDATE REACTION CROSS SECTION.                               
C                                                                       
 230  PHASE = SIGIN(LI+1) + SIGIN(LO+1)                                 
      TR = DCOS(PHASE)                                                  
      TI = DSIN(PHASE)                                                  
      IF ( LO .GE. LMN ) GO TO 235                                      
      SMATR = 0                                                         
      SMATI = 0                                                         
      IF ( LX ) 250, 240, 250                                           
 235  SR = S(1,KOFFS,I)                                                 
      SI = S(2,KOFFS,I)                                                 
      SMATR = SR*TI + SI*TR                                             
      SMATI = SI*TI - SR*TR                                             
      REACTN(LPARIT) = REACTN(LPARIT) - D2L1*( SR**2 + SI**2 )          
      IF ( LX .NE. 0 ) GO TO 250                                        
      IF ( LO .GT. LMN+1 ) GO TO 240                                    
      ALOWFC(1,LPARIT) = FACTOR*D2L1*SMATR                              
      ALOWFC(2,LPARIT) = FACTOR*D2L1*SMATI                              
 240  SMATR = SMATR - TI                                                
      SMATI = SMATI + TR                                                
      REACTN(LPARIT) = REACTN(LPARIT) + D2L1                            
C                                                                       
C     MULTIPLY  S  BY THE CLEBSCH-GORDAN ETC, AND SUM INTO  BETAS       
C     FOR EACH RELEVANT MX.                                             
C                                                                       
 250  I = 1 + NMX*( LX-LXMN + NMLX*(LI-LIMN)/2 )                        
      DO 269 MX = MXZ, LX                                               
      BETAS(1,KOFFZ+MX,ILO) = BETAS(1,KOFFZ+MX,ILO)  + TEMPS(I+MX)*SMATR
      BETAS(2,KOFFZ+MX,ILO) = BETAS(2,KOFFZ+MX,ILO)  + TEMPS(I+MX)*SMATI
 269  CONTINUE                                                          
C                                                                       
 299  CONTINUE                                                          
C                                                                       
C     END OF MAIN LOOP THROUGH KOFFS.                                   
C                                                                       
C     NOW CALCULATE THE SQRT(FACTORIALS) INTO TEMPS.                    
C                                                                       
      TEMPS(1) = 1                                                      
      IF ( MXMX .EQ. 0 ) GO TO 320                                      
      DO 309 MX = 1, MXMX                                               
      TEMPS(MX+1) = TEMPS(MX) / DSQRT( (DLO+MX)*(DLO-MX+1) )            

 309  CONTINUE                                                          
C                                                                       
C     CROSS SECTIONS MUST BE DOUBLED FOR IDENTICAL PARTICLES.           
C                                                                       
 320  TEMP = 40*PI/(2*DLO+1)                                            
      IF ( ISTAT .NE. 3 ) TEMP = 2*TEMP                                 
C                                                                       
C     SECOND PASS THROUGH KOFFS LOOP:                                   
C     INCREMENT THE TOTAL AND PARTIAL CROSS SECTIONS,                   
C     AND PUT THE SQRT(FACTORIALS) INTO BETA.                           
C                                                                       
      DO 399 KOFFS = 1, NSPL                                            
      IF ( JTOCS(4,KOFFS) .LT. 0 ) GO TO 399                            
      LX = JTOCS(2,KOFFS)                                               
      MX = ( JTOCS(1,KOFFS) + LX + 1 )/2                                
      BETAR = BETAS(1,KOFFS,ILO)                                        
      BETAI = BETAS(2,KOFFS,ILO)                                        
      IF ( ELSW ) GO TO 350                                             
C           REACTION ONLY.                                              
      TERM = TEMP*( BETAR**2 + BETAI**2 )                               
      TOTMX(KOFFS) = TOTMX(KOFFS) + TERM                                
      IF ( MX .GT. 0 ) TERM = 2*TERM                                    
      SIGTOT = SIGTOT + TERM                                            
      TOTLX(LX+1) = TOTLX(LX+1) + TERM                                  
      GO TO 360                                                         
C           ELASTICS ONLY                                               
 350  IF ( MX .EQ. 0 ) FOPT(LPARIT) = FOPT(LPARIT) + BETAI              
C                                                                       
 360  BETAR = TEMPS(MX+1)*BETAR                                         
      BETAI = TEMPS(MX+1)*BETAI                                         
      BETAS(1,KOFFS,ILO) = BETAR                                        
      BETAS(2,KOFFS,ILO) = BETAI                                        
C                                                                       
      IF ( PRNTSW) WRITE(6,393) JTOCS(3,KOFFS),JTOCS(4,KOFFS),LX,MX,L
     *O, BETAR, BETAI                                                   
 393  FORMAT ( ' JP, JT, LX, MX, LO, B =', 2(I3, '/2'),  2I3, I4, G17.5,
     * ' +', G13.5, 'I' )                                               
C                                                                       
 399  CONTINUE                                                          
C                                                                       
 499  CONTINUE                                                          
C                                                                       
C     FOR ELASTICS, FINISH CALCULATING THE REACTION AND                 
C     NUCLEAR CROSS SECTIONS.                                           
C                                                                       
      IF ( .NOT. ELSW ) RETURN                                          
      SIGREA = REACTN(1) + REACTN(2)                                    
      SIGTOT = FOPT(1) + FOPT(2)                                        
      IF ( ISTAT .EQ. 3 ) GO TO 520                                     
      TEMP = JSP                                                        
      TERM = TEMP + 1                                                   
      SIGREA = ( TEMP*SIGREA + 2*REACTN(ISTAT) )/TERM                   
      SIGTOT = ( TEMP*SIGTOT + 2*FOPT(ISTAT) )/TERM                     
 520  SIGREA = 10*PI*SIGREA/UK**2                                       
      SIGTOT = 40*PI*SIGTOT/UK                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE BOUND(IRET,IVOUT,IWF2)                                 
C                                                                       
C     BOUND STATE PROGRAM                                               
C                                                                       
C  CODED 2/22/73  D.GLOECKNER                                           
C     1/20/75 - FIX NSTEP CALCULATION - S. PIEPER                       
C     1/31/75 - USE /CNSTNT/, IPRINT CONTROLS PRINTING                  
C     2/9/75 - STORE STUFF THAT WAS STORED BY CONTRL - S.P.             
C     2/11/75 - RETURN CORRECT PHI, V AT R = 0 - S.P. & D.G.            
C     2/17/75 - ALLOW UP TO 9 OUTPUT VBOUNDS AND PHIS                   
C     2/24/75 - REMOVE MER STUFF; LOTS OF INPUT CHECKS                  
C     4/15/75 - NEW COMMON BLOCKS, USE TAU FOR VSO ALSO                 
C     4/21/75 - FIX BUG IN ASYMPTOTIC EXPANSION                         
C     4/23/75 - USE WHITTAKER FUNC FOR ASYMPTOTIC FORM                  
C     5/2/75 - SMALL FIXES; CHANGE COMPUTATION OF POTENTIALS            
C     5/21/75 - MORE CHECKS ON INPUT                                    
C     5/26/75 - MODIFY NUCONL SWITCH                                    
C     6/11/75 - USEHS; PRINT SUMMARY AFTER FAILURE                      
C     6/26/75 - STEPSPER ADDED; NEW ZPZT=0 TREATMENT OF RC; NEW         
C               NORM OF WHITAKER FUNCS                                  
C     8/29/75 - PRINT R0.                                               
C     11/10/76 - USE LOG-DERIVATIVE AT MATCHING POINT, EXTENSIVE        
C                REWRITE OF SEARCH ROUTINES, USE 1 TO 3 LOOPS - S.P.    
C     11/16/76 - USE NORMALIZED DERIVATIVES FOR MATCHING.               
C     3/7/77 - FIX SMALL BUG IN CHOICE OF NMTOP                         
C     6/23/78 - DON=T COMPARE TO XP WHEN NOT DEFINED (FOR CDC)          
C     5/4/79 - STORE RATMAS; PARITIES; USE BIGNUM - S.P.                
C     6/6/79 - REMOVE BOUNDV ENTRY, TBIT - RPG                          
C     6/8/79 - STANDARD PREFIXES, CHARACTER TYPE - RPG                  
C     7/6/79 - LINKULES AND MULTIPASS STUFF - RPG                       
C     1/14/80 - REPLACE MYSTERIOUS DROPPED CONTINUATION SYMBOL BEFORE   
C               STATEMENT 559 - RPG                                     
C     2/25/80 - DELETE FIRST INDEX FROM  LNKNAM  - RPG                  
C     6/3/80 - CHANGE PARPRT CALLS - S.P.                               
C     8/6/80 - IN DESPERATION, CALL LINKU2 FOR NOS - S.P.               
C                                                                       
C     NOTE...  THE CHANNEL NUMBER (1 OR 2) IS INPUT VIA  ICHANB BELOW   
C                                                                       
C     IFIT = 0  MEANS FIT E TO V.                                       
C            1  MEANS FIT V TO E.                                       
C                                                                       
C     ON OUTPUT:                                                        
C     IRET IS 1 IF BOUND WAS SUCCESSFUL  OR                             
C          IS 0 IF BOUND WAS NOT SUCCESSFUL                             
C     IVOUT POINTS TO THE COMPLETE POTENTIAL                            
C     IWF2 POINTS TO THE WAVEFUNCTION                                   
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      COMMON /FORMF/ IBDS(2), NPOTS(2), LBP, LBT, NBP, NBT, JBP, JBT, BN
     *DMAX(2), BNDSTP(2), NSTPBD(2), RBNDS(2), ABNDS(2), RCBNDS(2), BNDM
     *AS(2), BRATMS(2), RSOBDS(2), ASOBDS(2), VBNDS(2), VSOBDS(2), TAUBD
     *S(2), LNKADB(6,2,12)                                              
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
C                                                                       
C                                                                       
C     THESE EQUIVALENCES ARE IN COMMON /FORMF/.                         
C                                                                       
      DIMENSION LBNDS(2), NBNDS(2), JBNDS(2)                            
      EQUIVALENCE (LBNDS(1), LBP), (NBNDS(1), NBP), (JBNDS(1), JBP)     
C                                                                       
C                                                                       
C     THE X'S IN THESE NAMES GET REPLACED BY THE CHANNEL NUMBER.        
      CHARACTER*8 NAMES(2)                                              
      DATA NAMES/'PHIX', 'VBOUNDX'/                                     
CDC      INTEGER NAMES2(2) / 'PHIX', 'VBOUNDX' /                        
      CHARACTER*1 NAMES1(8, 2), CHAR                                    
      EQUIVALENCE ( NAMES(1), NAMES1(1) )                               
C                                                                       
      CHARACTER*8 CHANMS(2,3)                                           
      DATA CHANMS/'PROJECTI', 'LE', '    TARG', 'ET', ' ', ' '/         
C                                                                       
      DIMENSION UKS(3), ETAS(3), LWFS(3), UK2S(3), VS(3), DRIN(3),  DROU
     *T(3), PHIS(3), VALOUT(3), SUMOUT(3), SUMIN(3), NODCNT(3),  IPTYPS(
     *4)                                                                
      EQUIVALENCE ( LWFS(1), LWF1 ), ( LWFS(2), LWF2 ),  ( LWFS(3), LWF3
     * ), ( PHIS(1), PHI1 ), (PHIS(2), PHI2 ),  ( PHIS(3), PHI3 )       
C                                                                       
      CHARACTER*8 PWORD(3)                                              
      DATA PWORD/'-1', 'UNKNOWN', '+1'/                                 
      CHARACTER*1 CHNUM(9)                                              
      DATA CHNUM/'1', '2', '3', '4', '5', '6', '7', '8', '9'/           
CIB      CHARACTER*1 LINKID(4) / '*', '1', '0', '0' /                   
C  IFIT=1  MEANS FIT V0                                                 
C  IFIT=0  MEANS FIT E                                                  
C                                                                       
      LOGICAL PRNTSW, PCONSW, SOSW                                      
      DATA IPTYPS / 1, 3, 5, 6 /                                        
C                                                                       
CNS%'CALL LINKUL (' = 'CALL LINKU2 ('                                   
C                                                                       
CUN      NAMES1(I,J) = SUBSTR(NAMES(J),I,1)                             
C                                                                       
      ISEAR = 0                                                         
C                                                                       
  10  PCONSW = MOD(IPRINT/100, 10) .GE. 2                               
      PRNTSW = MOD(IPRINT, 10) .GE. 1                                   
C                                                                       
C   INITIALIZE PARAMETERS                                               
C	OPEN(UNIT=13,FILE='WFRPA',STATUS='OLD')

      IF ( ICHANB .GT. 9 ) ICHANB = 1                                   
      CHAR = CHNUM(ICHANB)                                              
      NAMES1(4,1) = CHAR                                                
      NAMES1(7,2) = CHAR                                                
CDC      ENCODE(20,2,NAMES)NAMES2(1),ICHANB,NAMES2(2),ICHANB            
CDC    2 FORMAT(A3,I1,6X,A6,I1)                                         
C                                                                       
      SOSW = VSO .NE. 0 .OR. TAU .NE. 0                                 
C                                                                       
C     60 IS A REASONABLE GUESS FOR V UNDER MANY CIRCUMSTANCES           
C                                                                       
      IF ( V .EQ. 0 ) V = 60                                            
C                                                                       
C     TEST THE INPUT AND RETURN  0  COMPLETION CODE IF BAD              
C                                                                       
      IRET = 1                                                          
      IF ( R .GT. 0 .AND. A .GT. 0 ) GO TO 30                           
      IF ( LNKADR(3,1) .GT. 0 ) GO TO 30                                
      WRITE(6,23) R, A                                                    
 23   FORMAT ('0**** R OR A HAS INVALID VALUE:', 2G15.5 )               
      IRET = 0                                                          
 30   IF ( .NOT. SOSW ) GO TO 40                                        
      IF ( RSO .GT. 0 .AND. ASO .GT. 0 ) GO TO 32                       
      IF ( LNKADR(3,3) .GT. 0 ) GO TO 32                                
      WRITE(6,31) RSO, ASO                                                
 31   FORMAT ( '0**** RSO OR ASO HAS INVALID VALUE:', 2G15.5 )          
      IRET = 0                                                          
 32   IF ( JP .NE. NOTDEF ) GO TO 34                                    
      WRITE(6,33)
 33   FORMAT ('0**** JP MUST BE DEFINED FOR SPIN ORBIT FORCE.')         
      IRET = 0                                                          
 34   IF ( JSP .NE. NOTDEF ) GO TO 36                                   
      WRITE(6,35)
 35   FORMAT ( '0**** WARNING:  SP WAS NOT DEFINED; ',  'IT IS ASSUMED T
     *O BE 1/2 FOR THE SPIN-ORBIT FORCE.' )                             
      JSP = 1                                                           
 36   IF ( JP .LE. JSP+2*L .AND. JP .GE. IABS(JSP-2*L)  .AND. MOD(JP+JSP
     *,2) .EQ. 0 ) GO TO 40                                             
      WRITE(6,37) L, JSP, JP                                              
 37   FORMAT ( '0**** ERROR: L, SP AND JP DO NOT FORM A TRIANGLE OR ',  
     *'THEY ARE MIXED INTEGER AND HALF-INTEGER: ',  I5, 2(I5, '/2') )   
      IRET = 0                                                          
 40   IF ( IFIT .EQ. 1 .AND. V .EQ. 0 ) V = 50                          
      IF ( IFIT .EQ. 0 .AND. E .EQ. UNDEF ) E = -15                     
      IF ( E .LT. 0 .AND. V .GT. 0 .AND. AM .GT. 0 .AND. E .NE. UNDEF ) 
     *GO TO 50                                                          
      WRITE(6,43) E, V, AM                                                
 43   FORMAT ('0**** E OR V OR M (REDUCED MASS) HAS INVALID',  ' VALUE:'
     *, 3G15.5 )                                                        
      IRET = 0                                                          
 50   IF ( R .LT. ASYMPT .OR. LNKADR(3,1) .GT. 0 ) GO TO 60             
      WRITE(6,53) R, ASYMPT                                               
 53   FORMAT ('0**** R MUST BE LESS THAN ASYMTOPIA:', 2G15.5 )          
      IRET = 0                                                          
 60   RCSAVE = RC                                                       
      IF ( RC .EQ. UNDEF .AND. IZP*IZT .EQ. 0 ) RC = 1                  
      IF ( RC .GT. 0 .OR. LNKADR(3,5) .GT. 0 ) GO TO 70                 
      WRITE(6,63) RC                                                      
 63   FORMAT ('0**** RC IS INVALID:', G15.5 )                           
      IRET = 0                                                          
 70   IF ( LNKADR(3,6) .GT. 0 ) GO TO 75                                
      IF ( L .NE. NOTDEF .AND. NODES .NE. NOTDEF ) GO TO 75             
      WRITE(6,73)
 73   FORMAT ( '0**** BOTH L AND NODES MUST BE DEFINED.' )              
      IRET = 0                                                          
 75   I = PARITY*PARIPT(1)*PARIPT(2)                                    
      IF ( I .EQ. 0 ) GO TO 80                                          
      I = (I+3)/2 + L                                                   
      IF ( MOD(I,2) .EQ. 0 ) GO TO 80                                   
      WRITE(6,78) L, PARITY, PARIPT                                       
 78   FORMAT ('0**** L AND PARITIES ARE INCOMPATABLE:', 4I5 )           
      IRET = 0                                                          
C                                                                       
  80  ITER=0                                                            
      ITERN=0                                                           
C                                                                       
      IF ( IRET .EQ. 0 ) GO TO 8875                                     
C                                                                       
C  K IS                                                                 
      UK=DSQRT(-2*AM*E)/HBARC                                           
      IF ( STPSPR .NE. UNDEF ) STEPSZ =  DMIN1( 1/UK, A ) / STPSPR      
      STPSZ2=STEPSZ*STEPSZ                                              
      AFAC=2.0D0*AM/(HBARC*HBARC)                                       
      DL2=L*(L+1)                                                       
C                                                                       
      NSTEPS=ASYMPT/STEPSZ+1.5                                          
C                                                                       
C     WE DO THE MATCHING BEYOND BOTH THE REAL RADIUS                    
C     AND THE LAST NODE.                                                
C                                                                       
      NMTOP = DMAX1(R, A)/STEPSZ + .5                                   
      NMTOP = MAX0( NMTOP, 20 )                                         
      NMBOT = MAX0( NMTOP-20, 3 )                                       
C                                                                       
      IWF2 = 0                                                          
      IVOUT = 0                                                         
C                                                                       
      NODEH = NODES                                                     
      IF ( IHSAVE .EQ. 2 ) GO TO 900                                    
C                                                                       
C  ASK FOR SPACE FOR POTENTIAL                                          
      IV1L= NALLOC( NSTEPS, 'BOUNDV1 ' )                                
      IV2L= NALLOC( NSTEPS, 'BOUNDV2 ' )                                
      IVOUT = NALLOC( NSTEPS, NAMES(2) )                                
C     AND SPACE FOR THE WAVE FUNCTIONS                                  
      IWF1= NALLOC( NSTEPS, 'BNDPHI1 ' )                                
      IWF2= NALLOC( NSTEPS, NAMES(1) )                                  
      IWF3= NALLOC( NSTEPS, 'BNDPHI3 ' )                                
C                                                                       
C     INITIALIZE THE LINKULES FOR CENTRAL, COULOMB, SPIN-ORBIT,         
C     AND WAVE FUNCTION.                                                
C                                                                       
      DO 99 II = 1, 4                                                   
      I = IPTYPS(II)                                                    
      IF ( LNKADR(3,I) .EQ. 0 ) GO TO 99                                
      IUNIQU = IUNIQU + 1                                               
CIB         CALL I4LIT ( IUNIQU, LINKID(2), -3 )                        
      ENCODE ( 4, 103, LINKID ) IUNIQU                                  
 103  FORMAT ( 1H*, I3 )                                                
      CALL LINKUL ( LNKADR(3,I), LNKNAM(1,I), LNKADR(5,I), I, 1,  IRETUR
     *, L, JP, 0.D0, STEPSZ, NSTEPS, DUMMY, DUMMY, LINKID )             
      IF ( IRETUR .LT. 0 ) GO TO 295                                    
      LNKADR(4,I) = IRET                                                
 99   CONTINUE                                                          
C                                                                       
C     NO MORE ALLOCATOR CALLS SO GET LOCATIONS FOR REST OF SUBROUTINE   
C                                                                       
      LV1 = Z(IV1L)                                                     
      LV2 = Z(IV2L)                                                     
      LVOUT = Z(IVOUT)                                                  
      LWF1 = Z(IWF1)                                                    
      LWF2 = Z(IWF2)                                                    
      LWF3 = Z(IWF3)                                                    
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C  AFINE IS FINE STRUCTURE CONSTANT                                     
C NEED CI1,CI2 FOR COULOMB POTENTIAL INSIDE NUCLEAR RADIUS              
C                                                                       
      CI1=IZP*IZT*HBARC*1.5D0/(AFINE*RC)                                
      CI2=IZP*IZT*HBARC*.5D0/(AFINE*RC*RC*RC)                           
C                                                                       
C  C0 IS COLOUMB OUTSIDE OF POTENTIAL                                   
C                                                                       
      C0=IZP*IZT*HBARC/AFINE                                            
C                                                                       
C                                                                       
C  CALCULATE POTENTIAL AT ALL STEPS                                     
C                                                                       
C     THE ARRAYS ARE                                                    
C                                                                       
C     ALLOC(LV1) = -(FIXED PART OF V) -- FIXED PART INCLUDES COULOMB    
C          D      AND VSO PART OF SPIN ORBIT.                           
C     ALLOC(LV2) = -(VARIABLE PART OF V)/DEPTH -- INCLUDES REAL W.S.    
C                  WELL AND TAU PART OF SPIN ORBIT.                     
C                                                                       
C     TOTAL POTENTIAL IS                                                
C        -( ALLOC(LV1) + V*ALLOC(LV2) )                                 
C     ALLOC(LVOUT) = -(FIXED PART OF EFFECTIVE TRANSITION OPERATOR)     
C                                                                       
C     IN EACH CASE                                                      
C        ALLOC(L+I) = V( STEPSIZE*(I-1) )                               
C                                                                       
C                                                                       
C     GET THE COULOMB POTENTIAL.                                        
C                                                                       
      VMUL = -1.                                                        
      I = 5                                                             
      LL = LV1                                                          
      ASSIGN 150 TO JUMP                                                
      IF ( LNKADR(3,5) .GT. 0 ) GO TO 290                               
      RVAL = -STEPSZ                                                    
      DO 139 I = 1, NSTEPS                                              
      RVAL = RVAL + STEPSZ                                              
      IF ( RVAL .GE. RC ) GO TO 120                                     
      VC = CI1 - CI2*(RVAL**2)                                          
      GO TO 130                                                         
 120  VC = C0/RVAL                                                      
 130  ALLOC(LV1-1+I) = -VC                                              
 139  CONTINUE                                                          
C                                                                       
C     INITIALIZE THE FIXED PART OF THE EFFECTIVE TRANSITION OPERATOR.   
C                                                                       
 150  DO 159 I = 1, NSTEPS                                              
      ALLOC(LVOUT-1+I) = 0                                              
      IF ( NUCONL .NE. 1 ) ALLOC(LVOUT-1+I) = ALLOC(LV1-1+I)            
 159  CONTINUE                                                          
C                                                                       
C     NOW THE CENTRAL POTENTIAL                                         
C                                                                       
      VMUL = -1./V                                                      
      I = 1                                                             
      LL = LV2                                                          
      ASSIGN 180 TO JUMP                                                
      IF ( LNKADR(3,1) .GT. 0 ) GO TO 290                               
      CALL WOODSX ( NSTEPS, 0.D0, STEPSZ, ALLOC(LV2), N1, N2,  1, -1.D0,
     * R, A, POWRL )                                                    
C                                                                       
C     NOW THE SPIN-ORBIT POTENTIAL (IF ANY)                             
C                                                                       
 180  IF ( .NOT. SOSW ) GO TO 300                                       
C     THIS IS SIGMA.L.  NOTE THAT JP, JSPS ARE DOUBLED.                 
      ALS = JP*(JP+2) - JSP*(JSP+2)                                     
      ALS = (0.25*ALS - DL2)/JSP                                        
      BLS = TAU*ALS                                                     
      ALS = VSO*ALS                                                     
      VSOSV = VSO                                                       
      VSO = 1.                                                          
      VMUL = -1.                                                        
      I = 3                                                             
      LL = LWF1                                                         
      ASSIGN 200 TO JUMP                                                
      IF ( LNKADR(3,3) .GT. 0 ) GO TO 290                               
      CALL WOODSX ( NSTEPS, 0.D0, STEPSZ, ALLOC(LWF1), N1, N2,  2, -1.D0
     *, RSO, ASO, 1.D0 )                                                
C     SPLIT SPIN-ORBIT INTO FIXED (VSO) AND VARIABLE (TAU) PARTS.       
 200  DO 209 I = 1, NSTEPS                                              
      ALLOC(LV1-1+I) = ALLOC(LV1-1+I) + ALS*ALLOC(LWF1-1+I)             
      ALLOC(LVOUT-1+I) = ALLOC(LVOUT-1+I) + ALS*ALLOC(LWF1-1+I)         
      ALLOC(LV2-1+I) = ALLOC(LV2-1+I) + BLS*ALLOC(LWF1-1+I)             
 209  CONTINUE                                                          
      VSO = VSOSV                                                       
      GO TO 300                                                         
C                                                                       
C     GET THE POTENTIAL FROM A LINKULE.                                 
C                                                                       
 290  CALL LINKUL ( LNKADR(3,I), LNKNAM(1,I), LNKADR(5,I),  I, 3, IRETUR
     *, L, JP,  0.D0, STEPSZ, NSTEPS, ALLOC(LL), -1.D0, 0 )             
      IF ( IRETUR .GE. 0 ) GO TO JUMP, ( 150, 180, 200 )                
 295  IRET = 0                                                          
      RETURN                                                            
C                                                                       
C                                                                       
C     NOW CALCULATE THE WAVE FUNCTION.                                  
C                                                                       
C     IF A LINKULE DOES IT, SKIP MOST OF THE FOLLOWING.                 
C                                                                       
 300  IF ( LNKADR(3,6) .GT. 0 ) GO TO 800                               
C                                                                       
C     WE FIND SOLUTIONS FOR THREE VALUES OF V OR K.  DELTA IS THE       
C     RELATIVE SPACING TO USE.  AS APPROPRIATE, DELTAV OR DELTAK ARE    
C     THE ABSOULTE SPACINGS TO USE.  SOLUTIONS ARE FOUND FOR            
C     V-DELTAV, V, V+DELTAV   OR   K-DELTAK, K, K+DELTAK                
C                                                                       
 3020 DELTA = DELTVK                                                    
      IF (PCONSW) WRITE(6,771) ITER,V,UK, DELTA                         
      VST = V                                                           
      UKST = UK                                                         
C                                                                       
C     SET K+, K, K- AND CORRESPONDING ETAS EACH TIME E CHANGES          
C     (THIS IS FOR WHEN E AND NOT V IS BEING VARIED)                    
C                                                                       
 3030 IF(IFIT.EQ.1)GO TO 301                                            
      DELTAK = UK*DELTA                                                 
      DELTAV = 0                                                        
      GO TO 302                                                         
 301  DELTAV = V*DELTA                                                  
      DELTAK = 0                                                        
C                                                                       
 302  UKM = UK-DELTAK                                                   
      UKP=UK+DELTAK                                                     
      UKS(1) = UKM                                                      
      UKS(2) = UK                                                       
      UKS(3) = UKP                                                      
      DO 329 I = 1, 3                                                   
      UK2S(I) = UKS(I)**2                                               
      ETAS(I) = IZP*IZT*AM/(HBARC*AFINE*UKS(I))                         
 329  CONTINUE                                                          
      ETA = ETAS(2)                                                     
C                                                                       
C     FIND ASYMPTOTIC FORM AS A WHITTAKER FUNCTION.                     
C     IASYMP = 1 ( SKIPASYMP )  MEANS TO JUST USE 2 AND 1 AS THE        
C            LAST TWO FUNCTION VALUES.  IF THIS IS ELECTED THEN         
C            ASYMPTOPIA MUST BE EXTENDED BY ABOUT 5 FM TO GIVE          
C            THE WAVEFUNCTION TIME TO HEAL TO THE CORRECT FORM.         
C                                                                       
      RGET = ASYMPT - STEPSZ                                            
C                                                                       
C     WE NEED A NORM TERM THAT IS SMALL FOR SMALL RHO AND               
C     ETA+L+1 FOR LARGE RHO.  WHEN THE WHITTAKER IS DIVIDED BY          
C     GAMMA(THIS NORM) IT WILL GENERALLY NOT BE TOO LARGE OR SMALL      
C                                                                       
      TEMP = RGET*UK                                                    
      TEMP = (L+ETA+1) * (TEMP/(2+TEMP))**2                             
C                                                                       
C                                                                       
      DO 359 II = 1, 2                                                  
      DO 349 I = 1, 3                                                   
      IF ( I .GT. 1 .AND. IFIT .EQ. 1 ) GO TO 345                       
      IF ( IASYMP .EQ. 1 ) GO TO 340                                    
      X = COULNG( L, ETAS(I), UKS(I)*RGET, TEMP )                       
C                                                                       
C     COULNG RETURNS THE WHITTAKER TIMES A FACTOR.  HERE WE             
C     PATCH UP THE RATIO BETWEEN W(ASYMPT-STEPSZ) AND W(ASYMPT)         
C                                                                       
      IF ( II .EQ. 1 ) X = X *  DEXP( UKS(I)*STEPSZ + ETAS(I)*DLOG(ASYMP
     *T/RGET) )                                                         
      GO TO 345                                                         
 340  X = (3-II)                                                        
 345  ALLOC(LWFS(I)+NSTEPS-3+II) = X                                    
 349  CONTINUE                                                          
      RGET = RGET + STEPSZ                                              
 359  CONTINUE                                                          
      IF (PCONSW)WRITE(6,363)ALLOC(LWF2+NSTEPS-2),ALLOC(LWF2+NSTEPS-1)
 363  FORMAT ( ' ASYMPTOTIC FORM AT LAST TWO STEPS:', 2G18.8 )          
C                                                                       
C  NOW HAVE ASYMPTOTIC WAVEFUNCTIONS                                    
C                                                                       
C  STEP INTO MATCHING RADIUS                                            
C                                                                       
C     FIND THE MAXIMUM VALUE OF THE MINIMUM OVER V-DELTA, V, V+DELTA,   
C     OF THE WAVEFUNCTION IN THE INNER 20 STEPS AND USE AS THE MATCHING 
C     RADIUS.                                                           
C                                                                       
C     WE COME HERE FOR EACH NEW VALUE OF V                              
C                                                                       
 500  VS(1) = V-DELTAV                                                  
      VS(2) = V                                                         
      VS(3) = V+DELTAV                                                  
C                                                                       
      XX = 0                                                            
      NGO=NSTEPS-NMBOT+1                                                
      DO 529 I=3,NGO                                                    
      II=NSTEPS-I+1                                                     
      ALL= DL2/(STEPSZ*II)**2                                           
      TEMP = BIGNUM                                                     
      DO 519 IVK = 1, 3                                                 
      K = LWFS(IVK)+II                                                  
      X = VS(IVK)*ALLOC(LV2+II)+ALLOC(LV1+II)                           
      X = 2 + STPSZ2*(UK2S(IVK) - AFAC*X + ALL)                         
      ALLOC(K-1) = X*ALLOC(K)-ALLOC(K+1)                                
      TEMP = DMIN1( TEMP, DABS(ALLOC(K)) )                              
 519  CONTINUE                                                          
      IF ( II .GT. NMTOP ) GO TO 529                                    
      IF ( TEMP .LE. XX ) GO TO 529                                     
      NMATCH = II                                                       
      XX = TEMP                                                         
529   CONTINUE                                                          
C                                                                       
C     COMPUTE OUTER MATCHING PARAMETERS -- DERIVATIVES, NORM            
C     OF OUTER PART, VALUE AT MATCHING POINT AND NUMBER OF NODES.       
C                                                                       
      DO 539 IVK = 1, 3                                                 
      K = LWFS(IVK) + NMATCH                                            
      DROUT(IVK) = (.5/STEPSZ)*(ALLOC(K+1)-ALLOC(K-1))                  
      VALOUT(IVK) = ALLOC(K)                                            
      NODCNT(IVK) = 0                                                   
      SUMIN(IVK) = 0                                                    
      SUMOUT(IVK) = .5*(ALLOC(K)**2 + ALLOC(LWFS(IVK)+NSTEPS-1)**2)     
      NGO = NMATCH+3                                                    
      DO 539 II = NGO, NSTEPS                                           
      K = LWFS(IVK)-2+II                                                
      SUMOUT(IVK) = SUMOUT(IVK) + ALLOC(K)**2                           
C     HERE WE COUNT THE NODE IF IT IS EXACTLY AT R(MATCH)               
      IF ( ALLOC(K)*ALLOC(K-1) .LE. 0 ) NODCNT(IVK) = NODCNT(IVK) +1    
 539  CONTINUE                                                          
C                                                                       
C  FIND POWER SERIES SOLUTION (KEEP FIRST TWO TERMS) IN ORDER           
C  TO FIX FUNCTION AT FIRST STEP.  THEN STEP TO MATCHING RADIUS         
C                                                                       
C     FOLLOWING IS AN APPROXIMATE EXPRESION AND NEED NOT BE TOO         
C     ACCURATE.  THIS EXPRESSION IS SUCH THAT FOR L = 0                 
C        PHI(R) = U(R)/R ---> 1   FOR R = 0.  (BEFORE NORMALIZATION)    
C     WE USE THIS FACT ONLY FOR L = 0 SO WE CAN LATER ON EXTRACT        
C     PHI(0).  REALLY THIS IS JUST FINESSE SINCE PHI(0) IS NEVER        
C     SIGNIFICANT.  SINCE THIS VALUE IS SIGNIFICANT ONLY FOR L = 0,     
C     WE ASSUME L = 0 AND THUS IGNORE SPIN-ORBIT FORCES.                
C                                                                       
C     INCLUDE IT.                                                       
C                                                                       
      DO 559 IVK = 1, 3                                                 
      K = LWFS(IVK)                                                     
      ALLOC(K)=0.0D0                                                    
C                                                                       
C     POTENTIAL + K**2  AT R = STEPSZ.                                  
C                                                                       
      TEMP = -AFAC * ( ALLOC(LV1+1) + VS(IVK)*ALLOC(LV2+1) )  + UK2S(IVK
     *)                                                                 
      ALLOC(K+1) = STEPSZ * ( 1 + STPSZ2*TEMP/6 )                       
 559  CONTINUE                                                          
C                                                                       
C  STEP OUT TO MATCHING RADIUS                                          
C                                                                       
      DO 589 II=1, NMATCH                                               
      ALL= DL2/(STEPSZ*II)**2                                           
      DO 589 IVK = 1, 3                                                 
      K = LWFS(IVK)+II                                                  
      X = VS(IVK)*ALLOC(LV2+II)+ALLOC(LV1+II)                           
      X = 2 + STPSZ2*(UK2S(IVK) - AFAC*X + ALL)                         
      ALLOC(K+1) = X*ALLOC(K)-ALLOC(K-1)                                
      SUMIN(IVK) = SUMIN(IVK) + ALLOC(K)**2                             
      IF ( ALLOC(K)*ALLOC(K-1) .LT. 0 ) NODCNT(IVK) =  NODCNT(IVK) + 1  
589   CONTINUE                                                          
C                                                                       
C     MATCH SOLUTIONS;  DERIVATIVES FOR INNER SIDE.                     
C                                                                       
      DO 599 IVK = 1, 3                                                 
      K = LWFS(IVK) + NMATCH                                            
      SUMIN(IVK) = SUMIN(IVK) - .5*ALLOC(K)**2                          
C                                                                       
C     SUMOUT MULTIPLIES THE OUTER SOLUTION TO NORMALIZE IT              
C     SUMIN  MULTIPLIES THE INNER SOLUTION TO NORMALIZE IT              
C                                                                       
      XX = ALLOC(K)/VALOUT(IVK)                                         
      X = 1/DSQRT( STEPSZ*(SUMIN(IVK) + XX**2*SUMOUT(IVK)) )            
      SUMIN(IVK) = X                                                    
      SUMOUT(IVK) = XX*X                                                
      VALOUT(IVK) = (XX*X) * VALOUT(IVK)                                
      DROUT(IVK) = (XX*X) * DROUT(IVK)                                  
      DRIN(IVK) = X * (.5/STEPSZ)*(ALLOC(K+1)-ALLOC(K-1))               
      PHIS(IVK) = DROUT(IVK) - DRIN(IVK)                                
 599  CONTINUE                                                          
C                                                                       
C     WE LOOK FOR A ZERO OF THE DIFFERENCE OF THE INNER AND OUTER       
C     DERIVATIVES.                                                      
C                                                                       
      NODEH = NODCNT(2)                                                 
      X = NMATCH*STEPSZ                                                 
      IF (PCONSW) WRITE(6,7853) X,VS,DRIN,UKS,DROUT,VALOUT,PHIS,NO
     *DCNT                                                              
 7853 FORMAT (' DERIVATIVES AT R =', F7.2, ' FM' ,  T86, 'V =', 3G15.6 /
     *  T5, 'INNER =', 3G16.6 , T86, 'K =', 3G15.6 /  T4, 'OUTER =', 3G1
     *6.6 , T83, 'U(R) =', 3G15.6 /  T7, 'DIF =', 3G16.6 , T82, 'NODES =
     *', 3(I9, 6X) )                                                    
      IF(DABS(PHI2).LT.ACCURA)GO TO 600                                 
      PPHI2=DABS(PHI2)                                                  
      IF (PCONSW) WRITE(6,7854)ITER,PPHI2,ACCURA                        
7854  FORMAT(' FOR ITER=',I3,' THE  FUNCTION IS',G11.3,' >',G11.3)      
      IF(ITER.GT.MAXITR)GO TO 1001                                      
      DP=(PHI3-PHI1)/(2.0D0*DELTA)                                      
      DPP=(PHI3-2.0D0*PHI2+PHI1)/(DELTA*DELTA)                          
      XL=-PHI2/DP                                                       
      XQ = 0                                                            
      X = XL                                                            
C                                                                       
C  IF DPP IS ZERO DO LINEAR APPROXIMATION                               
C                                                                       
      IF ( DABS(DPP) .LT. 1.E-5*DABS(DP) ) GO TO 7398                   
      CSQRT=(DP*DP)-2.0D0*PHI2*DPP                                      
      IF(CSQRT.LT.0)GO TO 7398                                          
C                                                                       
      XQ =(-DP+(DP/DABS(DP))*DSQRT(CSQRT))/DPP                          
      IF ( LINEAR .NE. 1 ) X = XQ                                       
C                                                                       
 7398 IF ( DABS(X) .GT. .5 ) X = DSIGN( .5 0D0, X )                     
      IF (PCONSW) WRITE(6,9123)DP,DPP, XL, XQ, X                        
9123  FORMAT(' DP,DPP =',2G14.5 /  ' LINEAR, QUADRATIC METHODS =', 2G12.
     *3,  5X, 'REL. STEP OF V OR K USED =', G14.5 )                     
C                                                                       
C     FIND A NEW DELTAVK.  WE USE THE STEP LENGTH USED IN THIS          
C     ITERATION UNLESS IT STAYED WITHIN THE THE PREVIOUS DELTA,         
C     INWHICH CASE WE USE .5 OF IT.                                     
C                                                                       
      XX = DELTA                                                        
      DELTA = DABS(X)                                                   
      IF ( DELTA .LT. XX ) DELTA = .5*DELTA                             
      IF(DELTA.LT.(1.0D-7))DELTA=1.0D-7                                 
      DELTA = DMIN1( DELTA, .2 0D0 )                                    
      IF(IFIT.NE.0)GO TO 3070                                           
      XX = UK*(1+X)                                                     
      IF(XX.LE.0.0D0)UK=UK/2.0D0                                        
      IF(XX.GT.0.0D0)UK=XX                                              
      GO TO 3737                                                        
 3070 XX = V*(1+X)                                                      
      IF ( XX .GT. 0 ) V = XX                                           
      IF ( XX .LE. 0 ) V = .5*V                                         
 3737 ITER = ITER + 1                                                   
      IF (PCONSW) WRITE(6,771) ITER,V,UK, DELTA                         
 771  FORMAT ( ' ITERATION', I3, 5X, 'V =', G16.8, '  K =', G16.8,  5X, 
     *'DELTAVK =', G12.4 )                                              
      IF(IFIT.EQ.0)GO TO 3030                                           
      DELTAV = DELTA*V                                                  
      GO TO 500                                                         
C                                                                       
C  MAXITRTER EXCEDED.  SEE IF WE HAVE RIGHT NUMBER OF NODES             
C                                                                       
 1001 IF(NODES.NE.NODEH)GO TO 6666                                      
      WRITE(6,901)                                                      
CXX      IF(ISEAR.EQ.0)GO TO 1111                                       
CXX      E=99.99D0                                                      
CXX      IRET = 0                                                       
CXX      GO TO 8875                                                     
901   FORMAT(' ******** NO SOLUTION FOUND *********')                   
C                                                                       
C     RETURN AFTER A FAILURE                                            
C                                                                       
 1111 IRET = 0                                                          
      GO TO 850                                                         
C                                                                       
C     HAVE CONVERGED ON A V OR UK - CHECK FOR PROPER NUMBER OF NODES    
C                                                                       
600   PPHI2=DABS(PHI2)                                                  
      IF (PCONSW) WRITE(6,8457)ITER,PPHI2,ACCURA                        
8457  FORMAT(' ON ITERATION ',I3,' THE FUNCTION IS',G11.3,' <',  G11.3) 
      E=-UK2S(2)*HBARC*HBARC/(2.0D0*AM)                                 
      IF (PCONSW) WRITE(6,5546)V,E                                      
5546  FORMAT(/'   FIT LOCATED WITH V=',F14.8,' AND E=',F14.8/)          
C                                                                       
C                                                                       
C  RENORMALIZE WAVEFUNCTION AND CHECK NODES                             
C                                                                       
      IF(NODEH.EQ.NODES)GO TO 6041                                      
C                                                                       
C     SOLUTION HAS WRONG NUMBER OF NODES - TRY ANOTHER V OR UK          
C                                                                       
 6666 WRITE(6,6044) V, E, NODEH,NODES                                   
6044  FORMAT(' FOR V =', F8.2, ',  E =', F7.2, ', WAVEFUNCTION HAS',  I3
     *, ' NODES BUT', I3, ' ARE DESIRED.' )                             
      IF ( ITERN .LE. MAXITR ) GO TO 6668                               
      WRITE(6,6667) NODES                                                 
 6667 FORMAT ( '0**** COULD NOT FIND A SOLUTION WITH', I3, ' NODES.')   
      GO TO 1111                                                        
 6668 ITER=0                                                            
      ITERN=ITERN+1                                                     
C                                                                       
C     WE USE                                                            
C                                                                       
C       X = DESIRED NUMBER OF NODES                                     
C       XQ = NUMBER OF NODES WE JUST GOT                                
C       XP = PREVIOUS NUMBER OF NODES                                   
C       PHI1 = PRESENT V OR K                                           
C       PHI2 = NEXT V OR K                                              
C       PHIP = PREVIOUS V OR K                                          
C                                                                       
      X = NODES                                                         
      XQ = NODEH                                                        
C                                                                       
C     WE USE THE STARTING OR FINAL V OR K, WHICH EVER IS CLOSER         
C     TO WHERE WE WANT TO GO.                                           
C                                                                       
      IF ( NODES .LT. NODEH ) GO TO 8130                                
      V = DMAX1( V, VST )                                               
      UK = DMIN1( UK, UKST )                                            
      GO TO 8150                                                        
 8130 V = DMIN1( V, VST )                                               
      UK = DMAX1( UK, UKST )                                            
 8150 PHI1 = V                                                          
      IF ( IFIT .EQ. 0 ) PHI1 = UK**2                                   
      IF ( ITERN .LE. 1) GO TO 8160                                     
      IF ( XP .NE. XQ ) GO TO 8200                                      
C                                                                       
C     WE HAVE ONLY ONE POINT TO WORK WITH                               
C                                                                       
 8160 IF ( IFIT .EQ. 0 ) GOTO 8170                                      
      PHI2 = (X+1)*PHI1/(XQ+1)                                          
      GO TO 8300                                                        
 8170 PHI2 = ( 1 + (XQ-X)/(XQ+1) )*PHI1                                 
      GO TO 8300                                                        
C                                                                       
C     HAVE TWO POINTS - USE STRAIGHT LINE                               
C                                                                       
 8200 PHI2 = PHI1 + (X-XQ)*(PHI1-PHIP)/(XQ-XP)                          
C                                                                       
C     DO NOT ALLOW TO GO NEGATIVE                                       
C                                                                       
 8300 IF ( PHI2 .LE. 0 ) PHI2 = .5*PHI1                                 
C                                                                       
      PHIP = PHI1                                                       
      XP = XQ                                                           
      IF ( IFIT .EQ. 1 ) GO TO 8350                                     
      UK = DSQRT(PHI2)                                                  
      E = -(UK*HBARC)**2 / (2*AM)                                       
      WRITE(6,4459) E                                                   
4459  FORMAT(' WILL TRY A NEW E: ', G14.5 )                             
      GO TO 3020                                                        
 8350 V = PHI2                                                          
      WRITE(6,7210)V                                                    
7210  FORMAT(' WILL TRY A NEW V:  ',G14.5)                              
      GO TO 3020                                                        
C                                                                       
C     SOLUTION HAS PROPER NUMBER OF NODES - CLEAN UP                    
C                                                                       
 6041 IF (PCONSW) WRITE(6,5564)NODES,L, JP                              
5564  FORMAT('  SOLUTION HAS ',I1,' NODE(S). L=',I2,' JP=',I2,'/2')     
      GO TO 850                                                         
C                                                                       
C                                                                       
C     WAVE FUNCTION IS CALCULATED BY A LINKULE.                         
C     ARRAY1 IS THE ANSWER, ARRAY2 IS (-1/V)*THE VARIABLE POTENTIAL,    
C     ID IS A POINTER TO -1*THE FIXED POTENTIAL.                        
C                                                                       
 800  CALL LINKUL ( LNKADR(3,6), LNKNAM(1,6), LNKADR(5,6), 6, 3,  IRETUR
     *, L, JP, 0.D0, STEPSZ, NSTEPS,  ALLOC(LWF2), ALLOC(LV2), LV1 )    
      IF ( IRETUR .LT. 0 ) GO TO 295                                    
      SUMIN(2) = 1                                                      
      SUMOUT(2) = 1                                                     
      NMATCH = NSTEPS/2                                                 
      NODEH = NODES                                                     
C                                                                       
C     NORMALIZE THE SOLUTION AND CONVERT TO   PHI = U/R                 
C                                                                       
 850  RVAL = STEPSZ                                                     
      NGO = NMATCH + 1                                                  
      DO 859 II = 1, NGO                                                
      ALLOC(LWF2+II) = SUMIN(2)*ALLOC(LWF2+II)/RVAL                     
      RVAL = RVAL + STEPSZ                                              
 859  CONTINUE                                                          
      NGO = NGO + 2                                                     
      DO 869 II = NGO, NSTEPS                                           
      ALLOC(LWF2-1+II) = SUMOUT(2)*ALLOC(LWF2-1+II)/RVAL                
      RVAL = RVAL + STEPSZ                                              
 869  CONTINUE                                                          
C                                                                       
C     FOR L = 0 GET WAVEFUNCTION AT ORIGIN BASED ON STARTING            
C     VALUE DEFINED ABOVE                                               
C                                                                       
      IF ( L .EQ. 0 ) ALLOC(LWF2) = SUMIN(2)                            
C                                                                       
C     FOR L=0 WAVEFUNCTIONS FROM LINKULES, WE EXTRAPOLATE, USING THE    
C     FACT THAT THE DERIVATIVE = 0 AT R=0.                              
C                                                                       
      IF ( L .EQ. 0 .AND. LNKADR(3,6) .GT. 0 )  ALLOC(LWF2) = ( 4*ALLOC(
     *LWF2+1) - ALLOC(LWF2+2) )/3                                       
C                                                                       
C  FREE SECONDARY AREAS HERE                                            
C                                                                       
      Z(IWF1)=-Z(IWF1)                                                  
      Z(IWF3)=-Z(IWF3)                                                  
      Z(IV1L) = -Z(IV1L)                                                
C                                                                       
C     PRINT RESULTS NICELY                                              
C                                                                       
 900  IF ( .NOT. PRNTSW ) GO TO 990                                     
      I = ICHANB                                                        
      IF ( I .GT. 2 ) I = 3                                             
      UK = DSQRT(-2*AM*E)/HBARC                                         
      ETA = IZP*IZT*AM / (HBARC*AFINE*UK)                               
      WRITE(6,913) CHANMS(1,I), CHANMS(2,I), E, UK                        
 913  FORMAT ( / X, T10, A8, A2, ' BOUND STATE PARAMETERS' /  ' E =', 
     *F10.4, ' MEV', 5X, 'KAPPA =', F8.5 )                              
      Q1 = 0                                                            
      Q2 = 0                                                            
      Q3 = 0                                                            
      IF ( AMP .EQ. UNDEF .OR. AMT .EQ. UNDEF ) GO TO 920               
      WRITE(6,918) AMP, AMT, AM                                           
 918  FORMAT ( ' PROJECTILE MASS =', F7.2, ' AMU', 5X,  'TARGET MASS =',
     * F7.2, ' AMU', 5X,  'REDUCED MASS =', F10.2, ' MEV/C**2' )        
      GO TO 925                                                         
 920  WRITE(6,923) AM                                                     
 923  FORMAT ( ' REDUCED MASS =', F10.2, ' MEV/C**2' )                  
 925  WRITE(6,928) L, NODEH                                               
 928  FORMAT ( ' L =', I3, I9, ' NODES' )                               
      IF ( JSP .NE. NOTDEF .AND. JST .NE. NOTDEF ) WRITE(6,933)JSP,JST 
 933  FORMAT ( ' PROJECTILE SPIN =', I3, '/2', 5X,  'TARGET SPIN =', I3,
     * '/2' )                                                           
      IF ( JP .NE. NOTDEF ) WRITE(6,935) JP                               
 935  FORMAT (' J PROJECTILE =', I3, '/2' )                             
      IF ( J .NE. NOTDEF ) WRITE(6,937) J                                 
 937  FORMAT ( ' TOTAL J =', I3, '/2' )                                 
      WRITE(6,943)PWORD(PARIPT(1)+2),PWORD(PARIPT(2)+2),PWORD(PARITY+2)
 943  FORMAT ( ' PROJECTILE PARITY IS ', A7,  '   TARGET PARITY IS ', A7
     *,  '   TOTAL PARITY IS ', A7 )                                    
      WRITE(6,953) IZP, IZT                                               
 953  FORMAT (' Z PROJECTILE =',I4,5X,'Z TARGET =',I4 /' POTENTIAL', 
     *T20, 'COUPLING CONS.', T38, 'RADIUS',  T48, 'DIFFUSENESS', T63
     *, 'RADIUS PARAM.' )                                               
      CALL PARPRT (1,'REAL CENTRAL',V,R,A,R/R0MASS,POWRL,
     *'   POWER',IRETUR )                                                    
      CALL PARPRT (3,'REAL SPIN-ORBIT',VSO,RSO,ASO,RSO/R0MASS,
     *TAU, '     TAU',IRETUR )                                           
      CALL PARPRT (5,'PT.&SPHERE COULOMB',ETA,RC,0.D0,RC/R0MASS, 
     *0.D0,'        ',IRETUR )                                        
C                                                                       
      TEMP = DMIN1( 1/UK, A ) / STEPSZ                                  
      WRITE(6,963) ASYMPT, STEPSZ, TEMP                                   
 963  FORMAT ( ' ASYMPTOPIA =', T15, F8.3, ' FM' /  ' STEP SIZE =', T15,
     * F8.3, ' FM' ,  5X, F8.3, ' STEPS PER "ASYMPTOTIC RANGE"' / )     
C                                                                       
C     IF THE WAVEFUNCTION IS CALCULATED BY A LINKULE, CALL IT TO        
C     PRINT STUFF ABOUT ITSELF.                                         
C                                                                       
      IF ( LNKADR(3,6) .EQ. 0 ) GO TO 990                               
      WRITE(6,973) LNKNAM(1,6)                                            
 973  FORMAT ( '  THE BOUND WAVEFUNCTION WAS COMPUTED BY THE ', A8,  ' L
     *INKULE:' )                                                        
      CALL LINKUL ( LNKADR(3,6), LNKNAM(1,6), LNKADR(5,6), 6, 2,  IRETUR
     *, L, JP, 0.D0, STEPSZ, NSTEPS,  ALLOC(LWF2), ALLOC(LV2), LV1 )    
      IF ( IRETUR .LT. 0 ) GO TO 295                                    
      WRITE(6,983)
 983  FORMAT ( 1X )                                                     
C                                                                       
C                                                                       
C     SAVE THE POTENTIAL AND OTHER STUFF FOR GRDSET                     
C                                                                       
 990  IF ( ICHANB .GT. 2 .OR. ICHANB .LT. 1 ) GO TO 6330                
      IBDS(ICHANB) = IWF2                                               
      NPOTS(ICHANB) = IVOUT                                             
      LBNDS(ICHANB) = L                                                 
      NBNDS(ICHANB) = NODES                                             
      JBNDS(ICHANB) = JP                                                
      BNDMAX(ICHANB) = ASYMPT                                           
      BNDSTP(ICHANB) = STEPSZ                                           
      NSTPBD(ICHANB) = NSTEPS                                           
      RBNDS(ICHANB) = R                                                 
      ABNDS(ICHANB) = A                                                 
      RCBNDS(ICHANB) = RC                                               
      BNDMAS(ICHANB) = AM                                               
      EBNDS(ICHANB) = E                                                 
      BRATMS(ICHANB) = RATMAS                                           
C                                                                       
C     THE FOLLOWING WILL BE NEEDED FOR THE NEXT PASS (IF ANY).          
C                                                                       
      RSOBDS(ICHANB) = RSO                                              
      ASOBDS(ICHANB) = ASO                                              
      VBNDS(ICHANB) = V                                                 
      VSOBDS(ICHANB) = VSO                                              
      TAUBDS(ICHANB) = TAU                                              
      DO 993 I = 1, 12                                                  
      DO 993 II = 1, 6                                                  
      LNKADB(II,ICHANB,I) = LNKADR(II,I)                                
 993  CONTINUE                                                          
C                                                                       
C     CAN WE COMPUTE THE Q OF THE REACTION                              
C                                                                       
      IF ( EBNDS(3-ICHANB) .EQ. UNDEF ) GO TO 6330                      
      Q = EBNDS(1) - EBNDS(2)                                           
      IF ( ISTRIP .EQ. -1 ) Q = -Q                                      
C                                                                       
 6330 IF ( IHSAVE .EQ. 2 ) GO TO 8875                                   
C                                                                       
C     CONSTRUCT THE COMPLETE POTENTIAL FOR V PHI                        
C                                                                       
      DO 6339 I = 1, NSTEPS                                             
      ALLOC(LVOUT-1+I) = -( ALLOC(LVOUT-1+I)  + V*ALLOC(LV2-1+I) )      
 6339 CONTINUE                                                          
      Z(IV2L) = -Z(IV2L)                                                
C                                                                       
C     IF REQUESTED, PRINT THE WAVEFUNCTION                              
C                                                                       
      RVAL=0.0D0                                                        
      IF(WRITES .LE. 0)GO TO 8875                                       
      NWRITE = DMAX1( WRITES/STEPSZ+.5, 1.D0 )                          
      WRITE(6,7071)                                                     
7071  FORMAT(' PSI=F(R)/R' /  4X, 'STEP', 6X, 'RADIUS', 8X, 'WAVEFUNCTIO
     *N' /)                                                             
      DO 6061 II=1,NSTEPS,NWRITE                                        
      RVAL=(II-1)*STEPSZ                                                

C*****LECTURE DE FUNCTION D'ONDE (TIINA)
C	IF(NODES.EQ.5)READ(13,*)RTIIS,ALLOC(LWF2+II-1)
      WRITE(6,7707)II, RVAL, ALLOC(LWF2+II-1)                           
 7707 FORMAT ( I8, F12.5, G15.5 )                                       
6061  CONTINUE                                                          
C	CLOSE(UNIT=13)
C                                                                       
8875  RC = RCSAVE                                                       
      RETURN                                                            
CXX      ENTRY BOUNDV (IRET,  IV2L, IWF2, VV0, VVSO)                    
CXX      ISEAR=1                                                        
CXX      V=VV0                                                          
CXX      VSO = VVSO                                                     
CXX      GO TO 10                                                       
      END                                                               

      SUBROUTINE BSPROD ( FAFB, ITYPE, RA, RB, X, ISCAT, NAIT,
     * RP_ENTRY, RT_ENTRY , * )
CDC     1  RP, RT),RETURNS(IRTRN1)
C
C     COMPUTES BOUND-STATE PRODUCT PHI(RT)*VEFF*PHI(RP)
C     USING SUBROUTINE AITLAG TO INTERPOLATE IN TABLES
C
C     ITYPE - CONTROLS FUNCTION COMPUTED:
C       = 1 - PHI V PHI
C       = 2 - PHI' V PHI'
C       = 3 - RPSI PHI V PHI RPSI
C       = 4 - RPSI PHI' V PHI' RPSI
C       WHERE
C         PHI = BOUNDSTATE WAVEFUNCTION;
C         PHI' = PHI         FOR R > LOC(MAX(PHI))
C              = MAX(PHI)    FOR  < LOC(MAX(PHI))
C         RPSI = R* SCATTERING WAVEFUNCTION
C     RP AND RT ARE COMPUTED FROM RA, RB AND X.
C     ISCAT IS THE ALLOCATOR INDEX OF THE SCATTERING WAVEFUNC TO USE.
C     *  IS ST. NO. TO GO TO WHEN RP OR RT EXCEEDS MAX. ALLOWED VALUE
C
C     IF RA OR RB > ASYMPTOPIA; THEN WE USE R INPLACE OF R*PSI
C
C     IF NUCONL.EQ.2 VEFF INCLUDES CORE-COULOMB CORRECTION
C     EVALUATED AT (RCORE,RSCAT)
C     IF NUCONL.EQ.3 VEFF INCLUDES BOTH COULOMB AND (REAL) NUCLEAR
C     CORE CORRECTIONS
C
C     6/1/75   (MHM)
C     7/7/75 - COMPUTE RP, RT, RCORE, RSCAT
C
C     4/29/76 - MHM
C               MAJOR MODIFICATIONS AND ADDITIONS
C               NEW ENTRY SETRS ADDED
C     5/23/76 - SETRS CHANGED TO BSSET AND INCLUDES INITIALIZATION
C               OF BS ARRAYS - S.P.
C     11/20/77 - V, NOT V/E, IS NOW IN WAVCOM - S.P.
C     12/13/77 - DEFINE IPRNT PROPERLY - S.P.
C     8/10/79 - STANDARD PREFIXES, PUT V*PHI IN ITS OWN ARRAY,
C        KEEP V AND PHI FOR MULTIPASS - RPG
C     3/9/83 - AVOID DIVIDE BY V = 0 - S.P.
C
C
C     PERMITS USE OF FOLDED-UNIFORM COULOMB POTENTIAL
C     IF NUCONL.EQ.3 INCLUDES CORE-CORRECTION TO VEFF FROM
C     REAL PART OF OPTICAL POTENTIAL IN APPROPRIATE CHANNEL
C
      IMPLICIT REAL*8 ( A-H, O-Z )
      INTEGER*4 Z
      COMMON /LOCKT/ Z(100)
      INTEGER FACFR4, FACFR2, FACFR1
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1
      DIMENSION ALLOC(1)
      LOGICAL*1 MLLOC(1)
      REAL*4 ALLOC4(1)
      INTEGER ILLOC(1)
      INTEGER*2 ILLOC2(1)
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP,
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI,
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ,
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P,
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI
      DIMENSION PARAMS(20)
      EQUIVALENCE ( PARAMS(1), PARAM1 )
      DIMENSION AMS(5)
      EQUIVALENCE ( AMS(1), AMA )
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ),
     *(ATEN(1), ATR )
      INTEGER PARITS, PARIPT, PARITY
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5),
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK
      INTEGER PROBLM, R0TYPE, CONVRG
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT,
     *ISAVSM
      LOGICAL*1 WASSET
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I
      COMMON /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)
      DIMENSION AKS(2), REDMS(2), RMAXS(2)
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )
      LOGICAL IOUTSW, PINFSW
      REAL*4 PHISGN
      COMMON /BSBLK/ S1, S2, T1, T2, BNDMXP, BNDMXT, RLPMAX, RLTMAX, VPM
     *AX, VTMAX, SCTMAX, SCTSP, BNDSPT, BNDSPP, BNDSPV, NSPBDT, NSPBDP,
     *NSPBDV, JBDT, JBDP, JPOT, IOUTSW, NSPSCT, ALPHAP, ALPHAT, PINFSW,
     *PHISGN, ROFMAX
      DIMENSION RLMAXS(2), VMAXS(2)
      EQUIVALENCE ( RLMAXS(1), RLPMAX ), ( VMAXS(1), VPMAX )
      COMMON /FORMF/ IBDS(2), NPOTS(2), LBP, LBT, NBP, NBT, JBP, JBT, BN
     *DMAX(2), BNDSTP(2), NSTPBD(2), RBNDS(2), ABNDS(2), RCBNDS(2), BNDM
     *AS(2), BRATMS(2), RSOBDS(2), ASOBDS(2), VBNDS(2), VSOBDS(2), TAUBD
     *S(2), LNKADB(6,2,12)
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG
C
      LOGICAL ALLSW
C
C     STEP 1 - COMPUTE  PHI V PHI   OR   PHI' V PHI'
C
      IENTRY=0
      RP=RP_ENTRY
      RT=RT_ENTRY
      RP = (S2*RA)**2 + (T2*RB)**2 +  2*(S2*RA)*(T2*RB)*X
      RT = (S1*RA)**2 + (T1*RB)**2 +  2*(S1*RA)*(T1*RB)*X
      IF ( DABS(RP) .LT. 1.D-8 ) RP = 0
      IF ( DABS(RT) .LT. 1.D-8 ) RT = 0
      RP = DSQRT(RP)
      RT = DSQRT(RT)
      RP_ENTRY=RP
      RT_ENTRY=RT
C
      FAFB = 0
      IF ( RP .GT. BNDMXP .OR. RT .GT. BNDMXT ) RETURN 1
C
      FP = VPMAX
      FT = VTMAX
      ALLSW = MOD( ITYPE, 2 ) .NE. 0
      DELVNU=0
C
      IF ( ALLSW .OR. RT .GT. RLTMAX )  FT=AITLAG(RT,BNDSPT,ALLOC(Z(JBDT
     *)),NSPBDT,NAIT)
      IF ( ALLSW .OR. RP .GT. RLPMAX )  FP=AITLAG(RP,BNDSPP,ALLOC(Z(JBDP
     *)),NSPBDP,NAIT)
      FACTOR=1
      FPFT = FP*FT
      IF((NUCONL.NE.2).AND.(NUCONL.NE.3)) GO TO 10
      IF ( DABS(FPFT) .LT. SMLNUM )  GO TO 200
C
C     MULTIPLY V*PHI BY (V+DV)/V ; THIS GIVES (V+DV)*PHI
C     DV IS CORE CORRECTION TO VEFF
C     NUCONL = 2 ; DV=VCOUL(RCORE)-VCOUL(RSCAT)
C     NUCONL = 3 ; DV=DV(COUL)+VNUC(RCORE)-VNUC(RSCAT)
C     WHERE VNUC IS REAL PART OF NUCLEAR OPTICAL POTENTIAL
C
      RSCAT = RA
      IF ( IOUTSW ) RSCAT = RB
      RCORE = DSQRT( ((S1-S2)*RA)**2 + ((T1-T2)*RB)**2  + 2*((S1-S2)*RA)
     **((T1-T2)*RB)*X )
      CALL VCSQ12(RCORE,POT,3)
      DELVCO=POT
      CALL VCSQ12(RSCAT,POT,ISC)
      DELVSC=POT
      DELV=DELVCO-DELVSC
      IF((NUCONL.NE.3).OR.(NAIT.EQ.2)) GO TO 8
      XCORE=(RCORE-RNCORE)/AOPT
      IF(XCORE.LT.BIGLOG) GO TO 400
      FCORE=0
      GO TO 440
  400 IF(XCORE.GT.-BIGLOG) GO TO 420
      FCORE=1
      GO TO 440
  420 FCORE=1/(1+DEXP(XCORE))
  440 XSCAT=(RSCAT-RNSCAT)/AOPT
      IF(XSCAT.LT.BIGLOG ) GO TO 460
      FSCAT=0
      GO TO 500
  460 IF(XSCAT.GT.-BIGLOG ) GO TO 480
      FSCAT=1
      GO TO 500
  480 FSCAT=1/(1+DEXP(XSCAT))
  500 DELVNU=VOPT*(FCORE-FSCAT)
      DELV=DELV+DELVNU
    8 RBND=RT*(IVRTEX-1)+RP*(2-IVRTEX)
      VEFF=AITLAG(RBND,BNDSPV,ALLOC(Z(JPOT)),NSPBDV,NAIT)
      FACTOR=1+DELV/VEFF
      FPFT = FACTOR*FPFT
      IF ( IPRNT .GE. 9 )
     1 WRITE(6,193) RA, RB, RP, RT, RCORE,
     2   VEFF, DELVSC, DELVCO, DELVNU, DELV, FACTOR, FPFT
 193  FORMAT ( ' BSP', 5F8.4, 7G12.4 )
C
C     NOW WE MULTIPLY IN THE PSI'S IF DESIRED.
C     IN FACT WE MULTIPLY IN R*PSI
C
  10  FAFB=FACTOR*FP*FT
C
 200  IF ( ITYPE .LE. 2 )  RETURN
C
      IF ( RA .GT. SCTMAX ) GO TO 220
      FAFB = FAFB *  AITLAG( RA, SCTSP, ALLOC(Z(ISCAT)), NSPSCT, NAIT )
C     AVOID UNDERFLOWS
      IF ( DABS(FAFB) .GT. 1.D-34 ) GO TO 250
      FAFB = 0
      RETURN
 220  FAFB = FAFB * RA
C
 250  IF ( RB .GT. SCTMAX ) GO TO 270
      FAFB = FAFB *  AITLAG( RB, SCTSP, ALLOC(Z(ISCAT)), NSPSCT, NAIT )
      GO TO 300
 270  FAFB = FAFB * RB
      GO TO 300
C
C     INITIALIZE THE FORM-FACTOR CALCULATION
C
      ENTRY BSSET
C
      IENTRY=1
C     COMPUTE APPROPRIATE  V*PHI  AND STORE IT IN "VPHI".  NOTE THAT FOR
C     NUCONL.GE.2 (SEE BELOW) THIS IS ONLY A TEMPORARY V*PHI FOR SETTING
C     UP THE GRIDS.  THE REAL V*PHI IS THEN FOUND AT STMNT. NO. 830.
C
C     IVRTEX = 1  FOR PROJECTILE VERTEX
C            = 2  FOR TARGET VERTEX
C
C     ALSO FIND THE MAXIMUM VALUES OF THE FORMFACTOR AND BOUND STATE
C     AND GET LOCS OF THE MAXIMA
C
      IPRNT=MOD(IPRINT/10000,10)
      JPOT = NPOTS(IVRTEX)
      JBD1 = IBDS(IVRTEX)
      JBD2 = IBDS(3-IVRTEX)
      NSPBDV = NSTPBD(IVRTEX)
      NSPBDT = NSTPBD(3-IVRTEX)
      IVPHI = NALLOC ( NSPBDV, 'VPHI    ' )
      LVPHI = Z(IVPHI) - 1
      LPOT = Z(JPOT) - 1
      LBD1 = Z(JBD1) - 1
      LBD2 = Z(JBD2) - 1
      VMAXS(IVRTEX) = 0
      VMAXS(3-IVRTEX) = 0
C
      RP = -BNDSTP(IVRTEX)
      DO 219 I = 1, NSPBDV
      RP = RP + BNDSTP(IVRTEX)
      TEMP = ALLOC(LBD1+I)*ALLOC(LPOT+I)
      IF ( DABS(TEMP) .LE. VMAXS(IVRTEX) ) GO TO 215
      RLMAXS(IVRTEX) = RP
      VMAXS(IVRTEX) = DABS(TEMP)
 215  ALLOC(LVPHI+I) = TEMP
 219  CONTINUE
      RT = -BNDSTP(3-IVRTEX)
      DO 229 I = 1, NSPBDT
      TEMP = ALLOC(LBD2+I)
      RT = RT + BNDSTP(3-IVRTEX)
      IF ( DABS(TEMP) .LE. VMAXS(3-IVRTEX) ) GO TO 229
      RLMAXS(3-IVRTEX) = RT
      VMAXS(3-IVRTEX) = DABS(TEMP)
 229  CONTINUE
C
      IF (PINFSW) WRITE(6,233) VMAXS, RLMAXS
 233  FORMAT ( ' PROJECTILE AND TARGET FORMFACTOR MAXIMA:',  2G15.5 /  '
     * LOCATION OF PROJECTILE AND TARGET FORM-FACTOR MAXIMA:',  2G15.5 )
     *
C
C     FREE POTENTIAL AT VERTEX WHERE INTERACTION ISNT (IF NOT MULTIPASS)
C
      IF ( IBSPAS .GT. 0 ) GO TO 1620
      Z(NPOTS(3-IVRTEX))=-Z(NPOTS(3-IVRTEX))
      IF(NUCONL.GE.2) GO TO 1620
      Z(JPOT)=-Z(JPOT)
C
 1620 JBDP = IBDS(1)
      IF ( IVRTEX .EQ. 1 ) JBDP = IVPHI
      JBDT = IBDS(2)
      IF ( IVRTEX .EQ. 2 ) JBDT = IVPHI
      BNDSPP = 1/BNDSTP(1)
      BNDSPT = 1/BNDSTP(2)
      BNDSPV = 1/BNDSTP(IVRTEX)
      NSPBDP = NSTPBD(1)
      NSPBDT = NSTPBD(2)
      BNDMXP = BNDMAX(1)
      BNDMXT = BNDMAX(2)
C
C     EXPONENTIAL TAIL FACTORS FOR H-INTERPOLATION
C
      ALPHAP = SQRT( -2*BNDMAS(1)*EBNDS(1) ) / HBARC
      ALPHAT = SQRT( -2*BNDMAS(2)*EBNDS(2) ) / HBARC
      IF ( IPRNT .GE. 4 ) WRITE(6,1643) ALPHAP, ALPHAT
 1643 FORMAT ( ' EXPONENTIAL DECAYS OF FORM FACTOR:  RP =',  G13.5, 5X,
     *'RT =', G13.5 )
C
      IF(IENTRY.EQ.0)THEN
        RP_ENTRY=RP
        RT_ENTRY=RT
      ENDIF
      IF ( NUCONL .LT. 2 ) RETURN
C
C
C     COMPUTE POTENTIAL PARAMETERS FOR CORE TERMS IN VEFF
C
C
C     COMPUTE  RADII AND COUPLING CONSTANTS FOR CORE TERMS IN VEFF
C
C     NUCONL  SPECIFIES WHAT IS TO BE DONE ABOUT CORE TERMS IN
C     THE VERTEX POTENTIAL:
C     0 - USESIMPLECOULOMB - V = V(NUC, IVERTEX) + V(COUL, IVERTEX)
C         HERE BOTH THE NUCLEAR AND COULOMB ARE FUNCTIONS OF JUST
C        ONE VERTEX COORDINATE (RP OR RT).
C     1 - NUCONLY - V = V(NUC, IVERTEX).  NO COULOMB TERMS AT ALL.
C     2 - USECOULOMB - V = V(NUC, IVERTEX) + V(COUL, RP, RT, PHI)
C         HERE THE COULOMB PART CONTAINS CORRECTIONS DUE TO THE
C         CORES AND IS A FUNCTION OF ALL 3 COORDINATES.
C     3 - USECORE - V = V(NUCONL=2) + DV(NUC)
C     WHERE DV(NUC) IS CORE CORRECTION FROM REAL PART OF VOPT
C     NUCONL = 0 OR 1  IS TAKEN CARE OF BY BOUND.  NUCONL.GE.2 IS
C     TREATED AS 0 BY BOUND AND MUST BE FURTHER CORRECTED HERE.
C
      POW=1.D0/3.D0
      AMA3=AMA**POW
      AMB3=AMB**POW
      AMBGA3=AMBIGA**POW
      AMBGB3=AMBIGB**POW
      FACTOR=1
C
C     FOLDED COULOMB POTENTIALS IN BOTH CHANNELS 0
C
      ISEE=0
      DO 20 I=1,2
   20 IF((RCSCTP(I).EQ.0).OR.(RCSCTT(I).EQ.0)) ISEE=1
C
C     PHISGN = +1 ; STRIPPING ;
C     PHISGN = -1 ; PICK-UP
C     IVRTEX =  1 ; VEFF AT PROJECTILE VERTEX
C     IVRTEX =  2 ; VEFF AT TARGET VERTEX
C
      IF(PHISGN.EQ.-1) GO TO 60
      IF(IVRTEX.EQ.2) GO TO 40
C
C     STRIPPING ; PROJECTILE VERTEX
C
      ISC=2
      IZS1=IZS(2)
      IZS2=IZS(4)
      IZC1=IZS(2)
      IZC2=IZS(3)
      IF(ISEE.EQ.0) FACTOR=AMBGA3/AMBGB3
      IF(ISEE.EQ.1) FACTOR=(AMBGA3+AMB3)/(AMBGB3+AMB3)
      RCPSCT=RCSCTP(2)
      RCTSCT=RCSCTT(2)
      RCCOP=RCPSCT
      RCCOT=RCTSCT*FACTOR
      IOUTSW=.TRUE.
      IF(NUCONL.NE.3) GO TO 100
      RNSCAT=RSCTS(2)
      RNCORE=RNSCAT*((AMBGA3+AMB3)/(AMBGB3+AMB3))
      VOPT=-V0RS(2)
      AOPT=ASCTS(2)
      GO TO 100
C
C     STRIPPING ; TARGET VERTEX
C
   40 ISC=1
      IZS1=IZS(1)
      IZS2=IZS(3)
      IZC1=IZS(2)
      IZC2=IZS(3)
      IF(ISEE.EQ.0) FACTOR=AMB3/AMA3
      IF(ISEE.EQ.1) FACTOR=(AMB3+AMBGA3)/(AMA3+AMBGA3)
      RCPSCT=RCSCTP(1)
      RCTSCT=RCSCTT(1)
      RCCOP=RCPSCT*FACTOR
      RCCOT=RCTSCT
      IOUTSW=.FALSE.
      IF(NUCONL.NE.3) GO TO 100
      RNSCAT=RSCTS(1)
      RNCORE=RNSCAT*((AMB3+AMBGA3)/(AMA3+AMBGA3))
      VOPT=-V0RS(1)
      AOPT=ASCTS(1)
      GO TO 100
C
C     PICK-UP ; PROJECTILE VERTEX
C
   60 IF(IVRTEX.EQ.2) GO TO 80
      ISC=1
      IZS1=IZS(1)
      IZS2=IZS(3)
      IZC1=IZS(1)
      IZC2=IZS(4)
      IF(ISEE.EQ.0) FACTOR=AMBGB3/AMBGA3
      IF(ISEE.EQ.1) FACTOR=(AMBGB3+AMA3)/(AMBGA3+AMA3)
      RCPSCT=RCSCTP(1)
      RCTSCT=RCSCTT(1)
      RCCOP=RCPSCT
      RCCOT=RCTSCT*FACTOR
      IOUTSW=.FALSE.
      IF(NUCONL.NE.3) GO TO 100
      RNSCAT=RSCTS(1)
      RNCORE=RNSCAT*((AMBGB3+AMA3)/(AMBGA3+AMA3))
      VOPT=-V0RS(1)
      AOPT=ASCTS(1)
      GO TO 100
C
C     PICK-UP ; TARGET VERTEX
C
   80 ISC=2
      IZS1=IZS(2)
      IZS2=IZS(4)
      IZC1=IZS(1)
      IZC2=IZS(4)
      IF(ISEE.EQ.0) FACTOR=AMA3/AMB3
      IF(ISEE.EQ.1) FACTOR=(AMA3+AMBGB3)/(AMB3+AMBGB3)
      RCPSCT=RCSCTP(2)
      RCTSCT=RCSCTT(2)
      RCCOP=RCPSCT*FACTOR
      RCCOT=RCTSCT
      IOUTSW=.TRUE.
      IF(NUCONL.NE.3) GO TO 100
      RNSCAT=RSCTS(2)
      RNCORE=RNSCAT*((AMA3+AMBGB3)/(AMB3+AMBGB3))
      VOPT=-V0RS(2)
      AOPT=ASCTS(2)
C
C     INITIALIZE COULOMB-POTENTIAL SUBROUTINE
C
  100 CALL SETVSQ(RCCOP,RCCOT,IZC1,IZC2,3)
C
      IF(IPRNT.LE.4) GO TO 300
      WRITE(6,550) ISC,IZS1,IZS2,IZC1,IZC2,NUCONL
  550 FORMAT(3X,'++++ SETRS ++++'/3X,'CHANNEL ',I2, '(Z1,Z2) = ( ',I
     *2,1X,I2,' )'/3X,'  CORE  (Z1,Z2) = (', I2,1X,I2,') NUCONL = ',I2)
      WRITE(6,600) RCPSCT,RCTSCT,RCCOT,RCCOP
  600 FORMAT(3X,'SCATTERING :(RT,RP) = ',G12.6,1X,G12.6, '(COULOMB)'
     */3X,'CORE :(RT,RP) = ',G12.6,1X,G12.6, '(COULOMB)')
      IF(NUCONL.NE.3) GO TO 300
      WRITE(6,650) RNSCAT,RNCORE,VOPT,AOPT
  650 FORMAT(3X,' (RNSCAT,RNCORE)=',G12.6,1X,G12.6/ 3X,'(-V,A)=(',G1
     *2.6,1X,G12.6,1X,G12.6,')')
      IF(IENTRY.EQ.0)THEN
        RP_ENTRY=RP
        RT_ENTRY=RT
      ENDIF
  300 RETURN
      END
C
C
      SUBROUTINE CALANG ( GRADSW, LLMIN, LLMAX, LSKIP, MPARA,  ANGLE,  P
     *L, COULPH, DFDX, SINCOS, SMAT, DSDP,  FR, FI, RUTH, HIGHR, HIGHI )
     *                                                                  
C                                                                       
C     EVALUATES CROSS SECTIONS AND GRADIENTS FOR ONE ANGLE              
C                                                                       
C     THIS ROUTINE IS CALLED FROM CALFUN TO DO THE CALCULATION AT ONE   
C     ANGLE.  IT IS A SEPARATE ROUTINE TO IMPROVE COMPILATION.          
C                                                                       
C     5/22/78 - SPLIT OFF FROM CALFUN - S.P.                            
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      LOGICAL GRADSW                                                    
      DIMENSION PL(LLMAX), COULPH(LLMAX), DFDX(2,MPARA),  SINCOS(2,LLMAX
     *), SMAT(2,LLMAX), DSDP(2,MPARA,LLMAX)                             
C                                                                       
CDC      ALLOCLEVEL  PL, COULPH, DFDX, SINCOS, SMAT, DSDP               
C                                                                       
C                                                                       
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /LOCFIT/ IDATA, LPL, LSIGMA, LSMAT, IESETS, IMASK, IEQUAL, 
     *NPARA, IPARA, ITEMP, LSCSIG, LEPARM, LFS, NPTS, LEQNAM, MAXEQL, MA
     *XVS, LVDERV, LSDELS, LDVTYP, LDSDP, LDFDX, LFGRAD, LTGRAD, LMASK, 
     *LEQUAL, MNDRIV, MXDRIV, IESIZE, LENPRE, LENKEY, LENHED, ILNKBL    
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
      COMMON /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
C                                                                       
C     GET LEGENDRE POLYNOMIALS                                          
C                                                                       
 250         A11=COS(ANGLE)
	CALL PLMSUB(LLMAX,0,A11,PL)
C                                                                       
C  RUTHEFORD CROSS SECTION FIRST                                        
C                                                                       
      RATJAC = ETAS(1)/(2*AKS(1))                                       
      TEMP = ANGLE                                                      
      FR = 0                                                            
      FI = 0                                                            
C                                                                       
C   ******************************************************              
C   *                                                    *              
C   *  FOLLOWING WORKS ONLY FOR:                         *              
C   *   1) NON-IDENTICAL PARTICLES (LSKIP=1)             *              
C   *   2) IDENTICAL SPIN-0 PARTICLES (LSKIP=2)          *              
C   *                                                    *              
C   ******************************************************              
C                                                                       
      DO 269 I = 1, LSKIP                                               
      S2=DSIN(TEMP*.5)                                                  
      FR = FR - RATJAC/S2**2 *DCOS(2*(COULPH(1)  - ETAS(1)*DLOG(S2)) )  
      FI = FI - RATJAC/S2**2 *DSIN(2*(COULPH(1)  - ETAS(1)*DLOG(S2)) )  
      TEMP = PI - TEMP                                                  
 269  CONTINUE                                                          
C  CROSS SECTIONS IN MILLI BARNS                                        
      RUTH= 10.0D0 * (FR*FR + FI*FI)                                    
      IF ( RUTH .EQ. 0 ) RUTH = 1                                       
C                                                                       
C  NOW NUCLEAR AMPS                                                     
C     FOLLOWING FACTORS CONTAIN FACTOR OF 2 FOR IDENTICAL PARTICLES     
C                                                                       
      CINCR = LSKIP/AKS(1)                                              
      C = .5*CINCR                                                      
      CINCR = LSKIP*CINCR                                               
C                                                                       
      IF ( .NOT. GRADSW ) GO TO 310                                     
      DO 309 I = 1, MPARA                                               
      DFDX(1,I) = 0                                                     
      DFDX(2,I) = 0                                                     
 309  CONTINUE                                                          
C                                                                       
 310  IF ( LLMIN .EQ. 0 ) GO TO 330                                     
C                                                                       
C     SUM FOR L < LMIN; S = 0                                           
C                                                                       
      LMINM1 = LLMIN-LSKIP                                              
      IZERO = 0                                                         
      DO 329 LL = IZERO, LMINM1, LSKIP                                  
      AFAC = C*PL(LL+1)                                                 
      C = C + CINCR                                                     
      FR = FR - AFAC*SINCOS(1,LL+1)                                     
      FI = FI + AFAC*SINCOS(2,LL+1)                                     
 329  CONTINUE                                                          
C                                                                       
C     NOW SUM FOR  LLMIN =< L =< LLMAX                                  
C                                                                       
 330  ASSIGN 360 TO IGOTO                                               
      ASSIGN 360 TO JGOTO                                               
      IF (GRADSW) GO TO 335                                             
      ASSIGN 369 TO IGOTO                                               
      ASSIGN 369 TO JGOTO                                               
 335  IF ( ITEMP .NE. 2 ) ASSIGN 355 TO IGOTO                           
C                                                                       
      DO 369 LL = LLMIN, LLMAX, LSKIP                                   
      AFAC = C*PL(LL+1)                                                 
      SINSIG = AFAC*SINCOS(1,LL+1)                                      
      COSSIG = AFAC*SINCOS(2,LL+1)                                      
      C = C + CINCR                                                     
      FR = FR + SINSIG*(SMAT(1,LL+1)-1)  + COSSIG*SMAT(2,LL+1)          
      FI = FI + SINSIG*SMAT(2,LL+1)  - COSSIG*(SMAT(1,LL+1)-1)          
C                                                                       
      GO TO IGOTO, ( 355, 360, 369 )                                    
 355  IF(LL.NE.(LLMAX-2))GO TO 359                                      
      HIGHR=FR                                                          
      HIGHI=FI                                                          
 359  GO TO JGOTO, ( 360, 369 )                                         
C                                                                       
C     COMPUTE THE GRADIENT OF F IF NEEDED                               
C                                                                       
 360  DO 365 I = 1, MPARA                                               
      DFDX(1,I) = DFDX(1,I)  + SINSIG*DSDP(1,I,LL+1)  + COSSIG*DSDP(2,I,
     *LL+1)                                                             
      DFDX(2,I) = DFDX(2,I)  + SINSIG*DSDP(2,I,LL+1)  - COSSIG*DSDP(1,I,
     *LL+1)                                                             
 365  CONTINUE                                                          
C                                                                       
369   CONTINUE                                                          
C                                                                       
      RETURN                                                            
C                                                                       
      END                                                               
