      SUBROUTINE WAVSET ( IRET, ALONSW, FITSW )                         
C                                                                       
C     INITIALIZES THE COMPUTATION OF THE SCATTERING WAVE FUNCTIONS.     
C                                                                       
C     THIS IS THE FIRST PART OF THE OLD WAVEF.  IT CHECKS AND           
C     PRINTS THE INPUT AND STORES EVERYTHING FOR WAVPOT.                
C     ARRAYS ARE SET UP FOR THE POTENTIAL IN THE FORM TO BE USED        
C     BY WAVELJ.  IN ALL CASES EXCEPT FITS THESE ARRAYS ARE FILLED.     
C     POINTERS AND PARAMETERS ARE LEFT IN 2-ELEMENT                     
C     ARRAYS THAT ARE LABELED BY THE CHANNEL NUMBER ( ICHANW = 1, 2 ).  
C                                                                       
C     IRET - SET TO 0 IF AN ERROR IS DETECTED; 1 IF O.K.                
C     ALONSW - LOGICAL*4 - .TRUE. MEANS THIS IS A STAND ALONE CALC.     
C              .FALSE. MEANS IT IS PART OF A DWBA.                      
C     FITSW - .TRUE. IF CALLED FROM THE FITTER (FITEL)                  
C                                                                       
C     THE POTENTIALS ARE DEFINED AS:                                    
C                                                                       
C     REAL(V) = VC - V/(1+X)                                            
C               + (VSO+TAU*V) * 4*L.S * (1/R) * (D/DR) 1/(1+XSO)        
C               + TR, TL, TP TENSOR TERMS (IF JSP = 2)                  
C     IMAG(V) = -VI/(1+XI)                                              
C               + (VSOI+TAUI*VI) * 4*L.S * (1/R) * (D/DR) 1/(1+XSOI)    
C               + VSI * 4*ASI * (D/DR) 1/(1+XSI)                        
C               + TR, TL, TP TENSOR TERMS (IF JSP = 2)                  
C     WHERE                                                             
C                                                                       
C     X = EXP( (RVAL-R)/A )                                             
C     XI = EXP( RVAL-RI)/AI ), ...,                                     
C     L.S = ( JP(JP+1) - SP(SP+1) - L(L+1) )/2                          
C     VC = ZP*ZT*HBARC/(ALPHA*RVAL)         RVAL > RC                   
C          ZP*ZT*HBARC/(2*ALPHA*RC) * (3 - (RVAL/RC)**2)  RVAL < RC     
C     ALPHA = FINE STRUCTURE CONSTANT.                                  
C                                                                       
C     THE COMPUTED WAVEFUNCTIONS ARE SOLUTIONS OF THE SCHROEDINGER      
C     EQUATION                                                          
C                                                                       
C       ( 1/(2M) * ( -(D/DR)**2 + L(L+1)/R**2 ) + V - E ) U(R) = 0      
C                                                                       
C     AND ARE NORMALIZED SUCH THAT                                      
C                                                                       
C       U(R) ---> (1/2) * ( (1+S)*F(KR) + I*(1-S)*G(KR) )               
C                                                                       
C     WHERE F(KR) AND G(KR) ARE THE REGULAR AND IRREGULAR COULOMB       
C     FUNCTIONS AND S IS THE S-MATRIX.                                  
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/22/75 - ALONSW ADDED; VSI ADDED                                 
C     6/10/75 - FIX ERROR IN VSI CONSTANT                               
C     6/27/75 - STEPSPER; NEW RC UNDEF CHECK                            
C     8/3/75 - ETAS INTO KANDM COMMON.                                  
C     10/7/75 - POTENTIALS IN MAKPOT; PRINT R0'S - S.P.                 
C     10/10/75 - PROCESS ENERGY DEPENDANCE IN A, AI, V, VI.             
C     10/20/75 - ESQ PARAMETERS                                         
C     1/31/76 - NEW PWAVSW SETTING                                      
C     2/15/76 - ADD PWBGSW                                              
C     4/30/76 - MODIFIED COULOMB INPUT(MHM)                             
C     8/1/76 - 1/ELAB EXPANSION                                         
C     4/25/77 - IDENTICAL PARTICLES, FITSW                              
C     10/16/77 - POWERS OF WOODS-SAXONS                                 
C     11/20/77 - NEW ASYMPTOPIA; STORE POTENTIAL DEPTHS WITHOUT 1/E;    
C                NOLONGER USE A IN STEPSPER; PIECES OF WAVPOT HERE NOW. 
C     11/25/77 - LINKULES                                               
C     12/1/77 - LCRITL NOW CALLED HERE - S.P.                           
C     12/4/77 - SAVE LINKULE STUFF FOR DWBA IN LOCFIT - S.P.            
C     2/10/78 - LINKULES FOR WAVEFUNCTIONS - S.P.                       
C     5/5/78 - CENTRIFIGAL BARRIER IN AN ARRAY - S.P.                   
C     5/21/78 - NEW WAVELJ STRUCTURES - S.P.                            
C     12/11/78 - ADD TENSOR POTENTIALS - RPG                            
C     2/19/79 - REDUCE VARIABLE ASYMPTOPIA - RPG                        
C     3/18/79 - SAVE ALL OF /LNKBLK/ IN LNKAD2 - S.P.                   
C     5/4/79 - RATMAS CHANGES; DEFINE RC0P FOR PRINT - S.P.             
C     9/12/79 - STANDARD PREFIXES ETC; DELETE NUMJS DEFINITION          
C        (NOW IN WAVPOT) - RPG                                          
C     1/18/80 - DON'T CHANGE ASYMP & STEPSIZE FOR C.C. - S.P.           
C     4/23/80 - USE PWBGSW INSTEAD OF PBUGSW - S.P.                     
C     6/3/80 - SET LMIN=0 WHEN LCRITL=0, CHANGE PARPRT - S.P.           
C     7/16/80 - REMOVE LOGICAL SOSWT - S.P.                             
C     7/22/80 - FOR NEW CRAY VERSION USE 3*NPTS WORK ARRAYS -SP         
C     7/29/81 - SET LX=0 FOR DEFORMED POTENTIALAS -S.P.                 
C     10/18/81 - SET LX=-1 AS FLAG FOR DEFORMED POTS - 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),
     * MLLOC(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 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 /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
      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                
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      REAL*4 TBEGIN, TIMES                                              
      COMMON /FTIME/ TBEGIN, NUMLOP, NUMWAV, TIMES(6), NUMCAL, NUMGRA   
      COMMON /LOCFIT/ LNKAD2(6,2,12)                                    
C                                                                       
      LOGICAL ALONSW, FITSW                                             
      CHARACTER*8 CHANAM(2), STATWD(2), SOTNAM(2), NAMES(2,11)          
      CHARACTER*4 TENNAM(6)
      CHARACTER*1 LINKID(4)
C 
      DATA CHANAM / 'INCOMING', 'OUTGOING' /                            
      DATA STATWD / 'BOSONS', 'FERMIONS' /                              
      DATA SOTNAM / 'SPIN-ORB', 'TENSOR' /                              
      DATA TENNAM / 'TR', 'TRI', 'TL', 'TLI', 'TP', 'TPI' /             
      DATA NAMES /'REALVA','REALVB','IMAGVA', 'IMAGVB','REALVSOA',
     *'REALVSOB','IMAGVSOA', 'IMAGVSOB' , 'CENTRIFA', 'CENTRIFB' , 
     *'REALVTRA','REALVTRB','IMAGVTRA','IMAGVTRB','REALVTLA', 
     *'REALVTLB','IMAGVTLA','IMAGVTLB',  'REALVTPA', 'REALVTPB',  
     *'IMAGVTPA', 'IMAGVTPB' /
c      DATA (NAMES(1,ik),ik=1,11)/'REALVA','IMAGVA','REALVSOA',
c     *'IMAGVSOA','CENTRIFA','REALVTRA','IMAGVTRA','REALVTLA', 
c     *'IMAGVTLA','REALVTPA','IMAGVTPA'/
c      DATA (NAMES(2,ik),ik=1,11)/'REALVB','IMAGVB','REALVSOB',
c     *'IMAGVSOB','CENTRIFB','REALVTRB','IMAGVTRB','REALVTLB', 
c     *'IMAGVTLB','REALVTPB','IMAGVTPB'/
C                                                                       
      DATA LINKID / '*', '1', '0', '0' /                                
C                                                                       
      LOGICAL SOSW, SOISW, IMAGSW, TENSW                                
C                                                                       
      IPRNT = 0                                                         
      IF ( FITSW ) GO TO 10                                             
      NUMFIT = 0                                                        
      IOFFIT = 1                                                        
      IPRNT = MOD( IPRINT, 10 )                                         
 10   PWAVSW = MOD(IPRINT/1000, 10) .GE. 1                              
      PWBGSW = MOD(IPRINT/1000, 10) .GE. 4                              
C                                                                       
      STANSW = ALONSW                                                   
C                                                                       
C     SOME OF THE PARAMETERS CAN HAVE AN ENERGY DEPENDENCE WHICH        
C     IS EXPRESSED IN TERMS OF THE LABORATORY ENERGY                    
C                                                                       
      EELAB = (1+RATMAS)*E                                              
      EEMUL=EELAB                                                       
      IF(IEPOW.EQ.1) EEMUL=1/EELAB                                      
      TVR = V + VE*EEMUL + VESQ*EEMUL**2                                
      TVI = VI + VIE*EEMUL + VIESQ*EEMUL**2                             
      TAR = A + AE*EEMUL + AESQ*EEMUL**2                                
      TAI = AI + AIE*EEMUL + AIESQ*EEMUL**2                             
C                                                                       
C     IS THERE AN IMAGINARY PART FOR THE POTENTIAL                      
C                                                                       
      IMAGSW = TVI .NE. 0                                               
C                                                                       
C     IS THERE A SPIN-ORBIT POTENTIAL                                   
C                                                                       
      TVSOR = VSO + TAU*TVR                                             
      TVSOI = VSOI + TAUI*TVI                                           
      SOSW = TVSOR .NE. 0                                               
      SOISW = TVSOI .NE. 0                                              
      SOSWT = SOSW .OR. SOISW                                           
C                                                                       
C     IS THERE A TENSOR POTENTIAL?                                      
C                                                                       
      TCSWS(ICHANW) = VTR .NE. 0 .OR. VTRI .NE. 0 .OR. VTP .NE. 0 .OR. V
     *TPI .NE. 0                                                        
      TENSW = TCSWS(ICHANW) .OR. VTL .NE. 0 .OR. VTLI .NE. 0            
      SOSWS(ICHANW) = SOSWT .OR. TENSW                                  
C                                                                       
C     TEST THE INPUT AND RETURN  0  COMPLETION CODE IF BAD              
C                                                                       
      IRET = 1                                                          
      IF ( LNKADR(3,1) .NE. 0 ) GO TO 25                                
      IF ( R .GT. 0 .AND. TAR .GT. 0 ) GO TO 25                         
      WRITE(6,23) R, TAR                                                  
 23   FORMAT ('0**** R OR A HAS INVALID VALUE:', 2G15.5 )               
      IRET = 0                                                          
 25   IF ( .NOT. IMAGSW ) GO TO 30                                      
      IF ( LNKADR(3,2) .NE. 0 ) GO TO 30                                
      IF ( RI .GT. 0 .AND. TAI .GT. 0 ) GO TO 30                        
      WRITE(6,27) RI, TAI                                                 
 27   FORMAT ( '0**** RI OR AI HAS INVALID VALUE:', 2G15.5 )            
      IRET = 0                                                          
 30   IF ( .NOT. SOSW ) GO TO 34                                        
      IF ( LNKADR(3,3) .NE. 0 ) GO TO 34                                
      IF ( RSO .GT. 0 .AND. ASO .GT. 0 ) GO TO 34                       
      WRITE(6,31) RSO, ASO                                                
 31   FORMAT ( '0**** RSO OR ASO HAS INVALID VALUE:', 2G15.5 )          
      IRET = 0                                                          
C                                                                       
C     CHECK  SP  FOR EITHER REAL OR IMAG SPIN ORBIT.                    
C                                                                       
 34   IF ( JSP .NE. NOTDEF .OR. .NOT. SOSWS(ICHANW) ) GO TO 40          
      JSP = 1                                                           
      IF (TENSW) JSP = 2                                                
      WRITE(6,35) JSP, SOTNAM(JSP)                                        
 35   FORMAT ( '0**** WARNING:  SP WAS NOT DEFINED; ',  'IT IS ASSUMED T
     *O BE ', I1, '/2 FOR THE ', A8, ' FORCE.' )                        
 40   IF ( E .GT. 0 .AND. AM .GT. 0 )  GO TO 45                         
      WRITE(6,43) E, AM                                                   
 43   FORMAT ('0**** ENERGY OR M (REDUCED MASS) HAS INVALID',  ' VALUE:'
     *, 3G15.5 )                                                        
      IRET = 0                                                          
 45   IF ( AMP .NE. UNDEF .AND. AMT .NE. UNDEF ) GO TO 50               
      WRITE(6,47)
 47   FORMAT ( '0**** BOTH MP AND MT MUST BE DEFINED.' )                
      IRET = 0                                                          
 50   IF ( RC .LT. ASYMPT ) GO TO 60                                    
      WRITE(6,53) RC, ASYMPT                                              
 53   FORMAT ('0**** RC MUST BE LESS THAN ASYMPTOPIA:', 2G15.5 )        
      IRET = 0                                                          
 60   RCC = RC                                                          
      IF ( RC .EQ. UNDEF ) WASSET(9) = .TRUE.                           
      IF ( RC .EQ. UNDEF ) RCC = 1                                      
      IF ( IZP*IZT .EQ. 0 ) GO TO 70                                    
      IF ( RC .GT. 0 ) GO TO 70                                         
      WRITE(6,63) RC
 63   FORMAT ('0**** RC IS INVALID:', G15.5 )                           
      IRET = 0                                                          
  70  RC = RCC                                                          
      IF ( VSI .EQ. 0 ) GO TO 80                                        
      IF ( LNKADR(3,2) .NE. 0 ) GO TO 80                                
      IF ( RSI .GT. 0 .AND. ASI .GT. 0 ) GO TO 80                       
      WRITE(6,73) RSI, ASI                                                
 73   FORMAT ( '0**** RSI OR ASI IS INVALID:', 2G15.5 )                 
      IRET = 0                                                          
 80   IF ( .NOT. SOISW ) GO TO 90                                       
      IF ( LNKADR(3,4) .NE. 0 ) GO TO 90                                
      IF ( RSOI .GT. 0 .AND. ASOI .GT. 0 ) GO TO 90                     
      WRITE(6,83) RSOI, ASOI                                              
 83   FORMAT ( '0**** RSOI OR ASOI HAS INVALID VALUE:', 2G15.5 )        
C                                                                       
 90   IF ( .NOT. TENSW ) GO TO 100                                      
      IF (JSP .EQ. 2) GO TO 93                                          
      WRITE(6,91) JSP                                                     
 91   FORMAT ( '0**** SP MUST BE 1 FOR TENSOR POTENTIALS, SP =',  I8, '/
     *2' / ' **** TENSOR POTENTIALS ARE SET TO 0' )                     
      DO 92 I = 1, 6                                                    
      VTEN(I) = 0                                                       
 92   CONTINUE                                                          
      TENSW = .FALSE.                                                   
      TCSWS(ICHANW) = .FALSE.                                           
      SOSWS(ICHANW) = SOSWT                                             
 93   DO 95 I = 1, 6                                                    
      IF ( VTEN(I) .EQ. 0 ) GO TO 95                                    
      IF ( LNKADR(3,I+4) .NE. 0 ) GO TO 95                              
      IF ( RTEN(I) .GT. 0 .AND. ATEN(I) .GT. 0 ) GO TO 95               
      WRITE(6,94) TENNAM(I), TENNAM(I), RTEN(I), ATEN(I)                  
 94   FORMAT ( '0**** R', A3, ' OR A', A3, ' HAS INVALID VALUE:',  2G15.
     *5 )                                                               
      IRET = 0                                                          
 95   CONTINUE                                                          
 100  IF ( IRET .EQ. 0 ) RETURN                                         
C                                                                       
      NBAKCM = NBACK                                                    
C                                                                       
C  SOME DERIVED DATA                                                    
C                                                                       
C  K VALUE                                                              
C                                                                       
      UK=DSQRT(2*AM*E)/HBARC                                            
      ALAMBD = 2*PI/UK                                                  
C                                                                       
C  COULOMB PARAMETER AND SIMPLE TERMS USING IT                          
C     INITIALIZE THE COULOMB POTENTIAL                                  
C                                                                       
      ETA=(IZP*IZT)*DSQRT(AM/(2.D0*E))/AFINE
      CALL SETVSQ(RCT,RCP,IZT,IZP,ICHANW)     
C                                                                       
C     COUPLED CHANNELS REQUIRE THE SAME STEPSIZE IN ALL CHANNELS        
C                                                                       
      IF ( PROBLM .LT. 23 .OR. ICHANW .EQ. 1 ) GO TO 110                
      RMAX = ASYMPS(1)                                                  
      STEPSZ = RSTEPS(1)                                                
      GO TO 120                                                         
C                                                                       
 110  IF ( STPSPR .NE. UNDEF ) STEPSZ = DMIN1( ALAMBD, 1.D0 ) / STPSPR  
C                                                                       
      RMAX = ASYMPT                                                     
C                                                                       
C     ADJUST ASYMPTOPIA IF THERE WILL BE VERY LARGE L'S.                
C     MATCHING MUST BE AT OR OUTSIDE THE CLASSICAL TURNING POINT.       
C     HOWEVER, FITTER DOES NOT ALLOW VARIABLE ASYMPTOPIA RIGHT NOW      
C                                                                       
      IF ( NUMFIT .EQ. 0 .AND. LMAX .NE. NOTDEF ) RMAX = DMAX1( RMAX, ( 
     *ETA + DSQRT(ETA**2+LMAX*(LMAX+1)) )/UK )                          
C                                                                       
C     NOTE - NSTEP IS COMPUTED HERE SEPARATLY FOR EACH CHANNEL          
C     AND IS STORED IN /WAVCOM/.  IT NEED NOT BE RELATED TO THE         
C     "NSTEPS" USED IN THE BOUND STATE CALCULATION.  HOWEVER, IF        
C     ASYMPT AND STEPSZ  ARE THE SAME FOR THE ENTIRE JOB, THEN          
C        NSTEP = NSTEPS-1.                                              
C                                                                       
 120  NSTEP = RMAX/STEPSZ + .5                                          
      RMAX = NSTEP*STEPSZ                                               
      H=UK*STEPSZ                                                       
C                                                                       
C     TEST FOR IDENTICAL PARTICLES                                      
C                                                                       
      LSKIP = 1                                                         
      ISTAT = 3                                                         
      IF ( IZP .NE. IZT .OR. AMP .NE. AMT .OR. JSP .NE. JST .OR. EXSPT(1
     *) .NE. EXSPT(2) ) GO TO 150                                       
      IF ( JSP .NE. NOTDEF ) GO TO 135                                  
      WRITE(6,133)
 133  FORMAT ( '0*** WARNING:  THE PARTICLES APPEAR TO BE IDENTICAL',  '
     * BUT THEIR SPINS HAVE NOT BEEN DEFINED;' /  15X, 'NON-IDENTICAL PA
     *RTICLE SCATTERING WILL BE ASSUMED.' )                             
      GO TO 150                                                         
 135  IF ( JSP .EQ. 0 ) LSKIP = 2                                       
      ISTAT = IAND(JSP,1) + 1                                           
C                                                                       
C     SAVE THINGS FOR WAVPOT AND WAVELJ                                 
C                                                                       
 150  HS(ICHANW)=H                                                      
      V0RS(ICHANW) =TVR                                                 
      V0IS(ICHANW) =TVI                                                 
      V0SORS(ICHANW) = TVSOR                                            
      V0SOIS(ICHANW) = TVSOI                                            
      V0SIS(ICHANW) = VSI                                               
      RSCTS(ICHANW) = R                                                 
      ASCTS(ICHANW) = TAR                                               
      RCSCTS(ICHANW) = RC                                               
      RCSCTP(ICHANW) = RCP                                              
      RCSCTT(ICHANW) = RCT                                              
      RIS(ICHANW) = RI                                                  
      AIS(ICHANW) = TAI                                                 
      RSOS(ICHANW) = RSO                                                
      ASOS(ICHANW) = ASO                                                
      RSOIS(ICHANW) = RSOI                                              
      ASOIS(ICHANW) = ASOI                                              
      RSIS(ICHANW) = RSI                                                
      ASIS(ICHANW) = ASI                                                
      DO 159 I = 1, 6                                                   
      VTENS(ICHANW,I) = VTEN(I)                                         
      RTENS(ICHANW,I) = RTEN(I)                                         
      ATENS(ICHANW,I) = ATEN(I)                                         
 159  CONTINUE                                                          
      ETAS(ICHANW) = ETA                                                
      IZPS(ICHANW) = IZP                                                
      IZTS(ICHANW) = IZT                                                
      ASYMPS(ICHANW) = RMAX                                             
      ES(ICHANW) = E                                                    
      RSTEPS(ICHANW) = STEPSZ                                           
      NSTPSS(ICHANW) = NSTEP                                            
      NSTP2S(ICHANW) = NSTEP                                            
      AKS(ICHANW) = UK                                                  
      REDMS(ICHANW) = AM                                                
      RATMSS(ICHANW) = RATMAS                                           
      JSPS(ICHANW) = JSP                                                
      STEPR = STEP1R                                                    
      STEPI = STEP1I                                                    
      NUMAIT = NAITKN                                                   
      NUMLOP = 0                                                        
      NUMWAV = 0                                                        
      LSKIPS(ICHANW) = LSKIP                                            
      ISTATS(ICHANW) = ISTAT                                            
      POWRLS(ICHANW) = POWRL                                            
      POWIMS(ICHANW) = POWIM                                            
      IWAVRS(ICHANW) = 0                                                
      IWAVIS(ICHANW) = 0                                                
C                                                                       
C     QUANTITIES FOR INTEGRATION PAST ASYMPTOPIA                        
C                                                                       
      XFACS(1,ICHANW) = 1 + H**2/12                                     
      XFACS(2,ICHANW) = - (H**2/12) * IZP*IZT*HBARC/(E*AFINE)           
      XFACS(3,ICHANW) = - (H**2/12) / UK**2                             
      TIMES(1) = 0                                                      
      TIMES(2) = 0                                                      
      TIMES(3) = 0                                                      
C                                                                       
C     INITIALIZE LINKULES IF NEEDED                                     
C                                                                       
      DO 259 I = 1, NUMLNK                                              
      IF ( LNKADR(3,I) .EQ. 0 ) GO TO 259                               
C                                                                       
C     GENERATE THE SPECIAL UNIQUE NAME                                  
C                                                                       
      IUNIQU = IUNIQU + 1                                               
      ENCODE ( 4, 233, LINKID ) IUNIQU                                  
 233  FORMAT ( 1H*, I3 )                                                
C                                                                       
C     MAKE INITIALIZING CALL                                            
C     
      CALL LINKUL ( LNKADR(3,I), LNKNAM(1,I), LNKADR(5,I), I, 1,  IRET, 
     *L, J, 0.D0, STEPSZ, NSTEP+1, DUMMY, DUMMY, LINKID )               
      IF ( IRET .GE. 0 ) GO TO 240                                      
      IRET = 0                                                          
      RETURN                                                            
 240  LNKADR(4,I) = IRET                                                
 259  CONTINUE                                                          
C                                                                       
      IF ( IPRNT .LT. 1 ) GO TO 600                                     
C                                                                       
C     PRINT OUT INPUT NICELY                                            
C                                                                       
 420  WRITE(6,423) CHANAM(ICHANW)                                         
 423  FORMAT ( / X, T10, 'OPTICAL MODEL SCATTERING FOR THE ',  A8, ' C
     *HANNEL' )                                                         
      WRITE(6,424) EELAB, E, UK, ALAMBD, AMP, AMT, AM                     
 424  FORMAT ( ' E LAB =', F9.3, ' MEV,    E CM =', F9.3,  ' MEV,     K 
     *=', G12.5, 5X, 'WAVELENGTH =', F8.4, ' FM' /  ' PROJECTILE MASS ='
     *, F7.2, ' AMU,', 5X,  'TARGET MASS =', F7.2, ' AMU,', 5X,  'REDUCE
     *D MASS =', F10.2, ' MEV/C**2' )                                   
      IF ( ISTAT .EQ. 3 ) WRITE(6,425)
 425  FORMAT ( ' THIS IS NON-IDENTICAL PARTICLE SCATTERING')            
      IF ( ISTAT .NE. 3 ) WRITE(6,426) STATWD(ISTAT)                      
 426  FORMAT ( ' THIS IS SCATTERING OF IDENTICAL ', A8 )                
      IF ( JSP .NE. NOTDEF .AND. JST .NE. NOTDEF )  WRITE(6,427)JSP,JST 
 427  FORMAT ( ' PROJECTILE SPIN =', I3, '/2', 5X, 'TARGET SPIN =',  I3,
     * '/2' )                                                           
      WRITE(6,429) IZP, IZT                                               
 429  FORMAT (' Z PROJECTILE =',I4, 5X,'Z TARGET =', I4 /' POTENTIAL', 
     *T20, 'COUPLING CONS.', T38, 'RADIUS',  T48, 'DIFFUSENESS', T63, 
     *'RADIUS PARAMETER' )                                            
C                                                                       
      IRET = 1                                                          
      CALL PARPRT ( 1, 'REAL CENTRAL       ', TVR, R, TAR,  R/R0MASS, PO
     *WRL, '   POWER', IRET )                                           
      CALL PARPRT ( 2, 'VOLUME ABSORPTION   ', TVI, RI, TAI,  RI/R0MASS,
     * POWIM, '   POWER   ', IRET )                                     
      CALL PARPRT ( 0, 'SURFACE ABSORPTION   ', VSI, RSI, ASI,  RSI/R0MA
     *SS, 0.D0, '        ', IRET )                                      
      CALL PARPRT ( 3, 'REAL SPIN-ORBIT   ', VSO, RSO, ASO,  RSO/R0MASS,
     * TAU, '     TAU', IRET )                                          
      CALL PARPRT ( 4, 'IMAG. SPIN-ORBIT   ', VSOI, RSOI, ASOI,  RSOI/R0
     *MASS, TAUI, '    TAUI', IRET )                                    
      CALL PARPRT ( 7, 'REAL TR      ', VTR, RTR, ATR,  RTR/R0MASS, 0.0D
     *0, '        ', IRET )                                             
      CALL PARPRT ( 8, 'IMAGINARY TR    ', VTRI, RTRI, ATRI,  RTRI/R0MAS
     *S, 0.0D0, '        ', IRET )                                      
      CALL PARPRT ( 9, 'REAL TL        ', VTL, RTL, ATL,  RTL/R0MASS, 0.
     *0D0, '        ', IRET )                                           
      CALL PARPRT ( 10, 'IMAG. TL        ', VTLI, RTLI, ATLI,  RTLI/R0MA
     *SS, 0.0D0, '        ', IRET )                                     
      CALL PARPRT ( 11, 'REAL TPR        ', VTP, RTP, ATP,  RTP/R0MASS, 
     *0.0D0, '        ', IRET )                                         
      CALL PARPRT ( 12, 'IMAG. TPR        ', VTPI, RTPI, ATPI,  RTPI/R0M
     *ASS, 0.0D0, '        ', IRET )                                    
      CALL PARPRT ( 5, 'PT&SPHERE  COULOMB', ETA, RC, 0.D0,  RC/R0MASS, 
     *0.0D0, '        ', IRET )                                         
      IF((RCP.EQ.0).OR.(RCT.EQ.0)) GO TO 500                            
      TEMP2 = RCP/AMP**0.33333333333333333333333 0D0                    
      TEMP3 = RCT/AMT**0.33333333333333333333333 0D0                    
      WRITE(6,187) RCP, RCT, TEMP2, TEMP3                                 
  187 FORMAT( ' FOLDED COULOMB POTENTIALS - RCP = ',F7.4,2X, 'RCT = ',F7
     *.4,2X,'RC0P = ',F7.4,2X,'RC0T = ',F7.4)                           
C                                                                       
 500  TEMP = DMIN1( ALAMBD, 1.D0 )/STEPSZ                               
      WRITE(6,503) RMAX, STEPSZ, TEMP                                     
  503 FORMAT(  ' ASYMPTOPIA =', T15, F8.3, ' FM' /  ' STEP SIZE =', T15,
     * F8.3, ' FM' ,  5X, F8.3, ' STEPS PER "WAVELENGTH"' / )           
C                                                                       
C     WILL THE WAVE FUNCTIONS BE FOUND BY A LINKULE                     
C                                                                       
      IF ( LNKADR(3,6) .EQ. 0 ) GO TO 600                               
      WRITE(6,533) LNKNAM(1,6)                                            
 533  FORMAT ( '  THE SCATTERING WAVEFUNCTION IS BEING',  ' COMPUTED BY 
     *THE ', A8, ' LINKULE:' )                                          
      I = 6                                                             
C                                                                       
C     CALL LINKULE TO PRINT STUFF ABOUT ITSELF                          
C                                                                       
 560  CALL LINKUL ( LNKADR(3,I), LNKNAM(1,I), LNKADR(5,I),  I, 2, IRTN, 
     * L, J, 0.D0, STEPSZ, NSTEP+1, DUMMY, DUMMY, ICHANW )              
      WRITE(6,563)
 563  FORMAT ( ' ' )                                                    
      IRET = MIN0(IRTN, IRET)                                           
      IF ( IRET .GE. 0 ) GO TO 600                                      
 570  IRET = 0                                                          
      RETURN                                                            
C                                                                       
C     SET ASIDE AREAS FOR THE POTENTIAL AND FOR V' USED BY WAVELJ       
C     THESE ARE STORED ONLY TO ASYMPTOPIA                               
C                                                                       
C     THIS IS DONE AS FOLLOWS:                                          
C                                                                       
C     1) FOR STAND-ALONE:  ON EVERY CALL TO WAVSET.                     
C     2) FOR ELASTIC FITS: MAXIMUM NUMBER OF STEPS IS ACCUMULATED IN    
C        NSTPSS(2); AS THE SIZE GROWS, THEY ARE ALLOCATED.              
C     3) FOR DWBA: POTENTIAL AREAS ARE ALLOCATED AT BOTH CALLS;         
C        WAVEFUNCTION AREAS ARE ALLOCATED ONLY ON 2ND CALL.             
C                                                                       
 600  NSTPP1 = NSTEP+1                                                  
C                                                                       
      IF ( NUMFIT .EQ. 0 ) GO TO 650                                    
      IF ( NSTPSS(2) .GE. NSTEP ) GO TO 680                             
      NSTPSS(2) = NSTEP                                                 
C                                                                       
 650  IVWORK = NALLOC( NSTPP1, 'VWORK' )                               
c      print 1919, nstpp1, names(ichanw,1)
c1919  format (x,I5,3x,A8)
      IRLVS(ICHANW) = NALLOC( NSTPP1, NAMES(ICHANW, 1) )                
      IIMVS(ICHANW) = NALLOC( NSTPP1+1, NAMES(ICHANW, 2) )              
      ICENTR(ICHANW) = NALLOC( NSTPP1, NAMES(ICHANW, 5) )               
      ISORS(ICHANW) = 0                                                 
      ISOIS(ICHANW) = 0                                                 
      IF ( V0SORS(ICHANW) .NE. 0 )  ISORS(ICHANW) = NALLOC( NSTPP1, NAME
     *S(ICHANW, 3) )                                                    
      IF ( V0SOIS(ICHANW) .NE. 0 )  ISOIS(ICHANW) = NALLOC( NSTPP1, NAME
     *S(ICHANW, 4) )                                                    
      DO 659 II = 1, 6                                                  
      ITENS(ICHANW,II) = 0                                              
      IF ( VTENS(ICHANW,II) .NE. 0 ) ITENS(ICHANW,II) =  NALLOC ( NSTPP1
     *, NAMES(ICHANW,II+5) )                                            
 659  CONTINUE                                                          
C                                                                       
C     AND COMPUTE THE POTENTIAL                                         
C     LX IS SET TO 0 FOR POSSIBLE USE BY DEFORMED POTENTIALS            
C                                                                       
 680  LXSAVE = LX                                                       
      LX = -1                                                           
      CALL MAKPOT ( ICHANW, IRET )                                      
      LX = LXSAVE                                                       
C                                                                       
C     FOR DWBA MUST SAVE TWO SETS OF LINKULE INDICATORS                 
C                                                                       
      IF ( NUMFIT .NE. 0 ) GO TO 690                                    
      DO 685 I = 1, NUMLNK                                              
      DO 685 II = 1, 6                                                  
      LNKAD2(II,ICHANW,I) = LNKADR(II,I)                                
 685  CONTINUE                                                          
C                                                                       
C     WORK AREA NOT NEEDED AFTER MAKPOT                                 
C                                                                       
 690  IF ( NUMFIT .EQ. 0 ) Z(IVWORK) = -Z(IVWORK)                       
C                                                                       
      IF ( IRET .GE. 0 ) GO TO 700                                      
      IRET = 0                                                          
      RETURN                                                            
C                                                                       
C     DETERMINE LCRITICAL.                                              
C     IF BOTH LMIN AND LMAX ARE DEFINED WE BYPASS THIS AND JUST USE     
C     THE AVERAGE.                                                      
C                                                                       
 700  IF ( LMIN .EQ. NOTDEF .OR. LMAX .EQ. NOTDEF ) GO TO 720           
      LCRITS(ICHANW) = (LMIN+LMAX)/2                                    
      GO TO 750                                                         
 720  CALL LCRITL ( E, UK, ETA, RC, NSTEP+1,  0.D0, STEPSZ, IRLVS(ICHANW
     *), IIMVS(ICHANW),  48, MOD(IPRINT/10, 10),  LC1, LC2, LCRITS(ICHAN
     *W) )                                                              
      IF ( IPRNT .NE. 0 ) WRITE(6,723) LCRITS(ICHANW), LC1, LC2           
 723  FORMAT ( ' ESTIMATED CRITICAL L:', I4 ,  5X, 'BY !S!:', I4, 5X, 'B
     *Y DEFLECTION FUNC.:', I4 )                                        
C                                                                       
C     IF LC1=0  THEN !S!=1 ALWAYS AND WE MUST FORCE LMIN=0.             
C                                                                       
      IF ( LC1 .EQ. 0 .AND. LMIN .EQ. NOTDEF ) LMIN = 0                 
C                                                                       
C     ON 2ND CALL ALLOCATE AREAS FOR THE WAVE FUNCTIONS USING LARGEST   
C     NSTEP.                                                            
C                                                                       
 750  IF ( .NOT. STANSW .AND. ICHANW .EQ. 1 ) GO TO 800                 
      IF ( .NOT. STANSW ) NSTPP1 = MAX0(NSTPSS(1)+1, NSTPP1)            
      I = NSTPP1+6                                                      
      NWAVEF = I                                                        
CCRA                                                                    
CCRA     ON CRAY WE DO SOME OF THE WORK IN VECTOR WORK ARRAYS           
CCRA                                                                    
CRA      I = 3*I                                                        
C     WE NEED ROOM FOR 4 WAVE FUNCTIONS IF TENSOR COUPLING IS PRESENT.  
      IF ( TCSWS(ICHANW) .OR. ( TCSWS(3-ICHANW) .AND. .NOT. STANSW ) )  
     *I = 4*I                                                           
      IWAVR = NALLOC( I, 'WAVER ' )                                     
      IWAVI = NALLOC( I, 'WAVEI ' )                                     
C                                                                       
 800  IRET = 1                                                          
      RETURN                                                            
      END                                                               
