      SUBROUTINE SETFG ( NCHNDF, MCHNDF, CHNDEF, RCHNDF,  NBASDF, MBASDF
     *, BASDEF, NUMLIS, LIS, FG,  L1, L2P1, FGWORK, R1, R2, IRET )      
C                                                                       
C     COMPUTES ALL F AND G COULOMB FUNCTIONS FOR C.C.                   
C                                                                       
C     LOOPS THROUGH THE CHANNELS ARRAY AND GETS ALL F'S AND G'S         
C     THEN STORES ACCORING TO BASIS DEF INDEXES.                        
C                                                                       
C     FG HAS THE STRUCTURE  FG( I, IB, ILI )                            
C       ILI POINTS TO THE J-VALUE                                       
C       IB  POINTS TO THE BASIS STATE                                   
C       I = 1 FOR F(R-DELTA), 2 FOR G(R-DELTA), 3 FOR F(R),             
C           4 FOR G(R)                                                  
C                                                                       
C     1/17/80 - FIRST VERSION - S.P.                                    
C     2/7/80 - FG ARRAY IS REAL*4 - S.P.                                
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      INTEGER CHNDEF(MCHNDF, NCHNDF), BASDEF(MBASDF, NBASDF)            
      REAL*4 RCHNDF(MCHNDF, NCHNDF)                                     
      INTEGER LIS(NUMLIS)                                               
      REAL*4 FG(4, NBASDF, NUMLIS)                                      
      REAL*8 FGWORK(L2P1, 6)                                            
C                                                                       
      L2 = L2P1-1                                                       
C                                                                       
C     LOOP THROUGH THE CHANNELS ARRAY.                                  
C                                                                       
C     FOR EACH CHANNEL COMPUTE ALL THE COULOMB FUNCTIONS                
C                                                                       
      DO 499 NC = 1, NCHNDF                                             
C                                                                       
      ETA = RCHNDF(6,NC)                                                
      AK = RCHNDF(7,NC)                                                 
      IB1 = CHNDEF(8,NC)                                                
      IB2 = CHNDEF(9,NC) + IB1 - 1                                      
C                                                                       
      RHO = AK*R1                                                       
      CALL RCWFN ( RHO, ETA, L1, L2, FGWORK(1,1),  FGWORK(1,5), FGWORK(1
     *,2), FGWORK(1,6),  1.D-12, IFLAG )                                
      IF ( IFLAG .NE. 0 ) GO TO 990                                     
C                                                                       
      RHO = AK*R2                                                       
      CALL RCWFN ( RHO, ETA, L1, L2, FGWORK(1,3),  FGWORK(1,5), FGWORK(1
     *,4), FGWORK(1,6),  1.D-12, IFLAG )                                
      IF ( IFLAG .NE. 0 ) GO TO 990                                     
C                                                                       
C     LOOP THROUGH THE L-J'S FOR THIS CHANNEL                           
C                                                                       
      DO 399 IB = IB1, IB2                                              
      LMJ = BASDEF(3,IB)                                                
C                                                                       
C     NOW LOOP THROUGH THE REQUIRED J'S AND STORE F AND G.              
C                                                                       
      DO 299 ILI = 1, NUMLIS                                            
C                                                                       
C**************************************************************         
C                                                                       
C*********  NOTE THAT J AND NOT 2*J IS STORED FOR NOW   *******         
C                                                                       
C**************************************************************         
C                                                                       
      J = 2*LIS(ILI)                                                    
      L = LMJ + J                                                       
      IF ( L .LT. 0 ) GO TO 299                                         
      L = JISHFT( L, -1)                                                
C                                                                       
      DO 249 I = 1, 4                                                   
      FG(I,IB,ILI) = FGWORK(L+1,I)                                      
 249  CONTINUE                                                          
C                                                                       
 299  CONTINUE                                                          
 399  CONTINUE                                                          
 499  CONTINUE                                                          
C                                                                       
      IRET = 1                                                          
      RETURN                                                            
C                                                                       
C     ERROR IN RCWFN                                                    
C                                                                       
 990  WRITE(6,993) IFLAG, NC, ETA, AK, RHO, L1, L2                        
 993  FORMAT ( '0**** RCWFN ERROR IN SETFG:' /  2I8, 3G20.10, 2I8 )     
      IRET = 0                                                          
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE SETFIT ( PARAM, IRET, NWP )                            
C                                                                       
C  THIS ROUTINE CONSTRUCTS THE PARAMETER VECTOR FROM THE OPTICAL PARAMET
C  OR COMBINATIONS OF OPTICAL PARAMETERS TO BE FITTED.                  
C  THIS IS THE VERSION USED IF THE STANDARD PTOLEMY KEYWORDS ARE        
C     ADEQUATE TO DESRIBE THE FIT.  ELSE A USER SUPPLIED ROUTINE SHOULD 
C     BE CALLED AT THE DESIGNATED POINT BELOW.                          
C                                                                       
C     IRET RETURN CODES:                                                
C       1 - ALL O.K.                                                    
C       0 - INTERNAL ERROR - EQUAL ARRAY MESSED UP.                     
C      -1 - STEP WAS OUT OF BOUNDS.                                     
C                                                                       
C                                                   D.GLOECKNER 8/13/75 
C     10/28/75 - MASSIVE CHANGES FOR GRADIENT COMPUTATION - S.P.        
C     11/4/75 - CHECK FOR OUT-OF-BOUNDS STEPS.                          
C     2/18/76 - CHECK FOR IMPLAUSABLE STEPS                             
C     8/1/76 - 1/ELAB EXPANSION                                         
C     4/15/77 - HANDLE RCP, RCT CORRECTLY                               
C     4/21/77 - RENORM AND ANGLE SHIFT MAY BE FIT                       
C     10/17/77 - POWERS OF WOODS-SAXONS                                 
C     11/20/77 - DON'T STORE INTO WAVCOM.                               
C     11/29/77 - LET MAKPOT RETURN LINKULE IRET'S                       
C     5/10/79 - MODIFIED RC, RCP, RCT STUFF - S.P.                      
C     5/14/82 - SET LX=-1 FOR DEFORMED LINKULE - S.P.                   
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL PARAM                                               
C                                                                       
      DIMENSION PARAM(1)                                                
C                                                                       
      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                                                                       
      REAL*8 FLOATK(1)                                                   
      EQUIVALENCE ( FLOATK(1), A )                                       
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                                           
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 /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
     *) )                                                               
      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                                                            
      COMMON / TEMPVS / TVR, TVI, TVSOR, TVSOI, TAR, TAI                
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
C                                                                       
C                                                                       
C  THE FOLLOWING PRODUCES A PARAMETER VECTOR AS SPECIFIED BYEHE FIT KEYW
C  IF NO PARAMETERS TO BE FITTED FOLLOW THE FIT KEYWORD (IN PARAENTHESIS
C  THEN IT IS ASSUMED THAT THE USER HAS MODIFIED THIS PROGRAM           
C                                                                       
      IRET=0                                                            
C                                                                       
      DO 19 I=1,NPARA                                                   
      INDEX=ILLOC(LMASK+I-1)                                            
      TEMP = PARAM(I)                                                   
      IF ( INDEX .GT. 0 ) GO TO 10                                      
      INDEX = MOD( -INDEX, 10000 )                                      
      ALLOC4(IDATA+INDEX) = TEMP                                        
      GO TO 19                                                          
 10   FLOATK(INDEX) = TEMP                                               
 19   CONTINUE                                                          
C                                                                       
C                                                                       
C                                                                       
C  IF SOME OPTICAL PARAMETERS ARE REQUIRED TO BE EQUAL TO OTHERS--      
C  SET THEM EQUAL HERE                                                  
C  EQUAL LOOKS LIKE:  2  1 2 3   4  1 2 3 4 5 ETC                       
C                                                                       
      INDEX=LEQUAL                                                      
20    IMANY=ILLOC(INDEX)                                                
      IF(IMANY)900,200,25                                               
C  IF  3  THINGS EQUAL, IMANY IS THEN 2                                 
C                                                                       
 25   IMANY = IMANY + 1                                                 
      DO 39 I = 1, IMANY                                                
      KEY = ILLOC(INDEX+I)                                              
      IF ( KEY .GT. 0 ) GO TO 30                                        
      KEY = IDATA + MOD( -KEY, 10000 )                                  
      IF ( I .EQ. 1 ) TEMP = ALLOC4(KEY)                                
      ALLOC4(KEY) = TEMP                                                
      GO TO 39                                                          
 30   IF ( I .EQ. 1 ) TEMP = FLOATK(KEY)                                 
      FLOATK(KEY) = TEMP                                                 
 39   CONTINUE                                                          
C                                                                       
      INDEX=INDEX+IMANY+1                                               
      GO TO 20                                                          
C                                                                       
C     NOW STORE LOTS OF STUFF IN THE WAVE COMMON BLOCKS                 
C                                                                       
C                                                                       
C  GET THE R'S FROM R0'S -- THIS ENERGY INDEPENDENT                     
C                                                                       
 200  IF(RC0.NE.UNDEF)RC=R0MASS*RC0                                     
      IF ( RC0P .NE. UNDEF ) RCP = RC0P * AMP**0.33333333333333333 0D0  
      IF ( RC0T .NE. UNDEF ) RCT = RC0T * AMT**0.33333333333333333 0D0  
      IF(RSO0.NE.UNDEF)RSO=R0MASS*RSO0                                  
      IF(RSOI0.NE.UNDEF)RSOI=R0MASS*RSOI0                               
      IF(RSI0.NE.UNDEF)RSI=R0MASS*RSI0                                  
C                                                                       
C  THE FOLLOWING REPLACEMENTS MAY BE AFFECTED BY A NEW ELAB             
C                                                                       
      EMUL=ELAB                                                         
      IF(IEPOW.EQ.1) EMUL=1/ELAB                                        
      TAR = A + EMUL*(AE+EMUL*AESQ)                                     
      TAI = AI + EMUL*(AIE+EMUL*AIESQ)                                  
      TVR = V + EMUL*(VE+EMUL*VESQ)                                     
      TVI = VI + EMUL*(VIE+EMUL*VIESQ)                                  
C  GET R'S  FROM R0'S                                                   
      IF ( R0 .NE. UNDEF ) R = R0MASS*(R0 +EMUL*(R0E + EMUL*R0ESQ))     
      IF ( RI0 .NE. UNDEF ) RI = R0MASS*(RI0 +EMUL*(RI0E +  EMUL*RI0ESQ)
     *)                                                                 
      TVSOR = VSO + TVR*TAU                                             
      TVSOI = VSOI + TVI*TAUI                                           
C                                                                       
C     WE HAVE SETUP ALL THE STANDARD PTOLEMY KEYWORDS.                  
C     THE USER'S LINKULES WILL HAVE TO PROCESS ANY NONSTANDARD          
C     KEYWORDS.                                                         
C                                                                       
C                                                                       
C     CHECK THE POTENTIAL PARAMETERS FOR VALIDITY ( OUT-OF-BOUND STEPS )
C                                                                       
C     FOLLOWING ARE CHECKS FOR PHYSICALLY IMPOSSIBLE OR IMPLAUSIBLE STEP
C                                                                       
C     IF A LINKULE IS BEING USED, LET IT DO THE CHECKING                
C                                                                       
      IF ( LNKADR(3,1) .NE. 0 ) GO TO 420                               
      IF ( R .LE. 0 .OR. TAR .LE. .001 ) GO TO 950                      
      IF ( TVR .LT. -100 ) GO TO 950                                    
      IF ( TAR .GT. R ) GO TO 950                                       
 420  IF ( LNKADR(3,2) .NE. 0 ) GO TO 440                               
      IF ( TVI .NE. 0 .AND. ( RI .LE. 0 .OR. TAI .LE. .001 ) )  GO TO 95
     *0                                                                 
      IF ( TVI .LT. 0 .OR. VSI .LT. 0 ) GO TO 950                       
      IF ( TVI .NE. 0 .AND. TAI .GT. RI ) GO TO 950                     
      IF ( VSI .NE. 0 .AND. ( RSI .LE. 0 .OR. ASI .LE. .001 ) )  GO TO 9
     *50                                                                
 440  IF ( LNKADR(3,5) .NE. 0 ) GO TO 500                               
      IF ( RC .LT. 0 ) GO TO 950                                        
C                                                                       
C     NOW ACTUALLY GENERATE THE POTENTIAL ARRAYS                        
C                                                                       
 500  IF ( RCP .EQ. 0 ) RCT = RC                                        
      RC = RCP + RCT                                                    
      CALL SETVSQ ( RCP, RCT, IZP, IZT, 1 )                             
C                                                                       
C     INDICATE THIS IS AN OPTICAL MODEL CALCULATION                     
C                                                                       
      LX = -1                                                           
      IF ( NWP .NE. 0 ) CALL MAKPOT ( NWP, IRET )                       
C                                                                       
      IF ( IRET .EQ. -1 ) GO TO 950                                     
      IF ( IRET .GE. 0 ) IRET=1                                         
      RETURN                                                            
900   WRITE (6,910) IMANY                                               
910   FORMAT(' EQUAL ARRAY MESSED UP',I8)                               
      RETURN                                                            
C                                                                       
C     MADE AN OUT-OF-BOUNDS STEP                                        
C                                                                       
 950  WRITE(6,953) ELAB, (PARAM(I), I = 1, NPARA)                         
 953  FORMAT ( '0**** WARNING:  FITTER TRIED TO STEP TO NON-PHYSICAL',  
     *' PARAMETERS (ELAB =', F8.2, ') :' /  ( 8G16.6 ) )                
      IRET = -1                                                         
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE SETLOG ( MAXI )                                        
C                                                                       
C     CONSTRUCTS THE TABLE OF LOG(N!) FOR 3-J, ETC                      
C                                                                       
C     7/31/80 - FIRST VERSION - SP                                      
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                                                                       
      REAL*8 LF                                                         
      COMMON /LOGFAC/ MAXLF, LFBIAS, LF(1)                              
C                                                                       
      CHARACTER*8 LOGNAM                                                
      DATA LOGNAM / 'LOGFACS ' /                                        
C                                                                       
C                                                                       
      ILOGFC = NAMLOC(LOGNAM)                                           
      CALL DUMMY1                                                       
      IF ( MAXI .GT. MAXLF ) GO TO 100                                  
      IF ( ILOGFC .EQ. 0 ) RETURN                                       
      GO TO 300                                                         
C                                                                       
 100  MAXLF = MAXI+10                                                   
      ILOGFC = NALLOC( MAXLF+1, LOGNAM )                                
      LLOGFC = Z(ILOGFC)                                                
      ALLOC(LLOGFC) = 0                                                 
      X = 0                                                             
      DI = 1                                                            
      DO 129 I = 1, MAXLF                                               
      X = X + DLOG(DI)                                                  
      DI = DI+1                                                         
      ALLOC(LLOGFC+I) = X                                               
 129  CONTINUE                                                          
C                                                                       
 300  LFBIAS = Z(ILOGFC)-1 + (%LOC(ALLOC)-%LOC(LF))/FACFR1              
	LFBIAS=LLOGFC-1
      RETURN                                                            
      END                                                               
      SUBROUTINE SETPOT ( IRET )                                        
C                                                                       
C     SETS UP POTENTIAL PARAMETERS FOR A SINGLE CHANNEL                 
C                                                                       
C     THIS ROUTINE IS CALLED BEFORE EACH OF THE BOUND STATE AND         
C     DISTORTED WAVE CALCULATIONS.  IT MAKES SURE THAT NECESSARY        
C     R AND A PARAMETERS ARE DEFINED AS FOLLOWS:                        
C                                                                       
C     FOR EACH NONZERO V(I) (AND ALWAYS FOR THE REAL V):                
C                                                                       
C     1)  IF R0(I) IS DEFINED USE IT; ELSE                              
C       A)  IF R(I) IS DEFINED USE IT R; ELSE                           
C       B1)  IF THIS IS AN IMAGINARY POT, USE CORRESPOND REAL R.        
C       B2)  IF THIS IS REAL S.O. OR TENSOR, USE R FOR REAL V.          
C       B3)  IF THIS IS IMAG S.O., USE R FOR REAL S.O.                  
C       B4)  IF THIS IS IMAG TENSOR, USE R FOR SURFACE ABSORPTION       
C              IF DEFINED, ELSE USE R FOR VOLUME ABSORPTION.            
C       C)  IF THESE FAIL TO DEFINE R(I) THEN COMPLAIN.                 
C                                                                       
C     2)  IF A(I) IS DEFINED USE IT; ELSE                               
C       A1)  IF THIS IS AN IMAG V, USE CORRESPONDING REAL A             
C       A2)  IF THIS IS REAL S.O. OR TENSOR, USE A FOR REAL V           
C       A3)  IF THIS IS IMAG S.O., USE A FOR REAL S.O.                  
C       A4)  IF THIS IS IMAG TENSOR, USE A FOR SURFACE ABSORPTION       
C              IF DEFINED, ELSE USE A FOR VOLUME ABSORPTION.            
C       B)  COMPLAIN IF A(I) CANNOT BE DEFINED BY ABOVE.                
C                                                                       
C     WE KEEP TRACK OF THOSE PARAMETERS THAT HAVE BEEN SET EQUAL TO     
C     OTHERS IN "WASSET".  THEN CLRCHN CAN RESET THEM TO UNDEFINED      
C     AGAIN.                                                            
C     FOR THE COULOMB CHANNEL USE RC OR IF NOT DEFINED, USE RC0;        
C     IF RC0 ALSO NOT DEFINED THEN USE FOLDED COULOMB FOR SCATTERING    
C     IF ZP*ZT = 0, DO NOT REQUIRE DEFINITION OF RC.                    
C                                                                       
C     R0 IS USED AS FOLLOWS:                                            
C       R = R0 * MG**1/3                IF ML <= 2.5                    
C       R = R0 * (MG**1/3 + ML**1/3 )   IF ML > 2.5                     
C     WHERE ML = LESSER(MT, MP);  MG = GREATER(MT, MP).                 
C                                                                       
C     5/2/75 - FIRST VERSION - S. PIEPER                                
C     5/22/75 - VSI ADDED                                               
C     6/26/75 - DON'T SET RC = 1 FOR ZERO CHARGE                        
C     8/29/75 - R0MASS PUT IN COMMON                                    
C     10/10/75 - USE R0E RI0E                                           
C     10/21/75 - USE ESQ PARAMETERS                                     
C     10/22/75 - USE WASSET ARRAY.                                      
C     4/29/76 - AMEND INPUT TO PERMIT USE OF FOLDED COULOMB POTENTIALS  
C     8/1/76 - 1/ELAB EXPANSION                                         
C     1/9/77 - FIX RC0 ERROR                                            
C     3/18/77 - FURTHER WORK ON ABOVE                                   
C     4/24/77 - SET WASSET FOR RC STUUFF                                
C     9/27/77 - WASSET IS INITIALIZED BY SETCHN                         
C     11/29/77 - FOR LINKULE-COMPUTED POTENTIALS, DO NOT CHECK THINGS   
C     12/13/77 - IMPROVE DEF OF RC0, RC FOR NO COULOMB FORCE - S.P.     
C     3/25/78 - FIX ERROR IN LINKULES - LNKBLK SHOULD BE LNKADR         
C     12/7/78 - ADD TENSOR POTENTIALS - RPG                             
C     2/27/79 - INCLUDE ML IN R/R0 ONLY IF ML > 2.5 - RPG               
C              DO NOT ALWAYS DEFINE RC0, RC0P, RC0T - S.P.              
C     7/21/79 - RESTORE PREVIOUS BOUND-STATE PARAMETERS ON PASS>=2 - RPG
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      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 /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
      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                                                            
      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*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 /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
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                                                                       
      DIMENSION RTEMP(2), ATEMP(2)                                      
      REAL*4 TNAME(6)                                                   
      DATA TNAME/'TR', 'TRI', 'TL', 'TLI', 'TPR', 'TPRI'/               
      CHARACTER*8 TNAMZ(6)                                              
      DATA TNAMZ/'TR0', 'TRI0', 'TL0', 'TLI0', 'TPR0', 'TPRI0'/         
C                                                                       
      IRET = 1                                                          
C                                                                       
C     SETUP R0 MASS FACTOR INCASE IT IS NEEDED                          
C                                                                       
      AMLESS = DMIN1( AMP, AMT )                                        
      AMMORE = AMP+AMT-AMLESS                                           
      THIRD = 1.D0/3.D0                                                 
      I = R0TYPE+1                                                      
      GO TO ( 72, 74, 76, 78 ), I                                       
C     R0DEFAULT                                                         
 72   R0MASS = AMMORE**THIRD                                            
      IF ( AMLESS .GT. 2.5 ) R0MASS = R0MASS + AMLESS**(1.D0/3.D0)      
      GO TO 100                                                         
C     R0TARGET                                                          
 74   R0MASS = AMMORE**THIRD                                            
      GO TO 100                                                         
C     R0SUM                                                             
 76   R0MASS = AMMORE**THIRD + AMLESS**THIRD                            
      GO TO 100                                                         
C     R0MTOT                                                            
 78   R0MASS = (AMLESS+AMMORE)**THIRD                                   
C                                                                       
C     ENERGY FACTOR FOR ENERGY-DEPENDANT POTENTIALS                     
C                                                                       
100   EELAB = (1+RATMAS)*E                                              
      EEMUL=EELAB                                                       
      IF(IEPOW.EQ.1) EEMUL=1/EELAB                                      
C                                                                       
C     ON THE SECOND AND SUBSEQUENT PASSES, RESTORE THOSE PARAMETERS     
C     WHICH HAVE NOT BEEN REDEFINED.                                    
C                                                                       
      IF ( IBSPAS .LE. 1 .OR. NEXT .LT. 1 .OR. NEXT .GT. 2 )  GO TO 140 
      IF ( L .EQ. NOTDEF ) L = LBNDS(NEXT)                              
      IF ( NODES .EQ. NOTDEF ) NODES = NBNDS(NEXT)                      
      IF ( JP .EQ. NOTDEF ) JP = JBNDS(NEXT)                            
      IF ( ASYMPT .EQ. UNDEF ) ASYMPT = BNDMAX(NEXT)                    
      IF ( STEPSZ .EQ. UNDEF ) STEPSZ = BNDSTP(NEXT)                    
      IF ( R .EQ. UNDEF ) R = RBNDS(NEXT)                               
      IF ( A .EQ. UNDEF ) A = ABNDS(NEXT)                               
      IF ( RC .EQ. UNDEF ) RC = RCBNDS(NEXT)                            
      IF ( AM .EQ. UNDEF ) AM = BNDMAS(NEXT)                            
      IF ( E .EQ. UNDEF ) E = EBNDS(NEXT)                               
      IF ( RSO .EQ. UNDEF ) RSO = RSOBDS(NEXT)                          
      IF ( ASO .EQ. UNDEF ) ASO = ASOBDS(NEXT)                          
      DO 129 I = 1, 6                                                   
      IF ( LNKADR(3,I) .GT. 0 .OR. LNKADB(3,NEXT,I) .LE. 0 )  GO TO 129 
      DO 119 II = 1, 6                                                  
      LNKADR(II,I) = LNKADB(II,NEXT,I)                                  
 119  CONTINUE                                                          
 129  CONTINUE                                                          
C     POTENTIALS ARE TURNED OFF BY "UNDEFINING" THEM.                   
      IF ( V .EQ. 0 ) V = VBNDS(NEXT)                                   
      IF ( VSO .EQ. 0 ) VSO = VSOBDS(NEXT)                              
      IF ( TAU .EQ. 0 ) TAU = TAUBDS(NEXT)                              
C                                                                       
 140  IF ( V .EQ. UNDEF ) V = 0                                         
      IF ( VSO .EQ. UNDEF ) VSO = 0                                     
      IF ( TAU .EQ. UNDEF ) TAU = 0                                     
C                                                                       
C     PARAMS FOR V REAL MUST ALWAYS BE DEFINED                          
C                                                                       
 150  IF ( R0 .NE. UNDEF ) GO TO 160                                    
      IF ( R .NE. UNDEF ) GO TO 190                                     
      IF ( LNKADR(3,1) .NE. 0 ) GO TO 200                               
      WRITE(6,153)                                                         
 153  FORMAT ( '0**** R OR R0 MUST BE DEFINED.')                        
      IRET = 0                                                          
      GO TO 190                                                         
 160  R = (R0+R0E*EEMUL+R0ESQ*EEMUL**2) * R0MASS                        
 190  IF ( A .NE. UNDEF ) GO TO 200                                     
      WRITE(6,193)
 193  FORMAT ( '0**** A MUST BE DEFINED.')                              
      IRET = 0                                                          
C                                                                       
C     NOW CHECK FOR THE EXISTANCE OF IMAG PART.                         
C                                                                       
 200  IF ( VI+VIE*EEMUL+VIESQ*EEMUL**2 .EQ. 0 ) GO TO 300               
C                                                                       
C     WHEN SPECIFIC IMAG PARAM IS NOT AVAIL, USE CORRESPONDING REAL     
C                                                                       
      IF ( RI0 .NE. UNDEF ) GO TO 210                                   
      IF ( RI .NE. UNDEF ) GO TO 240                                    
      RI = R                                                            
      RI0 = R0                                                          
      RI0E = R0E                                                        
      RI0ESQ = R0ESQ                                                    
      WASSET(1) = .TRUE.                                                
      IF ( RI .NE. UNDEF ) GO TO 240                                    
      IF ( LNKADR(3,2) .NE. 0 ) GO TO 240                               
      WRITE(6,203)
 203  FORMAT ( '0**** RI OR RI0 MUST BE DEFINED' )                      
      IRET = 0                                                          
      GO TO 240                                                         
 210  RI = (RI0+RI0E*EEMUL+RI0ESQ*EEMUL**2) * R0MASS                    
 240  IF ( AI .NE. UNDEF ) GO TO 300                                    
      AI = A                                                            
      AIE = AE                                                          
      AIESQ = AESQ                                                      
      WASSET(2) = .TRUE.                                                
      IF ( AI .NE. UNDEF .OR. LNKADR(3,2) .NE. 0 ) GO TO 300            
      WRITE(6,243)
 243  FORMAT ( '0**** AI MUST BE DEFINED.' )                            
      IRET = 0                                                          
C                                                                       
C     NEXT THE REAL SPIN ORBIT                                          
C                                                                       
 300  IF ( VSO .EQ. 0 .AND. TAU .EQ. 0 ) GO TO 350                      
C                                                                       
C     WHEN S.O. PARMS NOT AVAILABLE, USE CORRESPONDING REAL ONES.       
C                                                                       
      IF ( RSO0 .NE. UNDEF ) GO TO 310                                  
      IF ( RSO .NE. UNDEF ) GO TO 340                                   
      RSO = R                                                           
      WASSET(3) = .TRUE.                                                
      IF ( RSO .NE. UNDEF .OR. LNKADR(3,3) .NE. 0 ) GO TO 340           
      WRITE(6,303)
 303  FORMAT ( '0**** RSO OR RSO0 MUST BE DEFINED.' )                   
      IRET = 0                                                          
      GO TO 340                                                         
 310  RSO = RSO0 * R0MASS                                               
 340  IF ( ASO .NE. UNDEF ) GO TO 350                                   
      ASO = A                                                           
      WASSET(4) = .TRUE.                                                
      IF ( ASO .NE. UNDEF .OR. LNKADR(3,3) .NE. 0 ) GO TO 350           
      WRITE(6,343)
 343  FORMAT ( '0**** ASO MUST BE DEFINED.' )                           
      IRET = 0                                                          
C                                                                       
C     NEXT IMAGINARY S.O.                                               
C                                                                       
 350  IF ( VSOI .EQ. 0 .AND. TAUI .EQ. 0 ) GO TO 400                    
C                                                                       
C     WHEN IMAG S.O. PARMS NOT AVAILABLE, USE REAL S.O. ONES.           
C                                                                       
      IF ( RSOI0 .NE. UNDEF ) GO TO 370                                 
      IF ( RSOI .NE. UNDEF ) GO TO 390                                  
      RSOI = RSO                                                        
      WASSET(5) = .TRUE.                                                
      IF ( RSOI .NE. UNDEF .OR. LNKADR(3,4) .NE. 0 ) GO TO 390          
      WRITE(6,363)
 363  FORMAT ( '0**** RSOI OR RSOI0 MUST BE DEFINED.')                  
      IRET = 0                                                          
      GO TO 390                                                         
 370  RSOI = RSOI0 * R0MASS                                             
 390  WASSET(6) = ASOI .EQ. UNDEF                                       
      IF ( ASOI .EQ. UNDEF ) ASOI = ASO                                 
      IF ( ASOI .NE. UNDEF .OR. LNKADR(3,4) .NE. 0 ) GO TO 400          
      WRITE(6,393)
 393  FORMAT ( '0**** ASOI MUST BE DEFINED.')                           
      IRET = 0                                                          
C                                                                       
C     NEXT SURFACE ABSORPTION                                           
C                                                                       
 400  IF ( VSI .EQ. 0 ) GO TO 500                                       
C                                                                       
C     WHEN SPECIFIC VSI PARAM IS NOT AVALABLE, USE CORRESPONDING IMAG   
C                                                                       
      IF ( RSI0 .NE. UNDEF ) GO TO 410                                  

      IF ( RSI .NE. UNDEF ) GO TO 440                                   
      RSI = RI                                                          
      WASSET(7) = .TRUE.                                                
      IF ( RSI .NE. UNDEF .OR. LNKADR(3,2) .NE. 0 ) GO TO 440           
      WRITE(6,403)
 403  FORMAT ( '0**** RSI OR RSI0 MUST BE DEFINED.' )                   
      IRET = 0                                                          
      GO TO 440                                                         
 410  RSI = RSI0 * R0MASS                                               
 440  WASSET(8) = ASI .EQ. UNDEF                                        
      IF ( ASI .EQ. UNDEF ) ASI = AI                                    
      IF ( ASI .NE. UNDEF .OR. LNKADR(3,2) .NE. 0 ) GO TO 500           
      WRITE(6,443)
 443  FORMAT ( '0**** ASI MUST BE DEFINED.' )                           
      IRET = 0                                                          
C                                                                       
C     NEXT COULOMB                                                      
C                                                                       
 500  IF ( IZP .NE. NOTDEF .AND. IZT .NE. NOTDEF ) GO TO 510            
      WRITE(6,503)
 503  FORMAT ( '0**** ZP AND ZT MUST ALWAYS BE DEFINED.')               
      IRET = 0                                                          
      IZPZT = 1                                                         
      GO TO 520                                                         
510   IZPZT = IZP*IZT                                                   
 520  IF ( RC0 .NE. UNDEF ) GO TO 530                                   
      IF ( RC .NE. UNDEF ) GO TO 700                                    
C                                                                       
C     IF CHARGE IS 0 THEN RC NEED NOT BE DEFINED.  WE THEN SET IT       
C     TO 1 TO AVOID PROBLEMS LATER ON                                   
C                                                                       
      RC = 1                                                            
      WASSET(9) = .TRUE.                                                
      IF ( IZPZT .EQ. 0 ) GO TO 700                                     
      IF((NEXT.EQ.3).OR.(NEXT.EQ.4).OR.(NEXT.EQ.6).OR.(NEXT.EQ.21))  GO 
     *TO 620                                                            
      WRITE(6,523)
 523  FORMAT ( '0**** RC OR RC0 MUST BE DEFINED FOR BS.')               
      RC0 = UNDEF                                                       
      RC = UNDEF                                                        
      WASSET(9) = .FALSE.                                               
      IRET = 0                                                          
      GO TO 600                                                         
  620 IF(RC0P.NE.UNDEF) GO TO 630                                       
      IF(RCP.NE.UNDEF) GO TO 650                                        
      IAMP=AMP+.5                                                       
      CALL REQUIV(RCP,RC0P,IZP,IAMP)                                    
      RC0P = UNDEF                                                      
      WASSET(10) = .TRUE.                                               
      GO TO 650                                                         
  630 RCP=RC0P*(AMP**(1.D0/3.D0))                                       
  650 IF(RC0T.NE.UNDEF) GO TO 660                                       
      IF(RCT.NE.UNDEF) GO TO 680                                        
      IAMT=AMT+.5                                                       
      CALL REQUIV(RCT,RC0T,IZT,IAMT)                                    
      RC0T = UNDEF                                                      
      WASSET(11) = .TRUE.                                               
      GO TO 680                                                         
  660 RCT=RC0T*(AMT**(1.D0/3.D0))                                       
  680 RC=RCP+RCT                                                        
      GO TO 600                                                         
 530  RC = RC0 * R0MASS                                                 
  700 IF((NEXT.LE.2).OR.(NEXT.EQ.5)) GO TO 600                          
      IF(IVRTEX.EQ.2) GO TO 720                                         
      RCP=0                                                             
      RCT=RC                                                            
      GO TO 600                                                         
  720 RCP=RC                                                            
      RCT=0                                                             
