      SUBROUTINE MAKDER ( NSTEPS, NUMVS, MXVSIN, MPARA,  PARAM, DERSTP, 
     *VDERIV, ITYPE, VR, VI, DELVR, DELVI )                             
C                                                                       
C     COMPUTES DERIVATIVES OF V AS A FUNCTION OF R.                     
C                                                                       
C     *************************************************************     
C     *   WILL NEED CHANGES FOR SPIN-ORBIT FORCE                  *     
C     *************************************************************     
C                                                                       
C     STORES THE QUANTITIES                                             
C                                                                       
C     VDERIV(K,N) = (8) / (STEPSZ ) W(N) D(V(R(N)))/D(X(K))             
C                                                                       
C     FOR                                                               
C        N = 1, ..., NSTEPS                                             
C        K = 1, NUMVS                                                   
C                                                                       
C     ONLY THE NON-ZERO REAL AND IMAGINARY PARTS OF THE DERIVATIVE      
C     ARE STORED.  PARAMETERS THAT RESULT IN A COMPLETELY COMPLEX       
C     DERIVATIVE GET TWO ADJACENT K'S.                                  
C                                                                       
C     PARAM - THE PARAMETER VECTOR (X) FORWHICH DV/DX IS DESIRED.       
C     VR & VI - THE POTENTIAL EVALUATED AT X.                           
C     DELVR & DELVI - WORK ARRAYS                                       
C                                                                       
C     10/29/75 - FIRST VERSION - S.P.                                   
C     3/10/76 - LIMIT RANGE OF DERIVATIVES USED                         
C     4/21/77 - RENORM AND LABSHIFT CAN BE FIT                          
C     11/20/77 - NEW SETFIT CALL - S.P.                                 
C     2/14/78 - NUMERICAL DERIVATIVES                                   
C     5/31/78 - DO NOT TRIM OFF DERIVATIVES SO MUCH - S.P.              
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL PARAM,VDERIV,ITYPE,VR,VI,DELVR,DELVI                
C                                                                       
      DIMENSION PARAM(MPARA), VDERIV(MXVSIN, NSTEPS), ITYPE(MPARA),
     *VR(NSTEPS), VI(NSTEPS), DELVR(NSTEPS), DELVI(NSTEPS)                 
C                                                                       
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      COMMON /LOCFIT/ IDATA, LPL, LSIGMA, LSMAT, IESETS, IMASK, IEQUAL, 
     *NPARA, IPARA, ITEMP, LSCSIG, LEPARM, LFS, NPTS, LEQNAM, MAXEQL, MA
     *XVS, LVDERV, LSDELS, LDVTYP, LDSDP, LDFDX, LFGRAD, LTGRAD, LMASK, 
     *LEQUAL, MNDRIV, MXDRIV, IESIZE, LENPRE, LENKEY, LENHED, ILNKBL    
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
      COMMON /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
C                                                                       
C     FOOL MAKPOT INTO STORING INTO DELVR, DELVI                        
C                                                                       
      IRLVS(2) = IRLVS(1)                                               
      IRLVS(1) = IWAVR                                                  
      IIMVS(2) = IIMVS(1)                                               
      IIMVS(1) = IWAVI                                                  
C                                                                       
C     LOOP OVER THE PARAMETERS.  FOR EACH ONE, PERTURB IT AND           
C     RECALCULATE V.  DERIVATIVES ARE THEN FOUND BY DIFFERENCES.        
C                                                                       
      MNDRIV = NSTEPS                                                   
      MXDRIV = 0                                                        
      K = 1                                                             
      DO 489 I = 1, MPARA                                               
      KEY = ITYPE(I)                                                    
      IF ( KEY .EQ. 0 .OR. KEY .GE. 4 ) GO TO 489                       
      PSAVE = PARAM(I)                                                  
      STEP = DERSTP*PSAVE                                               
      IF ( PSAVE .EQ. 0 ) STEP = DERSTP                                 
      PARAM(I) = PSAVE + STEP                                           
      CALL SETFIT ( PARAM, IRET, 1 )                                    
      FAC = 8 / ( HS(1) * STEP )                                        
C                                                                       
C     WE USE SIMPSONS WEIGHTS BUT DO NOT BOTHER ABOUT MAKING THE        
C     FIRST AND LAST POINT CORRECT SINCE THEY DON'T MATTER (            
C     (EITHER U(0) = 0  OR  D(V(RMAX)) = 0).                            
C                                                                       
      WT = 2                                                            
      IGO = KEY - 2                                                     
      DRIVMX = 0                                                        
      DO 389 N = 2, NSTEPS                                              
      IF ( IGO ) 320, 330, 340                                          
 320  VDERIV(K,N) = WT*FAC*( DELVR(N)-VR(N) )                           
      GO TO 380                                                         
 330  VDERIV(K,N) = WT*FAC*( DELVI(N)-VI(N) )                           
      GO TO 380                                                         
 340  VDERIV(K,N) = WT*FAC*( DELVR(N)-VR(N) )                           
      VDERIV(K+1,N) = WT*FAC*( DELVI(N)-VI(N) )                         
C                                                                       
 380  WT = 6 - WT                                                       
      DRIVMX = DMAX1( DABS(VDERIV(K,N)), DRIVMX )                       
 389  CONTINUE                                                          
C                                                                       
C     NOW LIMIT THE DERIVATIVES TO THOSE THAT EXCEED                    
C     DERSTP TIMES THE MAXIMUM ONE OR JUST DERSTP.                      
C                                                                       
      TESTMN = DMIN1( DERSTP*DRIVMX, DERSTP )                           
      DO 459 N = 2, NSTEPS                                              
      TEST = DABS(VDERIV(K,N))                                          
      IF ( IGO .GT. 0 ) TEST = DMAX1( TEST, DABS(VDERIV(K+1,N)) )       
      IF ( TEST .GT. TESTMN ) GO TO 450                                 
      VDERIV(K,N) = 0                                                   
      IF ( IGO .GT. 0 ) VDERIV(K+1,N) = 0                               
      GO TO 459                                                         
 450  MNDRIV = MIN0( MNDRIV, N )                                        
      MXDRIV = MAX0( MXDRIV, N )                                        
 459  CONTINUE                                                          
C                                                                       
C     GO TO NEXT K                                                      
C                                                                       
      K = K+1                                                           
      IF ( IGO .GT. 0 ) K = K+1                                         
C                                                                       
      PARAM(I) = PSAVE                                                  
 489  CONTINUE                                                          
C                                                                       
C     THE PARAMETER VECTOR IS NOW BACK TO ITS ORIGINAL STATUS.          
C     RESTORE THE COMMON BLOCKS                                         
C                                                                       
      IRLVS(1) = IRLVS(2)                                               
      IIMVS(1) = IIMVS(2)                                               
      CALL SETFIT ( PARAM, IRET, 0 )                                    
C                                                                       
      NUMVS = K - 1                                                     
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE MAKPOT ( NWPIN, IRET )                                 
C                                                                       
C     COMPUTES THE POTENTIALS FOR WAVELJ                                
C                                                                       
C     WAVSET MUST BE CALLED FIRST TO INITIALIZE THINGS.                 
C                                                                       
C     THIS ROUTINE SETS UP THE REAL AND IMAGINARY "POTENTIAL"           
C     ARRAYS IN THE FORM REQUIRED BY WAVELJ:                            
C                                                                       
C       V' = 1 - (H**2/12) * (V/E - 1)                                  
C                                                                       
C     THE S.O. TERMS ARE STORED SEPARATELY AS                           
C                                                                       
C       VSO' = (H**2/12) * VSO/(E*S.L)                                  
C     WHERE                                                             
C       S.L IS  S DOT L                                                 
C                                                                       
C     10/7/75 - MADE FROM WAVELJ - S.P.                                 
C     10/27/75 - AVOID UNDERFLOWS FOR LARGE  R/A                        
C     1/28/77 - DO NOT STORE VERY SMALL POTENTIALS                      
C     2/3/77 - RESTART FLAG FOR WAVELJ                                  
C     3/18/77 - FIX S.O. BUG INTRODUCED IN ABOVE CHANGE.                
C     10/16/77 - POWERS OF WOODS-SAXONS                                 
C     11/21/77 - MAJOR REWRITE TO USE WOODSX SUBROUTINE - S.P.          
C     11/25/77 - LINKULES                                               
C     11/29/77 - ADD RETURN CODE                                        
C     5/5/78 - CENTRIFIGAL TERM IN ALLOCATOR - S.P.                     
C     6/24/78 - USE LOCAL VARIABLE IN VCSQ12 CALL FOR CDC LCM VERSION   
C     12/12/78 - ADD TENSOR POTENTIALS - RPG                            
C     3/1/79 - INITIALIZE LASTZR, NOW IN /WAVCOM/ - RPG                 
C     5/2/80 MODIFY V' FOR COUPLED CHANNELS . STORE AS                  
C            1-H**2/12*V/E FOR EXCITED CHANNELS MRB                     
C     12/9/80 - IF NWPIN=3; NO COULOMB FORCE - S.P.                     
C     7/16/81 - FOR NWPIN=3 ALSO COMPUTE -V, NOT 1-V - S.P.             
C     5/17/82 - INCLUDE VSI WHEN LINKULE COMPUTES VI - 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 )                                                   
      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                
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
C     ITYPE HAS SHAPE CODES FOR TENSOR POTENTIALS (SEE WOODSX).         
      INTEGERITYPS(6)                                                   
      DATAITYPS/4, 5, 2, 2, 1, 3/                                       
      DATA IDUMMY, DUMMY / 0, 0. /                                      
C                                                                       
C     SETUP THE PARAMETERS FOR THIS CHANNEL                             
C                                                                       
      NWP = NWPIN                                                       
      IF ( NWPIN .EQ. 3 ) NWP = 1                                       
      IRET = 0                                                          
      STEPSZ = RSTEPS(NWP)                                              
      EINV=1/E                                                          
      H = HS(NWP)                                                       
      H2 = H**2                                                         
      NSTEPP = NSTPSS(NWP) + 1                                          
      LREALV = Z(IRLVS(NWP)) - 1                                        
      LIMAGV = Z(IIMVS(NWP)) - 1                                        
      LCENTR = Z(ICENTR(NWP)) - 1                                       
      LVWORK = Z(IVWORK) - 1                                            
C                                                                       
      RVAL = -STEPSZ                                                    
C                                                                       
C     INDICATE THAT WAVELJ MUST REESTABLISH ITS STARTING POINT          
C                                                                       
      LASTL(NWP) = 999999                                               
      LASTZR = 1                                                        
C                                                                       
C     GET THE COULOMB POTENTIAL                                         
C                                                                       
      I = 5                                                             
      LL = LREALV+1                                                     
      IF ( LNKADR(3,5) .GT. 0 .AND. NWPIN .NE. 3 ) GO TO 800            
      X = 0                                                             
      DO 249 I = 1, NSTEPP                                              
C                                                                       
C     IN THIS LOOP WE HAVE                                              
C        R = STEPSZ * (I-1)                                             
C     WHICH IS H GREATER THAN IN WAVELJ.                                
C                                                                       
      RVAL = RVAL + STEPSZ                                              
C                                                                       
C     WE USE X BELOW TO HAVE AN SCM VARIABLE IN THE CDC LCM VERSION.    
C                                                                       
      IF ( NWPIN .NE. 3 )  CALL VCSQ12 ( RVAL, X, NWP, IDUMMY, IDUMMY ) 
      ALLOC(LREALV+I) = X                                               
 249  CONTINUE                                                          
C                                                                       
C     GET THE REAL POTENTIAL                                            
C                                                                       
 300  I = 1                                                             
      LL = LVWORK+1                                                     
      IF ( LNKADR(3,1) .NE. 0 ) GO TO 800                               
C                                                                       
      CALL WOODSX ( NSTEPP, 0.D0, STEPSZ, ALLOC(LVWORK+1), N1, N2,  1, T
     *VR, R, TAR, POWRL )                                               
C                                                                       
C     STORE COULOMB + REAL POTENTIAL                                    
C                                                                       
 400  RHO = 1.D-16                                                      
C     MODIFY FOR COUPLED CHANNELS                                       
      AJ=1.0D0                                                          
      IF ( PROBLM .EQ. 24 .OR. NWPIN .EQ. 3 ) AJ = 0.                   
      TEMP = 1                                                          
      IF ( NWPIN .EQ. 3 ) TEMP = 0                                      
      DO 489 I = 1, NSTEPP                                              
      AK1 = EINV * (ALLOC(LREALV+I)+ALLOC(LVWORK+I)) - AJ               
      ALLOC(LREALV+I) = TEMP - AK1*(H2/12)                              
      ALLOC(LCENTR+I) = -(H2/12)/RHO**2                                 
      RHO = RHO + H                                                     
 489  CONTINUE                                                          
C                                                                       
C     NOW GENERATE THE REST OF THE POTENTIALS                           
C                                                                       
C     IMAG POTENTIAL IS SUM OF VI AND VSI                               
C                                                                       
      I = 2                                                             
      IF ( LNKADR(3,2) .NE. 0 ) GO TO 800                               
      CALL WOODSX ( NSTEPP, 0.D0, STEPSZ, ALLOC(LVWORK+1), N1, N2,  1, T
     *VI, RI, TAI, POWIM )                                              
 510  DO 529 I = 1, NSTEPP                                              
      ALLOC(I+LIMAGV) = -(H2/(12*E)) * ALLOC(I+LVWORK)                  
 529  CONTINUE                                                          
C                                                                       
      IF ( VSI .EQ. 0 ) GO TO 600                                       
      CALL WOODSX ( NSTEPP, 0.D0, STEPSZ, ALLOC(LVWORK+1), N1, N2,  3, V
     *SI, RSI, ASI, 1.D0 )                                              
      DO 549 I = N1, N2                                                 
      ALLOC(I+LIMAGV) = ALLOC(I+LIMAGV) - (H2/(12*E))*ALLOC(I+LVWORK)   
 549  CONTINUE                                                          
C                                                                       
C     NOW POSSIBLE S.O. FORCES                                          
C                                                                       
 600  IF ( ISORS(NWP) .EQ. 0 ) GO TO 650                                
      LSOR = Z(ISORS(NWP))-1                                            
      I = 3                                                             
      IF ( LNKADR(3,3) .NE. 0 ) GO TO 800                               
      CALL WOODSX ( NSTEPP, 0.D0, STEPSZ, ALLOC(LVWORK+1), N1, N2,  2, V
     *SO, RSO, ASO, 1.D0 )                                              
 610  DO 629 I = 1, NSTEPP                                              
      ALLOC(LSOR+I) = (-H2/(12*E))*ALLOC(LVWORK+I)                      
 629  CONTINUE                                                          
C                                                                       
 650  IF ( ISOIS(NWP) .EQ. 0 ) GO TO 700                                
      LSOI = Z(ISOIS(NWP))-1                                            
      I = 4                                                             
      IF ( LNKADR(3,4) .NE. 0 ) GO TO 800                               
      CALL WOODSX ( NSTEPP, 0.D0, STEPSZ, ALLOC(LVWORK+1), N1, N2,  2, V
     *SOI, RSOI, ASOI, 1.D0 )                                           
 660  DO 679 I = 1, NSTEPP                                              
      ALLOC(LSOI+I) = (-H2/(12*E))*ALLOC(LVWORK+I)                      
 679  CONTINUE                                                          
C                                                                       
C     NOW POSSIBLE TENSOR FORCES.                                       
C                                                                       
 700  DO 749 II = 1, 6                                                  
      IF ( ITENS(NWP,II) .EQ. 0 ) GO TO 749                             
      LTEN = Z(ITENS(NWP,II)) - 1                                       
      I = II + 6                                                        
      IF ( LNKADR(3,I) .NE. 0 ) GO TO 800                               
      CALL WOODSX ( NSTEPP, 0.D0, STEPSZ, ALLOC(LVWORK+1),  N1, N2, ITYP
     *S(II), VTEN(II), RTEN(II), ATEN(II), 1.D0 )                       
 710  DO 729 I = 1, NSTEPP                                              
      ALLOC(LTEN+I) = (-H2/(12*E))*ALLOC(LVWORK+I)                      
 729  CONTINUE                                                          
C        DIVIDE TPD POTENTIALS BY R**2                                  
      IF ( II .LT. 5 ) GO TO 749                                        
      RVAL = 1.D-30                                                     
      DO 739 I = 1, NSTEPP                                              
      ALLOC(LTEN+I) = ALLOC(LTEN+I) / (RVAL*RVAL)                       
      RVAL = RVAL + STEPSZ                                              
 739  CONTINUE                                                          
 749  CONTINUE                                                          
      RETURN                                                            
C                                                                       
C     GET THE POTENTIAL FROM A LINKULE                                  
C                                                                       
 800  CALL LINKUL ( LNKADR(3,I), LNKNAM(1,I), LNKADR(5,I),  I, 3, IRET, 
     *IDUMMY, IDUMMY,  0.D0, STEPSZ, NSTEPP, ALLOC(LL), DUMMY, 0 )      
C                                                                       
      IF ( IRET .LT. 0 ) GO TO 900                                      
      GO TO ( 400, 510, 610, 660, 300, 710, 710, 710, 710, 710, 710,  71
     *0 ), I                                                            
C                                                                       
 900  RETURN                                                            
      END                                                               
      SUBROUTINE MEBDEF ( IORD, I12, IBN, XNS, IBC, XCS,  MEORD, LXX2, L
     *XX2S, IZ, RNUC, RC, DELTAE,  J2, J1, K2, K1, RMENUC, RMECOU, IRTN,
     * IPT )                                                            
C                                                                       
C     DEFORMED ROTATIONAL REDUCED MATRIX ELEMENT TO AND FROM BETA       
C                                                                       
C     THIS SUBROUTINE CONTAINS THE MODEL DEPENDANT PARTS OF             
C     BEBETA FOR THE FULL DEFORMED ROTATIONAL MODEL.                    
C                                                                       
C     IT ALLOWS  K2=K1  OR  K2=0  OR  K1=0, HOWEVER FOR                 
C     K2=K1^=0, THE K --> -K TRANSISITION IS IGNORED.                   
C                                                                       
C     IF A BETA NUCLEAR IS SUPPLIED AND A CORRESPONDING DEFORMATION     
C     IS DEFINED IN THE BETAS ARRAY, THE NUCLEAR RME IS SCALED BY       
C     THE RATIO BETA(INPUT)/BETA(DEFORMATION).  THIS IS ALSO DONE       
C     IF BETA NUCLEAR IS FOUND FROM BETA COULOMB.  IF THERE IS NO       
C     CORRESPONDING BETA IN THE BETA ARRAY, THE SUPPLED BETA IS IGNORED 
C     UNLESS IT IS ZERO.                                                
C                                                                       
C     IORD - THE ORDER OF THE RME TO PRODUCE.  IT MUST BE 1.            
C     I12 - ELEMENT OF XNS AND XCS ARRAYS TO USE.                       
C     IBN - TYPE OF INPUT IN XNS:                                       
C           1 = BETA                                                    
C           2 = <!!ALPHA!!>                                             
C           -99 = UNKNOWN, TO BE FOUND FROM COULOMB RESULT BY           
C                 EQUAL DEFORMATION LENGTHS.                            
C     XNS - THE INPUT NUCLEAR QUANTITY.  FOR ALL 1ST ORDER AND          
C           2ND ORDER ALPHAS, THERE IS ONLY XNS(I12).  FOR 2ND ORDER    
C           BETAS THERE IS BOTH XNS(1) AND XNS(2).                      
C           FOR 1ST ORDER IT IS CONVERTED TO BETA.                      
C     IBC - TYPE OF INPUT IN XCS:                                       
C        1 - INPUT IS BETA                                              
C        2 - INPUT IS <J2,K2!!ALPHA!!J1,K1>                             
C        3 - INPUT IS <J2,K2!!E(LX)!!J1,K1>  IN  E BARN**LX/2           
C        4 - INPUT IS <LX,0!!E(LX)!!0,0>   IN  E BARN**LX/2             
C       -99 - NOT DEFINED, HAPPENS ONLY IF IBN=IBC=-99                  
C     XCS - THE INPUT COULOMB QUANTITIES; SEE XNS.                      
C     MEORD - IGNORED                                                   
C                ELEMENT OF E(LX) AND BETA.                             
C             =1 MEANS USE SECOND ORDER RELATION.                       
C     LXX2 - 2*MULTIPOLE                                                
C     LXX2S - IGNORED                                                   
C     IZ - (INTEGER)  THE ATOMIC NUMBER.                                
C     RNUC - THE NUCLEAR RADIUS                                         
C     RC - COULOMB RADIUS OF THE NUCLEUS                                
C     DELTAE - DIFFERENCE IN ENERGY OF THE TWO STATES (>0)              
C     J2 - 2*SPIN OF THE HIGHER STATE.                                  
C     J1 - 2*SPIN OF THE LOWER STATE                                    
C     K2, K1 - 2*(K-QUANTUM NUMBERS)                                    
C     RMENUC - SET TO <!!ALPHA!!>                                       
C     RMECOU - IS SET TO THE COMPUTED R.M.E.                            
C              <J2,K2!!R.M.E.!!J1,K1>   IN E BARN**LX/2                 
C     IRTN - SET TO 0 IF ALL O.K., 1 IF NOT                             
C     IPT = 1 FOR PROJECTILE, 2 FOR TARGET                              
C                                                                       
C     8/28/81 - MEBDEF BASED ON MEBROT - S.P.                           
C     9/22/81 - FIX ERROR FOR UNDEFINED BETAN - S.P.                    
C     10/19/81 - LOOK FOR BETAP OR BETAT - S.P.                         
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      DIMENSION XCS(2), XNS(2), LXX2S(2)                                
      DIMENSION CLEBS(20)                                               
      CHARACTER*8 BETNAM(2)                                             
      DATA BETNAM/'BETAP', 'BETAT'/                                     
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 /LENGTH/ LENG(1)                                           
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
C                                                                       
      IRTN = 0                                                          
C                                                                       
C     CANNOT PROCEED IF IORD ^= 1                                       
C                                                                       
      IF ( IORD .NE. 1 ) GO TO 900                                      
C                                                                       
      LX = LXX2/2                                                       
      TJ1P1 = J1+1                                                      
C                                                                       
C     COEFFICENTS FOR RME TO BETA.  THESE ARE BASED ON THE ROTATIONAL   
C     MODEL                                                             
C     AME1 CONVERTS < !!ALPHA(COULOMB)!! >  TO < !!E(LX)!! >  IN        
C     SHARP CUTOFF MODEL.                                               
C                                                                       
      AME1 = 3*IZ*(RC/10)**LX / (4*PI)                                  
C                                                                       
C     AME2 CONVERTS BETA(EFFECTIVE) TO < !!ALPHA(COULOMB)!! >           
C                                                                       
      AME2 = CLEBSH( J1, LXX2, K1, K2-K1, J2, K2 ) * DSQRT(TJ1P1)       
      IF ( K1 .EQ. K2 ) GO TO 50                                        
      IF ( K2 .NE. 0 .AND. K1 .NE. 0 ) GO TO 920                        
      AME2 = DSQRT(2.D0)*AME2                                           
 50   IF ( AME2 .EQ. 0 ) GO TO 900                                      
      AMEUSE = AME1*AME2                                                
      AME2X = AME2                                                      
C                                                                       
      IF ( IBC .EQ. -99 ) GO TO 190                                     
C                                                                       
C     GET THE POWER SERIES COEFS THAT RELATE BETA TO BETA(EFFECTIVE)    
C     FOR THE LONG-RANGE PART OF THE COULOMB INTERACTION                
C                                                                       
C     BETA(EFFECTIVE) = BETA + X2*BETA**2 + X3*BETA**3                  
C                                                                       
      IZERO = 0                                                         
      X3 = 0                                                            
C                                                                       
C     IN THE FOLLOWING LOOP   L = 1/2 LAMBDA                            
C                                                                       
      DO 69 L = IZERO, LX                                               
      CLEBS(L+1) = CLEBSH( LXX2, LXX2, 0, 0, 4*L, 0 )                   
      X3 = X3 + CLEBS(L+1)**4/(4*L+1)                                   
 69   CONTINUE                                                          
C                                                                       
      X2 = 0                                                            
      IF (MOD(LX,2).EQ.0 )  X2 = .50D0 * (LX+2) * SQRT( (LXX2+1)/(4*PI) 
     *) *  CLEBS(LX/2+1)**2                                             
      X3 = (LX+2)*(LX+1)*(LXX2+1)**2/(24*PI) * X3                       
C                                                                       
      XC = XCS(I12)                                                     
C                                                                       
C     NOW GET THE BETA COULOMB IF NECESSARY                             
C                                                                       
      GO TO ( 200, 110, 150, 130 ), IBC                                 
      GO TO 930                                                         
C                                                                       
C     <!! ALPHA !!>  GET BETA EFFECTIVE                                 
C                                                                       
 110  XC = XC/AME2                                                      
      GO TO 160                                                         
C                                                                       
C     <LX,0!!R.M.E.!!0>                                                 
C                                                                       
 130  AME2X = 1                                                         
C                                                                       
C     <J2,K2!!R.M.E.!!J1,K1>   GET BETA EFFECTIVE                       
C                                                                       
 150  XC = XC/(AME1*AME2X)                                              
C                                                                       
C     NOW GET BETA FROM BETA(EFFECTIVE) BY THREE ITERATIONS             
C     OF NEWTON-RHAPSON.                                                
C     XC HAS THE DESIRED BETA(EFFECTIVE)                                
C                                                                       
 160  BETA = XC                                                         
      DO 169 I = 1, 3                                                   
      A = 1+BETA*(2*X2 + 3*X3*BETA)                                     
      BETA = BETA + (XC - BETA*(1 + BETA*(X2 + BETA*X3)) )/A            
 169  CONTINUE                                                          
      XC = BETA                                                         
      GO TO 200                                                         
C                                                                       
C     NOTHING ABOUT COULOMB DEFINED; USE ZERO                           
C                                                                       
 190  XC = 0                                                            
      XCS(I12) = 0                                                      
      RMECOU = 0                                                        
      GO TO 210                                                         
C                                                                       
C     BETA IS IN XC; GET EVERYTHING FROM IT.                            
C                                                                       
C     FIRST THE R.M.E.                                                  
C                                                                       
 200  XCS(I12) = XC                                                     
      RMECOU = AMEUSE * XC * ( 1 + XC*(X2 + XC*X3) )                    
C                                                                       
C     ADVANCE TO NUCLEAR FIRST ORDER                                    
C                                                                       
 210  XN = XNS(I12)                                                     
      BETDEF = 0                                                        
      IF ( IBN .NE. -99 .AND. XN .EQ. 0 ) GO TO 300                     
C                                                                       
C     LOCATE THE DEFINITIONS                                            
C                                                                       
      L1 = IPARM4                                                       
      IF ( L1 .EQ. NOTDEF ) L1 = 2                                      
      IBETA = NAMLOC( BETNAM(IPT) )                                     
      IF ( IBETA .EQ. 0 ) GO TO 910                                     
      L2 = LX-L1+1                                                      
      IF ( L2 .LE. LENG(IBETA) .AND. L2 .GE. 1 )  BETDEF = ALLOC(Z(IBETA
     *)-1+L2)                                                           
C                                                                       
      IF ( IBN .EQ. -99 ) GO TO 260                                     
      GO TO ( 300, 250 ), IBN                                           
      GO TO 930                                                         
C                                                                       
C     <!!ALPHA!>>                                                       
C                                                                       
 250  XN = XN/AME2                                                      
      GO TO 300                                                         
C                                                                       
C     GET NUCLEAR FROM COULOMB IF POSSIBLE                              
C                                                                       
 260  IF ( IBC .EQ. -99 ) GO TO 270                                     
      XN = RC/RNUC * XC                                                 
      GO TO 300                                                         
C                                                                       
C     NUCLEAR BETA IS NOT DEFINED;  USE DEFORMED VALUE IF POSSIBLE      
C                                                                       
 270  XNS(I12) = BETDEF                                                 
      RMENUC = 1                                                        
      GO TO 310                                                         
C                                                                       
C     XN IS NOW BETAN  OR 0 IF IT COULD NOT BE FOUND                    
C                                                                       
 300  XNS(I12) = XN                                                     
      RMENUC = 1                                                        
      IF ( BETDEF .NE. 0 ) RMENUC = XN/BETDEF                           
      IF ( XN .EQ. 0 ) RMENUC = 0                                       
 310  RMENUC = AME2*RMENUC                                              
      RETURN                                                            
C                                                                       
 900  RMECOU = 0                                                        
      RMENUC = 0                                                        
      RETURN                                                            
C                                                                       
 910  WRITE(6,913) BETNAM(IPT)                                            
 913  FORMAT ( '0*** "', A5, '" MUST BE DEFINED FOR DEFORMED MODEL' )   
      GO TO 925                                                         
C                                                                       
 920  WRITE(6,923) K1, K2                                                 
 923  FORMAT ( '0*** PRESENT ROTATIONAL MODEL DOES NOT WORK',  ' FOR K1,
     * K2 =', 2(I4, '/2') )                                             
 925  IRTN = 1                                                          
      GO TO 900                                                         
C                                                                       
 930  WRITE(6,933) IBC, IBN                                               
 933  FORMAT ( '0*** INVALID IBC OR IBN IN MEBDEF*', 2I12 )             
      GO TO 925                                                         
C                                                                       
      END                                                               
      SUBROUTINE MEBROT ( IORD, I12, IBN, XNS, IBC, XCS,  MEORD, LXX2, L
     *XX2S, IZ, RNUC, RC, DELTAE,  J2, J1, K2, K1, RMENUC, RMECOU, IRTN 
     *)                                                                 
C                                                                       
C     CONVERTS ROTATIONAL REDUCED MATRIX ELEMENT TO AND FROM BETA       
C                                                                       
C     THIS SUBROUTINE CONTAINS THE MODEL DEPENDANT PARTS OF             
C     BEBETA FOR THE ROTATIONAL MODEL.                                  
C                                                                       
C     IT ALLOWS  K2=K1  OR  K2=0  OR  K1=0, HOWEVER FOR                 
C     K2=K1^=0, THE K --> -K TRANSISITION IS IGNORED.                   
C                                                                       
C                                                                       
C     FOR SECOND ORDER, WE ASSUME THAT ALL OF THE DELTA K               
C     IS IN THE FIRST STEP:                                             
C        (LX1, K2-K1) + (LX2, 0) = (LX, K2-K1)                          
C                                                                       
C     IORD - THE ORDER OF THE RME TO PRODUCE.  IF 2 IT IS ALSO          
C           THE ORDER OF THE INPUT RME(E) OR RME(ALPHA).  IF 1,         
C           MEORD INDICATES THE ORDER OF RME(E), BUT 1ST ORDER IS       
C           ALWAYS PRODUCED.                                            
C     I12 - ELEMENT OF XNS AND XCS ARRAYS TO USE.                       
C     IBN - TYPE OF INPUT IN XNS:                                       
C           1 = BETA                                                    
C           2 = <!!ALPHA!!> OR <!! ALPHA X ALPHA  !!>                   
C           -99 = UNKNOWN, TO BE FOUND FROM COULOMB RESULT BY           
C                 EQUAL DEFORMATION LENGTHS.                            
C     XNS - THE INPUT NUCLEAR QUANTITY.  FOR ALL 1ST ORDER AND          
C           2ND ORDER ALPHAS, THERE IS ONLY XNS(I12).  FOR 2ND ORDER    
C           BETAS THERE IS BOTH XNS(1) AND XNS(2).                      
C           FOR 1ST ORDER IT IS CONVERTED TO BETA.                      
C     IBC - TYPE OF INPUT IN XCS:                                       
C        1 - INPUT IS BETA                                              
C        2 - INPUT IS <J2,K2!!ALPHA OR ALPHA X ALPHA!!J1,K1>            
C        3 - INPUT IS <J2,K2!!E(LX)!!J1,K1>  IN  E BARN**LX/2           
C        4 - INPUT IS <LX,0!!E(LX)!!0,0>   IN  E BARN**LX/2             
C       -99 - NOT DEFINED, HAPPENS ONLY IF IBN=IBC=-99                  
C     XCS - THE INPUT COULOMB QUANTITIES; SEE XNS.                      
C     MEORD - =0 MEANS USE FIRST ORDER RELATION BETWEEN REDUCED MATRIX  
C                ELEMENT OF E(LX) AND BETA.                             
C             =1 MEANS USE SECOND ORDER RELATION.                       
C     LXX2 - 2*MULTIPOLE                                                
C     LXX2S - 2*(LX1, LX2) FOR SECOND ORDER.                            
C     IZ - (INTEGER)  THE ATOMIC NUMBER.                                
C     RNUC - THE NUCLEAR RADIUS                                         
C     RC - COULOMB RADIUS OF THE NUCLEUS                                
C     DELTAE - DIFFERENCE IN ENERGY OF THE TWO STATES (>0)              
C     J2 - 2*SPIN OF THE HIGHER STATE.                                  
C     J1 - 2*SPIN OF THE LOWER STATE                                    
C     K2, K1 - 2*(K-QUANTUM NUMBERS)                                    
C     RMENUC - SET TO <!!ALPHA OR ALPHA X ALPHA!!>                      
C     RMECOU - IS SET TO THE COMPUTED R.M.E.                            
C              <J2,K2!!R.M.E.!!J1,K1>   IN E BARN**LX/2                 
C     IRTN - SET TO 0 IF ALL O.K., 1 IF NOT                             
C                                                                       
C     12/8/80 - FIRST VERSION SEPARATED FROM BEBETA - S.P.              
C     1/8/81 - PROCESS NUCLEAR AND 2ND ORDER - S.P.                     
C     7/24/81 - FIX BUG FOR BE(0-LX) SPECIFIED - S.P.                   
C     8/25/81 - CHECK FOR BOTH BETAS UNDEFINED - S.P.                   
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      DIMENSION XCS(2), XNS(2), LXX2S(2)                                
C                                                                       
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      IRTN = 0                                                          
C                                                                       
C     CANNOT PROCEED IF BOTH DEFORMATIONS ARE NOT DEFINED               
C                                                                       
      IF ( IBN .EQ. -99 .AND. IBC .EQ. -99 ) GO TO 900                  
C                                                                       
      LX = LXX2/2                                                       
      TJ1P1 = J1+1                                                      
C                                                                       
C     COEFFICENTS FOR RME TO BETA.  THESE ARE BASED ON THE ROTATIONAL   
C     MODEL                                                             
C     AME1 CONVERTS < !!ALPHA!! >  TO < !!E(LX)!! >  IN                 
C     SHARP CUTOFF MODEL.                                               
C                                                                       
      AME1 = 3*IZ*(RC/10)**LX / (4*PI)                                  
C                                                                       
C     AME2 CONVERS BETA OR BETA1*BETA2 TO < !!ALPHA!! >                 
C                                                                       
      AME2 = CLEBSH( J1, LXX2, K1, K2-K1, J2, K2 ) * DSQRT(TJ1P1)       
      IF ( K1 .EQ. K2 ) GO TO 50                                        
      IF ( K2 .NE. 0 .AND. K1 .NE. 0 ) GO TO 920                        
      AME2 = DSQRT(2.D0)*AME2                                           
 50   IF ( AME2 .EQ. 0 ) GO TO 900                                      
      AMEUSE = AME1*AME2                                                
      AME2X = AME2                                                      
C                                                                       
C                                                                       
      IF ( IORD .EQ. 2 ) GO TO 500                                      
C                                                                       
C     AME3 IS SECOND-ORDER CONTRIBUTION TO R.M.E.                       
C                                                                       
      AME3 = 0                                                          
      IF ( MEORD .EQ. 1 .AND. IORD .EQ. 1 )  AME3 = .25*(LX+2)*DSQRT( (L
     *XX2+1)/PI )  * ( CLEBSH( LXX2, LXX2, 0, 0, LXX2, 0 ) )**2         
C                                                                       
C     FIRST ORDER                                                       
C                                                                       
      XC = XCS(I12)                                                     
C                                                                       
C     NOW GET THE BETA COULOMB IF NECESSARY                             
C                                                                       
C                                                                       
      GO TO ( 200, 110, 150, 130 ), IBC                                 
      GO TO 930                                                         
C                                                                       
C     <!! ALPHA !!>                                                     
C                                                                       
 110  XC = XC/AME2                                                      
      GO TO 200                                                         
C                                                                       
C     <LX,0!!R.M.E.!!0>                                                 
C                                                                       
 130  AME2X = 1                                                         
C                                                                       
C     <J2,K2!!R.M.E.!!J1,K1>                                            
C                                                                       
C     WE ARE SOLVING   M.E. = A1*A2*BETA*( 1 + A3*BETA )                
C                                                                       
 150  XC = XC/(AME1*AME2X)                                              
      IF ( AME3 .NE. 0 ) XC=(DSQRT( 1 + 4*AME3*XC )-1)/(2*AME3)
C                                                                       
C     BETA IS IN XC; GET EVERYTHING FROM IT.                            
C                                                                       
C     FIRST THE R.M.E.  THIS IS MODEL DEPENDANT                         
C                                                                       
 200  XCS(I12) = XC                                                     
      RMECOU = AMEUSE*XC                                                
C                                                                       
C     ADVANCE TO NUCLEAR FIRST ORDER                                    
C                                                                       
      XN = XNS(I12)                                                     
      IF ( IBN .EQ. -99 ) GO TO 260                                     
      GO TO ( 300, 250 ), IBN                                           
      GO TO 930                                                         
C                                                                       
C     <!!ALPHA!>>                                                       
C                                                                       
 250  XN = XN/AME2                                                      
      GO TO 300                                                         
C                                                                       
C     GET NUCLEAR FROM COULOMB                                          
C                                                                       
 260  XN = RC/RNUC * XC                                                 
C                                                                       
C     XN IS NOW BETAN                                                   
C                                                                       
 300  XNS(I12) = XN                                                     
      RMENUC = AME2*XN                                                  
      RETURN                                                            
C                                                                       
C                                                                       
C     SECOND ORDER                                                      
C                                                                       
C     FIRST COULOMB                                                     
C                                                                       
 500  XC = XCS(2)                                                       
C                                                                       
C     AME4 CONVERTS < ALPHA ALPHA >  TO < E(LX) >                       
C                                                                       
      AME4 = AME1 * (LX+2)*DSQRT( (LXX2S(1)+1.D0)*(LXX2S(2)+1.D0) /  (16
     **PI*(LXX2+1.D0)) )  * CLEBSH( LXX2S(1), LXX2S(2), 0, 0, LXX2, 0 ) 
      AME2 = AME2 *  CLEBSH( LXX2S(1), LXX2S(2), K2-K1, 0,LXX2,K2-K1 )
C                                                                       
      GO TO ( 520, 600, 540 ), IBC                                      
      GO TO 930                                                         
C                                                                       
C     BETAC1 AND BETAC2, GET ALPHA X ALPHA                              
C                                                                       
 520  XC = AME2 * XCS(1)*XCS(2)                                         
      GO TO 600                                                         
C                                                                       
C     RME E(LX), GET ALPHA X ALPHA                                      
C                                                                       
 540  XC = XC/(AME4)                                                    
C                                                                       
C     NOW WE HAVE  ALPHA X ALPHA, GET RME E(LX)                         
C                                                                       
 600  RMECOU = AME4*XC                                                  
C                                                                       
C     GO ON TO NUCLEAR                                                  
C                                                                       
      IF ( IBN .EQ. -99 ) GO TO 760                                     
      GO TO ( 720, 740 ), IBN                                           
      GO TO 930                                                         
C                                                                       
C     BETAN1, BETAN2                                                    
C                                                                       
 720  RMENUC = AME2*XNS(1)*XNS(2)                                       
      GO TO 800                                                         
C                                                                       
C     ALPHA X ALPHA GIVEN                                               
C                                                                       
 740  RMENUC = XNS(2)                                                   
      GO TO 800                                                         
C                                                                       
C     UNKNOWN, USE COULOMB                                              
C                                                                       
 760  RMENUC = (RC/RNUC)**2 * XC                                        
C                                                                       
 800  RETURN                                                            
C                                                                       
 900  RMECOU = 0                                                        
      RMENUC = 0                                                        
      RETURN                                                            
C                                                                       
 920  WRITE(6,923) K1, K2                                                 
 923  FORMAT ( '0*** PRESENT ROTATIONAL MODEL DOES NOT WORK',  ' FOR K1,
     * K2 =', 2(I4, '/2') )                                             
 925  IRTN = 1                                                          
      GO TO 900                                                         
C                                                                       
 930  WRITE(6,933) IBC, IBN                                               
 933  FORMAT ( '0*** INVALID IBC OR IBN IN MEBROT*', 2I12 )             
      GO TO 925                                                         
C                                                                       
      END                                                               
      SUBROUTINE MEBVIB ( IORD, I12, IBN, XNS, IBC, XCS,  MEORD, LXX2, L
     *XX2S, IZ, RNUC, RC, DELTAE,  J2, J1, K2IN, K1IN, RMENUC, RMECOU, I
     *RTN )                                                             
C                                                                       
C     CONVERTS VIBRATIONAL REDUCED MATRIX ELEMENT TO AND FROM BETA      
C                                                                       
C     THIS SUBROUTINE CONTAINS THE MODEL DEPENDANT PARTS OF             
C     BEBETA FOR THE VIBRATIONAL MODEL.                                 
C                                                                       
C     THE FOLLOWING COUPLINGS CAN BE CONVERTED TO AND FROM BETA         
C     BY THIS ROUTINE ( < !!ALPHA!! > = FACTOR*BETA ):                  
C                                                                       
C            RME                          FACTOR                        
C     <LX !! LX !! 0>                       1                           
C     <LX,LX:J !! LX !! LX>              SQRT(2) JHAT/LXHAT  (J EVEN)   
C     <LX',LX:J !! LX !! LX'>              JHAT/LXHAT                   
C     <LX,LX:J !! (LX X LX)J !! 0>        SQRT(2) JHAT/LXHAT**2         
C     <LX1,LX2:J !! (LX1 X LX2)J !! 0>     JHAT/(LX1HAT*LX2HAT)         
C     <LX !! (LX X LX)J !! LX>          (-)**LX 2 JHAT/LXHAT**2         
C     <LX2 !! (LX1 X LX2)J !! LX1>      (-)**LX1 JHAT/(LX1HAT*LX2HAT)   
C                                                                       
C     WHERE  !LX>  IS A ONE-PHONON STATE AND !LX1,LX2:J> IS             
C     A TWO-PHONON STATE.  FOR ALL THE SECOND-ORDER MATRIX ELEMENTS,    
C     WE REQUIRE  LX1+LX2+LXTOTAL (LXTOTAL=J ABOVE)  TO BE EVEN         
C     SINCE WE WILL HAVE THE SUM OF BOTH LX1,LX2 AND LX2,LX1            
C     TERMS.  THIS PROPERTY IS ENSURED BY BASCPL.                       
C     ALL OF THE TRANSPOSE MATRIX ELEMENTS ARE ALSO FOUND BY            
C        <J1!!...!!J2> = (-1)**(J2-J1) <J2!!...!!J1>                    
C                                                                       
C     FOR ALL OTHER CASES, THE R.M.E. MUST BE DIRECTLY GIVEN, AND       
C     THE BETAS WILL NOT BE COMPUTED.                                   
C                                                                       
C                                                                       
C     IORD - THE ORDER OF THE RME TO PRODUCE.  IF 2 IT IS ALSO          
C           THE ORDER OF THE INPUT RME(E) OR RME(ALPHA).  IF 1,         
C           MEORD INDICATES THE ORDER OF RME(E), BUT 1ST ORDER IS       
C           ALWAYS PRODUCED.                                            
C     I12 - ELEMENT OF XNS AND XCS ARRAYS TO USE.                       
C     IBN - TYPE OF INPUT IN XNS:                                       
C           1 = BETA                                                    
C           2 = <!!ALPHA!!> OR <!! ALPHA X ALPHA  !!>                   
C           -99 = UNKNOWN, TO BE FOUND FROM COULOMB RESULT BY           
C                 EQUAL DEFORMATION LENGTHS.                            
C     XNS - THE INPUT NUCLEAR QUANTITY.  FOR ALL 1ST ORDER AND          
C           2ND ORDER ALPHAS, THERE IS ONLY XNS(I12).  FOR 2ND ORDER    
C           BETAS THERE IS BOTH XNS(1) AND XNS(2).                      
C           FOR 1ST ORDER IT IS CONVERTED TO BETA.                      
C     IBC - TYPE OF INPUT IN XCS:                                       
C        1 - INPUT IS BETA                                              
C        2 - INPUT IS <J2,K2!!ALPHA OR ALPHA X ALPHA!!J1,K1>            
C        3 - INPUT IS <J2,K2!!E(LX)!!J1,K1>  IN  E BARN**LX/2           
C        4 - INPUT IS <LX,0!!E(LX)!!0,0>   IN  E BARN**LX/2             
C       -99 - NOT DEFINED, HAPPENS ONLY IF IBN=IBC=-99                  
C     XCS - THE INPUT COULOMB QUANTITIES; SEE XNS.                      
C     MEORD - IGNORED FOR VIBRATIONAL MODEL                             
C     LXX2 - 2*MULTIPOLE                                                
C     LXX2S - 2*(LX1, LX2) FOR SECOND ORDER.                            
C     IZ - (INTEGER)  THE ATOMIC NUMBER.                                
C     RNUC - THE NUCLEAR RADIUS                                         
C     RC - COULOMB RADIUS OF THE NUCLEUS                                
C     DELTAE - DIFFERENCE IN ENERGY OF THE TWO STATES (>0)              
C     J2 - 2*SPIN OF THE HIGHER STATE.                                  
C     J1 - 2*SPIN OF THE LOWER STATE                                    
C     K2, K1 - 2*(NUMBER OF PHONONS)                                    
C           0 IS SET TO 1 EXCEPT FOR J=0 WHICH IS LEFT AT 0 (GS)        
C           <0 IS SET TO THE NUMBER THAT CONSERVES PHONONS,             
C                 EITHER 1 OR 2.                                        
C     RMENUC - SET TO <!!ALPHA OR ALPHA X ALPHA!!>                      
C     RMECOU - IS SET TO THE COMPUTED R.M.E.                            
C              <J2,K2!!R.M.E.!!J1,K1>   IN E BARN**LX/2                 
C     IRTN - SET TO 0 IF ALL O.K., 1 IF NOT                             
C                                                                       
C     1/20/81 - MEBVIB MADE FROM MEBROT - S.P.                          
C     8/25/81 - CHECK FOR BOTH BETAS UNDEFINED - S.P.                   
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      DIMENSION XCS(2), XNS(2), LXX2S(2)                                
C                                                                       
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      IRTN = 0                                                          
C                                                                       
C     CANNOT PROCEED IF BOTH DEFORMATIONS ARE NOT DEFINED               
C                                                                       
      IF ( IBN .EQ. -99 .AND. IBC .EQ. -99 ) GO TO 900                  
C                                                                       
      LX = LXX2/2                                                       
C                                                                       
C     WE ARRANGE THINS SO THAT  K2 > K1                                 
C     AND THEN COMPUTE  < 2 !! ... !! 1 >                               
C     IF THIS INVOLVES FLIPING THINGS, WE INTRODUCE THE                 
C     REQUIRED  (-1)**(J2-J1)                                           
C                                                                       
C     FILL IN UNDEFINED NUMBERS OF PHONOS                               
C                                                                       
      K1 = K1IN                                                         
      K2 = K2IN                                                         
      IF ( K1 .EQ. 0 .AND. J1 .GT. 0 ) K1 = 2                           
      IF ( K2 .EQ. 0 .AND. J2 .GT. 0 ) K2 = 2                           
      IF ( K1 .GE. 0 ) GO TO 20                                         
      IF ( K2 .LT. 0 ) GO TO 940                                        
      K1 = 2*IORD                                                       
      IF ( K2 .EQ. 2 ) K1 = 6-K1                                        
      GO TO 40                                                          
 20   IF ( K2 .GE. 0 ) GO TO 40                                         
      K2 = 2*IORD                                                       
      IF ( K1 .EQ. 2 ) K2 = 6-K2                                        
C                                                                       
 40   IF ( K2 .LT. K1 ) GO TO 45                                        
      KK1 = K1/2                                                        
      KK2 = K2/2                                                        
      JJ1 = J1                                                          
      JJ2 = J2                                                          
      SGNFAC = +1                                                       
      GO TO 50                                                          
 45   KK1 = K2/2                                                        
      KK2 = K1/2                                                        
      JJ1 = J2                                                          
      JJ2 = J1                                                          
      SGNFAC = (-1)**((J2-J1)/2)                                        
C                                                                       
 50   TJ2P1 = JJ2+1                                                     
C                                                                       
C     COEFFICENTS FOR RME TO BETA.  THESE ARE BASED ON THE VIBRATIONAL  
C     MODEL                                                             
C     AME1 CONVERTS < !!ALPHA!! >  TO < !!E(LX)!! >  IN                 
C     SHARP CUTOFF MODEL.                                               
C                                                                       
      AME1 = 3*IZ*(RC/10)**LX / (4*PI)                                  
C                                                                       
C     AME2 CONVERS BETA OR BETA1*BETA2 TO < !!ALPHA!! >                 
C                                                                       
C     IF THIS IS A CASE WE DON'T KNOW ABOUT, AME2 = 0                   
C                                                                       
      AME2 = 0                                                          
C                                                                       
C                                                                       
      IF ( IORD .EQ. 2 ) GO TO 400                                      
C                                                                       
C     FIRST ORDER                                                       
C                                                                       
      IF ( KK2 .GE. 3 ) GO TO 100                                       
      IF ( KK2 .NE. KK1+1 ) GO TO 100                                   
      IF ( KK1 .EQ. 0 .AND. JJ1 .NE. 0 ) GO TO 100                      
      GO TO ( 70, 80 ), KK2                                             
C                                                                       
C     < 1 PHONON !! LX !! 0 >    LX = J2 IS ALREADY KNOWN               
C                                                                       
 70   AME2 = 1                                                          
      GO TO 100                                                         
C                                                                       
C     < 2 PHONONS; J !! LX !! 1 PHONON >                                
C                                                                       
 80   AME2 = SQRT( TJ2P1/(LXX2+1) )                                     
      IF ( LXX2 .NE. JJ1 ) GO TO 100                                    
      IF ( MOD(JJ2, 4) .NE. 0 ) GO TO 99                                
      AME2 = DSQRT(2.D0)*AME2                                           
      GO TO 100                                                         
C                                                                       
 99   AME2 = 0                                                          
 100  AME2 = SGNFAC*AME2                                                
      XC = XCS(I12)                                                     
C                                                                       
C     NOW GET THE BETA COULOMB IF NECESSARY AND POSSIBLE                
C                                                                       
      GO TO ( 170, 110, 150, 130 ), IBC                                 
      GO TO 930                                                         
C                                                                       
C     <!! ALPHA !!>  CONVERT TO < !!E(LX)!! >                           
C                                                                       
 110  XC = XC*AME1                                                      
      GO TO 150                                                         
C                                                                       
C     <LX!!R.M.E.!!0>   GET BETA                                        
C                                                                       
 130  XC = XC/AME1                                                      
      GO TO 170                                                         
C                                                                       
C     <J2,K2!!R.M.E.!!J1,K1>  GET BETA IF POSSIBLE                      
C                                                                       
 150  RMECOU = XC                                                       
      XC = 0                                                            
      IF ( AME2 .NE. 0 ) XC = RMECOU/(AME1*AME2)                        
      GO TO 200                                                         
C                                                                       
C     BETA IS IN XC; GET EVERYTHING FROM IT.                            
C                                                                       
 170  IF ( AME2 .EQ. 0 ) GO TO 920                                      
      RMECOU = AME1*AME2 * XC                                           
C                                                                       
 200  XCS(I12) = XC                                                     
C                                                                       
C     ADVANCE TO NUCLEAR FIRST ORDER                                    
C                                                                       
      XN = XNS(I12)                                                     
      IF ( IBN .EQ. -99 ) GO TO 260                                     
      GO TO ( 270, 250 ), IBN                                           
      GO TO 930                                                         
C                                                                       
C     <!!ALPHA!>>                                                       
C                                                                       
 250  RMENUC = XN                                                       
      XN = 0                                                            
      IF ( AME2 .NE. 0 ) XN = RMENUC/AME2                               
      GO TO 300                                                         
C                                                                       
C     GET NUCLEAR ALPHA FROM COULOMB RME                                
C                                                                       
 260  XN = RC/RNUC * RMECOU/AME1                                        
      GO TO 250                                                         
C                                                                       
C     XN IS NOW BETAN                                                   
C                                                                       
 270  IF ( AME2 .EQ. 0 ) GO TO 920                                      
      RMENUC = AME2*XN                                                  
C                                                                       
 300  XNS(I12) = XN                                                     
      RETURN                                                            
C                                                                       
C     SECOND ORDER                                                      
C                                                                       
C     GET CONVERSION FACTORS                                            
C                                                                       
 400  IF ( KK2 .GE. 3 ) GO TO 500                                       
      IF ( KK1 .EQ. 0 .AND. KK2 .EQ. 2 ) GO TO 410                      
      IF ( KK1 .EQ. 1 .AND. KK2 .EQ. 1 ) GO TO 420                      
      GO TO 500                                                         
C                                                                       
C     < 2 PHONON !! (LX1 LX2)LX !! 0 >   LX = J2 IS KNOWN               
C                                                                       
 410  AME2 = DSQRT( TJ2P1/((LXX2S(1)+1)*(LXX2S(2)+1)) )                 
      IF ( LXX2S(1) .EQ. LXX2S(2) ) AME2 = DSQRT(2.D0)*AME2             
      GO TO 500                                                         
C                                                                       
C     < 1 PHONON !! (LX1 LX2)LX !! 1 PHONON >                           
C                                                                       
 420  IF ( LXX2S(1) .EQ. J1 .AND. LXX2S(2) .EQ. J2 ) GO TO 425          
      IF ( LXX2S(1) .EQ. J2 .AND. LXX2S(2) .EQ. J1 ) GO TO 425          
      GO TO 500                                                         
C                                                                       
 425  AME2 = (-1)**(LXX2S(1)/2) * DSQRT( (LXX2+1.D0)/  ( (LXX2S(1)+1.D0)
     **(LXX2S(2)+1.D0) ) )                                              
      IF ( J2 .EQ. J1 ) AME2 = 2*AME2                                   
C                                                                       
 500  AME2 = SGNFAC*AME2                                                
      AME4 = AME1 * (LX+2)*DSQRT( (LXX2S(1)+1.D0)*(LXX2S(2)+1.D0) /  (16
     **PI*(LXX2+1.D0)) )  * CLEBSH( LXX2S(1), LXX2S(2), 0, 0, LXX2, 0 ) 
C                                                                       
C     NOW DO COULOMB                                                    
C                                                                       
      XC = XCS(2)                                                       
      GO TO ( 520, 600, 540 ), IBC                                      
      GO TO 930                                                         
C                                                                       
C     BETAC1 AND BETAC2, GET ALPHA X ALPHA                              
C                                                                       
 520  IF ( AME2 .EQ. 0 ) GO TO 920                                      
      XC = AME2 * XCS(1)*XCS(2)                                         
      GO TO 600                                                         
C                                                                       
C     RME E(LX), GET ALPHA X ALPHA                                      
C                                                                       
 540  XC = XC/(AME4)                                                    
C                                                                       
C     NOW WE HAVE  ALPHA X ALPHA, GET RME E(LX)                         
C                                                                       
 600  RMECOU = AME4*XC                                                  
C                                                                       
C     GO ON TO NUCLEAR                                                  
C                                                                       
      IF ( IBN .EQ. -99 ) GO TO 760                                     
      GO TO ( 720, 740 ), IBN                                           
      GO TO 930                                                         
C                                                                       
C     BETAN1, BETAN2                                                    
C                                                                       
 720  IF ( AME2 .EQ. 0 ) GO TO 920                                      
      RMENUC = AME2*XNS(1)*XNS(2)                                       
      GO TO 800                                                         
C                                                                       
C     ALPHA X ALPHA GIVEN                                               
C                                                                       
 740  RMENUC = XNS(2)                                                   
      GO TO 800                                                         
C                                                                       
C     UNKNOWN, USE COULOMB                                              
C                                                                       
 760  RMENUC = (RC/RNUC)**2 * XC                                        
C                                                                       
 800  RETURN                                                            
C                                                                       
 900  RMECOU = 0                                                        
      RMENUC = 0                                                        
      RETURN                                                            
C                                                                       
 920  WRITE(6,923) J2, K2, LXX2S, LXX2, J1, K1, IORD                      
 923  FORMAT ( '0*** PRESENT VIBRATIONAL MODEL DOES NOT WORK',  ' FOR J2
     *, K2, LX1, LX2, LX, J1, K1, ORDER =' /  6X, 7(I4, '/2'), I4 )     
 925  IRTN = 1                                                          
      GO TO 900                                                         
C                                                                       
 930  WRITE(6,933) IBC, IBN                                               
 933  FORMAT ( '0*** INVALID IBC OR IBN IN MEBVIB*', 2I12 )             
      GO TO 925                                                         
C                                                                       
 940  WRITE(6,943)
 943  FORMAT ( '0**** CANNOT HAVE INDEFINET NUMBER OF PHONONS',  ' IN BO
     *TH STATES.' )                                                     
      GO TO 925                                                         
C                                                                       
      END                                                               
      SUBROUTINE MINMON ( ITCNT, NFCALL, NJCALL, NPARAM, NPTS, PARAM, F,
     * FS )                                                             
C                                                                       
C     PRINT ITERATION INFORMATION FOR DLSMIN AND OTHER MINIMIZERS       
C                                                                       
C     10/23/75 - FIRST VERSION - S. P.                                  
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL PARAM,FS                                            
C                                                                       
      DIMENSION PARAM(NPARAM), FS(NPTS)                                 
C                                                                       
      FF = F/NPTS                                                       
      WRITE(6,53) ITCNT, NFCALL, NJCALL, FF, PARAM                        
 53   FORMAT ( ' ITERATION', I5, I15, ' FUNCTION CALLS.',  I10, ' JACOBI
     *AN CALLS',  5X, '(CHI. SQ.)/PT =', G16.8, 5X, 'PARAMETERS:' /  ( 8
     *G16.6 ) )                                                         
      RETURN                                                            
      END                                                               
      SUBROUTINE MSCAN ( KEYEX, ITOKEN, CVALU, VALU, IVALU, MESS,  IMESS
     *, STOP )                                                          
C                                                                       
C     FIELD SCANNER FOR DELPHI                                          
C     MODIFIED MFIELD SCANNER OF SPEAKEZ                                
C     THIS VERSION IS FOR PTOLEMY.                                      
C                                                                       
C                                                                       
C     THE LINE TO SCAN IS IN IBUF.  IT CONTAINS NOCH CHARACTERS.        
C     INCH IS THE FIRST CHARACTER TO CONSIDER AND IS UPDATED TO POINT   
C          TO THE CHARACTER THAT STOPPED THE SCAN - I.E. TO THE FIRST   
C          CHARACTER TO CONSIDER THE NEXT TIME.                         
C                                                                       
C     ITOKEN IS SET AS FOLLOWS                                          
C     > 0 CODE VALUE AS DESCRIBED SEVERAL LINES BELOW                   
C      0  NO FIELD                                                      
C     -1  ALPHANUMERIC  LEFT SHIFTED BLANK FILLED - STORED IN 'CVALU'.  
C         THE NUMBER OF CHARACTERS IS STORED IN IMESS.                  
C     -2  NUMERIC (FLT. PT. FORM) - STORED IN 'VALU' AND 'IVALU'.       
C     -3  BEGINNING OF LEVEL SPECIFICATION (E.G. 1P FROM 1P3/2-).  THE  
C         NUMBER OF NODES IS STORED IN VALU (3P RESULTS IN VALU=2=3-1), 
C         AND THE NUMERIC (S=0, P=1, ETC.) L-VALUE IS STORED IN IVALU.  
C         ON THE NEXT CALL TO MSCAN, THE J-FIELD (IF PRESENT) WILL BE   
C         SCANNED.  THE FOLLOWING ARE RECOGNIZED AS L-INDICATORS:       
C             S P D F G H I J K .                                       
C         WITH THE EXCEPTION OF E (FOR EXPONENTS) ANY OTHER ALPHABETIC  
C         IN A NUMERIC FIELD IS TREATED AS AN ERROR.  NOTE THAT LEVEL   
C         SPECIFICATIONS MAY NOT HAVE A DECIMAL POINT SO THAT 1.D+10    
C         IS RECOGINIZED AS THE SAME AS 1E10 WHILE 1D10 WOULD BE TREATED
C         AS A LEVEL SPECIFICATION.                                     
C     -4  LITERAL DATA (80 COL. MAX).  STORED IN MESS; IMESS IS NUM.    
C         CHARACTERS STORED.                                            
C     -5  INTEGER (NO DECIMAL PT. OR E FIELD) - STORED IN 'VALU' AND    
C         'IVALU'.                                                      
C     -8  END OF CARD BEFORE ANYTHING WAS FOUND - NOTHING STORED.       
C     -9  ERROR ENCOUNTERED - NOTHING RELIABLE STORED.                  
C                                                                       
C     SPECIAL CHARACTER TOKENS ARE  ( + - * ARE NOLONGER TOKENS )       
C     %(1)  #(2)  &(3)  :(4)  ;(5)                                      
C     -(6)  +(7)  /(8)  *(9)  ((10)  (+ - NOW START NUMBERS)            
C                                    (* NOW AN ALPHA CHAR.)             
C     )(11) =(12) @(13) <(14) >(15)                                     
C     !(16) ^(17) ?(18) "(19) .(20)  (. IS NORMALLY NUMERIC)            
C     ,(21)                                                             
C                                                                       
C     \KEYEX\ TELLS NUMBER OF THE LARGEST TOKEN TO KEEP                 
C     OTHERS SERVE ONLY AS DELIMITERS                                   
C                                                                       
C     IF  KEYEX < 0  THEN NUMERIC FIELDS ARE NOT DECODED BUT ARE        
C     TREATED AS ALPHAMERIC AND TOKEN IS SET TO 1 FOR THEM.             
C     IN THIS CASE, ALPHABETICS ARE ALLOWED IN THE NUMERIC FIELD        
C     (I.E. 48CA IS VALID) AND +, -, AND . ARE TREATED AS TOKENS        
C     INSTEAD OF PARTS OF NUMERICS.                                     
C                                                                       
C     STOP IS SET TO THE CHARACTER THAT STOPPED THE SCAN -- I.E.        
C     THE FIRST CHARACTER TO BE CONSIDERED ON THE NEXT CALL TO          
C     MSCAN.  NOTE THAT FOR  ITOKEN > 0  THIS IMPLIES THAT STOP IS      
C     THE CHARACTER AFTER THE TOKEN.                                    
C                                                                       
C                                                                       
C     BLANKS ARE DELIMITERS AND NOT MADE INTO TOKENS                    
C     '(APOSTROHIES) DELIMIT LITERAL DATA, $ IS COMMENT DELIMITER       
C                                                                       
C                                                                       
C     5/7/75 - EXTENSIVE CHANGES FOR PTOLEMY - S. PIEPER                
C     8/26/76 - MUCH REWRITE FOR CDC/IBM VERSION.                       
C     5/6/79 - LEVELS PUT BACK; CORRECT ERROR IN LITERAL FIELDS - S.P.  
C     12/28/79 - STANDARD MORTRAN, CUN, CVA - RPG                       
C     1/11/80 - ADD CHARACTER*8 ARGUMENT CVALUE, USE IT;  USE QUOTES IN 
C        DATA STATEMENTS; OTHER RELATED CORRECTIONS - RPG               
C     3/15/80 - USE 1H_ IN CDC DELIMS DEFINITION - S.P.                 
C     6/2/80 - CDC 1H_ VERSION OF CHARS - S.P.                          
C     7/14/80 - CRAY VERSION - S.P.                                     
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
C                                                                       
      CHARACTER*1 STOP                                                  
C                                                                       
      CHARACTER*1 MESS(1)                                               
      CHARACTER*8 CVALU                                                 
      CHARACTER*1 DOLLAR, BLANK, DOT                                    
      DATADOT/'.'/                                                      
      DATABLANK/' '/                                                    
      DATA DOLLAR / '$' /                                               
      CHARACTER*1 STAR                                                  
      DATA STAR / '*' /                                                 
C                                                                       
CNV      CHARACTER*1                                                    
      INTEGERNUM0, NUM9, LETTRA, LETTRZ                                 
      DATALETTRZ/90/                                                    
      DATALETTRA/65/                                                    
      DATANUM9/57/                                                      
      DATA NUM0 / 48 /                                                  
      CHARACTER*1 LETTRE, LETTRD                                        
      DATALETTRD/'D'/                                                   
      DATA LETTRE / 'E' /                                               
C                                                                       
      DATA NUMLS /9/                                                    

      CHARACTER*1 LCHARS(9)                                             
      DATA LCHARS/'S', 'P', 'D', 'F', 'G', 'H', 'I', 'J', 'K'/          
C                                                                       
      CHARACTER*8 WORD, BLANK8                                          
      DATABLANK8/' '/                                                   
      CHARACTER*1 WORD1(8)                                              
      EQUIVALENCE ( WORD, WORD1(1) )                                    
C                                                                       
      CHARACTER*1 CHARS(21), DELIMS(4), ICH                             
C                                                                       
C                                                                       
      DATA  CHARS / '%', '#', '&', ':', ';',                            
     1  '-', '+', '/', '*', '(',                                        
     2  ')', '=', '@', '<', '>',                                        
     3  '!', '^', '?', '"', '.',                                        
     4  ',' /                                                           
C                                                                       
CDC      DATA CHARS / 1H%, 1H#, 1H&, 1H:, 1H;,                          
CDC     1  1H-, 1H+, 1H/, 1H*, 1H(,                                     
CDC     2  1H), 1H=, 1H@, 1H<, 1H>,                                     
CDC     3  1H!, 1H^, 1H?, 1H", 1H.,                                     
CDC     4  1H, /                                                        
C                                                                       
      DATA  DELIMS / '+', '-', '''', '$' /                              
CDC      DATA  DELIMS / 1H+, 1H-, 1H', 1H$ /                            
C                                                                       
C                                                                       
C                                                                       
C     PRESETS                                                           
C                                                                       
      INCHST = INCH                                                     
      SIGN = +1                                                         
      VAL = 0                                                           
      ICNT = 0                                                          
      INCH = INCH - 1                                                   
      IMESS=0                                                           
      ICOM=0                                                            
      IDEC = 0                                                          
C                                                                       
C     PHASES                                                            
C     1 NOTHING COOKING                                                 
C     2 ALPHABETIC FIELD BEING PROCESSED                                
C     3 NUMERICAL FIELD BEING PROCESSED                                 
C                                                                       
C                                                                       
      INPHAS = 1                                                        
C                                                                       
C     GET NEXT CHAR IF COMMENT SKIP IF NOT FIND TYPE                    
C                                                                       
  100 INCH=INCH+1                                                       
      IF (INCH.GT.NOCH) GO TO 710                                       
      ICH=IBUF(INCH)                                                    
C     IS A LITERAL COMMING IN                                           
      IF(IMESS.GT.0)GO TO 149                                           
C     IS A COMMENT COMMING IN (IF SO SKIP UNTIL $ IS MET)               
C                                                                       
      IF(ICOM.EQ.0)GO TO 101                                            
      IF (ICH.NE.DOLLAR) GO TO 100                                      
      ICOM=0                                                            
      GO TO 100                                                         
C                                                                       
C     BLANK0                                                            
C                                                                       
 101  IF ( ICH .EQ. BLANK ) GO TO ( 100, 210, 340 ), INPHAS             
C                                                                       
      ICHVAL = ICHAR(ICH)                                               
C                                                                       
C     NUMBER   0                                                        
C                                                                       
      IF ( ICHVAL .GE. NUM0 .AND. ICHVAL .LE. NUM9 ) GO TO 300          
C                                                                       
C     ALPHABETIC 0                                                      
C                                                                       
      IF ( ( ICHVAL .GE. LETTRA .AND. ICHVAL .LE. LETTRZ) .OR. ICH .EQ. 
     *STAR ) GO TO 200                                                  
C                                                                       
C     IT IS A SPECIAL CHARACTER                                         
C                                                                       
C     IS IT A PERIOD                                                    
C                                                                       
 102  IF (ICH.EQ.DOT) GO TO 320                                         
C                                                                       
C     ALL OTHER SPECIAL CHARACTERS STOP A FIELD THAT IS IN PROGRESS     
C                                                                       
      GO TO(105,210,340),INPHAS                                         
C                                                                       
C     FIRST CHECK FOR  + - ' $                                          
C                                                                       
 105  DO 129 I = 1, 4                                                   
      IF ( ICH .EQ. DELIMS(I) ) GO TO 140                               
 129  CONTINUE                                                          
C                                                                       
C     NOW LOOK FOR TOKENS                                               
C                                                                       
      DO 139 ITOKEN = 1, 21                                             
      IF ( ICH .EQ. CHARS(ITOKEN) ) GO TO 590                           
 139  CONTINUE                                                          
      GO TO 9000                                                        
C                                                                       
 140  GO TO ( 141, 142, 143, 144 ), I                                   
 141  SIGN = +1                                                         
      ITOKEN = 7                                                        
      IF ( KEYEX .LT. 0 ) GO TO 590                                     
      GO TO 302                                                         
 142  SIGN = -1                                                         
      ITOKEN = 6                                                        
      IF ( KEYEX .LT. 0 ) GO TO 590                                     
      GO TO 302                                                         
 143  IMESS = 1                                                         
      GO TO 100                                                         
 144  ICOM = 1                                                          
      GO TO 100                                                         
C                                                                       
C     COLLECTING A LITERAL                                              
C                                                                       
  149 MESS(IMESS)=ICH                                                   
      IMESS=IMESS+1                                                     
      IF(IMESS.GT.80) GO TO 9006                                        
      IF (ICH.NE.DELIMS(3))GO TO 100                                    
      IMESS=IMESS-2                                                     
      MESS(IMESS+1)=BLANK                                               
      ITOKEN=-4                                                         
      INCH = INCH+1                                                     
      GO TO 602                                                         
C                                                                       
C     ALPHABETIC CHARACTER CHECK PHASE                                  
C                                                                       
C                                                                       
 200  GO TO(201,202,330),INPHAS                                         
C     START                                                             
 201  WORD = BLANK8                                                     
      IWORD = 0                                                         
 202  IF (IWORD .LT. 8) THEN                                            
      WORD1(IWORD+1) = ICH                                              
      IWORD = IWORD+1                                                   
      END IF                                                            
      INPHAS=2                                                          
      GO TO 100                                                         
C     DONE                                                              
 210  IMESS = IWORD                                                     
      CVALU = WORD                                                      
      ITOKEN=-1                                                         
      GO TO 600                                                         
C                                                                       
C                                                                       
C     NUMERIC                                                           
C                                                                       
 300  IF ( KEYEX .LT. 0 ) GO TO 200                                     
      GO TO (301,202,303),INPHAS                                        
C     START                                                             
  301 IDEC=0                                                            
      VAL = ICHVAL - NUM0                                               
      ICNT = 1                                                          
  302 POW=1.0                                                           
      INPHAS=3                                                          
      GO TO 100                                                         
C     MORE                                                              
 303  VAL = 10*VAL + ICHVAL - NUM0                                      
      IF (IDEC.NE.0) POW=POW*10.0                                       
      ICNT = ICNT + 1                                                   
      GO TO 100                                                         
C                                                                       
C     DECIMAL PT.                                                       
C                                                                       
 320  ITOKEN = 20                                                       
      IF ( KEYEX .LT. 0 ) GO TO 590                                     
      GO TO (321,9002,310),INPHAS                                       
C                                                                       
C     DECIMAL PT ENCOUNTERED IN NUMERIC FIELD                           
C                                                                       
  310 IF (IDEC.NE.0) GO TO 9002                                         
      IDEC=1                                                            
      GO TO 100                                                         
  321 IDEC=1                                                            
      VAL=0.0                                                           
      GO TO 302                                                         
C                                                                       
C     ALPHABETIC IN NUMERIC FIELD - CHECK E FOR EXPONENTS               
C                                                                       
 330  IF ( ICH .EQ. LETTRE ) GO TO 332                                  
C                                                                       
C     IF WE HAVE NOT YET HAD A DECIMAL POINT THEN IT MUST BE A          
C     LEVEL SPECIFICATION.                                              
C                                                                       
      IF ( IDEC .EQ. 0 ) GO TO 400                                      
C                                                                       
C     FOLLOWING A DECIMAL POINT A "D" MAY BE USED FOR AN EXPONENT       
C                                                                       
      IF ( ICH .NE. LETTRD ) GO TO 9012                                 
C                                                                       
C                                                                       
C     E OR D FORMAT                                                     
C                                                                       
 332  ISG = 1                                                           
      IDEC = 1                                                          
      IPOW=0                                                            
      INCH=INCH+1                                                       
      IF (INCH.GT.NOCH) GO TO 9008                                      
      ICH=IBUF(INCH)                                                    
      IF (ICH.EQ.DELIMS(1)) GO TO 334                                   
      IF (ICH.NE.DELIMS(2)) GO TO 335                                   
      ISG=-1                                                            
  334 INCH=INCH+1                                                       
      IF (INCH.GT.NOCH) GO TO 3360                                      
      ICH=IBUF(INCH)                                                    
 335  ICHVAL = ICHAR(ICH)                                               
      IF ( ICHVAL .LT. NUM0 .OR. ICHVAL .GT. NUM9 ) GO TO 336           
      IPOW=IPOW*10+ ICHVAL - NUM0                                       
CIB      IF (IPOW.GT.75) GO TO 9004                                     
CDC      IF ( IPOW .GT. 300 )  GO TO 9004                               
CUN      IF ( IPOW .GT. 300 )  GO TO 9004                               
      IF ( IPOW .GT. 38 ) GO TO 9004                                    
CRA      IF ( IPOW .GT. 2465 )  GO TO 9004                              
      GO TO 334                                                         
C                                                                       
 3360 CONTINUE                                                          
  336 IF (IPOW.EQ.0)GO TO 340                                           
      P2=10.0D0**IPOW                                                   
      IF (IS G.LT.0) GO TO 337                                          
      POW=POW/P2                                                        
      GO TO 340                                                         
  337 POW=POW*P2                                                        
      GO TO 340                                                         
  340 ITOKEN=-2                                                         
      VALU1=VAL/POW                                                     
      VALU=VALU1*SIGN                                                   
      IVALU = VALU                                                      
      IF ( IDEC .EQ. 0 ) ITOKEN = -5                                    
      IF ( ICNT .EQ. 0 ) GO TO 9010                                     
      GO TO 600                                                         
C                                                                       
C     AN ALPHABETIC WAS FOUND IN AN INTEGER NUMERIC FIELD; IT MAY BE THE
C     L-DESIGNATOR OF A LEVEL-SPECIFICATION.                            
C                                                                       
 400  VALU = SIGN*VAL - 1                                               
      DO 409 I = 1, NUMLS                                               
      IF ( ICH .EQ. LCHARS(I) ) GO TO 420                               
 409  CONTINUE                                                          
      GO TO 9012                                                        
 420  IVALU = I-1                                                       
      ITOKEN = -3                                                       
      INCH = INCH+1                                                     
      GO TO 600                                                         
C                                                                       
C     SPECIAL CHARACTER FOUND - SHOULD WE SKIP OVER IT0                 
C                                                                       
  590 IF(ITOKEN.GT. IABS(KEYEX) )GO TO 100                              
      INCH = INCH + 1                                                   
C                                                                       
C     FIELD HAS BEEN FOUND AND PROCESSED                                
C                                                                       
 600  CONTINUE                                                          
 602  STOP = IBUF(INCH)                                                 
      RETURN                                                            
C                                                                       
C     END OF LINE ENCOUNTERED                                           
C                                                                       
  710 CONTINUE                                                          
      GO TO(701,210,340),INPHAS                                         
  701 CONTINUE                                                          
      ITOKEN = -8                                                       
      RETURN                                                            
C                                                                       
C     ERROR MESSAGES                                                    
C                                                                       
 9000 WRITE(6,9001) ICH, ICH                                              
 9001 FORMAT ( '0**** UNRECOGNIZABLE CHARACTER '', A1, ''', 5X,  '(HEX I
     *S ', Z2, ').' )                                                   
CDC     1  '(OCTAL IS ', O2, ').' )                                     
      GO TO 9019                                                        
 9002 WRITE(6,9003)
 9003 FORMAT ( '0**** INVALID DECIMAL POINT.' )                         
      GO TO 9019                                                        
 9004 WRITE(6,9005)
 9005 FORMAT ('0**** INVALID OR TOO LARGE EXPONENT FIELD.')             
      GO TO 9019                                                        
 9006 WRITE(6,9007)
 9007 FORMAT ('0**** FIELD IS TOO LONG.' )                              
      GO TO 9019                                                        
 9008 WRITE(6,9009)
 9009 FORMAT ('0**** E OR D MUST BE FOLLOWED BY NUMBER')                
      GO TO 9019                                                        
 9010 WRITE(6,9011)
 9011 FORMAT ( '0**** MISPLACED DECIMAL POINT OR PLUS OR MINUS SIGN.' ) 
      GO TO 9019                                                        
 9012 WRITE(6,9013)
 9013 FORMAT ( '0**** INVALID ALPHABETIC IN NUMMERIC FIELD' )           
C                                                                       
 9019 WRITE(6,9023) ( IBUF(I), I = INCHST, INCH )                         
 9023 FORMAT ( ' FIELD UP TO THE ERROR IS: ', 80A1 )                    
      ITOKEN = -9                                                       
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE MUELCO ( KA, KB, KBIGA, KBIGB, JA, JB, JBIGA, JBIGB,  N
     *QA, NQB, NQBIGA, NQBIGB, NSPL, IPARIT,  ITOC, COEF, COEP, COET, CO
     *EX, TERMK, PBUGSW )                                               
C                                                                       
C                                                                       
C     CALCULATES THE ANGLE-INDEPENDENT PARTS OF THE MUELLER MATRIX      
C     FOR A GIVEN SET OF K'S, ALL Q'S.                                  
C                                                                       
C                                                                       
C     REFERENCE:  B. A. ROBSON, THE THEORY OF POLARIZATION PHENOMENA    
C     (CLARENDON PRESS, OXFORD, 1974).                                  
C                                                                       
C                                                                       
C     NOTE:  THIS SUBROUTINE REQUIRES 9 LEVELS OF DO-LOOP NESTING       
C     AND 6 ARRAY INDICES.  MAY GIVE TROUBLE ON SOME COMPILERS.         
C                                                                       
C     NOTE ALSO:  THIS SUBROUTINE HAS BEEN TESTED FOR KB=KBIGA=KBIGB=0  
C     (PROJECTILE ANALYZING POWERS) ONLY.  RESULTS FOR OTHER CASES      
C     "SHOULD" BE RIGHT, BUT ARE NOT GUARANTEED.                        
C                                                                       
C                                                                       
C     INPUT SCALARS:                                                    
C                                                                       
C     KA, KB, KBIGA, KBIGB = THE K INDICES OF THE MUELLER MATRIX.       
C     JA, JB, JBIGA, JBIGB = 2 * THE PARTICLE SPINS.                    
C     NQA, NQB, NQBIGA, NQBIGB = THE NUMBER OF Q'S FOR EACH K.          
C        THE Q'S ALWAYS END AT K, AND START AT 0, 1, OR -K.             
C     NSPL = THE NUMBER OF AMPLITUDES (F'S) AT EACH ANGLE.              
C     IPARIT = THE PARITY CHANGE OF THE REACTION (+1 OR -1).            
C                                                                       
C     INPUT ARRAY (AND DIMENSIONS):                                     
C                                                                       
C     ITOC(4,NSPL) = TABLE OF CONTENTS (SEE ANGSET COMMENTS).           
C                                                                       
C     OUTPUT ARRAY (AND DIMENSIONS):                                    
C                                                                       
C     COEF(NQA,NQB,NQBIGA,NQBIGB,NSPL,NSPL) = COEFFICIENT OF            
C        F(KOFF) * F*(KOFFP) IN THE EXPRESSION FOR                      
C        Z(KA, QA, KB, QB, KBIGA, QBIGA, KBIGB, QBIGB),                 
C        FOR ALL KOFF, KOFFP, Q'S; FIXED K'S.                           
C                                                                       
C     SCRATCH ARRAYS (AND DIMENSIONS):                                  
C                                                                       
C     COEP(NQA, NQB) = PROJECTILE 9-J TIMES CLEBSCHES.                  
C     COET(NQBIGA, NQBIGB) = TARGET 9-J TIMES CLEBSCHES.                
C     COEX(KMAX+1) = THIRD 9-J ETC. FOR ALL K.                          
C     TERMK(KMAX+1) = COEX TIMES CLEBSCH, ALL K.                        
C        WHERE  KMAX = MIN( 2*MAX(LX), KA+KB+KBIGA+KBIGB ).             
C                                                                       
C                                                                       
C     10/30/79 - NEW ROUTINE - RPG                                      
C     6/3/80 - FOR CDC, COEF HAS ONLZ 3 DIMENSIONS - S.P.               
C     6/26/80 - DEBUGING PRINTOUT WITH PBUGSW - S.P.                    
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      DIMENSION COEF(NQA,NQB,NQBIGA,NQBIGB,NSPL,NSPL)                   
CDC      DIMENSION  COEF(NQA, NQB, 1)                                   
CDC%'COEF(#,#,#,#,#,#)' = 'COEF(#1, #2,                                 
CDC     1    ((#6*NSPL+#5)*NQBIGB+#4)*NQBIGA+#3                         
CDC     1    - ((NSPL+1)*NQBIGB+1)*NQBIGA )'                            
      DIMENSION ITOC(4, NSPL),  COEP(NQA,NQB), COET(NQBIGA,NQBIGB), COEX
     *(1), TERMK(1)                                                     
      LOGICAL PBUGSW                                                    
C                                                                       
      INTEGER QA, QB, QBIGA, QBIGB, QP, QT, Q, QAS, QBS, QBIGAS, QBIGBS,
     * QPMN, QPMX, QAMN, QAMX, QBMN, QBMX, QPMIN, QPMAX, QTMIN, QTMAX, Q
     *MIN, QMAX                                                         
C                                                                       
CDC      ALLOCLEVEL  COEF, COEP, COET, COEX, TERMK                      
C                                                                       
C     INITIALIZATION                                                    
C                                                                       
 1    JTPRV = -1                                                        
      JTPPRV = -1                                                       
      KTPRV = -1                                                        
      JPPRV = -1                                                        
      JPPPRV = -1                                                       
      KPPRV = -1                                                        
      QAS = KA - NQA + 1                                                
      QBS = KB - NQB + 1                                                
      QBIGAS = KBIGA - NQBIGA + 1                                       
      QBIGBS = KBIGB - NQBIGB + 1                                       
      PARITY = IPARIT                                                   
      N = NSPL*NSPL*NQA*NQB*NQBIGA*NQBIGB                               
      IF (PBUGSW) WRITE(6,3) KA,KB,KBIGA,KBIGB,JA,JB,JBIGA,JBIGB,  
     *NQA, NQB, NQBIGA, NQBIGB, NSPL, IPARIT, N                         
  3   FORMAT ( ' MUELCO...', (T15, 8I12) )                              
      DO 59 I = 1, N                                                    
      COEF(I,1,1,1,1,1) = 0                                             
 59   CONTINUE                                                          
C                                                                       
C     THIS GETS THE FACTORIAL TABLES INTO CORE.                         
C                                                                       
      CALL DUMMY2                                                       
C                                                                       
C     THE OUTER LOOPS ARE OVER THE JP'S AND JT'S.                       
C     THE ACTUAL LOOP PARAMETERS, KOFS AND KOFPS, ARE POINTERS          
C     TO THE FIRST F WITH A GIVEN JP,JT COMBINATION.                    
C                                                                       
      KOFE = 0                                                          
 100  KOFS = KOFE + 1                                                   
      KOFE = KOFS                                                       
      IF ( KOFS .GT. NSPL ) RETURN                                      
      IF ( ITOC(4,KOFS) .LT. 0 ) GO TO 100                              
      JT = ITOC(4,KOFS)                                                 
      JP = ITOC(3,KOFS)                                                 
      LXMN = ITOC(2,KOFS)                                               
C                                                                       
C     SEARCH FOR THE LAST ELEMENT WITH THIS JP,JT.                      
C                                                                       
 110  KOFE = KOFE + 1                                                   
      IF ( KOFE .GT. NSPL ) GO TO 120                                   
      IF ( ITOC(4,KOFE) .EQ. JT .AND. ITOC(3,KOFE) .EQ. JP )  GO TO 110 
 120  KOFE = KOFE - 1                                                   
      LXMX = ITOC(2,KOFE)                                               
C                                                                       
C     NOW DO THE SAME FOR JP', JT'.                                     
C                                                                       
      KOFPE = 0                                                         
 150  KOFPS = KOFPE + 1                                                 
      KOFPE = KOFPS                                                     
      IF ( KOFPS .GT. NSPL ) GO TO 100                                  
      IF ( ITOC(4,KOFPS) .LT. 0 ) GO TO 150                             
      JTP = ITOC(4,KOFPS)                                               
      JPP = ITOC(3,KOFPS)                                               
      LXPMN = ITOC(2,KOFPS)                                             
 160  KOFPE = KOFPE + 1                                                 
      IF ( KOFPE .GT. NSPL ) GO TO 170                                  
      IF ( ITOC(4,KOFPE) .EQ. JTP .AND. ITOC(3,KOFPE) .EQ. JPP )  GO TO 
     *160                                                               
 170  KOFPE = KOFPE - 1                                                 
      LXPMX = ITOC(2,KOFPE)                                             
C                                                                       
C     THE NEXT LOOP IS OVER KT.                                         
C                                                                       
      KTMN = MAX0( IABS( KBIGA-KBIGB ), IABS( JT-JTP )/2 )              
      KTMX = MIN0( KBIGA+KBIGB, (JT+JTP)/2 )                            
C     THIS TEST ELIMINATES JT,JT' COMBINATIONS THAT DON'T CONTRIBUTE.   
      IF ( KTMN .GT. KTMX ) GO TO 150                                   
      DO 599 KT = KTMN, KTMX                                            
C                                                                       
      QTMIN = MAX0( -KT, QBIGBS-KBIGA )                                 
      QTMAX = MIN0( KT, KBIGB-QBIGAS )                                  
      IF ( QTMIN .GT. QTMAX ) GO TO 599                                 
C                                                                       
C     CALCULATE THE FIRST 9-J ETC. IF NECESSARY.                        
C                                                                       
      IF ( KT .EQ. KTPRV .AND. JTP .EQ. JTPPRV  .AND. JT .EQ. JTPRV ) GO
     * TO 250                                                           
      C9JT = (JBIGA+1)*(JBIGB+1)*(2*KBIGA+1)*(JT+1)*(JTP+1)*(2*KT+1)    
      C9JT = DSQRT( C9JT ) * WIG9J( JBIGA, JT, JBIGB,  2*KBIGA, 2*KT, 2*
     *KBIGB, JBIGA, JTP, JBIGB )                                        
      IF (PBUGSW) WRITE(6,203) JT, KT, JTP, C9JT                          
 203  FORMAT ( ' 9J AT 203:', 3I8, G16.6)                               
      KTPRV = KT                                                        
      JTPPRV = JTP                                                      
      JTPRV = JT                                                        
      IF ( C9JT .EQ. 0 ) GO TO 599                                      
C                                                                       
C     CALCULATE THE CLEBSCH'S FOR THIS KT.                              
C                                                                       
      DO 229 IQBIGA = 1, NQBIGA                                         
      QBIGA = IQBIGA + QBIGAS - 1                                       
      DO 219 IQBIGB = 1, NQBIGB                                         
      QBIGB = IQBIGB + QBIGBS - 1                                       
      COET(IQBIGA,IQBIGB) = 0                                           
      IF ( IABS( QBIGB-QBIGA ) .LE. KT )  COET(IQBIGA,IQBIGB) = C9JT * C
     *LEBSH( 2*KBIGA, 2*KT,  2*QBIGA, 2*(QBIGB-QBIGA), 2*KBIGB, 2*QBIGB 
     *)                                                                 
 219  CONTINUE                                                          
 229  CONTINUE                                                          
C                                                                       
 250  IF ( C9JT .EQ. 0 ) GO TO 599                                      
C                                                                       
C     THE NEXT LOOP IS OVER KP.                                         
C                                                                       
      KPMN = MAX0( IABS( KB-KA ), IABS( JP-JPP )/2 )                    
      KPMX = MIN0( KB+KA, (JP+JPP)/2 )                                  
C     THIS TEST ELIMINATES JP,JP' COMBINATIONS THAT DON'T CONTRIBUTE.   
      IF ( KPMN .GT. KPMX ) GO TO 150                                   
      DO 589 KP = KPMN, KPMX                                            
C                                                                       
      QPMIN = MAX0( -KP, QAS-KB )                                       
      QPMAX = MIN0( KP, KA-QBS )                                        
      IF ( QPMIN .GT. QPMAX ) GO TO 589                                 
C                                                                       
C     CALCULATE THE SECOND 9-J SYMBOL ETC. IF NECESSARY                 
C                                                                       
      IF ( KP .EQ. KPPRV .AND. JPP .EQ. JPPPRV  .AND. JP .EQ. JPPRV ) GO
     * TO 285                                                           
      C9JP = (JA+1)*(JB+1)*(2*KB+1)*(JP+1)*(JPP+1)                      
      C9JP = (2*KP+1) * DSQRT( C9JP )  * WIG9J( JB, JP, JA, 2*KB, 2*KP, 
     *2*KA, JB, JPP, JA )                                               
      IF (PBUGSW) WRITE(6,253) JP, KP, JPP, C9JP                          
 253  FORMAT ( ' 9J AT 253:', 3I8, G16.6 )                              
      KPPRV = KP                                                        
      JPPPRV = JPP                                                      
      JPPRV = JP                                                        
      IF ( C9JP .EQ. 0 ) GO TO 589                                      
C                                                                       
C     ... AND THE KP CLEBSCH'S.                                         
C                                                                       
      DO 279 IQA = 1, NQA                                               
      QA = IQA + QAS - 1                                                
      DO 269 IQB = 1, NQB                                               
      QB = IQB + QBS - 1                                                
      COEP(IQA,IQB) = 0                                                 
      IF ( IABS( QA-QB ) .LE. KP ) COEP(IQA,IQB) = C9JP  * CLEBSH( 2*KB,
     * 2*KP, 2*QB, 2*(QA-QB), 2*KA, 2*QA )                              
 269  CONTINUE                                                          
 279  CONTINUE                                                          
C                                                                       
 285  IF ( C9JP .EQ. 0 ) GO TO 589                                      
C                                                                       
C     THE  NEXT 2 LOOPS ARE OVER LX, LX'.                               
C     GET THE INITIAL MX, MX' FROM THE TABLE OF CONTENTS (0 OR 1).      
C                                                                       
      KOFFS = KOFS                                                      
      DO 579 LX = LXMN, LXMX                                            
      MXMN = -LX                                                        
      MXZ = ( ITOC(1,KOFFS) + LX + 1 )/2                                
C                                                                       
      KOFFPS = KOFPS                                                    
      DO 569 LXP = LXPMN, LXPMX                                         
      MXPZ = ( ITOC(1,KOFFPS) + LXP + 1 )/2                             
C                                                                       
C     CALCULATE THE THIRD 9-J ETC. FOR ALL K.                           
C                                                                       
      KMN = MAX0( IABS( LX-LXP ), IABS( KP-KT ), QTMIN-QPMAX )          
      KMX = MIN0( LX+LXP, KP+KT )                                       
      IF ( KMN .GT. KMX ) GO TO 565                                     
C                                                                       
      QMIN = MAX0( -KMX, QTMIN-QPMAX )                                  
      QMAX = MIN0( KMX, QTMAX-QPMIN )                                   
      IF ( QMIN .GT. QMAX ) GO TO 565                                   
      DO 319 K = KMN, KMX                                               
      T = 2*LX + 1                                                      
      COEX(K+1) = (2*K+1) * DSQRT( T )  * WIG9J( 2*LX, JP, JT, 2*K, 2*KP
     *, 2*KT, 2*LXP, JPP, JTP )                                         
      IF (PBUGSW) WRITE(6,313) KT,KP,LX,LXP,K,JP,JT,JPP,JTP,COEX
     *(K+1)                                                             
 313  FORMAT ( ' 9J:', 9I5, G16.6 )                                     
 319  CONTINUE                                                          
C                                                                       
C     THE NEXT 2 LOOPS ARE OVER MX, MX'.  THE Q SUM IS FORMAL.          
C                                                                       
      DO 559 MX = MXMN, LX                                              
      KOFF = KOFFS + IABS( MX ) - MXZ                                   
      IF ( KOFF .LT. KOFFS ) GO TO 559                                  
      FACT = 1.                                                         
      IF ( MX .GE. 0 ) GO TO 330                                        
      FACT = PARITY                                                     
      IF ( MOD( LX+MX, 2 ) .NE. 0 ) FACT = -FACT                        
C                                                                       
 330  MXPMN = MAX0( -LXP, MX+QMIN )                                     
      MXPMX = MIN0( LXP, MX+QMAX )                                      
      IF ( MXPMN .GT. MXPMX ) GO TO 559                                 
      DO 549 MXP = MXPMN, MXPMX                                         
      KOFFP = KOFFPS + IABS( MXP ) - MXPZ                               
      IF ( KOFFP .LT. KOFFPS ) GO TO 549                                
      FAC = FACT                                                        
      IF ( MXP .GE. 0 ) GO TO 350                                       
      FAC = FAC*PARITY                                                  
      IF ( MOD( LXP+MXP, 2 ) .NE. 0 ) FAC = -FAC                        
C                                                                       
 350  Q = MXP - MX                                                      
C                                                                       
C     NOW CALCULATE THE K CLEBSCH FOR ALL K.                            
C                                                                       
      KMIN = MAX0( KMN, IABS( Q ) )                                     
      DO 389 K = KMIN, KMX                                              
      TERMK(K+1) = FAC * COEX(K+1)  * CLEBSH( 2*LX, 2*K, 2*MX, 2*Q, 2*LX
     *P, 2*MXP )                                                        
 389  CONTINUE                                                          
C                                                                       
C     THE NEXT LOOP IS OVER QP.  THE QT SUM IS FORMAL.                  
C     LIMITS ON Q (VIA MXP ) INSURE THAT THE LOOP IS NOT NULL.          
C                                                                       
      QPMN = MAX0( QPMIN, QTMIN-Q )                                     
      QPMX = MIN0( QPMAX, QTMAX-Q )                                     
      DO 529 QP = QPMN, QPMX                                            
      QT = Q + QP                                                       
C                                                                       
C     ACCUMULATE THE SUM OVER K (INCLUDING ONE 9-J, TWO CLEBSCH'S,      
C     AND SOME STATISTICAL FACTORS).                                    
C                                                                       
      SUMK = 0                                                          
      DO 409 K = KMIN, KMX                                              
      SUMK = SUMK + TERMK(K+1)  * CLEBSH( 2*K, 2*KP, 2*Q, 2*QP, 2*KT, 2*
     *QT )                                                              
 409  CONTINUE                                                          
C                                                                       
C     THE INNERMOST 2 LOOPS ARE OVER QBIGA AND QB.                      
C     LIMITS APPLIED TO QT AND QP INSURE THAT NEITHER LOOP IS NULL.     
C                                                                       
      QAMN = MAX0( QBIGAS, QBIGBS-QT )                                  
      QAMX = MIN0( KBIGA, KBIGB-QT )                                    
      QBMN = MAX0( QBS, QAS-QP )                                        
      QBMX = MIN0( KB, KA-QP )                                          
      DO 519 QBIGA = QAMN, QAMX                                         
      IQBIGA = QBIGA - QBIGAS + 1                                       
      QBIGB = QBIGA + QT                                                
      IQBIGB = QBIGB - QBIGBS + 1                                       
      TERMT = SUMK * COET(IQBIGA,IQBIGB)                                
      IF ( TERMT .EQ. 0 ) GO TO 519                                     
      DO 509 QB = QBMN, QBMX                                            
      IQB = QB - QBS + 1                                                
      QA = QB + QP                                                      
      IQA = QA - QAS + 1                                                
      TERM = TERMT * COEP(IQA,IQB)                                      
C                                                                       
C     FINALLY, THE ANSWER:                                              
C                                                                       
      COEF(IQA,IQB,IQBIGA,IQBIGB,KOFF,KOFFP)  = COEF(IQA,IQB,IQBIGA,IQBI
     *GB,KOFF,KOFFP) + TERM                                             
C                                                                       
      IF (PBUGSW) WRITE(6,503) QB,QBIGA,QP,MXP,MX,IQA,IQB,KOFFP,K
     *OFF, IQBIGA, IQBIGB, SUMK, TERMT, TERM                            
 503  FORMAT( ' COEF:', 11I5, 3G15.5 )                                  
 509  CONTINUE                                                          
C     END OF QB LOOP.                                                   
C                                                                       
 519  CONTINUE                                                          
C     END OF QBIGA LOOP.                                                
C                                                                       
 529  CONTINUE                                                          
C     END OF QP LOOP.                                                   
C                                                                       
 549  CONTINUE                                                          
C     END OF MXP LOOP.                                                  
C                                                                       
 559  CONTINUE                                                          
C     END OF MX LOOP.                                                   
C                                                                       
C     INCREMENT KOFFPS FOR THE NEXT LXP.                                
C                                                                       
 565  KOFFPS = KOFFPS + LXP - MXPZ + 1                                  
 569  CONTINUE                                                          
C     END OF LXP LOOP.                                                  
C                                                                       
C     INCREMENT KOFFS FOR THE NEXT LX.                                  
C                                                                       
      KOFFS = KOFFS + LX - MXZ + 1                                      
 579  CONTINUE                                                          
C     END OF LX LOOP.                                                   
C                                                                       
 589  CONTINUE                                                          
C     END OF KP LOOP.                                                   
C                                                                       
 599  CONTINUE                                                          
C     END OF KT LOOP.                                                   
C                                                                       
C     GO BACK FOR THE NEXT JP', JT'.                                    
C                                                                       
      GO TO 150                                                         
      END                                                               
      SUBROUTINE NSDUMP ( IDUMP, NSKEY )                                
C                                                                       
C  NSDUMP PRINTS OBJECTS IN NUMBERED STORAGE                            
C                                                                       
C     IDUMP - NUMBER OF OBJECT TO BE PRINTED;                           
C             IF ZERO, ALL OBJECTS ARE PRINTED.                         
C                                                                       
C     NSKEY - TYPE OF PRINTOUT DESIRED -                                
C       1 - AUTOMATIC (DEFAULT REAL ON OTHER MACHINES)                  
C       2 - REAL*4                                                      
C          ( FOR 2&3 REAL VERSUS INT IS DETERMINED NUMBER BY NUMBER)    
C       4 - INTEGER*2                                                   
C       5 - HEXADECIMAL (OCTAL AS APPROPRIATE)                          
C       6 - REAL*8                                                      
C                                                                       
C     7/24/79 - NSDUMP SEPARATED FROM IALLOC - S.P.                     
C     2/7/80 - DETERMIN TYPE OF DATA BEING PRINTED - S.P.               
C     3/18/80 - TYPE 6 FORCES REAL*8 - S.P.                             
C     3/24/80 - BASE 4-BYTE DETECTION ON NUMBER OF OCCURANCES - S.P.    
C     6/3/80 - FIXES FOR CDC VERSION - S.P.                             
C     7/14/80 - CRAY VERSION - S.P.                                     
C     7/16/80 - CDM, CDO PREFIXES - S.P.                                
C     7/22/80 - CAN'T MIX I-FMT WITH REAL DATA ON CRAY - S.P.           
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) )                                                          
C                                                                       
      real*8 NAMES                                                      
      COMMON /NAMCOM/ NAMES(1)                                          
      COMMON /LENGTH/ LENG(1)                                           
C                                                                       
      COMMON /INTRNL/ UNDEF, NOTDEF                                     
C                                                                       
CDO           real*8  FMTS(22) / '(', 20*' ', ')' /                     
      real*8 FMTS(22)                                                   
      real*8 IFMT / 'I13,' /                                            
CRA           real*8  IFMT / 'F13.0,'/                                  
      real*8 NOTFMT(2) /'7X,', '6HNOTDEF'/,  GFMT /'G13.5,'/            
CDC     1  GFMT /'E13.5,'/                                              
C                                                                       
      REAL*4 BUFFER(10)                                                 
      INTEGER IBUF(10)                                                  
      EQUIVALENCE ( BUFFER(1), IBUF(1) )                                
C                                                                       
CIB      LOGICAL R8SW                                                   
CIB      LOGICAL*1  EXPMSK /Z7F/,  ZEREXP /Z40/                         
CIB      REAL*8  DOUBLE                                                 
      INTEGER*4 INTGER(2)                                               
      REAL*4 SINGLE(2)                                                  
CIB      LOGICAL*1  ONEBYT(8)                                           
      EQUIVALENCE ( INTGER(1), SINGLE(1) )                              
CIB      EQUIVALENCE ( DOUBLE, INTGER(1), ONEBYT(1) )                   
C                                                                       
C                                                                       
      LOGICAL NSPTSW                                                    
      COMMON/USAGE/IBASE, NWORDS, IMAX, INAME, IGOT, NLOC, IPEAK, NAMPEK
     *, NUMCOM, ICHEC, THENAM, IWASAT, NAMLC2, NSPTSW                   
C                                                                       
      DATA  FMTS / 1H(, 20*1H , 1H) /                                   
C                                                                       
C     SETUP SIZE OF EACH WORD TO PRINT                                  
C                                                                       
      GO TO ( 110, 120, 120, 130, 120, 110 ), NSKEY                     
C                                                                       
 110  IFAC = 1                                                          
      GO TO 200                                                         
 120  IFAC = FACFR4                                                     
      GO TO 200                                                         
 130  IFAC = FACFR2                                                     
      GO TO 200                                                         
C                                                                       
C                                                                       
 200  NSTRT = 1                                                         
      NEND = INAME                                                      
      IF ( IDUMP .EQ. 0 ) GO TO 230                                     
      NSTRT = IDUMP                                                     
      NEND = IDUMP                                                      
C                                                                       
 230  DO 879 NUMLOC = NSTRT, NEND                                       
      LX = Z(NUMLOC)                                                    
      IF ( LX .LE. 0 ) GO TO 879                                        
      LX = IFAC*LX - IFAC                                               
      LLX=LENG(NUMLOC)                                                  
      LLX = IFAC*LLX                                                    
      IF ( NSKEY .LE. 3 .OR. NSKEY .EQ. 6 ) GO TO 400                   
      WRITE(6, 257)NUMLOC, NAMES(NUMLOC), LLX                           
 257  FORMAT(/'  ----NUMBERED OBJECT',I6,'  NAMED ', A8,  '  WITH', I6, 
     *' ELEMENTS----' /)                                                
C                                                                       
      GO TO ( 310, 320, 330, 340, 350 ), NSKEY                          
C                                                                       
C                                                                       
C     NOTE...  FOR NSKEY=1, 2 3 OR 6 WE NEVER REALLY GET HERE           
C     AND THUS 310 THROUGH 330 ARE REALLY NOT USED ANYMORE.             
C                                                                       
 310  WRITE(6,313) ( ALLOC(LX+I), I = 1, LLX )                            
 313  FORMAT ( 1X, 10G13.5 )                                            
      GO TO 879                                                         
 320  WRITE(6,313) ( ALLOC4(LX+I), I = 1, LLX )                           
      GO TO 879                                                         
 330  WRITE(6,333) ( ILLOC(LX+I), I = 1, LLX )                            
 333  FORMAT ( 1X, I10, 9I13 )                                          
      GO TO 879                                                         
 340  WRITE(6,333) ( ILLOC2(LX+I), I = 1, LLX )                           
      GO TO 879                                                         
 350  WRITE(6,353) ( ILLOC(LX+I), I = 1, LLX )                            
CIB 353     FORMAT ( 5( Z10, Z9 ) )                                     
 353  FORMAT ( 5( Z10, Z9 ) )                                           
CRA 353     FORMAT ( 5( Z10, Z9 ) )                                     
CDC 353     FORMAT ( 5O22 )                                             
CUN 353     FORMAT ( 10O13 )                                            
      GO TO 879                                                         
C                                                                       
C     DUMP, DUMP8, DUMPR4, DUMPI4.  HERE WE ATTEMPT TO DETERMIN THE     
C     NATURE OF THE NUMBER AND PRINT IT ACCORDINGALLY.                  
C     IF IT HAS BEEN DECLAIRED AS 4- OR 8-BYTE DATA, WE ACCEPT          
C     THIS.  ELSE WE TRY TO SEE IF IT SHOULD BE TREATED AS              
C     FOUR-BYTE OR EIGHT-BYTE.                                          
C                                                                       
C     ON CDC & CRAY THERE IS, OF COURSE NO DIFFERENCE                   
C     THIS HAS NOT YET BEEN THOUGHT ABOUT FOR THE VAX.                  
C                                                                       
 400  ASSIGN 510 TO IGOTO                                               
      IF ( NSKEY .EQ. 6 ) ASSIGN 600 TO IGOTO                           
CIB         I4 = 0                                                      
CIB         IZERO = 0                                                   
CIB         R8SW = .FALSE.                                              
CIB         IF ( NSKEY .NE. 1 )  GO TO 500                              
CIB         DO 449  I = 1, LLX                                          
CIB            DOUBLE = ALLOC(LX+I)                                     
CIB            IF ( INTGER(1) .NE. NOTDEF )  GO TO 410                  
CIBC                                                                    
CIBC     FIRST WORD IS NOTDEF; INORDER TO BE DOUBLE PRECISION,          
CIBC     SECOND MUST BE ZERO.                                           
CIBC                                                                    
CIB            IF ( INTGER(2) .NE. 0 )  GO TO 470                       
CIB            GO TO 449                                                
CIBC                                                                    
CIBC     IF IT IS A DOUBLE WORD OF ZEROS THEN WE CAN'T TELL ANYTHING    
CIBC     WE USE FLOATING POINT ZEROS CHECKS TO CATCH FLOATING -0        
CIBC                                                                    
CIB 410        IF ( SINGLE(1) .NE. 0 )  GO TO 420                       
CIB            IF ( SINGLE(2) .NE. 0 )  GO TO 470                       
CIB            IZERO = IZERO + 1                                        
CIB            GO TO 449                                                
CIBC                                                                    
CIBC     IS IT AN INTEGER  (I.E. FLOATING POINT EXPONENT OF 00 OR FF)   
CIBC                                                                    
CIB 420        IF ( IABS(INTGER(1)) .LT. 16000000 )  GO TO 470          
CIBC                                                                    
CIBC     IT IS REAL; IS SECOND WORD A REASONABLE INTEGER.  HERE WE      
CIBC     ASSUME THAT THE UNLIKELY SEQUENCE OF 16 0'S OR 16 1'S          
CIBC     DOES NOT APPEAR IN THE MIDDLE OF THE DOUBLE PRECISION NUMBER.  
CIBC     IF IT IS ALL ZEROS, WE MUST ASSUME IT IS THE TAIL OF AN        
CIBC     EXACT FLOATING POINT NUMBER.                                   
CIBC                                                                    
CIB            IF ( INTGER(2) .EQ. 0 )  GO TO 449                       
CIB            IF ( IABS(INTGER(2)) .LT. 32000 )  GO TO 430             
CIB            IF ( INTGER(2) .EQ. NOTDEF )  GO TO 470                  
CIBC                                                                    
CIBC     NOW CHECK FOR A REASONALBLE FLOATING POINT NUMBER.             
CIBC     IS IT NORMALIZED?  IS EXPONENT MODERATE?                       
CIBC                                                                    
CIB            IF ( ONEBYT(6) .LT. 16 )  GO TO 440                      
CIB            IF ( IABS( LAND(EXPMSK, ONEBYT(5))-ZEREXP ) .GT. 10 )    
CIB     1         GO TO 449                                             
CIB 430        I4 = I4+1                                                
CIB            GO TO 449                                                
CIB 440        R8SW = .TRUE.                                            
CIB 449     CONTINUE                                                    
CIBC                                                                    
CIBC     WE NEVER FOUND A DEFINET INDICATOR; IS IT LIKELY TO BE         
CIBC     REAL*4?                                                        
CIBC     IF 50% OF THE NON-ZERO WORDS ARE REASONABLE 4-BYTE             
CIBC     INFORMATION, THEN WE USE THEM.                                 
CIBC                                                                    
CIB         ASSIGN 600 TO IGOTO                                         
CIB         IF ( R8SW .OR.  2*I4 .LT. LLX-IZERO )                       
CIB     1      GO TO 500                                                
CIBC                                                                    
CIBC     IT APPEARS TO BE 4-BYTE INFORMATION                            
CIBC                                                                    
CIB 470     LLX = 2*LLX                                                 
CIB         LX = 2*LX                                                   
CIB         ASSIGN 510 TO IGOTO                                         
C                                                                       
C     NOW PRINT ARRAY CHECKING EACH ELEMENT FOR INTEGER VS REAL         
C                                                                       
 500  WRITE(6,257) NUMLOC, NAMES(NUMLOC), LLX                             
      I1 = 2                                                            
      I2 = 1                                                            
      DO 699 I = 1, LLX                                                 
      GO TO IGOTO, ( 510, 600 )                                         
 510  INTGER(1) = ILLOC(LX+I)                                           
C                                                                       
C     DETERMIN HOW TO PRINT THIS NUMBER                                 
C     GET RID OF FLOATING POINT -0                                      
C                                                                       
      IF ( INTGER(1) .EQ. NOTDEF ) GO TO 550                            
      IF ( SINGLE(1) .EQ. 0 ) SINGLE(1) = 0                             
      IF ( IABS(INTGER(1)) .LT. 16000000 ) GO TO 530                    
C                                                                       
C     IT IS FLOATING POINT                                              
C                                                                       
      FMTS(I1) = GFMT                                                   
      GO TO 535                                                         
C     IT IS INTEGER                                                     
 530  FMTS(I1) = IFMT                                                   
CCRA                                                                    
CCRA     ON CRAY MUST HAVE AGREEMENT BETWEEN FMT AND ARRAY              
CCRA                                                                    
CRA      SINGLE(1) = INTGER(1)                                          
 535  I1 = I1 + 1                                                       
      IBUF(I2) = INTGER(1)                                              
      I2 = I2+1                                                         
      GO TO 650                                                         
C                                                                       
C     IT IS NOT DEFINED                                                 
C                                                                       
 550  FMTS(I1) = NOTFMT(1)                                              
      FMTS(I1+1) = NOTFMT(2)                                            
      I1 = I1+2                                                         
      GO TO 650                                                         
C                                                                       
C     REAL*8                                                            
C                                                                       
 600  IF ( ALLOC(LX+I) .EQ. UNDEF ) GO TO 550                           
      BUFFER(I2) = ALLOC(LX+I)                                          
      FMTS(I1) = GFMT                                                   
      I2 = I2+1                                                         
      I1 = I1+1                                                         
C                                                                       
C     HAVE WE FILLED UP AN OUTPUT LINE                                  
C                                                                       
 650  IF ( MOD(I,10) .NE. 0 .AND. I .NE. LLX ) GO TO 699                
      FMTS(I1) = FMTS(22)                                               
      I2 = I2-1                                                         
      IF ( I2 .EQ. 0 ) GO TO 670                                        
      WRITE ( 6, FMTS ) ( BUFFER(II), II = 1, I2 )                      
      GO TO 680                                                         
 670  WRITE ( 6, FMTS )                                                 
 680  I1 = 2                                                            
      I2 = 1                                                            
 699  CONTINUE                                                          
C                                                                       
 879  CONTINUE                                                          
      RETURN                                                            
      END
      
      SUBROUTINE NXINT(INTARG,*,*,*)                                    
CDC      SUBROUTINE NXINT ( INT, VALARG ),                              
CDC     1  RETURNS( IRTRN1, IRTRN2, IRTRN3, IRTRN4 )                    
C                                                                       
C     THE INPUT INTERFACE                                               
C                                                                       
C     ABNORMAL RETURNS ARE                                              
C     1)  WRONG TYPE OF FIELD ENCOUNTERED.                              
C     2)  SEMICOLON ENCOUNTERED.                                        
C     3)  OTHER SPECIAL CHARACTER ENCOUNTERED.                          
C     FOR TYPES 1) AND 3) THE SAME FIELD WILL BE RESCANED FOR THE       
C     NEXT CALL TO ONE OF THESE ENTRES.  FOR TYPE 2) THE ; IS           
C     NOT RESCANNED.                                                    
C                                                                       
C                                                                       
C  THIS ROUTINE IS ADOPTED FROM ONE WITH SAME NAME WRITTEN BY           
C  STAN COHEN FOR THE ARGONNE SHELL MODEL PROGRAMS                      
C                                                                       
C     5/7/75 - EXTENSIVE CHANGES FOR PTOLEMY - S. PIEPER                
C     5/21/75 - SMALL FIXES TO ABOVE.                                   
C    8/15/75 - NEW ENTRY FITKEY,NXVALF ADDED  D.G.                      
C     12/28/79 - STANDARD MORTRAN - RPG                                 
C     1/11/80 - SEPARATE CVALU ARGUMENT TO MSCAN - RPG                  
C     1/16/80 - INT, VAL, CVALU ARE LOCAL VARIABLES, AND INTARG, VALARG,
C        CVARG ARE ARGUMENTS - RPG                                      
C     3/15/80 - PUT IN MARK'S FIX OF USING () AS TOKENS - S.P.          
C               ALSO PUT IN MARK'S IMPROVED TEST FOR INTEGERS - S.P.    
C     5/30/80 - FIX VALARG IN CDC SUBROUTINE LINE - S.P.                
C     12/7/80 - FITKEY SETS UP RESCAN FOR 4TH RETURN - S.P.             
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
C                                                                       
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/IASYMP,ICHECK,IECHO,IELAST,IFIT,IVRTEX,IRLWAV, 
     * ITSO,LINEAR,NUCONL,NEXT,IFITER,IEPOW,ISAVMX,ISAVB,LABANG, 
     * PROBLM,MASTYP,R0TYPE,IBSPAS,ISW1,ISW2,ISW3,ISCRFL,NOBFAC, 
     * CONVRG,IEXTYP,IBRNSB,MEORD,KFRMTP,IWRTWV,LORNTZ,IRELPT,ISAVSM                                                            
C                                                                       
      CHARACTER*1 STOP, SLASH, PLUS, MINUS                              
      DATA MINUS/'-'/                                                    
      DATA PLUS/'+'/                                                     
      DATA SLASH/'/'/                                                    
      CHARACTER*8 CVALU, CVARG                                          
      DATA KEYEX / 11 /                                                 
C                                                                       
C                                                                       
C                                                                       
C     THE SCANNER                                                       
C                                                                       
C     AN INTEGER HAS BEEN REQUESTED - WE ACCEPT ANYTHING THAT IS EQUAL  
C     TO ITS INTEGER PART.                                              
C                                                                       
      KEY=2                                                             
      GO TO 50                                                          
  200 IF ( ICD .NE. -2 .AND. ICD .NE. -5 ) GO TO 2000                   
      IF ( VAL .NE. INT ) GO TO 2000                                    
C     DO NOT ACCEPT HALF-INTEGERS                                       
      IF ( STOP .EQ. SLASH ) GO TO 2000                                 
      INTARG = INT                                                      
      RETURN                                                            
C                                                                       
C                                                                       
C     GET NEXT FIELD                                                    
C                                                                       
 50   INCHST = INCH                                                     
      CALL MSCAN( KEYEX, ICD, CVALU, VAL, INT, IBUFN, IMESS, STOP )     
      IF ( ICD .NE. -8 ) GO TO 52                                       
C                                                                       
C     TIME TO READ A NEW CARD AND THEN TRY AGAIN                        
C                                                                       
      READ(5,5001)IBUF                                                  
5001  FORMAT(80A1)                                                      
      INCH = 1                                                          
      IMX = 72                                                          
      IF ( ITSO .EQ. 0 ) IMX = 80                                       
      IF ( IECHO .NE. 0 ) WRITE(6,7002) ( IBUF(I), I = 1, IMX )           
7002  FORMAT( ' INPUT... ',80A1 )                                       
      GO TO 50                                                          
C                                                                       
 52   IF ( ICD .EQ. 0 ) GO TO 50                                        
      GO TO (810, 200, 300, 550, 500, 310, 2000, 800, 2000, 860), KEY   
C                                                                       
      ENTRY NXVAL(VALARG,*,*,*)                                         
      KEY=3                                                             
      GO TO 50                                                          
 300  IF ( ICD .NE. -2 .AND. ICD .NE. -5 ) GO TO 2000                   
C     DO NOT ACCEPT HALF-INTEGERS                                       
      IF ( STOP .EQ. SLASH ) GO TO 2000                                 
      VALARG = VAL                                                      
      RETURN                                                            
C                                                                       
C                                                                       
C                                                                       
      ENTRY NXVALF(VALARG,*,*,*,*)                                      
      KEY=6                                                             
      KEYEX=12                                                          
      GO TO 50                                                          
310   KEYEX = 11                                                        
      IF(ICD.EQ.11)RETURN 4                                             
      GO TO 300                                                         
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C     J OR JP VALUES:  FORMS ARE  5 , 5+ , 5- , 5/2 , 5/2+ , 5/2-       
C       THE OPTIONAL PARITY SIGN IS IGNORED.                            
C                                                                       
      ENTRY NXHINT(INTARG,*,*,*)                                        
      KEY=5                                                             
      GO TO 50                                                          
  500 IF (ICD.NE.-5)GO TO 2000                                          
      INTARG = INT*2                                                    
      IF ( STOP .NE. SLASH ) GO TO 570                                  
      IINT = INTARG/2                                                   
      INTARG = IINT                                                     
      INCH = INCH + 1                                                   
      KEY = 4                                                           
      GO TO 50                                                          
 550  IF ( ICD .NE. -5 .OR. INT .NE. 2 ) GO TO 2050                     
      INTARG = IINT                                                     
C     SKIP TRAILING SIGN                                                
 570  IF ( STOP .EQ. PLUS .OR. STOP .EQ. MINUS ) INCH = INCH+1          
      RETURN                                                            
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C                                                                       
      ENTRY NXWORD(CVARG,*,*,*)                                         
      KEY=8                                                             
      GO TO 50                                                          
  800 IF(ICD.NE.-1)GO TO 2000                                           
      CVARG = CVALU                                                     
      RETURN                                                            
C                                                                       
C                                                                       
C                                                                       
      ENTRY FITKEY(CVARG,*,*,*,*)                                       
C                                                                       
C     RETURNS ARE                                                       
C       NORMAL - KEYWORD WAS FOUND.                                     
C       1 - (      2 - =      3 - )    FOUND; NO RESCAN                 
C       4 - ANYTHING ELSE FOUND - WILL BE RESCANNED.                    
C                                                                       
      KEY=1                                                             
      KEYEX=12                                                          
      GO TO 50                                                          
810   KEYEX = 11                                                        
      CVARG = CVALU                                                     
      IF(ICD.EQ.-1)RETURN                                               
      IF(ICD.EQ.10)RETURN 1                                             
      IF(ICD.EQ.11)RETURN 3                                             
      IF(ICD.EQ.12)RETURN 2                                             
      INCH = INCHST                                                     
      RETURN 4                                                          
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C                                                                       
CCCC      ENTRY NXFLD(INTARG)                                           
CCCC      KEY=10                                                        
CCCC      GO TO 50                                                      
  860 INTARG = ICD                                                      
      RETURN                                                            
C                                                                       
C                                                                       
C     NOT FOUND; RESCAN SAME FIELD NEXT TIME.                           
C                                                                       
 2000 IF (ICD.EQ.5) RETURN 2                                            
      INCH = INCHST                                                     
      IF (ICD.LT.0) RETURN 1                                            
      RETURN 3                                                          
C                                                                       
2050  WRITE(6,5004) INT                                                 
5004  FORMAT('0**** NUMBER FOLLOWING / MUST BE 2', I10 )                
      RETURN 1                                                          
C                                                                       
C                                                                       
C                                                                       
C     FORCE NEW CARD OR GET STARTED.                                    
C                                                                       
      ENTRY NEWCD                                                       
C                                                                       
CDC      END                                                            
CDC      SUBROUTINE NEWCD                                               
CDC      COMMON /INPBUF/ NOCH, INCH, IBUF(80)                           
C                                                                       
      NOCH = 72                                                         
      INCH = NOCH + 1                                                   
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE PARAM ( IRET )                                         
C                                                                       
C     SETS UP CANNED PACKAGES OF PARAMETERS                             
C                                                                       
C     2/20/75 - MADE FROM CONTRL AND DEFALT - S.P.                      
C     3/5/75 - FIX BUG IN DVRS1W1                                       
C     4/17/75 - NEW COMMONS                                             
C     5/30/75 - FIX ERROR MESSAGE.                                      
C     6/14/75 - FIRST SETS OF INTEGRATION PARAMETERS                    
C     6/27/75 - STEPSPER ADDED                                          
C     7/28/75 - ALL MIDMULT'S ARE 1.                                    
C     8/28/75 - LMAXTMULT, LMINMULT, NO MIDMULT                         
C     9/25/75 - NEW DWCUTOFF; REMOVE VCUTOFF                            
C     9/30/75 - LMAXMULT BECOMES LMAXADD                                
C     2/16/76 - FIX /INTGER/ COMMON BLOCK                               
C     2/29/76 - REDUCE LARGE ASYMPTOPIA VALUES IN PB SERIES             
C     6/19/76 - REMOVE DEVRIES; STUFF FOR POINTS PER.                   
C     8/11/76 - SMALL GRIDS FOR INTERPOLATION                           
C     10/3/76 - MORE SMALL GRIDS                                        
C     1/12/76 - INELASTIC PARAMETER SETS                                
C     5/9/77 - LMINSUB, LMAXADD; ELASTIC PARAMS                         
C     11/22/77 - FIX ALMXMT ERROR; SPLIT ASYMPTOPIAS - S.P.             
C     3/19/78 - ALPHA SETS - S.P.                                       
C     4/20/78 - HUGH MAXLEX FOR INELASTIC SETS - S.P.                   
C     12/28/79 - STANDARD MORTRAN - RPG                                 
C     1/16/80 - MOVE CFR%F DOWN; CHARACTER*8 DATANM - RPG               
C     2/28/80 - PARAMETERSETS DPSA, DPDA, DPSB, DPDB; ADD PHIMID,       
C        MIDMULT - RPG                                                  
C     3/20/80 - SET ACCURACY FOR INELASTIC SETS - S.P.                  
C     6/28/81 - POWER EXTRAPOLATION FOR INELASTIC SETS - 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 )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
C                                                                       
      CHARACTER*8 DATANM                                                
C                                                                       
      DATA NUMDAT / 16 /                                                
      CHARACTER*8 DATAS(16)                                             
      DATA DATAS / 'CA60A', 'CA60B', 'PB100A', 'PB100B', 'PB100C',  
     *'PBO1A','PBO1B', 'PBO1C', 'PBO1D','ALPHA1','ALPHA2','ALPHA3',
     *'DPSA', 'DPDA', 'DPSB', 'DPDB' /                                   
      INTEGERDATNUM(16)                                                 
      DATADATNUM/1, 2, 3, 4, 5, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13/    
C                                                                       
C     FOLLOWING ARE THE GRID PARAMETERS                                 
C     EACH ROW CORRESPONDS TO A DIFFERENT DATA WORD                     
C                                                                       
C     FIRST THE REAL VALUES                                             
C     THEY ARE IN THE ORDER                                             
C      DWCUT, SUMPOINT, STPSPR, GAMSUM, GAMDIF, BNDASY, ALMNMT, ALMXMT, 
C      SCTASY, PHIMID, MIDMULT                                          
C                                                                       
      REAL*8 RGRIDS(11,13)                                              
      DATA RGRIDS/1.D-2, 6.D0, 12.D0, 5.D0, 5.D0, 20.D0, .60D0, 1.50D0, 
     *15.D0, .50D0, 2.D0, 1.D-3, 6.D0, 20.D0, 5.D0, 5.D0, 25.D0, .50D0, 
     *1.70D0, 20.D0, .50D0, 2.D0, 1.D-3, 2.50D0, 8.D0, 1.D-2, 3.D0, 45.D
     *0, .86D0, 1.60D0, 20.D0, .50D0, 2.D0, 3.D-4, 3.00D0, 12.D0, 1.D-2,
     * 3.D0, 50.D0, .78D0, 1.80D0, 23.D0, .50D0, 2.D0, 1.D-4, 3.50D0, 16
     *.D0, 1.D-2, 3.D0, 55.D0, .70D0, 2.00D0, 26.D0, .50D0, 2.D0, 1.D-5,
     * 4.00D0, 20.D0, 1.D-2, 3.D0, 60.D0, .60D0, 2.20D0, 30.D0, .50D0, 2
     *.D0, 1.D-3, 6.00D0, 12.D0, 3.D0, 5.D0, 20.D0, .60D0, 1.50D0, 15.D0
     *, .50D0, 2.D0, 1.D-4, 7.00D0, 20.D0, 3.D0, 5.D0, 25.D0, .50D0, 1.7
     *0D0, 20.D0, .50D0, 2.D0, 1.D-5, 8.00D0, 25.D0, 3.D0, 5.D0, 30.D0, 
     *.40D0, 2.00D0, 24.D0, .50D0, 2.D0, 2.D-5, 6.00D0, 5.D0, 2.D0, 12.D
     *0, 20.D0, 0.0D0, 1.60D0, 20.D0, .20D0, .90D0, 2.D-6, 6.00D0, 5.D0,
     * 2.D0, 20.D0, 20.D0, 0.0D0, 1.60D0, 20.D0, .15D0, .90D0, 2.D-6, 8.
     *00D0, 8.D0, 2.D0, 12.D0, 20.D0, 0.0D0, 2.00D0, 20.D0, .20D0, .90D0
     *, 5.D-7, 8.00D0, 8.D0, 2.D0, 20.D0, 20.D0, 0.0D0, 2.00D0, 20.D0, .
     *15D0, .90D0/                                                      
C                                                                       
C     NEXT THE INTEGERS.  THEY ARE IN THE ORDER                         
C       NPSUM, NPDIF, NPPHI, NPHIAD, LSTEP, LMAXAD, LMINSB              
C                                                                       
      INTEGERIGRIDS(7,13)                                               
      DATAIGRIDS/10, 10, 10, 4, 3, 15, 10, 15, 13, 12, 4, 2, 20, 15, 10,
     * 8, 10, 4, 5, 30, 12, 15, 10, 12, 4, 4, 35, 16, 20, 14, 16, 4, 3, 
     *40, 20, 30, 18, 20, 4, 2, 45, 25, 40, 25, 12, 4, 2, 15, 10, 50, 30
     *, 14, 4, 1, 20, 15, 70, 35, 16, 4, 1, 25, 20, 20, 20, 10, 4, 1, 10
     *, 8, 20, 30, 15, 4, 1, 10, 8, 40, 40, 20, 4, 1, 12, 10, 40, 60, 30
     *, 4, 1, 12, 10/                                                   
C                                                                       
C                                                                       
C     FOLLOWING ARE FOR INELASTIC SCATTERING                            
C                                                                       
      DATA NUMINL / 3 /                                                 
      CHARACTER*8 DATINL(3)                                             
      DATA DATINL/'INELOCA1', 'INELOCA2', 'INELOCA3'/                   
C                                                                       
C     INELASACC, DWCUTOFF, STEPSPER, SUMPOINT, SCTASYMPT,               
C     ALMXMT, ACCURACY                                                  
C                                                                       
      REAL*8 GRIDIN(7,3)                                                
      DATA GRIDIN/1.D-3, 1.D-3, 15.D0, 6.D0, 20.D0, 1.60D0, 1.D-2, 1.D-4
     *, 1.D-4, 20.D0, 8.D0, 25.D0, 2.00D0, 5.D-3, 1.D-6, 1.D-5, 25.D0, 1
     *2.D0, 30.D0, 2.60D0, 1.D-3/                                       
C                                                                       
C     LMAXADD, NPCOULOMB                                                
C                                                                       
      INTEGERIGRIDI(2,3)                                                
      DATAIGRIDI/20, 6, 30, 8, 50, 10/                                  
C                                                                       
C     FOLLOWING ARE FOR ELASTIC SCATTERING                              
C                                                                       
      DATA NUMEL /3/                                                    
      CHARACTER*8 DATEL(3)                                              
      DATA DATEL/'EL1', 'EL2', 'EL3'/                                   
C                                                                       
C     STEPSPER, SCTASYMPT, ALMNMT, ALMXMT, FITACC                       
C                                                                       
      REAL*8 GRIDEL(5,3)                                                
      DATA GRIDEL/12.D0, 15.D0, .70D0, 1.60D0, 2.D-3, 15.D0, 20.D0, .60D
     *0, 1.80D0, 2.D-4, 20.D0, 25.D0, .50D0, 2.00D0, 2.D-5/             
C                                                                       
C     LMINSB, LMAXAD                                                    
C                                                                       
      INTEGERIGRIDE(2,3)                                                
      DATAIGRIDE/15, 15, 20, 20, 25, 25/                                
C                                                                       
      IRET = 0                                                          
      CALL NXWORD ( DATANM, &80, &80, &80 )                             
      DO 59 N = 1, NUMDAT                                               
      IF ( DATANM .EQ. DATAS(N) ) GO TO 100                             
 59   CONTINUE                                                          
C                                                                       
      DO 64 N = 1, NUMINL                                               
      IF ( DATANM .EQ. DATINL(N) ) GO TO 400                            
 64   CONTINUE                                                          
      DO 69 N = 1, NUMEL                                                
      IF ( DATANM .EQ. DATEL(N) ) GO TO 500                             
 69   CONTINUE                                                          
C                                                                       
C                                                                       
      WRITE(6,73) DATANM, DATAS, DATINL, DATEL                            
 73   FORMAT ( '0**** INVALID DATA NAME: ', A8,  '.  ALLOWABLE DATA NAME
     *S ARE:' /  ( 2X, 7A10 ) )                                         
      RETURN                                                            
 80   WRITE(6,83)
 83   FORMAT ( '0**** DATA MUST BE FOLLOWED BY A DATA NAME' )           
      RETURN                                                            
C                                                                       
C     TRANSFER GRID WORDS                                               
C                                                                       
 100  IRET = 1                                                          
      I = DATNUM(N)                                                     
C                                                                       
C                                                                       
 210  DWCUT = RGRIDS(1,I)                                               
      SUMPTS = RGRIDS(2,I)                                              
      STPSPR = RGRIDS(3,I)                                              
      GAMSUM = RGRIDS(4,I)                                              
      GAMDIF = RGRIDS(5,I)                                              
      BNDASY = RGRIDS(6,I)                                              
      ALMNMT = RGRIDS(7,I)                                              
      ALMXMT = RGRIDS(8,I)                                              
      SCTASY = RGRIDS(9,I)                                              
      PHIMID = RGRIDS(10,I)                                             
      AMDMLT = RGRIDS(11,I)                                             
C                                                                       
      NPSUM = IGRIDS(1,I)                                               
      NPDIF = IGRIDS(2,I)                                               
      NPPHI = IGRIDS(3,I)                                               
      NPHIAD = IGRIDS(4,I)                                              
      LSTEP = IGRIDS(5,I)                                               
      LMAXAD = IGRIDS(6,I)                                              
      LMINSB = IGRIDS(7,I)                                              
C                                                                       
      RETURN                                                            
C                                                                       
C     INELASTIC PAAMETERS                                               
C                                                                       
 400  ALMNMT = 0                                                        
      GAMSUM = 5                                                        
      LSTEP = 1                                                         
      MAXLEX = 5000                                                     
      IEXTYP = 2                                                        
      ACCINE = GRIDIN(1,N)                                              
      DWCUT = GRIDIN(2,N)                                               
      STPSPR = GRIDIN(3,N)                                              
      SUMPTS = GRIDIN(4,N)                                              
      SCTASY = GRIDIN(5,N)                                              
      ALMXMT = GRIDIN(6,N)                                              
      ACCURA = GRIDIN(7,N)                                              
      LMAXAD = IGRIDI(1,N)                                              
      NPCOUL = IGRIDI(2,N)                                              
C                                                                       
      IRET = 1                                                          
      RETURN                                                            
C                                                                       
C     ELASTIC PARAMETERS                                                
C                                                                       
 500  STPSPR = GRIDEL(1,N)                                              
      SCTASY = GRIDEL(2,N)                                              
      ALMNMT = GRIDEL(3,N)                                              
      ALMXMT = GRIDEL(4,N)                                              
      FITACC = GRIDEL(5,N)                                              
      LMINSB = IGRIDE(1,N)                                              
      LMAXAD = IGRIDE(2,N)                                              
      IRET = 1                                                          
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE PARPRT ( I, NAME, VPAR, RPAR, APAR, RPAR0,  P5, P5NAME,
     * IRET )                                                           
C                                                                       
C     PRINTS PARAMETERS OF ONE POTENTIAL TERM.                          
C                                                                       
C     I = TERM NUMBER (INDEX IN LNKADR) (0 IF NO LINKULE POSSIBLE).     
C     NAME = 18-CHARACTER LABEL FOR TERM, RIGHT JUSTIFIED.              
C     VPAR = COUPLING CONSTANT.                                         
C     RPAR = RADIUS.                                                    
C     APAR = DIFFUSENESS.                                               
C     RPAR0 = RADIUS PARAMETER.                                         
C     P5 = OPTIONAL PARAMETER, PRINTED IF NONZERO.                      
C     P5NAME = 8-CHARACTER LABEL FOR FIFTH PARAMETER, RIGHT JUSTIFIED.  
C     IRET = ERROR FLAG, SET TO 0 IF ERROR OCCURS IN LINKULE.           
C     * = ERROR RETURN, IF IFLG < 0 FROM LINKULE.                       
C                                                                       
C     IF A LINKULE EXISTS, IT IS CALLED TO PRINT STUFF ABOUT ITSELF.    
C     OTHERWISE, THE USUAL PARAMETERS ARE PRINTED INSTEAD.              
C                                                                       
C     12/12/78 - FIRST VERSION - RPG                                    
C     6/3/80 - CDC VERSION, NO RETURNS, CHANGE IRET FOR ERR - S.P.      
C     7/14/80 - USE CHAR*8 FOR BETTER GENERALITY - S.P.                 
C     7/21/81 - REMOVE UNDEFINED STEPSIZE, NUMBER OF STEPS - S.P.       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      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 /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
C                                                                       
      CHARACTER*8 NAME(3), P5NAME                                       
CDC%'2A8,A2' = 'A10, A8'                                                
C                                                                       
C     IF A LINKULE EXISTS, CALL IT TO PRINT STUFF ABOUT ITSELF.         
C                                                                       
      IF ( I .LE. 0 ) GO TO 100                                         
      IF ( LNKADR(3,I) .EQ. 0 ) GO TO 100                               
      WRITE(6,53) NAME, LNKNAM(1,I)                                       
 53   FORMAT ( X,2A8,A2, ' POTENTIAL IS BEING COMPUTED BY THE ',  A8, 
     *' LINKULE:' )                                                     
C                                                                       
C     NOTE IN THIS CALL TO THE LINKULE WE DO NOT PASS CORRECT VALUES    
C     FOR THE STEPSIZE AND NUMBER OF STEPS.                             
C                                                                       
      CALL LINKUL ( LNKADR(3,I), LNKNAM(1,I), LNKADR(5,I),  I, 2, IRTN, 
     * L, JP, 0.D0, 0.0D0, 0, DUMMY, DUMMY, ICHANW )                    
      WRITE(6,63)
 63   FORMAT ( ' ' )                                                    
      IF (IRTN .GE. 0 ) RETURN                                          
      IRET = -1                                                         
      RETURN                                                            
C                                                                       
C     NO LINKULE.  PRINT 4 OR 5 PARAMETERS, IF VPAR IS NONZERO.         
C                                                                       
 100  IF ( VPAR .NE. 0 ) GO TO 110                                      
      IF ( I .NE. 3 .AND. I .NE. 4 ) RETURN                             
      IF ( P5 .EQ. 0 ) RETURN                                           
 110  IF ( P5 .NE. 0 ) GO TO 120                                        
      WRITE(6,113) NAME, VPAR, RPAR, APAR, RPAR0                          
 113  FORMAT ( ' ', 2A8,A2, G14.5, T37, F7.4, T49, F7.4, T67, F7.4,  5X,
     * A8, ' =', G13.5 )                                                
      RETURN                                                            
 120  WRITE(6,113) NAME, VPAR, RPAR, APAR, RPAR0, P5NAME, P5              
      RETURN                                                            
      END                                                               
      SUBROUTINE PHSPRT ( PRNTSW )                                      
C                                                                       
C     TABULATE THE MAGNITUDES AND PHASES OF THE S-MATRICES.             
C                                                                       
C     THIS ROUTINE IS CALLED BY XSECTN PRIOR TO THE COMPUTATION OF      
C     THE CROSS SECTIONS.  IT COMPUTES AND STORES THE MAGNITUDES        
C     AND PHASES OF THE REACTION AND ELASTIC S-MATRICES.                
C     ALL PHASES ARE "SMOOTHED" AND GO TO 0 FOR LARGE L.                
C       IF REQUESTED, THE PARTIAL WAVE MAGNITUDES AND PHASES ARE        
C     PRINTED.                                                          
C                                                                       
C     6/2/75 - FIRST VERSION - S. PIEPER                                
C     1/11/77 - MODS FOR INELASTIC SCATTERING                           
C     5/5/77 - IDENTICAL PARTICLES                                      
C     6/22/77 - DEFINE ALL OF IMAG AND IPHASE                           
C     7/22/77 - FIX BUG INTRODUCED 6/22/77                              
C     4/25/78 - REVERSE LI AND LO - S.P.                                
C     4/26/78 - ONE COMPLEX I ARRAY WITHOUT COULOMB PHASES - S.P.       
C     3/6/79 - S-MATRICES AND UNITARITY - S.P.                          
C     4/12/79 - OUT IS IN FOR COUPLED - S.P.                            
C     8/8/79 -  MAJOR RE-WRITE FOR SPIN-ORBIT ETC. - RPG                
C     11/20/79 - S-MATRICES STORED BY LO-LI - S.P.                      
C     4/1/80 - C.C. VERSION; REAL*4 S-MATRICES - S.P.                   
C     4/7/80 - OUTPUT 5 REACTION S-MATRICES PER LINE - S.P.             
C     10/12/81 - FIX BUG IN OPTICAL S; SEVERAL BLOCKS/PAGE - S.P.       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      LOGICAL PRNTSW                                                    
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 PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      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
     *) )                                                               
      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 /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 /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
C                                                                       
C                                                                       
      DIMENSION ISMG(3), ISPH(3)                                        
      LOGICAL ELSW, CCSW, PBUGSW, TOPSW                                 
      CHARACTER*8 WORDS(3,2), MAGNAM(3), PHSNAM(3)                      
C                                                                       
      DATA WORDS /'COUPLED ','INCOMING','OPTICAL' , 'ELASTIC ', 
     *'OUTGOING', ' ELASTIC' /                                             
      DATA MAGNAM / 'SMAG    ', 'SINMAG  ', 'SOUTMAG ' /                
      DATA PHSNAM / 'SPHASE  ', 'SINPHASE', 'SOUTPHAS' /                
C                                                                       
      DIMENSION JTTS(5), JTPS(5), LXS(5), LDELS(5), DMAGS(5), PHASES(5) 
      DIMENSION KOFFSS(5)                                               
C                                                                       
C                                                                       
CIB      DATA  SUBHAF / Z 407FFFFF FFFFFFFF /                           
      DATA SUBHAF /.4999999990D0 /                                      
C                                                                       
      CHARACTER*1 BLANK                                                 
      DATA BLANK / ' ' /                                                
C                                                                       
      DMODPI(X) = X - 2*PI*DINT( X/(2*PI) + DSIGN( SUBHAF, X ) )        
      UNMOD(X, Y) = X + DMODPI( Y-X )                                   
C                                                                       
      CCSW = PROBLM .EQ. 24                                             
      PBUGSW = MOD(IPRINT,10) .GE. 4                                    
C                                                                       
      IELUNI = NALLOC( LMAX+1, 'ELUNITAR' )                             
      CALL INIT8 ( IELUNI, 0.D0 )                                       
C                                                                       
C     THIS FIRST LOOP IS OVER THE "PSEUDO-CHANNEL" - REACTION,          
C     INCOMING ELASTIC, AND OUTGOING ELASTIC.                           
C     FOR ICH=1 WE PROCESS ALL REACTION CHANNELS.                       
C                                                                       
      DO 399 ICH = 1, 3                                                 
      ELSW = ICH .GT. 1                                                 
      ASSIGN 369 TO JGOTO                                               
C                                                                       
C     ALLOCATE SPACE TO STORE THE MAGNITUDES AND PHASES                 
C                                                                       
      N = (LILOSZ+FACFR4-1)/FACFR4                                      
      IF ( ELSW ) N = (NUMJS(ICH-1)*(LMAX+1)+FACFR4-1)/FACFR4           
      ISMG(ICH) = NALLOC ( N, MAGNAM(ICH) )                             
      ISPH(ICH) = NALLOC ( N, PHSNAM(ICH) )                             
      CALL INIT8 ( ISMG(ICH), 0.D0 )                                    
      CALL INIT8 ( ISPH(ICH), 0.D0 )                                    
C                                                                       
      LMAG = FACFR4*(Z(ISMG(ICH)) - 1)                                  
      LPHASE = FACFR4*(Z(ISPH(ICH)) - 1)                                
      LELUNI = Z(IELUNI)                                                
      NUMCHN = 2                                                        
C                                                                       
      IF ( ELSW ) GO TO 150                                             
C                                                                       
C     POINTERS FOR REACTION.                                            
C                                                                       
      NPLI = NSPLI                                                      
      LS = FACFR4*(Z(IRDINT) - 1)                                       
      ASSIGN 310 TO IGOTO                                               
      LTOCS = Z(ITOCS)*FACFR4 - FACFR4                                  
      LLAST = LIMOST                                                    
      LBASE = LMIN                                                      
      PHSMUL = 1.                                                       
      NCHNDF = 2                                                        
      IF ( .NOT. CCSW ) GO TO 160                                       
C                                                                       
C     SETUP TO DO COUPLED CHANNELS                                      
C                                                                       
      LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      NCHNDF = ILLOC(LCHNDF)                                            
      MCHNDF = ILLOC(LCHNDF+1)                                          
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2) + MCHNDF                        
      LTOCSV = LTOCS                                                    
      NUMCHN = NCHNDF                                                   
      LSSAVE = LS                                                       
      LMAGSV = LMAG                                                     
      LPHASV = LPHASE                                                   
      GO TO 160                                                         
C                                                                       
C     POINTERS FOR ELASTIC SCATTERING.                                  
 150  LS = Z(ISMATS(ICH-1)) - 1                                         
      ASSIGN 315 TO IGOTO                                               
      IF ( ICH .EQ. 2 ) ASSIGN 350 TO JGOTO                             
      IPROB = ICH-1                                                     
      IF ( PROBLM .GE. 23 ) IPROB = 1                                   
      LTOCS = Z(ITOCE(IPROB))*FACFR4 - FACFR4                           
      NPLI = NUMJS(IPROB)                                               
      LLAST = LMAX                                                      
      LBASE = 0                                                         
      PHSMUL = 0.5                                                      
C                                                                       
C                                                                       
C     COMPUTE THE PARTIAL WAVE MAGNITUDES AND SMOOTHED PHASE SHIFTS     
C                                                                       
C     THE PHASES FOR LO = LMAX ARE SET AS CLOSE TO 0 AS IS POSSIBLE.    
C     THE OTHERS ARE THEN MADE CONTINUOUS WITH THIS STARTING POINT.     
C                                                                       
C                                                                       
C     LOOP OVER ALL REACTION CHANNELS FOR ICH=1                         
 160  DO 389 NCHN = 2, NUMCHN                                           
      IF ( ELSW .OR. .NOT. CCSW ) GO TO 180                             
      NPLI = ILLOC(LCHNDF+10)                                           
      LTOCS = LTOCSV + ILLOC(LCHNDF+12)                                 
      LSOFF = ILLOC(LCHNDF+13)                                          
      LS = LSSAVE + 2*LSOFF                                             
      LMAG = LMAGSV + LSOFF                                             
      LPHASE = LPHASV + LSOFF                                           
      LLAST = ILLOC(LCHNDF+14)                                          
C                                                                       
C                                                                       
C        LOOP THROUGH JT, JP, LX, AND LI-LO.  SKIP UNUSED ELEMENTS.     
C                                                                       
 180  DO 379 KOFFS = 1, NPLI                                            
      JTT = ILLOC(LTOCS+4*KOFFS)                                        
      IF ( PBUGSW ) WRITE(6,183) ICH,ELSW,LMAG,LPHASE,NPLI,LS,LTOCS
     *,  LLAST, LBASE, LMIN, IPROB, JTT                                 
 183  FORMAT (' PHSPRT:', I10, L3, 12I10 )                              
      IF ( JTT .LT. 0 ) GO TO 379                                       
      PHASE = 0                                                         
      PHASP = 0                                                         
C                                                                       
C           LOOP THROUGH LI, BACKWARD.                                  
C           THIS WILL WORK FOR IDENTICAL PRTICLES IN EITHER CHANNEL,    
C           EVEN THOUGH LSKIP IS IGNORED.                               
C                                                                       
      DO 369 LLI = LMIN, LLAST                                          
      LI = LLAST + LMIN - LLI                                           
      I = (LI-LBASE)*NPLI + KOFFS                                       
      GO TO IGOTO, ( 310, 315 )                                         
 310  SR = ALLOC4(LS+2*I-1)                                             
      SI = ALLOC4(LS+2*I)                                               
      GO TO 320                                                         
 315  SR = ALLOC(LS+2*I-1)                                              
      SI = ALLOC(LS+2*I)                                                
 320  ALLOC4(LMAG+I) = DSQRT(SR**2+SI**2)                               
      IF ( ALLOC4(LMAG+I) .EQ. 0 ) GO TO 369                            
      PHASE = DATAN2( SI, SR )                                          
      PHASE = UNMOD ( PHASP, PHASE )                                    
      PHASP = PHASE                                                     
      ALLOC4(LPHASE+I) = PHSMUL * PHASE                                 
      GO TO JGOTO, ( 350, 379 )                                         
 350  ALLOC(LELUNI+LI) = ALLOC(LELUNI+LI) + (SR**2+SI**2)               
 369  CONTINUE                                                          
 379  CONTINUE                                                          
      LCHNDF = LCHNDF+MCHNDF                                            
 389  CONTINUE                                                          
 399  CONTINUE                                                          
C                                                                       
C                                                                       
C     NOW PRINT THEM IF SO REQUESTED                                    
C                                                                       
      IF ( .NOT. PRNTSW ) RETURN                                        
C                                                                       
      LTOCS = Z(ITOCS)*FACFR4 - FACFR4                                  
      LTOCI = Z(ITOCE(1))*FACFR4 - FACFR4                               
      LTOCO = Z(ITOCE(IPROB))*FACFR4 - FACFR4                           
      LMAG = FACFR4*(Z(ISMG(1)) - 1)                                    
      LMAGI = FACFR4*(Z(ISMG(2)) - 1)                                   
      LMAGO = FACFR4*(Z(ISMG(3)) - 1)                                   
      LPHASE = FACFR4*(Z(ISPH(1)) - 1)                                  
      LPHASI = FACFR4*(Z(ISPH(2)) - 1)                                  
      LPHASO = FACFR4*(Z(ISPH(3)) - 1)                                  
      LSIGIN = Z(ISIGS(1))                                              
      LSIGOT = Z(ISIGS(IPROB))                                          
      LUNITR = FACFR4*(Z(IUNITR)-1) + 1 - LMIN                          
      LELUNI = Z(IELUNI)                                                
C                                                                       
C                                                                       
C     FIRST WE PRINT THE ELASTIC S-MATRIX ELEMENTS AND UNITARITY        
C                                                                       
      IPROB = 2                                                         
      IF ( PROBLM .GE. 23 ) IPROB = 1                                   
      LINECT = 100                                                      
      LINES = MAX0 ( NUMJS(1), NUMJS(2) )                               
C                                                                       
C     ADJUST LO FOR ODD PARITY.                                         
C                                                                       
      LOADD = 0                                                         
      IF ( MOD( LBP+LBT, 2 ) .NE. 0 .AND. .NOT. CCSW ) LOADD = 1        
C                                                                       
C     LOOP THROUGH THE INCOMING L VALUES.                               
C                                                                       
      DO 699 LI = LMIN, LMAX, LSKIP                                     
      J = 2*LI                                                          
C                                                                       
C     PRINT THE HEADINGS IF NECESSARY.                                  
C                                                                       
      IF ( LINECT+LINES .LE. 58 ) GO TO 550                             
      WRITE(6,533) REACT, ELAB, HEADER                                    
 533  FORMAT ( X, T58, 'P T O L E M Y' /  T39, 'ELASTIC PARTIAL WAVE S
     *-MATRIX ELEMENTS AND UNITARITY' / X, 45A1, 'ELAB =', F7.2, ' MEV
     *', 5X, 65A1 / )                                                   
      IF (.NOT. CCSW) WRITE(6,543) ( WORDS(I,IPROB), I=1,3 )              
 543  FORMAT (  T16, 'INCOMING ', A8, T58, 'UNITARITY', T93, 2A8 /  ( 4X
     *, 'L   L   LX  MAGNITUDE   PHASE  COULOMB  ' ),  T49, 'ELASTIC  RE
     *ACTION  RESIDUAL',  ( 8X, 'L   L   LX  MAGNITUDE   PHASE  COULOMB 
     *' ) / )                                                           
      IF (CCSW) WRITE(6,548)
 548  FORMAT ( T23, 'COUPLED ELASTIC', T58, 'UNITARITY',  T85, 'OPTICAL 
     *ELASTIC' /  4X, 'J', 6X, 'L', 7X, '!S!', 6X, 'PHASE',  2X, 'COULOM
     *B',  T47, '   ELASTIC  REACTION  RESIDUAL',  10X, '!S!', 6X, 'PHAS
     *E' /  T29, 'SHIFT', 3X, 'PHASE', T96, 'SHIFT' / )                 
      TOPSW = .TRUE.                                                    
      LINECT = 9                                                        
C                                                                       
 550  KI = 0                                                            
      KO = 0                                                            
      UNITAR = ALLOC4(LUNITR+LI)                                        
      ELUNIT = ALLOC(LELUNI+LI)                                         
      RESID = 1 - ELUNIT - UNITAR                                       
      CPHASI = ALLOC(LSIGIN+LI)                                         
      LASO = LI + LOADD                                                 
      CPHASO = ALLOC(LSIGOT+LASO)                                       
C                                                                       
C     LOOP THROUGH LO, LX, JP, JT VALUES.                               
C                                                                       
      DO 689 KOFFS = 1, LINES                                           
      JUMP = 0                                                          
C                                                                       
C     PROCESS THE INCOMING ELASTIC INFORMATION.                         
C                                                                       
 560  KI = KI + 1                                                       
      IF ( KI .GT. NUMJS(1) ) GO TO 580                                 
      IADD = NUMJS(1)*LI + KI                                           
      DMAGI = ALLOC4(LMAGI+IADD)                                        
      IF ( DMAGI .EQ. 0 ) GO TO 560                                     
      PHASI = ALLOC4(LPHASI+IADD)                                       
      LXI = ILLOC(LTOCI+4*KI-2)                                         
      LOI = LI + ILLOC(LTOCI+4*KI-3)                                    
      JUMP = JUMP + 2                                                   
C                                                                       
C     NOW THE OUTGOING ELASTIC INFORMATION.                             
C                                                                       
 580  KO = KO + 1                                                       
      IF ( KO .GT. NUMJS(2) ) GO TO 590                                 
      IADD = NUMJS(2)*LASO + KO                                         
      DMAGO = ALLOC4(LMAGO+IADD)                                        
      IF ( DMAGO .EQ. 0 ) GO TO 580                                     
      PHASO = ALLOC4(LPHASO+IADD)                                       
      LXO = ILLOC(LTOCO+4*KO-2)                                         
      LOO = LASO + ILLOC(LTOCO+4*KO-3)                                  
      JUMP = JUMP + 1                                                   
C                                                                       
C     WE HAVE 4 DIFFERENT FORMATS, DEPENDING ON HOW MUCH WE             
C     HAVE TO PRINT ON THIS LINE.                                       
C                                                                       
 590  IF ( KOFFS .NE. 1 ) GO TO 600                                     
C                                                                       
C     FIRST LINE:  PRINT EVERYTHING, INCLUDING COULOMB PHASES.          
C                                                                       
      IF ( TOPSW ) GO TO 595                                            
      IF ( LINES .GT. 1 ) GO TO 592                                     
      IF ( MOD(LI,10) .NE. 0 ) GO TO 595                                
C 592  WRITE(6,813)
 592  CONTINUE
      LINECT = LINECT+1                                                 
C                                                                       
 595  IF ( .NOT. CCSW ) WRITE(6,597) LI,LOI,LXI,DMAGI,PHASI,CPHASI, 
     * ELUNIT, UNITAR, RESID,  LASO, LOO, LXO, DMAGO, PHASO, CPHASO     
 597  FORMAT ( 1X,2( I4, I5, I3, F10.6, 2F9.3 , 4X, 3F10.5, 5X ))    
      IF ( CCSW ) WRITE(6,598) J,LI,DMAGI,PHASI,CPHASI,ELUNIT,UNITA
     *R, RESID, DMAGO, PHASO                                            
 598  FORMAT (1X,I4,'/2',I5,F12.6,2F9.3,4X,3F10.5,F15.6,F9.3)
      GO TO 680                                                         
C                                                                       
 600  IF ( JUMP .EQ. 0 ) GO TO 699                                      
      GO TO ( 610, 620, 630 ), JUMP                                     
C                                                                       
C     JUMP = 1:  OUTGOING ONLY.                                         
 610  WRITE(6,613) LASO, LOO, LXO, DMAGO, PHASO                           
 613  FORMAT ( T81, I4, I5, I3, F10.6, F9.3 )                           
      GO TO 680                                                         
C                                                                       
C     JUMP = 2:  INCOMING ONLY.                                         
 620  WRITE(6,623) LI, LOI, LXI, DMAGI, PHASI                             
 623  FORMAT ( 1X, I4, I5, I3, F10.6, F9.3, 48X,  I4, I5, I3, F10.6, F9.
     *3 )                                                               
      GO TO 680                                                         
C                                                                       
C     JUMP = 3:  ELASTICS ONLY.                                         
 630  WRITE(6,623) LI,LOI,LXI,DMAGI,PHASI,LASO,LOO,LXO,DMAGO,PHASO
C                                                                       
 680  LINECT = LINECT + 1                                               
      TOPSW = .FALSE.                                                   
 689  CONTINUE                                                          
 699  CONTINUE                                                          
C                                                                       
C     NOW PRINT THE REACTION S-MATRICES                                 
C                                                                       
      IF ( .NOT. CCSW ) GO TO 720                                       
      LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2) + MCHNDF                        
      LTOCSV = LTOCS                                                    
      LMAGSV = LMAG                                                     
      LPHASV = LPHASE                                                   
C                                                                       
 720  DO 899 NCHN = 2, NCHNDF                                           
      MCHN = NCHN                                                       
      IF ( .NOT. CCSW ) GO TO 740                                       
      MCHN = ILLOC(LCHNDF)                                              
      NSPLI = ILLOC(LCHNDF+10)                                          
      LTOCS = LTOCSV + ILLOC(LCHNDF+12)                                 
      LSOFF = ILLOC(LCHNDF+13)                                          
      LMAG = LMAGSV + LSOFF                                             
      LPHASE = LPHASV + LSOFF                                           
      LOADD = 0                                                         
      IPT = ISIGN( 1, ILLOC(LCHNDF+1) )                                 
      IPP = ISIGN( 1, ILLOC(LCHNDF+3) )                                 
      IF ( IPP*IPT .LT. 0 ) LOADD = 1                                   
C                                                                       
C     COUNT THE LINES TO BE PRINTED.  WE WILL SKIP THOSE WHICH          
C     HAVEN'T BEEN CALCULATED YET.                                      
C                                                                       
 740  LINES = 0                                                         
      DO 749 KOFFS = 1, NSPLI                                           
      IF ( ILLOC(LTOCS+4*KOFFS) .GE. 0 ) LINES = LINES + 1              
 749  CONTINUE                                                          
      NSETS = (LINES+4)/5                                               
      KF1 = 1                                                           
      DO 889 NSET = 1, NSETS                                            
C                                                                       
C     FIND THE 5 (JP, JT, LX, LO-LI) FOR THIS PRINTOUT                  
C                                                                       
      II = 0                                                            
      DO 779 K = KF1, NSPLI                                             
      JTT = ILLOC(LTOCS+4*K)                                            
      IF ( JTT .LT. 0 ) GO TO 779                                       
      II = II+1                                                         
      JTTS(II) = JTT                                                    
      LDELS(II) = ILLOC(LTOCS+4*K-3)                                    
      LXS(II) = ILLOC(LTOCS+4*K-2)                                      
      JTPS(II) = ILLOC(LTOCS+4*K-1)                                     
      KOFFSS(II) = K                                                    
      IF ( II .EQ. 5 ) GO TO 780                                        
 779  CONTINUE                                                          
 780  NDO = II                                                          
      KF1 = K+1                                                         
      IF ( LINECT+8+1.1*(LMAX-LMIN+LSKIP)/LSKIP .GT. 58 )  LINECT = 100 
      TOPSW = .TRUE.                                                    
C                                                                       
      DO 879 LI = LMIN, LMAX, LSKIP                                     
C                                                                       
C     PRINT HEADING IF NECESSARY                                        
C                                                                       
      IF ( LINECT .LE. 58 .AND. .NOT. TOPSW ) GO TO 820                 
      IF ( LINECT .GT. 58 ) WRITE(6,803) REACT, ELAB, HEADER              
 803  FORMAT ( X, T49, 'P T O L E M Y' /  1X, 45A1, 'ELAB =', F7.2, ' 
     *MEV', 5X, 65A1 )                                                  
      IF ( LINECT .LT. 58 ) WRITE(6,813)
      WRITE(6,804) MCHN                                                   
 804  FORMAT ( '  L IN', T20, 'S-MATRICES FOR CHANNEL', I3,  '  AND PART
     *IAL WAVES LABELED BY ',  '( JP, JT, LX, L(OUT)-L(IN) )' )         
      WRITE(6,807) (BLANK,JTPS(I),JTTS(I),LXS(I),LDELS(I),I=1,NDO)
 807  FORMAT ( 5X, 5( 3X, A2, '(', I2, '/2', I3, '/2',  I3, I4, ' )
     *' ) )                                                             
      WRITE(6,808) ( BLANK, I = 1, NDO )                                  
 808  FORMAT ( 5X, 5( 7X, 1A1, '!S!', 8X, 'PHASE' ) )                   
      WRITE(6,813)
 813  FORMAT ( ' ' )                                                    
      TOPSW = .TRUE.                                                    
      LINECT = LINECT + 8                                               
      IF ( LINECT .GT. 58 ) LINECT = 9                                  
C                                                                       
 820  DO 849 I = 1, NDO                                                 
      K = KOFFSS(I)                                                     
      IADD = NSPLI*(LI-LMIN) + K                                        
      DMAGS(I) = ALLOC4(LMAG+IADD)                                      
      PHASES(I) = ALLOC4(LPHASE+IADD)                                   
 849  CONTINUE                                                          
C                                                                       
      IF ( MOD(LI,10) .NE. 0 .OR. TOPSW ) GO TO 860                     
C      WRITE(6,813)
      LINECT = LINECT+1                                                 
 860  WRITE(6,863) LI, ( DMAGS(I), PHASES(I), I = 1, NDO )                
 863  FORMAT ( I5, 5( G15.5, F9.3 ) )                                   
      TOPSW = .FALSE.                                                   
      LINECT = LINECT+1                                                 
 879  CONTINUE                                                          
 889  CONTINUE                                                          
      LCHNDF = LCHNDF+MCHNDF                                            
 899  CONTINUE                                                          
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE PRBPRT ( IRET )                                        
C                                                                       
C     MAKES CONSISTANCY CHECKS AND PRINTS PROBLEM SUMMARY               
C                                                                       
C     THIS ROUTINE IS CALLED BY THE GRIDSETUP KEYWORD. IT CHECKS        
C     THAT ALL INPUT NECESSARY FOR THE DESCRIPTION OF THE DWBA          
C     PROBLEM HAS BEEN ENTERED AND MAKES SOME CONSISTENCY CHECKS.       
C                                                                       
C     MUCH OF THIS ROUTINE IS SKIPPED FOR COUPLED-CHANNELS              
C     CALCULATIONS SINCE THE ROUTINE IS ORIENTED TO ONLY TWO            
C     CHANNELS (IT IS ALL USED FOR COUPL2, HOWEVER).                    
C     IT THEN PRINTS A SHORT SUMMARY OF THE REACTION.                   
C     FOLLOWING THIS ROUTINE, GRDSET IS CALLED BY MAIN.                 
C                                                                       
C     FOR THE HISTORY PRIOR TO THE SPLIT, SEE GRDSET.                   
C                                                                       
C     5/28/75 - SPLIT OFF FROM GRDSET.                                  
C     6/5/75 - LBTS MORE PRINTED                                        
C     6/28/75 - SMALL FIXES                                             
C     8/3/75 - BASE LMIN, LMAX ON LCRIT                                 
C     8/28/75 - LMINMULT, LMAXMULT, SPFACP SPFACT                       
C     9/1/75 - USE LCRIT FUNCTION                                       
C     9/18/75 - IMPROVED LCRITL FUNCTION                                
C     9/30/75 - LMAXMULT BECOMES LMAXADD                                
C     12/12/76 - INELASTIC SCATTERING                                   
C     3/7/77 - CORRECT BUG WHEN LCRIT VERY SMALL                        
C     5/5/77 - LMINSUB, LMAXMULT;  IDENTICAL PARTICLES                  
C     9/24/77 - BETTER USECORE MESSAGES; GIVE HIM HIS LMIN              
C     11/20/77 - V IS NOW STORED WITHOUT 1/E - S.P.                     
C     12/1/77 - LCRITICAL NOW FOUND BY WAVSET - S.P.                    
C     12/4/77 - LINKULES - S.P.                                         
C     1/30/77 - USE CORRECT BE FOR NON-ZERO GROUND STATES.              
C     4/18/78 - DO ABOVE TRUELY CORRECTLY - S.P.                        
C     4/20/78 - IRET FINALLY USED; DEEXCITAION ALLOWED - S.P.           
C     4/24/78 - INTERCHANGE LI AND LO - S.P.                            
C     3/6/79 - S-MATRICES; NO MORE BETABAR - S.P.                       
C     5/4/79 - PARITIES - S.P.                                          
C     6/6/79 - CHANGE DEF. OF SPECTROSCOPIC COEFFICIENTS FOR TRANSFER,  
C        ADD JPMIN, JPMAX, JTMIN, JTMAX. USE MOD - RPG                  
C     6/8/79 - STANDARD PREFIXES, CHARACTER TYPE - RPG                  
C     12/21/79 - COUPLED CHANNELS - S.P.                                
C     7/14/80 - CDO, CDM PREFIXES - S.P.                                
C     6/3/80 - MOVE CDC XWORDS - S.P.                                   
C     7/16/80 - CHAR*8 PWORD - S.P.                                     
C     7/1/81 - LXSTEP=1 FOR CC CALCULATIONS; FIX LX=*** FOR CC - S.P.   
C     7/16/81 - ALLOW EXTERNAL SPECIFICATION OF L VALUES - S.P.         
C     5/4/82 - PROPER DEF OF LBNDS FOR 1/2 INT INELASTIC - S.P.         
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) )                                                          
      COMMON /LENGTH/ LENG(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                                                                 
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      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 /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 NBNDS(2), R2S(4), LBNDS(2)                              
      EQUIVALENCE ( NBNDS(1), NBP ), ( R2S(1), RBNDS(1) )               
      EQUIVALENCE ( LBNDS(1), LBP )                                     
      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)                 
      REAL*8 JACOB                                                      
      COMMON /GRIDCM/ JACOB, STPINV, COSSTP, IMSVAL, IINTS, INTOFF, IA12
     *VL, ICOSIN, IPHIT, IPHIP, IPHI, LOGIC, LOCTRP, IRI, IRO, ILOR, ILO
     *I, ILIR, ILII, IWIO, NOFLO, NRIROI, NCRIT, IXLAM, INLAM, IA12N, MS
     *KCOS, MAXCNT, ISMHPT, ISMIPT, ICOSS4, IJA12S, IHS, IIINDX, IA12TM,
     * IDW, IHINT, IHABS, IABS1, IGRDC1, NPSUMI, RVRLIM, ISMHWK, ISMHVL,
     * ISMIVL, IRIOEX, NUMHS, IGRDC2(4), IWFII, IWFIO, NWFI, NWFO, IDWI 
      LOGICAL ONELSW, IDENSW                                            
      COMMON /INELCM/ JBPF,JBTF,LXMIN,LXMAX,ILILOR,ILILOI,MSTOP,IA12M, 
     *NMLOLX,ONELSW,NUMLX,IRDINT,IELCUP,LILOSZ,NUMLIS,ILIS,IBETAS(4), 
     *ICL2FF,LXSTEP,IDENSW,LSKIP,JPMIN,JPMAX,JPBASE,NJP,JTMIN,JTMAX, 
     *JTBASE,NJT,IINDXS,ISMATR,ISMATI,NSMAT,NLX,NSPLI,ITOCS,NASPLI, 
     *IUNITR,LIFIT,ILIFIT,NOLFIT,IDELSR,IDELSI
      INTEGER INDXJS(4,2)                                               
      EQUIVALENCE ( INDXJS(1,1), JPMIN )                                
      COMMON /LOCFIT/ LNKAD2(6,2,12)                                    
      COMMON / TEMPVS / TVR, TVI, TVSOR, TVSOI, TAR, TAI                
C                                                                       
      INTEGERIND(5)                                                     
      DATAIND/3, 1, 2, 4, 5/                                            
	CHARACTER*8 PARTIC(5) /'A', 'B','BIGA', 'BIGB', 'X' /
C                                                                       
      LOGICAL PRNTSW                                                    
C                                                                       
CDO           real*8  XWORDS(2) / ' ', ';   X' /                        
	CHARACTER*8 WORDS(4) / 'PROJECTI', 'LE', 'TARGET', ' ' /
	CHARACTER*8 BETNAM(4) /'BETA', 'BETACOUL', 'BETARATS','BELX ' /
CDO           real*8 PWORD(3) / '     -1', 'UNKNOWN', '     +1' /       
      LOGICAL BETSWS(4), TRANSW, COUPSW                                 
	REAL*8 XWORDS(2)
	REAL*8 PWORD(3)
      DATA XWORDS / 1H , 5H;   X /                                      
      DATA PWORD / 7H     -1,  7HUNKNOWN,  7H     +1 /                  
C                                                                       
      IRET = 1                                                          
C                                                                       
      IPRNT = MOD( IPRINT, 10 )                                         
      PRNTSW = IPRNT .GE. 1                                             
C                                                                       
      IF ( PRNTSW ) WRITE(6,3) REACT, ELAB, HEADER                        
 3    FORMAT ( X, T49, 'P T O L E M Y' /  '   CONSTRUCTION OF THE INTE
     *GRATION GRIDS', T70,  'MERELY TO CONCEIVE OF SUCH THINGS MAKES THE
     *M APPEAR RIDICULOUS' /  X, 45A1, 'ELAB =', F7.2, ' MEV', 5X, 65A
     *1 / )                                                             
C                                                                       
C     IS THIS TRANSFER OR INELASTIC EXCITATION?                         
C     TREATMENT OF LX DEPENDS ON THE PROBLEM                            
C                                                                       
      TRANSW = ISTRIP .NE. 0                                            
      COUPSW = PROBLM .EQ. 24                                           
C                                                                       
      LXSTEP = 1                                                        
      IF ( TRANSW ) GO TO 40                                            
C                                                                       
C     FOR INELASTIC SCATTERING WE SET L(BOUNDSTATE) = DELTA(J(OUTGOING))
C     AT EACH VERTEX.                                                   
C     THIS IS APPROPRIATE FOR INTEGER SPINS WITH NO CHANGES IN          
C     INTRINNSIC PARITY.  ELSE WE NEED TO KNOW MORE TO PROPERLY SET     
C     UP THE LX LIMITS.                                                 
C     THIS IS FURTHER REFINED PAST STMNT NO 285                         
C                                                                       
C     INELASTIC DWBA CAN ONLY HAVE LXSTEP=2 BY PARITY SINCE WE DON'T    
C     ALLOW FOR SPIN-ORBIT.                                             
C                                                                       
      IF ( .NOT. COUPSW ) LXSTEP = 2                                    
      LBP = IABS(JB-JA)/2                                               
      LBT = IABS(JBIGB-JBIGA)/2                                         
C                                                                       
C     CHECK PARTICLE MASSES                                             
C                                                                       
C     AMS ARRAY CONTAINS  MA, MB, MBIGA, MBIGB, MX                      
C                                                                       
  40  DO 49 I = 1, 4                                                    
      IF ( AMS(I) .NE. UNDEF ) GO TO 42                                 
      WRITE(6,41) PARTIC(I)                                               
 41   FORMAT ( '0***** ERROR:  M', A4, ' IS NOT DEFINED.' )             
      IRET = 0                                                          
  42  IF ( JS(I) .NE. NOTDEF ) GO TO 44                                 
      WRITE(6,43) PARTIC(I)                                               
 43   FORMAT ( '0***** ERROR:  J', A4, ' IS NOT DEFINED.' )             
      IRET = 0                                                          
  44  IF ( IZS(I) .NE. NOTDEF ) GO TO 49                                
      WRITE(6,45) PARTIC(I)                                               
 45   FORMAT ( '0***** ERROR:  Z', A4, ' IS NOT DEFINED.' )             
      IRET = 0                                                          
 49   CONTINUE                                                          
      IF ( AMX .EQ. UNDEF ) AMX = DABS( AMA-AMB )                       
      IF ( DABS(AMA+AMBIGA-AMB-AMBIGB) .LT. .3 ) GO TO 55               
      WRITE(6,53) AMBIGA, AMA, AMB, AMBIGB                                
 53   FORMAT ( '0**** THE REACTION DOES NOT CONSERVE MASS:' /  ' MBIGA(M
     *A, MB)MBIGB =', 4G15.5 )                                          
      IRET = 0                                                          
 55   IF ( IZS(1)+IZS(3) .EQ. IZS(2)+IZS(4) ) GO TO 60                  
      WRITE(6,57) IZS(3), IZS(1), IZS(2), IZS(4)                          
 57   FORMAT ( '0**** THE REACTION DOES NOT CONSERVE CHARGE:' /  ' ZBIGA
     *(ZA, ZB)ZBIGB =', 4I8 )                                           
      IRET = 0                                                          
C                                                                       
 60   IF ( DABS( AMX - DABS(AMA-AMB) ) .LT. .3 ) GO TO 65               
      WRITE(6,63)                                                         
 63   FORMAT ( '0**** THE EXCHANGED MASS IS INCONSISTANT WITH THE ',  'O
     *THER FOUR MASSES.' )                                              
      IRET = 0                                                          
 65   IF ( AMX .GT. .7 ) GO TO 90                                       
      IF ( .NOT. TRANSW ) GO TO 70                                      
      WRITE(6,68) AMX                                                     
 68   FORMAT ( '0**** THE EXCHANGED MASS MUST NOT BE 0 OR NEGATIVE:',  G
     *15.5 )                                                            
      IRET = 0                                                          
      GO TO 90                                                          
 70   IF ( IZS(5) .EQ. 0 ) GO TO 90                                     
      WRITE(6,73) IZS(5)                                                  
 73   FORMAT ( '0**** CANNOT TRANSFER CHARGE WITHOUT MASS TRANSFER:',  '
     * AMX = 0, ZX =', I4 )                                             
      IRET = 0                                                          
C                                                                       
  90  CONTINUE                                                          
C                                                                       
      IF ( COUPSW ) GO TO 400                                           
      IF ( .NOT. TRANSW ) GO TO 200                                     
C                                                                       
C     FOR TRANSFER CANNOT HAVE NUCLEAR CORE CORRECTIONS FOR LINKULES    
C                                                                       
      IF ( LNKAD2(3,1,1) .EQ. 0 .AND. LNKAD2(3,2,1) .EQ. 0 )  GO TO 200 
      IF ( NUCONL .LT. 3 ) GO TO 200                                    
      WRITE(6,103)
 103  FORMAT ( '***** WARNING - NUCLEAR CORE-CORE CORRECTIONS CANNOT',  
     *' BE COMPUTED FOR LINKULE-COMPUTED POTENTIALS.' /  6X, 'ONLY COULO
     *MB CORE-CORE CORRECTIONS WILL BE USED.' )                         
      NUCONL = 2                                                        
C                                                                       
C     CHECK THAT JBP AND JBT ARE INSIDE ALLOWED BOUNDS                  
C                                                                       
 200  JBPMIN=IABS(JA-JB)                                                
      JBPMAX=JA+JB                                                      
      JBTMIN=IABS(JBIGA-JBIGB)                                          
      JBTMAX=JBIGA+JBIGB                                                
C                                                                       
      IF ( .NOT. TRANSW ) GO TO 270                                     
C                                                                       
C     FOR TRANSFER, WE CAN HANDLE ONE (JBP, JBT) PAIR ON EACH PASS.     
C     S-MATRIX VALUES WILL BE ACCUMULATED.                              
C                                                                       
      IF ( JBP .GE. JBPMIN .AND. JBP .LE. JBPMAX  .AND. JBT .GE. JBTMIN 
     *.AND. JBT .LE. JBTMAX ) GO TO 260                                 
      WRITE(6,253) JA,JB,JBIGA,JBIGB,JBPMIN,JBPMAX,JBTMIN,JBTMAX   
 253  FORMAT ('0***** ERROR IN INPUT:' /  ' JA, JB, JBIGA, JBIGB =', 4(I
     *5, '/2') /  ' RESULTS IN' /  ' JBPMIN, JBPMAX, JBTMIN, JBTMAX =', 
     *4(I5, '/2') )                                                     
      IRET = 0                                                          
      IF ( JBP .EQ. NOTDEF .OR. JBT .EQ. NOTDEF ) GO TO 255             
      WRITE(6,254) JBP, JBT                                               
 254  FORMAT ( ' BUT  JBP, JBT =', 2(I5, '/2'), '  AND ARE OUT OF ',  'B
     *OUNDS.' )                                                         
      GO TO 260                                                         
 255  WRITE(6,257) JBP, JBT                                               
 257  FORMAT ( ' THUS THERE IS MORE THAN ONE POSSIBILITY FOR',  ' JP FOR
     * THE PROJECTILE OR TARGET BOUND STATE.' /  ' IN SUCH AMBIGUOUS CAS
     *ES JP MUST BE EXPLICITLY INDICATED.' /  ' WE PRESENTLY HAVE  JP(PR
     *OJ) = ', I3, '/2,', 4X,  'JP(TARG) = ', I3, '/2' /  ' WHERE THE **
     ** INDICATES THE AMBIGUOUS CASE.' )                                
C                                                                       
C                                                                       
C     FIND LX RANGE FOR TRANSFER AND MAKE NECESSARY CHECKS              
C                                                                       
 260  LXMIN=IABS(JBP-JBT)                                               
      LXMAX=JBP+JBT                                                     
      IF(LXMIN.LT.IABS(2*(LBP-LBT)))LXMIN=IABS(2*(LBP-LBT))             
      IF(LXMAX.GT.(2*(LBP+LBT)))LXMAX=2*(LBP+LBT)                       
C                                                                       
C                                                                       
      LXMAX=LXMAX/2                                                     
      LXMIN=LXMIN/2                                                     
      IPARIT = 1 - 2*MOD(LBP+LBT, 2)                                    
      JPMIN = JBP                                                       
      JPMAX = JBP                                                       
      JTMIN = JBT                                                       
      JTMAX = JBT                                                       
      IF ( LXMAX .GE. LXMIN ) GO TO 300                                 
      WRITE(6,263) JBP, JBT, LBP, LBT, LXMIN, LXMAX                       
 263  FORMAT ( '0**** INVALID BOUND STATE ANGULAR MOMENTA:' /  ' JP, JT,
     * LP, LT =', 2(I5, '/2'), 2I5 /  ' RESULTS IN  LXMIN, LXMAX =', 2I8
     * )                                                                
      IRET = 0                                                          
      GO TO 300                                                         
C                                                                       
C     SETUP LX RANGE FOR INELASTIC SCATTERING                           
C                                                                       
C                                                                       
C                                                                       
 270  IF ( EXS(4) .NE. EXS(3) ) GO TO 275                               
C                                                                       
C     PROJECTILE EXCITATION                                             
C                                                                       
      IEXCIT = 1                                                        
      LXMAX = JBPMAX                                                    
      LXMIN = JBPMIN                                                    
      JPMIN = JBPMIN                                                    
      JPMAX = JBPMAX                                                    
      JTMIN = 0                                                         
      JTMAX = 0                                                         
      JIN = JA                                                          
      JOUT = JB                                                         
      IPARIT = PARITS(1)*PARITS(2)                                      
      IF ( EXS(2) .NE. EXS(1) ) GO TO 280                               
      WRITE(6,273)
 273  FORMAT ( '0**** E*B OR E*BIGB MUST BE DEFINED' )                  
      IRET = 0                                                          
      GO TO 280                                                         
C                                                                       
C     TARGET EXCITATION                                                 
C                                                                       
 275  IEXCIT = 2                                                        
      LXMAX = JBTMAX                                                    
      LXMIN = JBTMIN                                                    
      JPMIN = 0                                                         
      JPMAX = 0                                                         
      JTMIN = JBTMIN                                                    
      JTMAX = JBTMAX                                                    
      JIN = JBIGA                                                       
      JOUT = JBIGB                                                      
      IPARIT = PARITS(3)*PARITS(4)                                      
      IF ( EXS(2) .EQ. EXS(1) ) GO TO 280                               
      WRITE(6,278)
 278  FORMAT ( '0**** CANNOT SIMULTANEOUSLY EXCITE BOTH PROJECTILE',  ' 
     *AND TARGET.' )                                                    
      IRET = 0                                                          
C                                                                       
 280  IF ( MOD(LXMIN, 2) .EQ. 0 ) GO TO 285                             
      WRITE(6,283) LXMIN, LXMAX, IEXCIT                                   
 283  FORMAT ( '0**** INELASTIC EXCITATION MUST INVOLVE AN',  ' INTEGER 
     *CHANGE IN NUCLEAR SPINS', 3I8 )                                   
      IRET = 0                                                          
 285  LXMIN = LXMIN/2                                                   
      LXMAX = LXMAX/2                                                   
C                                                                       
C     IF WE KNOW THE PARITIES, WE CAN REFINE LXMIN AND LXMAX            
C     AND STORE A BETTER LBP OR LBT.                                    
C                                                                       
      IF ( IPARIT .EQ. 0 ) GO TO 290                                    
      I = (IPARIT+3)/2                                                  
      LXMIN = LXMIN + MOD(I+LXMIN, 2)                                   
      LXMAX = LXMAX - MOD(I+LXMAX, 2)                                   
      LBNDS(IEXCIT) = LXMIN                                             
C                                                                       
 290  IF ( LXMAX .EQ. LXMIN .OR. LX .NE. NOTDEF ) GO TO 300             
      IF ( IPARIT .NE. 0 ) GO TO 295                                    
      WRITE(6,293)
 293  FORMAT ( X, 120('*') /  ' **** WARNING, THE PARITIES OF THE STAT
     *ES MUST BE KNOWN',  ' TO UNIQUELY DETERMIN THE MULTIPOLARITY OF TH
     *E EXCITATION' /  ' **** PTOLEMY ASSUMES THAT THE CHANGE IN THE INT
     *RINSIC PARITY', ' IS JUST  (-1)**!J(IN)-J(OUT)!.' /  ' ', 120('*')
     * )                                                                
      LXMAX = LXMAX - MOD( LXMIN+LXMAX, 2 )                             
      GO TO 300                                                         
C                                                                       
 295  IF ( LXMAX .GT. LXMIN ) GO TO 300                                 
      WRITE(6,298) IPARIT, JIN, JOUT, LXMIN, LXMAX                        
 298  FORMAT ( '0**** ERROR:  PARITIES AND J-VALUES RESULT IN',  ' IMPOS
     *SIBLE EXCITATION:', I4, 2(I4,'/2'), 2I4 )                         
      IRET = 0                                                          
C                                                                       
C     DOES HE WANT ONLY ONE LX OR ALL OF THEM?                          
C                                                                       
  300 ONELSW = LX .NE. NOTDEF                                           
      IF ( .NOT. ONELSW ) GO TO 340                                     
C                                                                       
      IF ( LXMIN .LE. LX .AND. LX .LE. LXMAX ) GO TO 330                
      IF ( TRANSW )  WRITE(6,303) JBP,JBT,LBP,LBT,LXMIN,LXMAX,LX    
  303 FORMAT ( '0**** ERROR IN INPUT:' /  ' JBP, JBT, LBP, LBT =', 2(I5,
     * '/2'), 2I5 /  ' AND RESULTS IN' /  ' LXMIN, LXMAX =', 2I5 /  ' BU
     *T LX HAS BEEN INPUT AS', I5 / )                                   
      IF ( .NOT. TRANSW ) WRITE(6,307) JS(3),JS(1),JS(2),JS(4),IPARIT
     *, LXMIN, LXMAX, LX                                                
 307  FORMAT ( '0**** ERROR:  PARTICLE SPINS ARE', I5, '/2(',  I3, '/2,'
     *, I3, '/2)', I3, '/2',  4X, 'PARITY CHANGE =', I2 /  ' **** WHICH 
     *RESULT IN',  '  LXMIN, LXMAX =', 2I4, 5X, 'BUT LX =', I4,  ' WAS S
     *PECIFIED.' )                                                      
      IRET = 0                                                          
C                                                                       
  330 LXMIN = LX                                                        
      LXMAX = LXMIN                                                     
C                                                                       
 340  NUMLX = LXMAX-LXMIN+1                                             
      NUMLXI = (LXMAX-LXMIN)/2 + 1                                      
      IF ( .NOT. TRANSW ) GO TO 400                                     
C                                                                       
C  SUM OVER JX NEXT,WHERE LBP+JX=JBP, AND LBT+JX=JBT                    
C                                                                       
      JXMAX=2*LBP+JBP                                                   
      IF(JXMAX.GT.(2*LBT+JBT))JXMAX=2*LBT+JBT                           
      JXMIN=IABS(2*LBP-JBP)                                             
      IF(JXMIN.LT.IABS(2*LBT-JBT))JXMIN=IABS(2*LBT-JBT)                 
      IF ( JXMAX .GE. JXMIN ) GO TO 342                                 
      WRITE(6,341) JBP, JBT, LBP, LBT, JXMIN, JXMAX                       
  341 FORMAT ( '0**** INVALID BOUND STATE ANGULAR MOMENTA:' /  ' JP, JT,
     * LP, LT =', 2(I5, '/2'), 2I5 /  ' RESULTS IN  JXMIN, JXMAX =', 2(I
     *7, '/2') )                                                        
      IRET = 0                                                          
C                                                                       
C     WE PRESENTLY ALLOW ONLY ONE JX                                    
C                                                                       
  342 IF ( JX .NE. NOTDEF ) GO TO 345                                   
      IF ( JXMIN .EQ. JXMAX ) GO TO 350                                 
      WRITE(6,343) JXMIN, JXMAX                                           
  343 FORMAT ( '0***** ERROR: MORE THAN ONE JX IS POSSIBLE BUT JX WAS', 
     * ' NOT SET.  JXMIN, JXMAX =', 2(I5, '/2') / )                     
      IRET = 0                                                          
      GO TO 400                                                         
  345 IF ( JXMIN .LE. JX .AND. JX .LE. JXMAX ) GO TO 400                
      WRITE(6,348) JXMIN, JXMAX, JX                                       
  348 FORMAT ( '0**** ERROR, JXMIN, JXMAX, JX =', 3(I5, '/2') / )       
      IRET = 0                                                          
      GO TO 400                                                         
  350 JX = JXMIN                                                        
C                                                                       
C     COMPUTE L CRITICAL                                                
C                                                                       
 400  LCRIT = (LCRITS(1)+LCRITS(2))/2                                   
C                                                                       
C     IF AN ARRAY NAMED LVALUES IS DEFINED, WE USE IT AS THE            
C     ARRAY OF L-VALUES AT WHICH THE COMPUTATIONS ARE DONE.             
C     OTHERWISE WE MUST FIND LMIN AND LMAX AND ANGSET WILL              
C     SET UP AN UNIFORMLY SPACED ARRAY.                                 
C                                                                       
      ILVALU = NAMLOC( 'LVALUES ' )                                     
      IF ( ILVALU .EQ. 0 ) GO TO 430                                    
      NUMLIS = LENG(ILVALU)                                             
      ILIS = NALLOC( (NUMLIS+1)/FACFR4, 'LIS ' )                        
      LLVALU = Z(ILVALU)-1                                              
      LMIN = ALLOC(LLVALU+1)                                            
      L1 = -1                                                           
      LSTEP = 1                                                         
      DO 419 I = 1, NUMLIS                                              
      L = ALLOC(LLVALU+1)                                               
      IF ( L .GT. L1 ) GO TO 415                                        
      WRITE(6,413) I, L, L1                                               
 413  FORMAT ( '0*** LVALUES ARRAY MUST BE INCREASING:  ',  'ELEMENT', I
     *4, ' IS ', I5, ', PREVIOUS IS', I4 )                              
      RETURN                                                            
 415  ILLOC(FACFR4*Z(ILIS)-FACFR4+I) = L                                
      LSTEP = MAX0( LSTEP, L-L1 )                                       
      L1 = L                                                            
 419  CONTINUE                                                          
      LMAX = L                                                          
      GO TO 450                                                         
C                                                                       
C     NOW ESTIMATE LMIN, LMAX FROM L CRITICAL IF THEY WERE NOT GIVEN    
C                                                                       
 430  LMININ = LMIN                                                     
      IF ( LMIN .NE. NOTDEF ) GO TO 440                                 
      IF ( LMINSB .EQ. NOTDEF ) LMINSB = 10                             
      LMIN = LCRIT*ALMNMT                                               
      LMIN = MAX0( 0, MIN0( LMIN, LCRIT-LMINSB ) )                      
 440  IF ( LMAX .NE. NOTDEF ) GO TO 450                                 
      LMAX = ALMXMT*LCRIT                                               
      LMAX = MAX0( LMAX, LCRIT + MAX0(4*LSTEP, LMAXAD) )                
C                                                                       
C     IF THERE ARE IDENTICAL PARTICLES IN EXIT OR ENTRANCE CHANNEL,     
C     MUST FIX UP CHOICE OF L'S NOW.                                    
C                                                                       
 450  IDENSW = .FALSE.                                                  
      LSKIP = MAX0( LSKIPS(1), LSKIPS(2) )                              
      IF ( ISTATS(1) .EQ. 3 ) GO TO 460                                 
      IF ( JA .EQ. 0 ) GO TO 455                                        
 452  WRITE(6,453)
 453  FORMAT ( '0**** ONLY SPIN-0 IDENTICAL PARTICLES MAY BE USED',  ' F
     *OR NOW.' )                                                        
      IRET = 0                                                          
      GO TO 500                                                         
C     ENTRANCE CHANNEL MUST HAVE ONLY EVEN PARTIAL WAVES                
 455  LIBASE = 0                                                        
      GO TO 470                                                         
C                                                                       
 460  IF ( ISTATS(2) .EQ. 3 ) GO TO 480                                 
      IF ( JB .GT. 0 ) GO TO 452                                        
C     EXIT CHANNEL MUST HAVE EVEN WAVES                                 
      LIBASE = MOD( LBP+LBT, 2 )                                        
C                                                                       
C     IDENTICAL PARTICLES; MAKE ADJUSTMENTS                             
C                                                                       
 470  IDENSW = .TRUE.                                                   
      LSTEP = LSTEP + MOD(LSTEP, 2)                                     
C                                                                       
C     MAKE LMIN AND LMAX LSTEP MULTIPLES                                
C                                                                       
 480  IF ( LMININ .EQ. NOTDEF ) LMIN = LSTEP*(LMIN/LSTEP)               
      IF ( LSKIP .NE. 1 ) LMIN = IABS( LMIN-LIBASE )                    
      LMAX = LSTEP*((LMAX-LMIN+LSTEP-1)/LSTEP) + LMIN                   
C                                                                       
C    PROCESS SPECTROSCOPIC OR DEFORMATION FACTORS                       
C                                                                       
 500  IF ( TRANSW ) GO TO 580                                           
C                                                                       
C     SETUP EXCITATION POTENTIAL PARAMETERS                             
C     ALLOW OVERRIDES OF THE POTENTIAL PARAMETERS FROM THE INCOMING     
C     STATE WHICH IS THE DEFAULT.                                       
C                                                                       
      EMUL = ELAB                                                       
      IF ( IEPOW .EQ. 1 ) EMUL = 1/ELAB                                 
      IF ( R0 .NE. UNDEF ) R = R0MASS*(R0+EMUL*(R0E+EMUL*R0ESQ))        
      IF ( RI0 .NE. UNDEF ) RI = R0MASS*(RI0+EMUL*(RI0E+EMUL*RI0ESQ))   
      IF ( RSI0 .NE. UNDEF ) RSI = R0MASS*RSI0                          
      TAR = A + EMUL*(AE+EMUL*AESQ)                                     
      TAI = AI + EMUL*(AIE+EMUL*AIESQ)                                  
      TVR = V + EMUL*(VE+EMUL*VESQ)                                     
      TVI = VI + EMUL*(VIE+EMUL*VIESQ)                                  
      IF ( RC0 .NE. UNDEF ) RC = R0MASS*RC0                             
C                                                                       
C     ALWAYS USE POINT AND SPHERE COULOMB FOR EFFECTIVE EXCITATION      
C                                                                       
      RCP = 0                                                           
      RCT = RC                                                          
C                                                                       
      IF ( RI .EQ. UNDEF ) RI = R                                       
C                                                                       
      IF ( R .NE. UNDEF .AND. RC .NE. UNDEF ) GO TO 510                 
      WRITE(6,503) R, RC                                                  
 503  FORMAT ( '0**** BOTH R AND RC (OR R0 AND RC0) MUST BE',  ' DEFINED
     * TO COMPUTE DEFORMATION LENGTHS:' /  6X, 'R, RC = ', F8.3, 1X, F8.
     *3 )                                                               
      IRET = 0                                                          
      RETURN                                                            
C                                                                       
 510  R0 = R/R0MASS                                                     
      RI0 = RI/R0MASS                                                   
      RC0 = RC/R0MASS                                                   
      VC = -3*IZS(1)*IZS(3)*HBARC / AFINE                               
      R2S(4) = VC                                                       

C                                                                       
      IF ( COUPSW ) GO TO 600                                           
C                                                                       
C     DEFOMATION LENGTHS INVOLVE ONLY TARGET OR PROJECTILE RADIUS       
C                                                                       
      R2MASS = AMS(2*IEXCIT-1)**(1.D0/3.D0)                             
      R2S(1) = R0*R2MASS                                                
      R2S(2) = RI0*R2MASS                                               
      R2S(3) = RC0*R2MASS                                               
C                                                                       
C     PROCESS DEFORMATION PARAMETERS FOR INELASTIC SCATTERING.          
C     DEFAULT VALUES ARE 1 FOR NUCLEAR AND                              
C     RC2 BETAC = R2 BETA  FOR COULOMB                                  
C                                                                       
C     HERE WE SETUP THE IBETAS ARRAY AS FOLLOWS                         
C                                                                       
C       1 - BETA (NUCLEAR)                                              
CC      2 - BETACOULOMB                                                 
C       3 - A PRESENTLY EMPTY ARRAY                                     
C       4 - BE(LX)                                                      
C                                                                       
C     THESE DEFINITIONS WILL BE CHANGED JUST BEFORE STATEMENT 580       
C                                                                       
      BETA = 1                                                          
      DO 549 II = 1, 4                                                  
      IB = NAMLOC(BETNAM(II))                                           
      BETSWS(II) = IB .NE. 0                                            
      LEN = 0                                                           
      IF ( IB .EQ. 0 ) GO TO 540                                        
 520  BETA = ALLOC(Z(IB))                                               
      LEN = LENG(IB)                                                    
      IF ( LEN .EQ. NUMLXI ) GO TO 548                                  
      IF ( LEN .LE. 1 ) GO TO 540                                       
      WRITE(6,533) BETNAM(II), LEN, NUMLXI                                
 533  FORMAT ( '***** ', A8, ' WAS DEFINED TO HAVE', I4,  ' VALUES BUT T
     *HERE ARE', I4, ' VALUES OF LX' )                                  
      IRET = 0                                                          
      GO TO 548                                                         
C                                                                       
 540  IB = NALLOC( NUMLXI, BETNAM(II) )                                 
      DO 544 I = 1, NUMLXI                                              
      ALLOC(Z(IB)-1+I) = BETA                                           
 544  CONTINUE                                                          
C                                                                       
 548  IBETAS(II) = IB                                                   
 549  CONTINUE                                                          
C                                                                       
C                                                                       
      CHARGE = IZS(2*IEXCIT-1)                                          
      IBETNR = NALLOC( NUMLXI, 'BETANRAT' )                             
      LBETA = Z(IBETAS(1))-LXMIN/2                                      
      LBETAC = Z(IBETAS(2))-LXMIN/2                                     
      LBETAR = Z(IBETAS(3))-LXMIN/2                                     
      LBELX = Z(IBETAS(4))-LXMIN/2                                      
      LBETNR = Z(IBETNR) - LXMIN/2                                      
C                                                                       
C     INITIALIZE FOR CLEBSCH'S IN BE TO BETA                            
C                                                                       
      CALL DUMMY1                                                       
      K = MOD(JIN, 2)                                                   
C                                                                       
C     MAKE SURE THE BETA(COULOMB) ARE DEFINED                           
C                                                                       
      IF ( BETSWS(2) ) GO TO 560                                        
      IF ( BETSWS(4) ) GO TO 555                                        
      WRITE(6,553)
 553  FORMAT ( '0**** WARNING:  BETA COULOMB IS BEING CHOSEN SUCH',  ' 
     *THAT:' /  16X, 'RC*BETACOULOMB = R*BETA',  4X, 'WHERE RC AND R REF
     *ER ONLY TO THE EXCITED NUCLEUS' )                                 
      DO 554 LX = LXMIN, LXMAX, 2                                       
      ALLOC(LBETAC+LX/2) = (R2S(1)/R2S(3)) * ALLOC(LBETA+LX/2)          
 554  CONTINUE                                                          
      GO TO 560                                                         
C                                                                       
C     GET COULOMB BETAS FROM B(E LX)                                    
C                                                                       
 555  DO 559 LX = LXMIN, LXMAX, 2                                       
      ALLOC(LBETAC+LX/2) = (4*PI/(3*CHARGE)) *  DSQRT( ALLOC(LBELX+LX/2)
     * )  / ( (R2S(3)/10)**LX * CLEBSH( JIN, 2*LX, K, 0, JOUT, K ) )    
 559  CONTINUE                                                          
C                                                                       
C     COULOMB BETAS NOW SETUP - PROCEED TO NUCLEAR BETAS                
C                                                                       
 560  IF ( BETSWS(1) ) GO TO 570                                        
      IF ( BETSWS(2) .OR. BETSWS(4) ) GO TO 565                         
      WRITE(6,563)
 563  FORMAT ( X, 120('*') / ' **', T120, '**' /  ' **    WARNING:  BE
     *TA ASSUMED TO BE 1 --',  ' MUST MULTIPLY CROSS SECTIONS BY SQUARE 
     *OF ACTUAL',  ' BETA TO GET TRUE VALUES.', T120, '**' /  ' ** ', T1
     *20, '**' / 1X, 120('*') / )                                       
      GO TO 570                                                         
 565  DO 569 LX = LXMIN, LXMAX, 2                                       
      ALLOC(LBETA+LX/2) = (R2S(3)/R2S(1)) * ALLOC(LBETAC+LX/2)          
 569  CONTINUE                                                          
C                                                                       
C     NOW DEFINE AUXILARY QUANTITIES                                    
C     BETARAT CONTAINS  (BETACOULOMB) ( RC2**LX / (2*LX+1) )            
C         * CLEBSCH( JIN, LX, K, 0: JOUT, K )                           
C     BETANRAT CONTAINS  BETA                                           
C         * CLEBSCH( JIN, LX, K, 0: JOUT, K )                           
C                                                                       
 570  DO 574 LX = LXMIN, LXMAX, 2                                       
      TEMP = CLEBSH( JIN, 2*LX, K, 0, JOUT, K )                         
      ALLOC(LBETAR+LX/2) = ALLOC(LBETAC+LX/2)*TEMP  * R2S(3)**LX / (2*LX
     *+1.D0)                                                            
      ALLOC(LBETNR+LX/2) = ALLOC(LBETA+LX/2)*TEMP                       
      ALLOC(LBELX+LX/2) = ( 3*CHARGE*ALLOC(LBETAC+LX/2)  * TEMP * (R2S(3
     *)/10)**LX  / (4*PI) )**2                                          
C                                                                       
 574  CONTINUE                                                          
C                                                                       
C     WE WILL USE BETANRAT, BETARAT  FROM NOW ON.                       
C                                                                       
C     THE FINAL DEFINITION OF THE IBETAS ARRAY IS                       
C        1 - BETA (NUCLEAR)                                             
C        2 - BETANRAT                                                   
C        3 - BETARAT                                                    
C        4 - BE(LX)                                                     
C                                                                       
      IBETAS(2) = IBETNR                                                
      GO TO 600                                                         
C                                                                       
C     PROCESS SPECTROSCOPIC INFO FOR TRANSFER                           
C                                                                       
 580  IF ( SPAMP .EQ. 1 ) SPAMP = DSQRT(SPFACP)                         
      SPFACP = SPAMP**2                                                 
      IF ( SPAMT .EQ. 1 ) SPAMT = DSQRT(SPFACT)                         
      SPFACT = SPAMT**2                                                 
C                                                                       
C     HERE WE SETUP THE A-TERMS                                         
C                                                                       
      IBETAS(1) = NALLOC( LXMAX+1, 'ATERM ' )                           
C                                                                       
C     INITIALIZE FOR THE RACAHS                                         
C                                                                       
      CALL DUMMY1                                                       
      LATERM = Z(IBETAS(1))                                             
      TEMP = (JBIGB+1.D0)/(JBIGA+1)                                     
      IF ( ISTRIP .EQ. -1 ) TEMP = (JB+1.D0)/(JA+1)                     
      TEMP = DSQRT(TEMP)                                                
      DO 589 LX = LXMIN, LXMAX                                          
      ATERM = TEMP*DSQRT(2*LX+1.D0) * SPAMP*SPAMT * RACAH( 2*LBT, JBT, 2
     **LBP, JBP, JX, 2*LX )                                             
      ITEST = JX - JBP + 2*(LBP+LBT)                                    
      IF ( ISTRIP .EQ. -1 ) ITEST = JX-JBT+JA+JBIGA-JB-JBIGB            
      ITEST = ITEST/2 + 1                                               
      IF ( MOD(ITEST, 2) .NE. 0 ) ATERM = -ATERM                        
      ALLOC(LATERM+LX) = ATERM                                          
      IF ( IPRNT .GE. 4 ) WRITE(6,587) LX, ITEST, ATERM                   
 587  FORMAT ( ' LX =', I3, 5X, 'SIGN, ATERM =', I4, G15.8 )            
 589  CONTINUE                                                          
C                                                                       
C     PRODUCE A NICE SUMMARY OF THE REACTIONS                           
C                                                                       
 600  IF ( .NOT. PRNTSW ) GO TO 800                                     
      NUMPAR = 4 + IABS(ISTRIP)                                         
      WRITE(6,623) REACT,XWORDS(NUMPAR-3),(AMS(IND(J)),J=1,NUMPAR)  
      WRITE(6,624) (IZS(IND(J)), J = 1, NUMPAR)                           
      WRITE(6,625) (EXS(IND(J)), J = 1, NUMPAR)                           
      WRITE(6,626) (JS(IND(J)), J = 1, NUMPAR)                            
      WRITE(6,627) ( PWORD(PARITS(IND(J))+2), J = 1, NUMPAR )             
 623  FORMAT ( 21X, 'SUMMARY OF THE REACTION' /  24X, 45A1 /  
     * X, T19, 'BIGA   (   A   ,    B   )  BIGB   ', A8 /  ' M (AMU)', 
     *T15, 5F9.2 )                                                      
 624  FORMAT ( ' Z', T12, 5I9 )                                         
 625  FORMAT( ' E* (MEV)', T17, 5F9.4 )                                 
 626  FORMAT ( ' J', T14, 5( I7, '/2' ) )                               
 627  FORMAT ( ' PARITY', T16, 5( A7, 2X ) )                            
C                                                                       
      IF ( .NOT. TRANSW ) GO TO 680                                     
      WRITE(6,643) EBNDS,Q,JBP,JBT,LBP,LBT,NBNDS,SPAMP,SPAMT,SPF
     *ACP, SPFACT                                                       
 643  FORMAT ( / 6X, 'BOUND STATE PROPERTIES' /  12X, 'PROJECT
     *ILE', 3X, 'TARGET' /  ' E', T12, 2F10.4 , 10X, 'Q =', F9.4 /  ' JP
     *', T10, 2( I8, '/2' ) /  ' L', T9, 2I10 /  ' NODES', T9, 2I10 /  '
     * SPEC. AMP.', T12, 2F10.4 /  ' SPEC. FACTOR', T14, F8.4, F10.4 )  
C                                                                       
C                                                                       
      IF ( ISTRIP .EQ. 1 ) WRITE(6,663)
 663  FORMAT ( ' THIS IS A STRIPPING REACTION' )                        
      IF ( ISTRIP .EQ. -1 ) WRITE(6,664)
 664  FORMAT ( ' THIS IS A PICKUP REACTION' )                           
C                                                                       
      WRITE(6,672)
 672  FORMAT ( ' THE EXCHANGE POTENTIAL CONSISTS OF' )                  
      IF ( IVRTEX .EQ. 1 ) WRITE(6,673)
 673  FORMAT ( '    THE NUCLEAR POTENTIAL AT THE PROJECTILE VERTEX' )   
      IF ( IVRTEX .EQ. 2 ) WRITE(6,674)
 674  FORMAT ( '    THE NUCLEAR POTENTIAL AT THE TARGET VERTEX' )       
      IF ( NUCONL .EQ. 0 ) WRITE(6,677)
 677  FORMAT ( '    AND THE COULOMB POTENTIAL AT THE SAME VERTEX.' )    
      IF ( NUCONL .GE. 2 ) WRITE(6,678)
 678  FORMAT ( '    AND THE COULOMB POTENTIAL INCLUDING CORE-CORE' ,  ' 
     *CORRECTION TERMS' )                                               
      IF ( NUCONL .EQ. 3) WRITE(6,679)
  679 FORMAT( '    AND THE CORE-CORE CORRECTIONS FROM THE REAL' ,  ' PAR
     *T OF THE NUCLEAR OPTICAL POTENTIAL')                              
      GO TO 750                                                         
C                                                                       
C     PRINTOUT FOR INELASTIC SCATTERING                                 
C                                                                       
 680  IF ( COUPSW ) GO TO 750                                           
C                                                                       
      WRITE(6,683) WORDS(2*IEXCIT-1),WORDS(2*IEXCIT),(LX,ALLOC(LBETA+
     *LX/2), ALLOC(LBETAC+LX/2),ALLOC(LBELX+LX/2),LX=LXMIN,LXMAX,2)
 683  FORMAT (' THE REACTION IS INELASTIC EXCITATION OF THE ',2A8 / 
     *' LX',9X,'DEFORMATION PARAMETERS',T44,'B(E(LX))'/T13,'NUCLEAR', 
     *T28, 'COULOMB', T41, '(E**2 BARN**LX)' /  (I3, 5X, 3G15.5)) 
      WRITE(6,687) ( R2S(I), I = 1, 3 )
 687  FORMAT (' DEFORMATION RADII:'/'   REAL',F14.4 /3X,'IMAGINARY', 
     *F9.4 /  3X, 'COULOMB', F11.4)                               
C                                                                       
 750  WRITE(6,751) LCRITS, LCRIT                                          
 751  FORMAT ( / ' ESTIMATED CRITICAL L  S:    INCOMING =', I4,  5X, 'OU
     *TGOING =', I4, 5X, 'AVERAGE =', I4 )                              
      IF ( COUPSW ) GO TO 760                                           
      IF ( ONELSW ) WRITE(6,753) LXMIN                                    
 753  FORMAT ( 6X, 'LX =', I3 )                                    
      IF ( .NOT. ONELSW ) WRITE(6,754) LXMIN, LXMAX                       
 754  FORMAT ( X, I5, '  =< LX =<', I3 )                              
      WRITE(6,757) LMIN, LMAX                                             
 757  FORMAT ( X, T25, I5, '  =<  LIN, LOUT  =<', I4 )                
      GO TO 765                                                         
 760  WRITE(6,763) LMIN, LMAX                                             
 763  FORMAT ( ' FOR COMPUTED S MATRICES:', I6, ' =< J OR LIN =<', I5 ) 
 765  IF ( ILVALU .EQ. 0 ) WRITE(6,767) LSTEP                             
 767  FORMAT ( X, T60, 'LSTEP =', I3 )                                
      IF ( ILVALU .NE. 0 ) WRITE(6,768) LSTEP                             
 768  FORMAT (X, T60, 'USING SPECIFIED VALUES WITH A',  ' MAXIMUM LSTE
     *P OF', I4 )                                                       
C                                                                       
C                                                                       
C     CHECK VALIDITY OF Q AND PRINT WARNINGS.                           
C                                                                       
 800  IF ( .NOT. TRANSW ) GO TO 810                                     
      IF ( DABS( EBNDS(1)-EBNDS(2)-ISTRIP*Q ) .GT. .001 ) WRITE(6,803)
 803  FORMAT ( '0**** WARNING:  Q IS NOT EQUAL TO THE DIFFERENCE',  ' OF
     * THE BOUND STATE ENERGIES.' )                                     
 810  IF ( DABS( ECM+Q - ES(2) ) .GT. .001 )  WRITE(6,813)
 813  FORMAT ( '0**** WARNING:  THE DIFFERENCE OF THE C.M. SCATTERING', 
     * ' ENERGIES IS NOT EQUAL TO Q.' )                                 
C                                                                       
      LOMOST = LMAX + LXMAX                                             
C     INCASE LINTRP IS NOT USED:                                        
      LIMOST = LMAX                                                     
C                                                                       
C     CERTAIN THINGS THAT FOLLOW DON'T LIKE  LCRIT = 0                  
C                                                                       
      IF ( LCRIT .EQ. 0 ) LCRIT = LMAX/2                                
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE PRTCHI ( WT, ASHIFT, IREACT, RENORM )                  
C                                                                       
C     PRINT THE CHI. SQ. INFO. AT THE START AND END OF A FIT            
C                                                                       
C                                                                       
C     11/4/75 - SEPARATED FROM CALFUN - S.P.                            
C     11/20/75 - ANGLESHIFT, HEADER ADDED - S.P.                        
C     12/28/75 - ADD PRTDER ENTRY                                       
C     2/18/76 - PRINT GRADIENT OF CHI.SQR./POINT                        
C     8/1/76 - SPLIT OFF PRTDER                                         
C     4/15/77 - SMALL FIXES                                             
C     10/16/77 - POWERS OF WOODS SAXONS                                 
C     11/22/77 - USE TEMPVS COMMON - S.P.                               
C     11/27/77 - LINKULES                                               
C     1/18/78 - CDC BECOMES CDB                                         
C     3/24/78 - WAVEFUNTION LINKULES - S.P.                             
C     5/10/79 - COMPUTE RCOP, RCOT; R0MASS ALWAYS DEFINED - S.P.        
C     12/28/79 - STANDARD MORTRAN - RPG                                 
C     2/25/80 - REMOVE 1ST INDEX OF LNKNAM; CHAR*8 WORDS ETC. - RPG     
C     3/15/80 - BACK TO TWO SUBSCRIPTS ON LNKNAM - S.P.                 
C     5/17/82 - PRINT VSI EVEN WHEN VI IS DONE BY LINKULE - S.P.        
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
CDC      ALLOCLEVEL IREACT                                              
      DIMENSION IREACT(11)                                              
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 PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /LOCFIT/ IDATA, LPL, LSIGMA, LSMAT, IESETS, IMASK, IEQUAL, 
     *NPARA, IPARA, ITEMP, LSCSIG, LEPARM, LFS, NPTS, LEQNAM, MAXEQL, MA
     *XVS, LVDERV, LSDELS, LDVTYP, LDSDP, LDFDX, LFGRAD, LTGRAD, LMASK, 
     *LEQUAL, MNDRIV, MXDRIV, IESIZE, LENPRE, LENKEY, LENHED, ILNKBL    
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
      COMMON /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
      COMMON / TEMPVS / TVR, TVI, TVSOR, TVSOI, TAR, TAI                
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
C                                                                       
      real*8 WORDS(2) / 'INITIAL ', '  FINAL ' /                        
C                                                                       
      real*8 POTTYP(5) / '    REAL', 'IMAGINAR', ' REAL SO',  ' IMAG SO'
     *, ' COULOMB' /                                                    
      real*8 BLANK / ' ' /                                              
C                                                                       
C                                                                       
      LOGICAL SOSW, SOISW, IMAGSW                                       
C                                                                       
      IMAGSW = TVI .NE. 0                                               
      SOSW = TVSOR .NE. 0                                               
      SOISW = TVSOI .NE. 0                                              
      LWORDS = Z(NAMLOC('FITWORDS')) - 1                                
      IF(IOFFIT.NE.1)GO TO 100                                          
      IF(ITEMP.EQ.1)WRITE(6, 63)                                        
 63   FORMAT(/ '-INITIAL ITERATION '/)                                  
      IF(ITEMP.EQ.3)WRITE(6, 64)                                        
 64   FORMAT(/ '-FINAL FIT'/)                                           
      DO 89 I=1,NPARA                                                   
CDBC                                                                    
CDBC     FOLLOWING IS REALLY JUST FOR BERKELEY'S STUPIDITY              
CDBC                                                                    
CDB      IF ( MAXEQL .NE. 0 )  PRINT 77,                                
CDB     1  ( ALLOC(LEQNAM+(I-1)*MAXEQL+II), II = 1, MAXEQL )            
      WRITE(6, 73)ALLOC(LWORDS+I), ALLOC(IPARA-1+I)                     
 73   FORMAT(' ',10X,A8,' =',G15.5)                                     
      IF ( MAXEQL .EQ. 0 ) GO TO 89                                     
      IF ( ALLOC(LEQNAM+(I-1)*MAXEQL+1) .EQ. BLANK ) GO TO 89           
      WRITE(6,77)( ALLOC(LEQNAM+(I-1)*MAXEQL+II), II = 1, MAXEQL )       
  77  FORMAT ( X, ( T40, 6( A5, A8 ) ) )                              
 89   CONTINUE                                                          
C                                                                       
C  PRINT HEADER                                                         
C                                                                       
 100  WRITE(6,103) WORDS(ITEMP/2+1),(ALLOC(LWORDS+I),I=1,NPARA)   
 103  FORMAT ( X, T48, 'P T O L E M Y' /  1X, 'ELASTIC SCATTERING FIT 
     *- ', A8, 'VALUES',  T75, 'FITTING:', ( T85, 6A8 ) )               
      WRITE(6,108) IREACT, HEADER                                         
 108  FORMAT ( 1X, 11A4, 21X, 65A1 )                                    
CDC 108  FORMAT ( 1X, 11A1, 54X, 65A1 )                                 
      WRITE(6,123)ELAB, WT, ASHIFT, RENORM                              
123   FORMAT( '-E LAB =', F9.4, ' MEV', 10X, ' WEIGHT =', F9.4,  10X, 'L
     *AB-ANGLE SHIFT =', F7.3, ' DEGREES' ,  10X, 'RENORM =', F7.4 )    
C                                                                       
C     RECOMPUTE R0'S FOR PRINTING                                       
C                                                                       
      TEMP1 = R/R0MASS                                                  
      IF ( TVI .NE. 0 ) TEMP2 = RI/R0MASS                               
      IF ( VSO .NE. 0 ) TEMP3 = RSO/R0MASS                              
      IF ( VSOI .NE. 0 ) TEMP4 = RSOI/R0MASS                            
      IF ( VSI .NE. 0 ) TEMP5 = RSI/R0MASS                              
      TEMP6 = RC/R0MASS                                                 
      ETA = ETAS(1)                                                     
      NSTEP = NSTPSS(1)                                                 
C                                                                       
C     WITH THE EXCEPTION OF STMNTS 420 AND 429, ALL OF THE FOLLOWING    
C     ARE LIFTED DIRECTLY FROM WAVSET.                                  
C                                                                       
 420  WRITE(6,429)
 429  FORMAT (  ' POTENTIAL', T20, 'COUPLING CONS.', T38, 'RADIUS',  T48
     *, 'DIFFUSENESS', T63, 'RADIUS PARAMETER',  T82, 'POWER' / )       
C                                                                       
      I = 1                                                             
      IF ( LNKADR(3,1) .NE. 0 ) GO TO 550                               
      WRITE(6,437) TVR, R, TAR, TEMP1, POWRL                              
 437  FORMAT ( ' REAL', T20, G14.5, T37, F7.4, T49, F7.4, T67, F7.4,  T8
     *0, F7.3 )                                                         
C                                                                       
 440  IF ( .NOT. IMAGSW ) GO TO 450                                     
      I = 2                                                             
      IF ( LNKADR(3,2) .NE. 0 ) GO TO 550                               
      WRITE(6,443) TVI, RI, TAI, TEMP2, POWIM                             
 443  FORMAT (' IMAGINARY', T20, G14.5, T37, F7.4, T49, F7.4,  T67, F7.4
     *, T80, F7.3 )                                                     
 445  IF ( VSI .NE. 0 ) WRITE(6,446) VSI, RSI, ASI, TEMP5                 
 446  FORMAT ( ' SURFACE ABSORPTION:', T20, G14.5, T37, F7.4,  T49, F7.4
     *, T67, F7.4, T80, F7.3 )                                          
C                                                                       
 450  IF ( .NOT. SOSW ) GO TO 460                                       
      I = 3                                                             
      IF ( LNKADR(3,3) .NE. 0 ) GO TO 550                               
      WRITE(6,453) VSO, RSO, ASO, TEMP3, TAU                              
 453  FORMAT (' REAL SPIN-ORBIT', T20, G14.5, T37, F7.4, T49, F7.4,  T67
     *, F7.4, 5X, 'TAU  =', G13.5 )                                     
C                                                                       
 460  IF ( .NOT. SOISW ) GO TO 470                                      
      I = 4                                                             
      IF ( LNKADR(3,4) .NE. 0 ) GO TO 550                               
      WRITE(6,463) VSOI, RSOI, ASOI, TEMP4, TAUI                          
 463  FORMAT (' IMAG SPIN-ORBIT', T20, G14.5, T37, F7.4, T49, F7.4,  T67
     *, F7.4, 5X, 'TAUI =', G13.5 )                                     
C                                                                       
 470  IF ( ETA .EQ. 0 ) GO TO 500                                       
      I = 5                                                             
      IF ( LNKADR(3,5) .NE. 0 ) GO TO 550                               
      WRITE(6,183) ETA, RC, TEMP6                                         
 183  FORMAT ( ' COULOMB', T20, G14.5, T37, F7.4, T67, F7.4 )           
      IF((RCP.EQ.0).OR.(RCT.EQ.0)) GO TO 500                            
      TEMP2 = RCP / AMP**0.33333333333333333333 0D0                     
      TEMP3 = RCT / AMT**0.33333333333333333333 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                                                                       
C     WILL THE WAVE FUNCTIONS BE FOUND BY A LINKULE                     
C                                                                       
 500  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                                                             
      GO TO 560                                                         
 600  GO TO 900                                                         
C                                                                       
C                                                                       
C     CALL LINKULE TO PRINT STUFF ABOUT ITSELF                          
C                                                                       
 550  WRITE(6,553) POTTYP(I), LNKNAM(1,I)                                 
 553  FORMAT ( X, A8, ' POTENTIAL IS BEING COMPUTED BY THE ',  A8, ' L
     *INKULE:' )                                                        
C                                                                       
 560  CALL LINKUL ( LNKADR(3,I), LNKNAM(1,I), LNKADR(5,I),  I, 2, IRET, 
     * L, J, 0.D0, STEPSZ, NSTEP+1, DUMMY, DUMMY, 1 )                   
      WRITE(6,563)
 563  FORMAT ( ' ' )                                                    
      IF ( IRET .GE. 0 ) GO TO ( 440, 445, 460, 470, 500, 600 ), I      
      IRET = 0                                                          
      RETURN                                                            
C                                                                       
C                                                                       
  900 CONTINUE                                                          
C                                                                       
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE PRTDER(X,GRADSW,TGRAD,HESNSW,COVAR,WORK,MPARA,T1)
C                                                                       
C     THIS ENTRY PRINTS STUFF ABOUT THE FINAL GRADIENT AND/OR           
C     THE COVARIANCE MATRIX.                                            
C     IT ALSO PRINTS THE FIT TIMES                                      
C                                                                       
C     1/8/76 - SPLIT OFF FROM PRTCHI TO MAKE CDC EASIER.                
C     4/8/78 - COMPUTE DIAGONAL RMS DEVIATIONS CORRECTLY - S.P.         
C     5/26/78 - REAL*4 T1 FOR ALIGNMENT PROBS - S.P.                    
C     12/28/79 - STANDARD MORTRAN - RPG                                 
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL X,TGRAD,COVAR,WORK                                  
C                                                                       
      DIMENSION X(MPARA),TGRAD(MPARA),COVAR(MPARA,MPARA),WORK(MPARA)
      LOGICAL GRADSW , HESNSW                                           
      REAL*4 T1                                                         
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*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      REAL*4 T0                                                         
      COMMON /FITCOM/ T0, IP, IPL, IEPARM, IFS, MAXCAL, NROC, ISCSIG    
      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    
C                                                                       
      LWORDS = Z(NAMLOC('FITWORDS')) - 1                                
C                                                                       
      IF ( .NOT. (GRADSW .OR. HESNSW) ) GO TO 800                       
      WRITE(6,301)
 301  FORMAT ( X, T48, 'P T O L E M Y' /  T27, 'ELASTIC SCATTERING FIT
     * - FINAL VALUES AND UNCERTAINTIES' )                              
      WRITE(6,108) REACT, HEADER                                          
 108  FORMAT ( 1X, 48A1, 17X, 65A1 )                                    
      WRITE(6,303) ( ALLOC(LWORDS+I), I = 1, NPARA )                      
 303  FORMAT ( / X, T11, 'PARAMETER:', ( T23, 10( A8, 3X ) ) )        
C                                                                       
      WRITE(6,308) X                                                      
 308  FORMAT ( / ' FINAL VALUES:', ( T21, 10G11.3 ) )                   
C                                                                       
      IF ( .NOT. GRADSW ) GO TO 400                                     
C                                                                       
C     HERE PROCESS GRADIENT                                             
C                                                                       
      DO 309 I = 1, NPARA                                               
      TGRAD(I) = TGRAD(I)/NPTS                                          
 309  CONTINUE                                                          
      WRITE(6,313) TGRAD                                                  
 313  FORMAT ( / ' FINAL GRADIENT:', ( T21, 10G11.3 ) )                 
C                                                                       
      SUM = 0                                                           
      DO 319 I = 1, NPARA                                               
      TGRAD(I) = TGRAD(I)*X(I)                                          
      SUM = SUM + TGRAD(I)**2                                           
 319  CONTINUE                                                          
      WRITE(6,323) TGRAD                                                  
 323  FORMAT ( ' RELATIVE GRADIENT:', ( T21, 10G11.3) )                 
      SUM = DSQRT(SUM)                                                  
      WRITE(6,328) SUM                                                    
 328  FORMAT ( ' MAGNITUDE OF RELATIVE GRADIENT =', G15.5 )             
C                                                                       
 400  IF ( .NOT. HESNSW ) GO TO 800                                     
C                                                                       
C     HERE PROCESS THE COVARIANCE MATRIX                                
C                                                                       
C     TURN IT INTO .5 * SECOND DERIVATIVE MATRIX                        
C                                                                       
      CALL MATINV ( COVAR, NPARA, WORK, 0, DET, NPARA )                 
C                                                                       
C     NOW PRINT DIAGONAL RMS UNCERTAINTIES                              
C                                                                       
      DO 409 I = 1, NPARA                                               
      WORK(I) = 333.D+33                                                
      IF ( COVAR(I,I) .GT. 0 ) WORK(I) = DSQRT( 1/COVAR(I,I) )          
 409  CONTINUE                                                          
      WRITE(6,413) WORK                                                   
 413  FORMAT ( / ' RMS UNCERTAINTIES:', (T21, 10G11.3) )                
C                                                                       
C     MAKE THE RELATIVE SECOND DERIV MATRIX ( TIMES .5 )                
C                                                                       
      DO 429 I = 1, NPARA                                               
      DO 425 II = 1, NPARA                                              
      COVAR(I,II) = COVAR(I,II)*(X(I)*X(II))                            
 425  CONTINUE                                                          
      WORK(I) = 333.D+33                                                
      IF ( COVAR(I,I) .GT. 0 ) WORK(I) = DSQRT( 1/COVAR(I,I) )          
 429  CONTINUE                                                          
      WRITE(6,433) WORK                                                   
 433  FORMAT ( ' RELATIVE' / ' RMS UNCERTAINTIES:', (T21, 10G11.3) )    
C                                                                       
      CALL SDIAG ( NPARA, NPARA, 1.D-13, 30, COVAR, WORK,  COVAR, TGRAD 
     *)                                                                 
C                                                                       
      DO 459 I = 1, NPARA                                               
      ALL = 333.D+33                                                    
      IF ( WORK(I) .GT. 0 ) ALL = DSQRT( 1/WORK(I) )                    
      WORK(I) = ALL                                                     
 459  CONTINUE                                                          
C                                                                       
      WRITE(6,463)
 463  FORMAT ( / ' EIGEN-ANALYSIS OF THE RELATIVE COVARIANCE MATRIX' /  
     *' SQRT(EIGENVALUE)     EIGENVECTOR' / )                           
      DO 469 I = 1, NPARA                                               
      WRITE(6,467) WORK(I), ( COVAR(II,I), II = 1, NPARA )                
 467  FORMAT ( G15.5, ( T21, 10G11.3 ) )                                
 469  CONTINUE                                                          
C                                                                       
 800  CONTINUE
      RETURN                                                            
      END                                                               

CDC      PROGRAM PTOLEMY ( INPUT=64/80, OUTPUT=64/133, TAPE15=64/80,    
CDC     1  TAPE1=512, TAPE2=512,                                        
CDC     2  TAPE5=INPUT, TAPE6=OUTPUT )                                  
CRA      PROGRAM PTOLEMY                                                
C                                                                       
C     MAIN PROGRAM FOR THE DWBA CODE                                    
C                                                                       
C     THIS ACTS AS A SWITCHER FOR CONTRL.  CONTRL IS CALLED AND         
C     READS INPUT.  EACH TIME A SUBSTANTIAL CALCULATION IS TO BE DONE   
C     CONTRL SETS  IGOTO  AND  JGOTO  AND RETURNS TO HERE.  IGOTO       
C     IS THEN USED TO SWITCH TO THE APPROPRIATE ROUTINE.  UPON          
C     COMPLETION OF THE CALCULATION, CONTRL IS AGAIN CALLED.  THIS MODE 
C     OF OPERATION IS USED TO ALLOW  CONTRL  TO BE OVERLAYED AGAINST THE
C     LARGE CALCULATIONAL BLOCKS.                                       
C                                                                       
C     1/18/75 - MADE FROM CONTRL - S. PIEPER                            
C     1/18/75 - REARRANGED TO BE OVERLAYED - S. P.                      
C     1/24/75 - FOR SPLIT UP INELDC                                     
C     2/5/75 - FOR SPLIT UP WAVEF                                       
C     2/7/75 - FIRST ADDITION OF GRDSET                                 
C     2/10/75 - SEPARATE GRIDSET, INELDC, DSIGMA; TEMP1,2,3             
C     2/25/75 - RETURN CODES FROM WAVEF, WAVSET                         
C     4/17/75 - NEW COMMONS                                             
C     4/23/75 - CALL WAVPOT AFTER GRDSET                                
C     5/5/75 - COMPLETE DWBA PATH WITHOUT SEPARATE CALLS                
C     5/22/75 - STAND ALONE SWITH OFF ON WAVSET CALLS                   
C     5/28/75 - PRBPRT AND ANGSET SEPARATED FROM GRDSET.                
C     6/9/75 - CALL LINTRP WHEN NEEDED                                  
C     7/8/75 - CALL GETSCT PRIOR TO GRDSET.                             
C     8/7/75 -  CALL FITELE ADDED                                       
C     10/13/75 - EXTERNALS FOR OVERLAY PROCESSING                       
C     11/6/75 - FITEL INTO TWO PIECES                                   
C     9/1/76 - ADD VCSQ12 TO EXTERNALS                                  
C     12/26/76 - INELASTIC SCATTERING ADDED                             
C     4/18/77 - CHANGE PARM TO PRM TO AVOID COMMON CONFLICTS            
C     4/26/77 - FITSW IN WAVSET                                         
C     10/14/77 - PLMSUB ADDED TO EXTERNALS FOR OVERLAY; DATAN2 OUT      
C     11/20/77 - NEW WAVPOT CALLING LOCATION.                           
C     12/1/77 - INTRPC ADDED TO EXTERNALS - S.P.                        
C     12/20/77 - FIX USEHS ERROR MADE ON 11/20 - S.P.                   
C     5/8/78 - CALL COUPL2; SPLIT OFF LINTRP CALL - S.P.                
C     6/27/78 - CALL TO TABLES FOR CDC                                  
C     5/2/79 - ADD COUPL2 STUFF AND WAVETC TO EXTERNAL LIST - S.P.      
C     6/10/79 - CMS VERSIN - S.P.                                       
C     7/5/79 - ADD SDERIV TO EXTERNALS - S.P.                           
C     12/28/79 - ADD CLEBSH, 3J, 6J, 9J TO EXTERNALS - S.P.             
C     12/27/79 - CFR$F, MORE COMMENTS - RPG                             
C     1/15/80 - COUPLED CHANNELS CALLS - S.P.                           
C     2/8/80 - CALL COUPLN - S.P.                                       
C     3/21/80 - CALL FFACST - S.P.                                      
C     6/3/80 - CALL TABLES ONLY IN THE BROOKHAVEN VERSION - S.P.        
C     6/25/80 - COUPL2 ONLY IN IBM, DOESN'T WORK IN CDC - S.P.          
C     7/10/80 - CHANGE CDC BUFFER SIZES, CIB ON EXTERNALS,              
C               REMOVE LOTS IN CRAY VERSION WITH CNR - S.P.             
C     7/15/80 - COMMONS FOR THE CRAY VERSION - S.P.                     
C     7/23/80 - VCSBLK COMMON - S.P.                                    
C     7/28/80 - GRABCOM WITH DATA STATEMENT FOR CRAY - S.P.             
C     7/30/80 - READ TO END OF FILE ON CRAY TO CEAR UP I.O. - S.P.      
C     8/13/80 - REMOVE CDC TAPE10 DEFINITION - S.P.                     
C     12/17/80 - REMOVE CRA FROM STMNT 94; CUPROT IN EXTERNALS - S.P.   
C     4/3/81 - REMOVE COUPL2 - S.P.                                     
C     9/21/81 - CUPROT EXTERNAL REMOVED, ADD CUPSPN, CUPAB - S.P.       
C     12/14/81 - GETSCT NOW CALLED ALWAYS - S.P.                        
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      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                                                                 
CCRA                                                                    
CCRA      THE CRAY LOADER IS PRIMATIVE AND WE NAME ALL COMMONS IN       
CCRA      MAIN PROGRAM JUST TO BE SAFE.                                 
CMSC      CMS ALSO REQUIRES THESE BECAUSE OF DELINK PROBLEMS            
CCRA                                                                    
CRA      ALLOCS; USAGE; FLOAT; INTGER; JBLOCK; LNKBLK; HEDCOM; KANDM    
CRA      CNSTNT; FORMF; INELCM; CCBLK; FTIMEI; WAVCOM; TEMPVS           
CRA      GRIDCMFORINEL; INPBUF; LOCFITFORDWBA                           
CRA      COMMON /LENGTH/ LENG(100);   COMMON /NAMCOM/ NAMES(100)        
CRA      COMMON /FACTRL/ IFAC1, IFAC2, FTB(97)                          
CRA      COMMON /LOGFAC/ ILOG1, ILOG2, FLTB(101)                        
CRA      COMMON /VCSBLK/ VCSQ12(3,11)                                   
CMS      FITCOM ; BSBLK                                                 
CMS      COMMON /VMM/ VMM(32)    /VMM2/ IVMM2                           
CMS      COMMON /F152/ F152(75)                                         
CCRA                                                                    
CCRA      FOLLOWING COMMON IS FOR RETURNING RETURN CODES FROM CRAY'S    
CCRA      CRUMMY OVERLAY PROCESSOR.                                     
CCRA                                                                    
CRA      COMMON /IRETURN/  IPRM1, IGOTO, JGOTO                          
CCRA                                                                    
CCRA      FOLLOWING ALLOWS GRAB TO KNOW WHEN HLM IN JC TABLE HAS CHANGED
CCRA                                                                    
CRA      COMMON /GRABCOM/  LASTHLM                                      
C                                                                       
      LOGICAL ONESW                                                     
CRA      DATA LASTHLM /0/                                               
C                                                                       
C     THE FOLLOWING EXTERNALS DEFINE V-TYPE ADCONS IN THE ROOT SEGMENT  
C     THAT WILL IMPROVE OVERLAY PROCESSING.                             
C                                                                       
CIB      EXTERNAL  WAVELJ, SETPOT, SETFIT, MAKPOT, MINMON               
CIB      EXTERNAL  CUPSPN, CUPAB                                        
CIB      EXTERNAL CLEBSH, THREEJ, SIXJ, WIG9J                           
CIB      EXTERNAL RCWFN, RCASYM                                         
CIB      EXTERNAL BSPROD, VCSQ12, PLMSUB, PLSUB, INTRPC                 
CIB      EXTERNAL WAVETC                                                
CIB      EXTERNAL SDERIV                                                
C                                                                       
C     INITIALIZE WITH ALL THE DEFAULTS                                  
C                                                                       
CBR      CALL TABLE1                                                    
CBR      CALL TABLE2                                                    
CBR      CALL TABLE3                                                    
C                                                                       
      JGOTO = 3                                                         
C                                                                       
C     START OR CONTINUE THE INPUT PROCESS                               
C                                                                       
 90   CALL CONTRL ( IGOTO, JGOTO, IPRM1, IPRM2, IPRM3, PRM1 )           
C                                                                       
      IF ( IGOTO .NE. 0 ) GO TO 95                                      
CCRA                                                                    
CCRA     CRAY SEEMS TO NOT LIKE TO HAVE THE INPUT FILE LEFT WITH        
CCRA     UNREAD RECORDS OR END OF FILE.  WE FINISH IT OFF NOW.          
CCRA                                                                    
CRA  92  READ ( 5, 93, END=94 ) AWORD                                   
CRA  93  FORMAT ( A8 )                                                  
CRA      GO TO 92                                                       
  94  STOP                                                              
C                                                                       
C                                                                       
C     WHAT IS TO BE DONE NEXT                                           
C                                                                       
C     IGOTO = 4 AVAILABLE FOR RECYCLING                                 
C                                                                       
  95  ONESW = .TRUE.                                                    
      GO TO ( 100, 200, 300, 90, 500, 600, 620, 650, 670, 700, 720, 740,
     * 800, 850, 870 ), IGOTO                                           
C                                                                       
C     IGOTO = 1:  ; AFTER PROJECTILE OR TARGET.                         
C                                                                       
 100  CALL BOUND ( IPRM1, IPRM2, IPRM3 )                                
      GO TO 90                                                          
C                                                                       
C     IGOTO = 2:  ; AFTER FIT OR FITELASTIC                             
C                                                                       
200   CALL FITEL ( IPRM1 )                                              
      IF ( IPRM1 .EQ. 0 ) GO TO 90                                      
      CALL FITEL2 ( IPRM1 )                                             
      GO TO 90                                                          
C                                                                       
C     IGOTO = 3:  ; AFTER CALLTSO.                                      
C                                                                       
COS 300  CALL TSO ( PRM1 )                                              
CDC 300  PRINT 303                                                      
CDC 303  FORMAT ( '0**** TSO KEYWORD NOT AVAILABLE IN CDC VERSION')     
CMS 300  PRINT 303                                                      
 300  continue                                                          
CMS 303  FORMAT ( '0**** TSO NOT IN CMS')                               
      GO TO 90                                                          
C                                                                       
C     IGOTO = 5:  ; AFTER INCOMING OR OUTGOING.                         
C                                                                       
 500  CALL WAVSET ( IPRM1, .FALSE., .FALSE. )                           
      GO TO 90                                                          
C                                                                       
C     GRIDSETUP                                                         
C                                                                       
C     IGOTO = 6:  ; AFTER GRIDSETUP.                                    
C                                                                       
 600  CALL PRBPRT ( IPRM1 )                                             
      IF ( IPRM1 .EQ. 0 ) GO TO 90                                      
      IF ( PROBLM .NE. 24 ) GO TO 605                                   
C                                                                       
C     COUPLED CHANNELS CALLS                                            
C                                                                       
      CALL BASLBL ( IPRM1 )                                             
      IF ( IPRM1 .EQ. 0 ) GO TO 90                                      
      CALL BASCPL ( IPRM1 )                                             
      IF ( IPRM1 .EQ. 0 ) GO TO 90                                      
C                                                                       
 605  CALL GETSCT ( IPRM1 )                                             
      IF ( IPRM1 .EQ. 0 ) GO TO 90                                      
      IF ( ISTRIP .NE. 0 ) CALL GRDSET ( IPRM1 )                        
C                                                                       
C     FOLLOWING DONE FOR ALL CALCULATIONS                               
C                                                                       
      IF ( ISTRIP .EQ. 0 ) CALL INGRST ( IPRM1 )                        
      IF ( IPRM1 .EQ. 0 ) GO TO 90                                      
      CALL ANGSET ( IPRM1 )                                             
      IF ( IPRM1 .EQ. 0 ) GO TO 90                                      
      IF ( ISTRIP .EQ. 0 ) GO TO 615                                    
      IF ( ONESW ) GO TO 90                                             
      GO TO 620                                                         
C                                                                       
C     SETUP COULOMB INTEGRALS FOR INELASTIC AND CC                      
C                                                                       
 615  CALL COULST ( IPRM1 )                                             
C                                                                       
      IF ( IPRM1 .EQ. 0 .OR. ONESW ) GO TO 90                           
C                                                                       
C     IGOTO = 7:  ; AFTER RADIALINTEGRALS                               
C                                                                       
 620  CONTINUE                                                          
      IF ( PROBLM .EQ. 20 ) CALL INELDC ( IPRM1 )                       
      IF ( PROBLM .EQ. 22 ) CALL INRDIN ( IPRM1 )                       
      IF ( PROBLM .EQ. 24 ) CALL COUPLN ( IPRM1 )                       
      IF ( IPRM1 .EQ. 0 .OR. ONESW ) GO TO 90                           
C                                                                       
C     IGOTO = 8:  ; AFTER LINTERPOLATION                                
C                                                                       
 650  IPRM1 = 1                                                         
      IF ( PROBLM .EQ. 24 ) CALL FFACST (IPRM1)                         
      IF ( IPRM1 .EQ. 0 ) GO TO 90                                      
      CALL LINTRP                                                       
      IF (ONESW) GO TO 90                                               
C                                                                       
C     IGOTO = 9:  ; AFTER CROSSSECTION.                                 
C                                                                       
 670  CALL XSECTN ( IPRM1 )                                             
      GO TO 90                                                          
C                                                                       
C     IGOTO = 10, 11, 12:  ; AFTER DOTEMP1, DOTEMP2, DOTEMP3.           
C                                                                       
 700  CALL TEMP1                                                        
      GO TO 90                                                          
 720  CALL TEMP2                                                        
      GO TO 90                                                          
 740  CALL TEMP3                                                        
      GO TO 90                                                          
C                                                                       
C     IGOTO = 13:  ; AFTER SCATTERING.                                  
C                                                                       
 800  CALL WAVEF ( IPRM1 )                                              
      GO TO 90                                                          
C                                                                       
C     IGOTO = 14:  ; AFTER ALL CHANNELS ARE SET UP:                     
C     FULL TRANSFER OR INELASTIC CALCULATION                            
C                                                                       
 850  ONESW = .FALSE.                                                   
      GO TO 600                                                         
C                                                                       
C     IGOTO = 15:  ; AFTER CROSSSECTION IF LINTRPOLATION IS NOT DONE:   
C     BOTH LINTRP AND XSECTN                                            
C                                                                       
 870  ONESW = .FALSE.                                                   
      GO TO 650                                                         
C                                                                       
CRA 100  CONTINUE                                                       
CRA 200  CONTINUE                                                       
CRA 300  CONTINUE                                                       
CRA 700  CONTINUE                                                       
CRA 720  CONTINUE                                                       
CRA 740  CONTINUE                                                       
CRA 800  PRINT 903                                                      
CRA 903  FORMAT ('0*** REQUESTED PROGRAM NOT AVAILABLE.' )              
CRA      IPRM1 = 0                                                      
CRA      GO TO 90                                                       
C                                                                       
      END                                                               
      SUBROUTINE QVSCAN ( GUY, ESTARS, NODVLS, LVALS, JVALS, IPARYS,  IR
     *TN )                                                              
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
C  SCANS AN INPUT LINE FOR Q-VALUE PROGRAM                              
C                                                                       
C  DESCRIPTION OF PARAMETERS:                                           
C  GUY    R*8 A 4-COMPONENT ARRAY THAT WILL CONTAIN THE PARTICIPANTS    
C  ESTARS R*8 WILL BE SET TO EXPLICITLY GIVEN EXCITED STATE E'S.        
C  NODVLS I*4 NUMBER OF NODES FROM LEVEL SPEC (3P MEANS NODVLS=2)       
C  LVALS  I*4 L-VALUE FROM LEVEL SPEC                                   
C  JVALS  I*4 WILL BE SET TO EXPLICITLY GIVEN J'S.                      
C  IPARYS I*4 -1, 0, +1 FOR PARITIES.                                   
C  IRTN   I*4 AN ERROR RETURN CODE                                      
C         =0  AOK         =-1 SYNTAX ERROR                              
C                                                                       
C     IN THIS VERSION, THE INPUT LINE IS IN   /INPBUF/.                 
C     THIS VERSION DOES NOT RECOGNIZE  *'S  OR  &'S.                    
C                                                                       
C     CODED BY F. SERDUKE                                               
C     5/8/75 - PTOLEMY VERSION - S. P. - USE /INPBUF/; NO *,&;          
C              PROCESS EXCITED STATES.                                  
C     7/27/76 - DON'T USE FIELD                                         
C     9/24/77 - ESTAR = UNDEF FOR UNDEFINED                             
C     5/6/79 - PARITIES, LEVEL SPECS - S.P.                             
C     12/28/79 - STANDARD MORTRAN - RPG                                 
C     1/11/80 - SEPARATE CVALU ARGUMENT TO MSCAN; QUOTES IN DATA STMT - 
C     6/3/80 - CDC VERSION OF STOPS DATA - S.P.                         
C     7/14/80 - CDM, CDO PREFIXES - S.P.                                
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
C                                                                       
      IMPLICIT INTEGER*4 (A-Z)                                          
C                                                                       
      DIMENSION NODVLS(4), LVALS(4), JVALS(4), IPARYS(4)                
C                                                                       
      REAL*8 UNDEF                                                      
      COMMON /INTRNL/ UNDEF, NOTDEF                                     
C                                                                       
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
C                                                                       
      CHARACTER*1 SLASH, PLUS, MINUS                                    
      DATAMINUS/'-'/                                                    
      DATAPLUS/'+'/                                                     
      DATA SLASH / '/' /                                                
      CHARACTER*8 GUY(4), BLANK8, CVALU                                 
      DATABLANK8/' '/                                                   
      REAL*8 ESTARS(4), VALU, DUMMY                                     
      CHARACTER*1 STPCHR, BLANK, COMMA                                  
      DATACOMMA/','/                                                    
      DATABLANK/' '/                                                    
C                                                                       
      CHARACTER*1 STOPS(4)                                              
      DATA STOPS / '(', ',', ')', ' ' /                                 
CDO      DATA STOPS / 1H(, 1H,, 1H), 1H  /                              
C                                                                       
      IRTN = 0                                                          
      INCHST = INCH                                                     
C                                                                       
C --- LOOP ON THE REACTION PARTICIPANTS                                 
      DO 699 I=1,4                                                      
      GUY(I) = BLANK8                                                   
      NODVLS(I) = NOTDEF                                                
      LVALS(I) = NOTDEF                                                 
      JVALS(I) = NOTDEF                                                 
      ESTARS(I) = UNDEF                                                 
      IPARYS(I) = 0                                                     
      CALL MSCAN ( -20, ITOKEN, GUY(I), VALU, IVALU, IBUF, IMESS,  STPCH
     *R )                                                               
      IF ( IMESS .GT. 5 ) GO TO 9004                                    
      IF ( IMESS .EQ. 0 ) GO TO 9005                                    
      INCH = INCH+1                                                     
C                                                                       
C                                                                       
C     IF STOPPED BY A  (  AND NOT FIRST FIELD THEN PROCESS EXCITED STATE
C     STATE.                                                            
C                                                                       
      IF ( STPCHR .NE. STOPS(1) .OR. I .EQ. 1 ) GO TO 400               
C                                                                       
C     GET E* AND J                                                      
C                                                                       
 200  CALL MSCAN ( 18, ITOKEN, CVALU, VALU, IVALU, IBUF, IMESS,  STPCHR 
     *)                                                                 
      IF ( ITOKEN .EQ. -9) GO TO 9900                                   
      IF ( ITOKEN .EQ. -8 ) GO TO 9007                                  
      IF ( ITOKEN .NE. -2 ) GO TO 230                                   
C                                                                       
C     IT IS E*                                                          
C                                                                       
      IF ( ESTARS(I) .EQ. UNDEF ) GO TO 220                             
      WRITE(6,213)
 213  FORMAT ( '0**** ATTEMPTING TO ENTER 2 VALUES FOR E*' )            
      GO TO 9900                                                        
 220  ESTARS(I) = VALU                                                  
      GO TO 200                                                         
C                                                                       
 230  IF ( ITOKEN .NE. -5 ) GO TO 270                                   
C                                                                       
C     IT IS J                                                           
C                                                                       
      IF ( JVALS(I) .EQ. NOTDEF ) GO TO 240                             
      WRITE(6,233)
 233  FORMAT ( '0**** ATTEMPTING TO ENTER 2 VALUES FOR J' )             
      GO TO 9900                                                        
 240  JVALS(I) = 2*IVALU                                                
      IF ( STPCHR .NE. SLASH ) GO TO 250                                
C                                                                       
C     BYPASS /2                                                         
C                                                                       
      INCH = INCH+1                                                     
      JVALS(I) = IVALU                                                  
C                                                                       
C     IT IS NECESSARY TO CODE THE 2 FOLLOWING THE /                     
C     MAKE SURE IT IS JUST A SIMPLE 2                                   
C                                                                       
      CALL MSCAN ( 18, ITOKEN, CVALU, VALU, IVALU, IBUF, IMESS, STPCHR )
      IF ( ITOKEN .EQ. -9 ) GO TO 9900                                  
      IF ( ITOKEN .EQ. -8 ) GO TO 9007                                  
      IF ( ITOKEN .EQ. -5 .AND. IVALU .EQ. 2 ) GO TO 250                
      WRITE(6,243)
 243  FORMAT ( '0**** INVALID J FIELD' )                                
      GO TO 9900                                                        
C                                                                       
C     BYPASS TERMINAL + OR -                                            
C                                                                       
 250  IP = +1                                                           
      IF ( STPCHR .EQ. PLUS ) GO TO 255                                 
      IP = -1                                                           
      IF ( STPCHR .NE. MINUS ) GO TO 200                                
 255  IPARYS(I) = IP                                                    
      INCH = INCH+1                                                     
      GO TO 200                                                         
C                                                                       
 270  IF ( ITOKEN .NE. -3 ) GO TO 280                                   
C                                                                       
C     IT IS A NODES AND L PART OF A LEVEL DESCRIPTOR                    
C                                                                       
      IF ( LVALS(I) .EQ. NOTDEF ) GO TO 275                             
      WRITE(6,273)
 273  FORMAT ( '0**** ATTEMPTING TO ENTER TWO LEVEL DESCRIPTORS' )      
      GO TO 9900                                                        
 275  LVALS(I) = IVALU                                                  
      NODVLS(I) = VALU                                                  
      GO TO 200                                                         
C                                                                       
C     IS IT THE CLOSING )                                               
C                                                                       
 280  IF ( ITOKEN .EQ. 11 ) GO TO 290                                   
      WRITE(6,283) ITOKEN                                                 
 283  FORMAT ( '0**** UNRECOGNIZABLE EXCITED STATE DESCRIPTOR (TOKEN =',
     * I4, ')' )                                                        
      GO TO 9900                                                        
C                                                                       
C     ALL DONE WITH THE EXCITED STATE; BYPASS FINAL ).                  
C                                                                       
 290  STPCHR = IBUF(INCH)                                               
      INCH = INCH + 1                                                   
C                                                                       
C                                                                       
C                                                                       
C ----- BYPASS BLANKS                                                   
 400  IF ( STPCHR .NE. BLANK .OR. I .EQ. 2 .OR. I .EQ. 4 ) GO TO 500    
      CALL MSCAN ( -20, ITOKEN, CVALU, DUMMY, IVALU, IBUF, IMESS,  STPCH
     *R )                                                               
      STPCHR = IBUF(INCH-1)                                             
      IF ( IMESS .NE. 0 ) GO TO 9006                                    
C ... LEFT AND RIGHT PARENTHESES MUST FOLLOW 1-ST AND 3-RD GUYS         
 500  IF ( (I.EQ.1 .OR. I.EQ.3) .AND. STPCHR.NE.STOPS(I) ) GO TO 9001   
C          THERE MUST BE A BLANK OR COMMA AFTER THE SECOND GUY          
      STPTYP = 2                                                        
      IF ( STPCHR .EQ. BLANK .OR. STPCHR .EQ. COMMA ) STPTYP = 1        
      IF ( I.EQ.2 .AND. STPTYP.NE.1 ) GO TO 9002                        
 699  CONTINUE                                                          
      IF ( STPTYP .NE. 1 .AND. INCH .LE. NOCH ) GO TO 9003              
      RETURN                                                            
C PARENTHESES NOT IN RIGHT PLACE                                        
9001  WRITE(6,9011)
 9011 FORMAT ( '0**** MISSING PARENTHESIS.' )                           
      GO TO 9900                                                        
C BLANK OR COMMA NOT AFTER 2-ND GUY                                     
9002  WRITE(6,9012)
 9012 FORMAT ( '0**** INVALID DELIMITOR AFTER INCOMING PROJECTILE.' )   
      GO TO 9900                                                        
9003  WRITE(6,9013)
 9013 FORMAT ( '0**** ONLY 4 PARTICIPANTS IN REACTION ALLOWED.' )       
      GO TO 9900                                                        
C  ONE OF THE GUYS HAS MORE THAN 5 CHARACTERS IN IT                     
9004  WRITE(6,9014)
 9014 FORMAT ( '0**** TOO MANY CHARACTERS IN SYMBOL AND ATOMIC MASS.' ) 
      GO TO 9900                                                        
 9005 WRITE(6,9015)
 9015 FORMAT ( '0**** UNEXPECTED DELIMITOR OR END OF LINE ENCOUNTERED', 
     * ' WHEN LOOKING FOR ELEMENT SYMBOL.' )                            
      GO TO 9900                                                        
 9006 WRITE(6,9016)DUMMY                                                 
 9016 FORMAT ( '0**** UNEXPECTED FIELD ENCOUNTERED WHEN LOOKING FOR ',  
     *'DELIMITOR; FIELD = ', A8 )                                       
      GO TO 9900                                                        
 9007 WRITE(6,9017)
 9017 FORMAT ( '0**** COMPLETE REACTION MUST BE ON SAME LINE AS',  ' REA
     *CTION KEYWORD.' )                                                 
      GO TO 9900                                                        
C                                                                       
 9900 INCHM1 = INCH - 1                                                 
      WRITE(6,9903) I,(IBUF(II), II = INCHST, INCHM1 )                  
 9903 FORMAT ( 6X, 'WAS PROCESSING FIELD', I2, ' OF THE REACTION' /  6X,
     * 'REACTION UP TO THE ERROR IS: ', 80A1 )                          
      IRTN = -1                                                         
      RETURN                                                            
      END                                                               
      SUBROUTINE RCASYM ( L, ETA, RHO, IPRN, SIGL, ZETA, PHI, DZETA,  F,
     * FP, G, GP, Z, DZSQ, S, ZINV, EPS, NMAX, NTZ, ISIG )              
C                                                                       
C     ASYMPTOTIC SERIES IN 1/RHO FOR COULOMB FUNCTIONS                  
C                                                                       
C     THIS INVOLVES THE REPRESENTATION SIN(PHI)/SQRT(ZETA)              
C     AND COS(PHI)/SQRT(ZETA) FOR F AND G                               
C     THE NON-LINEAR EQUATION FOR ZETA IS THEN SOLVED DIRECTLY          
C     TERM BY TERM. WE WORK WITH A POWER SERIES                         
C     REPRESENTATION OF ZETA IN 1/RHO. THIS POWER SERIES                
C     IS THEN FOUND COEFFICIENT BY COEFFICIENT IN ASCENDING POWERS      
C     STOPPING WHEN LAST TERMS IS LESS IN MAGNITUDE THAN EPS            
C                                                                       
C     ARGUMENT-LIST FOR CALCULATION OF FL,GL(ETA,RHO)                   
C                                                                       
C      L     (INPUT) I*4 ANGULAR MOMENTUM                               
C      ETA   (INPUT) R*8 COULOMB PARAMETER                              
C      RHO   (INPUT) R*8 RADIAL VARIABLE                                
C      IPRN  (INPUT) I*4 PRINT CONTROL (=0 ONLY ERROR MESSAGES)         
C      SIGL  (INPUT) R*8 COULOMB PHASE-SHIFT                            
C      ZETA  (RETURNED) R*8  AMPLITUDE FUNCTION AT RHO                  
C      PHI   (RETURNED) R*8  PHASE FUNCTION                             
C      DZETA (RETURNED) R*8  DERIVATIVE OF ZETA WRT RHO                 
C      F,G   (RETURNED) R*8  REGULAR AND IRREGULAR COULOMB FNS AT RHO   
C      FP,GP (RETURNED) R*8  DERIVATIVES OF COULOMB FNS                 
C      Z     (RETURNED) R*8  ARRAY OF FIRST (NTZ+1) COEFFICIENTS IN     
C                       OF SERIES FOR ZETA IN POWERS OF (RHO/RHO0)**-1  
C            SERIES FOR ZETA IN INVERSE POWERS OF RHO/RHO0              
C            WITH RHO0 = RHO                                            
C      DZSQ,S,ZINV  R*8 WORK ARRAYS (DIMENSION NTZ+1)                   
C      EPS   (INPUT) R*8 DESIRED RELATIVE ACCURACY                      
C      NMAX   (INPUT) I*4 MAXIMUM NO OF TERMS IN SERIES                 
C      NTZ   (RETURNED) I*4 NO OF TERMS IN POWER SERIES FOR ZETA        
C      ISIG  (RETURNED) I*4 ERROR SIGNAL (EQ.0 IF ALL IS WELL)          
C                                                                       
C     MHM - DECEMBER 10, 1976                                           
C     JAN 16, 1977 - DZ ARRAY REMOVED - S.P.                            
C     JAN 24, 1977 - DO NOT ALLOW ASYMPTOTIC COEFS TO INCREASE          
C                                                                       
      IMPLICIT REAL*8(A-H,O-Z)                                          
C                                                                       
      DIMENSION Z(1),DZ(1),DZSQ(1),S(1),ZINV(1)                         
C                                                                       
C                                                                       
      DATA PI/3.14159 26535 89793 0D0/                                  
C                                                                       
      ISIG=0                                                            
      FLL=L*(L+1)                                                       
      ETASQ=ETA*ETA                                                     
      RHOSQ=RHO*RHO                                                     
      BF1=2*(ETA/RHO)                                                   
      BF2=FLL/RHOSQ                                                     
      IF(ETA.GT.0) RHOT=ETA*(1+DSQRT(1.D0+FLL/ETASQ))                   
      IF(ETA.EQ.0) RHOT=DSQRT(FLL)                                      
      IF((ETA.EQ.0).AND.(L.EQ.0)) RHOT=.5                               
      IF(ETA.LT.0) RHOT=DABS(ETA)*(DSQRT(1.D0+FLL/ETASQ)-1)             
      IF(RHO.GT.RHOT) GO TO 1                                           
      WRITE(6,100)
  100 FORMAT(3X,'-- RCASYM. ASYMPTOTIC EAXPANSION INSIDE TP --')    
      ISIG=-5                                                           
      GO TO 50                                                          
C                                                                       
C     SOLVE DIFFERENTIAL EQUATION FOR ZETA TERM BY TERM FOR             
C     COEFFICIENTS OF POWER-SERIES IN RHO**-N FOR ZETA                  
C                                                                       
    1 Z(1)=1                                                            
      S(1)=1                                                            
      DZSQ(1)=0                                                         
      ZINV(1)=1                                                         
      ZETA=Z(1)                                                         
      DZETA=0                                                           
      PHI=RHO-ETA*DLOG(2.D0*RHO)+SIGL-.5*L*PI                           
      KSER=2                                                            
      NTZ=1                                                             
      I=2                                                               
  500 Z(I)=0                                                            
      JTOP=(I+1)/2                                                      
      S(I)=0                                                            
      DZSQ(I)=0                                                         
      CF=0                                                              
      IF(I.EQ.2) GO TO 515                                              
      DO 510 J=2,JTOP                                                   
      FACTOR=2                                                          
      IF(J.EQ.(I-J+1)) FACTOR=1                                         
  510 S(I)=S(I)+FACTOR*Z(J)*Z(I-J+1)                                    
  515 JHI=I-1                                                           
      DO 520 J=1,JHI                                                    
  520 CF=CF+Z(J)*S(I-J+1)                                               
      BF=-BF1*Z(I-1)                                                    
      IF(I.GT.2) BF=BF-BF2*Z(I-2)                                       
      IF(I.LE.5) GO TO 545                                              
      ILOC=I-4                                                          
      JJTOP=ILOC-1                                                      
      ZINV(ILOC)=0                                                      
      DO 540 J=1,JJTOP                                                  
  540 ZINV(ILOC)=ZINV(ILOC)-ZINV(J)*Z(ILOC-J+1)                         
  545 TF=0                                                              
      IF(I.LE.4) GO TO 560                                              
      DO 565 J=3,JTOP                                                   
      FACTOR= 2/RHO**2                                                  
      IF(J.EQ.(I-J+1)) FACTOR= 1/RHO**2                                 
  565 DZSQ(I)=DZSQ(I)+FACTOR*(J-2)*(I-J-1)*Z(J-1)*Z(I-J)                
      JJTOP=I-4                                                         
      DO 550 J=1,JJTOP                                                  
  550 TF=TF+ZINV(J)*DZSQ(I-J+1)                                         
  560 D2F=0                                                             
      IF(I.GT.3) D2F=(I-2)*(I-3)*(Z(I-2)/RHOSQ)                         
      Z(I)=(-CF+BF+.75*TF-.5*D2F)*.5                                    
      IF(IPRN .GE. 5) WRITE(6,563)I,Z(I),CF,BF,TF,D2F                     
  563 FORMAT(I5, ' Z =', 5G13.6 )                                       
      NTZ=NTZ+1                                                         
      S(I)=S(I)+2*Z(I)                                                  
      ZETA=ZETA+Z(I)                                                    
      IF(DABS(Z(I)).GE.EPS) GO TO 570                                   
      KSER=KSER-1                                                       
  570 DZETA=DZETA - (I-2)*Z(I-1)/RHO                                    
      IF((I.EQ.2).OR.(DABS((I-2)*Z(I-1)/RHO).GE.EPS)) GO TO 580         
      KSER=KSER-1                                                       
  580 IF(I.EQ.2) GO TO 590                                              
      PHI=PHI-(Z(I)*RHO)/DFLOAT(I-2)                                    
  590 IF(KSER.LE.0) GO TO 600                                           
      I=I+1                                                             
      IF(I .GT. NMAX) GO TO 1000                                        
C                                                                       
C     MAKE SURE WE HAVE NOT PASSED THE MINIMUM OF THE ASYMPTOTIC        
C     SERIES                                                            
C                                                                       
      IF ( I .LT. 8 ) GO TO 500                                         
      IF ( DABS(Z(I-1)) .GT. DABS(Z(I-7)) ) GO TO 1020                  
      GO TO 500                                                         
C                                                                       
C     HAVE CONVERGED                                                    
C                                                                       
  600 CONTINUE                                                          
      IF(IPRN.GT.0) WRITE(6,170)NTZ,ZETA,DZETA,PHI                        
  170 FORMAT(3X,'WITH ',I2,' TERMS,  ZETA = ',G22.14/ 3X,'DZETA = ',
     *G22.14,' PHI = ',G22.14)                                          
C                                                                       
C     COMPUTE REGULAR AND IRREGULAR COULOMB FUNCTIONS AND DERIVATIVES   
C     IN TERMS OF PHI ZETA AND D(ZETA)/D(RHO)                           
C                                                                       
   90 RTZ=DSQRT(ZETA)                                                   
      F=DSIN(PHI)/RTZ                                                   
      G=DCOS(PHI)/RTZ                                                   
      FACTOR=(.5*DZETA)/(ZETA*ZETA)                                     
      FP=ZETA*(G-FACTOR*F)                                              
      GP=-ZETA*(F+FACTOR*G)                                             
C                                                                       
   50 RETURN                                                            
C                                                                       
C     COULD NOT CONVERGE                                                
C                                                                       
 1000 IF ( IPRN .GT. -4 ) WRITE(6,1010)NMAX                               
 1010 FORMAT( ' **** MORE THAN ',I4,' TERMS NEEDED IN SERIES FOR ZETA   
     *  ****')                                                          
      GO TO 1050                                                        
C                                                                       
 1020 IF ( IPRN .GT. -4 ) WRITE(6,1023) I                                 
 1023 FORMAT ( ' **** COULOMB SERIES TURNS AT', I6, ' TERMS ****' )     
C                                                                       

 1050 IF ( IPRN .GT. -4 ) WRITE(6,1053) L, ETA, RHO, ZETA, Z(I-1)         
 1053 FORMAT ( ' **** L, ETA, RHO, ZETA, LAST =', I4, 4G15.5 )          
      ISIG = -5                                                         
      GO TO 50                                                          
C                                                                       
      END                                                               
      SUBROUTINE REACTN ( IRET )                                        
C                                                                       
C     SCANS A REACTION OF THE GENERAL FORM                              
C         40CA(O16, 12C(2+ 3.26))44TI(7.23 3/2)                         
C                                                                       
C     AND STORES  Z'S,  M'S,  J'S,  E*'S,  AND  MASS EXCESSES  OF       
C     THE 5 PARTILCES INTO THE COMMON BLOCKS.                           
C                                                                       
C     5/12/75 - FIRST VERSION - S. PIEPER                               
C     12/12/76 - ELASTIC AND INELASTIC SCATTERING ADDED                 
C     9/24/77 - RECOGNIZE E*=0; ALLOW LATTER DEF OF MASS EXCESS         
C     5/6/79 - PARITIES; LEVEL SPECS - S.P.                             
C     12/28/79 - STANDARD MORTRAN - RPG                                 
C     1/31/80 - CHARDATAVALUE IS NUMERIC; SYMBOL, ALPHA ARE CHAR. - RPG 
C     7/15/81 - ALLOW ABSURB TRANSFERS; USE CHARINT - 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 )                                                   
      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)                             
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
C                                                                       
      CHARACTER*8 GUY(4)                                                
      REAL*8 ESTARS(4)                                                  
      INTEGER NODVLS(4), LVALS(4), JVALS(4), IPARYS(4)                  
      CHARACTER*1 BLANK1                                                
      DATA BLANK1 / ' ' /                                               
      CHARACTER*2 SYMBOL                                                
      CHARACTER*4 ALPHA                                                 
C                                                                       
      INTEGERMAP(4)                                                     
      DATAMAP/3, 1, 2, 4/                                               
      CHARACTER*4 NAMES(5)                                              
      DATA NAMES/'A', 'B', 'BIGA', 'BIGB', 'X'/                         
C                                                                       
      INTEGERLETTRA, LETTRZ, NUM0, NUM9                                 
      DATANUM9/57/                                                      
      DATANUM0/48/                                                      
      DATALETTRZ/90/                                                    
      DATA LETTRA / 65 /                                                
C                                                                       
C                                                                       
      IRET = 0                                                          
C                                                                       
C     GET PAST ANY INITIAL DELIMITORS ( ASSUME THE REACTION IS IN UPPER 
C      CASE ).                                                          
C                                                                       
 100  I = ICHAR(IBUF(INCH))                                             
      IF ( I .GE. LETTRA .AND. I .LE. LETTRZ .OR. I .GE. NUM0 .AND. I .L
     *E. NUM9 ) GO TO 150                                               
      INCH = INCH + 1                                                   
      IF ( INCH .LE. NOCH ) GO TO 100                                   
 120  WRITE(6,123)
 123  FORMAT ( '0**** REACTION KEYWORD AND COMPLETE REACTION MUST BE',  
     *' ON ONE LINE.' )                                                 
      RETURN                                                            
C                                                                       
C     START OF REACTION FOUND.  BREAK IT INTO 4 PIECES.                 
C                                                                       
 150  INCHST = INCH                                                     
      CALL QVSCAN ( GUY, ESTARS, NODVLS, LVALS, JVALS, IPARYS, IRTN )   
      IF ( IRTN .NE. 0 ) RETURN                                         
C                                                                       
C     NOW GET THE A AND Z VALUES                                        
C                                                                       
 200  DO 239 I = 1, 4                                                   
      CALL AZCODE ( GUY(I), IZ, IA, SYMBOL, IRTN )                      
      IF ( IRTN .EQ. 0 ) GO TO 230                                      
      IF (IRTN .NE. -2) WRITE(6,213) GUY(I)                               
 213  FORMAT ( '0**** A SYMBOL HAS INCORRECT SYNTAX:  ',  'SYMBOL = ', A
     *8 )                                                               
      IF ( IRTN .EQ. -2 ) WRITE(6,217) GUY(I)                             
 217  FORMAT ( '0**** THE SYMBOL ', A6, ' IS NOT A KNOWN ELEMENT.' )    
      RETURN                                                            
 230  II = MAP(I)                                                       
      IZS(II) = IZ                                                      
      AMS(II) = IA                                                      
      IF ( ESTARS(I) .NE. UNDEF ) EXS(II) = ESTARS(I) + 1.D-30          
      IF ( NODVLS(I) .NE. NOTDEF ) NODESP(II) = NODVLS(I)               
      IF ( LVALS(I) .NE. NOTDEF ) LSPECS(II) = LVALS(I)                 
      IF ( JVALS(I) .NE. NOTDEF ) JS(II) = JVALS(I)                     
      IF ( IPARYS(I) .NE. 0 ) PARITS(II) = IPARYS(I)                    
 239  CONTINUE                                                          
C                                                                       
C     FIND X                                                            
C                                                                       
      IZS(5) = IABS( IZS(1) - IZS(2) )                                  
      AMS(5) = DABS( AMS(1) - AMS(2) )                                  
      NUMPAR = 5                                                        
      IF ( AMS(5) .EQ. 0 ) NUMPAR = 4                                   
C                                                                       
C     NOW GET GROUND STATE MASS EXCESS AND DETERMIN IF THE NUCLEII      
C     EXIST.                                                            
C                                                                       
      DO 359 I = 1, NUMPAR                                              
      IA = AMS(I)                                                       
      IZ = IZS(I)                                                       
      N = IA-IZ                                                         
      AMXCES = EXCESS( IZ, IA, IRTN )                                   
      IF ( IRTN .EQ. 0 ) GO TO 330                                      
      IF ( I .EQ. 5 ) GO TO 320                                         
      WRITE(6,313) IA, IZ, N                                              
 313  FORMAT ( '0**** THE NUCLEUS WITH A =', I4, ',  Z =', I4,  ',  N ='
     *, I4, '  IS NOT BOUND ',  'ACCORDING TO PTOLEMY"S MASS TABLE.' )  
      GO TO 359                                                         
 320  WRITE(6,323) IA, IZ, N                                              
 323  FORMAT ( '0**** THE EXCHANGED CLUSTER HAS A =', I4,  ', Z =', I4, 
     *',  N =', I4, '  AND IS NOT BOUND.' /  6X, 'MERELY TO CONCEIVE OF 
     *SUCH THINGS MAKES THEM APPEAR ',  'RIDICULOUS.' )                 
      RETURN                                                            
 330  IF ( I .NE. 5 ) GO TO 340                                         
C                                                                       
C     PRINT WARNING FOR ABSURB EXCHANGES                                
C                                                                       
      IF ( IA .LE. 2 .OR. IZ .NE. 0 .OR. IZ .NE. IA )  GO TO 340        
      WRITE(6,333)
 333  FORMAT ( '0**** WARNING:  THE EXCHANGED CLUSTER IS ABSURB,',  ' BU
     *T IF THAT  S WHAT YOU WANT, SO BE IT.' )                          
 340  AMXCGS(I) = AMXCES                                                
 359  CONTINUE                                                          
C                                                                       
C     NOW GET J FOR EACH OF THE 5                                       
C                                                                       
      DO 459 I = 1, NUMPAR                                              
C                                                                       
C     IF E* HAS BEEN ENTERED THEN G.S. J IS MEANINGLESS                 
C                                                                       
      IF ( EXS(I) .GT. 1.D-5 ) GO TO 459                                
      IA = AMS(I)                                                       
      IZ = IZS(I)                                                       
      N = IA - IZ                                                       
      CALL GSINFO ( IZ, IA, JVAL, IPARIT, ALPHA, IRTN )                 
      IF ( IRTN .EQ. 0 .AND. JVAL .NE. NOTDEF ) GO TO 430               
C     NO ERROR IF J IS ALREADY DEFINED OR IS EXPLICITLY GIVEN           
C     IN THE REACTION.                                                  
      IF ( JS(I) .NE. NOTDEF ) GO TO 457                                
C                                                                       
C     DINEUTRON OR DIPROTON IS J = 0                                    
C                                                                       
      IF ( IA .NE. 2 .OR. IZ .EQ. 1 ) GO TO 420                         
      JVAL = 0                                                          
      GO TO 450                                                         
 420  WRITE(6,423) IA, IZ, N                                              
 423  FORMAT ( '0**** WARNING:  THE GROUND STATE SPIN OF THE',  ' NUCLEU
     *S WITH A =', I4, ',  Z =', I4, ',  N =', I4,  '  IS NOT KNOWN TO P
     *TOLEMY.' )                                                        
      GO TO 457                                                         
C                                                                       
C     IF J HAS BEEN DEFINED TO BE DIFFERENT FROM G.S. THEN NEED E*      
C                                                                       
 430  IF ( JS(I) .EQ. NOTDEF ) GO TO 450                                
      IF ( JS(I) .EQ. JVAL .OR. EXS(I) .NE. 0 ) GO TO 457               
      WRITE(6,433) NAMES(I), JVAL, NAMES(I), JS(I), NAMES(I)              
 433  FORMAT ( '0**** WARNING:  GROUND STATE SPIN FOR PARTICLE ',  A4, '
     * IS', I3, '/2.  YOU HAVE SPECIFIED J', A4,  ' =', I3, '/2, BUT HAV
     *E NOT YET SPECIFIED E*', A4, '.')                                 
      GO TO 459                                                         
C                                                                       
 450  JS(I) = JVAL                                                      
      IF ( IPARIT .NE. 0 ) PARITS(I) = IPARIT                           
 457  IF ( EXS(I) .EQ. 1.D-30 ) EXS(I) = 0                              
 459  CONTINUE                                                          
C                                                                       
C                                                                       
C     IT WAS SUCCESFUL, COPY REACTION FOR HEADER                        
C                                                                       
      DO 649 I = 1, 45                                                  
      REACT(I) = BLANK1                                                 
 649  CONTINUE                                                          
      N = MIN0( 45, INCH-INCHST )                                       
      DO 659 I = 1, N                                                   
      REACT(I) = IBUF(INCHST-1+I)                                       
 659  CONTINUE                                                          
      IRET = 1                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE REQUIV(REQ,R0EQ,IZ,IA)                                 
C     CALCULATES RADIUS OF EQUIVALENT UNIFORM DISTRIBUTION              
C     IT IS EQUIVALENT IN THAT IT HAS SAME RMS                          
C     RADIUS AS FERMI DISTRIBUTION THAT FITS ELECTRON SCATTERING        
C     FOR A GT 16 USES FORMULA FOR R0 GIVEN BY BOHR AND MOTTELSON       
C     FOR A BETWEEN 3 AND 16 USES VALUES GIVEN ON PP 32 TO 34 OF        
C     NUCLEAR RADII - LANDOLT-BORNSTEIN - SPRINGER VERLAG 1967          
C     FOR A LT 3 RETURNS REQ R0EQ = 0                                   
C     MHM 4/25/76                                                       
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      DIMENSION RMSR(14)                                                
      DATA RMSR / 2.18 , 2.16 , 2.67 , 3.22 ,  3.13 , 3.1 , 3.12 , 3.16 
     *, 3.12 , 3.17 , 2.99 ,  3.18 , 3.35 , 3.54 /                      
      A=IA                                                              
      POW=1.D0/3.D0                                                     
      ACUB=A**POW                                                       
      IF(IA.GT.16) GO TO 150                                            
C                                                                       
C     3HE RADIUS                                                        
C                                                                       
      IF((IZ.NE.2).OR.(IA.NE.3)) GO TO 5                                
      REQ=2.37                                                          
      GO TO 500                                                         
C                                                                       
    5 IF(IA.GE.3) GO TO 10                                              
      REQ=0                                                             
      GO TO 500                                                         
C                                                                       
C     SPECIAL CASES FROM LANDOLT-BORNSTEIN :  A FROM 3 TO 16            
C                                                                       
   10 REQ=RMSR(IA-2)                                                    
      GO TO 500                                                         
C                                                                       
C     USE BOHR-MOTTELSON FORMULA FOR R0 IF A GT 16                      
C                                                                       
  150 EPS=1.D-08                                                        
      NSTEPS=40                                                         
      RC=1.12*ACUB-.86/ACUB                                             
      DIFF=.54D0                                                        
      RTOP=RC+DIFF*DLOG(1.D0/EPS)                                       
      H=RTOP/NSTEPS                                                     
      XNORM=0                                                           
      RSQ=0                                                             
      EXFAC=DEXP(-RC/DIFF)                                              
      DEX=DEXP(H/DIFF)                                                  
      R=0                                                               
  160 WT=1                                                              
      IF((R.EQ.0).OR.(R.EQ.RTOP)) WT=.5                                 
      R2=R*R                                                            
      R4=R2*R2                                                          
      EXF=1/(1+EXFAC)                                                   
      XNORM=XNORM+R2*EXF*WT                                             
      RSQ=RSQ+R4*EXF*WT                                                 
      R=R+H                                                             
      EXFAC=EXFAC*DEX                                                   
      IF(R.LE.RTOP) GO TO 160                                           
      REQ=(5*RSQ)/(3*XNORM)                                             
      REQ=DSQRT(REQ)                                                    
  500 R0EQ=REQ/ACUB                                                     
      RETURN                                                            
      END                                                               
      FUNCTION RTXLNX ( A, B, C, ACC )                                  
C                                                                       
C     FINDS THE REAL SOLUTION OF  A*X + B*LN(X) + C = 0                 
C                                                                       
C     ACC IS THE REQUIRED ABSOLUTE ACCURACY                             
C                                                                       
C     12/20/76 - FIRST VERSION - S. PIEPER                              
C     11/22/79 - AVOID LN(0) - S.P.                                     
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      IF ( A .EQ. 0 ) GO TO 800                                         
      BP = B/A                                                          
      CP = C/A                                                          
      IF ( B .EQ. 0 ) GO TO 850                                         
      X = -CP                                                           
      IF ( X .LT. .1 ) X = .1                                           
      DO 199 I = 1, 100                                                 
      XOLD = X                                                          
      DELTA = -(X+BP*DLOG(X)+CP)/(1+BP/X)                               
      X = X + DELTA                                                     
      IF ( X .LE. 0 ) X = .1*XOLD                                       
      IF ( DABS(DELTA) .LE. ACC ) GO TO 300                             
 199  CONTINUE                                                          
      WRITE(6,203) A, B, C, X                                             
 203  FORMAT ( '0**** COULD NOT CONVERGE IN RTXLNX', 4G20.10 )          
 300  RTXLNX = X                                                        
      RETURN                                                            
 800  RTXLNX = DEXP(-C/B)                                               
      RETURN                                                            
 850  RTXLNX = -CP                                                      
      RETURN                                                            
      END                                                               
      SUBROUTINE SDERIV ( NFIRST, NSTEPS, NUMVS, MAXVS, NPARA,  WAVER, W
     *AVEI, ALPHAR, ALPHAI, VDERIV, ITYPE, SDELS, DSDP )                
C                                                                       
C     COMPUTES DERIVATIVES OF THE S-MATRIX.                             
C                                                                       
C     USES THE FIRST ORDER RELATIONSHIP:                                
C                                                                       
C       D(S(L)) = - (4 I M) / (K HBARC**2)  <U(L)*  D(V)  U(L)>         
C                                                                       
C     TO COMPUTE THE DERIVATIVES OF THE S-MATRIX WITH RESPECT TO ALL    
C     THE POTENTIAL PARAMETERS THAT ARE BEING VARIED BY THE FITTER.     
C                                                                       
C *************************************************************         
C *   THIS ROUTINE WILL NEED ADDITIONAL WORK FOR S.O. FORCES  *         
C *************************************************************         
C                                                                       
C     NFIRST - FIRST STEP THAT HAS A NON-ZERO WAVEFUNCTION (FROM WAVELJ)
C     NSTEPS - NUMBER OF STEPS + 1 IN THE SOLUTION OF THE WAVE-EQUATION.
C     NUMVS - NUMBER OF NON-ZERO  D(V)/D(X(K)).  COMPLEX D(V)/D(X(K))   
C             COUNT AS TWO.                                             
C     LMAXVS - MAXIMUM POSSIBLE VALUE OF NUMVS ( 2*NPARA ).             
C     NPARA - NUMBER OF PARAMETERS.                                     
C     WAVER & WAVEI - (DIMENSION NSTEPS) U(L, R) AS COMPUTED BY         
C             WAVELJ AND NOT YET NORMALIZED.                            
C     ALPHAR & ALPHAI - THE NORMALIZATION FOR WAVER & WAVEI.            
C     VDERIV - (DIMENSION MAXVS X NSTEPS)  THE ARRAY OF                 
C              (I 8 K) / (STEPSIZE HBARC**2) * W(NP) * D(V)/D(X(K))     
C             WHERE                                                     
C              W(NP) = 1, 4, 2, 4, ..., 4, 2, 4, 1   ARE SIMPSON'S      
C             WEIGHTS.  THIS ARRAY WAS SETUP BY MAKDER.                 
C             ONLY THE FIRST NUMVS ROWS ARE USED.                       
C     ITYPE - (DIMENSION NPARA)  AN ARRAY CONTAINING                    
C              1  IF D(V)/D(X(K)) IS REAL ,                             
C              2  IF D(V)/D(X(K)) IS IMAGINARY                          
C              3  IF D(V)/D(X(K)) IS COMPLEX.                           
C             THIS ARRAY IS SETUP BY FITINP.                            
C     SDELS - (DIMENSION 2 X NUMVS)  A WORK ARRAY.                      
C     DSDP - (DIMENSION 2 X NPARA) - THE DERIVATIVES OF THE S-MATRIX    
C            ARE STORED HERE.                                           
C                                                                       
C     10/27/75 - FIRST VERSION - S. PIEPER                              
C     2/23/76 - START AT 1D-30                                          
C     3/10/76 - LIMIT THE RANGE OF THE DERIVATIVES                      
C     2/3/77 - SEARCH FOR STARTING POINT NOLONGER NEEDED                
C     4/21/77 - RENORM AND LABSHIFT MAY BE FIT                          
C     2/14/78 - NUMERICAL DERIVATIVES                                   
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL WAVER,WAVEI,VDERIV,ITYPE,SDELS,DSDP                 
C                                                                       
      DIMENSION WAVER(NSTEPS), WAVEI(NSTEPS), VDERIV(MAXVS, NSTEPS),  IT
     *YPE(NPARA), SDELS(2, MAXVS), DSDP(2, NPARA)                       
C                                                                       
      COMMON /LOCFIT/ LFITSP(26), MNDRIV, MXDRIV                        
C                                                                       
      IF ( NUMVS .EQ. 0 ) GO TO 300                                     
      DO 29 NV = 1, NUMVS                                               
      SDELS(1,NV) = 0                                                   
      SDELS(2,NV) = 0                                                   
 29   CONTINUE                                                          
C                                                                       
C     STEP 1)  COMPUTE THE INTEGRALS WITHOUT REGARD TO FACTORS OF I     
C              IN VDERIV.                                               
C                                                                       
C     FIND A START THAT WON'T UNDERFLOW.                                
C                                                                       
      NP1 = MAX0( NFIRST-1, MNDRIV )                                    
C                                                                       
C     NOW DO THE INTEGRALS                                              
C                                                                       
 100  DO 189 NP = NP1, MXDRIV                                           
      UR = WAVER(NP)**2 - WAVEI(NP)**2                                  
      UI = WAVER(NP)*WAVEI(NP)                                          
      UI = UI + UI                                                      
      DO 169 NV = 1, NUMVS                                              
      SDELS(1,NV) = SDELS(1,NV) + UR*VDERIV(NV,NP)                      
      SDELS(2,NV) = SDELS(2,NV) + UI*VDERIV(NV,NP)                      
 169  CONTINUE                                                          
 189  CONTINUE                                                          
C                                                                       
C     STEP 2)  COMPUTE  D(S)/D(X(K))  FROM THE ABOVE DERIVATIVES.       
C              ALSO PUT IN THE WAVEFUNCTION NORMALIZATIONS.             
C                                                                       
 300  BETAR = ALPHAR**2 - ALPHAI**2                                     
      BETAI = 2*ALPHAR*ALPHAI                                           
      NV = 1                                                            
      DO 389 NX = 1, NPARA                                              
      DSDP(1,NX) = 0                                                    
      DSDP(2,NX) = 0                                                    
      I = ITYPE(NX)                                                     
      IF ( I .EQ. 0 .OR. I .GE. 4 ) GO TO 389                           
      DREAL = BETAR*SDELS(1,NV) - BETAI*SDELS(2,NV)                     
      DIMAG = BETAR*SDELS(2,NV) + BETAI*SDELS(1,NV)                     
      GO TO ( 320, 330, 340 ), I                                        
 320  DSDP(1,NX) = -DIMAG                                               
      DSDP(2,NX) = DREAL                                                
      NV = NV + 1                                                       
      GO TO 389                                                         
 330  DSDP(1,NX) = -DREAL                                               
      DSDP(2,NX) = -DIMAG                                               
      NV = NV + 1                                                       
      GO TO 389                                                         
 340  DSDP(1,NX) = -DIMAG - BETAR*SDELS(1,NV+1)  + BETAI*SDELS(2,NV+1)  
      DSDP(2,NX) = DREAL - BETAR*SDELS(2,NV+1)  - BETAI*SDELS(1,NV+1)   
      NV = NV + 2                                                       
 389  CONTINUE                                                          
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE SECDER ( ITYPE, N, NA, DEL, X, F, FJAC, G, FSTO,  JTJ, 
     *DNL, A, FJSTO, FJACC, XSTO, VALS )                                
C                                                                       
C     NUMERICAL CALCULATION OF COMPLETE SECOND-DERIVATIVE MATRIX        
C     OR NUMERICAL CHECK OF THE CALCULATION OF THE FIRST DERIVATIVES    
C                                                                       
C     IF ITYPE = 1, THIS ROUTINE SIMPLY CALLS DERCHK TO CHECK THE       
C        ANALYTIC DERIVATIVES.                                          
C     IF ITYPE = 2, THIS ROUTINE COMPUTES THE COMPLETE SECOND           
C     DERIVATIVE MATRIX BY MAKING SMALL PERTURBATIONS IN THE            
C     PARAMETERS AND USING CALGRA TO THE THE FIRST DERIVATIVES.         
C     VARIOUS COMPARASONS ARE THEN MADE BETWEEN THE SECOND DERIVATIVE   
C     MATRIX AND THE JTJ APPROXIMATION TO IT.                           
C                                                                       
C     1/29/75 - FIRST VERSION - MHM                                     
C     11/20/77 - NEW SETFIT CALL - S.P.                                 
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL X,F,FJAC,G,FSTO,JTJ,DNL,A,FJSTO,FJACC,XSTO,VALS     
C                                                                       
C                                                                       
      REAL*8 JTJ                                                        
      LOGICAL PRTSW                                                     
      DIMENSION X(N),G(N),F(NA),FSTO(NA),FJAC(NA,N)                     
      DIMENSION JTJ(N,N),DNL(N,N),XSTO(N),VALS(N),FJSTO(NA,N), A(N,N)   
      DIMENSION FJACC(NA, N)                                            
      COMMON/INTGER/JUNK(16),IPR                                        
C                                                                       
      WRITE(6,3) DEL                                                      
  3   FORMAT( ' RELATIVE STEPSIZE FOR NUMERICAL DERIVATIVES =', 1PG12.3)
      IF ( ITYPE .EQ. 1 ) GO TO 1000                                    
C                                                                       
      PRTSW=MOD(IPR,10).GE.2                                            
      CHISQ=CALGRA(NA,N,F,X,FJAC,G)                                     
      DO 10 I=1,NA                                                      
      DO 9 K = 1, N                                                     
  9   FJACC(I,K) = FJAC(I,K)                                            
   10 FSTO(I)=F(I)                                                      
      WRITE(6,200)
  200 FORMAT(3X,'PARAMETER-VECTOR')                                 
      DO 15 J=1,N                                                       
   15 XSTO(J)=X(J)                                                      
      WRITE(6,400)(X(I),I=1,N)                                            
  400 FORMAT(1H ,2X,6(G12.6,1X)/3X,6(G12.6,1X))                         
      WRITE(6,250)CHISQ                                                   
  250 FORMAT(1H ,2X,'CHISQ = ',G12.6)                                   
      DO 30 I=1,N                                                       
      DO 30 J=1,N                                                       
      JTJ(I,J)=0                                                        
      DO 20 K=1,NA                                                      
   20 JTJ(I,J)=JTJ(I,J)+FJAC(K,I)*FJAC(K,J)                             
      FACTOR=X(I)*X(J)                                                  
      JTJ(I,J)=JTJ(I,J)*FACTOR                                          
   30 DNL(I,J)=0                                                        
C                                                                       
C     HERE WE LOOP OVER THE N PARAMETERS AND PERTURB EACH ONE           
C     SEPARATELY AND GET THE FIRST DERIVATIVES FROM CALGRA.             
C     THE 2ND DERIVS ARE THEN COMPUTED BY SUBTRACTION.  NOTE THAT       
C     WE COMPUTE 3 DIFFERENT VALUES OF THE 2ND DERIVATIVES USING:       
C        X-DEL & X+DEL ;   X-DEL & X ;   X & X+DEL .                    
C     NOTE ALSO THAT THE COMPLETE SECOND DERIVATIVE MATRIX IS BUILT     
C     UP AND THAT ITS ASYMETRY IS AN INDICATION OF THE NUMERICAL        
C     ERRORS INVOLVED.                                                  
C                                                                       
      DO 50 I=1,N                                                       
      DX=DEL*XSTO(I)                                                    
      D2X=2*DX                                                          
      X(I)=XSTO(I)+DX                                                   
      CHISQ=CALGRA(NA,N,F,X,FJAC,G)                                     
      DO 85 JA=1,NA                                                     
      DO 85 K=1,N                                                       
   85 FJSTO(JA,K)=FJAC(JA,K)                                            
      X(I)=X(I)-D2X                                                     
      CHISQ=CALGRA(NA,N,F,X,FJAC,G)                                     
      DO 45 J=1,N                                                       
      FACTOR=XSTO(I)*XSTO(J)                                            
      IF(PRTSW) WRITE(6,450)I,J                                           
  450 FORMAT(3X,'(I,J) = (',I2,1X,I2,')' /'   NID', 8X, 'F', 12X, 
     *'D2F', 10X, 'F*D2F', 9X, 'D2F(L)',  9X, 'D2F(R)', 10X, 'DF(L)', 10
     *X, 'DF(R)' / )                                                    
      SUMABS=0                                                          
      DO 40 IA=1,NA                                                     
      NID=400+10*IA                                                     
      DIJ=(FJSTO(IA,J)-FJAC(IA,J))/D2X                                  
      BIT=FSTO(IA)*DIJ                                                  
      DIJL = (FJACC(IA,J) - FJAC(IA,J))/DX                              
      DIJR = (FJSTO(IA,J) - FJACC(IA,J))/DX                             
      IF(PRTSW) WRITE(6,500)NID,FSTO(IA),DIJ,BIT,DIJL,DIJR,FJAC(IA,J),
     * FJSTO(IA,J)                                                      
  500 FORMAT(1H ,2X,I3, 7G15.6 )                                        
      SUMABS=SUMABS+DABS(BIT)                                           
   40 DNL(I,J)=DNL(I,J)+BIT                                             
      CANCEL=DABS(DNL(I,J))/SUMABS                                      
      IF(PRTSW) WRITE(6,155)CANCEL                                        
  155 FORMAT(3X,'CANCELLATION RATIO = ',G12.6)                      
      DNL(I,J)=DNL(I,J)*FACTOR                                          
   45 CONTINUE                                                          
      X(I)=XSTO(I)                                                      
   50 CONTINUE                                                          
C                                                                       
C     RESTORE THE COMMON BLOCKS TO THE ORIGINAL PARAMETERS              
C                                                                       
      CALL SETFIT ( XSTO, IRET, 0 )                                     
C                                                                       
      WRITE(6,950)
  950 FORMAT(3X,'--- MATRICES SCALED BY X(I)*X(J) FACTORS ---')     
      WRITE(6,550)
  550 FORMAT(3X,' SUM(F*D2F) ')                                     
      DO 60 I=1,N                                                       
   60 WRITE(6,400)(DNL(I,J),J=1,N)                                        
      WRITE(6,300)
  300 FORMAT(3X,' JTJ ')                                            
      DO 25 I=1,N                                                       
   25 WRITE(6,400)(JTJ(I,J),J=1,N)                                        
      DO 65 I=1,N                                                       
      DO 65 J=1,N                                                       
      FJAC(I,J)=DNL(I,J)                                                
   65 DNL(I,J)=DNL(I,J)+JTJ(I,J)                                        
      WRITE(6,600)
  600 FORMAT(3X,' 1/2 D2(CHISQ)/DXI*DXJ ')                          
      DO 70 I=1,N                                                       
   70 WRITE(6,400)(DNL(I,J),J=1,N)                                        
      DO 165 I=1,N                                                      
      DO 165 J=1,N                                                      
  165 A(I,J)=DNL(I,J)                                                   
      CALL SDIAG( N,N,1.D-13,30,A,VALS,A,XSTO)                          
      WRITE(6,740)
  740 FORMAT(3X,'EIGENVALUES OF 1/2 D2(CHISQ)/DXI*DXJ ')            
      WRITE(6,400)(VALS(I),I=1,N)                                         
      CALL SYMINV(JTJ,N,XSTO,0,DET, N)                                  
      DO 52 I=2,N                                                       
      JTOP=I-1                                                          
      DO 52 J=1,JTOP                                                    
   52 JTJ(I,J)=JTJ(J,I)                                                 
      WRITE(6,730)
  730 FORMAT(3X,' JTJ**-1 ')                                        
      DO 54 I=1,N                                                       
   54 WRITE(6,400)(JTJ(J,I),J=1,N)                                        
      DO 920 I=1,N                                                      
      DO 920 J=I,N                                                      
      A(I,J)=0                                                          
      DO 915 K=1,N                                                      
  915 A(I,J)=A(I,J)+JTJ(I,K)*FJAC(K,J)                                  
  920 A(J,I)=A(I,J)                                                     
      CALL SDIAG(NA,N,1.D-13,30,FJAC,VALS,FJAC,XSTO)                    
      VMAX=0                                                            
      DO 925 I=1,N                                                      
      TEM=DABS(VALS(I))                                                 
  925 IF(TEM.GT.VMAX) VMAX=TEM                                          
      PP=VMAX                                                           
      WRITE(6,935)
  935 FORMAT(3X,'EIGENVALUES OF NON-LINEAR CORRECTION MATRIX')      
      WRITE(6,400)(VALS(I),I=1,N)                                         
      CALL SDIAG(N,N,1.D-13,30,A,VALS,A,XSTO)                           
      VMAX=0                                                            
      DO 930 I=1,N                                                      
      TEM=DABS(VALS(I))                                                 
  930 IF(TEM.GT.VMAX) VMAX=TEM                                          
      RP=VMAX                                                           
      CALL SYMINV(DNL,N,XSTO,0,DET, N)                                  
      DO 56 I=2,N                                                       
      JTOP=I-1                                                          
      DO 56 J=1,JTOP                                                    
   56 DNL(I,J)=DNL(J,I)                                                 
      WRITE(6,770)
  770 FORMAT(3X,' 1/2 D2CHISQ**-1 ')                                
      DO 58 I=1,N                                                       
   58 WRITE(6,400)(DNL(J,I),J=1,N)                                        
      CALL SDIAG( N,N,1.D-13,30,JTJ,VALS,JTJ,XSTO)                      
      VMAX=0                                                            
      DO 940 I=1,N                                                      
  940 IF(VALS(I).GT.VMAX) VMAX=VALS(I)                                  
      PP=PP*VMAX                                                        
      DO 75 I=1,N                                                       
      VALS(I)=DSQRT(VALS(I))                                            
   75 FSTO(I)=1/VALS(I)                                                 
      WRITE(6,700)
  700 FORMAT(3X,'SQRT EIGENVALUES OF JTJ**-1')                      
      WRITE(6,400)(VALS(J),J=1,N)                                         
      WRITE(6,750)
  750 FORMAT(3X,'SQRT EIGENVALUES OF JTJ ')                         
      WRITE(6,400)(FSTO(J),J=1,N)                                         
      WRITE(6,800)
  800 FORMAT(3X,'EIGENVECTORS')                                     
      DO 80 I=1,N                                                       
   80 WRITE(6,400)(JTJ(K,I),K=1,N)                                        
      CALL SDIAG( N,N,1.D-13,30,DNL,VALS,DNL,XSTO)                      
      WRITE(6,900)
  850 FORMAT(3X,'EIGENVALUES OF 1/2(D2(CHISQ)/DXI*DXJ) ')           
      WRITE(6,400)(VALS(I),I=1,N)                                         
      DO 175 I=1,N                                                      
      DO 175 J=1,N                                                      
      FSTO(I)=DABS(VALS(I))                                             
  175 FSTO(I)=DSQRT(FSTO(I))                                            
      WRITE(6,760)
  760 FORMAT(3X,'SQRT /EIGENVALUES/ OF 1/2(D2(CHISQ)/DXI*DXJ) ')    
      WRITE(6,400)(FSTO(I),I=1,N)                                         
      DO 90 J=1,N                                                       
   90 FSTO(J)=1/VALS(J)                                                 
      WRITE(6,850)
  900 FORMAT(3X,'EIGENVALUES OF 2*(D2(CHISQ)/DXI*DXJ**-1) ')        
      WRITE(6,400)(FSTO(I),I=1,N)                                         
      WRITE(6,800)
      DO 98 I=1,N                                                       
   98 WRITE(6,400)(DNL(K,I),K=1,N)                                        
      WRITE(6,945)RP,PP                                                   
  945 FORMAT(3X,'+++++ MCKEOWN S PARAMETERS  +++++'/ 9X,'R = ',G12.6
     *,' P = ',G12.6/3X,8('+++++'))                                     
      RETURN                                                            
C                                                                       
C     CHECK THE ANALYTIC FIRST DERIVATIVES                              
C                                                                       
 1000 CALL DERCHK ( N, NA, DEL, X, F, FJAC, G, FSTO )                   
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE SETBFC ( NBINDX, MBINDX, BINDEX,MCHNDF,CHNDEF,RCHNDF, 
     * NUMLIS,LIS,R2S,LMXMX,SIG1,SIG2,RLOWER,ALLSW,IRORC,NMBFAC,BFAC, 
     * FFWORK,IDIM1,LDLDIM,WRKWK,FIWORK,IDIM2,WRKST,IRET)                                                     
C                                                                       
C     GETS AND STORES THE B FACTORS  OR COULOMB FF2 INTEGRALS           

C                                                                       
C     NBINDX, MBINDX, BINDEX - THE B-INDEX ARRAY                        
C     MCHNDF, RCHNDF - THE CHANNEL-DEFINITION ARRAY                     
C     NUMLIS, LIS - FOR B FACTORS, THIS IS THE ARRAY OF J'S (SO FAR     
C              NOT 2*J) AT WHICH CALCULATIONS ARE TO BE DONE.           
C              FOR FF2'S  NUMLIS IS A WORK VARIABLE AND                 
C              LIS(1) MUST BE                                           
C              MIN(2*J) = 2*LMIN.                                       
C     R2S - R2S(4) CONTAINS  -3*ZP*ZT*ALPHA*HBARC                       
C     LMXMX - MUST BE LMAX+LXMAX (LOMOST+LXMAX)                         
C             FOR FF2'S THIS VARIABLE IS SET IN HERE.                   
C     SIG1, SIG2 - ARRAYS TO HOLD THE COULOMB PHASE SHIFTS.  FOR        
C          FF2, SIG1 MUST ALREADY HAVE THE ELASTIC PHASES.              
C     RLOWER - SUMMAX FOR B FACTORS,  0 FOR FF2 INTS.                   
C     ALLSW - .TRUE. FOR B-FACTORS,  .FALSE. FOR FF2                    
C     IRORC - FIRST DIMENSION OF BFAC, = 2 FOR BFACTORS AND             
C             1 FOR FF2INTS.                                            
C     NMBFAC - SECOND DIMENSION OF BFAC, = NMBFAC FOR BFACTORS,         
C              NMFFAC FOR FF2INTS.                                      
C     BFAC - GETS THE B FACTORS OR FF2 INTS AS DESCRIBED BELOW.         
C                                                                       
C                                                                       
C                                                                       
C     THE QUANTITY COMPUTED IS  FOR B FACTORS                           
C        B(2,1)/X(1,2) =  FAC*( FG-GF + I(FF+GG) )                      
C     WHERE                                                             
C        FG = INTEGRAL(R,INF) F(1)*G(2)/R**(LX+1)                       
C     AND                                                               
C     FAC IS 3/2*ZP*ZT*ALPHA*HBARC/SQRT(K1*K2) * 2MU/HBAR**2            
C     ETC.                                                              
C                                                                       
C     OR FOR  FF2 INTS                                                  
C        !S(BORN)!/X(1,ALPHA0) = 4*FAC*FF                               
C                                                                       
C     HERE BASIS STATE 1 IS THE STATE WHOSE S-MATRIX IS TO BE FOUND.    
C     2 IS A STATE THAT IS IN THE RHS OF 1.                             
C                                                                       
C     1/8/80 - FIRST VERSION BASED ON ANGSET - S.P.                     
C     2/19/80 - INCLUDE LOOP ON NBINDX; DO FF2 INTS - S.P.              
C     3/15/80 - STORE IN J BLOCKS - S.P.                                
C     4/8/80 - USE IPRINT/10 FOR FF2 DEBUG PRINT OUT - S.P.             
C     4/25/80 - MAKE ETA2 REAL*8 CONSISTANT WITH ETA1, K1, K2 - S.P.    
C     9/25/80 - MUST GET LIMOST FROM CHNDEF - S.P.                      
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
           DIMENSION LIS(1), SIG1(1), SIG2(1),  FFWORK(IDIM1,4), WRKWK(1
     *), FIWORK(IDIM2,4), WRKST(1),  R2S(4)                             
      REAL*4 BFAC(IRORC, NMBFAC, 1), RCHNDF(MCHNDF, 1)                  
      INTEGER BINDEX(MBINDX, NBINDX), CHNDEF(MCHNDF, 1)                 
      LOGICAL ALLSW                                                     
C                                                                       
C                                                                       
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      LOGICAL PBUGSW                                                    
C                                                                       
      IPRNT = IPRINT/10                                                 
      IF ( ALLSW ) IPRNT = IPRINT/100                                   
      IPRNT = MOD( IPRNT, 10 )                                          
      PBUGSW = IPRNT .GE. 3                                             
C                                                                       
C                                                                       
C     WE LOOP OVER ALL SETS OF B FACTORS                                
C                                                                       
      DO 699 IBF = 1, NBINDX                                            
C                                                                       
C     IF DOING FF2, ONLY THE STUFF CONNECTED TO THE G.S. IS DONE.       
C                                                                       
      ASSIGN 350 TO IGO                                                 
      IF ( ALLSW ) GO TO 130                                            
      IF ( BINDEX(9,IBF) .EQ. 0 ) GO TO 699                             
      ASSIGN 360 TO IGO                                                 
C                                                                       
 130  LX = BINDEX(1,IBF)                                                
      IC1 = BINDEX(2,IBF)                                               
      IC2 = BINDEX(3,IBF)                                               
      MXLMJ1 = BINDEX(4,IBF)                                            
      MXLMJ2 = BINDEX(5,IBF)                                            
      MNLMJ1 = BINDEX(6,IBF)                                            
      MNLMJ2 = BINDEX(7,IBF)                                            
      LB = BINDEX(8,IBF)                                                
      ETA1 = RCHNDF(6,IC1)                                              
      AK1 = RCHNDF(7,IC1)                                               
      ETA2 = RCHNDF(6,IC2)                                              
      AK2 = RCHNDF(7,IC2)                                               
C                                                                       
C ****  HERE WE NEED DOUBLE PRECISION ACCURACY FOR ETA, K. *******      
C ****  WE COMPUTE THEM FROM THE INPUT BUT IT WOULD BE BETTER ****      
C ****  AND MORE GENERAL TO HAVE REAL*8 VALUES STORED.     *******      
C ****  WE ASSUME NO CHANGE IN THE REDUCED MASS BETWEEN CHANNELS.       
C                                                                       
      TEMP = IZS(1)*IZS(3)*AM/(AFINE*HBARC)                             
      X = ECM - RCHNDF(3,IC1) - RCHNDF(5,IC1)                           
      AK1 = DSQRT(2*AM*X)/HBARC                                         
      ETA1 = TEMP/AK1                                                   
      X = ECM - RCHNDF(3,IC2) - RCHNDF(5,IC2)                           
      AK2 = DSQRT(2*AM*X)/HBARC                                         
      ETA2 = TEMP/AK2                                                   
C                                                                       
      IF ( ALLSW ) GO TO 180                                            
      LIMOST = CHNDEF(15,IC2)                                           
      NUMLIS = LIMOST - LIS(1)/2 + 1                                    
      LMXMX = LIMOST+LX                                                 
      LB = BINDEX(9,IBF)                                                
      GO TO 190                                                         
C                                                                       
 180  CALL DSGMAL ( ETA1, LMXMX+LX, SIG1 )                              
 190  CALL DSGMAL ( ETA2, LMXMX+LX, SIG2 )                              
C                                                                       
C     FAC IS 3/2*ZP*ZT*ALPHA*HBARC/SQRT(K1*K2) * 2MU/HBAR**2            
C     AND   4*ABOVE = 6*ZP*ZT*....  FOR FF2 FACTORS.                    
C                                                                       
      FAC = -.5*R2S(4)/SQRT(AK1*AK2) * 2*AM/HBARC**2                    
      IF ( .NOT. ALLSW ) FAC = 4*FAC                                    
C                                                                       
      LMNMN = MAX0( LMIN+(MNLMJ1+MNLMJ2-3)/4, LX/2 )                    
C                                                                       
      IF ( PBUGSW ) WRITE(6,3) ETA1,AK1,ETA2,AK2,LX,MXLMJ1,MXLMJ2, 
     *MNLMJ1, MNLMJ2, NUMLIS, LMXMX, LMNMN                              
  3   FORMAT ( ' SETBFC, ETA1, K1, ETA2, K2 =', 4G20.5 /  '    LX, MXLMJ
     *1, MXLMJ2, MNLMJ1, MNLMJ2, NUMLIS, LMXMX,',  ' LMNMN =', 8I8 )    
C                                                                       
      CALL COULIN (LX+1, LX, LMNMN, LMXMX,  ETA1, AK1, SIG1, ETA2, AK2,
     * SIG2, RLOWER, ALLSW,  FFWORK(1,1), FFWORK(1,2), FFWORK(1,3), FFWO
     * RK(1,4),  LDLDIM, ACCINE, COULML,MXCOUL,NPCOUL,WRKWK,FIWORK(1,1),
     * FIWORK(1,2), FIWORK(1,3), FIWORK(1,4),WRKST, IPRNT,IRET)
      IF ( IRET .NE. 0 ) GO TO 9960                                     
C                                                                       
      MAXDEL = MAX0(2, LX)                                              
C                                                                       
C     THE REQUIRED QUANTITIES ARE INDEXED BY                            
C                                                                       
C     I = ( L2-L1+LX + (LX+1)(L1-MIN(L1)) )/2 + LB                      
C                                                                       
C     AND ARE SUCH THAT                                                 
C                                                                       
C       B(2,1) = X(1,2) * ( BFAC(1,I,ILI) + 1I*BFAC(2,I,ILI) )          
C                                                                       
C     WHERE LB IS  BINDEX(8,IB))                                        
C           IB = BASCPL(9,...)                                          
C           BFAC IS ALLOC4(LCL1FF)                                      
C                                                                       
C     FOR FF2 INTEGRALS IT IS                                           
C                                                                       
C       FF2(2,1) = X(1,2) * BFAC(I+1)                                   
C                                                                       
C     WHERE  BFAC  IS ALLOC4(LCL2FF+BINDEX(9,IB))                       
C     I = ( L2-L1+LX + (LX+1)(L1-MIN(L1)) )/2                           
C         + (LX+1)*NM1FRJ*(J-JMIN)                                      
C                                                                       
C     NOTE THAT BOTH L2 AND L1 GO IN STEPS OF 2.                        
C                                                                       
      NM1FRJ = (MXLMJ1-MNLMJ1)/4 + 1                                    
      NMBFRJ = (LX+1)*NM1FRJ                                            
C                                                                       
      DO 399 ILI = 1, NUMLIS                                            
      J = LIS(1)-2 + 2*ILI                                              
      IF ( ALLSW ) J = 2*LIS(ILI)                                       
      MINL1 = (MNLMJ1+J)/2                                              
      L1ST = MAX0( MINL1, 0 )                                           
      L1ST = L1ST + MOD( L1ST-MINL1, 2 )                                
C                                                                       
      L1END = (MXLMJ1+J)/2                                              
      L2 = (MNLMJ2+J)/2                                                 
      L2ST = MAX0( L2, 0 )                                              
      L2ST = L2ST + MOD( L2ST-L2, 2 )                                   
      L2END = (MXLMJ2+J)/2                                              
C                                                                       
      IF ( PBUGSW ) WRITE(6,323) L1ST, L1END, L2ST, L2END                 
 323  FORMAT ( ' L1ST, L1END, L2ST, L2END =', 4I8 )                     
C                                                                       
      DO 389 L1 = L1ST, L1END, 2                                        
      L2MN = MAX0( L2ST, IABS(L1-LX) )                                  
      L2MN = L2MN + MOD(L2MN-L2ST, 2 )                                  
      L2MX = MIN0( L2END, L1+LX )                                       
      IF ( L2MX .LT. L2MN ) GO TO 389                                   
C                                                                       
      IF ( L1+L2MN .LT. 2*LMNMN .OR. L1+L2MX .GT. 2*LMXMX ) GO TO 9950  
C                                                                       
      DO 379 L2 = L2MN, L2MX, 2                                         
      LDEL = L1-L2                                                      
      ID = JISHFT( MAXDEL-LDEL, -1)                                     
      IL = L2 + ( L1-2*LMNMN )                                          
      I1 = ID + IL*LDLDIM + 1                                           
      I = (LX+1)*(L1-MINL1)  - L1 + LX + L2                             
      I = JISHFT(I,-1)                                                  
C                                                                       
      GO TO IGO, ( 350, 360 )                                           
C                                                                       
 350  BFAC(1,I+LB,ILI) = FAC*( FFWORK(I1,2)-FFWORK(I1,3) )              
      BFAC(2,I+LB,ILI) = FAC*( FFWORK(I1,1) + FFWORK(I1,4) )            
      GO TO 379                                                         
C                                                                       
 360  I = I + NMBFRJ*(ILI-1)                                            
      BFAC(1,LB+I,1) = FAC*FFWORK(I1,1)                                 
C                                                                       
 379  CONTINUE                                                          
 389  CONTINUE                                                          
 399  CONTINUE                                                          
C                                                                       
 699  CONTINUE                                                          
C                                                                       
      IRET = 0                                                          
      RETURN                                                            
C                                                                       
 9950 WRITE(6,9953) ILI,J,LMNMN,LMXMX,L1ST,L1END,L2ST,L2END,L1,L
     *2MN, L2MX, LX, MXLMJ1, MXLMJ2,  MNLMJ1, MNLMJ2                    
 9953 FORMAT ( '0**** INTERNAL ERROR IN SETBFC AT 9950:' /  (8I10) )    
C                                                                       
 9960 WRITE(6,9963) IRET,LX,LMNMN,LMXMX,ETA2,AK2,ETA1,AK1,RLOWER,
     * ALLSW,  LDLDIM, ACCINE, COULML, MXCOUL, NPCOUL                   
 9963 FORMAT ( '0**** ERROR IN COULIN:', 4I12 /  5G18.7, L5 /  I10, 2G18
     *.7, 2I10 )                                                        
      RETURN                                                            
      END                                                               
      SUBROUTINE SETBRN ( NBINDX, MBINDX, BINDEX, MCHNDF, CHNDEF,  MBASD
     *F, BASDEF, MBASCP, BASCUP, RBASCP,  NUMLIS, LIS, JMIN, FF2INT,  IN
     *DXS, SMATR, SMATI )                                               
C                                                                       
C     COMPUTES COULOMB BORN S MATRICES AND SUBTRACTS FROM CC            
C                                                                       
C     FOR ALL CHANNELS THAT ARE                                         
C     FIRST-ORDER COULOMB COUPLED TO THE GROUND STATE, THE              
C     FF INTEGRALS ARE THEN CONVERTED TO S(BORN) WITH THE               
C     EXCEPTION OF THE FACTOR I.  THAT IS EITHER REAL(S) OR             
C     IM(S) IS COMPUTED AS APPROPRIATE.  FINALLY THE BORS               
C     S-MATRICES ARE SUBTRACTED FROM THE C.C. S-MATRICES.               
C                                                                       
C     3/21/80 - FIRST VERSION - S.P.                                    
C     4/8/80 - PRINT !DIF! - S.P.                                       
C     6/24/80 - DEFINE IPRINT, PRINT FOR 2 -- S.P.                      
C     7/2/80 - PRINT MCHN, NOT IC2 - S.P.                               
C     9/25/80 - MUST GET EACH JMOST FROM CHNDEF - S.P.                  
C     12/18/80 - IMPROVE COMMENTS  - S.P.                               
C     1/12/81 - BOHR-MOTTELSON R.M.E. - S.P.                            
C     9/12/81 - ALLOW SEVERAL G.S. COUPLINGS DUE TO 2ND ORDER - S.P.    
C     10/28/81 - ROOT 2 NEEDED FOR PARTIALLY SYMMETRIZED STATES - S.P.  
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      INTEGER BINDEX(MBINDX, NBINDX), CHNDEF(MCHNDF, 1), BASDEF(MBASDF, 
     *1), BASCUP(MBASCP, 1), LIS(1), INDXS(1)                           
      REAL*4 RBASCP(MBASCP, 1), FF2INT(1)                               
      REAL*8 SMATR(1), SMATI(1)                                         
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                                           
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      LOGICAL PRNTSW, BADSW                                             
C                                                                       
      DATA ROOT2 / 1.41421 35623 731 0D0 /                              
C                                                                       
      PRNTSW = MOD(IPRINT, 10) .GE. 2                                   
C                                                                       
C     WE ASSUME THAT THERE IS ONLY ONE BASIS STATE FOR THE              
C     GROUND-STATE CHANNEL.                                             
C                                                                       
      L1MJ = 0                                                          
C                                                                       
C     LOOP OVER ALL SETS OF FF2 BFACTORS                                
C                                                                       
      DO 699 IBF = 1, NBINDX                                            
      LB = BINDEX(9,IBF)                                                
      IF ( LB .EQ. 0 ) GO TO 699                                        
      LX = BINDEX(1,IBF)                                                
      IC1 = BINDEX(2,IBF)                                               
      IC2 = BINDEX(3,IBF)                                               
      MXLMJ1 = BINDEX(4,IBF)                                            
      MNLMJ1 = BINDEX(6,IBF)                                            
C                                                                       
C       FF2(2,1) = X(2,1) * BFAC(I+1)                                   
C     WHERE  X(2,1)  EXPRESSES THE CONTRIBUTION OF THE G.S. CHANNEL (1) 
C     TO THE BASIS STATE 2.  X(2,1) CONSISTS OF THE KINEMATICAL         
C     PIECE    I**LX * SQRT( 1/4PI ) *                                  
C               ! CLEBSCH( L1 LX 0 0 ; L2 0 ) !                         
C     WHICH IS COMPUTED HERE, TIMES THE MODEL PIECE FROM THE            
C     BASIS COUPLING ARRAY.                                             
C     THIS EXPRESSION IS THE VALUE OF W(2,1) AS DEFINED IN              
C     EQ. 21 OF THE NOTES, FOR THE CASE THAT                            
C       S(1) = JP(1) = JT(1) = 0,  L(1) = J .                           
C     WE USE THE FACT THAT                                              
C        PHASE < L1 LX 0 0 ; L2 0 >  =  I**(L1+LX-L2)                   
C                                                                       
C     HERE  BFAC  IS ALLOC4(LCL2FF+BINDEX(9,IB))                        
C     I = ( L2-L1+LX + (LX+1)(L1-MIN(L1)) )/2                           
C         + (LX+1)*NM1FRJ*(J-JMIN)                                      
C                                                                       
C     NOTE THAT BOTH L2 AND L1 GO IN STEPS OF 2.                        
C                                                                       
      NM1FRJ = (MXLMJ1-MNLMJ1)/4 + 1                                    
      NMBFRJ = (LX+1)*NM1FRJ                                            
C                                                                       
      MCHN = CHNDEF(1,IC2)                                              
      IB2ST = CHNDEF(8,IC2)                                             
      IB2ND = IB2ST + CHNDEF(9,IC2) - 1                                 
      KSMAT = CHNDEF(10,IC2)                                            
      NSPLI = CHNDEF(11,IC2)                                            
      KINDXS = CHNDEF(12,IC2) + 3 + 3*LX                                
      KBASE = KSMAT + INDXS(KINDXS-2)                                   
      LDELMN = INDXS(KINDXS-1)                                          
      LIMOST = CHNDEF(15,IC2)                                           
      JMOST = 2*LIMOST                                                  
      NUMJ = (JMOST-JMIN)/2 + 1                                         
C                                                                       
C     LOOP OVER ALL BSIS STATES FOR CHANNEL 2                           
C                                                                       
      DO 659 IB2 = IB2ST, IB2ND                                         
      L2MJ = BASDEF(3,IB2)                                              
      ICUPST = BASDEF(4,IB2)                                            
      ICUPND = ICUPST + BASDEF(5,IB2) - 1                               
      LDEL = ( L2MJ-L1MJ )/2                                            
      KOFFS = KBASE + JISHFT( LDEL-LDELMN, -1)                          
C                                                                       
C     LOCATE THE COUPLINGS TO THE G.S. OF THIS BASIS STATE, AND         
C     ACCUMULATE THE MATRIX ELEMENT FOR THE 1/R**(LX+1) TAIL.           
C                                                                       
      FAC1 = 0                                                          
      DO 129 ICUP = ICUPST, ICUPND                                      
      IF ( IABS(BASCUP(9,ICUP)) .EQ. IBF )  FAC1 = FAC1 + RBASCP(6,ICUP)
     *                                                                  
 129  CONTINUE                                                          
      IF ( FAC1 .EQ. 0 ) GO TO 659                                      
      BADSW = .FALSE.                                                   
C                                                                       
C     WE HAVE FOUND THE RELAVANT COUPLING PARAMETER                     
C     SINCE WE ASSUME ONLY ONE G.S. BASIS STATE, THERE IS               
C     ONLY ONE POSSIBLE USE OF EACH FF2INT.                             
C     THEREFORE WE WEIGHT EACH ONE WITH THE APPROPRIATE SUM             
C     OF MATRIX ELEMENTS.                                               
C                                                                       
C     HERE WE INCORPORATE THE SIGN OF I**(LX-1) IN THE FACTOR           
C     THE EXTRA -1 COMES FROM MAKING AN S-MATRIX FROM THE T-MATRIX.     
C                                                                       
      FAC1 = FAC1/RT4PI                                                 
      IF ( BASDEF(7,IB2) .EQ. 2 ) FAC1 = ROOT2*FAC1                     
      LXP1 = LX+1                                                       
      IF ( MOD(LXP1,4).LE.1 ) FAC1 = -FAC1                              
C                                                                       
      INDX1 = LB + JISHFT( LDEL+LX, -1)                                 
C                                                                       
C     NOW LOOP OVER ALL J'S AND COMPUTE S(BORN) FOR THIS L-J.           
C                                                                       
      DO 399 NJ = 1, NUMJ                                               
      J = 2*NJ + (JMIN-2)                                               
      L1X2 = J+L1MJ                                                     
      L2X2 = J+L2MJ                                                     
      IF ( L2X2 .LT. 2*LX-L1X2 ) GO TO 399                              
      I = INDX1 + NMBFRJ*(NJ-1)                                         
      FF2INT(I) = FAC1*FF2INT(I) *  ABS( CLEBSH( L1X2, 2*LX, 0, 0, L2X2,
     * 0 ) )                                                            
 399  CONTINUE                                                          
C                                                                       
C     NOW SUBTGRACT THE BORN VALUES FROM ALL THE COMPUTED S MATRICES    
C                                                                       
      ASSIGN 460 TO IGOTO                                               
      IF ( MOD(LX,2).EQ.0 ) ASSIGN 465 TO IGOTO                         
C                                                                       
      IF (PRNTSW) WRITE(6,403) MCHN, IB2, LX, LDEL                        
 403  FORMAT ( ' COMPARISON OF C.C. AND COULOMB BORN',  ' S MATRICES FOR
     * CHANNEL', I3, ', BASIS STATE', I4,  5X, 'LX =', I3, 5X, 'LOUT-LIN
     * =', I3 /  '    J   L IN  L OUT', T31, 'S(C.C.)',  T54, 'S(BORN)',
     * T74, 'DIFFERENCE', T96,  '!DIFFERENCE!', T116, '%' )             
C                                                                       
      DO 499 ILI = 1, NUMLIS                                            
      J = 2*LIS(ILI)                                                    
      L1X2 = J+L1MJ                                                     
      L2X2 = J+L2MJ                                                     
      IF ( L2X2 .LT. 2*LX-L1X2 ) GO TO 499                              
      L1 = JISHFT(L1X2, -1)                                             
      L2 = JISHFT(L2X2, -1)                                             
      I1 = (ILI-1)*NSPLI + KOFFS                                        
      I2 = INDX1 + NMBFRJ*JISHFT(J-JMIN, -1)                            
      SR = SMATR(I1)                                                    
      SI = SMATI(I1)                                                    
      SBORN = FF2INT(I2)                                                
      GO TO IGOTO, ( 460, 465 )                                         
 460  SMATR(I1) = SR-SBORN                                              
      GO TO 480                                                         
 465  SMATI(I1) = SI-SBORN                                              
C                                                                       
 480  IF ( .NOT. PRNTSW ) GO TO 499                                     
      SMAG = DSQRT( SMATR(I1)**2 + SMATI(I1)**2 )                       
      PERCNT = 100*SMAG/(DABS(SBORN)+1.D-20)                            
      WRITE(6,483) J,L1,L2,SR,SI,SBORN,SMATR(I1),SMATI(I1),SMAG, 
     *PERCNT                                                            
 483  FORMAT ( I5, '/2', I5, I6, G15.5, G13.5, G16.5,  G16.5, G13.5, G14
     *.4, F13.2 )                                                       
 499  CONTINUE                                                          
 659  CONTINUE                                                          
      IF (BADSW) WRITE(6,673) IBF,LB,IC1,IC2,LX,IB2ST,IB2ND         
 673  FORMAT ( '0*** INTERNAL ERROR IN SETBRN:', 8I8 )                  
 699  CONTINUE                                                          
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE SETCHN ( ICHAN, IRET )                                 
C                                                                       
C     SETS UP PARAMETERS FOR A GIVEN CHANNEL                            
C                                                                       
C     THIS ROUTINE IS CALLED PRIOR TO EACH BOUND STATE AND              
C     DISTORTED WAVE CALCULATION.  WHERE NECESSARY IT DEFINES           
C     PROJECTILE (P) AND TARGET (T) PARAMETERS USING THE FIVE           
C     PARTICLE PARAMETERS.  IT ALSO COMPUTES SOME OF THE 5 PARTILCLE    
C     PARAMETERS FROM THE OTHERS.  IT FINDS E FROM VARIOUS              
C     POSSIBLE SOURCES.  FINALLY IT STORES THE P AND T PARAMETERS       
C     BACK INTO THE 5 PARTICLE PARAMETERS.                              
C     WHEN A DWBA IS NOT IN PROGRESS, THE 5 PARTICLE PARAMETERS         
C     ARE NOT USED NOR RESET.                                           
C                                                                       
C     ICHAN - THE CHANNEL TO BE PROCESSED:                              
C     1)  PROJECTILE BOUND STATE                                        
C     2)  TARGET BOUND STATE                                            
C     3)  INCOMING DISTORTED WAVE                                       
C     4)  OUTGOING DISTORTED WAVE                                       
C     5)  BOUND STATE WITHOUT DWBA                                      
C     6)  OPTICAL MODEL SCATTERING WITHOUT DWBA                         
C                                                                       
C     IRET - SET TO 0 IF AN ERROR FOUND; 1 OTHERWISE.                   
C                                                                       
C     5/5/75 - FIRST VERSION                                            
C     5/18/75 - USE Q BEFORE MASS EXCESS                                
C     5/30/75 - MORE J=0 STUFF.                                         
C     7/20/75 - AUTO PICK L'S, J'S FOR STANDALONES                      
C     10/13/75 - ELAB AND ECM ALWAYS WIN IN ELASTIC SCATTERING.         
C     12/14/76 - INELASTIC SCATTERING                                   
C     4/24/77 - SET EXSPT FOR IDENTICAL PARTICLE DETERMINATION          
C     9/24/77 - SET WASSET FOR JP, J, L; INITIALIZE WASSET              
C     11/20/77 - SET CORRECT ASYMPTOPIA FROM NEW SPLIT VALUES - S.P.    
C     2/11/78 - INDICATE WHEN ELAB HAS BEED DEFINED FROM ECM            
C     5/4/79 - RATMAS; MP AND MT ALWAYS REQUIRED; PARITY; SPECTROSCOPIC 
C              NOTATION CAN SET L, NODES - S.P.                         
C     6/5/79 - ELECTRON MASSES; FIX ELAB WASSET CONDITION - S.P.        
C     12/28/79 - STANDARD MORTRAN - RPG                                 
C                                                                       
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                                                            
      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 /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
C     FOLLOWING IS ELECTRON MASS FOR CONVERTING ATOMIC MASSES           
C     TO NUCLEAR MASSES.  FOLLOWING APPARENT CONVENTION, WE             
C     IGNOR ELECTRON BINDING ENERGIES.                                  
C                                                                       
      DATA EMASS / .511 003 4 0D0 /                                     
C                                                                       
      IRET = 1                                                          
C                                                                       
      JPOLD = JP                                                        
      JOLD = J                                                          
      LOLD = L                                                          
      IPOLD = PARITY                                                    
C                                                                       
C     WASSET IS USED TO KEEP TRACK OF THINGS SET TO OTHER THINGS        
C     CLRCHN USES IT TO DETERMIN WHAT TO UNDEFINE.                      
C                                                                       
      DO 19 I = 1, 32                                                   
 19   WASSET(I) = .FALSE.                                               
C                                                                       
C     IBND = 0  MEANS NOT A BOUND STATE CHANNEL,                        
C          > 0  MEANS A BOUND STATE, SEE STMNT NO 240 FOR MORE DETAILS  
C                                                                       
      IBND = 1                                                          
      IF ( ICHAN .EQ. 5 ) GO TO 300                                     
      IBND = 0                                                          
      IF ( ICHAN .EQ. 6 ) GO TO 310                                     
C                                                                       
C     COMPUTE  MASS EXCESS = MASS EXCESS (GROUND STATE) + E*            
C                                                                       
      DO 129 I = 1, 5                                                   
      IF ( AMXCS(I) .NE. UNDEF ) GO TO 129                              
      IF ( AMXCGS(I) .EQ. UNDEF ) GO TO 129                             
      AMXCS(I) = AMXCGS(I) + EXS(I)                                     
 129  CONTINUE                                                          
C                                                                       
C     FIND ZX, MX AND THE SIGNED ZX, MX                                 
C       ( SIGNMX = MA-MB = MBIGB-MBIGA, ETC )                           
C                                                                       
      SIGNMX = UNDEF                                                    
      ISGNZX = NOTDEF                                                   
C                                                                       
C     IF THE CHARGE TRANSFER IS 0 OR IF MX = 0 (INELASTIC SCAT)         
C     THEN NO AMBIGUITY                                                 
C                                                                       
      IF ( DABS(AMX) .LT. .3 ) SIGNMX = 0                               
      IF ( IZS(5) .EQ. 0 ) ISGNZX = 0                                   
C                                                                       
      DO 149 I = 1, 3, 2                                                
      IF ( IZS(I) .EQ. NOTDEF .OR. IZS(I+1) .EQ. NOTDEF)  GO TO 140     
      ISGNZX = (IZS(I)-IZS(I+1)) * (2-I)                                
      IF ( IZS(5) .EQ. NOTDEF ) IZS(5) = IABS(ISGNZX)                   
 140  IF ( AMS(I) .EQ. UNDEF .OR. AMS(I+1) .EQ. UNDEF )  GO TO 149      
      SIGNMX = (AMS(I)-AMS(I+1)) * (2-I)                                
      IF ( AMS(5) .EQ. UNDEF ) AMS(5) = DABS(SIGNMX)                    
 149  CONTINUE                                                          
      IF ( DABS(SIGNMX) .LT. .3 ) SIGNMX = 0                            
C                                                                       
C     NOW SUPPLY MISSING MASS OR Z VALUES IF POSSIBLE                   
C                                                                       
      DO 189 I = 1, 4                                                   
C     I, I2, AND 5 (=X)  MAKE A TRIPLE.                                 
      I2 = I-1 + 2*MOD(I, 2)                                            
      KSIGN = IABS(5-2*I) - 2                                           
      IF ( ISGNZX .EQ. NOTDEF ) GO TO 180                               
      IF ( IZS(I) .NE. NOTDEF ) GO TO 180                               
      IF ( IZS(I2) .EQ. NOTDEF ) GO TO 180                              
      IZS(I) = IZS(I2) + KSIGN*ISGNZX                                   
 180  IF ( SIGNMX .EQ. UNDEF ) GO TO 189                                
      IF ( AMS(I) .NE. UNDEF ) GO TO 189                                
      IF ( AMS(I2) .EQ. UNDEF ) GO TO 189                               
      AMS(I) = AMS(I2) + KSIGN*SIGNMX                                   
 189  CONTINUE                                                          
C                                                                       
C     IF REQUESTED CONVERT ATOMIC NUMBERS TO TRUE MASSES FOR ALL USES   
C                                                                       
      IF ( MASTYP .NE. 2 ) GO TO 220                                    
      DO 199 I = 1, 5                                                   
      IF ( AMXCS(I) .EQ. UNDEF ) GO TO 199                              
      M = AMS(I)                                                        
      IF ( AMS(I) .NE. M ) GO TO 199                                    
      AMS(I) = AMS(I) + AMXCS(I)/AMUMEV                                 
 199  CONTINUE                                                          
C                                                                       
C     WE HAVE DONE THE MOST WE CAN DO TO DEFINE THE M'S AND Z'S (1-5).  
C     NOW PUSH ON AND DEFINE THE P AND T IF NECESSARY.                  
C                                                                       
C     FIRST WE DETERMIN WHICH IS P AND T                                
C                                                                       
C     WE SET:                                                           
C     IP - LABELS THE PROJECTILE (1, 2, OR 5)                           
C     IT - LABELS THE TARGET (1-4)                                      
C     IBND - FOR BOUND STATES LABELS THE COMPOSITE (1-4).               
C            NOTE THAT THE PROJECTILE BOUND STATE (ICHAN=1) MAY BE      
C            EITHER 1 OR 2 (STRIPING OR PICKUP) AND SIMILARLY THE       
C            TARGET (ICHAN=2) MAY BE EITHER 4 OR 3.                     
C     THE ARRAYS LABELED BY IP, IT AND IBND ARE IN THE ORDER            
C       A, B, BIGA, BIGB, X                                             
C                                                                       
C     ISTRIP IS SET TO +1 FOR STRIPPING; -1 FOR PICKUP; 0 FOR           
C     INELASTIC SCATTERING.                                             
C     IT IS ALSO USED BY BOUND WHEN COMPUTING Q.                        
C                                                                       
 220  ISTRIP = NOTDEF                                                   
      IF ( ISGNZX .NE. NOTDEF ) ISTRIP = ISGNZX                         
      IF ( SIGNMX .NE. UNDEF ) ISTRIP = SIGNMX                          
      IF ( ISTRIP .EQ. NOTDEF ) WRITE(6,223)
 223  FORMAT ('0***** WARNING:  NOT ENOUGH DATA TO DETERMIN IF',  ' REAC
     *TION IS STRIPPING OR PICKUP - STRIPPING ASSUMED.')                
      IF ( ISTRIP .EQ. NOTDEF ) ISTRIP = 1                              
      IF ( ISTRIP .NE. 0 ) ISTRIP = ISIGN( 1, ISTRIP )                  
C                                                                       
      IF ( ICHAN .GE. 3 ) GO TO 250                                     
C                                                                       
C     BOUND STATE,  PROJECTILE IS ALWAYS X.                             
C                                                                       
      IP = 5                                                            
      IF ( ISTRIP .LT. 0 ) GO TO 240                                    
      IT = ICHAN + 1                                                    
      IBND = IT + 2*ICHAN-3                                             
      GO TO 280                                                         
 240  IBND = ICHAN + 1                                                  
      IT = IBND + 2*ICHAN-3                                             
      GO TO 280                                                         
C                                                                       
C     SCATTERING STATES - NO COMPOSITE                                  
C                                                                       
 250  IBND = 0                                                          
      IP = ICHAN-2                                                      
      IT = IP + 2                                                       
C                                                                       

C     NOW DEFINE UNDEFINED P AND T STUFF                                
C                                                                       
 280  IF ( IZP .EQ. NOTDEF ) IZP = IZS(IP)                              
      IF ( IZT .EQ. NOTDEF ) IZT = IZS(IT)                              
      IF ( AMP .EQ. UNDEF ) AMP = AMS(IP)                               
      IF ( AMT .EQ. UNDEF ) AMT = AMS(IT)                               
      IF ( JSP .EQ. NOTDEF ) JSP = JS(IP)                               
      IF ( JST .EQ. NOTDEF ) JST = JS(IT)                               
C                                                                       
C     COPY E* FOR P AND T.  THESE WILL BE UUSED BY WAVSET TO DETERMIN   
C     IF THE PARTICLES ARE IDENTICAL                                    
C                                                                       
      IF ( EXSPT(1) .EQ. UNDEF ) EXSPT(1) = EXS(IP)                     
      IF ( EXSPT(2) .EQ. UNDEF ) EXSPT(2) = EXS(IT)                     
      IF ( AMXGPT(1) .EQ. UNDEF ) AMXGPT(1) = AMXCGS(IP)                
      IF ( AMXGPT(2) .EQ. UNDEF ) AMXGPT(2) = AMXCGS(IT)                
      IF ( PARIPT(1) .EQ. 0 ) PARIPT(1) = PARITS(IP)                    
      IF ( PARIPT(2) .EQ. 0 ) PARIPT(2) = PARITS(IT)                    
      LSPCPT(2) = LSPECS(IT)                                            
      NODEPT(2) = NODESP(IT)                                            
C                                                                       
C     FOR SCATTERING ALLOW RANGES OF  L, JP, AND J.                     
C                                                                       
      IF ( IBND .EQ. 0 ) GO TO 310                                      
C                                                                       
C     FOLLOWING PAGE OR SO IS FOR BOUND STATES ONLY.                    
C                                                                       
      IF ( J .EQ. NOTDEF ) J = JS(IBND)                                 
      IF ( PARITY .EQ. 0 ) PARITY = PARITS(IBND)                        
      IF ( L .EQ. NOTDEF ) L = LSPECS(IBND)                             
      IF ( NODES .EQ. NOTDEF ) NODES = NODESP(IBND)                     
C                                                                       
C     WE HAVE PULLED EVERYTING OUT OF 1-5 THAT WE WILL                  
C                                                                       
C     THE FOLLOWING CODE IS ALSO USED WHEN NOT DOING A DWBA             
C                                                                       
C                                                                       
C     TO ALLOW FOR HOLE STATES, WE ACCEPT LEVEL DESCRIPTORS OF          
C     THE TARGET AS LEVEL DESCRIPTORS OF THE COMPOSITE.  LEVEL          
C     DESCRIPTORS OF THE PROJECTILE ARE IGNORED.  NO CHECK IS MADE      
C     FOR MULTIPLE LEVEL DESCRIPTORS -- THE COMPOSITE ALWAYS WINS.      
C                                                                       
 300  IF ( L .EQ. NOTDEF ) L = LSPCPT(2)                                
      IF ( NODES .EQ. NOTDEF ) NODES = NODEPT(2)                        
C                                                                       
C     IF SOME ANGULAR MOMENTA ARE ZERO THEN WE CAN DEFINE OTHERS        
C                                                                       
      IF ( JP .EQ. NOTDEF .AND. JST .EQ. 0 ) JP = J                     
      IF ( JP .EQ. NOTDEF .AND. J .EQ. 0 ) JP = JST                     
      IF ( JP .EQ. NOTDEF .AND. L .EQ. 0 ) JP = JSP                     
      IF ( JP .EQ. NOTDEF .AND. JSP .EQ. 0 .AND. L .NE. NOTDEF ) JP = 2*
     *L                                                                 
      IF ( J .EQ. NOTDEF .AND. JST .EQ. 0 ) J = JP                      
      IF ( L .NE. NOTDEF ) GO TO 305                                    
      IF ( JP .NE. NOTDEF .AND. JSP .EQ. 0 ) L = JP/2                   
      IF ( JSP .NE. NOTDEF .AND. JP .EQ. 0 ) L = JSP/2                  
C                                                                       
C     IF THERE ARE ONLY TWO POSSIBLE L'S, THEN PARITY CAN TELL          
C     US WHAT TO DO.                                                    
C                                                                       
      IF ( L .NE. NOTDEF ) GO TO 305                                    
      I = PARITY*PARIPT(1)*PARIPT(2)                                    
      IF ( I .EQ. 0 ) GO TO 310                                         
      I = (I+3)/2                                                       
      IF ( JP .EQ. NOTDEF .OR. JSP .EQ. NOTDEF ) GO TO 310              
      L1 = IABS(JP-JSP)/2                                               
      L1 = L1 + MOD( I+L1, 2 )                                          
      L2 = (JP+JSP)/2                                                   
      IF ( L2-L1 .GT. 1 ) GO TO 310                                     
      L = L1                                                            
C                                                                       
C     L IS DEFINED; WE MAY BE ABLE TO PATCH UP A PARITY                 
C                                                                       
 305  I = +1                                                            
      IF ( MOD( L, 2 ) .NE. 0 ) I = -1                                  
      IF ( PARITY .EQ. 0 ) PARITY = PARIPT(1)*PARIPT(2)*I               
      IF ( PARIPT(1) .EQ. 0 ) PARIPT(1) = I*PARITY*PARIPT(2)            
      IF ( PARIPT(2) .EQ. 0 ) PARIPT(2) = I*PARITY*PARIPT(1)            
C                                                                       
C     FOLLOWING IS FOR BOTH SCATTERING AND BOUND STATES                 
C                                                                       
C                                                                       
C     SETUP KINEMATIC PROJECTILE AND TARGET MASES                       
C                                                                       
C     1)  TOTAL MASS EXCESS IN AMU                                      
C                                                                       
 310  AMXCP = 0                                                         
      IF ( AMXGPT(1) .NE. UNDEF )  AMXCP = (AMXGPT(1)+EXSPT(1))/AMUMEV  
      AMXCT = 0                                                         
      IF ( AMXGPT(2) .NE. UNDEF )  AMXCT = (AMXGPT(2)+EXSPT(2))/AMUMEV  
C                                                                       
C     MP AND MT MUST BE SEPARATELY DEFINED                              
C                                                                       
      IF ( AMP .NE. UNDEF .AND. AMT .NE. UNDEF ) GO TO 330              
      WRITE(6,323)
 323  FORMAT ( '0**** ERROR:  BOTH MP AND MT ARE REQUIRED.')            
      IRET = 0                                                          
      GO TO 400                                                         
C                                                                       
C     2)  IF NECESSARY CONVERT TO FLOATING MASS                         
C                                                                       
 330  IF ( MASTYP .NE. 2 ) GO TO 340                                    
      M = AMP                                                           
      IF ( M .EQ. AMP ) AMP = AMP + AMXCP - IZP*(EMASS/AMUMEV)          
      M = AMT                                                           
      IF ( M .EQ. AMT ) AMT = AMT + AMXCT - IZT*(EMASS/AMUMEV)          
C                                                                       
C     3)  NOW THE KINEMATIC MASSES IN TMP, TMT                          
C                                                                       
 340  TMP = AMP                                                         
      TMT = AMT                                                         
      IF ( MASTYP .NE. 0 ) GO TO 370                                    
      M = TMP                                                           
      IF ( M .EQ. TMP ) TMP = TMP + AMXCP - IZP*(EMASS/AMUMEV)          
      M = TMT                                                           
      IF ( M .EQ. TMT ) TMT = TMT + AMXCT - IZT*(EMASS/AMUMEV)          
C                                                                       
C     DEFINE THE REDUCED MASS IF NECESSARY                              
C                                                                       
 370  IF ( AM .NE. UNDEF ) GO TO 380                                    
      AM = AMUMEV * TMP*TMT/(TMP+TMT)                                   
C                                                                       
C     FIND ELAB TO ECM CONVERSION                                       
C                                                                       
 380  RATMAS = TMP/TMT                                                  
      CMLAB = 1 + RATMAS                                                
C                                                                       
C     FIND E IF NECESSARY                                               
C                                                                       
C     IN THE CASE OF ELASTIC SCATTERING, ELAB OR ECM ALWAYS             
C     DOMINATES E.                                                      
C                                                                       
 400  IF ( ICHAN .GE. 6 ) GO TO 450                                     
      IF ( E .NE. UNDEF ) GO TO 500                                     
      GO TO ( 410, 410, 450, 480, 430, 450 ), ICHAN                     
C                                                                       
C     BOUND STATE; FIRST TRY Q AND THEN MASS EXCESS                     
 410  IF ( Q .EQ. UNDEF .OR. EBNDS(3-ICHAN) .EQ. UNDEF )  GO TO 420     
C     REMEMBER THAT THE PROJECTILE BOUND STATE MAY BE EITHER            
C     INCOMING OR OUTGOING.                                             
      E = (3-2*ICHAN) * ISTRIP * Q + EBNDS(3-ICHAN)                     
      GO TO 500                                                         
 420  IF ( AMXCS(IP) .EQ. UNDEF .OR. AMXCS(IT) .EQ. UNDEF  .OR. AMXCS(IB
     *ND) .EQ. UNDEF ) GO TO 430                                        
      E = AMXCS(IBND) - AMXCS(IP) - AMXCS(IT)                           
      GO TO 500                                                         
 430  WRITE(6,433)
 433  FORMAT ( '0**** E MUST BE DEFINED.')                              
      IRET = 0                                                          
      GO TO 500                                                         
C                                                                       
C     INCOMING SCATTERING STATE; ECM OR ELAB APPLIES.                   
C     THIS IS ALSO USED FOR STAND ALONE SCATTERING                      
C     IF BOTH ELAB AND ECM ARE DEFINED; ELAB WINS                       
C                                                                       
 450  IF ( ECM .NE. UNDEF ) E = ECM                                     
      IF ( ELAB .EQ. UNDEF ) GO TO 465                                  
      E = ELAB/CMLAB                                                    
      GO TO 500                                                         
 465  IF ( E .NE. UNDEF ) GO TO 500                                     
      WRITE(6,468)
 468  FORMAT ('0**** E, ECM OR ELAB MUST BE DEFINED.')                  
      IRET = 0                                                          
      GO TO 500                                                         
C                                                                       
C     OUTGOING SCATTERING STATE;  APPLY Q TO ECM                        
C                                                                       
 480  IF ( ECM .EQ. UNDEF ) GO TO 430                                   
      IF ( Q .NE. UNDEF ) GO TO 495                                     
C                                                                       
C     ATTEMPT TO GET Q FROM TOTAL MASS EXCESSES                         
C     THIS WILL BE THE USUAL METHOD FOR INELASTIC SCATTERING            
C                                                                       
      DO 484 I = 1, 4                                                   
      IF ( AMXCS(I) .EQ. UNDEF ) GO TO 430                              
 484  CONTINUE                                                          
      Q = AMXCS(1) - AMXCS(2) + AMXCS(3) - AMXCS(4)                     
 495  E = ECM + Q                                                       
      GO TO 500                                                         
C                                                                       
C     AT LAST E IS DEFINED.  FOR INCOMING WAVE DEFINE ECM, ELAB         
C                                                                       
 500  IF ( ICHAN .NE. 3 .AND. ICHAN .NE. 6 ) GO TO 550                  
      ECM = E                                                           
      WASSET(16) = ELAB .EQ. UNDEF .AND. ICHAN .EQ. 6                   
      ELAB = E*CMLAB                                                    
C                                                                       
C     FOR OUTGOING CHANNEL, DEFINE Q                                    
C                                                                       
 550  IF ( ICHAN .NE. 4 ) GO TO 600                                     
      IF ( ECM .NE. UNDEF ) Q = E - ECM                                 
C                                                                       
C     NOW STORE THE P AND T STUFF BACK INTO THE 1-5 STUFF               
C                                                                       
 600  IF ( ICHAN .GT. 4 ) GO TO 700                                     
      AMS(IP) = AMP                                                     
      AMS(IT) = AMT                                                     
      IZS(IP) = IZP                                                     
      IZS(IT) = IZT                                                     
      JS(IP) = JSP                                                      
      JS(IT) = JST                                                      
      PARITS(IP) = PARIPT(1)                                            
      PARITS(IT) = PARIPT(2)                                            
      IF ( IBND .NE. 0 ) JS(IBND) = J                                   
      IF ( IBND .NE. 0 ) PARITS(IBND) = PARITY                          
      IF ( SPAM .EQ. UNDEF ) GO TO 700                                  
      IF ( ICHAN .EQ. 1 ) SPAMP = SPAM                                  
      IF ( ICHAN .EQ. 2 ) SPAMT = SPAM                                  
C                                                                       
 700  WASSET(12) = JPOLD .NE. JP                                        
      WASSET(13) = JOLD .NE. J                                          
      WASSET(14) = LOLD .NE. L                                          
      WASSET(29) = PARITY .NE. IPOLD                                    
C                                                                       
C     SET ASYMPTOPIA IF NEEDED                                          
C                                                                       
      IF ( ASYMPT .NE. UNDEF ) GO TO 750                                
      WASSET(15) = .TRUE.                                               
      ASYMPT = BNDASY                                                   
      IF ( IBND .EQ. 0 ) ASYMPT = SCTASY                                
C                                                                       
 750  RETURN                                                            
      END                                                               