C                                                                       
C     LOOP THROUGH TENSOR POTENTIAL TYPES:                              
C     REAL TR, IMAG TR, REAL TL, IMAG TL, REAL TP, IMAG TP.             
C     DEFAULT REAL TENSOR PARTMETERS = REAL CENTRAL.                    
C     DEFAULT IMAG. TENSOR PARAMETERS = SURFACE IMAG. CENTRAL IF        
C        DEFINED, ELSE VOLUME IMAG. CENTRAL.                            
C                                                                       
 600  RTEMP(1) = R                                                      
      RTEMP(2) = RSI                                                    
      IF ( RTEMP(2) .EQ. UNDEF ) RTEMP(2) = RI                          
      ATEMP(1) = A                                                      
      ATEMP(2) = ASI                                                    
      IF ( ATEMP(2) .EQ. UNDEF ) ATEMP(2) = AI                          
      IRI = 1                                                           
      DO 860 ITEN = 1, 6                                                
      IF ( VTEN(ITEN) .EQ. 0 ) GO TO 850                                
      IF ( RTEN0(ITEN) .NE. UNDEF ) GO TO 810                           
      IF ( RTEN(ITEN) .NE. UNDEF ) GO TO 840                            
      RTEN(ITEN) = RTEMP(IRI)                                           
      WASSET(2*ITEN+15) = .TRUE.                                        
      IF ( RTEN(ITEN) .NE. UNDEF .OR. LNKADR(3,ITEN+4) .NE. 0 )  GO TO 8
     *40                                                                
      WRITE(6,803) TNAME(ITEN), TNAMZ(ITEN)                               
 803  FORMAT ( '0**** R', A4, ' OR R', A5, ' MUST BE DEFINED.' )        
      IRET = 0                                                          
      GO TO 840                                                         
 810  RTEN(ITEN) = RTEN0(ITEN) * R0MASS                                 
 840  IF ( ATEN(ITEN) .NE. UNDEF ) GO TO 850                            
      ATEN(ITEN) = ATEMP(IRI)                                           
      WASSET(2*ITEN+16) = .TRUE.                                        
      IF ( ATEN(ITEN) .NE. UNDEF .OR. LNKADR(3,ITEN+4) .NE. 0 )  GO TO 8
     *50                                                                
      WRITE(6,843) TNAME(ITEN)                                            
 843  FORMAT ( '0**** A', A4, ' MUST BE DEFINED.' )                     
      IRET = 0                                                          
 850  IRI = 3 - IRI                                                     
 860  CONTINUE                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE SETSPT ( ISIZE, LOC, IPASS, JBGBIN, JBIN, PBUGSW,  BASD
     *EF, MBASDF, NBASDF )                                              
C                                                                       
C     SETS UP S-MATRIX POINTERS                                         
C                                                                       
C     THIS IS BOB GODDARD'S LOOPS FROM ANGSET TO SET UP THE             
C     INDXS AND TOCS ARRAYS.  THEY HAVE BEEN FRAGMENTED TO              
C     ALLOW REPEATED CALLS TO BUILD UP THE ARRAYS FOR                   
C     COUPLED-CHANNELS CALCULATIONS.                                    
C                                                                       
C     IPASS:                                                            
C        1   ADDS REQUIRED INDXS SIZE TO ISIZE.                         
C        2   STORES INDEXS AT ALLOC(LOC) AND ADDS NSPLI  TO             
C            ISIZE (4*NSPLI = REQUIRED TOCS SIZE)                       
C        3   STORES TOCS IN ILLOC(ISIZE); USES INDXS FROM               
C            ILLOC(LOC)                                                 
C                                                                       
C     JBIN, JBGBIN - VALUES OF JB AND JBIGB FOR THIS CHANNEL            
C                                                                       
C     12/26/79 - TAKEN FROM ANGSET - S.P.                               
C     4/25/80 - PBUGSW MADE AN ARGUMENT - S.P.                          
C     7/16/80 - REMOVE LOGICAL SOSWT - S.P.                             
C     10/26/81 - CHECK BASDEF ARRAY FOR LX DEFINITIONS - S.P.           
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      INTEGER BASDEF(MBASDF, NBASDF)                                    
      LOGICAL PBUGSW                                                    
C                                                                       
      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 /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                                                                       
      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 )                                
C                                                                       
      LOGICAL MULTSW                                                    
C                                                                       
C                                                                       
C     SETUP SOME ANGULAR MOMENTUM STUFF FOR THIS CHANNEL                
C                                                                       
      JS(2) = JBIN                                                      
      JS(4) = JBGBIN                                                    
C                                                                       
      IF ( PROBLM .NE. 24 ) GO TO 50                                    
C                                                                       
      JPMIN = IABS( JS(1)-JS(2) )                                       
      JPMAX = JS(1)+JS(2)                                               
      JTMIN = IABS( JS(3)-JS(4) )                                       
      JTMAX = JS(3)+JS(4)                                               
      LBP = JPMIN/2                                                     
      LBT = JTMIN/2                                                     
C                                                                       
  50  JTBASE = IABS ( JS(3) - JS(4) )                                   
      NJT = ( JS(3) + JS(4) - JTBASE ) / 2 + 1                          
      JPBASE = IABS ( JS(1) - JS(2) )                                   
      NJP = ( JS(1) + JS(2) - JPBASE ) / 2 + 1                          
      NLX = ( JS(1) + JS(2) + JS(3) + JS(4) )/2 + 1                     
C                                                                       
      GO TO ( 100, 200, 400 ), IPASS                                    
C                                                                       
C     RETURN REQUIRED INDXS SIZE                                        
C                                                                       
 100  ISIZE = ISIZE + 3*NLX*NJP*NJT                                     
      RETURN                                                            
C                                                                       
C     IPASS = 2 ; FILL IN INDXS AND COMPUTE NSPLI                       
C                                                                       
 200  NSPLI = 0                                                         
      LINDXS = LOC                                                      
C                                                                       
C     NOW FILL IN "INDXS" FOR ALL S-MATRIX ELEMENTS NEEDED ON THIS      
C     AND SUBSEQUENT PASSES.                                            
C                                                                       
      MULTSW = SOSWS(1) .OR. SOSWS(2) .OR. IBSPAS .GT. 0                
      JTMN = JTMIN                                                      
      JTMX = JTMAX                                                      
      IF ( IBSPAS .GT. 0 ) JTMN = JTBASE                                
      IF ( IBSPAS .GT. 0 ) JTMX = JS(3) + JS(4)                         
      JPMN = JPMIN                                                      
      JPMX = JPMAX                                                      
      IF ( MULTSW ) JPMN = JPBASE                                       
      IF ( MULTSW ) JPMX = JS(1) + JS(2)                                
      DO 349 JTT = JTMN, JTMX, 2                                        
      DO 339 JTP = JPMN, JPMX, 2                                        
      LXMN = IABS ( JTT - JTP )/2                                       
      LXMX = ( JTT + JTP )/2                                            
      IF ( .NOT. MULTSW ) LXMN = MAX0( LXMN, LXMIN )                    
      IF ( .NOT. MULTSW ) LXMX = MIN0( LXMX, LXMAX )                    
      IF ( LXMX .LT. LXMN ) GO TO 339                                   
      DO 329 LX = LXMN, LXMX                                            
      IF ( PROBLM .NE. 24 ) GO TO 250                                   
C                                                                       
C     FOR C.C. WE MUST MAKE SURE THAT EACH LX IS BEING FOUND            
C                                                                       
      DO 239 I = 1, NBASDF                                              
      IF ( BASDEF(2,I) .EQ. 2*LX ) GO TO 250                            
  239 CONTINUE                                                          
      GO TO 329                                                         
  250 NDEL = LX + 1 - MOD ( LX+LBP+LBT, 2 )                             
      IF ( NDEL .EQ. 0 ) GO TO 329                                      
      K = ( JTP-JPBASE + NJP*(JTT-JTBASE) )/2                           
      K = 1 + LX + NLX*K                                                
      LDELMN = 1 - NDEL                                                 
      ILLOC(LINDXS+3*K-2) = NSPLI + 1                                   
      ILLOC(LINDXS+3*K-1) = LDELMN                                      
      ILLOC(LINDXS+3*K) = NDEL                                          
      NSPLI = NSPLI + NDEL                                              
  329 CONTINUE                                                          
  339 CONTINUE                                                          
  349 CONTINUE 
      ISIZE = ISIZE + NSPLI                                             
      I = 3*NLX*NJP*NJT                                                 
      IF ( PBUGSW ) WRITE(6,393) NSPLI,ISIZE,NLX,JPMIN,JPMAX,JPBASE,
     * NJP, JTMIN, JTMAX, JTBASE, NJT,  ( ILLOC(LINDXS+K), K = 1, I )   
  393 FORMAT ( ' NSPLI, ISIZE, NLX, JPMIN, JPMAX, JPBASE, NJP =',  7I10 
     */  ' JTMIN, JTMAX, JTBASE, NJT =', 4I10 /  ( ' INDXS', 3I10 ) )   
C                                                                       
      RETURN                                                            
C                                                                       
C     PASS 3 - FILL IN TOCS                                             
C                                                                       
 400  LTOCS = ISIZE                                                     
      LINDXS = LOC                                                      
C                                                                       
C                                                                       
C     ALL PASSES:  FILL IN "TOCS" FOR THOSE S-MATRIX ELEMENTS WHICH     
C     ARE USED ON THIS PASS.                                            
C                                                                       
      SOSWT = SOSWS(1) .OR. SOSWS(2)                                    
      JPMN = JPMIN                                                      
      JPMX = JPMAX                                                      
      IF ( SOSWT ) JPMN = JPBASE                                        
      IF ( SOSWT ) JPMX = JS(1) + JS(2)                                 
      NLXJP = NLX*NJP                                                   
      N = NLXJP*NJT                                                     
      DO 469 K = 1, N                                                   
      NDEL = ILLOC(LINDXS+3*K)                                          
      IF ( NDEL .EQ. 0 ) GO TO 469                                      
      JTT = ( (K-1)/NLXJP )*2 + JTBASE                                  
      IF ( JTT .LT. JTMIN .OR. JTT .GT. JTMAX ) GO TO 469               
      JTP = MOD ( (K-1)/NLX, NJP )*2 + JPBASE                           
      IF ( JTP .LT. JPMN .OR. JTP .GT. JPMX ) GO TO 469                 
      LX = MOD ( K-1, NLX )                                             
      IF ( .NOT. SOSWT .AND. ( LX .LT. LXMIN .OR. LX .GT. LXMAX ) ) GO T
     *O 469                                                             
      LDEL = ILLOC(LINDXS+3*K-1)                                        
      KOFFS = ILLOC(LINDXS+3*K-2)                                       
      DO 459 IDEL = 1, NDEL                                             
      ILLOC(LTOCS+4*KOFFS-3) = LDEL                                     
      ILLOC(LTOCS+4*KOFFS-2) = LX                                       
      ILLOC(LTOCS+4*KOFFS-1) = JTP                                      
      ILLOC(LTOCS+4*KOFFS) = JTT                                        
      LDEL = LDEL + 2                                                   
      KOFFS = KOFFS + 1                                                 
  459 CONTINUE                                                          
  469 CONTINUE                                                          
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE SFROMI ( LI, ILI, SMATR, SMATI, INDXS, XIREAL, XIIMAG, 
     * IINDEX, NI, INDXDW, IDWFI, IDWFO, RIROAB, ATERM, FACTOR,  PINFSW,
     * NLINE )                                                          
C                                                                       
C     COMPUTES S MATRIX ELEMENTS FROM TRANSFER RADIAL INTEGRALS.        
C                                                                       
C     OPTIONALLY, THE S-MATRIX MAY ALSO BE PRINTED.                     
C                                                                       
C                                                                       
C     ARGUMENTS ARE:                                                    
C     NAME     BASE     MEANING                                         
C     LI                INCIDENT L.                                     
C     ILI               INDEX OF LI IN THE LIS ARRAY                    
C     SMATR    ISMATR   REAL S-MATRIX (OUTPUT).                         
C     SMATI    ISMATI   IMAGINARY S-MATRIX (OUTPUT).                    
C     INDXS    IINDXS   S-MATRIX INDICES FOR EACH (JP, JT) PAIR.        
C     XIREAL   ILILOR   REAL RADIAL INTEGRALS.                          
C     XIIMAG   ILILOI   IMAG. RADIAL INTEGRALS.                         
C     IINDEX   IIINDX   INDICES FOR EACH RADIAL INTEGRAL.               
C     NI                NUMBER OF RADIAL INTEGRALS.                     
C     INDXDW   IDWI     INDICES FOR EACH FI*FO DISTORTED WAVE PRODUCT.  
C     IDWFI    IWFII    INDICES FOR EACH INCIDENT DISTORTED WAVE.       
C     IDWFO    IWFIO    INDICES FOR EACH OUTGOING DISTORTED WAVE.       
C     RIROAB   IABS1    INTEGRALS OF ABS. VALUE OF INTEGRANDS.          
C     ATERM    IBETAS(1)  SPECTROSCOPIC COEFFICIENTS A(LX,JBP,JBT)      
C                           FOR EACH LX.                                
C     FACTOR            KINEMATIC FACTOR = 2*SQRT(KI*KF/EI*EF).         
C     PINFSW            TRUE IF S-MATRIX ELEMENTS ARE TO BE PRINTED.    
C     NLINE             NUMBER OF LINES ALREADY PRINTED ON THIS PAGE.   
C                                                                       
C     6/11/79 - NEW ROUTINE - RPG                                       
C     11/20/79 - S-MATRICES STORED BY LO-LI; ILI ARGUMENT - S.P.        
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      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 /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)                                              
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      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 )                                
      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                                                                 
      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)                 
      EQUIVALENCE ( JA, JSPS(1) ), ( JB, JSPS(2) )                      
C                                                                       
C     ARGUMENT DIMENSIONS, TYPES                                        
C                                                                       
      DIMENSION SMATR(1), SMATI(1), INDXS(3,1), XIREAL(1), XIIMAG(1),  I
     *INDEX(4,1), INDXDW(4,1), IDWFI(3,1), IDWFO(4,1), RIROAB(1),  ATERM
     *(1)                                                               
      LOGICAL PINFSW                                                    
C                                                                       
C     PRINT HEADINGS IF NECESSARY.                                      
C                                                                       
      IF ( .NOT. PINFSW ) GO TO 100                                     
      NLINE = NLINE + NI + 1                                            
      IF ( NLINE .LE. 58 ) GO TO 90                                     
      IF ( NLINE .LT. 1000 ) WRITE(6,23) REACT, ELAB, HEADER              
 23   FORMAT ( X, T60, 'P T O L E M Y' /  10X, 'COMPUTATION OF TRANSFE
     *R S-MATRIX ELEMENTS',  T95, 'WHEELS WITHIN WHEELS' /  X, 45A1, '
     *ELAB =', F7.2, ' MEV', 5X, 65A1 / 1X )                            
C                                                                       
C     THE FORMAT DEPENDS ON THE PRESENCE OF S.O. AND TENSOR POTENTIALS. 
C                                                                       
      IF ( .NOT. SOSWT ) WRITE(6,33)
 33   FORMAT ( '   L   L  LX',  20X, 'S-MATRIX', 17X, 'CANCELLATION' /  
     *'   IN OUT',  11X, 'REAL', 8X, 'IMAG', 7X, 'MAGNITUDE', 9X, 'RI, R
     *O' )                                                              
      IF ( SOSWT .AND. .NOT. ( TCSWS(1) .OR. TCSWS(2) ) ) WRITE(6,43)
 43   FORMAT ( '   L    JP    L    JP   LX  ',  13X, 'S-MATRIX (BEFORE 9
     *-J)', 10X, 'CANCELLATION' /  '   IN   IN   OUT   OUT',  11X, 'REAL
     *', 8X, 'IMAG', 7X, 'MAGNITUDE', 9X, 'RI, RO' )                    
      IF ( TCSWS(1) .OR. TCSWS(2) ) WRITE(6,53)
 53   FORMAT ( '   L    L    JP    L    L    JP   LX  ',  13X, 'S-MATRIX
     * (BEFORE 9-J)', 10X, 'CANCELLATION' /  '   IN  IN   IN   OUT OUT  
     * OUT',  11X, 'REAL', 8X, 'IMAG', 7X, 'MAGNITUDE', 9X, 'RI, RO' )  
      NLINE = 7 + NI                                                    
C                                                                       
 90   WRITE(6,93)
 93   FORMAT ( 1X )                                                     
C                                                                       
C     LOOP THROUGH THE RADIAL INTEGRALS.                                
C     RETRIEVE THE QUANTUM NUMBERS FROM THE INDEX ARRAYS.               
C                                                                       
 100  JPMX = JA + JB                                                    
      DO 299 II = 1, NI                                                 
      LXP = IINDEX(4,II)                                                
      KDW = IINDEX(3,II)                                                
      KWI = INDXDW(1,KDW)                                               
      KWO = INDXDW(2,KDW)                                               
      LASI = IDWFI(1,KWI) + LI                                          
      JPI = IDWFI(2,KWI) + 2*LI                                         
      LO = IDWFO(1,KWO) + LI                                            
      LASO = IDWFO(2,KWO) + LI                                          
      JPO = IDWFO(3,KWO) + 2*LI                                         
C                                                                       
C     GET PART OF THE INDEX TO THE S-MATRIX ARRAYS.                     
C     NOTE THAT FOR TENSOR POTS IN INCOMING CHANNEL,                    
C     LSTEP=1 IS GUARANTEED                                             
C                                                                       
      KSBASE = ILI-1                                                    
      IF ( TCSWS(1) ) KSBASE = LASI-LMIN                                
      KSBASE = NSPLI*KSBASE                                             
C                                                                       
C        MULTIPLY IN THE SPECTROSCOPIC STUFF ( ATERM), KINEMATIC        
C        FACTOR, AND I**(LI+LO+1)*(-1)**LX'.                            
C                                                                       
      TEMP = FACTOR*ATERM(LXP+1)/DSQRT(2*LASI+1.D0)                     
      ITEST = LASI + LASO + 2*LXP + 1                                   
      IF ( MOD(ITEST, 4) .GE. 2 ) TEMP = -TEMP                          
      TEMPR = TEMP*XIREAL(II)                                           
      TEMPI = TEMP*XIIMAG(II)                                           
      SR = TEMPR                                                        
      SI = TEMPI                                                        
      IF ( MOD(ITEST, 2) .EQ. 0 ) GO TO 150                             
      SR = -TEMPI                                                       
      SI = TEMPR                                                        
 150  IF ( .NOT. PINFSW ) GO TO 160                                     
      AMPLI = DSQRT ( SR*SR + SI*SI )                                   
      IF ( AMPLI .EQ. 0 ) AMPLI = 1.D-30                                
      TEMP = DABS(TEMP)*RIROAB(II)/AMPLI                                
C                                                                       
C        IF THERE ARE NO SPIN-ORBIT OR TENSOR FORCES, STORE AND PRINT   
C        (IF REQUIRED) AS IT STANDS.                                    
C                                                                       
 160  IF ( SOSWT ) GO TO 200                                            
      K = ( JBP-JPBASE + NJP*(JBT-JTBASE) )/2                           
      K = 1 + LXP + NLX*K                                               
      KOFFS = INDXS(1,K)                                                
      LDELMN = INDXS(2,K)                                               
      KS = KSBASE + KOFFS + ( LASO-LASI-LDELMN )/2                      
      SMATR(KS) = SMATR(KS) + SR                                        
      SMATI(KS) = SMATI(KS) + SI                                        
      IF ( PINFSW ) WRITE(6,173) LI,LO,LXP,SR,SI,AMPLI,TEMP         
 173  FORMAT ( 1X, 2I4, I3, 1P G16.4, G12.4, G14.4, 0P F12.2 )          
      GO TO 299                                                         
C                                                                       
C     IF SPIN-ORBIT OR TENSOR POTENTIALS EXIST, WE MUST MULTIPLY        
C     BY TWO 9-J SYMBOLS, SOME STATISTICAL FACTORS, AND THE             
C     PHASE (-1)**(LX+LX'), AND ADD THE RESULT TO THE S-MATRIX          
C     ELEMENTS FOR SEVERAL VALUES OF JP, LX.                            
C                                                                       
C     FIRST, PRINT IF NECESSARY.                                        
C                                                                       
 200  IF ( .NOT. PINFSW ) GO TO 220                                     
      IF ( TCSWS(1) .OR. TCSWS(2) ) GO TO 210                           
      WRITE(6,203) LI, JPI, LO, JPO, LXP, SR, SI, AMPLI, TEMP             
 203  FORMAT ( 2( 1X, 2I4, '/2' ), I4,  1P G16.4, G12.4, G14.4, 0P F12.2
     * )                                                                
      GO TO 220                                                         
 210  WRITE(6,213) LI,LASI,JPI,LO,LASO,JPO,LXP,SR,SI,AMPLI,TEMP
 213  FORMAT ( 2( 1X, 3I4, '/2' ), I4,  1P G16.4, G12.4, G14.4, 0P F12.2
     * )                                                                
C        QUIT IF THE AMPLITUDE IS ZERO.                                 
 220  IF ( AMPLI .EQ. 1.D-30 ) GO TO 299                                
C                                                                       
C        IF ONE CHANNEL HAS NO SPIN-ORBIT, WE MUST LOOP THROUGH         
C        THOSE JP'S.                                                    
C                                                                       
      JPIMN = JPI                                                       
      JPIMX = JPI                                                       
      IF ( .NOT. SOSWS(1) ) JPIMN = IABS( 2*LI - JSPS(1) )              
      JPOMN = JPO                                                       
      JPOMX = JPO                                                       
      IF ( .NOT. SOSWS(2) ) JPOMN = IABS( 2*LO - JSPS(2) )              
      DO 279 JPI = JPIMN, JPIMX, 2                                      
      DO 269 JPO = JPOMN, JPOMX, 2                                      
C                                                                       
C           MULTIPLY S BY THE FIRST 9-J SYMBOL.                         
C                                                                       
      SAV9J = (JPI+1) * (JPO+1) * (2*LXP+1) * (JBP+1)                   
      SAV9J = DSQRT(SAV9J) * WIG9J ( JBT, 2*LXP, JBP, JPI, 2*LI,  JA, JP
     *O, 2*LO, JB )                                                     
      IF ( SAV9J .EQ. 0 ) GO TO 269                                     
      TEMPR = SAV9J*SR                                                  
      TEMPI = SAV9J*SI                                                  
C                                                                       
C           LOOP THROUGH THE ALLOWED JP AND LX VALUES.                  
C                                                                       
      DO 259 JP = JPBASE, JPMX, 2                                       
      LXMN = MAX0( IABS(JBT-JP)/2, IABS(LASO-LASI) )                    
      LXMX = MIN0( (JBT+JP)/2, LASO+LASI )                              
      IF ( LXMN .GT. LXMX ) GO TO 259                                   
      DO 249 LX = LXMN, LXMX                                            
      K = ( JP-JPBASE + NJP*(JBT-JTBASE) )/2                            
      K = 1 + LX + NLX*K                                                
      KOFFS = INDXS(1,K)                                                
      LDELMN = INDXS(2,K)                                               
C                                                                       
C              MULT. BY THE OTHER 9-J AND A PHASE, AND ADD IT INTO      
C              THE APPROPRIATE S-MATRIX ELEMENT.                        
C                                                                       
      TEMP = SAV9J                                                      
      IF ( LX .EQ. LXP .AND. JP .EQ. JBP .AND. LASI .EQ. LI .AND. LASO .
     *EQ. LO ) GO TO 240                                                
      TEMP = (JPI+1) * (JPO+1) * (2*LX+1) * (JP+1)                      
      TEMP = DSQRT(TEMP) * WIG9J ( JBT, 2*LX, JP,  JPI, 2*LASI, JA, JPO,
     * 2*LASO, JB )                                                     
      IF ( TEMP .EQ. 0 ) GO TO 249                                      
 240  IF ( MOD(LX+LXP, 2) .NE. 0 ) TEMP = -TEMP                         
      KS = KSBASE + KOFFS + ( LASO-LASI-LDELMN )/2                      
      SMATR(KS) = SMATR(KS) + TEMP*TEMPR                                
      SMATI(KS) = SMATI(KS) + TEMP*TEMPI                                
 249  CONTINUE                                                          
 259  CONTINUE                                                          
 269  CONTINUE                                                          
 279  CONTINUE                                                          
 299  CONTINUE                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE SWKB ( E, FK, L, EPS, IPRINT, ETA, RC,  NSTEPS, ROSTRT,
     * H, VCONS, VARRAY, VCOEFS, WARRAY, WCOEFS,  NGAUSS, PTS, WTS,  DEL
     *TR, DELTIM, THETA, THETC, RHOT, ROTC, DUEFF )                     
C                                                                       
C     EVALUATES WKB PHASE-SHIFT FOR PARTIAL WAVE L                      
C     AND THE CORRESPONDING CLASSICAL DEFLECTION FUNCTION               
C                                                                       
C     INPUT ARGUMENTS:                                                  
C                                                                       
C     E   - COM KINETIC ENERGY                                          
C     FK  - COM WAVE NUMBER                                             
C     L   - PARTIAL WAVE QUANTUM NUMBER                                 
C     EPS - ACCURACY CRITERION FOR LOCATING RTURN.                      
C           1D-14 IS REASONABLE                                         
C     IPRINT = 0 MEANS NO PRINTING; =1 CAUSES DEBUGGING PRINTOUT        
C     ETA - COULOMB STRENGTH PARAMETER                                  
C     RC  - COULOMB RADIUS (NOT RC0)                                    
C       ETA MAY BE ZERO BUT RC MUST ALWAYS BE > 0 (EVEN WHEN ETA=0).    
C     NSTEPS, ROSTRT, H - DEFINE THE GRID OF K*R ON WHICH THE REAL      
C           AND IMAGINARY POTENTIALS ARE DEFINED.                       
C              RHOLAST = ASYMPTOPIA = (NSTEPS-1)*H + ROSTRT             
C     VCONS - = 1 IF VARRAY CONTAINS THE H**2/12 TERM, = 0 IF NOT.      
C             NORMALLY VCONS IS 1 BUT FOR C.C. CALCS IT IS 0.           
C     VARRAY, WARRAY - ARRAYS OF THE POTENTIAL (INCLUDING COULOMB)      
C           IN THE FORM MADE BY MAKPOT:                                 
C              1 - (H/12)**2 (V/E-VCONS)                                
C     VCOEFS, WCOEFS - (NSTEPS,3) DIMENSIONAL ARRAYS CONTAINING         
C           THE CUBIC SPLINE COEFFICENTS FOR VARRAY, WARRAY.            
C           THE CUBIC SPLINES ARE IN TERMS OF RHO = K*R.                
C     NGAUSS, PTS, WTS - A SET OF GAUSS POINTS ON (-1,1).               
C                                                                       
C     OUTPUT ARGUMENTS:                                                 
C                                                                       
C     DELTR, DELTIM - REAL AND IMAGINARY PART OF THE WKB PHASE SHIFT.   
C     THETA, THETC - NUCLEAR AND COULOMB DEFLECTION ANGLES.             
C     RHOT, ROTC - NUCLEAR AND COULOMB TURNING POINTS (TIMES K).        
C     DUEFF - DERIVATIVE OF EFFECTIVE POTENTIAL AT THE NUCLEAR TURNING  
C             POINT.                                                    
C                                                                       
C     MHM SEPT 12 1975                                                  
C     2/25/76 - AVOID OVERFLOW/UNDERFLOW FOR EXTREME PARAMETER VALUES   
C     3/19/77 - ALLOW ETA = 0 - S. P.                                   
C     11/30/77 - GENERAL POTENTIALS - S.P.                              
C     12/10/77 - FIX ERRORS WHEN RHOTURN = 0 - S.P.                     
C                USE QUANTUM MECHANICAL L(L+1) TO AVOID TROUBLES        
C     2/14/78 - DON'T LET RHOTURN BE 0 FOR L > 0.                       
C               ALLOW RHO(TURN) > RHO(MAX)  ( S = 1 )                   
C     10/24/79 - STANDARDIZE, PREVENT SQRT(NEGATIVE) FROM ROUNDOFF - RPG
C     5/8/80 - VCONS ADDED FOR C.C. - S.P.                              
C     6/16/80 - FIX XVAL UNDEF IF RHOT=0, UER .LE. 0 - S.P.             
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
CDC      ALLOCLEVEL PTS, WTS                                            
CDC      ALLOCLEVEL VARRAY, VCOEFS, WARRAY, WCOEFS                      
      DIMENSION PTS(NGAUSS), WTS(NGAUSS)                                
      DIMENSION VARRAY(NSTEPS), VCOEFS(NSTEPS,3), WARRAY(NSTEPS),  WCOEF
     *S(NSTEPS,3)                                                       
C                                                                       
C     INTRODUCE DIMENSIONLESS VARIABLES                                 
C                                                                       
      PI=3.14159 26535 89793 0D0                                        
      RT2=1.41421 35623 73095 0D0                                       
      TP=1/RT2                                                          
      NMAX=50                                                           
      RHOC=FK*RC                                                        
      UC0=(2*ETA)/RHOC                                                  
C                                                                       
C     NOTE QUANTUM-MECHANICAL VALUE.  THIS AVOIDS SOME TROUBLES         
C                                                                       
      FLL = L*(L+1.D0)                                                  
      ECC = DSQRT( ETA**2 + FLL )                                       
      DELTR=5.D0                                                        
      DELTIM=5.D0                                                       

C                                                                       
C     OUTER LIMIT OF THE WKB INTEGRALS WILL BE ASYMPTOPIA               
C                                                                       
      ROMAX = ROSTRT + H*(NSTEPS-1)                                     
C                                                                       
C     CALCULATE CTP IN PURE COULOMB POTENTIAL                           
C                                                                       
      ROTC = ETA + ECC                                                  
      IF ( ROTC.GE.RHOC .OR. ETA .EQ. 0 ) GO TO 24                      
      F1=(3*ETA-RHOC)/(2*ETA)                                           
      ROTC=DSQRT(F1**2+FLL/(ETA*RHOC))+F1                               
      IF ( ROTC .LT. 0 ) ROTC = 0                                       
      ROTC=DSQRT(ROTC)*RHOC                                             
CCCCC                                                                   
CCCCC     CHECK THAT ROMAX AND COULOMB TP ARE REASONABLE                
CCCCC                                                                   
CCCC   24 IF(ROMAX.GT.ROTC) GO TO 27                                    
CCCC      PRINT 26, L, ETA, RC, ROTC, ROMAX                             
CCCC 26   FORMAT ( '0**** SWKB VALUE FOR RHOTURN(COULOMB) IS UNREASONABL
CCCC     1  I5, 4G15.5 )                                                
CCCC      GO TO 50                                                      
C                                                                       
C     CALCULATE CTP IN FULL(NUCLEAR +COULOMB) POTENTIAL                 
C                                                                       
C     FIND INTERVAL (RHO,RHO-H) CONTAINING CTP                          
C                                                                       
   24 ULAS=0                                                            
      RHO=ROMAX                                                         
      N = NSTEPS                                                        
      NITS = 0                                                          
 2    UEFF = ((12/H**2)+VCONS) - (12/H**2)*VARRAY(N) + FLL/RHO**2       
      IF(UEFF.GT.1) GO TO 4                                             
      ULAS=UEFF                                                         
      RHO=RHO-H                                                         
      N = N-1                                                           
      IF(RHO.GT.0) GO TO 2                                              
      RHOT=0                                                            
      RHO = 0                                                           
      IF ( L .EQ. 0 ) GO TO 11                                          
      WRITE(6,1010)L                                                      
 1010 FORMAT(1H0,2X,'--- RHOT < H FOR L = ',I3,' ---')                  
      RHOT = H                                                          
      GO TO 11                                                          
 4    RHOT = RHO                                                        
      IF ( RHO .GE. ROMAX ) GO TO 160                                   
      IF(DABS(UEFF-1.D0).GT.EPS) GO TO 5                                
      GO TO 11                                                          
C                                                                       
C     USE REGULA FALSI TO LOCATE CTP WITHIN (RHO,RHO-H)                 
C                                                                       
  5   RO1=RHO                                                           
      RO2=RHO+H                                                         
      U1=UEFF                                                           
      U2=ULAS                                                           
    6 RO3=(RO2*(U1-1)+RO1*(1-U2))/(U1-U2)                               
      RO=RO3                                                            
      ASSIGN 7 TO IK                                                    
      GO TO 710                                                         
    7 IF(DABS(UEFF-1.D0).GT.EPS) GO TO 8                                
      RHOT=RO3                                                          
      GO TO 11                                                          
    8 IF(UEFF.LT.1) GO TO 9                                             
      RO1=RO3                                                           
      U1=UEFF                                                           
      GO TO 10                                                          
    9 RO2=RO3                                                           
      U2=UEFF                                                           
   10 NITS=NITS+1                                                       
      IF(NITS.LE.NMAX) GO TO 6                                          
      ACC=DABS(UEFF-1.D0)                                               
      WRITE(6,110) L,NMAX,EPS,ACC                                          
  110 FORMAT ( '0**** SWKB: FOR L = ',I3,' AFTER ',I4,' ITERATIONS'/  3X
     *, 'REQUESTED ACCURACY OF ',D12.4,' CANNOT BE ACHIEVED '  3X, 'ACCU
     *RACY ACHIEVED = ',D12.4)                                          
      RHOT=RO3                                                          
C                                                                       
C     EVALUATE D(UEFF)/D(RHO) AT CTP                                    
C                                                                       
 11   X = (RHOT-RHO)                                                    
      DUN = -(12/H**2) * (VCOEFS(N,1) + X*(2*VCOEFS(N,2) +  3*X*VCOEFS(N
     *,3) ))                                                            
      DUL = 0                                                           
      IF ( L .NE. 0 ) DUL=-(2*FLL)/(RHOT**3)                            
      DUEFF=DUN+DUL                                                     
      RT=RHOT/FK                                                        
      IF(IPRINT.GT.1) WRITE(6,120) L,NITS,RHOT,RT,DUEFF, DUN, DUL     
  120 FORMAT ( 1H0,2X,'--- CTP FOR L = ',I3,' FOUND IN ',I4, ' ITERATION
     *S', 3X,'RHOT = ',G13.5,' RT = ',G13.5/  ' DUEFF =', G14.5,  '    D
     *UN+DUC = ',G13.5,' DUL = ',G13.5 )                                
      IF ( DUEFF.LT.0 .OR. RHOT .EQ. 0 ) GO TO 160                      
      WRITE(6,155) DUEFF                                                   
  155 FORMAT( '0****** DUEFF=',G15.5,' ERROR IN SWKB ***')              
C                                                                       
C     INTEGRATE FROM RHOT TO ROMAX TO EVALUATE WKB PHASE-SHIFT          
C     AND CLASSICAL DEFLECTION FUNCTION                                 
C                                                                       
 160  IF ( ETA .NE. 0 ) GO TO 165                                       
      PHC = 0                                                           
      TEMP = DSQRT(FLL)/ROMAX                                           
      GO TO 170                                                         
 165  TEMP = ETA/ECC                                                    
      PHC = DACOS(TEMP)                                                 
      TEMP = ( ETA + FLL/ROMAX ) / ECC                                  
 170  IF ( TEMP .GT. 1 ) TEMP = 1                                       
      PHI = DACOS(TEMP)                                                 
C                                                                       
      IF(ROMAX.GT.RHOT) GO TO 220                                       
      DELTR=0                                                           
      DELTIM=0                                                          
      TURN=PHC                                                          
      GO TO 230                                                         
  220 AP=(ROMAX-RHOT)/2                                                 
      BP=(ROMAX+RHOT)/2                                                 
      AD = ROMAX/2                                                      
      BD = 0                                                            
      IF ( RHOT .EQ. 0 ) GO TO 225                                      
      AD=1/RHOT-1/ROMAX                                                 
      AD=.5*DSQRT(AD)                                                   
      BD = 1/RHOT                                                       
 225  TEMR=0                                                            
      TEMI=0                                                            
      TEMP=0                                                            
C                                                                       
      DO 499 I = 1, NGAUSS                                              
C                                                                       
      WTP=AP*WTS(I)                                                     
      WTD=AD*WTS(I)                                                     
      RO=AP*PTS(I)+BP                                                   
      XVAL = AD*(1+PTS(I))                                              
      ASSIGN 185 TO IK                                                  
      GO TO 700                                                         
  185 UEFFC=FLL/RO**2                                                   
      Y=RO/RHOC                                                         
      IF(RO.LT.RHOC) UEFFC=UEFFC+UC0*(1.5-.5*(Y**2))                    
      IF(RO.GE.RHOC) UEFFC=UEFFC+UC0/Y                                  
      W = -(12/H**2) * ( WARRAY(N) +  X*(WCOEFS(N,1) + X*(WCOEFS(N,2) + 
     *X*WCOEFS(N,3) )))                                                 
      UE1=1-UEFF                                                        
      IF(UE1.LT.0) UE1=0                                                
      UE2=DSQRT(UE1**2+W**2)                                            
      IF((UE2-UE1).LT.0) UE2=UE1                                        
      FINTI=TP*DSQRT(UE2-UE1)                                           
      FINTR=TP*DSQRT(UE2+UE1)                                           
      IF(RO.LE.ROTC) GO TO 195                                          
      UEC=1-UEFFC                                                       
      IF(UEC.LT.0) UEC=0                                                
      FINTR=FINTR-DSQRT(UEC)                                            
 195  IF ( RHOT .EQ. 0 ) GO TO 190                                      
      RO= BD-XVAL*XVAL                                                  
      RO=1/RO                                                           
      GO TO 197                                                         
 190  RO = .5*AD*(1+PTS(I))**2                                          
 197  ASSIGN 200 TO IK                                                  
      GO TO 700                                                         
  200 UER=1-UEFF                                                        
      IF (UER .LE. 0) GO TO 900                                         
      FINTD=XVAL/DSQRT(UER)                                             
  207 TEMI=TEMI+WTP*FINTI                                               
      TEMR=TEMR+WTP*FINTR                                               
      TEMP=TEMP+WTD*FINTD                                               
C                                                                       
 499  CONTINUE                                                          
C                                                                       
      DELTR=TEMR                                                        
      DELTIM=TEMI                                                       
      TURN=2*(L+.5)*TEMP+PHC-PHI                                        
  230 THETA=PI-2*TURN                                                   
      THETC=PI-2*PHC                                                    
C                                                                       
   50 RETURN                                                            
C                                                                       
C     CALCULATE (DIMENSIONLESS) EFFECTIVE POTENTIAL                     
C                                                                       
C                                                                       
C     GET U EFFECTIVE                                                   
C                                                                       
 700  N = (RO-ROSTRT)/H + 1                                             
 710  X = (RO-ROSTRT-(N-1)*H)                                           
      UEFF = ((12/H**2)+VCONS) - (12/H**2) * ( VARRAY(N)  + X*(VCOEFS(N,
     *1) + X*(VCOEFS(N,2) + X*VCOEFS(N,3) )))  + FLL/RO**2              
      GO TO IK, ( 7, 185, 200 )                                         
C                                                                       
C                                                                       
 900  WRITE(6,903) L, I, RHOT, RT, XVAL, RO, UEFF, UER                    
 903  FORMAT ( '0**** SWKB ERROR AT STMNT 205:', 2I5 /  6X, 6G15.5 )    
      RETURN                                                            
      END                                                               
      FUNCTION TCOEF ( ITYP, LAS, L, JP, JSP )                          
C                                                                       
C     COMPUTES COEFFICIENTS FOR THE TENSOR POTENTIALS.                  
C                                                                       
C                                                                       
C     ITYP = 1 FOR TR, 2 FOR TL, 3 FOR TPR.                             
C     LAS = ASYMPTOTIC ORBITAL ANGULAR MOMENTUM.                        
C     L = LOCAL ORBITAL ANGULAR MOMENTUM.                               
C     JP = 2 * PROJECTILE TOTAL ANGULAR MOMENTUM.                       
C     JSP = 2 * SPIN OF PROJECTILE.                                     
C                                                                       
C                                                                       
C     THIS VERSION WORKS FOR SPIN-1 (JSP=2) PROJECTILES ONLY.           
C     FOR OTHER VALUES OF JSP, A DIAGNOSTIC IS PRINTED FOR THE          
C     LAS=L=0 PARTIAL WAVE ONLY, AND ZERO IS RETURNED.                  
C                                                                       
C     NOTE:  TPR IS THE DIFFERENCE TP - P**2*TR, IN THE                 
C     LOCAL MOMENTUM APPROXIMATION.  SEE R. P. GODDARD,                 
C     PH.D. THESIS, UNIVERSITY OF WISCONSIN - MADISON (1978),           
C     SECT. 4.4.                                                        
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      REAL*4 TNAME(3)                                                   
      DATA TNAME/'TR', 'TL', 'TPR'/                                     
C                                                                       
C     CHECK FOR ILLEGAL SPIN.                                           
C                                                                       
      IF ( JSP .EQ. 2 ) GO TO 80                                        
      IF ( L + LAS .EQ. 0 ) WRITE(6,23) TNAME(ITYP), JSP                  
 23   FORMAT ( '0***** TCOEF - ', A3, ' POTENTIAL IS LEGAL FOR SPIN 1'  
     *' ONLY, SPIN =', I2, '/2.' )                                      
 50   TCOEF = 0.                                                        
      RETURN                                                            
C                                                                       
C     BRANCH ACCORDING TO TYPE AND ANGULAR MOMENTA.                     
C                                                                       
 80   AL = L                                                            
      I = L - JP/2 + 1                                                  
      IF ( L .NE. LAS ) I = 3                                           
      I = 3*I + ITYP                                                    
      GO TO (110, 120, 50, 210, 220, 50, 310, 320, 50, 410, 50, 430), I 
C                                                                       
C     J = L+1 = LAS+1                                                   
C                                                                       
C     TR                                                                
 110  TCOEF = -AL / (6.*AL + 9.)                                        
      RETURN                                                            
C     TL                                                                
 120  TCOEF = AL*(2.*AL-1.)/6.                                          
      RETURN                                                            
C                                                                       
C     J = L = LAS                                                       
C                                                                       
C     TR                                                                
 210  TCOEF = 1.D0 / 3.D0                                               
      RETURN                                                            
C     TL                                                                
 220  TCOEF = -(2.*AL-1.)*(2.*AL+3.)/6.                                 
      RETURN                                                            
C                                                                       
C     J = L-1 = LAS-1                                                   
C                                                                       
C     TR                                                                
 310  TCOEF = -(AL+1.) / (6.*AL-3.)                                     
      RETURN                                                            
C     TL                                                                
 320  TCOEF = (AL+1.)*(2.*AL+3.)/6.                                     
      RETURN                                                            
C                                                                       
C     OFF-DIAGONAL POTENTIAL                                            
C                                                                       
C     TR                                                                
 410  AL = JP/2                                                         
      TCOEF = DSQRT (AL*(AL+1.))/(2.*AL+1.)                             
      RETURN                                                            
C     TPR ( = TP - TR*P**2 IN LOCAL MOMENTUM APPROXIMATION)             
 430  AL = JP/2                                                         
      TCOEF = -(2.*AL+1.)*DSQRT (AL*(AL+1.))                            
      RETURN                                                            
      END                                                               
      SUBROUTINE TEMP1                                                  
C                                                                       
C     THESE ARE 3 DUMMIES THAT ARE CALLED BY THE KEYWORD                
C        CALL TEMP1, CALL TEMP2, CALL TEMP3                             
C                                                                       
C     2/10/75 - S.P.                                                    
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE TEMP2                                                  
      RETURN                                                            
      END                                                               
      SUBROUTINE TEMP3                                                  
      RETURN                                                            
      END                                                               
      SUBROUTINE TMATCH ( WAVR, WAVI, CR, CI, SMATS, JP, NWP, NWAVF )   
C                                                                       
C     CALCULATES S-MATRIX AND RENORMALIZATION FOR TENSOR-COUPLED WF.    
C                                                                       
C                                                                       
C     THE ARGUMENTS ARE:                                                
C                                                                       
C     WAVR, WAVI - INPUT UN-NORMALIZED WAVE FUNCTIONS,                  
C        DIMENSION (NWAVEF,2,2) (SEE COMMENTS IN WAVETC).               
C     CR, CI - COMPUTED RENORMALIZATIONS, DIMENSION (2,2),              
C        INDEXED BY IS = 1 OR 2 FOR THE 2 INDEPENDENT SOLUTIONS,        
C        AND BY ILAS = 1 OR 2 FOR LAS = J-1 OR J+1.                     
C     SMATS - COMPUTED S-MATRIX ELEMENTS (STORED BY JPTOLX).            
C     JP - 2*J OF PROJECTILE.                                           
C     NWP - CHANNEL NUMBER (1 OR 2).                                    
C                                                                       
C     THE 4-BY-4 SYSTEM TO SOLVE IS                                     
C                                                                       
C     ( -AC(J-1,R1)    0       U(J-1,1,R1) U(J-1,2,R1) )                
C     ( -AC(J-1,R2)    0       U(J-1,1,R2) U(J-1,2,R2) ) *              
C     (     0      -AC(J+1,R1) U(J+1,1,R1) U(J+1,2,R1) )                
C     (     0      -AC(J+1,R2) U(J+1,1,R2) U(J+1,2,R2) )                
C                                                                       
C        ( S(J-1,J-1) S(J-1,J+1) )   ( A(J-1,R1)    0      )            
C      * ( S(J+1,J-1) S(J-1,J-1) ) = ( A(J-1,R2)    0      )            
C        ( C(1,J-1)   C(1,J+1)   )   (     0     A(J+1,R1) )            
C        ( C(2,J-1)   C(2,J+1)   )   (     0     A(J+1,R2) )            
C                                                                       
C     WHERE A(LAS,R) = (F + I*G)/2 (F, G = COULOMB WAVE FUNCTIONS),     
C     AC(L,R) = (F - I*G)/2, U(L,I,R) IS THE UN-NORMALIZED WAVE         
C     FUNCTION, S(L,LAS) IS THE NUCLEAR S MATRIX, AND C(I,LAS)          
C     IS THE NORMALIZATION, FOR ORBITAL ANGULAR MOMENTUM L,             
C     ASYMPTOTIC ORBITAL ANGULAR MOMENTUM LAS, RADII R = R1 AND R2,     
C     AND SOLUTION I.                                                   
C                                                                       
C          THE S-MATRIX ELEMENTS ARE PRINTED IF REQUESTED               
C     (1000 DIGIT OF IPRINT).                                           
C                                                                       
C                                                                       
C     2/7/79 - SPLIT OFF FROM WAVETC - RPG                              
C     3/1/79 - CHANGE TO GAUSSIAN ELIMINATION METHOD - RPG              
C     8/3/79 - STANDARD PREFIXES, CALL JPTOLX TO TRANSLATE S - RPG      
C     6/3/80 - GET NWAVF DIMENSION FOR CDC COMPATABILITY - S.P.         
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL WAVR, WAVI, SMATS                                   
C                                                                       
      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) )                                                          
      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                                                                       
      DIMENSION WAVR(NWAVF,2,2), WAVI(NWAVF,2,2),  CR(2,2), CI(2,2), SMA
     *TS(1)                                                             
C                                                                       
      DIMENSION F1(2), G1(2), F2(2), G2(2), ABI(2), U1R(2,2),  U1I(2,2),
     * U2R(2,2), U2I(2,2), BYR(2,2), BYI(2,2)                           
      CHARACTER*8 CHANAM(3)                                             
      DATA CHANAM/'INCOMING', 'OUTGOING' , ' '/                         
C                                                                       
C      F IS THE REGULAR COULOMB WAVE                                    
C      G IS THE IRREGULAR COULOMB WAVE                                  
C  NOTE THAT F1,G1 ARE REGULAR AND IRREGULAR COULOMB FUNTIONS AT NBACK  
C                                                                       
      I = JP/2 - 1 + (IOFFIT-1)*(LOMOST+1)                              
      LF = (Z(NFS(NWP))+I)                                              
      LG = (Z(NGS(NWP))+I)                                              
      LF1 = (Z(NF1S(NWP))+I)                                            
      LG1 = (Z(NG1S(NWP))+I)                                            
      NSTEP = NSTPSS(NWP)                                               
C                                                                       
C     REDUCE THE 4-BY-4 SYSTEM TO A 2-BY-2 SYSTEM FOR THE NORMALIZATIONS
C     ONLY.  THE RIGHT-HAND SIDE (ABI) IS A DIAGONAL, PURELY IMAGINARY  
C     MATRIX.                                                           
C                                                                       
      DO 519 IL = 1, 2                                                  
      I = 2*IL - 2                                                      
      F1(IL) = 0.5*ALLOC(LF+I)                                          
      G1(IL) = 0.5*ALLOC(LG+I)                                          
      F2(IL) = 0.5*ALLOC(LF1+I)                                         
      G2(IL) = 0.5*ALLOC(LG1+I)                                         
      ABI(IL) = F2(IL)*G1(IL) - F1(IL)*G2(IL)                           
      ABI(IL) = ABI(IL) + ABI(IL)                                       
      DO 509 IS = 1, 2                                                  
      U1R(IL,IS) = WAVR(NSTEP+1,IL,IS)                                  
      U1I(IL,IS) = WAVI(NSTEP+1,IL,IS)                                  
      U2R(IL,IS) = WAVR(NSTEP+1-NBAKCM,IL,IS)                           
      U2I(IL,IS) = WAVI(NSTEP+1-NBAKCM,IL,IS)                           
      BYR(IL,IS) = F2(IL)*U1R(IL,IS) + G2(IL)*U1I(IL,IS)  - F1(IL)*U2R(I
     *L,IS) - G1(IL)*U2I(IL,IS)                                         
      BYI(IL,IS) = F2(IL)*U1I(IL,IS) - G2(IL)*U1R(IL,IS)  - F1(IL)*U2I(I
     *L,IS) + G1(IL)*U2R(IL,IS)                                         
 509  CONTINUE                                                          
 519  CONTINUE                                                          
C                                                                       
C     SOLVE THE 2-BY-2 SYSTEM FOR THE NORMALIZATIONS (CR,CI).           
C                                                                       
C     THE SYSTEM IS SOLVED BY GAUSSIAN ELIMINATION.  FOR A COMPLEX      
C     2-BY-2 SYSTEM THIS IS SLIGHTLY SLOWER THAN USING DETERMINANTS,    
C     BUT IT AVOIDS INTERMEDIATE RESULTS INVOLVING THE FOURTH POWER     
C     OF THE WAVE FUNCTIONS.  WE ASSUME THAT THE LARGEST ELEMENTS OF    
C     BY ARE ON THE DIAGONAL - TRUE IF THE TENSOR POTENTIAL IS SMALL.   
C                                                                       
      TEMP = BYR(1,1)**2 + BYI(1,1)**2                                  
      PIVR = BYR(1,1)/TEMP                                              
      PIVI = -BYI(1,1)/TEMP                                             
      TEMP = PIVR*BYR(1,2) - PIVI*BYI(1,2)                              
      BYI(1,2) = PIVR*BYI(1,2) + PIVI*BYR(1,2)                          
      BYR(1,2) = TEMP                                                   
      CR(1,1) = -PIVI*ABI(1)                                            
      CI(1,1) = PIVR*ABI(1)                                             
      BYR(2,2) = BYR(2,2) - BYR(2,1)*BYR(1,2) + BYI(2,1)*BYI(1,2)       
      BYI(2,2) = BYI(2,2) - BYR(2,1)*BYI(1,2) - BYI(2,1)*BYR(1,2)       
      CR(2,1) = -BYR(2,1)*CR(1,1) + BYI(2,1)*CI(1,1)                    
      CI(2,1) = -BYR(2,1)*CI(1,1) - BYI(2,1)*CR(1,1)                    
      TEMP = BYR(2,2)**2 + BYI(2,2)**2                                  
      PIVR = BYR(2,2)/TEMP                                              
      PIVI = -BYI(2,2)/TEMP                                             
      TEMP = PIVR*CR(2,1) - PIVI*CI(2,1)                                
      CI(2,1) = PIVR*CI(2,1) + PIVI*CR(2,1)                             
      CR(2,1) = TEMP                                                    
      CR(2,2) = -PIVI*ABI(2)                                            
      CI(2,2) = PIVR*ABI(2)                                             
      CR(1,1) = CR(1,1) - BYR(1,2)*CR(2,1) + BYI(1,2)*CI(2,1)           
      CI(1,1) = CI(1,1) - BYR(1,2)*CI(2,1) - BYI(1,2)*CR(2,1)           
      CR(1,2) = -BYR(1,2)*CR(2,2) + BYI(1,2)*CI(2,2)                    
      CI(1,2) = -BYR(1,2)*CI(2,2) - BYI(1,2)*CR(2,2)                    
C                                                                       
C     NOW SUBSTITUTE BACK TO FIND THE S-MATRIX ELEMENTS.                
C                                                                       
      NNWP = NWP                                                        
      IF ( STANSW ) NNWP = 3                                            
      DO 559 IL = 1, 2                                                  
      LL = ( JP/2 - 3 ) + 2*IL                                          
      DENA = F1(IL)*F1(IL) + G1(IL)*G1(IL)                              
      DENR = F1(IL)/DENA                                                
      DENI = G1(IL)/DENA                                                
      DO 549 ILAS = 1, 2                                                
      LLAS = ( JP/2 - 3 ) + 2*ILAS                                      
      TR = U1R(IL,1)*CR(1,ILAS) - U1I(IL,1)*CI(1,ILAS)  + U1R(IL,2)*CR(2
     *,ILAS) - U1I(IL,2)*CI(2,ILAS)                                     
      TI = U1R(IL,1)*CI(1,ILAS) + U1I(IL,1)*CR(1,ILAS)  + U1R(IL,2)*CI(2
     *,ILAS) + U1I(IL,2)*CR(2,ILAS)                                     
      IF ( IL .NE. ILAS ) GO TO 530                                     
      TR = TR - F1(IL)                                                  
      TI = TI - G1(IL)                                                  
 530  SJR = TR*DENR - TI*DENI                                           
      SJI = TR*DENI + TI*DENR                                           
C                                                                       
C           PRINT ELASTIC S-MATRIX IF REQUESTED (1000 DIGIT OF IPRINT)  
C                                                                       
      IF ( .NOT. PWAVSW ) GO TO 540                                     
      WRITE(6,543) CHANAM(NNWP), LL, LLAS, JP, SJR, SJI                   
 543  FORMAT ( 1X,A8, ' ELASTIC S-MATRIX FOR L =', I4, ',  LAS =', I4, '
     *,   JP =', I4, '/2:', G15.5, ' +', G13.5, ' I' )                  
C                                                                       
C           TRANSLATE S-MATRICES TO LX SYSTEM AND STORE THEM.           
C                                                                       
 540  CALL JPTOLX ( LL, LLAS, JP, NWP, SJR, SJI,  ALLOC(Z(IINDXE(NWP))),
     * SMATS )                                                          
 549  CONTINUE                                                          
 559  CONTINUE                                                          
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE VCSQ12(R,VC,K)                                         
CDC      SUBROUTINE VCSQ12 (R,VC,KIN,IZ2,KIN2)                          
C     COULOMB POTENTIAL BETWEEN TWO UNIFORM CHARGE DISTRIBUTIONS        
C     USES EXPLICIT EXPRESSION V(COULOMB) = 1/R*(POLYNOMIAL IN R)       
C     EXPRESSION GIVEN BY POLING ET.AL. PHYS.REV.C13,648,1976           
C     SUBROUTINE CHECKED BY NUMERICAL QUADRATURE TO 12 FIGURES          
C     MHM - MARCH 9 1976                                                
C                                                                       
C     IF R1 OR R2 IS ZERO EXPRESSION REDUCES TO COULOMB                 
C     POTENTIAL OF POINT CHARGE IN A UNIFORM FIELD OF RADIUS            
C     EQUAL TO WHICHEVER OF R1 AND R2 IS NONZERO                        
C                                                                       
C     MHM - APRIL 25 1976                                               
C                                                                       
C     DIMENSIONED TO PERMIT CALCULATION OF POTENTIAL BETWEEN UP TO      
C     3 DISTINCT PAIRS OF CHARGE DISTRIBUTIONS                          
C     MHM - APRIL 29 1976                                               
C     4/26/78 - REMOVE ENTRIES FOR CRAY VERSION - S.P.                  
C     12/28/79 - CIB TO CND - RPG                                       
C     7/14/80 - SECOND CRAY VERSION NOW THE SAME AS IBM - S.P.          
C     7/16/80 - FIX BUG IN ABOVE - S.P.                                 
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
C     MAIN ENTRY ; COMPUTE COULOMB POTENTIAL AT R                       
C                                                                       
      COMMON /VCSBLK/ A(3),B(3),C(3),D(3),E(3),F(3),X(3),Y(3),R1(3), R2(
     *3),VC0(3)                                                         
C                                                                       
      COMMON /CNSTNT/PI,RT4PI,PIINV,RAD,DEG,HBARC,AMUMEV,AFINE          
C                                                                       
CDC      K=KIN                                                          
      IF(R.LT.(R1(K)+R2(K))) GO TO 1                                    
      VC=VC0(K)/R                                                       
      RETURN                                                            
    1 IF(R.GT.(R1(K)-R2(K))) GO TO 2                                    
      VC=X(K)+Y(K)*R*R                                                  
      RETURN                                                            
    2 VC=A(K)+R*(B(K)+R*(C(K)+R*(D(K)+R*(E(K)+R*R*F(K)))))              
      VC=VC/R                                                           
      RETURN                                                            
C                                                                       
C     INITIAL ENTRY ONLY; COMPUTE COEFFICIENTS OF POLYNOMIALS           
C                                                                       
      ENTRY SETVSQ ( RR1, RR2, IZ1, IZ2, K )                            
C                                                                       
C                                                                       
CDC      RR1=R                                                          
CDC      RR2=VC                                                         
CDC      IZ1=KIN                                                        
CDC      K=KIN2                                                         
      R1(K)=RR1                                                         
      R2(K)=RR2                                                         
      VC0(K)=IZ1*IZ2*(HBARC/AFINE)                                      
      IF(R1(K).GE.R2(K)) GO TO 3                                        
      TEM=R2(K)                                                         
      R2(K)=R1(K)                                                       
      R1(K)=TEM                                                         
    3 R1SQ=R1(K)*R1(K)                                                  
      R2SQ=R2(K)*R2(K)                                                  
      R13=R1SQ*R1(K)                                                    
      IF(R2(K).EQ.0) GO TO 4                                            
      R14=R13*R1(K)                                                     
      R15=R14*R1(K)                                                     
      R16=R15*R1(K)                                                     
      R23=R2SQ*R2(K)                                                    
      R24=R23*R2(K)                                                     
      R25=R24*R2(K)                                                     
      R26=R25*R2(K)                                                     
      R12C=R13*R23                                                      
      V=VC0(K)/R12C                                                     
      A(K)=(V*(R16-9*R14*R2SQ+16*R12C-9*R1SQ*R24+R26))/32               
      B(K)=-(3*V*(R15-5*R13*R2SQ-5*R1SQ*R23+R25))/20                    
      C(K)=(9*V*(R14-2*R1SQ*R2SQ+R24))/32                               
      D(K)=-(V*(R13+R23))/4                                             
      E(K)=(3*V*(R1SQ+R2SQ))/32                                         
      F(K)=-V/160                                                       
    4 IF(R1(K).EQ.0) RETURN                                             
      X(K)=.3D0*(5*R1SQ-R2SQ)*(VC0(K)/R13)                              
      Y(K)=-.5*(VC0(K)/R13)                                             
C                                                                       
   50 RETURN                                                            
      END                                                               
      SUBROUTINE WAVEF ( IRET )                                         
C                                                                       
C  WAVEF CALCULATES RADIAL WAVEFUNCTION FOR ALL PARTIAL WAVES           
C  USING WOOD-SAXON POTENTIAL                                           
C                                                                       
C     THIS ROUTINE IS USED ONLY FOR STAND-ALONE CALCULATIONS OF         
C     ELASTIC SCATTERING.  IT IS AN INTERFACE TO WAVSET, WAVPOT         
C     AND WAVELJ WITH A COUPLE OF BELLS AND WHISTLES ADDED.             
C                                                                       
C     IF L IS DEFINED THEN THE CALC IS DONE FOR ONLY ONE VALUE OF       
C     L; ELSE THE RANGE (LMIN, LMAX) IS USED.                           
C     IF THERE IS A SPIN-ORBIT FORCE THEN JP IS CHECKED.  IF IT IS      
C     DEFINED THEN ONLY THAT JP (AND THE ASSOCIATED L'S) ARE DONE.      
C     IF IT IS NOT DEFINED THEN ALL JP'S FOR EACH L ARE DONE.           
C                                                                       
C     SEE WAVSET FOR DEFINITIONS OF THE POTENTIALS AND WAVEFUNCTION.    
C                                                                       
C            THIS VERSION 3/73   D.GLOECKNER                            
C  REVISED 8/19/73                                                      
C     1/16/75 - ADD COULF; SMALL FIXES - S. PIEPER                      
C     1/28/75 - USE /CNSTNT/                                            
C     1/31/75 - PRINTING CONTROLED BY IPRINT - S.P.                     
C     2/19/75 - NOLONGER USED FOR DWBA CALCS.                           
C     2/22/75 - DON'T DIVIDE BY 0 ASO, AIDIFU; CHANGE PRINT OUT         
C               USE IWAVES ARRAY; BETTER NFIRST CHOICE                  
C     2/25/75 - LOTS OF INPUT CHECKING, RETURN CODE                     
C     3/3/75  - PRINT OUTPUT NICELY                                     
C     3/5/75 - AVOID UNDERFLOW DUE TO BKM1 UNDEFINED                    
C     4/20/75 - NEW COMMON BLOCK; REMOVE S.O. SINCE IT IS WROING        
C     5/24/75 - MASSIVE SIMPLIFICATION - USE WAVSET, WAVPOT, WAVELJ     
C     10/1/75 - NEW ELDCS CALL                                          
C     10/7/75 - POTENTIALS TO MAKPOT                                    
C     10/14/75 - AUTOMATIC LMIN, LMAX; IMPROVED PRINTOUT                
C     11/6/75 - PHASE SHIFTS IN DEGREES                                 
C     3/23/76 - USE MANCHESTER COULOMB ROUTINE                          
C     6/7/76 - T(L), REACTION CROSS SECTION, KAHANA                     
C     11/19/76 - AVOID OVERFLOWS IN ASYMPTOTIC CHECK.                   
C     2/3/77 - REMOVE SAVEWAVE; ADD REALWAVE; CHECK AND PRINT ONLY      
C              ON LAST COMPUTATION OF A RANGE.                          
C     2/10/77 - CHANGE ELDCS CALL; IMPROVE CHOICE OF LMIN, LMAX         
C     3/21/77 - FIX REACTION CROSS SEC. FOR S.O. FORCES - S.P.          
C     4/18/77 - USE LMINSUB, LMAXMULT.                                  
C     4/21/77 - FIX ERROR IN SINGLE JP CALCULATIONS                     
C     4/24/77 - IDENTICAL PARTICLES; FITSW                              
C     5/7/77 - NO CCOEFS; ELDCS DOES TOTAL CROSS SECTIONS               
C     11/20/77 - NEW STORAGE OF WELL DEPTHS - S.P.                      
C     12/1/77 - WAVSET NOW FINDS LCRITICAL - S.P.                       
C     3/26/78 - GET OUTPUT INTO 80 COLUMNS; MUNICH FIXES - S.P.         
C     4/24/78 - REVERSE LOMOST FOR LIMOST - S.P.                        
C     5/21/78 - NEW WAVELJ STRUCTURE, CRAY STUFF - S.P.                 
C     6/13/78 - IMAG S.O. NOLONGER REQUIRES SPECIAL ARRAY - S.P.        
C     12/28/78 - ADD TENSOR COUPLING - RPG                              
C     9/10/79 - STANDARD PREFIXES ETC.; REMOVE OUTDATED CRAY STUFF;     
C        USE TOC ARRAY, LX BASIS; S.O. ETC. FOR GENERAL SPIN - RPG      
C     11/2/79 - CALCULATE ANALYZING POWERS - RPG                        
C     11/20/79 - S-MATRICES STORED BY L-LAS - S.P.                      
C     3/7/80 - FIX ISTRT PROBLEMS FOR REALWAVE, ETC. - S.P.             
C     4/23/80 - USE PWBGSW INSTEAD OF PBUGSW - S.P.                     
C     9/17/81 - NAME FOR RUTHERFORD PASSED TO ELDCS - 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                                           
      COMMON /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
      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                                                                 
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      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
     *) )                                                               
      COMMON / TEMPVS / TVR, TVI, TVSOR, TVSOI, TAR, TAI                
C                                                                       
      LOGICAL ONEJSW, SOSW, TCSW, THISTC, FKEPSW                        
      CHARACTER*8 RUTNAM, RUTHNM                                        
      DATARUTHNM/'RUTHERFO'/                                            
      DATA RUTNAM / 'TORUTHER' /                                        
C                                                                       
      OPEN(UNIT=8,FILE='SMATR.PLT',STATUS='UNKNOWN',FORM='FORMATTED')
      IPRNT = MOD( IPRINT, 10 )                                         
      IF ( IPRNT .GT. 0 ) WRITE(6,13) REACT, ELAB, HEADER                 
 13   FORMAT ( X, T48, 'P T O L E M Y' /  X, 45A1, F8.2, ' MEV', 5X,
     * 65A1 )                                                           
C                                                                       
C     TEST THE INPUT AND RETURN  0  COMPLETION CODE IF BAD              
C                                                                       
      IRET = 0                                                          
      LLMAX = LMAX                                                      
      LLMIN = LMIN                                                      
      LSAVE = L                                                         
      JPSAVE = JP                                                       
C                                                                       
      IF ( L .EQ. NOTDEF ) GO TO 60                                     
C                                                                       
C     DOING ONLY ONE L                                                  
C                                                                       
      LLMAX = L                                                         
      LLMIN = L                                                         
C                                                                       
 60   IF ( ICHANW .GT. 2 ) ICHANW = 1                                   
C                                                                       
C     SET UP ARRAYS AND PRINT PARAMETERS.                               
C                                                                       
      CALL WAVSET ( IRET, .TRUE., .FALSE. ) 
      IF ( IRET .EQ. 0 ) GO TO 9900                                     
      IRET = 0                                                          
      LSKIP = LSKIPS(ICHANW)                                            
      ISTAT = ISTATS(ICHANW)                                            
C                                                                       
      IF ( LLMIN .EQ. NOTDEF .OR. LLMAX .EQ. NOTDEF ) GO TO 80          
C                                                                       
C     LSKIP = 2 ONLY FOR IDENTICAL SPIN 0 SCATTERING                    
C                                                                       
      IF ( LSKIP .EQ. 2 ) LLMIN = IABS( LLMIN - MOD(LLMIN,2) )          
      IF ( LSKIP .EQ. 2 ) LLMAX = LLMAX + MOD(LLMAX,2)                  
      GO TO 100                                                         
C                                                                       
C     GET ESTIMATE OF L CRITICAL                                        
C                                                                       
 80   LCRIT = LCRITS(ICHANW)                                            
C                                                                       
      IF ( LLMIN .NE. NOTDEF ) GO TO 85                                 
      LLMIN = LCRIT*ALMNMT                                              
      LLMIN = MIN0( LLMIN, LCRIT-LMINSB )                               
      LLMIN = MAX0( LLMIN, 0 )                                          
      IF ( LSKIP .EQ. 2 ) LLMIN = IABS( LLMIN - MOD(LLMIN,2) )          
 85   IF ( LLMAX .EQ. NOTDEF )  LLMAX = MAX0( LCRIT+LMAXAD, INT(ALMXMT*L
     *CRIT) )                                                           
      IF ( LSKIP .EQ. 2 ) LLMAX = LLMAX + MOD(LLMAX,2)                  
C                                                                       
 100  WRITE(6,103) LLMIN, LLMAX                                           
 103  FORMAT ( X, I10, ' =< L =<', I4 )                               
C     ARE WE DOING ONLY ONE JP                                          
C                                                                       
      SOSW = SOSWS(ICHANW)                                              
      TCSW = TCSWS(ICHANW)                                              
      ONEJSW = JP .NE. NOTDEF                                           
      ISPST = 0                                                         
      ISPND = 0                                                         
      SPNAV = 1                                                         
      IF ( .NOT. SOSW ) GO TO 200                                       
      SPNAV = 1.D0/(JSP+1)                                              
      IF ( ONEJSW ) GO TO 150                                           
C     DOING ALL JP FOR EACH L                                           
      ISPST = -JSP                                                      
      ISPND = JSP                                                       
      GO TO 200                                                         
 150  IF ( MOD(JP+JSP, 2) .EQ. 0 ) GO TO 160                            
      WRITE(6,153) JP, JSP                                                
 153  FORMAT ( '0**** JP AND SP ARE AN INVALID HALF-INTEGER AND ',  'INT
     *EGER COMBINATION:', 2(I6, '/2') )                                 
      GO TO 9900                                                        
C     ONLY DOING ONE JP, REDUCE L-RANGE                                 
 160  LLMIN = MAX0( LLMIN, (JP-JSP)/2 )                                 
      LLMAX = MIN0( LLMAX, (JP+JSP)/2 )                                 
      IF ( LLMIN .LE. LLMAX ) GO TO 200                                 
      WRITE(6,163) JP, JSP, LMIN, LMAX, L                                 
 163  FORMAT ( '0**** THERE ARE NO VALID COMBINATIONS OF JP, SP AND L:',
     * '   JP, SP =', 2(I5, '/2') /  ' LMIN, LMAX =', 2I5, '  OR  L =', 
     *I5 )                                                              
      GO TO 9900                                                        
C                                                                       
 200  LOMOST = LLMAX                                                    
      IF ( TCSW .AND. L .NE. NOTDEF ) LOMOST = LLMAX + 2                
C                                                                       
C     SET UP S-MATRIX AND COULOMB WF ARRAYS.                            
C                                                                       
      CALL WAVPOT (IRET)                                                
      IF ( IRET .EQ. 0 ) GO TO 9900                                     
      IRET = 0                                                          
      NSTEP = NSTPSS(ICHANW)                                            
      NSTEPS = NSTEP + 1                                                
      ETA = ETAS(ICHANW)                                                
      H = HS(ICHANW)                                                    
      NSPL = NUMJS(ICHANW)                                              
C                                                                       
C     IF NECESSARY, GET WORK AREAS FOR THE ASYMPTOTIC CHECK             
C                                                                       
      IF ( ICHECK .EQ. 0 ) GO TO 210                                    
      LOCWRK = NALLOC( 2*(LLMAX+1), 'ASYWRK ' )                         
      NFJ = NALLOC( LLMAX+1, 'ASYF ' )                                  
      NGJ = NALLOC( LLMAX+1, 'ASYG ' )                                  
C                                                                       
 210  CONTINUE                                                          
C                                                                       
C                                                                       
C     ALL ALLOCATIONS DONE, GET LOCATIONS                               
C                                                                       
      LWAVR = Z(IWAVR)                                                  
      LWAVI = Z(IWAVI)                                                  
      LSMATS = Z(ISMATS(ICHANW)) - 1                                    
      LTOC = Z(ITOCE(ICHANW))*FACFR4 - FACFR4                           
      IF ( ICHECK .EQ. 0 ) GO TO 220                                    
      LFJ = Z(NFJ)                                                      
      LGJ = Z(NGJ)                                                      
      LWORK = Z(LOCWRK)                                                 
C                                                                       
C  SOME DERIVED DATA                                                    
C                                                                       
C     INITIALIZE S-MATRIX ELEMENTS TO ZERO.                             
C                                                                       
 220  CALL INIT8 ( ISMATS(ICHANW), 0.D0 )                               
C                                                                       
      IF ( LLMIN .EQ. LLMAX ) IPRNT = 1                                 
C                                                                       
C     PRINT HEADINGS IF NECESSARY.                                      
C                                                                       
      LINES = 35                                                        
      IF ( IPRNT .GT. 0 ) WRITE(6,255)
 255  FORMAT (/'  L    L     LX',18X,'S',24X,'!S!',4X,'PHASE SHIFT',2X, 
     *'COULOMB PHASE',7X,'ABSORBED' / 67X,'DEGREES',8X,'RADIAN',/ 1X)  
C 
 1260 CONTINUE
C
C     THIS BRINGS IN THE TABLES NEEDED BY RACAH.                        
C
      CALL DUMMY1                                                       
      LREALV = Z(IRLVS(ICHANW))                                         
      LIMAGV = Z(IIMVS(ICHANW))                                         
      LCENTR = Z(ICENTR(ICHANW))                                        
C                                                                       
C     LOOP THROUGH INCIDENT L.                                          
C                                                                       
      DO 399 L = LLMIN, LLMAX, LSKIP                                    
C                                                                       
C        LOOP THROUGH JP = 2*J(PROJECTILE).  SPIN OF TARGET IS IGNORED. 
C        S-MATRIX ELEMENTS FOR ALL LX ARE ACCUMULATED AS SUMS OVER JP.  
C                                                                       
      DO 259 ISP = ISPST, ISPND, 2                                      
      IF ( .NOT. ONEJSW ) JP = 2*L + ISP                                
      THISTC = TCSW .AND. JP .NE. 2*L .AND. JP-L .GE. 0                 
C                                                                       
C           SUBROUTINE WFGET CALLS EITHER WAVELJ (NO TENSOR) OR WAVETC  
C           (TENSOR COUPLING) TO DO THE ACTUAL CALCULATION.             
C                                                                       
      CALL WFGET ( L, L, JP, ICHANW, 0, ALLOC, ALLOC, ALLOC,  ALLOC(LWAV
     *R), ALLOC(LWAVI), ALLOC(LREALV), ALLOC(LIMAGV), ALLOC(LCENTR) )   
C                                                                       
 259  CONTINUE                                                          
C                                                                       
C        END OF CALCULATION LOOP THROUGH JP.                            
C        IF NECESSARY, RETRIEVE AND PRINT THE S-MATRIX ELEMENTS.        
C                                                                       
      IF ( IPRNT .EQ. 0 ) GO TO 399                                     
C                                                                       
C        PRINT HEADINGS IF NECESSARY.                                   
C                                                                       
C      IF ( LINES+NSPL .LT. 59 ) GO TO 270                               
C      WRITE(6,13) REACT, ELAB, HEADER                                     
C      WRITE(6,255)
C      LINES = 7                                                         
C                                                                       
C        CALCULATE THE FRACTION ABSORBED FROM THIS L.                   
C                                                                       
 270  TL = 1.                                                           
      I = LSMATS + 2*NSPL*L - 1                                         
      DO 279 KOFFS = 1, NSPL                                            
      I = I + 2                                                         
      TL = TL - ALLOC(I)**2 - ALLOC(I+1)**2                             
 279  CONTINUE                                                          
C                                                                       
C        LOOP THROUGH KOFFS = LX, LAS.  QUANTUM NUMBERS ARE             
C        IN THE TABLE-OF CONTENTS ARRAY.                                
C                                                                       
      DO 299 KOFFS = 1, NSPL                                            
      LX = ILLOC(LTOC+4*KOFFS-2)                                        
      LL = L + ILLOC(LTOC+4*KOFFS-3)                                    
      IF ( LX .GT. L+LL ) GO TO 299                                     
C                                                                       
C           RETRIEVE THE S-MATRIX ELEMENT, AND CALCULATE THE            
C           MAGNITUDE, PHASE, AND FRACTION ABSORBED.                    
C                                                                       
      I = LSMATS + 2*( NSPL*L + KOFFS ) - 1
      lsigk=z(isigs(ichanw))
      pcb=alloc(lsigk+l)
      SR = ALLOC(I)
      SI = ALLOC(I+1)
      TEMP = DSQRT( SR**2 + SI**2 )
      IF ( TEMP .EQ. 0 ) GO TO 299
      PHASE = 0.5*RADIAN*DATAN2( SI, SR )                               
C
C          PRINT IT.
C
      IF ( KOFFS .EQ. 1 ) GO TO 290                                     
      WRITE(8,283) L,LL,LX,SR,SI,TEMP,PHASE,pcb
      WRITE(6,283) L,LL,LX,SR,SI,TEMP,PHASE,pcb
 283  FORMAT (1X,I4,2I5,G16.8,' R',G16.8,' I', 4G15.6)
      GO TO 295
 290  WRITE(8,283) L,LL,LX,SR,SI,TEMP,PHASE,pcb,TL
      WRITE(6,283) L,LL,LX,SR,SI,TEMP,PHASE,pcb,TL
 295  LINES = LINES + 1                                                 
 299  CONTINUE                                                          
C                                                                       
C        END OF KOFFS LOOP FOR PRINTING.  INSERT A BLANK LINE IF NEEDED.
C                                                                       
      IF ( NSPL .EQ. 1 ) GO TO 399                                      
      WRITE(6,323)
 323  FORMAT ( 1X )                                                     
      LINES = LINES + 1                                                 
C                                                                       
 399  CONTINUE                                                          
C                                                                       
C     END OF LOOP OVER ALL L'S AND J'S                                  
C                                                                       
      L = LLMAX                                                         
C                                                                       
C     FOR SINGLE WAVEFUNCTION, REDEFINE WAVER AND WAVEI TO BE           
C     THE CORRECT SIZE WITH NO SLOP AT THE END                          
C                                                                       
      IF ( LLMAX .EQ. LLMIN .AND. .NOT. THISTC )  CALL IREDEF ( NSTEP+1,
     * IWAVR )                                                          
      IF ( LLMAX .EQ. LLMIN .AND. .NOT. THISTC )  CALL IREDEF ( NSTEP+1,
     * IWAVI )                                                          
C                                                                       
      LWAVR = Z(IWAVR)                                                  
      LWAVI = Z(IWAVI)                                                  
      ISTRT = LASTNF(ICHANW)-2                                          
C                                                                       
C     IF REQUESTED, ATTEMPT TO MAKE SCATTERING WAVE REAL                
C                                                                       
      ROTR = 1                                                          
      ROTI = 0                                                          
      IF ( IRLWAV .EQ. 0 ) GO TO 500                                    
      ROTR = DCOS( DEGREE*PHASE )                                       
      ROTI = -DSIN( DEGREE*PHASE )                                      
      DO 459 II = ISTRT, NSTEP                                          
      FR = ROTR*ALLOC(LWAVR+II) - ROTI*ALLOC(LWAVI+II)                  
      ALLOC(LWAVI+II) = ROTR*ALLOC(LWAVI+II) + ROTI*ALLOC(LWAVR+II)     
      ALLOC(LWAVR+II) = FR                                              
 459  CONTINUE                                                          
      IF ( .NOT. THISTC ) GO TO 500                                     
      DO 469 II = ISTRT, NSTEP                                          
      FR = ROTR*ALLOC(LWAVR+II+NWAVEF) - ROTI*ALLOC(LWAVI+II+NWAVEF)    
      ALLOC(LWAVI+II+NWAVEF) = ROTR*ALLOC(LWAVI+II+NWAVEF)+ROTI*ALLOC
     *(LWAVR+II+NWAVEF)                                                 
      ALLOC(LWAVR+II+NWAVEF) = FR                                       
 469  CONTINUE                                                          
C                                                                       
C     WF TABULATION INTERVAL IS 'WRITESTEP' KEYWORD.                    
C                                                                       
 500  NWRITE = 1                                                        
      IF ( WRITES .GT. 0 ) NWRITE = DMAX1( WRITES/STEPSZ+.5, 1.D0 )     
C                                                                       
C     IF REQUESTED ('CHECKASYM'), DO ASYMPTOTIC CHECK.                  
C                                                                       
      IF(ICHECK .EQ.0)GO TO 600                                         
      WRITE(6,513)                                                      
513   FORMAT('         ** ASYMTOTIC CHECK ** ' /  '  SOLUTION SHOULD GO 
     *TO ASYMPTOTIC FORM' //  '    R', 16X, 'F(R)', 15X, 'ASYMPTOTIC FOR
     *M', 7X,  'REL. ERROR' / )                                         
C                                                                       
C                                                                       
      DO 559 II = NWRITE, NSTEP, NWRITE                                 
      IF ( II .LT. ISTRT ) GO TO 559                                    
      RHOO=H*II                                                         
      RVAL = STEPSZ*II                                                  
      CALL RCWFN ( RHOO, ETA, L, L, ALLOC(LFJ), ALLOC(LWORK),  ALLOC(LGJ
     *), ALLOC(LWORK+LLMAX+1), 1.D-8, IFLAG )                           
      IF ( IFLAG .NE. 0 ) GO TO 9920                                    
      REALF=(ALLOC(LFJ+L)*(1.0D0+SR)+SI*ALLOC(LGJ +L))/2.0D0            
      AMAGF=(ALLOC(LGJ+L)*(1.0D0-SR)+SI*ALLOC(LFJ  +L))/2.0D0           
      FR = ROTR*REALF - ROTI*AMAGF                                      
      AMAGF = ROTR*AMAGF + ROTI*REALF                                   
      REALF = FR                                                        
      FR = ALLOC(LWAVR+II)                                              
      FI = ALLOC(LWAVI+II)                                              
      RATR = ( DABS(FR-REALF) + DABS(FI-AMAGF) ) /  ( DABS(FR) + DABS(FI
     *) )                                                               
      WRITE(6,553)RVAL, FR, FI, REALF, AMAGF,RATR                       
553   FORMAT( F7.2, 2X, 2G11.4, 4X, 2G11.4, G14.2 )                     
559   CONTINUE                                                          
C                                                                       
C     FREE ALLOCATED SPACE                                              
C                                                                       
      Z(NFJ) = -Z(NFJ)                                                  
      Z(NGJ) = -Z(NGJ)                                                  
      Z(LOCWRK) = -Z(LOCWRK)                                            
      GO TO 700                                                         
C                                                                       
C                                                                       
C     ARE WE TO PRINT THE WAVEFUNCTION                                  
C                                                                       
 600  IF(WRITES.LE.0)GO TO 700                                          
C                                                                       
      IF ( .NOT. SOSW ) WRITE(6,613) L                                    
 613  FORMAT ( ' OPTICAL MODEL WAVEFUNCTION FOR L =', I4 / )            
      IF ( SOSW ) WRITE(6, 617) L, JP                                   
 617  FORMAT( ' OPTICAL MODEL WAVE FUNCTION FOR L =', I4,  '  J =', I4, 
     *'/2' / )                                                          
      IF ( THISTC ) GO TO 670                                           
      WRITE(6,331)                                                      
 331  FORMAT( 5X, 'R', 7X, 'REAL F', 7X, 'IMAG F' )                     
      DO 659 II=1,NSTEPS,NWRITE                                         
      IF ( II .LT. ISTRT ) GO TO 659                                    
      RR=(II-1)*STEPSZ                                                  
      WRITE(6, 653) RR ,ALLOC(LWAVR+II-1),ALLOC(LWAVI+II-1)             
 653  FORMAT( F8.3, 2X, 2G13.5, 5X, 2G13.5 )                            
 659  CONTINUE                                                          
      GO TO 700                                                         
C                                                                       
C     IF TENSOR COUPLING EXISTS, PRINT BOTH PARTS OF COUPLED WF.        
C                                                                       
 670  LAS = JP - L                                                      
      WRITE(6,673) L, LAS                                                 
 673  FORMAT ( 2( 19X, 'LAS =', I3, 3X ) /  5X, 'R', 2( 7X, 'REAL F', 7X
     *, 'IMAG F', 4X ) )                                                
      DO 679 II = 1, NSTEPS, NWRITE                                     
      IF ( II .LT. ISTRT ) GO TO 679                                    
      RR = (II-1)*STEPSZ                                                
      WRITE(6,653) RR,ALLOC(LWAVR+II-1),ALLOC(LWAVI+II-1),ALLOC(LWAVR+
     *II-1+NWAVEF), ALLOC(LWAVI+II-1+NWAVEF)                            
 679  CONTINUE                                                          
C                                                                       
C     IF DESIRED, COMPUTE THE ELASTIC DIFFERENTIAL CROSS SECTIONS       
C                                                                       
 700  IF(IELAST.EQ.0)GO TO 850                                          
      FKEPSW = ISAVB .EQ. 1 .OR. SOSW                                   
      CALL ELDCS ( H/STEPSZ, ETA, ANGMIN, ANGMAX, ANGSTP,  LLMIN, LLMAX,
     * LSKIP, ISTAT, JSP, ISMATS(ICHANW), ITOCE(ICHANW),  NSPL, ISIGS(IC
     *HANW), ELAB, ELAB/E-1, .TRUE., ITORUT, RUTNAM,  FKEPSW, IFEL, 'F '
     *, SIGREA, IRUTH, RUTHNM )                                         
C                                                                       
C     NOW COMPUTE THE ANALYZING POWERS (IF NONZERO).                    
C                                                                       
      IF ( .NOT. SOSW ) GO TO 850                                       
      PWBGSW = MOD( IPRINT, 10 ) .GE. 3                                 
      CALL ANAPOW ( ANGMIN, ANGMAX, ANGSTP, JSP, JSP, JST, JST,  NSPL, 1
     *, .TRUE., PWBGSW, 'ANPOW   ', ELAB, 'ELASTIC ',  IFEL, ITOCE(ICHAN
     *W), IAPOW )                                                       
C                                                                       
C     A L L   D O N E                                                   
C                                                                       
C                                                                       
 850  CONTINUE                                                          
      IRET = 1                                                          
      GO TO 9900                                                        
C                                                                       
C                                                                       
C     ERROR RETURNS                                                     
C                                                                       
C                                                                       
C     ERRORS IN RCWFN                                                   
 9920 WRITE(6,9927) IFLAG, ETA, RHOO, L                                   
 9927 FORMAT ('-***** ERROR RETURN FROM RCWFN:', 5G18.8)                
      Z(LOCWRK) = -Z(LOCWRK)                                            
      IRET = 0                                                          
C                                                                       
C     RESTORE COMMON                                                    
C                                                                       
 9900 L = LSAVE                                                         
      JP = JPSAVE                                                       
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE WAVELJ ( L, JP, NWP, NUMPTS, RGRID, WAVER, WAVEI,  WAVR
     *, WAVI, VREAL, VIMAG, VCENT )                                     
C                                                                       
C     COMPUTES SCATTERING WAVE FOR A GIVEN CHANNEL, L, JP.              
C                                                                       
C                                                                       
C     THE INPUT IS                                                      
C                                                                       
C     L - L VALUE.                                                      
C     JP - J OF PROJECTILE - USED ONLY FOR SPIN ORBIT FORCE.            
C     NWP - CHANNEL NUMBER (1 OR 2).                                    
C     NUMPTS - NUMBER OF DESIRED OUTPUT (BY INTERPOLATION) POINTS.      
C              IF = <0, THEN THIS IS A REQUEST BY COUPLN TO JUST        
C              INITIALIZE THE WAVR, WAVI ARRAYS WITH THE POTENTIALS     
C              AND FIRST TWO XSI'S.  NOTE THAT THE FIRST TWO 12*U'S     
C              MUST ALREADY BE IN WAVR AND WAVI.  ALSO FOR THIS         
C              CASE, -NUMPTS MUST BE THE NFIRST TO USE.                 
C     RGRID - VALUES OF R ATWHICH OUTPUT IS TO BE FOUND.                
C     WAVER, WAVEI - THE COMPUTED WAVE FUNCTION AT RGRID IS STORED HERE.
C     NUMPTS-WAVEI ARE IGNORED FOR STAND-ALONE CALCULATIONS             
C     WAVR, WAVI - TWO WORK ARRAYS OF DIMENSION NSTEP+4.  THEY WILL     
C         GET THE WAVEFUNCTION AT EQUALLY SPACED POINTS.  FOR OPTICAL   
C         FITS THEY WILL NOT BE RENORMALIZED (THE RENORM CONSTANT WILL  
C         BE ALPHAR+I*ALPHAI).                                          
C     VREAL, VIMAG - THE REAL AND IMAGINARY PARTS (NOT INCLUDING S.O.   
C         NOR CENTRIFIGAL TERMS) OF THE POTENTIAL IN THE NUMEROV        
C         FORM (SEE MAKPOT OR BELOW).  IF THERE IS AN IMAG S.O.,        
C         THEN VIMAG SHOULD INSTEAD BE  WAVI(4)  AND DOES NOT NEED      
C         TO BE INITIALIZED.                                            
C     VCENT - 1/RHO**2 IN THE NUMEROV FORM - USED TO COMPUTE THE        
C         CENTRIFIGAL TERM IN THE POTENTIAL.                            
C                                                                       
C                                                                       
C     2/4/75 - SEPARATED FROM WAVEF - S. PIEPER                         
C     2/19/75 - USE AITLAG                                              
C     2/25/75 - IMPROVE CHOICE OF STARTING POINT                        
C     3/5/75 - DEFINE BKM1 = 0 AT START; AVOID UNDERFLOW                
C     3/20/75 - OUTPUT IS IN SINGLE PRECISION                           
C     4/4/75 - FIX NSTEP/NSTEPS BUG; IMPROVE LOOP SLIGHTLY              
C     5/21/75 - DO ANY POSITIVE L THAT COMES IN.                        
C     5/22/75 - POTENTIALS AND AITKEN DONE HERE; STAND ALONE; SPIN ORBIT
C     5/26/75 - FURTHER CLEANUP OF THE LOOP, AVOID UNDERFLOWS.          
C     10/1/75 - ADD TIMING  - D.G.                                      
C     10/7/75 POTENTIALS MOVED TO MAKPOT; OTHER LOOP IMPROVEMENTS - S.P.
C     10/27/75 - SAVE SOME THINGS FOR D(S)/D(POT) CALCULATIONS.         
C     11/5/75 - INCLUDE ABSORBTION IN CHOICE OF NFIRST                  
C     2/15/76 - (RHO/RHOTURN)**POW CHOICE OF NFIRST - S.P.              
C     2/23/76 - FIXUP IMAGINARY PART OF NFIRST CHOICE                   
C     1/27/77 - REVISE LOOPS                                            
C     2/1/77 - GREATLY SIMPLIFIED INITIAL VALUE PROCEEDURE - S.P.       
C     5/8/77 - FIX BUG IN STORING S(L,J) FOR S.O. FORCES                
C     11/20/77 - NEW ASYMPTOPIA; ONLY L.S LEFT OUT OF VSO               
C     2/10/78 - LINKULES FOR WAVEFUNCTIONS - S.P.                       
C     4/24/78 - REVERSE LOMOST FOR LIMOST - S.P.                        
C     4/29/78 - USE BIGNUM, SMLNUM FROM /CNSTNT/ - S.P.                 
C     5/5/78 - CENTRIFUGAL BARRIER COMES FROM AN ARRAY - S.P.           
C     5/21/78 - MODIFIED NUMEROV; EXTRA ARGS FOR BETTER COMPILATION - S.
C     6/1/78 - MOVE IMAG POT FOR LINKULE CALLS                          
C     6/13/78 - L-DEPENDANT POTENTIALS - S.P.                           
C     7/11/78 - FIX ERROR IN ABOVE                                      
C     11/11/78 - GO BACK TO 1.E-25 AS INNER CUTOFF FOR WAVEFUNC - S.P.  
C     11/16/78 - STEP1R CONTROLS STARTING VALUE FOR BOTH REAL AND IMAG; 
C                STEP1I NOW CONTROLS LOC OF NFIRST - S.P.               
C     12/21/78 - ADD TENSOR POTENTIALS - RPG                            
C     1/10/79 - USE 5-POINT LAGRANGE INTERP., NOT AITKEN LOOP - RPG     
C     2/19/79 - CHANGE LOCAL R TO RT TO PRESERVE PARAMETER - RPG        
C     3/1/79 - ADD DUMPS, MOVE LASTZR TO /WAVCOM/ - RPG                 
C     3/19/79 - REMOVE DUMPS - RPG                                      
C     3/22/79 - RESTORE /LNKBLK/ FROM LNKAD2 FOR DWBA - S.P.            
C     4/21/79 - AVOID OVERFLOW FOR FIRST L GIGANTIC (500) - S.P.        
C     8/3/79 - STANDARD PREFIXES, CALL JPTOLX, SMALLER N1ADD FOR BIG L, 
C        FIX MINOR BUGS - RPG                                           
C     11/10/79 - USE DOUBLE PRECISION EXP AT 410 - S.P.                 
C     11/13/79 - PUT 1/24 IN DATA STATEMENT - S.P.                      
C     6/2/80 MODIFY POTENTIAL DEF. FOR MULTI-CHANNEL CALCULATIONS MRB   
C           PUT IN NEW DEFINITION OF COULOMB FUNCTIONS(MULTI-CHANNEL)   
C     4/17/80 - ADD TO DEBUG OUTPUT - S.P.                              
C     4/23/80 - USE PWBGSW INSTEAD OF PBUGSW - S.P.                     
C     4/25/80 - FIX N1ADD CHANGING BUG - S.P.                           
C     11/19/81 - PROCESS NUMPTS = -1 FOR COUPLN - S.P.                  
C     5/10/82 - STORE J FOR J-DEPENDANT LINKULES - S.P.                 
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL RGRID, WAVER, WAVEI, WAVR, WAVI, VREAL, VIMAG, VCENT
C                                                                       
	   REAL*4 RGRID(1),WAVER(1),WAVEI(1)
      DIMENSION WAVR(1), WAVI(1), VREAL(1), VIMAG(1), VCENT(1)          
C                                                                       
      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 )                                                   
      COMMON /JBLOCK/ J                                                 
      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                                                                 
      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
     *) )                                                               
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
      COMMON /LOCFIT/ LNKAD2(6,2,12)                                    
C                                                                       
      CHARACTER*8 CHANAM(3)                                             
      DATA CHANAM/'INCOMING', 'OUTGOING' , ' '/                         
C                                                                       
C                                                                       
      LOGICAL BADSW                                                     
C                                                                       
C     FOLLOWING IS 1/12  AND  1/24                                      
C                                                                       
      DATA TWELTH / .0833333333333333333333 0D0 /                       
      DATA OVER24 / .041666666666666666667 0D0 /                        
C                                                                       
C     LASTZR IS THE LAST STEP+1 TO HAVE BEEN ZEROED.                    
C     WE ASSUME THE PREVIOUS WORDS OF WAVR, WAVI TO STILL BE 0 UNLESS   
C     LASTL INDICATES THAT WE HAVE STEPPED BACKWARDS.                   
C                                                                       
C     SETUP THE PARAMETERS FOR THIS CHANNEL                             
C                                                                       
      IF ( NUMPTS .LT. 0 ) GO TO 5                                      
      IF ( L .LT. 0 ) RETURN                                            
      I = IABS( 2*L - JSPS(NWP) )                                       
      IF ( SOSWS(NWP) .AND. JP .LT. I ) RETURN                          
C                                                                       
  5   DL = L                                                            
      DLSQ = DL*(DL+1)                                                  
      H = HS(NWP)                                                       
      H2 = H**2                                                         
      STEPSZ = RSTEPS(NWP)                                              
      NSTEP = NSTPSS(NWP)                                               
C     DEFINITION OF COULOMB FUNCTIONS FOR MULTI-CHANNEL                 
      IF ( PROBLM .NE. 24 ) GO TO 40                                    
      F1=WAVER(1)                                                       
      G1=WAVER(2)                                                       
      F=WAVER(3)                                                        
      G=WAVER(4)                                                        
      GO TO 45                                                          
C                                                                       
C     FOR NON-C.C. CALCULATIONS, STORE J-TOTAL FOR L-DEPENDANT LINKULES 
C                                                                       
 40   J = 2*L                                                           
C                                                                       
C     IF LINKULE POTENTIALS OR WAVEFUNCTIONS ARE IN USE,                
C     AND IF THIS IS A DWBA, THEN WE MUST SETUP THE PROPER /LNKBLK/     
C                                                                       
 45   IF ( PROBLM .LT. 20 .OR. PROBLM .EQ. 21 ) GO TO 50                
      DO 49 I = 1, NUMLNK                                               
      DO 49 II = 1, 6                                                   
      LNKADR(II,I) = LNKAD2(II,NWP,I)                                   
 49   CONTINUE                                                          
C                                                                       
C     START THE INTEGRATION AT THE POINT DETERMINED FOR THE PREVIOUS    
C     SOLUTION IF WE HAVE NOT RESET TO A NEW, LOWER, L VALUE.           
C                                                                       
 50   NFIRST = -NUMPTS                                                  
      ISTRT = NFIRST - 2                                                
      IF ( NUMPTS .LT. 0 ) GO TO 220                                    
      NFIRST = LASTNF(NWP)                                              
      ISTRT = NFIRST - 2                                                
      IF ( L .GE. LASTL(NWP) ) GO TO 160                                
      NFIRST = 2                                                        
      ISTRT = 0                                                         
      LASTZR = 1                                                        
C                                                                       
C     STEP1I (=STEPI) IS THE SMALLEST VALUE OF THE WAVEFUNCTION TO      
C     ALLOW AND THUS CONTROLS THE CHOICE OF NFIRST.  IT USE TO HAVE     
C     A DEFAULT OF 1 WHICH WE MAP TO THE DEFAULT OF 1E-6.               
C                                                                       
 160  IF ( STEPI .EQ. 1 ) STEPI = 1.D-6                                 
C                                                                       
C     OUR INITIAL GUESS IS ALWAYS STEPR*STEPI.  WE WILL NEVER LET       
C     !U! > BIGNUM.  THIS MEANS THAT THE REQUIRED RENORM WILL SATISFY   
C     1/STEPI > RENORM > SMLNUM, AND THUS RENORM**2 WILL NOT            
C     OVERFLOW OR UNDERFLOW.  THIS IS IMPORTANT FOR SDERIV.             
C     NOTE THAT STEPR EXISTS ONLY FOR HISTORICAL REASONS AND IS         
C     ALWAYS 1.                                                         
C                                                                       
      THISR = STEPI*STEPR                                               
      THISI = THISR                                                     
C                                                                       
C     ASSUME   U(R) = R**(L+1)  TO GET RATIO OF FIRST TWO POINTS        
C                                                                       
      AA1 = ISTRT                                                       
C     ZERO THE FIRST FEW POINTS IF NECESSARY.                           
      IF ( NUMFIT .NE. 0 .OR. ISTRT .LT. LASTZR ) GO TO 180             
      DO 174 I = LASTZR, ISTRT                                          
      WAVR(I) = 0.                                                      
      WAVI(I) = 0.                                                      
 174  CONTINUE                                                          
 180  D = AA1/(AA1+1)                                                   
      WAVR(ISTRT+1) = THISR*D**(L+1)                                    
      WAVI(ISTRT+1) = THISI*D**(L+1)                                    
      WAVR(ISTRT+2) = THISR                                             
      WAVI(ISTRT+2) = THISI                                             
      THISR = THISR + THISI                                             
      THSRSV = THISR                                                    
C                                                                       
C     COMPUTE THE TOTAL EFFECTIVE POTENTIAL FOR THIS L AND TEMPORARILY  
C     STORE IN THE WAVEFUNCTION ARRAYS.                                 
C     MODIFY POTENTIAL FOR MULTI-CHANNELS                               
      IF ( PROBLM .EQ. 24 ) GO TO 220                                   
C                                                                       
      DO 204 I = ISTRT, NSTEP                                           
      WAVR(I+4) = VREAL(I+1) + DLSQ*VCENT(I+1)                          
      WAVI(I+4) = VIMAG(I+1)                                            
 204  CONTINUE                                                          
      GO TO 230                                                         
 220  CCH = H2*TWELTH                                                   
      DO 224 I = ISTRT, NSTEP                                           
      WAVR(I+4) = VREAL(I+1)+CCH+DLSQ*VCENT(I+1)                        
      WAVI(I+4) = VIMAG(I+1)                                            
 224  CONTINUE                                                          
C                                                                       
C        MAKE ONE EXTRA SAFE                                            
C                                                                       
 230  WAVR(NSTEP+5) = 1                                                 
      WAVI(NSTEP+5) = 0                                                 
C                                                                       
C     ADD IN THE SPIN ORBIT FORCES IF THEY EXIST                        
C                                                                       
      IF ( ISORS(NWP)+ISOIS(NWP) .EQ. 0 ) GO TO 250                     
C                                                                       
C     SDOTL IS REALLY  SIGMA.L .  NOTE THAT  JP, JSPS  ARE TWICE THE    
C     REAL VALUES.                                                      
C                                                                       
      SDOTL = .25*(JP*(JP+2) - JSPS(NWP)*(JSPS(NWP)+2)) - DLSQ          
      SDOTL = SDOTL / JSPS(NWP)                                         
      IF ( ISORS(NWP) .EQ. 0 ) GO TO 240                                
      LSOR = Z(ISORS(NWP))                                              
      DO 239 I = ISTRT, NSTEP                                           
      WAVR(I+4) = WAVR(I+4) + SDOTL*ALLOC(LSOR+I)                       
 239  CONTINUE                                                          
 240  IF ( ISOIS(NWP) .EQ. 0 ) GO TO 250                                
      LSOI = Z(ISOIS(NWP))                                              
      LIMV = Z(IIMVS(NWP))                                              
      DO 249 I = ISTRT, NSTEP                                           
      WAVI(I+4) = WAVI(I+4) + SDOTL*ALLOC(LSOI+I)                       
 249  CONTINUE                                                          
C                                                                       
C     ADD IN THE TENSOR POTENTIALS IF THEY EXIST.                       
C                                                                       
 250  DO 259 II = 1, 3                                                  
      IF ( ITENS(NWP,2*II-1)+ITENS(NWP,2*II) .EQ. 0 ) GO TO 259         
      TCO = TCOEF ( II, L, L, JP, JSPS(NWP) )                           
      IF ( TCO .EQ. 0 ) GO TO 259                                       
      IF ( ITENS(NWP,2*II-1) .EQ. 0 ) GO TO 255                         
      LTEN = Z(ITENS(NWP,2*II-1))                                       
      DO 254 I = ISTRT, NSTEP                                           
      WAVR(I+4) = WAVR(I+4) + TCO* ALLOC(LTEN+I)                        
 254  CONTINUE                                                          
 255  IF ( ITENS(NWP,2*II) .EQ. 0 ) GO TO 259                           
      LTEN = Z(ITENS(NWP,2*II))                                         
      DO 257 I = ISTRT, NSTEP                                           
      WAVI(I+4) = WAVI(I+4) + TCO* ALLOC(LTEN+I)                        
 257  CONTINUE                                                          
 259  CONTINUE                                                          
C                                                                       
C     NOW PROCESS L-DEPENDENT POTENTIALS WHICH COME ONLY FROM LINKULES. 
C                                                                       
C     THE LINKULE MUST ADD THE L-DEPENDENT PART OF THE POTENTIAL        
C     IN THE FORM    -H**2/(12*E) * V(L)   TO THE POTENTIAL ARRAYS      
C     ALREADY BUILTUP IN WAVR, WAVI.  THESE ARRAYS CONTAIN THE          
C     L-INDEPENDENT PART OF THE POTENTIAL THAT WAS RETURNED FOR         
C     THE IREQUE=3 CALL MADE FROM MAKPOT.                               
C     THE FACTOR   -H**2/(12*E)  WILL BE PASSED AS THE 1ST ELEMENT      
C     OF THE SECOND ARRAY TO THE LINKULE (A1 BELOW).                    
C                                                                       
 260  A1 = -(STEPSZ/HBARC)**2 * REDMS(NWP) / 6.D0                       
      N = NSTEP-ISTRT+1                                                 
      RSTART = ISTRT*STEPSZ                                             
C                                                                       
      IF ( LNKADR(3,1) .EQ. 0 .OR. LNKADR(4,1) .NE. 1 ) GO TO 270       
      CALL LINKUL ( LNKADR(3,1), LNKNAM(1,1), LNKADR(5,1),  1, 4, IRET, 
     * L, JP, RSTART, STEPSZ, N, WAVR(ISTRT+4), A1, NWP )               
      IF ( IRET .LT. 0 ) STOP 7777                                      
C                                                                       
 270  IF ( LNKADR(3,2) .EQ. 0 .OR. LNKADR(4,2) .NE. 1 ) GO TO 300       
      CALL LINKUL ( LNKADR(3,2), LNKNAM(1,2), LNKADR(5,2),  2, 4, IRET, 
     * L, JP, RSTART, STEPSZ, N, WAVI(ISTRT+4), A1, NWP )               
      IF ( IRET .LT. 0 ) STOP 7777                                      
C                                                                       
C     COMPUTE FIRST TWO XSI'S                                           
C                                                                       
 300  II = ISTRT+1                                                      
      DO 309 I = ISTRT, II                                              
      WAVR(I+3) =  TWELTH*( WAVR(I+1)*WAVR(I+4) - WAVI(I+1)*WAVI(I+4) ) 
      WAVI(I+3) =  TWELTH*( WAVR(I+1)*WAVI(I+4) + WAVI(I+1)*WAVR(I+4))  
 309  CONTINUE                                                          
C                                                                       
      IF ( NUMPTS .LT. 0 ) RETURN                                       
C                                                                       
C     READY TO DO THE INTEGRATION.                                      
C     IS IT DONE HERE OR IN A LINKULE?                                  
C                                                                       
      IF ( LNKADR(3,6) .EQ. 0) GO TO 350                                
C                                                                       
      CALL LINKUL ( LNKADR(3,6), LNKNAM(1,6), LNKADR(5,6),  NFIRST, 3, I
     *RET, L, JP, H*ISTRT, H, NSTEP+1,  WAVR, WAVI, NWP )               
      IF ( IRET .GE. 0 ) GO TO 500                                      
      STOP 7777                                                         
C                                                                       
C     WILL DO INTEGRATION HERE                                          
C                                                                       
 350  CONTINUE                                                          
C                                                                       
C      NUMEROV METHOD (A LA RAYNAL) IS USED IN THE FOLLOWING LOOP       
C                                                                       
C     WE DEFINE                                                         
C       W(I) = 1 - (H**2/12)*(V(I)/E - 1)                               
C       XSI(I) = W(I)*U(I)/12                                           
C     WHERE                                                             
C       V(I) = V(I*STEPSZ) = V(I*H/K)                                   
C     CONTAINS THE COMPLETE NUCLEAR, COULOMB AND CENTRIFIGAL POTENTIALS.
C     MOST OF W(I) IS COMPUTED AND STORED IN MAKPOT, HOWEVER            
C     THE L-DEPENDENT PIECES ARE ADDED IN JUST ABOVE.                   
C                                                                       
C     THE DESIRED WAVEFUNCTION IS                                       
C       U(I) = U(I*STEPSZ)                                              
C     EXCEPT THAT AT THIS STAGE THE NORMALIZATION IS ARBITRARY:         
C       U(R) ---> CONS*R**(L+1) .                                       
C                                                                       
C     AT STEP I IN THE LOOP, THE WAVR AND WAVI ARRAYS CONTAIN:          
C                                                                       
C     WAV_(...)   CONTENTS                                              
C          I-1    U(I-2)     NOT USED                                   
C          I      U(I-1)                                                
C          I+1    XSI(I-2),   CHANGED TO U(I) DURING STEP               
C          I+2    XSI(I-1)                                              
C          I+3    W(I-1), NOT USED, CHANGED TO XSI(I) DURING STEP       
C          I+4    W(I)                                                  
C                                                                       
C     THE SMALLEST POSSIBLE NFIRST IS 2 WHICH RESULTS IN ISTRT=0.       
C     THE U AND XSI FOR NFIRST-2, NFIRST-1 HAVE ALREADY BEEN STORED.    
C                                                                       
C                                                                       
C     ON THE FIRST PARTIAL WAVE, WE MUST FROM TIME TO TIME CHECK        
C     FOR IMMENENT OVERFLOW AND RENORMALIZE DOWN.  AFTER THE FIRST      
C     PARTIAL WAVE WE KNOW WHERE TO START AND NEED NOT CHECK.           
C                                                                       
      N1 = NFIRST                                                       
      N2 = NSTEP                                                        
      IF ( L .GE. LASTL(NWP) ) GO TO 420                                
      N1ADD = 20                                                        
      IF ( L .GT. 16 ) N1ADD = EXP ( 50.D0/DL )                         
C                                                                       
 410  N2 = N1 + N1ADD                                                   
      N2 = MIN0(N2, NSTEP)                                              
C                                                                       
 420  D = ( 12. / ( WAVR(N1+4)**2 + WAVI(N1+4)**2 ) )                   
C                                                                       
      DO 449 I = N1, N2                                                 
C                                                                       
      WAVR(I+3) = ((-10.)*WAVR(I+2)) + (WAVR(I)-WAVR(I+1))              
      WAVI(I+3) = ((-10.)*WAVI(I+2)) + (WAVI(I)-WAVI(I+1))              
C                                                                       
      WAVR(I+1) = ( WAVR(I+4)*WAVR(I+3) + WAVI(I+4)*WAVI(I+3) ) * D     
      WAVI(I+1) = ( WAVR(I+4)*WAVI(I+3) - WAVI(I+4)*WAVR(I+3) ) * D     
C                                                                       
      D = ( 12. / ( WAVR(I+5)**2 + WAVI(I+5)**2 ) )                     
C                                                                       
 449  CONTINUE                                                          
      IF ( N2 .EQ. NSTEP ) GO TO 500                                    
C                                                                       
C     CHECK FOR NEARNESS OF OVERFLOW                                    
C                                                                       
      THISR = DABS(WAVR(N2+1)) + DABS(WAVI(N2+1))                       
      IF ( PWBGSW ) WRITE(6,463) NWP, L, N1, N2, THISR                    
 463  FORMAT ( ' CHECKING SIZE: NWP, L, N1, N2, MAG =',  4I5, G13.3 )   
C                                                                       
      IF ( THISR .GT. BIGNUM ) GO TO 470                                
      IF ( THISR .LT. 10000*THSRSV ) N1ADD = N1ADD+5                    
      GO TO 490                                                         
C                                                                       
C     MUST SCALE DOWN.  WE WILL MULTIPLY EVERYTHING BY 1/THISR.         
C     FIRST WE FIND WHERE THIS WILL RESULT IN !U! = STEPI.              
C                                                                       
 470  THISI = STEPI*THISR                                               
      N1 = ISTRT                                                        
      DO 479 ISTRT = N1, N2                                             
      IF ( DABS(WAVR(ISTRT+1)) .GE. THISI ) GO TO 480                   
      WAVR(ISTRT+1) = 0                                                 
      WAVI(ISTRT+1) = 0.                                                
 479  CONTINUE                                                          
C                                                                       
C                                                                       
C     SHOULD WE REDUCE N1ADD                                            
C                                                                       
 480  IF ( THISR*1.D-10 .GT. BIGNUM ) N1ADD = MAX0(N1ADD/2, 1)          
      IF ( PWBGSW ) WRITE(6,483) ISTRT, N1ADD                             
 483  FORMAT ( 5X, 'RESCALING: NEW ISTRT =', 2I6 )                      
C                                                                       
      THISI = 1/THISR                                                   
      N1 = N2+2                                                         
      DO 489 I = ISTRT, N1                                              
      WAVR(I+1) = THISI*WAVR(I+1)                                       
      WAVI(I+1) = THISI*WAVI(I+1)                                       
 489  CONTINUE                                                          
      THISR = 0                                                         
C                                                                       
 490  N1 = N2+1                                                         
      THSRSV = THISR                                                    
      GO TO 410                                                         
C                                                                       
C     END OF THE INTEGRATION                                            
C                                                                       
 500  CONTINUE
C                                                                       
C     EXTRACT S-MATRIX AND NORMALIZATION FROM U AND U AT NBAKCM         
C     STEPS BACK FROM END.                                              
C                                                                       
C F IS THE REGULAR COULOMB WAVE                                         
C  G IS THE IRREGULAR COULOMB WAVE                                      
C  NOTE THAT F1,G1 ARE REGULAR AND IRREGULAR COULOMB FUNTIONS AT NBACK  
C                                                                       
      I = L + (IOFFIT-1)*(LOMOST+1)                                     
      IF(PROBLM.EQ.24)GO TO 520                                         
      F = ALLOC(Z(NFS(NWP))+I)                                          
      G = ALLOC(Z(NGS(NWP))+I)                                          
      F1 = ALLOC(Z(NF1S(NWP))+I)                                        
      G1 = ALLOC(Z(NG1S(NWP))+I)                                        
C                                                                       
 520  CONTINUE                                                          
C  NOW FINDING REAL S AND IMAG S                                        
C                                                                       
      A1 = WAVR(NSTEP+1)*F1 + WAVI(NSTEP+1)*G1  - WAVR(NSTEP+1-NBAKCM)*F
     *  - WAVI(NSTEP+1-NBAKCM)*G                                        
      A2 = -WAVR(NSTEP+1)*G1 + WAVI(NSTEP+1)*F1  + WAVR(NSTEP+1-NBAKCM)*
     *G  - WAVI(NSTEP+1-NBAKCM)*F                                       
      CR = -WAVR(NSTEP+1)*F1 + WAVI(NSTEP+1)*G1  + WAVR(NSTEP+1-NBAKCM)*
     *F  - WAVI(NSTEP+1-NBAKCM)*G                                       
      CI = -WAVR(NSTEP+1)*G1 - WAVI(NSTEP+1)*F1  + WAVR(NSTEP+1-NBAKCM)*
     *G  + WAVI(NSTEP+1-NBAKCM)*F                                       
C                                                                       
C     TRANSLATE THE ELASTIC S-MATRICES TO THE LX SYSTEM AND SAVE THEM.  
C                                                                       
      SJR = ( CR*A1 + CI*A2 ) / ( A1*A1 + A2*A2 )                       
      SJI = ( CI*A1 - CR*A2 ) / ( A1*A1 + A2*A2 )                       
      IF ( (NWP .NE. 2) .OR. (PROBLM .NE. 24))  CALL JPTOLX ( L, L, JP, 
     *NWP, SJR, SJI,  ALLOC(Z(IINDXE(NWP))), ALLOC(Z(ISMATS(NWP))) )    
C                                                                       
C  NORMALIZATION HERE                                                   
C                                                                       
      A1 = .5*( F*( 1.+SJR ) + SJI*G )                                  
      A2 = .5*( G*( 1.-SJR ) + SJI*F )                                  
      CR = ( WAVR(NSTEP+1)*A1 + WAVI(NSTEP+1)*A2 ) /  ( WAVR(NSTEP+1)**2
     * + WAVI(NSTEP+1)**2 )                                             
      ALPHAR = CR                                                       
      CI = ( WAVR(NSTEP+1)*A2 - WAVI(NSTEP+1)*A1 ) /  ( WAVR(NSTEP+1)**2
     * + WAVI(NSTEP+1)**2 )                                             
      ALPHAI = CI                                                       
C                                                                       
C     FIND NEXT STARTING POINT                                          
C     FIND POINT WHERE ALL RENORMALIZED WAVEFUNCTION WILL BE < STEPI    
C                                                                       
      AA1 = DABS(CR) + DABS(CI)                                         
      BB1 = STEPI/AA1                                                   
      DO 629 I = ISTRT, NSTEP                                           
      IF ( DABS(WAVR(I+1)) + DABS(WAVI(I+1)) .GE. BB1 ) GO TO 630       
      WAVR(I+1) = 0.                                                    
      WAVI(I+1) = 0.                                                    
 629  CONTINUE                                                          
C                                                                       
 630  ISTRT = I                                                         
      LASTZR = I+1                                                      
C                                                                       
C     SET IT BACK SOME FOR LINKULES                                     
C                                                                       
      IF ( LNKADR(3,6) .NE. 0 ) I = I - 10                              
      I = MAX0( I+1, 2 )                                                
      LASTNF(NWP) = I                                                   
      LASTL(NWP) = L                                                    
      BADSW = ( AA1 .GT. BIGNUM*1.D-10 .AND. NFIRST .GT. 2 ) .OR. AA1 .L
     *T. SMLNUM*1.D-5                                                   
      IF ( BADSW ) WRITE(6,663)
 663  FORMAT ( '0**** WARNING, LARGE WAVEFUNCTION RENORMALIZATION:' )   
      IF ( PWBGSW .OR. BADSW ) WRITE(6,668) NWP,L,NFIRST,I,AA1,NSTEP
     *, NSTP2S(NWP), NUMPTS                                             
 668  FORMAT ( ' NWP, L =', I2, I4, '  NFIRST =', I4,  '  NEW NFIRST =',
     * I4, '  RENORM =', D11.3 ,  3X, 'NUM PTS:', 3I6 )                 
      NFIRST = ISTRT                                                    
C                                                                       
      IF ( NUMFIT .NE. 0 ) GO TO 880                                    
C                                                                       
      IF ( .NOT. PWAVSW ) GO TO 750                                     
      NNWP = NWP                                                        
      IF ( STANSW ) NNWP = 3                                            
      IF ( SOSWS(NWP) ) GO TO 730                                       
      WRITE(6,723) CHANAM(NNWP), L, SJR, SJI                              
 723  FORMAT ( 1X, A8, ' ELASTIC S-MATRIX FOR L =', I4,  ':', G15.5, ' +
     *', G13.5, ' I' )                                                  
      GO TO 750                                                         
 730  IF ( TCSWS(NWP) ) GO TO 740                                       
      WRITE(6,733) CHANAM(NNWP), L, JP, SJR, SJI                          
 733  FORMAT ( 1X, A8, ' ELASTIC S-MATRIX FOR L =', I4, ',   JP =',  I4,
     * '/2:', G15.5, ' +', G13.5, ' I' )                                
      GO TO 750                                                         
 740  WRITE(6,743) CHANAM(NNWP), L, L, JP, SJR, SJI                       
 743  FORMAT ( 1X, A8, ' ELASTIC S-MATRIX FOR L =', I4, ',  LAS =',  I4,
     * ',   JP =', I4, '/2:', G15.5, ' +', G13.5, ' I' )                
C                                                                       
C  STORE NORMALIZED WAVE FUNCTIONS                                      
C                                                                       
C     CR AND CI WILL NORMALIZE THE WAVEFUNCTION TO                      
C                                                                       
C       U(L) ---> ( (1+S)*F(L) + I (1-S)*G(L) ) / 2                     
C                                                                       
C     FOR STAND-ALONE CALCULATIONS WE MAY INSTEAD USE A NORMALIZATION   
C     THAT RESULTS IN REAL U(L) FOR REAL POTENTIALS.  THIS NORM         
C     IS COMPUTED AND APPLIED IN WAVEF.                                 
C                                                                       
 750  N2 = NSTEP+2                                                      
      DO 779 I = ISTRT, N2                                              
      A1 = CR*WAVR(I+1) - CI*WAVI(I+1)                                  
      WAVI(I+1) = CR*WAVI(I+1) + CI*WAVR(I+1)                           
      WAVR(I+1) = A1                                                    
 779  CONTINUE                                                          
C                                                                       
C     IF NECESSARY, CONTINUE THE INTEGRATION USING JUST COULOMB         
C                                                                       
      NSTEP2 = NSTP2S(NWP)                                              
      IF ( NSTEP2 .LE. NSTEP ) GO TO 800                                
C                                                                       
      NSTEP = NSTEP+1                                                   
      RT = NSTEP*STEPSZ                                                 
C                                                                       
      DO 789 I = NSTEP, NSTEP2                                          
      RINV = 1./RT                                                      
      WAVR(I+3) = (-10.)*WAVR(I+2) + ( WAVR(I) - WAVR(I+1) )            
      WAVI(I+3) = (-10.)*WAVI(I+2) + ( WAVI(I) - WAVI(I+1) )            
      D = 12./( XFACS(1,NWP) + RINV*( XFACS(2,NWP) +  (DLSQ*XFACS(3,NWP)
     *)*RINV ) )                                                        
      WAVR(I+1) = D*WAVR(I+3)                                           
      WAVI(I+1) = D*WAVI(I+3)                                           
      RT = RT + STEPSZ                                                  
 789  CONTINUE                                                          
C                                                                       
 800  IF ( STANSW .OR. NUMPTS .EQ. 0 ) GO TO 880                        
C                                                                       
C     NOW INTERPOLATE TO THE DESIRED GRID                               
C                                                                       
      STPINV = 1/RSTEPS(NWP)                                            
      IMX = NSTEP2 - 2                                                  
      IF ( PWBGSW ) WRITE(6,803) NUMPTS, IMX, STPINV                      
 803  FORMAT ( ' INTERPOLATING:', 2I6, G15.5 )                          
      DO 859 IR = 1, NUMPTS                                             
      RT = RGRID(IR)                                                    
C                                                                       
C     FIND THE LOCATION OF R IN THE TABLE                               
C                                                                       
      RBYH = RT*STPINV                                                  
      I = RBYH + 0.5                                                    
      I = MAX0 ( 2, MIN0 ( I, IMX ) )                                   
      P = RBYH - I                                                      
C     USE 5-POINT LAGRANGIAN INTERPOLATION (ABRAMOWITZ & STEGUN 25.2.15)
      PS = P*P                                                          
      X1 = P*(PS-1.)*OVER24                                             
      X2 = X1 + X1                                                      
      X3 = X1*P                                                         
      X4 = X2 + X2 - 0.5*P                                              
      X5 = X4*P                                                         
      C1 = X3 - X2                                                      
      C5 = X3 + X2                                                      
      C3 = X5 - X3                                                      
      C2 = X5 - X4                                                      
      C4 = X5 + X4                                                      
      C3 = C3 + C3 + 1.                                                 
      WAVER(IR) = C1*WAVR(I-1) - C2*WAVR(I) + C3*WAVR(I+1)  - C4*WAVR(I+
     *2) + C5*WAVR(I+3)                                                 
      WAVEI(IR) = C1*WAVI(I-1) - C2*WAVI(I) + C3*WAVI(I+1)  - C4*WAVI(I+
     *2) + C5*WAVI(I+3)                                                 
C                                                                       
 859  CONTINUE                                                          
C                                                                       
 880  CONTINUE
      RETURN                                                            
      END                                                               

      SUBROUTINE WAVETC ( L, LAS, JP, NWP, NWAVF, NUMPTS, RGRID,  WAVER,
     * WAVEI, WAVR, WAVI, VREAL, VIMAG, VCENT )                         
C                                                                       
C     COMPUTES TENSOR-COUPLED SCATTERING WAVE FOR A GIVEN L, LAS, JP.   
C                                                                       
C                                                                       
C     THE INPUT IS                                                      
C                                                                       
C     L - L VALUE.                                                      
C     LAS - ASYMPTOTIC L VALUE.                                         
C     JP - 2*J OF PROJECTILE.                                           
C     NWP - CHANNEL NUMBER (1 OR 2).                                    
C     NUMPTS - NUMBER OF DESIRED OUTPUT POINTS.                         
C     RGRID - VALUES OF R ATWHICH OUTPUT IS TO BE FOUND.                
C     WAVER, WAVEI - THE COMPUTED WAVE FUNCTION AT RGRID IS STORED HERE.
C     NUMPTS-WAVEI ARE IGNORED FOR STAND-ALONE CALCULATIONS             
C     WAVR, WAVI - TWO WORK ARRAYS OF DIMENSION 4*NWAVEF.  THEY WILL    
C         GET THE WAVEFUNCTION AT EQUALLY SPACED POINTS.                
C     NOTE:  NWAVEF (IN /WAVCOM/) IS AT LEAST NSTEP+4.                  
C     VREAL, VIMAG - THE REAL AND IMAGINARY PARTS (NOT INCLUDING S.O.   
C         NOR CENTRIFIGAL TERMS) OF THE POTENTIAL IN THE NUMEROV        
C         FORM (SEE MAKPOT OR BELOW).                                   
C     VCENT - 1/RHO**2 IN THE NUMEROV FORM - USED TO COMPUTE THE        
C         CENTRIFIGAL TERM IN THE POTENTIAL.                            
C                                                                       
C                                                                       
C           NOTE:  THIS SUBROUTINE IS USED FOR SPIN-1 PROJECTILES WHEN  
C     TR OR TP TENSOR POTENTIALS ARE PRESENT.                           
C                                                                       
C           IF THE WAVE FUNCTIONS ARE TO BE USED (STANSW = .FALSE.),    
C     WAVETC SHOULD BE CALLED FIRST FOR ALL WAVES WITH ONE PARITY,      
C     THEN FOR ALL WAVES WITH THE OTHER PARITY.  OTHERWISE,             
C     THE WRONG WAVE FUNCTIONS WILL BE RETURNED WHENEVER L OR LAS       
C     IS GREATER THAN J.                                                
C                                                                       
C           WHEN NUMPTS>0, THE COUPLED WAVE FUNCTIONS ARE STORED IN     
C     THE ALLOCATOR, INDEXED BY IWAVRS/IWAVIS(JP) ON THE FIRST CALL     
C     TO WAVETC FOR A GIVEN JP (L = LAS = JP/2-1).  ON SUBSEQUENT       
C     CALLS FOR THE SAME JP, THE REQUESTED WAVE FUNCTION IS MERELY      
C     TRANSFERRED TO WAVER/WAVEI.                                       
C                                                                       
C     1/30/79 - CREATE WAVETC, BASED ON WAVELJ - RPG                    
C     2/7/79 - SPLIT OFF TMATCH TO ALLOW EXPRESS COMPILATION - RPG      
C     2/19/79 - USE SMLISH,BIGISH; CHANGE LOCAL R TO RT - RPG           
C     2/27/79 - CHANGE LOWER L TO LOCAL LL - RPG                        
C     3/1/79 - INSERT DUMP, REMOVE SMLISH, BIGISH - RPG                 
C     3/20/79 - REMOVE DUMPS - RPG                                      
C     8/3/79 - RESTORE /LNKBLK/ FROM LNKAD2 FOR DWBA, CHANGE SIZE       
C        CHECKING - RPG                                                 
C     11/10/79 - USE DOUBLE-PRECISION EXP AT 410 - S.P.                 
C     11/15/79 - USE 1/24; REARRANGE INTERP STUFF - S.P.                
C     4/23/80 - USE PWGSW INSTEAD OF PBUGSW - S.P.                      
C     6/3/80 - GET AND PASS NWAVF DIMENSION FOR CDC - S.P.              
C     6/25/80 - DEFINE /SWITCH/ FOR PROBLM (MISSING) - S.P.             
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL RGRID, WAVER, WAVEI, WAVR, WAVI, VREAL, VIMAG, VCENT
C                                                                       
      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 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                                                                 
      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
     *) )                                                               
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
      COMMON /LOCFIT/ LNKAD2(6,2,12)                                    
C                                                                       
      REAL*4 RGRID(NUMPTS), WAVER(1), WAVEI(1)                          
      DIMENSION WAVR(NWAVF,2,2), WAVI(NWAVF,2,2),  VREAL(1), VIMAG(1), V
     *CENT(1)                                                           
C                                                                       
      DIMENSION DLSQ(2), SDOTL(2), TCO(3), CR(2,2), CI(2,2),  U1R(2,2), 
     *U1I(2,2), WIR(2), WII(2)                                          
C                                                                       
C                                                                       
      LOGICAL BADSW                                                     
C                                                                       
C     FOLLOWING IS 1/12                                                 
C                                                                       
      DATA TWELTH / .0833333333333333333333 0D0 /                       
      DATA OVER24 / .041666666666666666667 0D0 /                        
C                                                                       
C     LASTZR IS THE LAST STEP+1 TO HAVE BEEN ZEROED.                    
C     WE ASSUME THE PREVIOUS WORDS OF WAVR, WAVI TO STILL BE 0 UNLESS   
C     LASTL INDICATES THAT WE HAVE STEPPED BACKWARDS.                   
C                                                                       
C     SETUP THE PARAMETERS FOR THIS CHANNEL                             
C                                                                       
      LL = JP/2 - 1                                                     
      IF ( L .LT. 0 .OR. LL .LT. 0 ) RETURN                             
      LWAVRS = Z(IWAVRS(NWP))*FACFR4 - FACFR4                           
      LWAVIS = Z(IWAVIS(NWP))*FACFR4 - FACFR4                           
C                                                                       
C     IF THIS WAVE HAS ALREADY BEEN CALCULATED, GO TRANSFER IT.         
C                                                                       
      IF ( ( LL .NE. L .OR. LAS .NE. L )  .AND. L .GE. LASTL(NWP) ) GO T
     *O 900                                                             
C                                                                       
      DL = LL                                                           
      DLSQ(1) = DL*(DL+1)                                               
      DLSQ(2) = (DL+2)*(DL+3)                                           
      H = HS(NWP)                                                       
      STEPSZ = RSTEPS(NWP)                                              
      NSTEP = NSTPSS(NWP)                                               
C                                                                       
C     IF LINKULE POTENTIALS OR WAVEFUNCTIONS ARE IN USE,                
C     AND IF THIS IS A DWBA, THEN WE MUST SETUP THE PROPER /LNKBLK/     
C                                                                       
      IF ( PROBLM .LT. 20 .OR. PROBLM .EQ. 21 ) GO TO 50                
      DO 49 I = 1, NUMLNK                                               
      DO 49 II = 1, 6                                                   
      LNKADR(II,I) = LNKAD2(II,NWP,I)                                   
 49   CONTINUE                                                          
C                                                                       
C     START THE INTEGRATION AT THE POINT DETERMINED FOR THE PREVIOUS    
C     SOLUTION IF WE HAVE NOT RESET TO A NEW, LOWER, L VALUE.           
C                                                                       
 50   NFIRST = LASTNF(NWP)                                              
      IF ( LL .GE. LASTL(NWP) ) GO TO 160                               
      NFIRST = 2                                                        
      LASTZR = 1                                                        
C                                                                       
C     STEP1I (=STEPI) IS THE SMALLEST VALUE OF THE WAVEFUNCTION TO      
C     ALLOW AND THUS CONTROLS THE CHOICE OF NFIRST.  IT USE TO HAVE     
C     A DEFAULT OF 1 WHICH WE MAP TO THE DEFAULT OF 1E-6.               
C                                                                       
 160  IF ( STEPI .EQ. 1 ) STEPI = 1.D-6                                 
C                                                                       
C     OUR INITIAL GUESS IS ALWAYS STEPR*STEPI.  WE WILL NEVER LET       
C     !U! > BIGNUM.  THIS MEANS THAT THE REQUIRED RENORM WILL SATISFY   
C     1/STEPI > RENORM > SMLNUM, AND THUS RENORM**2 WILL NOT            
C     OVERFLOW OR UNDERFLOW.  THIS IS IMPORTANT FOR SDERIV.             
C     NOTE THAT STEPR EXISTS ONLY FOR HISTORICAL REASONS AND IS         
C     ALWAYS 1.                                                         
C                                                                       
      THISR = STEPI*STEPR                                               
      THISI = THISR                                                     
C                                                                       
C     ASSUME   U(R) = R**(L+1)  TO GET RATIO OF FIRST TWO POINTS        
C                                                                       
      AA1 = NFIRST - 2                                                  
      ISTRT = NFIRST - 2                                                
C     ZERO THE FIRST FEW POINTS IF NECESSARY.                           
      IF ( NFIRST .LT. LASTZR ) GO TO 180                               
      DO 174 I = LASTZR, NFIRST                                         
      DO 174 IL = 1, 4                                                  
      WAVR(I,IL,1) = 0.                                                 
      WAVI(I,IL,1) = 0.                                                 
 174  CONTINUE                                                          
 180  D = AA1/(AA1+1)                                                   
      WAVR(ISTRT+1,1,1) = THISR*D**(LL+1)                               
      WAVI(ISTRT+1,1,1) = THISI*D**(LL+1)                               
      WAVR(ISTRT+2,1,1) = THISR                                         
      WAVI(ISTRT+2,1,1) = THISI                                         
C     THE RATIO OF THE L+2 WAVE FUNCTION TO THE L WAVE FUNCTION         
C     DEPENDS ON THE LOCAL WAVE NUMBER.                                 
      AA1 = (2*LL+3)*(2*LL+5)                                           
      AA1 = (NFIRST-1)**2 * 12.*(VREAL(NFIRST)-1.) / AA1                
      WAVR(ISTRT+1,2,2) = THISR*AA1*D**(LL+3)                           
      WAVI(ISTRT+1,2,2) = THISI*AA1*D**(LL+3)                           
      WAVR(ISTRT+2,2,2) = THISR*AA1                                     
      WAVI(ISTRT+2,2,2) = THISI*AA1                                     
C                                                                       
C     COMPUTE THE TOTAL EFFECTIVE POTENTIAL FOR THIS L AND TEMPORARILY  
C     STORE IN THE WAVEFUNCTION ARRAYS.                                 
C                                                                       
      DO 224 I = ISTRT, NSTEP                                           
      WAVR(I+4,1,1) = VREAL(I+1) + DLSQ(1)*VCENT(I+1)                   
      WAVR(I+4,2,1) = VREAL(I+1) + DLSQ(2)*VCENT(I+1)                   
      WAVI(I+4,1,1) = VIMAG(I+1)                                        
      WAVI(I+4,2,1) = WAVI(I+4,1,1)                                     
      WAVR(I+4,1,2) = 0.                                                
      WAVI(I+4,1,2) = 0.                                                
 224  CONTINUE                                                          
      THSRSV = THISR + THISI                                            
C                                                                       
C     ADD IN THE SPIN ORBIT FORCES IF THEY EXIST                        
C                                                                       
      IF ( ISORS(NWP)+ISOIS(NWP) .EQ. 0 ) GO TO 250                     
C                                                                       
C     SDOTL IS REALLY  SIGMA.L.  NOTE THAT  JP, JSPS  ARE TWICE THE REAL
C     VALUES.                                                           
C                                                                       
      AA1 = .25*(JP*(JP+2) - JSPS(NWP)*(JSPS(NWP)+2))                   
      SDOTL(1) = ( AA1 - DLSQ(1) ) / JSPS(NWP)                          
      SDOTL(2) = ( AA1 - DLSQ(2) ) / JSPS(NWP)                          

      IF ( ISORS(NWP) .EQ. 0 ) GO TO 240                                
      LSOR = Z(ISORS(NWP))                                              
      DO 239 I = ISTRT, NSTEP                                           
      WAVR(I+4,1,1) = WAVR(I+4,1,1) + SDOTL(1)*ALLOC(LSOR+I)            
      WAVR(I+4,2,1) = WAVR(I+4,2,1) + SDOTL(2)*ALLOC(LSOR+I)            
 239  CONTINUE                                                          
 240  IF ( ISOIS(NWP) .EQ. 0 ) GO TO 250                                
      LSOI = Z(ISOIS(NWP))                                              
      DO 249 I = ISTRT, NSTEP                                           
      WAVI(I+4,1,1) = WAVI(I+4,1,1) + SDOTL(1)*ALLOC(LSOI+I)            
      WAVI(I+4,2,1) = WAVI(I+4,2,1) + SDOTL(2)*ALLOC(LSOI+I)            
 249  CONTINUE                                                          
C                                                                       
C     ADD IN THE TENSOR POTENTIALS IF THEY EXIST.                       
C                                                                       
 250  DO 259 II = 1, 3                                                  
      IF ( ITENS(NWP,2*II-1)+ITENS(NWP,2*II) .EQ. 0 ) GO TO 259         
      TCO(1) = TCOEF ( II, LL, LL, JP, JSPS(NWP) )                      
      TCO(2) = TCOEF ( II, LL+2, LL+2, JP, JSPS(NWP) )                  
      TCO(3) = TCOEF ( II, LL, LL+2, JP, JSPS(NWP) )                    
      IF ( ITENS(NWP,2*II-1) .EQ. 0 ) GO TO 255                         
      LTEN = Z(ITENS(NWP,2*II-1))                                       
      DO 254 IL = 1, 3                                                  
      IF ( TCO(IL) .EQ. 0 ) GO TO 254                                   
      DO 253 I = ISTRT, NSTEP                                           
      WAVR(I+4,IL,1) = WAVR(I+4,IL,1) + TCO(IL)*ALLOC(LTEN+I)           
 253  CONTINUE                                                          
 254  CONTINUE                                                          
 255  IF ( ITENS(NWP,2*II) .EQ. 0 ) GO TO 259                           
      LTEN = Z(ITENS(NWP,2*II))                                         
      DO 258 IL = 1, 3                                                  
      IF ( TCO(IL) .EQ. 0 ) GO TO 258                                   
      DO 257 I = ISTRT, NSTEP                                           
      WAVI(I+4,IL,1) = WAVI(I+4,IL,1) + TCO(IL)*ALLOC(LTEN+I)           
 257  CONTINUE                                                          
 258  CONTINUE                                                          
 259  CONTINUE                                                          
C                                                                       
C     NOW PROCESS L-DEPENDENT POTENTIALS WHICH COME ONLY FROM LINKULES. 
C                                                                       
C     THE LINKULE MUST ADD THE L-DEPENDENT PART OF THE POTENTIAL        
C     IN THE FORM    -H**2/(12*E) * V(L)   TO THE POTENTIAL ARRAYS      
C     ALREADY BUILTUP IN WAVR, WAVI.  THESE ARRAYS CONTAIN THE          
C     L-INDEPENDENT PART OF THE POTENTIAL THAT WAS RETURNED FOR         
C     THE IREQUE=3 CALL MADE FROM MAKPOT.                               
C     THE FACTOR   -H**2/(12*E)  WILL BE PASSED AS THE 1ST ELEMENT      
C     OF THE SECOND ARRAY TO THE LINKULE (A1 BELOW).                    
C                                                                       
 260  A1 = -(STEPSZ/HBARC)**2 * REDMS(NWP) / 6.D0                       
C                                                                       
      IF ( LNKADR(3,1) .EQ. 0 .OR. LNKADR(4,1) .NE. 1 ) GO TO 270       
      CALL LINKUL ( LNKADR(3,1), LNKNAM(1,1), LNKADR(5,1),  1, 4, IRET, 
     * LL, J, 0.D0, STEPSZ, NSTEP+1, WAVR(4,1,1), A1, NWP )             
      IF ( IRET .LT. 0 ) STOP 7777                                      
      CALL LINKUL ( LNKADR(3,1), LNKNAM(1,1), LNKADR(5,1),  1, 4, IRET, 
     * LL+2, J, 0.D0, STEPSZ, NSTEP+1, WAVR(4,2,1), A1, NWP )           
      IF ( IRET .LT. 0 ) STOP 7777                                      
C                                                                       
 270  IF ( LNKADR(3,2) .EQ. 0 .OR. LNKADR(4,2) .NE. 1 ) GO TO 300       
      CALL LINKUL ( LNKADR(3,2), LNKNAM(1,2), LNKADR(5,2),  2, 4, IRET, 
     * LL, J, 0.D0, STEPSZ, NSTEP+1, WAVI(4,1,1), A1, NWP )             
      IF ( IRET .LT. 0 ) STOP 7777                                      
      CALL LINKUL ( LNKADR(3,2), LNKNAM(1,2), LNKADR(5,2),  2, 4, IRET, 
     * LL+2, J, 0.D0, STEPSZ, NSTEP+1, WAVI(4,2,1), A1, NWP )           
      IF ( IRET .LT. 0 ) STOP 7777                                      
C                                                                       
C     COMPUTE FIRST TWO XSI'S                                           
C                                                                       
 300  II = ISTRT+1                                                      
      DO 309 I = ISTRT, II                                              
      DO 308 IL = 1, 2                                                  
      ILP = 3 - IL                                                      
      DO 307 IS = 1, 2                                                  
      WAVR(I+3,IL,IS) =  TWELTH*( WAVR(I+1,IL,IS)*WAVR(I+4,IL,1)  - WAVI
     *(I+1,IL,IS)*WAVI(I+4,IL,1)  + WAVR(I+1,ILP,IS)*WAVR(I+4,1,2)  - WA
     *VI(I+1,ILP,IS)*WAVI(I+4,1,2) )                                    
      WAVI(I+3,IL,IS) =  TWELTH*( WAVR(I+1,IL,IS)*WAVI(I+4,IL,1)  + WAVI
     *(I+1,IL,IS)*WAVR(I+4,IL,1)  + WAVR(I+1,ILP,IS)*WAVI(I+4,1,2)  + WA
     *VI(I+1,ILP,IS)*WAVR(I+4,1,2) )                                    
 307  CONTINUE                                                          
 308  CONTINUE                                                          
C                                                                       
 309  CONTINUE                                                          
C                                                                       
C     READY TO DO THE INTEGRATION.                                      
C     IS IT DONE HERE OR IN A LINKULE?                                  
C                                                                       
      IF ( LNKADR(3,6) .EQ. 0) GO TO 350                                
C                                                                       
      CALL LINKUL ( LNKADR(3,6), LNKNAM(1,6), LNKADR(5,6),  NFIRST, 3, I
     *RET, L, JP, H*ISTRT, H, NSTEP+1,  WAVR, WAVI, NWP )               
      IF ( IRET .GE. 0 ) GO TO 500                                      
      STOP 7777                                                         
C                                                                       
C     WILL DO INTEGRATION HERE                                          
C                                                                       
 350  CONTINUE                                                          
C                                                                       
C      NUMEROV METHOD (A LA RAYNAL) IS USED IN THE FOLLOWING LOOP       
C                                                                       
C     WE DEFINE                                                         
C       W(I) = 1 - (H**2/12)*(V(I)/E - 1)                               
C       XSI(I) = W(I)*U(I)/12                                           
C     WHERE                                                             
C       V(I) = V(I*STEPSZ) = V(I*H/K)                                   
C     CONTAINS THE COMPLETE NUCLEAR, COULOMB AND CENTRIFIGAL POTENTIALS.
C     MOST OF W(I) IS COMPUTED AND STORED IN MAKPOT, HOWEVER            
C     THE L-DEPENDENT PIECES ARE ADDED IN JUST ABOVE.                   
C                                                                       
C     THE DESIRED WAVEFUNCTION IS                                       
C       U(I) = U(I*STEPSZ)                                              
C     EXCEPT THAT AT THIS STAGE THE NORMALIZATION IS ARBITRARY:         
C       U(R) ---> CONS*R**(L+1) .                                       
C                                                                       
C     AT STEP I IN THE LOOP, THE WAVR AND WAVI ARRAYS CONTAIN:          
C                                                                       
C     WAV_(...)   CONTENTS                                              
C          I-1    U(I-2)     NOT USED                                   
C          I      U(I-1)                                                
C          I+1    XSI(I-2),   CHANGED TO U(I) DURING STEP               
C          I+2    XSI(I-1)                                              
C          I+3    W(I-1), NOT USED, CHANGED TO XSI(I) DURING STEP       
C          I+4    W(I)                                                  
C                                                                       
C     THE SMALLEST POSSIBLE NFIRST IS 2 WHICH RESULTS IN ISTRT=0.       
C     THE U AND XSI FOR NFIRST-2, NFIRST-1 HAVE ALREADY BEEN STORED.    
C                                                                       
C     NOTE THAT U AND XSI, AS DEFINED ABOVE, ARE 2-BY-2 MATRICES AT     
C     EACH I, INDEXED BY IL (FOR THE UPPER OR LOWER L VALUE) AND        
C     IS (FOR THE 2 INDEPENDENT SOLUTIONS).  THE DIAGONAL POTENTIALS    
C     ARE STORED IN THE LOWER HALF OF WAV_ (IS=1).  THE                 
C     OFF-DIAGONAL (COUPLING) POTENTIAL IS IN WAV_(I+4,1,2).            
C                                                                       
C                                                                       
C     ON THE FIRST PARTIAL WAVE, WE MUST FROM TIME TO TIME CHECK        
C     FOR IMMINENT OVERFLOW AND RENORMALIZE DOWN.  AFTER THE FIRST      
C     PARTIAL WAVE WE KNOW WHERE TO START AND NEED NOT CHECK.           
C                                                                       
      N1 = NFIRST                                                       
      N2 = NSTEP                                                        
      IF ( LL .GE. LASTL(NWP) ) GO TO 420                               
      N1ADD = 20                                                        
      IF ( L .GT. 16 ) N1ADD = EXP ( 50.D0/L )                          
C                                                                       
 410  N2 = N1 + N1ADD                                                   
      N2 = MIN0(N2, NSTEP)                                              
C                                                                       
C     LOOP THROUGH RADII.                                               
C                                                                       
 420  DO 449 I = N1, N2                                                 
C                                                                       
C        WI(I) = 12./W(I)  (MATRIX INVERSION)                           
C                                                                       
      TR = WAVR(I+4,1,1)*WAVR(I+4,2,1) - WAVI(I+4,1,1)*WAVI(I+4,2,1)  - 
     *WAVR(I+4,1,2)*WAVR(I+4,1,2) + WAVI(I+4,1,2)*WAVI(I+4,1,2)         
      TI = WAVR(I+4,1,2)*WAVI(I+4,1,2)                                  
      TI = TI + TI  - WAVR(I+4,1,1)*WAVI(I+4,2,1) - WAVI(I+4,1,1)*WAVR(I
     *+4,2,1)                                                           
      TD = 12. / ( TR*TR + TI*TI )                                      
      TR = TR*TD                                                        
      TI = TI*TD                                                        
      WIR(1) = TR*WAVR(I+4,2,1) - TI*WAVI(I+4,2,1)                      
      WII(1) = TR*WAVI(I+4,2,1) + TI*WAVR(I+4,2,1)                      
      WIR(2) = TR*WAVR(I+4,1,1) - TI*WAVI(I+4,1,1)                      
      WII(2) = TR*WAVI(I+4,1,1) + TI*WAVR(I+4,1,1)                      
      WTR = (-TR)*WAVR(I+4,1,2) + TI*WAVI(I+4,1,2)                      
      WTI = (-TR)*WAVI(I+4,1,2) - TI*WAVR(I+4,1,2)                      
C                                                                       
C        LOOP THROUGH THE 2 INDEPENDENT SOLUTIONS.                      
C                                                                       
      DO 439 IS = 1, 2                                                  
C                                                                       
C        XSI(I) = (-10.)*XSI(I-1) + U(I-1) - XSI(I-2)  (FOR EACH L)     
C                                                                       
      DO 424 IL = 1, 2                                                  
      WAVR(I+3,IL,IS) = (-10.)*WAVR(I+2,IL,IS)  + WAVR(I,IL,IS) - WAVR(I
     *+1,IL,IS)                                                         
      WAVI(I+3,IL,IS) = (-10.)*WAVI(I+2,IL,IS)  + WAVI(I,IL,IS) - WAVI(I
     *+1,IL,IS)                                                         
 424  CONTINUE                                                          
C                                                                       
C           U(I) = (12/W(I))*XSI(I)  (FOR EACH L)                       
C                                                                       
      DO 429 IL = 1, 2                                                  
      ILP = 3 - IL                                                      
      WAVR(I+1,IL,IS)  = WIR(IL)*WAVR(I+3,IL,IS) - WII(IL)*WAVI(I+3,IL,I
     *S)  + WTR*WAVR(I+3,ILP,IS) - WTI*WAVI(I+3,ILP,IS)                 
      WAVI(I+1,IL,IS)  = WIR(IL)*WAVI(I+3,IL,IS) + WII(IL)*WAVR(I+3,IL,I
     *S)  + WTR*WAVI(I+3,ILP,IS) + WTI*WAVR(I+3,ILP,IS)                 
 429  CONTINUE                                                          
C                                                                       
 439  CONTINUE                                                          
C                                                                       
 449  CONTINUE                                                          
      IF ( N2 .EQ. NSTEP ) GO TO 500                                    
C                                                                       
C     CHECK FOR NEARNESS OF OVERFLOW                                    
C                                                                       
      THISR = 0.                                                        
      DO 459 IL = 1, 4                                                  
      THISR = THISR + DABS(WAVR(N2+1,IL,1)) + DABS(WAVI(N2+1,IL,1))     
 459  CONTINUE                                                          
      IF ( PWBGSW ) WRITE(6,463) NWP, LL, N1, N2, THISR                   
 463  FORMAT ( ' CHECKING SIZE: NWP, LL, N1, N2, MAG =',  4I5, G13.3 )  
C                                                                       
      IF ( THISR .GT. BIGNUM ) GO TO 470                                
      IF ( THISR .LT. 100*THSRSV ) N1ADD = N1ADD + 5                    
      GO TO 490                                                         
C                                                                       
C     MUST SCALE DOWN.  WE WILL MULTIPLY EVERYTHING BY SMLNUM.          
C     FIRST WE FIND WHERE THIS WILL RESULT IN !U! = STEPI.              
C                                                                       
 470  THISI = STEPI*THISR                                               
      N1 = ISTRT                                                        
      DO 479 ISTRT = N1, N2                                             
      DO 478 IL = 1, 4                                                  
      IF ( DABS(WAVR(ISTRT+1,IL,1)) + DABS(WAVI(ISTRT+1,IL,1))  .GE. THI
     *SI ) GO TO 480                                                    
      WAVR(ISTRT+1,IL,1) = 0                                            
      WAVI(ISTRT+1,IL,1) = 0.                                           
 478  CONTINUE                                                          
 479  CONTINUE                                                          
C                                                                       
C                                                                       
C     SHOULD WE REDUCE N1ADD?                                           
C                                                                       
 480  IF ( THISR*1.D-10 .GT. BIGNUM ) N1ADD = MAX0(N1ADD/2, 1 )         
      IF ( PWBGSW ) WRITE(6,483) ISTRT                                    
 483  FORMAT ( 5X, 'RESCALING: NEW ISTRT =', I6 )                       
C                                                                       
      THISI = 1/THISR                                                   
      N1 = N2+2                                                         
      DO 489 I = ISTRT, N1                                              
      DO 488 IL = 1, 4                                                  
      WAVR(I+1,IL,1) = THISI*WAVR(I+1,IL,1)                             
      WAVI(I+1,IL,1) = THISI*WAVI(I+1,IL,1)                             
 488  CONTINUE                                                          
 489  CONTINUE                                                          
C                                                                       
 490  N1 = N2+1                                                         
      THSRSV = THISR                                                    
      GO TO 410                                                         
C                                                                       
C     END OF THE INTEGRATION                                            
C                                                                       
 500  CONTINUE
C                                                                       
C     EXTRACT S-MATRIX AND NORMALIZATION FROM U AND U AT NBAKCM         
C     STEPS BACK FROM END.                                              
C                                                                       
      LFORS = Z(ISMATS(NWP))                                            
      CALL TMATCH ( WAVR, WAVI, CR, CI, ALLOC(LFORS), JP, NWP, NWAVF )  
C                                                                       
C     FIND NEXT STARTING POINT                                          
C     FIND POINT WHERE ALL RENORMALIZED WAVEFUNCTION WILL BE < STEPI    
C                                                                       
      AA1 = 0.                                                          
      DO 609 IL = 1, 4                                                  
      AA1 = AA1 + DABS(CR(IL,1)) + DABS(CI(IL,1))                       
 609  CONTINUE                                                          
      BB1 = STEPI/AA1                                                   
      DO 629 I = ISTRT, NSTEP                                           
      DO 619 IL = 1, 4                                                  
      IF ( DABS(WAVR(I+1,IL,1)) + DABS(WAVI(I+1,IL,1)) .GE. BB1)  GO TO 
     *630                                                               
      WAVR(I+1,IL,1) = 0.                                               
      WAVI(I+1,IL,1) = 0.                                               
 619  CONTINUE                                                          
 629  CONTINUE                                                          
C                                                                       
 630  ISTRT = I                                                         
      LASTZR = I+1                                                      
C                                                                       
      ILP = 3 - IL                                                      
C     SET IT BACK SOME FOR LINKULES                                     
C                                                                       
      IF ( LNKADR(3,6) .NE. 0 ) I = I - 10                              
      I = MAX0( I+1, 2 )                                                
      LASTNF(NWP) = I                                                   
      LASTL(NWP) = LL                                                   
      BADSW = ( AA1 .GT. BIGNUM*1.D-10 .AND. NFIRST .GT. 2 ) .OR. AA1 .L
     *T. SMLNUM*1.D-5                                                   
      IF ( BADSW ) WRITE(6,663)
 663  FORMAT ( '0**** WARNING, LARGE WAVEFUNCTION RENORMALIZATION:' )   
      IF ( PWBGSW .OR. BADSW ) WRITE(6,668) NWP,LL,NFIRST,I,AA1      
 668  FORMAT ( ' NWP, LL =', I2, I4, '  NFIRST =', I4,  '  NEW NFIRST ='
     *, I4, '  RENORM =', D11.3 )                                       
      NFIRST = ISTRT                                                    
C                                                                       
C*********  REVIEW THESE 3 LINES IF/WHEN TENSOR FITS ARE ADDED.         
      ALPHAR = 1.                                                       
      ALPHAI = 0.                                                       
CCC      IF ( NUMFIT .NE. 0 )  GO TO 880                                
C                                                                       
C  STORE NORMALIZED WAVE FUNCTIONS                                      
C                                                                       
C     CR AND CI WILL NORMALIZE THE WAVEFUNCTION TO                      
C                                                                       
C       U(L) ---> ( (1+S)*F(L) + I (1-S)*G(L) ) / 2                     
C                                                                       
C     FOR STAND-ALONE CALCULATIONS WE MAY INSTEAD USE A NORMALIZATION   
C     THAT RESULTS IN REAL U(L) FOR REAL POTENTIALS.  THIS NORM         
C     IS COMPUTED AND APPLIED IN WAVEF.                                 
C                                                                       
 750  N2 = NSTEP+2                                                      
      DO 779 I = ISTRT, N2                                              
      DO 759 IL = 1, 4                                                  
      U1R(IL,1) = WAVR(I+1,IL,1)                                        
      U1I(IL,1) = WAVI(I+1,IL,1)                                        
 759  CONTINUE                                                          
      DO 769 IL = 1, 2                                                  
      DO 764 ILAS = 1, 2                                                
      WAVR(I+1,IL,ILAS)  = U1R(IL,1)*CR(1,ILAS) - U1I(IL,1)*CI(1,ILAS)  
     *+ U1R(IL,2)*CR(2,ILAS) - U1I(IL,2)*CI(2,ILAS)                     
      WAVI(I+1,IL,ILAS)  = U1R(IL,1)*CI(1,ILAS) + U1I(IL,1)*CR(1,ILAS)  
     *+ U1R(IL,2)*CI(2,ILAS) + U1I(IL,2)*CR(2,ILAS)                     
 764  CONTINUE                                                          
 769  CONTINUE                                                          
 779  CONTINUE                                                          
C                                                                       
C     IF NECESSARY, CONTINUE THE INTEGRATION USING JUST COULOMB         
C                                                                       
      NSTEP2 = NSTP2S(NWP)                                              
      IF ( NSTEP2 .LE. NSTEP ) GO TO 800                                
C                                                                       
      NSTEP = NSTEP+1                                                   
      RT = NSTEP*STEPSZ                                                 
      DLSQ(1) = DLSQ(1) * XFACS(3,NWP)                                  
      DLSQ(2) = DLSQ(2) * XFACS(3,NWP)                                  
C                                                                       
      DO 789 I = NSTEP, NSTEP2                                          
      RINV = 1./RT                                                      
      DO 787 IL = 1, 2                                                  
      D = 12. / ( XFACS(1,NWP) + RINV*( XFACS(2,NWP)  + DLSQ(IL)*RINV ) 
     *)                                                                 
      DO 784 ILAS = 1, 2                                                
      WAVR(I+3,IL,ILAS) = (-10.)*WAVR(I+2,IL,ILAS)  + WAVR(I,IL,ILAS) - 
     *WAVR(I+1,IL,ILAS)                                                 
      WAVI(I+3,IL,ILAS) = (-10.)*WAVI(I+2,IL,ILAS)  + WAVI(I,IL,ILAS) - 
     *WAVI(I+1,IL,ILAS)                                                 
      WAVR(I+1,IL,ILAS) = D*WAVR(I+3,IL,ILAS)                           
      WAVI(I+1,IL,ILAS) = D*WAVI(I+3,IL,ILAS)                           
 784  CONTINUE                                                          
 787  CONTINUE                                                          
      RT = RT + STEPSZ                                                  
 789  CONTINUE                                                          
C                                                                       
 800  IF ( STANSW .OR. NUMPTS .EQ. 0 ) GO TO 950                        
C                                                                       
C     NOW INTERPOLATE TO THE DESIRED GRID                               
C                                                                       
      STPINV = 1/RSTEPS(NWP)                                            
      IMX = NSTEP2 - 2                                                  
      DO 859 IR = 1, NUMPTS                                             
      RT = RGRID(IR)                                                    
C                                                                       
C     FIND THE LOCATION OF R IN THE TABLE                               
C                                                                       
      RBYH = RT*STPINV                                                  
      I = RBYH + 0.5                                                    
      I = MAX0 ( 2, MIN0 ( I, IMX ) )                                   
      P = RBYH - I                                                      
C     USE 5-POINT LAGRANGIAN INTERPOLATION (ABRAMOWITZ & STEGUN 25.2.15)
      PS = P*P                                                          
      X1 = P*(PS-1.)*OVER24                                             
      X2 = X1 + X1                                                      
      X3 = X1*P                                                         
      X4 = X2 + X2 - 0.5*P                                              
      X5 = X4*P                                                         
      C1 = X3 - X2                                                      
      C5 = X3 + X2                                                      
      C3 = X5 - X3                                                      
      C2 = X5 - X4                                                      
      C4 = X5 + X4                                                      
      C3 = C3 + C3 + 1.                                                 
      II = IR                                                           
      DO 849 IL = 1, 4                                                  
      ALLOC4(LWAVRS+II) = C1*WAVR(I-1,IL,1) - C2*WAVR(I,IL,1)  + C3*WAVR
     *(I+1,IL,1) - C4*WAVR(I+2,IL,1) + C5*WAVR(I+3,IL,1)                
      ALLOC4(LWAVIS+II) = C1*WAVI(I-1,IL,1) - C2*WAVI(I,IL,1)  + C3*WAVI
     *(I+1,IL,1) - C4*WAVI(I+2,IL,1) + C5*WAVI(I+3,IL,1)                
      II = II + NUMPTS                                                  
 849  CONTINUE                                                          
C                                                                       
 859  CONTINUE                                                          
C                                                                       
C     MOVE THE DESIRED WAVE FUNCTION FROM THE STORAGE ARRAY             
C     TO THE OUTPUT ARRAY.                                              
C                                                                       
 900  IF ( STANSW .OR. NUMPTS .EQ. 0 ) GO TO 950                        
      I = ( (L-LL)/2 + LAS-LL ) * NUMPTS                                
      LWAVRS = LWAVRS + I                                               
      LWAVIS = LWAVIS + I                                               
      DO 919 IR = 1, NUMPTS                                             
      WAVER(IR) = ALLOC4(LWAVRS+IR)                                     
      WAVEI(IR) = ALLOC4(LWAVIS+IR)                                     
 919  CONTINUE                                                          
C                                                                       
 950  CONTINUE
      RETURN                                                            
      END                                                               

      SUBROUTINE WAVINH ( NFIRST, NSTEP, WAVR, WAVI,  RHSR, RHSI, FLP, N
     *STPDM )                                                           
C                                                                       
C     NUMEROV LOOP FOR INHOMOGENEOUS WAVEFUNCTIONS                      
C                                                                       
C     4/17/80 - REMOVED FROM COUPLN - S.P.                              
C     4/19/80 - RHS MADE REAL*8 - S.P.                                  
C     7/28/80 - SPLIT LOOP FOR CRAY VERSION - S.P.                      
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      REAL*8 WAVR(1), WAVI(1)                                           
CRA      REAL*8  WAVR(NSTPDM, 3), WAVI(NSTPDM, 3)                       
      REAL*8 RHSR(1), RHSI(1)                                           
C                                                                       
C                                                                       
C      NUMEROV METHOD (A LA RAYNAL) IS USED IN THE FOLLOWING LOOP       
C                                                                       
C     WE DEFINE                                                         
C       W(I) = 1 - (H**2/12)*(V(I)/E - 1)                               
C       XSI(I) = W(I)*U(I)/12                                           
C     WHERE                                                             
C       V(I) = V(I*STEPSZ) = V(I*H/K)                                   
C     CONTAINS THE COMPLETE NUCLEAR, COULOMB AND CENTRIFIGAL POTENTIALS.
C     W(I) IS COMPUTED BY COUPLN BEFORE CALLING US.                     
C                                                                       
C     THE DESIRED WAVEFUNCTION IS                                       
C       U(I) = U(I*STEPSZ)                                              
C     EXCEPT THAT HERE WE REALLY COMPUTE 12*U WHICH IS WHAT             
C     IS DESIGNATED AS U BELOW  ( U = 12*PSI*R ).                       
C                                                                       
C     AT STEP I IN THE LOOP, THE WAVR AND WAVI ARRAYS CONTAIN:          
C                                                                       
C     WAV_(...)   CONTENTS                                              
C          I-1    U(I-2)     NOT USED                                   
C          I      U(I-1)                                                
C          I+1    XSI(I-2),   CHANGED TO U(I) DURING STEP               
C          I+2    XSI(I-1)                                              
C          I+3    W(I-1), NOT USED, CHANGED TO XSI(I) DURING STEP       
C          I+4    W(I)                                                  
C                                                                       
C     THE SMALLEST POSSIBLE NFIRST IS 2 WHICH RESULTS IN ISTRT=0.       
C     THE U AND XSI FOR NFIRST-2, NFIRST-1 HAVE ALREADY BEEN STORED.    
C                                                                       
      D = 12.D0/( WAVR(NFIRST+4)**2 + WAVI(NFIRST+4)**2 )               
C                                                                       
      DO 210 I = NFIRST,NSTEP                                           
C                                                                       
      WAVR(I+3) = 10.D0*(RHSR(I)-WAVR(I+2)) + (WAVR(I)-  WAVR(I+1)+RHSR(
     *I+1)+RHSR(I-1) )                                                  
      WAVI(I+3) = 10.D0*(RHSI(I)-WAVI(I+2)) + (WAVI(I)-  WAVI(I+1)+RHSI(
     *I+1)+RHSI(I-1) )                                                  
      WAVR(I+1) = (WAVR(I+4)*WAVR(I+3)+  WAVI(I+4)*WAVI(I+3))*D         
      WAVI(I+1) = (WAVR(I+4)*WAVI(I+3)-  WAVI(I+4)*WAVR(I+3))*D         
      D = (12.D0/(WAVR(I+5)**2+WAVI(I+5)**2))                           
C                                                                       
 210  CONTINUE                                                          
C                                                                       
C     FOR CRAY WE DO AS MUCH A POSSIBLE IN VECTOR MODE                  
C                                                                       
CRA      DO 199  I = NFIRST, NSTEP                                      
CRA         WAVR(I+4,2) = WAVR(I+4,1) * ( 12./(WAVR(I+4,1)**2 +         
CRA     1        WAVI(I+4,1)**2) )                                      
CRA         WAVI(I+4,2) = WAVI(I+4,1) * ( 12./(WAVR(I+4,1)**2 +         
CRA     1        WAVI(I+4,1)**2) )                                      
CRA         WAVR(I,3) = 10*RHSR(I) + RHSR(I-1) + RHSR(I+1)              
CRA         WAVI(I,3) = 10*RHSI(I) + RHSI(I-1) + RHSI(I+1)              
CRA 199  CONTINUE                                                       
C                                                                       
CRA      DO 299  I = NFIRST, NSTEP                                      
CRA         WAVR(I+3,1) = WAVR(I,3) - 10.*WAVR(I+2,1) + WAVR(I,1) -     
CRA     1      WAVR(I+1,1)                                              
CRA         WAVI(I+3,1) = WAVI(I,3) - 10.*WAVI(I+2,1) + WAVI(I,1) -     
CRA     1      WAVI(I+1,1)                                              
CRA         WAVR(I+1,1) = WAVR(I+4,2)*WAVR(I+3,1) +                     
CRA     1       WAVI(I+4,2)*WAVI(I+3,1)                                 
CRA         WAVI(I+1,1) = WAVR(I+4,2)*WAVI(I+3,1) -                     
CRA     1       WAVI(I+4,2)*WAVR(I+3,1)                                 
CRA 299  CONTINUE                                                       
C                                                                       
      FLP = 24*(NSTEP-NFIRST+1)                                         
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE WAVPOT (IRET)                                          
C                                                                       
C     GETS L-DEPENDENT STUFF (COULOMB FCNS, S-ARRAYS) FOR WAVELJ        
C                                                                       
C     THIS IS THE SECOND PART OF THE OLD WAVEF.  IT SETS UP THE         
C     ARRAYS FOR THE S-MATRICES AND FINDS THE COULOMB                   
C     BOUNDRY CONDITIONS.  POINTERS AND PARAMETERS ARE LEFT IN 2-ELEMENT
C     ARRAYS THAT ARE LABELED BY THE CHANNEL NUMBER ( ICHANW = 1, 2 ).  
C                                                                       
C     2/4/75 - MASSIVE RUPTURE OF WAVEF - S. P.                         
C     2/10/75 - COMPUTE COULOMB PHASE SHIFTS FOR INELDC                 
C     2/24/75 - INTEGRATE TO SEVERAL STEPS PAST LARGEST R NEEDED        
C     2/25/75 - LOTS OF INPUT CHECKS; DON'T DIVIDE BY 0 DIFUSNESS       
C     4/16/75 - NEW COMMON BLOCKS; REMOVE S.O. SINCE IT IS WRONG        
C     4/20/75 - SPLIT INTO WAVSET AND WAVPOT.                           
C     5/21/75 - DO THINGS UPTO LIMOST                                   
C     5/22/75 - POTENTIALS MOVED TO WAVELJ; STANSW                      
C     10/7/75 - POTENTIALS MOVED TO MAKPOT                              
C     10/15/75 - ELAB-DEPENDANCE OF STEPSIZE IN ELASTIC FITS.           
C     3/23/76 - USE MANCHESTER COULOMB ROUTINE                          
C     4/15/77 DO NOT COMPUTE POTENTIAL WHEN NOT NEEDED                  
C     11/20/77 - AREA FOR MAKPOT TO CONSTRUCT POTENTIAL - S.P.          
C                MUCH MOVED TO WAVSET.                                  
C     4/24/78 - REVERSE LOMOST FOR LIMOST - S.P.                        
C     5/24/78 - INITIALIZE SMAT TO 0 - S.P.                             
C     8/1/79 - STANDARD PREFIXES, S-MATRIX INDICES - RPG                
C     1/18/80 - SKIP COULOMB F & G FOR C.C. - S.P.                      
C     4/27/80 - COMPUTE FOR ONE VALUE OF L FOR C.C. - S.P.              
C     5/14/82 - DO NOT DESTROY LX - HURTS DEFORMED FITS - 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 /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 /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
      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                                                                 
      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)                 
      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
     *) )                                                               
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      CHARACTER*8 NAMES(2, 8)                                           
      DATA NAMES/'SIN', 'SOUT', 'COULFA', 'COULFB', 'COULGA', 'COULGB', 
     *'COULFBA', 'COULFBB', 'COULGBA', 'COULGBB', 'COULSIGA', 'COULSIGB'
     *, 'INDXEA', 'INDXEB', 'TOCEA', 'TOCEB'/                           
C                                                                       
      IRET = 1                                                          
      STEPSZ = RSTEPS(ICHANW)                                           
      ETA = ETAS(ICHANW)                                                
      E = ES(ICHANW)                                                    
C                                                                       
      NSTEP = NSTPSS(ICHANW)                                            
C                                                                       
      I = (LOMOST+1) * MAX0( NUMFIT, 1 )                                
      IOFF = (IOFFIT-1) * (LOMOST+1)                                    
      L1 = 0                                                            
      L2 = LOMOST                                                       
C                                                                       
      IF ( PROBLM .NE. 24 ) GO TO 150                                   
C                                                                       
      L1 = MAX0( 0, LMIN-LXMAX )                                        
      L2 = L1                                                           
C                                                                       
C   FIRST CALCULATE WAVEF AT ASYMTOPIA SINCE GET ALL L FOR PRICE OF ONE 
C                                                                       
C  NEED COULOMB WAVES                                                   
C                                                                       
C     WE ALLOCATE SPACE ON THE 1ST CALL TO WAVPOT WHEN FITTING          
C     AT MULTIPLE ENERGIES.  THEREAFTER WE JUST FILL IN AN ADDITIONAL   
C     COLUMN OF THE ARRAYS FOR EACH NEW ENERGY.                         
C     FOR NON-FITTING JOBS (DWBA AND ELASTIC SCATTERING), WE ALWAYS     
C     HAVE   NUMFIT = 0; IOFFIT = 1.                                    
C                                                                       
 150  NF = NFS(ICHANW)                                                  
      NG = NGS(ICHANW)                                                  
      NF1 = NF1S(ICHANW)                                                
      NG1 = NG1S(ICHANW)                                                
C                                                                       
      IF ( IOFFIT .NE. 1 ) GO TO 200                                    
C                                                                       
      NF=NALLOC(I, NAMES(ICHANW,2) )                                    
      NG=NALLOC(I, NAMES(ICHANW,3) )                                    
      NF1=NALLOC(I, NAMES(ICHANW,4) )                                   
      NG1=NALLOC(I, NAMES(ICHANW,5) )                                   
C                                                                       
C     SAVE THINGS FOR USE BY WAVELJ                                     
C                                                                       
      NFS(ICHANW) = NF                                                  

      NGS(ICHANW) = NG                                                  
      NF1S(ICHANW) = NF1                                                
      NG1S(ICHANW) = NG1                                                
C                                                                       
C     NOW COMPUTE THE COULOMB WAVE FUNCTIONS                            
C                                                                       
 200  RHO=NSTEP*HS(ICHANW)                                              
C                                                                       
C     SETUP WORKAREA FOR RCWFN (F' AND G')                              
C                                                                       
      IWRK = IALLOC(2*(LOMOST+1))                                       
      LWRK = Z(IWRK)                                                    
C                                                                       
      CALL RCWFN ( RHO, ETA, L1, L2, ALLOC(Z(NF)+IOFF),  ALLOC(LWRK), AL
     *LOC(Z(NG)+IOFF),  ALLOC(LWRK+(LOMOST+1)), 1.D-14, IFLAG )         
      IF ( IFLAG .NE. 0 ) GO TO 9910                                    
C                                                                       
C  CALCULATE COULOMB FUNCTION AT NBACK STEPS BACK                       
C                                                                       
      RHO1=(NSTEP-NBAKCM)*HS(ICHANW)                                    
      CALL RCWFN ( RHO1, ETA, L1, L2, ALLOC(Z(NF1)+IOFF),  ALLOC(LWRK), 
     *ALLOC(Z(NG1)+IOFF),  ALLOC(LWRK+(LOMOST+1)), 1.D-14, IFLAG )      
      IF ( IFLAG .NE. 0 ) GO TO 9910                                    
C                                                                       
C     FREE THE WORK AREA                                                
      Z(IWRK) = -Z(IWRK)                                                
C                                                                       
C     COULOMB PHASE SHIFTS                                              
C                                                                       
 300  IF ( IOFFIT .EQ. 1 ) ISIGS(ICHANW)=NALLOC(I,NAMES(ICHANW,6))
C                                                                       
      CALL DSGMAL ( ETA, LOMOST, ALLOC(Z(ISIGS(ICHANW))+IOFF) )         
C                                                                       
C     REST IS NOT DONE FOR MULTIPLE ENERGY FITS AFTER 1ST ENERGY        
C                                                                       
      IF ( IOFFIT .NE. 1 ) RETURN                                       
C                                                                       
C     ALLOCATE SPACE FOR ELASTIC S-MATRICES AND INITIALIZE THEIR        
C     INDICES AND TABLES OF CONTENTS.  FORMATS ARE THE SAME AS          
C     "INDXS" AND "TOCS" (SEE ANGSET AND JPTOLX COMMENTS).              
C                                                                       
      NLXE = 1                                                          
      IF ( SOSWS(ICHANW) ) NLXE = JSPS(ICHANW) + 1                      
      IINDXE(ICHANW) = NALLOC( (3*NLXE*NLXE+1)/FACFR4, NAMES(ICHANW,7) )
      CALL INIT4 ( IINDXE(ICHANW), 0 )                                  
      I = ( NLXE**2 + 1 )/2                                             
      ITOCE(ICHANW) = NALLOC ( 4*I/FACFR4, NAMES(ICHANW,8) )            
      LTOCE = Z(ITOCE(ICHANW))*FACFR4 - FACFR4                          
      LINDXE = Z(IINDXE(ICHANW))*FACFR4 - FACFR4                        
      II = 1                                                            
      DO 319 LXP = 1, NLXE                                              
      LXTMP = LXP - 1                                                   
      NLO = ( LXTMP + LXP + MOD(LXP, 2) )/2                             
      LDEL = 1 - NLO                                                    
      K = LINDXE + 1 + 3*LXTMP*( JSPS(ICHANW) + 2 )                     
      ILLOC(K) = II                                                     
      ILLOC(K+1) = LDEL                                                 
      ILLOC(K+2) = NLO                                                  
      DO 309 IDEL = 1, NLO                                              
      ILLOC(LTOCE+4*II-3) = LDEL                                        
      ILLOC(LTOCE+4*II-2) = LXTMP                                       
      ILLOC(LTOCE+4*II-1) = 2*LXTMP                                     
      ILLOC(LTOCE+4*II) = 0                                             
      II = II + 1                                                       
      LDEL = LDEL + 2                                                   
 309  CONTINUE                                                          
 319  CONTINUE                                                          
C                                                                       
      NUMJS(ICHANW) = II - 1                                            
      II = 2*NUMJS(ICHANW)*(LOMOST+1)                                   
      ISMATS(ICHANW) = NALLOC( II, NAMES(ICHANW,1) )                    
      CALL INIT8 ( ISMATS(ICHANW), 0.D0 )                               
C                                                                       
      RETURN                                                            
C                                                                       
C     ERRORS IN RCWFN                                                   
 9910 WRITE(6,9927) IFLAG, ETA, RHO, L1, L2                               
 9927 FORMAT ('-***** ERROR RETURN FROM RCWFN:', I8, 2G18.8, 2I8)       
      Z(IWRK) = -Z(IWRK)                                                
      IRET = 0                                                          
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE WFGET ( L, LAS, JP, NWP, NUMPTS, RGRID, WAVER, WAVEI,  
     *WAVR, WAVI, VREAL, VIMAG, VCENT )                                 
C                                                                       
C     INTERFACE TO CALL WAVELJ OR WAVETC AS APPROPRIATE.                
C                                                                       
C                                                                       
C     WAVETC IS CALLED IF THIS COMBINATION OF L, LAS, JP, NWP IS        
C     TENSOR COUPLED.  OTHERWISE, WAVELJ IS CALLED.                     
C                                                                       
C     6/6/79 - NEW ROUTINE - RPG                                        
C     6/8/79 - STANDARD PREFIXES - RPG                                  
C     4/23/80 - USE PWBFSW INSTEAD OF PBUGSW - S.P.                     
C     6/4/80 - PASS NWAVEF TO WAVETC - S.P.                             
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      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                                                                       
	REAL*4 RGRID(1),WAVER(1),WAVEI(1)
      DIMENSION WAVR(1), WAVI(1), VREAL(1), VIMAG(1), VCENT(1)          
C                                                                       
      IF ( PWBGSW ) WRITE(6,33) L, LAS, JP, NWP, NUMPTS                   
 33   FORMAT ( ' WFGET:  L,LAS,JP,NWP,NUMPTS=', 5I8 )                   
C                                                                       
C     CHECK FOR LEGALITY AND COUPLING.                                  
C                                                                       
      IF ( L .LT. 0 ) GO TO 200                                         
      IF ( .NOT. SOSWS(NWP) ) GO TO 100                                 
      IF ( JP .LT. IABS(2*L-JSPS(NWP)) ) GO TO 200                      
      IF ( .NOT. TCSWS(NWP) ) GO TO 100                                 
      IF ( LAS .LT. 0 .OR. LAS .GT. LOMOST ) GO TO 200                  
      IF ( JP .EQ. 2*L .OR. JP .EQ. 0 .OR. JP .GE. 2*LOMOST )  GO TO 100
     *                                                                  
C                                                                       
C     TENSOR COUPLED                                                    
C                                                                       
      CALL WAVETC ( L, LAS, JP, NWP, NWAVEF, NUMPTS, RGRID,  WAVER, WAVE
     *I, WAVR, WAVI, VREAL, VIMAG, VCENT )                              
      RETURN                                                            
C                                                                       
C     NOT TENSOR COUPLED                                                
C                                                                       
 100  CALL WAVELJ ( L, JP, NWP, NUMPTS, RGRID, WAVER, WAVEI,  WAVR, WAVI
     *, VREAL, VIMAG, VCENT )                                           
      RETURN                                                            
C                                                                       
C     ILLEGAL - SET TO ZERO.                                            
C                                                                       
 200  IF ( NUMPTS .EQ. 0 ) RETURN                                       
      DO 239 I = 1, NUMPTS                                              
      WAVER(I) = 0                                                      
      WAVEI(I) = 0                                                      
 239  CONTINUE                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE WOODSX ( NUMPTS, RSTRT, STEPSZ, VRAY, N1, N2,  ITYPE, V
     *, R, A, POWER )                                                   
C                                                                       
C     COMPUTES WOODS-SAXON TYPE POTENTIALS                              
C                                                                       
C     NUMPTS - NUMBER OF DESIRED POTENTIAL VALUES                       
C     RSTRT - FIRST R VALUE                                             
C     STEPSZ - INCREMENT IN R - LASTR = RSTRT + (NUMPTS-1)*STEPSZ       
C     VRAY - ARRAY OF NUMPTS LOCATIONS TO GET V                         
C     N1 - SET TO INDEX OF FIRST ELEMENT OF VRAY THAT IS NONTRIVIAL     
C     N2 - SET TO INDEX OF LAST NON-ZERO ELEMENT IN VRAY.               
C     ITYPE - TYPE OF POTENTIAL DESIRED:                                
C       1 - WOODS SAXON.                                                
C          -V / ( 1 + EXP((RVAL-R)/A) )**POWER                          
C       2 - SPIN ORBIT W.S.                                             
C          + 2*V/RVAL * D/DR 1 / ( 1 + EXP((RVAL-R)/A) )                
C       3 - DERIVATIVE OF W.S.                                          
C          + 4*V*A * D/DR 1 / ( 1 + EXP((RVAL-R)/A) )                   
C       4 - FOLDED REAL TR                                              
C         -2*V*RVAL * D/DR   1/RVAL * D/DR 1 / ( 1 + EXP((RVAL-R)/A) )  
C       5 - FOLDED IMAG TR                                              
C          +8*V*RVAL * D/DR   1/RVAL * D/DR                             
C                D/DR 1 / ( 1 + EXP((RVAL-R)/A) )                       
C     V, R, A, POWER - POTENTIAL PARAMETERS                             
C                                                                       
C     11/21/77 - FIRST VERSION - S.P.                                   
C     3/11/78 - DON'T GENERATE V'S < 1E-30 - S.P.                       
C     4/3/78 - DON'T GENERATE V'S < 1E-20 - S.P.                        
C     4/17/78 - KEEP N1 AND N2 IN BOUNDS; N2 > N1 - S.P.                
C     6/23/78 - ALLOCLEVEL ADDED                                        
C     12/13/78 - ADD SHAPES FOR TENSOR POTENTIALS (ITYPE = 4, 5) - RPG  
C     2/19/79 - LOCAL R CHANGED TO RT TO PRESERVE ARGUMENT - RPG        
C     12/28/79 - USE BIGLOG - RPG                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      DIMENSION VRAY(NUMPTS)                                            
C                                                                       
C     CHECK FOR ZERO POTENTIAL                                          
C                                                                       
      N1 = 0                                                            
      N2 = 0                                                            
      IF ( V .EQ. 0 ) GO TO 300                                         
C                                                                       
      XSTP = STEPSZ/A                                                   
      YSTP = DEXP(XSTP)                                                 
      X = (RSTRT-STEPSZ - R)/A                                          
C                                                                       
C     BREAK THE REGION (RSTRT, REND) INTO THREE REGIONS:                
C     1) SMALL R:  EXP((RVAL-R)/A)  <  EXP(-100)                        
C     2) MODERATE R:  EXP(..)**POWER IS COMPUTABLE                      
C     3) LARGE R:  V/( EXP((RVAL-R)/A) )**POWER  <  EXP(-46) = 1.E-20   
C                                                                       
      N1 = -(100+X)/XSTP                                                
      N1 = MAX0( N1, 1 )                                                
      N1 = MIN0( N1, NUMPTS )                                           
      Y = 46 + DLOG( DABS(V) )                                          
      Y = DMIN1( Y, BIGLOG )                                            
      IF ( POWER .GT. 1 ) Y = Y/POWER                                   
      N2 = (Y-X)/XSTP                                                   
      N2 = MIN0( N2, NUMPTS )                                           
      N2 = MAX0( N2, N1 )                                               
C                                                                       
C     REGION 1 - POTENTIAL IS -V OR ZERO.                               
C                                                                       
      IF ( N1 .EQ. 1 ) GO TO 200                                        
      Y = -V                                                            
      IF ( ITYPE .GT. 1 ) Y = 0                                         
      DO 189 I = 1, N1                                                  
      VRAY(I) = Y                                                       
 189  CONTINUE                                                          
C                                                                       
C     REGION 2 - COMPUTE THE POTENTIAL                                  
C                                                                       
 200  X = X + N1*XSTP                                                   
      Y = DEXP(X)                                                       
      GO TO ( 210, 230, 230, 250, 260 ), ITYPE                          
C                                                                       
C     STRAIGHT W.S.                                                     
C                                                                       
 210  IF ( POWER .NE. 1 ) GO TO 220                                     
      DO 214 I = N1, N2                                                 
      VRAY(I) = -V/(1+Y)                                                
      Y = Y*YSTP                                                        
 214  CONTINUE                                                          
      GO TO 300                                                         
C                                                                       
C     POWER OF W.S.                                                     
C                                                                       
 220  DO 224 I = N1, N2                                                 
      VRAY(I) = -V/(1+Y)**POWER                                         
      Y = Y*YSTP                                                        
 224  CONTINUE                                                          
      GO TO 300                                                         
C                                                                       
C     DERIVATIVE OF W.S.                                                
C                                                                       
 230  DO 234 I = N1, N2                                                 
      VRAY(I) = (-4*V) * (Y/(1+Y))/(1+Y)                                
      Y = Y*YSTP                                                        
 234  CONTINUE                                                          
C                                                                       
      IF ( ITYPE .NE. 2 ) GO TO 300                                     
C                                                                       
C     CONVERT DERIVATIVE OF W.S. TO SPIN ORBIT                          
C                                                                       
      RT = RSTRT + (N1-1)*STEPSZ + 1.D-30                               
      DO 244 I = N1, N2                                                 
      VRAY(I) = (.5/A) * VRAY(I)/RT                                     
      RT = RT + STEPSZ                                                  
 244  CONTINUE                                                          
      GO TO 300                                                         
C                                                                       
C     FOLDED REAL TR                                                    
C                                                                       
 250  V1 = 2.*V/(A*A)                                                   
      RT = RSTRT + (N1-1)*STEPSZ + 1.D-30                               
      DO 254 I = N1, N2                                                 
      XX = 1. + Y                                                       
      VRAY(I) = V1 * (Y/XX) * ( (1.-Y)/XX - A/RT ) / XX                 
      RT = RT + STEPSZ                                                  
      Y = Y * YSTP                                                      
 254  CONTINUE                                                          
      GO TO 300                                                         
C                                                                       
C     FOLDED IMAGINARY TR                                               
C                                                                       
 260  V1 = 8. * V / A                                                   
      AA = 1. / A                                                       
      A4 = 4.*AA                                                        
      RT = RSTRT + (N1-1)*STEPSZ + 1.D-30                               
      DO 264 I = N1, N2                                                 
      XX = 1. + Y                                                       
      YY = Y / XX                                                       
      RR = 1. / RT                                                      
      VRAY(I) = V1 * YY * ( ( (RR-AA)/XX + A4*YY )/XX  - (RR+AA)*YY*YY )
     * / XX                                                             
      RT = RT + STEPSZ                                                  
      Y = Y * YSTP                                                      
 264  CONTINUE                                                          
C                                                                       
C     NOW FILL OUT THE REST OF THE ARRAY WITH 0                         
C                                                                       
 300  IF ( N2 .EQ. NUMPTS ) RETURN                                      
      N2P1 = N2+1                                                       
      DO 329 I = N2P1, NUMPTS                                           
      VRAY(I) = 0                                                       
 329  CONTINUE                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE XSECTN ( IRTN )                                        
C                                                                       
C     COMPUTES THE  TRANSFER OR INELASTIC CROSS SECTIONS.               
C                                                                       
C     THIS CALCULATES THE  F(LX, MX)  FROM THE S(LX, LO, LI).           
C     THE CROSS SECTIONS ARE THEN SUMS OF  !F!**2.                      
C                                                                       
C   D.GLOECKNER 10/15/73                                                
C                                                                       
C     1/23/75 - SPLIT INTO TWO PIECES - INELDC AND XSECTN - S.P.        
C     2/10/75 - COMPUTE FAC2;  USE PRINT CONTROL                        
C     2/19/75 - CALL DUMMY1 TO SETUP CLEBSH, OTHER SMALL THINGS         
C     2/28/75 - SAVE RESULTS IN ARRAYS                                  
C     3/7/75 - REMOVE SPIN FACTORS FROM CROSS SECTION; MUCH COSMETICS;  
C              FIX A FEW BUGS; TOTAL CROSS SECTIONS; ALLOW AMIN = 0.    
C     4/8/75 - SUM ON LX, LOLA AND NON-LOLA SIGMAS, NEW I ARRAYS        
C     4/18/75 - NEW COMMONS                                             
C     6/1/75 - (-)**LO CHANGE; PHSPRT; ELASTIC D(SIGMA)                 
C     7/29/75 - PRINT ERRORS DUE TO L TRUNCATION                        
C     7/31/75 - LINTRP NOW EXTRAPOLATES                                 
C     8/6/75 - PRINT TOTAL  L > LMAX (LINTRP EXTRAP) CONTRIBUTION       
C     2/11/76 - STORE BETAR, BETAI ON TOP OF ILILOR, ILILOI - S.P.      
C     2/24/76 - USE SIGNS OF CHAPTER 2 OF MANUAL; CORRECT PICKUP ERROR  
C     4/27/76 - FIX TOTAL CROSS SECTIONS                                
C     9/13/76 - SUM TO LIMOST IN ELASTIC CROSS SECTIONS                 
C     11/7/76 - SAVE LX, MX CROSS SECTIONS, AND B'S.                    
C     12/26/76 - INELASTIC SCATTERING ADDED                             
C     12031/76 - REMOVE LOLA CROSS SECTIONS                             
C     5/7/77 - IDENTICAL PARTICLES; ELDCS DOES ELASTIC.                 
C     4/24/78 - LI, LO INTERCHANGE SOMEWHAT; LIMOST FOR ELASTIC - S.P.  
C     4/26/78 - RECREATE I FROM MAG & PHASE & COULOMB PHASES;           
C               STORE COMPLEX ISUM - S.P.                               
C     9/7/78 - USE BETA=1 FOR COUPLED CHANNELS - S.P.                   
C     3/6/79 - S-MATRICES; USE P(L,M) - S.P.                            
C     4/12/79 - OUT IS IN FOR COUPLED - S.P.                            
C     5/4/79 - USE RATMAS IN ELDCS; FIX ERROR IN ABOVE; DETAILED TIMING 
C     8/17/79 - STANDARDIZE, MAJOR REWRITE FOR SPIN-ORBIT ETC. - RPG    
C     4/2/80 - C.C. VERSION; REAL*4 S MATRICES - S.P.                   
C     4/26/80 - PBUGSW NOLONGER IN WAVCOM - S.P.                        
C     5/9/80 - USE JMOST FOR ELDCS - S.P.                               
C     6/24/80 - PRINT HEADER BY DIFFERENT FORMATS (523,524) - S.P.      
C     7/2/80 - PRINT MCHN INSTEAD OF NCHN - S.P.                        
C     7/11/80 - FOR C.C. REDEFINE BETAS FOR EACH CHAN - S.P.            
C     7/28/80 - PASS SCRATCH ARRAYS TO AMPCAL - S.P.                    
C     8/1/80 - CALL SETLOG - S.P.                                       
C     8/11/80 - PRINT CORRECT CHANNEL NUMBER ON 1ST PAGE - S.P.         
C     9/26/80 - INITIALIZE FLO TO ZEROS - S.P.                          
C     12/14/80 - SAVE ALL F'S; PRINT JP, ... - S.P.                     
C     6/1/81 - LXSTP BECOMES LXSTEP - S.P.                              
C     9/17/81 - EPSILON ALGORITHM USED - S.P.                           
C     10/12/81 - SMALL PRINTING FIXES - S.P.                            
C     10/27/81 - CHANGE SYMMETRY INDICATOR FOR AMPCAL - S.P.            
C                                                                       
C ***********************************                                   
C                                                                       
C     THIS IS A QUICK JOB AND IT REALLOCATES THE SCRATCH ARRAYS         
C     FAR MORE THAN IS DESIRABLE FOR C.C. CALCULATIONS.                 
C                                                                       
C ***********************************                                   
C                                                                       
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      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*8 NAMES                                                 
      COMMON /NAMCOM/ NAMES(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 )                                                   
      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 /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
      EQUIVALENCE ( JS(1), JA ), ( JS(2), JB ), ( JS(3), JBIGA ),  ( JS(
     *4), JBIGB ), ( JS(5), JX )                                        
      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                                                                 
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      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 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 /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 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                                                                       
      CHARACTER*8 BETNAM                                                
      DATA BETNAM / 'BETAS   ' /                                        
      CHARACTER*8 RUTNAM(2)                                             
      DATA RUTNAM/'TORUTHIN', 'TORUTHOT'/                               
      CHARACTER*8 FENAME(2)                                             
      DATA FENAME/'FIN     ', 'FOUT    '/                               
      CHARACTER*8 RUTHNM(2)                                             
      DATA RUTHNM/'RUTHIN', 'RUTHOUT'/                                  
      CHARACTER*8 INHEAD(2), OUTHED(2)                                  
      DATAOUTHED/'OUTGOING', ' OPTICAL'/                                
      DATA INHEAD/'INCOMING', ' COUPLED'/                               
C                                                                       
      CHARACTER*8 BLANK                                                 
      DATA BLANK / ' ' /                                                
C                                                                       
	DIMENSION DUM(1)
      CHARACTER*1 SIGNS(2)                                              
      DATA SIGNS/'+', '-'/                                              
C                                                                       
      LOGICAL PBUGSW, PHEDSW, PCONSW, TRANSW, FKEPSW, CCSW              
      DATA IZERO / 0 /, LINEMX / 57 /                                   
C-JSW
	PARAMETER (PLTMAX = 200)
	REAL PLTANG(PLTMAX), PLTSIG(PLTMAX)
	DATA NUMPLT /0/
C--
      IRTN = 0                                                          
      CRSFLP = 0                                                        
      TRANSW = ISTRIP .NE. 0                                            
      CCSW = PROBLM .EQ. 24                                             
      JMOST = LIMOST                                                    
      IF (CCSW) JMOST = LOMOST-LXMAX                                    
C                                                                       
      IPRNT = MOD(IPRINT, 10)                                           
      PBUGSW = IPRNT .GE. 4                                             
      PCONSW = IPRNT .GE. 3                                             
C                                                                       
      CALL PHSPRT ( IPRNT .GE. 1 )                                      
C                                                                       
      TBET = 0                                                          
      TCROSS = 0                                                        
C                                                                       
      WRITE(6,3) REACT, ELAB, HEADER                                      
  3   FORMAT ( X, T56, 'P T O L E M Y' /  10X, 'COMPUTATION OF CROSS S
     *ECTIONS',  T78, 'SOPHISTICATED PROGRAMS CONTAIN SUBTLE ERRORS' /  
     *X, 45A1, F7.2, ' MEV', 5X, 65A1 / )                             
      LINECT = 4                                                        
C
      PHEDSW = .TRUE.                                                   
C
C     LOCATE MAGNITUDES AND PHASES OF RADIAL INTEGRALS                  
C
      IMAG = NAMLOC('SMAG ')                                            
      IPHASE = NAMLOC('SPHASE ')                                        
      IF ( CCSW ) Z(IRDINT) = -Z(IRDINT)                                
C
      NUMANG = (ANGMAX-ANGMIN)/ANGSTP + 1.5                             
C
C     COMPUTE THE ELASTIC CROSS SECTIONS                                
C
      FKEPSW = ISAVB .EQ. 1 .OR. SOSWS(1)                               
      CALL ELDCS ( AKS(1), ETAS(1), ANGMIN, ANGMAX, ANGSTP,  LMIN, JMOST
     *, LSKIPS(1), ISTATS(1), JSPS(1), ISMATS(1),  ITOCE(1), NUMJS(1), I
     *SIGS(1), ELAB, RATMSS(1), .FALSE.,  ITORT1, RUTNAM(1), FKEPSW, IFI
     *N, FENAME(1), REACIN,  IRUTH1, RUTHNM(1) )                        
C                                                                       
C     DOES THE 2ND ARRAY CONTAIN INCOMING OR OUTGOING                   
C                                                                       
      IPROB = 2                                                         
      IF ( PROBLM .GE. 23 ) IPROB = 1                                   
      FKEPSW = ISAVB .EQ. 1 .OR. SOSWS(IPROB)                           
      CALL ELDCS ( AKS(IPROB), ETAS(IPROB), ANGMIN, ANGMAX, ANGSTP,  LMI
     *N, JMOST, LSKIPS(IPROB), ISTATS(IPROB), JSPS(IPROB),  ISMATS(2), I
     *TOCE(IPROB),  NUMJS(IPROB), ISIGS(IPROB), ELAB, RATMSS(IPROB), .FA
     *LSE.,  ITORT2, RUTNAM(2), FKEPSW, IFOUT, FENAME(2), REACOT,  IRUTH
     *2, RUTHNM(2) )                                                    
C
C     POSSIBLY SETUP FOR C.C. CALCULATIONS                              
C
      NCHNDF = 2                                                        
      LTOCOF = 0                                                        
      LSOFF = 0                                                         
      MCHN = 2                                                          
      IF = 0                                                            
      LFOFF = 0                                                         
C
C     TO COMPUTE  SIGMA(REACTION)/RUTHERFORD, WE USE                    
C     SQRT(RUTH(IN)*RUTH(OUT)).  RUTHFC  CONVERTS RUTH(IN)              
C     TO THIS GEOMETRIC MEAN.                                           
C
      RUTHFC = ETAS(2)*AKI/(ETAS(1)*AKO)                                
C
      IF ( .NOT. CCSW ) GO TO 200                                       
C
      LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      NCHNDF = ILLOC(LCHNDF)                                            
      MCHNDF = ILLOC(LCHNDF+1)                                          
      FKEPSW = ISAVB .EQ. 1                                             
      IF ( FKEPSW ) IF = NALLOC( 2*NUMANG*NASPLI, 'F ' )                
C
 200  ICROSS = NALLOC( NUMANG*(NCHNDF-1), 'CROSSSEC' )                  
      IFEPSL = NALLOC( 2*LEBACK+1, 'FEPSILON' )                         
C
      IDNPAR = 0                                                        
      IF ( IDENSW ) IDNPAR = 1                                          
C
C	JSW -- OPEN PLOT FILE
C
CK      OPEN(UNIT=9,FILE='INSIG.PLT',STATUS='NEW',CARRIAGECONTROL='LIST')
      OPEN(UNIT=9,FILE='INSIG.PLT',STATUS='UNKNOWN',FORM='FORMATTED')
C
      DO 1099 NCHN = 2, NCHNDF                                          
      IF ( .NOT. CCSW ) GO TO 210                                       
      LCHNDF = FACFR4*(Z(ICHNDF)-1)+1                                   
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2) + MCHNDF*(NCHN-1)               
      MCHN = ILLOC(LCHNDF)                                              
      JT = ILLOC(LCHNDF+1)                                              
      IT = 1                                                            
      IF ( JT .LT. 0 ) IT = 2                                           
      JT = IABS(JT)                                                     
      ET = ALLOC4(LCHNDF+2)                                             
      JP = ILLOC(LCHNDF+3)                                              
      IP = 1                                                            
      IF ( JP .LT. 0 ) IP = 2                                           
      JP = IABS(JP)                                                     
      EP = ALLOC4(LCHNDF+4)                                             
      KT = ILLOC(LCHNDF+15)                                             
      KP = ILLOC(LCHNDF+16)                                             
      IF ( IDENSW ) IDNPAR = 1                                          
      IF ( IDENSW .AND. JT .EQ. JP .AND. ET .EQ. EP )  IDNPAR = 2       
      WRITE(6,203) MCHN,EP,JP,SIGNS(IP),KP,ET,JT,SIGNS(IT), KT    
 203  FORMAT (' REACTION CROSS SECTIONS ARE FOR CHANNEL', I7,  ':  PROJE
     *CTILE, E =', F7.3, '  J =', I3, '/2', A1,  '  K =', I2, '/2',  '; 
     * TARGET, E =', F7.3, '  J =', I3, '/2', A1,  '  K =', I2, '/2' )  
      LINECT = LINECT+2                                                 
      ETAS(2) = ALLOC4(LCHNDF+5)                                        
      RUTHFC = ECM/(ECM-ET-EP)                                          
      NSPLI = ILLOC(LCHNDF+10)                                          
      LTOCOF = ILLOC(LCHNDF+12)                                         
      LSOFF = ILLOC(LCHNDF+13)                                          
      LIMOST = ILLOC(LCHNDF+14)                                         
      IF (PBUGSW) WRITE(6,208) ETAS(2),NSPLI,LTOCOF, LSOFF,  LIMOST     
 208  FORMAT ( ' ETA2, NSPLI, LTOCOF, LSOFF, LIMOST:', 8I8 )            
      IRDINT = NALLOC( (2*NSPLI*(LIMOST-LMIN+1))/FACFR4,  'BETAS ' )    
C
C     SCAN THE TABLE OF CONTENTS FOR EXTREMA IN LX, LI-LO.              
C
 210  LXMN = 1000                                                       
      LXMX = -1000                                                      
      LDELMX = -1000                                                    
      JPMX = -1000                                                      
      LTOCS = Z(ITOCS)*FACFR4 - FACFR4 + LTOCOF                         
      DO 249 KOFFS = 1, NSPLI                                           
      IF ( ILLOC(LTOCS+4*KOFFS) .LT. 0 ) GO TO 249                      
      LX = ILLOC(LTOCS+4*KOFFS-2)                                       
      LXMN = MIN0( LXMN, LX )                                           
      LXMX = MAX0( LXMX, LX )                                           
      LDEL = ILLOC(LTOCS+4*KOFFS-3)                                     
      LDELMX = MAX0( LDELMX, LDEL )                                     
      JPMX = MAX0( JPMX, ILLOC(LTOCS+4*KOFFS-1) )                       
249   CONTINUE                                                          
      LXRNGE = LXMX - LXMN + 1                                          
      NMLX = (LXMX-LXMN+LXSTEP)/LXSTEP                                  
      IF (PBUGSW) WRITE(6,253) LXMN,LXMX,LDELMX,JPMX,NMLX,LXRNGE     
 253  FORMAT ( ' LXMN, LXMX, LDELMX, JPMX, NMLX:', 8I8 )                
C
C     "TEMPS" IS USED FOR SCRATCH STORAGE BY SUBROUTINE BETCAL.         
C
      NTEMPS = ( LXMX+1 )*LXRNGE*( LDELMX+1 )                           
      ITEMPS = NALLOC( NTEMPS, 'TEMPS   ' )                             
      ILXTOT = NALLOC( LXMX+1, 'LXTOTS ' )                              
      IMXTOT = NALLOC( NSPLI, 'MXTOTS ' )                               
C
C     SUBROUTINE BETCAL CALCULATES THE ANGLE-INDEPENDENT PARTS          
C     (BETA) OF THE REACTION AMPLITUDES F.                              
C     THEY ARE PUT INTO THE ARRAY "S", WHICH IS THEN RENAMED "BETAS".   
C
      CALL SETLOG ( 2*(LOMOST+LXMAX) )                                  
C
      LMAG = FACFR4*(Z(IMAG)-1) + 1 + LSOFF                             
      LPHASE = FACFR4*(Z(IPHASE)-1) + 1 + LSOFF                         
      LRDINT = FACFR4*(Z(IRDINT)-1) + 1                                 
      LTOCS = Z(ITOCS)*FACFR4 - FACFR4 + LTOCOF                         
C
      IF ( CCSW )CALL DSGMAL(ETAS(2),LIMOST+LXMAX,ALLOC(Z(ISIGS(2))))
C                                                                       
      CALL BETCAL ( .FALSE., AKI, JSPS(1), NSPLI, LMIN, LIMOST, LSKIP,  
     *LXMN, LXMX, LDELMX, NTEMPS, ISTATS(1), PBUGSW,  SIGTOT, DUMMY,  IL
     *LOC(LTOCS+1),DUM(1) ,ALLOC4(LMAG), ALLOC4(LPHASE),  ALLOC(Z(ISIGS(
     *1))), ALLOC(Z(ISIGS(2))),  ALLOC4(LRDINT), ALLOC(Z(ILXTOT)), ALLOC
     *(Z(IMXTOT)),DUM(1),  ALLOC(Z(ITEMPS)) )                           
C
C     FREE THE SCRATCH ARRAY.                                           
C
      Z(ITEMPS) = -Z(ITEMPS)                                            
C
C     NOW COMPUTE THE REACTION CROSS SECTION FOR EACH ANGLE             
C
C     ALLOCATE SPACE FOR PLM                                            
C
      ISPACE = LIMOST+1+ ((2*LIMOST+1-LXMX)*LXMX)/2                     
      IPLM = NALLOC(ISPACE, 'PLM     ' )                                
      ITMPCN = NALLOC( 2*(LIMOST+1), 'TMPCONTR' )                       
C
C     SPACE FOR CROSS SECTIONS                                          
C     NOTE THAT THE NUMBER OF (LX, MX) COMBINATIONS IS THE SAME AS      
C     THE NUMBER OF (LI, LX) COMBINATIONS FOR EACH LO.                  
C
      ILXCRO = NALLOC( NUMANG*LXRNGE, 'LXCROSSS' )                      
      IMXCRO = 0                                                        
      IF ( ISAVMX .EQ. 1 ) IMXCRO = NALLOC( NUMANG*NSPLI, 'MXCROSSS' )  
      IMXCON = NALLOC( NSPLI, 'MXCONS ' )                               
      IF ( CCSW ) GO TO 350                                             
      FKEPSW = ISAVB .EQ. 1 .OR. MIN0( JS(1), JPMX, LXMX ) .GT. 0       
      IF ( FKEPSW ) IF = NALLOC( 2*NUMANG*NSPLI, 'F       ' )           
 350  ILXCNT = NALLOC( LXMX+1, 'LXCONTRB' )                             
      IFTEMP = NALLOC( 2*NSPLI, 'FTEMP   ' )                            
      IFLO = NALLOC( 2*NSPLI, 'FLO     ' )                              
      IFHI = NALLOC ( 2*NSPLI, 'FHI     ' )                             
      IFERR = NALLOC( NSPLI, 'FERROR' )                                 
      CALL INIT8 ( IFLO, 0.D0 )                                         
C
      CALL SETLOG ( 2*(LOMOST+LXMAX) )                                  
C
C     NO MORE ALLOCATIONS SO GET SOME LOCATIONS                         
C
      LLXCNT = Z(ILXCNT)                                                
      LRDINT = FACFR4*(Z(IRDINT)-1)+1                                   
      LPLM = Z(IPLM)                                                    
      LTMPCN = Z(ITMPCN)                                                
      LLXCRO = Z(ILXCRO) - LXMN*NUMANG - 1                              
      LMXCRO = Z(IMXCRO) - NUMANG - 1                                   
      LFTEMP = Z(IFTEMP) - 2                                            
      LFEND = LFTEMP + 2*NSPLI - 1                                      
      LFLO = Z(IFLO) - 2                                                
      LFHI = Z(IFHI) - 2                                                
      LFERR = Z(IFERR)-1                                                
      LF = Z(IF) - 2*NUMANG - 2 + LFOFF                                 
      LMXCON = Z(IMXCON) - 1                                            
      LTORT1 = Z(ITORT1) - 1                                            
      LTORT2 = Z(ITORT2) - 1                                            
      LRUTH1 = Z(IRUTH1) - 1                                            
      LCROSS = Z(ICROSS)-1 + NUMANG*(NCHN-2)                            
      LLXTOT = Z(ILXTOT)                                                
      LMXTOT = Z(IMXTOT)                                                
      LTOCS = Z(ITOCS)*FACFR4 - FACFR4 + LTOCOF                         
C
C     THE OUTER LOOP IS OVER THE ANGLES                                 
C
C     THE INNER LOOPS ARE IN THE ORDER:                                 
C        JT, JP, LX, MX (FROM "TOCS", INDEXED BY KOFFS)                 
C           LO                                                          
C
C     MAKE A SPACE EVERY ONCE AND A WHILE TO HELP APPEARANCES           
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                                                        
C
C     DO FOR ALL ANGLES                                                 
C
 500  NUMBLK = ANGBLK/ANGSTP + .5                                       
      I = 3                                                             
      IF ( NCHN .GT. 2 ) I = 5                                          
      LINADD = (NMLX+I-1)/I                                             
      NUMBLK = NUMBLK*LINADD                                            
      NMLXH = MIN0( NMLX, I )                                           
      IF ( .NOT. PCONSW ) GO TO 510                                     
C                                                                       
C     WHEN PRINTING (LX,MX) CONTRIBUTIONS, SPACE EVERY ANGLE            
C                                                                       
      NUMBLK = NSPLI+LINADD                                             
      ANGBLK = ANGSTP                                                   
C
      IF ( PBUGSW ) LINECT = 1000                                       
C
 510  DO 889 NANG = 1, NUMANG                                           
C
C        DO WE NEED A HEADER                                            
C
      IF ( LINECT .LT. LINEMX ) GO TO 520                               
      WRITE(6,3) REACT, ELAB, HEADER                                      
      LINECT = 4                                                        
      PHEDSW = .TRUE.                                                   
      IF ( CCSW ) WRITE(6,203) MCHN,EP,JP,SIGNS(IP),KP,ET,JT,SIGNS
     *(IT), KT                                                          
      IF ( CCSW ) LINECT = LINECT+2                                     
C     HAS THE SUBHEADER ALREADY BEEN PRINTED                            
 520  IF ( .NOT. PHEDSW ) GO TO 550                                     
      I2 = NMLXH+1                                                      
      IF ( NMLX .EQ. 1 ) I2 = 1                                         
      N = 1                                                             
      IF ( CCSW ) N = 2                                                 
      WRITE(6,523)
 523  FORMAT ('  ANGLE',T10,'REACTION', 5X, 'REACTION',  3X, 'LOW L',
     * 2X, 'HIGH L', 3X, '% FROM' )                                     
      IF ( NCHN .EQ. 2 ) WRITE(6,526) INHEAD(N),OUTHED(N),(BLANK,I= 
     *1, I2 )                                                           
 526  FORMAT ( X,T60, A8, ' ELASTIC', T82, A8,  A1, ( T91, 3( A1, 2X,
     * 'REACTION', 3X ) ) )                                             
      IF ( NCHN .GT. 2 ) WRITE(6,527) ( BLANK, I = 1, I2 )                
 527  FORMAT ( X,A1, ( T55, 5( A1, 2X, 'REACTION', 3X ) ) )          
C                                                                       
      WRITE(6,533)
 533  FORMAT ( T11, '(MB)', T25, '/RUTH', T35, '%/L',  T41, '% ERROR', T
     *50, 'L>LMAX' )                                                    
      IF ( NCHN .GT. 2 ) GO TO 540                                      
      WRITE(6,536)
 536  FORMAT ( X,T60, '(MB)', 8X, '/RUTH', T84, '/RUTH' )            
      IF ( NMLX .GT. 1 ) WRITE(6,538)(BLANK,LX,LX=LXMN,LXMX,LXSTEP )
 538  FORMAT ( X, ( T91, 3 ( A1, 3X, 'LX =', I2, 4X ) ) )             
      GO TO 545                                                         
 540  IF ( NMLX .GT. 1 ) WRITE(6,543)(BLANK,LX,LX=LXMN,LXMX,LXSTEP )
 543  FORMAT ( X, ( T56, 5 ( A1, 3X, 'LX =', I2, 4X ) ) )             
 545  WRITE(6,548)
 548  FORMAT ( ' ' )                                                    
      LINECT = LINECT + LINADD + 1                                      
      PHEDSW = .FALSE.                                                  
C                                                                       
 550  ANGLE = ANGMIN + (NANG-1)*ANGSTP                                  
C
C     CALCULATE THE TRANSITION AMPLITUDES F AT THIS ANGLE.              
C
      LHI = LMAX                                                        
      CALL AMPCAL ( ANGLE, .FALSE., NSPLI, LMIN, LIMOST, LSKIP,  LXMX, I
     *DNPAR, DUMMY, DUMMY, DUMMY, .TRUE., LHI,  ILLOC(LTOCS+1), ALLOC4(L
     *RDINT), DUM(1), ALLOC(LFTEMP+2), ALLOC(LFLO+2), ALLOC(LFHI+2),  AL
     *LOC(LFERR+1),DUM(1),  ALLOC(LPLM), ALLOC(LTMPCN), ALLOC(LTMPCN+LIM
     *OST+1),  LEBACK, ALLOC(Z(IFEPSL)), NFLPAM )                       
      CRSFLP = CRSFLP + NFLPAM                                          
C
      SIGMA = 0                                                         
      SUMLOW = 0                                                        
      SUMHI = 0                                                         
      SUMERR = 0                                                        
C
      DO 559 LX = IZERO, LXMX                                           
      ALLOC(LLXCNT+LX) = 0                                              
 559  CONTINUE                                                          
C
C     SUM OVER KOFFS = JT, JP, LX, MX.                                  
C
      DO 689 KOFFS = 1, NSPLI                                           
      IF ( ILLOC(LTOCS+4*KOFFS) .LT. 0 ) GO TO 689                      
      LX = ILLOC(LTOCS+4*KOFFS-2)                                       
      MX = ( ILLOC(LTOCS+4*KOFFS-3) + LX + 1 )/2                        
C
      FMNEG = 1.0D0                                                     
      IF ( MX .NE. 0 ) FMNEG = 2.0D0                                    
C
C     RETRIEVE F, ALREADY CALCULATED BY SUBROUTINE AMPCAL.              
C
      FR = ALLOC(LFTEMP+2*KOFFS)                                        
      FI = ALLOC(LFTEMP+2*KOFFS+1)                                      
C    IMPRESSION DE FR FI
C    SAVE F IN "F" IF REQUESTED.                                    
C
      IF ( .NOT. FKEPSW ) GO TO 600                                     
      ALLOC(LF+2*NANG+2*NUMANG*KOFFS) = FR                              
      ALLOC(LF+2*NANG+2*NUMANG*KOFFS+1) = FI                            
C
C        CROSS SECTION CONTRIBUTION IS JUST !F!**2.                     
C
 600  CONTRI = 10*(FR*FR+FI*FI)                                         
      ALLOC(LMXCON+KOFFS) = CONTRI                                      
      IF ( ISAVMX .EQ. 1 )  ALLOC(LMXCRO+NANG+NUMANG*KOFFS) = CONTRI    
      CONTRI = CONTRI*FMNEG                                             
      ALLOC(LLXCNT+LX) = CONTRI + ALLOC(LLXCNT+LX)                      
      SIGMA = SIGMA + CONTRI                                            
C 
C        WE ACCUMULATE THE CROSS SECTIONS WITH FIRST AND LAST 2 LO'S    
C        REMOVED IN SUMLOW AND SUMHI                                    
C
      SUMLOW = SUMLOW + 10*FMNEG *  ( ALLOC(LFLO+2*KOFFS)**2 + ALLOC(LFL
     *O+2*KOFFS+1)**2 )                                                 
      SUMHI = SUMHI + 10*FMNEG *  ( ALLOC(LFHI+2*KOFFS)**2 + ALLOC(LFHI+
     *2*KOFFS+1)**2 )                                                   
      SUMERR = SUMERR + ALLOC(LFERR+KOFFS)*CONTRI                       
C
      ALLOC(LLXCRO+NANG+NUMANG*LX) = ALLOC(LLXCNT+LX)                   
C
 689  CONTINUE                                                          
C
C     END OF KOFFS LOOP                                                 
C
      ALLOC(LCROSS+NANG) = SIGMA                                        
C
C     COMPUTE ERRORS DUE TO L-TRUNCATIONS                               
C
      SAFE = DMAX1( SIGMA, SMLNUM )                                     
      ERRLOW = 100 * (SIGMA-SUMLOW) / (SAFE+SUMLOW)                     
      HICONT = 100 * (SIGMA-SUMHI) / SAFE                               
      SUMERR = 200 * SUMERR/SAFE                                        
C
      IF ( .NOT. PCONSW ) GO TO 700                                     
      DO 699 KOFFS = 1, NSPLI                                           
      IF (ILLOC(LTOCS+4*KOFFS) .LT. 0 ) GO TO 699                       
      LX = ILLOC(LTOCS+4*KOFFS-2)                                       
      MX = ( ILLOC(LTOCS+4*KOFFS-3) + LX + 1 )/2                        
      GR = 100*ALLOC(LMXCON+KOFFS)/SAFE                                 
      WRITE(6, 693) ILLOC(LTOCS+4*KOFFS-1),  ILLOC(LTOCS+4*KOFFS), LX, M
     *X, ALLOC(LMXCON+KOFFS), GR                                        
 693  FORMAT ( 6X, ' JP, JT, LX, MX =', 2( I3, '/2' ), 2I3, 5X,  'CONTRI
     *BUTION =', G14.7, F8.2, '%' )                                     
 699  CONTINUE                                                          
C                                                                       
 700  RUTH = ALLOC(LRUTH1+NANG)                                         
      ELAS = RUTH*ALLOC(LTORT1+NANG)                                    
      SIGMAR = 0                                                        
      IF ( RUTH .NE. 0 ) SIGMAR = SIGMA/(RUTHFC*RUTH)                   
C
C     AT LAST, PRINT IT
C
      IF ( NCHN .GT. 2 ) GO TO 860                                      
      IF ( NMLX .EQ. 1 )WRITE(6,853) ANGLE,SIGMA,SIGMAR,ERRLOW,SUMER
     *R, HICONT,  ELAS, ALLOC(LTORT1+NANG), ALLOC(LTORT2+NANG)          
      IF ( NMLX .GT. 1 )WRITE(6,853) ANGLE,SIGMA,SIGMAR,ERRLOW,SUMER
     *R,HICONT,ELAS,ALLOC(LTORT1+NANG),ALLOC(LTORT2+NANG),(ALLOC
     *(LLXCNT+LX), LX = LXMN, LXMX, LXSTEP )
      IF(NMLX.GE.1) WRITE(9,864) ANGLE,SIGMA,SIGMAR 
ccc
c
c
      IF ( NMLX .EQ. 1 )WRITE(16,854) ANGLE,SIGMA,SIGMAR,
     *ALLOC(LTORT1+NANG), ALLOC(LTORT2+NANG)          
ccc      IF ( NMLX .GT. 1 )WRITE(16,854) ANGLE,SIGMA,SIGMAR,
ccc     *ALLOC(LTORT1+NANG),ALLOC(LTORT2+NANG)
      IF(NMLX.GE.1) WRITE(19,864) ANGLE,SIGMA,SIGMAR 
 854  FORMAT (F7.2, G13.5, F10.6, F12.6,F12.6)                                                   
c
c
ccc
C      IF ( NMLX .EQ. 1 )WRITE(9,853) ANGLE,SIGMA,SIGMAR,ERRLOW,SUMER
C     *R, HICONT,  ELAS, ALLOC(LTORT1+NANG), ALLOC(LTORT2+NANG)          
C      IF ( NMLX .GT. 1 )WRITE(9,853) ANGLE,SIGMA,SIGMAR,ERRLOW,SUMER
C     *R,HICONT,ELAS,ALLOC(LTORT1+NANG),ALLOC(LTORT2+NANG),(ALLOC
C     *(LLXCNT+LX), LX = LXMN, LXMX, LXSTEP )
 853  FORMAT (F7.2, G13.5, F10.6, 2F8.2, F8.1, G14.5, F10.6, F12.6, 
     *(T91, 3G14.5 ) )                                                   
      GO TO 880                                                         
 860  continue
      IF ( NMLX .EQ. 1 )WRITE(6,863) ANGLE,SIGMA,SIGMAR,ERRLOW,SUMER
     *R, HICONT                                                         
      IF ( NMLX .GT. 1 )WRITE(6,863) ANGLE,SIGMA,SIGMAR,ERRLOW,SUMER
     *R, HICONT,  ( ALLOC(LLXCNT+LX), LX = LXMN, LXMX, LXSTEP )         
      IF ( NMLX .GE. 1 )WRITE(9,864) ANGLE,SIGMA,SIGMAR
ccc
c
c
ccc      IF ( NMLX .EQ. 1 )WRITE(16,864) ANGLE,SIGMA,SIGMAR                                                         
ccc      IF ( NMLX .GT. 1 )WRITE(16,864) ANGLE,SIGMA,SIGMAR         
      IF ( NMLX .GE. 1 )WRITE(19,864) ANGLE,SIGMA,SIGMAR
c
c
ccc
C      IF ( NMLX .GT. 1 )WRITE(9,863) ANGLE,SIGMA,SIGMAR,ERRLOW,SUMER
C     *R, HICONT,  ( ALLOC(LLXCNT+LX), LX = LXMN, LXMX, LXSTEP )         
 863  FORMAT ( F7.2, G13.5, F10.6, 2F8.2, F8.1, ( T56, 5G14.5 ) )      
 864  FORMAT( F7.2, 2G14.5) 
 880  continue
      LINECT = LINECT + LINADD                                          
C-JSW STORE FOR PLOTTING
	NUMPLT = NUMPLT + 1
	IF (NUMPLT .LT. PLTMAX) PLTANG(NUMPLT) = ANGLE
	IF (NUMPLT .LT. PLTMAX) PLTSIG(NUMPLT) = SIGMA
      IF ( PCONSW ) LINECT = LINECT + NSPLI                             
      IF ( DMOD( ANGLE+ANGSTP+1.D-7, ANGBLK ) .GT. 1.D-5 ) GO TO 889    
      LINECT = LINECT + 1
      IF ( LINECT+NUMBLK .GT. LINEMX ) LINECT=1000                      
C
 889  CONTINUE                                                          
C
C     END OF LOOP OVER ANGLES                                           
C
      CRSFLP = CRSFLP + 26*NUMANG                                       
C
      WRITE(6,923) SIGTOT
 923  FORMAT ( / ' TOTAL:', G15.5 )                                     
      CLOSE(UNIT=9)
      SAFE = DMAX1( SIGTOT, SMLNUM )                                    
      IF ( NCHN .GT. 2 ) GO TO 935                                      
      WRITE(6,927) REACIN, REACOT                                         
 927  FORMAT ( X, T55, G14.5, G24.5 )                                 
      IF ( NMLX .EQ. 1 ) GO TO 980                                      
      WRITE(6,933) (ALLOC(LLXTOT+LX),LX = LXMN, LXMX, LXSTEP )          
 933  FORMAT ( X, ( T91, 3G14.5 ) )                                   
      GO TO 950                                                         
 935  IF ( NMLX .EQ. 1 ) GO TO 980                                      
      WRITE(6,938)(ALLOC(LLXTOT+LX), LX = LXMN, LXMX, LXSTEP )          
 938  FORMAT ( X, ( T55, 5G14.5) )                                    
C
 950  DO 955 LX = LXMN, LXMX, LXSTEP                                    
      ALLOC(LLXTOT+LX) = 100*ALLOC(LLXTOT+LX)/SAFE                      
 955  CONTINUE                                                          
      IF ( NCHN .EQ. 2 ) WRITE(6,963)(ALLOC(LLXTOT+LX),LX=LXMN,LXMX
     *, LXSTEP )                                                        
 963  FORMAT ( ( T87, 3(F13.2, '%') ) )                                 
      IF ( NCHN .GT. 2 ) WRITE(6,968)(ALLOC(LLXTOT+LX),LX=LXMN,LXMX
     *, LXSTEP )                                                        
 968  FORMAT ( ( T51, 5(F13.2, '%') ) )                                 
C                                                                       
 980  IF ( NSPLI .EQ. 1 ) GO TO 1000                                    
      WRITE(6,983)
 983  FORMAT ( / '  JP  JT  LX MX      TOTAL      PERCENT' ,  5X, '(VALU
     *ES FOR M > 0 NOT DOUBLED.)' / )                                   
      DO 999 KOFFS = 1, NSPLI                                           
      JTT = ILLOC(LTOCS+4*KOFFS)                                        
      IF ( JTT .LT. 0 ) GO TO 999                                       
      LX = ILLOC(LTOCS+4*KOFFS-2)                                       
      MX = ( ILLOC(LTOCS+4*KOFFS-3) + LX + 1 )/2                        
      GR = 100*ALLOC(LMXTOT+KOFFS-1)/SAFE                               
      WRITE(6,993) ILLOC(LTOCS+4*KOFFS-1),JTT,LX,MX,ALLOC(LMXTOT+KOFF
     *S-1), GR                                                          
 993  FORMAT ( 2( I3, '/2' ), 2I3, G15.5, F8.2 )                        
 999  CONTINUE                                                          
C                                                                       
C     GO TO THE NEXT CHANNEL                                            
C                                                                       
 1000 IF ( NCHN .EQ. NCHNDF ) GO TO 1099                                
      WRITE(6,3) REACT, ELAB, HEADER                                      
      PHEDSW = .TRUE.                                                   
      LINECT = 4                                                        
      LFOFF = LFOFF + 2*NSPLI*NUMANG                                    
C
 1099 CONTINUE                                                          
C
C     A L L    D O N E    WITH CROSS SECTIONS                           
C     RENAME THE "S" ARRAY TO "BETAS" WHICH IT BY NOW REALLY IS.        
C
      NAMES(IRDINT) = BETNAM                                            
      Z(IPLM) = -Z(IPLM)                                                
C
C     FREE VARIOUS ALLOCATOR ARRAYS.                                    
C
      Z(IMXCON) = -Z(IMXCON)                                            
      Z(ILXCNT) = -Z(ILXCNT)                                            
      Z(IFTEMP) = -Z(IFTEMP)                                            
      Z(IFLO) = -Z(IFLO)                                                
      Z(IFHI) = -Z(IFHI)                                                
C
C     NOW CALCULATE AND PRINT ANALYSING POWERS IF POSSIBLE.             
C
C     THIS PART DOES NOT WORK FOR C.C.                                  
C
      IF ( JS(1) .EQ. 0 ) GO TO 2150                                    
C
C     FIRST REACTION AP'S.                                              
C
      IF ( LXMX .NE. 0 .AND. JPMX .NE. 0 ) GO TO 2050                   
      WRITE(6,2023)
 2023 FORMAT ( ' ---- ALL REACTION ANALYZING POWERS ARE ZERO ----' )    
      GO TO 2100                                                        
 2050 IPARIT = PARITS(1)*PARITS(2)*PARITS(3)*PARITS(4)                  
      IF ( IPARIT .EQ. 0 .AND. TRANSW )IPARIT = 1 - 2*MOD(LBP+LBT,2)
      IF ( IPARIT .NE. 0 ) GO TO 2060                                   
      WRITE(6,2053)
 2053 FORMAT ( '0**** REACTION ANALYZING POWERS CANNOT BE CALCULATED',  
     *' BECAUSE THE PARITY CHANGE IS UNKNOWN ****' )                    
      GO TO 2100                                                        
C                                                                       
 2060 CALL ANAPOW ( ANGMIN, ANGMAX, ANGSTP, JS(1), JS(2), JS(3), JS(4), 
     * NSPLI, IPARIT, .TRUE., PBUGSW, 'ANPOW   ', ELAB, 'REACTION',  IF,
     * ITOCS, IANPOW )                                                  
C
C     NEXT THE INCIDENT ELASTIC CHANNEL.                                
C
 2100 IF (SOSWS(1)) GO TO 2120                                        
      WRITE(6,2113)
 2113 FORMAT('----ALL INCOMING ELASTIC ANALYZING POWERS ARE ZERO',  
     *'----' )
      GO TO 2150                                                        
C
 2120 CALL ANAPOW ( ANGMIN, ANGMAX, ANGSTP, JS(1), JS(1), JS(3), JS(3), 
     * NUMJS(1), 1, .TRUE., PBUGSW, 'ANPOWA  ', ELAB, 'INCOMING',  IFIN,
     * ITOCE(1), IAPOWA )                                               
C
C     NOW THE OUTGOING ELASTIC CHANNEL.                                 
C
 2150 IF ( JS(2) .EQ. 0 ) GO TO 2190                                    
      IF ( SOSWS(2) ) GO TO 2170                                        
      WRITE(6,2163)
 2163 FORMAT ( '---- ALL OUTGOING ELASTIC ANALYZING POWERS ARE ZERO',  
     *' ----' )                                                         
      GO TO 2190                                                        
C
 2170 EELAB = (1+RATMSS(2))*(E+Q)                                       
      CALL ANAPOW ( ANGMIN, ANGMAX, ANGSTP, JS(2), JS(2), JS(4), JS(4), 
     * NUMJS(2), 1, .TRUE., PBUGSW, 'ANPOWB  ', EELAB, 'OUTGOING',  IFOU
     *T, ITOCE(2), IAPOWB )                                             
C
 2190 CONTINUE
      IF(.NOT.CCSW) CALL LPPLOT(PLTANG,PLTSIG,NUMPLT)
C
      IRTN = 1                                                          
      RETURN                                                            
      END                                                               
