      SUBROUTINE DERCHK (NPARA,NPTS,STEP,PARAM,FS,FGRAD,TGRAD,FSAVE)
C                                                                       
C     NUMERICALLY CHECKS THE GRADIENT COMPUTATION                       
C                                                                       
C     10/29/75 - FIRST VERSION - S.P.                                   
C     1/29/76 - STEP IS INPUT                                           
C     4/22/77 - FIX DIVIDE BY 0                                         
C     11/20/77 - NEW SETFIT CALL - S.P.                                 
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL PARAM,FS,FGRAD,TGRAD,FSAVE                          
C                                                                       
      DIMENSION PARAM(NPARA), FS(NPTS), FGRAD(NPTS,NPARA),  TGRAD(NPARA)
     *, FSAVE(NPTS)                                                     
C                                                                       
C     GET F(PARAM) AND THE ANALYTIC GRADIENT                            
C                                                                       
      CALL CALGRA ( NPTS, NPARA, FS, PARAM, FGRAD, TGRAD )              
C                                                                       
      DO 89 N = 1, NPTS                                                 
      FSAVE(N) = FS(N)                                                  
 89   CONTINUE                                                          
C
C     NOW NUMERICALLY COMPUTE THEM,
C     DO IT FOR EACH PARAMETER 
C
      DO 589 IP = 1, NPARA                                              
      PSAVE = PARAM(IP)                                                 
      STEPP = STEP*PSAVE                                                
      PARAM(IP) = PARAM(IP) + STEPP                                     
C                                                                       
      CALL CALFUN ( NPTS, NPARA, FS, PARAM )                            
      RMS = 0                                                           
      T = 0                                                             
      F = 0                                                             
      WRITE(6,203) IP, PSAVE, STEPP                                       
 203  FORMAT ( ' PARAMETER', I2, ' =', G25.15, 5X,'STEP =', G15.5 / 
     *' POINT     VALUE',T30,'ANALYTIC',T55,'NUMERIC',T75,'REL. DIF.'/)
C                                                                       
      DO 299 N = 1, NPTS                                                
      DFDP = (FS(N)-FSAVE(N))/STEPP                                     
      F = F + FSAVE(N)                                                  
      T = T + 2*FSAVE(N)*DFDP                                           
      REL = 0                                                           
      IF ( DFDP .NE. 0 ) REL = (DFDP-FGRAD(N,IP))/DFDP                  
      RMS = RMS + REL**2                                                
      WRITE(6,233) N, FSAVE(N), FGRAD(N,IP), DFDP, REL                    
 233  FORMAT ( I5, G15.5, 2G25.15, G15.5 )                              
 299  CONTINUE                                                          
      RMS = DSQRT(RMS/NPTS)                                             
      REL = 0                                                           
      IF ( T .NE. 0 ) REL = (T-TGRAD(IP))/T                             
      WRITE(6,303) F, TGRAD(IP), T, REL, RMS                              
 303  FORMAT ( ' TOTAL', G14.5, 2G25.15, G15.5 /  ' RMS ERROR IN GRAD(FS
     *) =', G15.5 )                                                     
C                                                                       
      PARAM(IP) = PSAVE                                                 
 589  CONTINUE                                                          
C                                                                       
C     RESTORE COMMON BLOCKS TO UNMODIFIED FORM                          
C                                                                       
      CALL SETFIT ( PARAM, IRET, 0 )                                    
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE DRIVE ( RHSR, RHSI, I5, I6, NFIRST, ITR, MBASCP,  BASCU
     *P, RBASCP, NUCH, COULH, NPTIN, NPTSAV, INHR, INHI, FLP,  VMULT )  
C                                                                       
C     CONTRUCT DRIVING TERM OF INHOMOGENEOUS EQUATION                   
C                                                                       
C     FIRST VERSION 12/2/80 MRB                                         
C     4/17/80 - REMOVE ALLOCS - S.P.                                    
C     4/19/80 - ALL ARITHMATIC IN REAL*4; COMBINED COULOMB AND NUC - S.P
C     4/27/80 - NPTSAV DIMENSION FOR INHR, INHI - S.P.                  
C     5/3/80 - FAKE REAL*4 RHS TO SAVE REAL8-REAL4 CONVERSION S.P.      
C     6/2/80 - PASS NUMPT AS NPTIN FOR CDC COMPATIBILITY - S.P.         
C     7/2/80 - FIX 4/19/80 BLUNDER FOR ODD PARITY - S.P.                
C     7/28/80 - ALLOW ZEROING LOOP TO VECTORIZE ON CRAY - S.P.          
C     3/15/82 - TEMPORARY REAL8 VERSION                                 
C     3/15/82 - ADD SCALING OF THE COUPLING - S.P.                      
C     4/10/82 - BACK TO REAL*4 - S.P.                                   
C                                                                       
C     IN THIS VERSION WE WILL NOT ASSUME NUCLEAR TRANSITION
C     POTENTIAL IS INDEPENDENT OF MULTIPOLE; HENCE VALID FOR
C     MORE GENERAL PROBLEMS                                             
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      REAL*8 RHSR(1),RHSI(1)                                            
CIB      REAL*4  RHSR(2,1), RHSI(2,1)                                   
C                                                                       
      INTEGER BASCUP(MBASCP, 1)                                         
      REAL*4 RBASCP(MBASCP, 1), NUCH(2, NPTIN, 1), COULH(NPTIN, 1)      
      REAL*4 INHR(NPTSAV, 1), INHI(NPTSAV, 1)                           
C                                                                       
      REAL*4 XN, XC, XKF, FAC, XCBYXN, TERM                             
C                                                                       
      COMMON /GRIDCM/ RCUEFF, GRDCM1(2), IBINDX, MBINDX, NBINDX, NMFFAC,
     * MXLXGS, NMBFAC, IINHR, IINHI, IRHSR, IRHSI, INUCH, ICOULH, ILOR, 
     *ILOI, ILIR, ILII, NPTMIN, NOFLO, NUMPT, NCRIT, ISMX, ISMSQ, IPADE,
     * IHOMO, ISMTSV, IRPTS4, IRPTS, IGRDC4(5), IDW, IGRDC5(2), IABS1, I
     *GRDC6(2), GRDCM2, IGRDC7(2), IRWTS, IGRDC8(2), ICL1FF, ICL1FG, ICL
     *1GF, ICL1GG                                                       
C                                                                       
      ISTRT=NFIRST-1                                                    
      IFLOP = 0                                                         
C                                                                       
C     MAKE SURE RHS EQUALS ZERO                                         
C                                                                       
      NPSTRT = NPTMIN+1                                                 
      NDO2 = NUMPT - IAND(NUMPT-NPTMIN,3)                               
      DO 10 I = NPSTRT, NDO2, 4                                         
CRA      DO 10  I = NPSTRT, NUMPT                                       
      RHSR(I)=0.                                                        
      RHSI(I)=0.                                                        
      RHSR(I+1)=0.                                                      
      RHSI(I+1)=0.                                                      
      RHSR(I+2)=0.                                                      
      RHSI(I+2)=0.                                                      
      RHSR(I+3)=0.                                                      
      RHSI(I+3)=0.                                                      
 10   CONTINUE                                                          
      IF ( NDO2 .EQ. NUMPT ) GO TO 50                                   
      NDO2 = NDO2+1                                                     
      DO 19 I = NDO2, NUMPT                                             
      RHSR(I) = 0.                                                      
      RHSI(I) = 0.                                                      
 19   CONTINUE                                                          
C                                                                       
C     LOOP OVER ALL POSSIBLE RHS COMPONENTS AND SELECT                  
C     APPROPIATE F ACTORS AND POINTERS                                  
C                                                                       
 50   DO 999 I7=I5,I6                                                   
      IPTWF = BASCUP(2,I7)                                              
C                                                                       
C                                                                       
      XN=RBASCP(5,I7)                                                   
      XC=RBASCP(6,I7)                                                   
      ITRI=BASCUP(7,I7)                                                 
      ITRAB=IABS(ITRI)                                                  
      XKF=RBASCP(8,I7)                                                  
      IF ( XKF .EQ. 0 ) GO TO 999                                       
      IPTN= BASCUP(10,I7)                                               
C                                                                       
C     IPTN IS STORED AS 1,3, 5  FOR THE 1ST, 2ND, 3RD, ...              
C     RADIAL WAVEFUNCTION.  HERE SET IT TO WHAT IT SHOULD BE            
C                                                                       
      IPTN = (IPTN+1)/2                                                 
      IPTC= BASCUP(11,I7)                                               
C                                                                       
C     FACTOR OF 12 CORRECTS SIMPLIFIED NUMEROV ALGORITHUM               
C     DONT NEED FACTOR OF 12 FOR INITIAL GUESS ELASTIC WAVEFUNCTION     
C                                                                       
      FAC = XKF*VMULT                                                   
      IF ( ITRI .LT. 0 ) FAC = -FAC                                     
      IF ( ITR .NE. 1 .OR. IPTWF .NE. 1 ) FAC = FAC/12.                 
      XN = FAC*XN                                                       
      XC = FAC*XC                                                       
C                                                                       
      IF(ITRAB.GT.1)GO TO 500                                           
C                                                                       
C     THIS SECTION FOR REAL TIME REVERSAL INVARIANCE                    
C     CALCULATE PRODUCT OF W.F. AND NUCLEAR POTENTIAL                   
C                                                                       
      IF(XN.EQ.0)GO TO 200                                              
      IF ( XC .NE. 0 ) GO TO 150                                        
C                                                                       
C     HERE WE ONLY HAVE THE A NUCLEAR POTENTIAL                         
C                                                                       
      IFLOP = IFLOP + 10                                                
      DO 139 I=ISTRT,NUMPT                                              
      RHSR(I)=(NUCH(1,I,IPTN)*INHR(I,IPTWF)  -NUCH(2,I,IPTN)*INHI(I,IPTW
     *F))*XN+RHSR(I)                                                    
      RHSI(I)=(NUCH(1,I,IPTN)*INHI(I,IPTWF)  +NUCH(2,I,IPTN)*INHR(I,IPTW
     *F))*XN+RHSI(I)                                                    
 139  CONTINUE                                                          
      GO TO 999                                                         
C                                                                       
C     HERE WE HAVE BOTH THE COULOMB AND NUCLEAR POTENTIAL               
C                                                                       
 150  IFLOP = IFLOP+12                                                  
      XCBYXN = XC/XN                                                    
      DO 169 I = ISTRT, NUMPT                                           
      TERM = NUCH(1,I,IPTN) + XCBYXN*COULH(I,IPTC)                      
      RHSR(I) = RHSR(I) + XN*( TERM*INHR(I,IPTWF)  - NUCH(2,I,IPTN)*INHI
     *(I,IPTWF) )                                                       
      RHSI(I) = RHSI(I) + XN*( TERM*INHI(I,IPTWF)  + NUCH(2,I,IPTN)*INHR
     *(I,IPTWF) )                                                       
 169  CONTINUE                                                          
      GO TO 999                                                         
C                                                                       
C     HERE ONLY A COULOMB POTENTIAL                                     
C                                                                       
200   IF(XC.EQ.0)GO TO 999                                              
      IFLOP = IFLOP + 5                                                 
      DO 249 I=ISTRT,NUMPT                                              
      RHSR(I) = RHSR(I) + (XC*COULH(I,IPTC))*INHR(I,IPTWF)              
      RHSI(I) = RHSI(I) + (XC*COULH(I,IPTC))*INHI(I,IPTWF)              
249   CONTINUE                                                          
      GO TO 999                                                         
C                                                                       
C     THIS SECTION FOR IMAGINARY TIME REVERSAL INVARIENCE               
C     CALCULATE PRODUCT OF W.F. AND NUCLEAR POTENTIAL                   
C                                                                       
 500  IF(XN.EQ.0)GO TO 600                                              
      IF ( XC .NE. 0 ) GO TO 550                                        
C                                                                       
C     HERE JUST A NUCLEAR FORCE                                         
C                                                                       
      IFLOP = IFLOP + 10                                                
      DO 539 I=ISTRT,NUMPT                                              
      RHSR(I)=-(NUCH(1,I,IPTN)*INHI(I,IPTWF)  +NUCH(2,I,IPTN)*INHR(I,IPT
     *WF))*XN+RHSR(I)                                                   
      RHSI(I)=(NUCH(1,I,IPTN)*INHR(I,IPTWF)  -NUCH(2,I,IPTN)*INHI(I,IPTW
     *F))*XN+RHSI(I)                                                    
539   CONTINUE                                                          
C                                                                       
      GO TO 999                                                         
C                                                                       
C     HERE WE HAVE BOTH COULOMB AND NUCLEAR POTENTIALS                  
C                                                                       
 550  IFLOP = IFLOP + 12                                                
      XCBYXN = XC/XN                                                    
      DO 569 I = ISTRT, NUMPT                                           
      TERM = NUCH(1,I,IPTN) + XCBYXN*COULH(I,IPTC)                      
      RHSR(I) = RHSR(I) - XN*( TERM*INHI(I,IPTWF)  + NUCH(2,I,IPTN)*INHR
     *(I,IPTWF) )                                                       
      RHSI(I) = RHSI(I) + XN*( TERM*INHR(I,IPTWF)  - NUCH(2,I,IPTN)*INHI
     *(I,IPTWF) )                                                       
 569  CONTINUE                                                          
      GO TO 999                                                         
C                                                                       
C     HERE ONLY A COULOMB POTENTIAL                                     
C                                                                       
600   IF(XC.EQ.0)GO TO 999                                              
      IFLOP = IFLOP + 5                                                 
      DO 649 I=ISTRT,NUMPT                                              
      RHSR(I) = RHSR(I) - (XC*COULH(I,IPTC))*INHI(I,IPTWF)              
      RHSI(I) = RHSI(I) + (XC*COULH(I,IPTC))*INHR(I,IPTWF)              
649   CONTINUE                                                          
999   CONTINUE                                                          
C                                                                       
      FLP = IFLOP*(NUMPT-NFIRST+1)                                      
      RETURN                                                            
      END                                                               
      SUBROUTINE DUMMY1                                                 
C                                                                       
C     USED TO FORCE COMMON BLOCKS INTO CORE AT RIGHT TIME.              
C                                                                       
C     6/19/75 - CALLS DUMMY2 TO GET /LOGFAC/                            
C                                                                       
      CALL DUMMY2                                                       
      RETURN                                                            
      END                                                               
C---------------------------------------------------------------------
      SUBROUTINE ELDCS ( UK,ETA,ANGMIN,ANGMAX,ANGSTP,LMN,LMX,LSKP, 
     * ISTAT,JSP,ISMAT,ITOC,NSPL,ISIG,ELAB,TAU,PRNTSW,ITORUT, 
     * RUTNAM,FKEPSW,IFEL,FNAME,SIGREA,IRUTH,RUTHNM )           
C                                                                       
C     CALCULATES DIFFERENTIAL CROSS SECTIONS FOR ELASTIC SCATTERING     
C     FOR THE FOLLOWING CASES:                                          
C     1)  NON-IDENTICAL PARTICLES WITH NO SPIN DEPENDENCE IN THE FORCE  
C     2)  IDENTICAL PARTICLES OF ARBITRARY SPIN WITH NO SPIN            
C         DEPENDENCE IN THE FORCE.                                      
C     3)  NON-IDENTICAL PARTICLES OF ARBITRARY SPIN, WITH SPIN-ORBIT    
C         AND/OR TENSOR FORCES INVOLVING THE PROJECTILE SPIN ONLY       
C         (I.E. INDEPENDENT OF TARGET SPIN).                            
C     ATTEMPTING TO MIX CASES 2 AND 3  WILL RESULT IN GARBAGE.          
C                                                                       
C     ARGUMENTS (INPUT UNLESS MARKED 'RETURNED'):                       
C                                                                       
C     UK = WAVE NUMBER (FM**-1).                                        
C     ETA = COULOMB PARAMETER.                                          
C     ANGMIN, ANGMAX, ANGSTEP = MINIMUM, MAXIMUM, STEP IN ANGLE         
C        (DEGREES).                                                     
C     LMN, LMX = MINIMUM, MAXIMUM LI.                                   
C     LSKP = ANGLE STEP = 2 FOR IDENTICAL SPIN-0 PARTICLES, 1 OTHERWISE.
C     ISTAT = 1 FOR IDENTICAL BOSONS, 2 FOR IDENTICAL FERMIONS,         
C        3 IF NOT IDENTICAL.                                            
C     JSP = 2 * PROJECTILE SPIN.                                        
C     ISMAT = NALLOC TO THE S-MATRIX.                                   
C     ITOC = NALLOC TO THE TABLE OF CONTENTS FOR S.                     
C     NSPL = NUMBER OF JT, JP, LX, LO COMBINATIONS PER LI.              
C     ISIG = NALLOC TO COULOMB PHASES.                                  
C     ELAB = LAB ENERGY (MEV).                                          
C     TAU = MASS RATIO (PROJECTILE/TARGET).                             
C     PRNTSW = .TRUE. IF CROSS SECTIONS ARE TO BE PRINTED.              
C     ITORUT = NALLOC TO CROSS SECTIONS/RUTHERFORD (RETURNED).          
C     RUTNAM = NAME TO BE ASSIGNED TO ARRAY ABOVE.                      
C     FKEPSW = .TRUE. IF AMPLITUDES F ARE TO BE SAVED.                  
C     IFEL = NALLOC TO SAVED F (RETURNED).                              
C     FNAME = NAME TO BE ASSIGNED TO F ARRAY.                           
C     SIGREA = TOTAL REACTION CROSS SECTION (MB) (RETURNED).            
C                                                                       
C     THIS FIRST VERSION 8/15/73 D.GLOECKNER                            
C     SMALL CHANGES 9/22/75                                             
C     10/7/75 - STORE CROSS SECTIONS - S.P.                             
C     10/14/75 - PRINT ERRORS; NICE PRINTOUT                            
C     6/7/76 - LAB ANGLES                                               
C     1/3/77 - FIX BUG FOR SPIN-ORBIT FORCE.                            
C     1/26/77 - LAB ANGLES                                              
C     2/10/77 - REMOVE ARRAYS FROM ARG. LIST                            
C     4/24/77 - IDENTICAL PARTICLES                                     
C     5/7/77 - REMOVE C COEFS; PRNTSW; VARIABLE NAMES; TOTAL REACT      
C     10/22/77 - FIX ERROR IN 180 DEGREE CROSS SECTIONS.                
C     5/12/79 - STORE ANGLE-INDEPENDENT STUFF IN ARRAYS - S.P.          
C     9/3/79 - STANDARD PREFIXES; ARBITRARY PROJECTILE SPIN WITH        
C        S.O., TENSOR FORCES - RPG                                      
C     1/31/80 - CHARACTER*8 FNAME, RUTNAM - RPG                         
C     7/28/80 - PASS NEW WORK ARRAYS TO AMPCAL - S.P.                   
C     8/1/80 - CALL SETLOG - S.P.                                       
C     9/17/81 - CHANGED AMPCAL CALL; SAVE RUTHERFORD - S.P.             
C     10/27/81 - AMPCAL CHANGED AGAIN FOR SYM INDICATOR - S.P.          
C     3/9/82 - FIX BUGS SAVING CROSSSECT - 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) )                                                          
      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, XNUMANG
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
C                                                                       
      LOGICAL PRNTSW, PBETSW, IDNTSW, FKEPSW                            
      CHARACTER*8 RUTNAM, FNAME                                         
C                                                                       
      DIMENSION FCOUL(2,3), ALOWFC(2,2)                                 
	DIMENSION DUMMY(1)
	DUM=0.0
	DUMMY(1)=0.0
      PBETSW = MOD( IPRINT, 10 ) .GE. 4                                 
C                                                                       
C     PRINT HEADER                                                      
C                                                                       
      IF (PRNTSW) WRITE(6, 13) REACT, ELAB, HEADER                      
 13   FORMAT(X,T48,'P T O L E M Y' /  1X, 45A1, F8.2, ' MEV', 5X, 65A1
     * /  '     ANGLE', T21, 'SIGMA/', T40, 'SIGMA', T59, 'RUTHERFORD', 
     * T78, '% PER', T87, '% PER' /  '  C.M.    LAB     RUTHERFORD', T34
     *, 'C.M.', T47, 'LAB',  T62, 'C.M.', T78, 'LOW L', T86, 'HIGH L' / 
     *)                                                                 
CK      OPEN(UNIT=7,FILE='ELSIG.PLT',STATUS='NEW',CARRIAGECONTROL='LIST')
      OPEN(UNIT=7,FILE='ELSIG.PLT',STATUS='UNKNOWN',FORM='FORMATTED')
C
      ANMIN = ANGMIN
      ANMAX = ANGMAX
      ANGBAR = 1.D30
      TABAR = 180
C                                                                       
C     FOR LAB ANGLES WE HAVE FUNNY STUFF IF TAU > 1                     
C                                                                       
      IF ( LABANG .EQ. 0 ) GO TO 50                                     
      IF ( TAU .LE. 1 ) GO TO 50                                        
C                                                                       
C     OUR CONVENTION IS THAT NEGATIVE VALUES FOR ANGLEMIN OR ANGLEMAX   
C     CORRESPOND TO THE 2ND BRANCH.                                     
C                                                                       
      ANGBAR = RADIAN * ASIN(1/TAU)                                     
      ANGSTP = DABS(ANGSTP)                                             
      ABAR = ANGSTP * DINT( ANGBAR/ANGSTP + 1.D-10 )                    
      TABAR = 2*ABAR                                                    
      IF ( ABAR .LT. ANGBAR ) TABAR = TABAR + ANGSTP                    
      IF ( ANMIN .LT. 0 ) ANMIN = TABAR + ANMIN                         
      IF ( ANMAX .LE. 0 ) ANMAX = TABAR + ANMAX                         
C                                                                       
 50   ANMIN = DMAX1( ANMIN, 0.D0 )                                      
      ANMAX = DMIN1( ANMAX, TABAR )                                     
      ANGSTP = DSIGN( ANGSTP, ANMAX-ANMIN )                             
      XNUMANG = (ANMAX-ANMIN)/ANGSTP + 1.5
C                                                                       
C     MAKE A SPACE EVERY ONCE AND A WHILE.                              
C                                                                       
      ANGBLK = 52                                                       
      IF ( XNUMANG .LE. 50 ) GO TO 80
      ANGBLK = 10                                                       
      IF ( ANGSTP .GE. 1 ) GO TO 80                                     
      ANGBLK = 5                                                        
      IF ( ANGSTP .GE. .5 ) GO TO 80                                    
      ANGBLK = 1                                                        
 80   LINECT = 1                                                        
      NUMBLK = ANGBLK/ANGSTP + .5                                       
      LINEMX = 53                                                       
C                                                                       
      IF ( NSPL .EQ. 1 .OR. ISTAT .EQ. 3 ) GO TO 100                    
      WRITE(6,98)                                                           
 98   FORMAT ( '0**** CANNOT EVALUATE ELASTIC SCATTERING FOR ',  'IDENTI
     *CAL PARTICLES WITH S.O. FORCE' )                                  
      RETURN                                                            
C                                                                       
C     ALLOCATE SPACE FOR THETA-INDEPENDENT ARRAYS                       
C                                                                       
 100  LXMX = 0                                                          
      IF ( NSPL .GT. 1 ) LXMX = JSP                                     
      LDELMX = LXMX - MOD( LXMX, 2 )                                    
      NTEMPS = (LXMX+1)**2 * (LDELMX+1)                                 
      ITEMPS = NALLOC( NTEMPS, 'TEMPS   ' )                             
      IBETA = NALLOC( 2*NSPL*(LMX+1), 'BETAELAS' )                      
C                                                                       
      CALL SETLOG ( 2*(LMX+LXMX) )                                      
C                                                                       
C     CALCULATE "BETAELAS", THE ANGLE-INDEPENDENT PARTS OF F.           
C     ALSO CALCULATE TOTAL REACTION AND NUCLEAR CROSS SECTIONS.         
C                                                                       
      CALL BETCAL ( .TRUE., UK, JSP, NSPL, LMN, LMX, LSKP,  0, LXMX, LDE
     *LMX, NTEMPS, ISTAT, PBETSW,  SIGNUC, SIGREA,  ALLOC(Z(ITOC)), ALLO
     *C(Z(ISMAT)),DUM,DUM , ALLOC(Z(ISIG)),DUMMY, ALLOC(Z(IBETA)),DUMMY,
     *DUMMY, ALOWFC, ALLOC(Z(ITEMPS)) )
C                                                                       
C     RELEASE TEMPORARY ARRAY.                                          
C                                                                       
      Z(ITEMPS) = -Z(ITEMPS)                                            
C                                                                       
C     ALLOCATE SPACE FOR LEGENDRE FUNCTIONS, AMPLITUDES, CROSS SECTIONS.
C                                                                       
      ISPACE = LMX + 1 + ( (2*LMX+1-LXMX)*LXMX )/2                      
      IPLM = NALLOC( ISPACE, 'PLM     ' )                               
      ITMPCN = NALLOC( 2*(LMX+1), 'TMPCONTR' )                          
      IDNTSW = ISTAT .NE. 3                                             
      IDNPAR = 0                                                        
      IF ( IDNTSW ) IDNPAR = 2                                          
      NF = 2*NSPL                                                       
      IF ( IDNTSW ) NF = 6                                              
      IFTEMP = NALLOC( NF, 'FTEMP   ' )                                 
      IFLO = NALLOC( NF, 'FLO     ' )                                   
      IFHI = NALLOC( NF, 'FHI     ' )                                   
      IFERR = NALLOC( NF, 'FERROR ' )                                   
      IFEPSL = NALLOC( 2*LEBACK+1, 'FEPSILON' )                         
      IFEL = 0                                                          
      IF ( FKEPSW ) IFEL = NALLOC( NF*XNUMANG, FNAME )
      ICROSS = 0                                                        
      IF (PRNTSW) ICROSS = NALLOC( XNUMANG, 'CROSSSEC' )
      ITORUT = NALLOC( XNUMANG, RUTNAM )
      ILAB = 0                                                          
      IF (PRNTSW) ILAB = NALLOC( XNUMANG, 'LABCROSS' )
      IRUTH = NALLOC( XNUMANG, RUTHNM )
C                                                                       
C     ALLOCATIONS ARE DONE, GET THE BASE ADDRESSES.                     
C                                                                       
      LFTEMP = Z(IFTEMP) - 2                                            
      LFLO = Z(IFLO) - 2                                                
      LFHI = Z(IFHI) - 2                                                
      LFERR = Z(IFERR)-1                                                
      LTOC = Z(ITOC)*FACFR4 - FACFR4                                    
      LF = Z(IFEL) - NF - 1                                             
      LBETA = Z(IBETA)                                                  
      LPLM = Z(IPLM)                                                    
      LTMPCN = Z(ITMPCN)                                                
C                                                                       
      STATFC = 0                                                        
      IF ( ISTAT .LT. 3 ) STATFC = (ISTAT-1.50D0)*JSP/(JSP+1.D0)        
      LHI = LMX - 2 - MOD( LMX, LSKP )                                  
      SIGZRO = ALLOC(Z(ISIG))                                           
C                                                                       
C     LOOP OVER ALL ANGLES                                              
C                                                                       
      DO 489 NANG = 1, XNUMANG
C                                                                       
      ANGLE = ANMIN + (NANG-1)*ANGSTP                                   
C                                                                       
      IF ( LABANG .EQ. 0 ) GO TO 120                                    
      AN = DEGREE*ANGLE                                                 
      IF ( ANGLE .GT. ANGBAR ) AN = DEGREE*(TABAR-ANGLE)                
      TERM2 = 1 - (TAU*DSIN(AN))**2                                     
      IF ( TERM2 .LT. 0 ) TERM2 = 0                                     
      TERM2 = DCOS(AN)*DSQRT(TERM2)                                     
      IF ( ANGLE .GT. ANGBAR ) TERM2 = -TERM2                           
      ANGLE = RADIAN * ACOS( -TAU*(DSIN(AN))**2 + TERM2 )               
C                                                                       
 120  COSAN=DCOS(ANGLE*DEGREE)                                          
      ANGLAB = RADIAN*DATAN2( DSIN(ANGLE*DEGREE), COSAN+TAU )           
C                                                                       
      TERM2 = 1 + TAU*(TAU+2*COSAN)                                     
      TEMP = 1 + TAU*COSAN                                              
      AJACOB = 0                                                        
      IF ( TERM2 .LT. 0 ) TERM2 = 0                                     
      IF ( TEMP .NE. 0 ) AJACOB = DABS( TERM2*DSQRT(TERM2)/TEMP )       
C                                                                       
C        CALCULATE THE AMPLITUDES FOR THIS ANGLE.                       
C                                                                       
      CALL AMPCAL ( ANGLE, .TRUE., NSPL, LMN, LMX, LSKP,  LXMX, IDNPAR, 
     *ETA, UK, SIGZRO, PRNTSW, LHI,  ILLOC(LTOC+1), ALLOC(LBETA), ALOWFC
     *,  ALLOC(LFTEMP+2), ALLOC(LFLO+2), ALLOC(LFHI+2),  ALLOC(LFERR+1),
     * FCOUL, ALLOC(LPLM), ALLOC(LTMPCN),  ALLOC(LTMPCN+LMX+1),  LEBACK,
     * ALLOC(Z(IFEPSL)), NFLPAM )                                       
C                                                                       
C        CALCULATE THE CROSS SECTIONS.                                  
C                                                                       
      SIGMA = 0                                                         
      SIGLOW = 0                                                        
      SIGHI = 0                                                         
      IF ( IDNTSW ) GO TO 250                                           
      DO 229 KOFFS = 1, NSPL                                            
      IF ( ILLOC(LTOC+4*KOFFS) .LT. 0 ) GO TO 229                       
      MX = ( ILLOC(LTOC+4*KOFFS-3) + ILLOC(LTOC+4*KOFFS-2) + 1 )/2      
      TEMP = 10.                                                        
      IF ( MX .NE. 0 ) TEMP = 20.                                       
      SIGMA = SIGMA + TEMP *  ( ALLOC(LFTEMP+2*KOFFS)**2 + ALLOC(LFTEMP+
     *2*KOFFS+1)**2 )                                                   
      IF ( .NOT. PRNTSW ) GO TO 229                                     
      SIGLOW = SIGLOW + TEMP *  ( ALLOC(LFLO+2*KOFFS)**2 + ALLOC(LFLO+2*
     *KOFFS+1)**2 )                                                     
      SIGHI = SIGHI + TEMP *  ( ALLOC(LFHI+2*KOFFS)**2 + ALLOC(LFHI+2*KO
     *FFS+1)**2 )                                                       
 229  CONTINUE                                                          
      RUTH = ( FCOUL(1,3)**2 + FCOUL(2,3)**2 )*10.                      
      GO TO 260                                                         
C                                                                       
C        IDENTICAL PARTICLES (NO SPIN-DEPENDENT FORCES).                
C                                                                       
 250  RUTH = ( FCOUL(1,ISTAT)**2 + FCOUL(2,ISTAT)**2  + STATFC*( FCOUL(1
     *,1)**2 + FCOUL(2,1)**2  - FCOUL(1,2)**2 - FCOUL(2,2)**2 ) )*10.   
      SIGMA = ( ALLOC(LFTEMP+2*ISTAT)**2 + ALLOC(LFTEMP+2*ISTAT+1)**2 + 
     *STATFC*( ALLOC(LFTEMP+2)**2 + ALLOC(LFTEMP+3)**2  - ALLOC(LFTEMP+4
     *)**2 - ALLOC(LFTEMP+5)**2 ) )*10.                                 
      IF ( .NOT. PRNTSW ) GO TO 260                                     
      SIGLOW = ( ALLOC(LFLO+2*ISTAT)**2 + ALLOC(LFLO+2*ISTAT+1)**2  + ST
     *ATFC*( ALLOC(LFLO+2)**2 + ALLOC(LFLO+3)**2  - ALLOC(LFLO+4)**2 - A
     *LLOC(LFLO+5)**2 ) )*10.                                           
      SIGHI = ( ALLOC(LFHI+2*ISTAT)**2 + ALLOC(LFHI+2*ISTAT+1)**2  + STA
     *TFC*( ALLOC(LFHI+2)**2 + ALLOC(LFHI+3)**2  - ALLOC(LFHI+4)**2 - AL
     *LOC(LFHI+5)**2 ) )*10.                                            
C                                                                       
C        SAVE F IF NECESSARY.                                           
C                                                                       
 260  IF ( .NOT. FKEPSW ) GO TO 280                                     
      DO 269 K = 1, NF                                                  
      ALLOC(LF+NANG*NF+K) = ALLOC(LFTEMP+1+K)                           
 269  CONTINUE                                                          
C                                                                       
C        COMPUTE RELATIVE ERRORS FROM LOWER AND UPPER L-TRUNCATIONS     
C                                                                       
 280  EL = 50 * (1 - SIGLOW/SIGMA)                                      
      EH = 50 * (1 - SIGHI/SIGMA)                                       
      SIGMAR = 0                                                        
      IF ( RUTH .NE. 0 ) SIGMAR = SIGMA/RUTH                            
C                                                                       
      IF ( .NOT. PRNTSW ) GO TO 400                                     
C                                                                       
      SIGLAB = AJACOB*SIGMA                                             
C                                                                       
C        PRINT EVERTHING IN MILLIBARNS                                  
C                                                                       
      WRITE(7,300) ANGLE,SIGMAR,SIGMA   
 300  FORMAT( F7.2, 2G14.5)
 303  FORMAT( 2F7.2, 2G14.4, G12.4, G15.4, F13.2, F8.2 )                
      WRITE(6,303) ANGLE,ANGLAB,SIGMAR,SIGMA,SIGLAB,RUTH,EL,EH   
      ALLOC(Z(ICROSS)-1+NANG) = SIGMA
      ALLOC(Z(ILAB)-1+NANG) = SIGLAB                                    
 400  ALLOC(Z(ITORUT)-1+NANG) = SIGMAR                                  
      ALLOC(Z(IRUTH)-1+NANG) = RUTH                                     
C
 489  CONTINUE
C
      IF (PRNTSW) WRITE(6,813) SIGREA, SIGNUC
 813  FORMAT ( / ' TOTAL REACTION CROSS SECTION =', F13.3, ' MB' /  
     *'  NUCLEAR TOTAL CROSS SECTION =', F13.3, ' MB' )
C
C  FREE ALLOCATED SPACE                                                 
C
      Z(IPLM)=-Z(IPLM)                                                  
      Z(IBETA) = -Z(IBETA)                                              
      Z(IFTEMP) = -Z(IFTEMP)                                            
      Z(IFLO) = -Z(IFLO)                                                
      Z(IFHI) = -Z(IFHI)                                                
      RETURN                                                            
      END                                                               
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
C E=EXCESS(Z,A,NOTTAB) IS ATOMIC MASS EXCESS IN MEV FROM 1975 AMSTERDAM 
C       COMPILATION OF THIS PROGRAM REQUIRES 300K WITH H-EXTENDED OPT-2 
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
C                                                                       
C  PURPOSE                                                              
C    TO PROVIDE THE NUCLEAR MASS-EXCESS IN MEV FOR ANY Z (ATOMIC NUMBER)
C  AND A (MASS NUMBER).    A TABLE LOOK UP METHOD IS USED.  THE         
C  DATA ARE FROM A TAPE SENT BY BOS OF AMSTERDAM TO JOHN ERSKINE AT     
C  ARGONNE LATE IN 1975.  THE LAST PUBLISHED INFORMATION OF THIS SORT   
C  IS THAT OF  WAPSTRA AND GOVE  NUCL. DATA  A8 (1971).                 
C                                                                       
C    TWO ENTRIES ARE PROVIDED..                                         
C  #EXCESS' RETURNS THE MASS EXCESS IN MEV...                           
C  #BEMEV'  RETURNS THE BINDING ENERGY (A POSITIVE NUMBER) IN MEV AND IS
C           COMPUTED BY                                                 
C               BEMEV = Z*EXCESS(1H) + N*EXCESS(1N) - EXCESS(Z,A)       
C  ..                                                                   
C    SUGGESTED USAGE:                                                   
C     DOUBLE PRECISION EXCESS,BEMEV,E,B                                 
C     E = EXCESS(KZ,KA,NOTTAB)                                          
C     B = BEMEV (KZ,KA,NOTTAB)                                          
C                                                                       
C  WHERE KZ IS THE ATOMIC NUMBER, KA IS THE MASS NUMBER, NOTTAB IS SET  
C  TO ZERO IF THE NUCLEAR MASS IS FOUND, TO ONE IF IT ISNT FOUND.       
C     THE TABLE CONTAINS MASS EXCESSES ACCURATE TO ABOUT 6 SIG FIGS     
C     WHICH MAY BE .01 KEV FOR LIGHT NUCLEI AND ABOUT 1 KEV FOR THE     
C     MORE MASSIVE NUCLEI.  IN ANY CASE, IT APPEARS TO REPRODUCE THE    
C     LEVEL OF SIGNIFICANCE IN THE WAPSTRA-GOVE 1971 TABLES             
C                                                                       
C  THE ECONOMY OF STORING ALL EXCESSES IN SINGLE PRECISION EXACTS       
C  A SMALL PENALTY. IN PARTICULAR, THOSE MASSES  THAT ARE KNOWN         
C  TO SIX SIGNIFICANT FIGURES AND WHERE THE SIXTH FIGURE APPEARS        
C  BEYOND THE DECIMAL WILL HAVE AN ERROR IN THE SEVENTH FIGURE,         
C  IE,  THE SEVENTH FIGURE WILL NOT BE RETURNED AS ZERO UNLESS          
C  THE FRACTION IS EXPRESSABLE EXACTLY IN HEXICECIMAL (EG .5)           
C                                                                       
C   1/74 CHANGES:                                                       
C        ACCEPTS Z=0 A>=0 .. RETURNS A*NEUTRON MASS                     
C                           FRANK SERDUKE                               
C                                                                       
C     3/8/74  MAJOR REVISION..EXCESSES STORED IN KEV INSTEAD OF AMU     
C             AMASS ENTRY DROPPED..ONLY EXCESS AND BEMEV RETAINED       
C     12/27/79 - IE IS INTEGER*2 IN NON-IBM VERSIONS - RPG              
C                                           FRANK SERDUKE               
C                                                                       
C  SUBROUTINES REQUIRED                                                 
C     NONE                                                              
C                                                                       
C ... MODIFICATIONS MAY BE MADE TO THIS PROGRAM BUT ARE RESTRICTED.     
C...  THESE RESTRICTIONS MUST ENSURE THE THE PROGRAM 'MODMAS' WILL      
C     STILL WORK.  MODMAS SEARCHES FOR A 'D' IN COLUMN 7 .  IT WILL     
C     STORE ALL COMMENT CARDS AND ALL FORTRAN STATEMENTS UP TO          
C     THE CARD FOLLOWING THE FIRST NON-COMMENT WITH A 'D' IN COLUMN 7.  
C     IT IS TRYING TO FIND THE DIMENSION OF THE AM ARRAY AND ASSUMES    
C     THAT THIS DIMENSION IS TO BE FOUND IN THE SECOND CARD AFTER THE   
C     FIRST 'D' IN COLUMN 7 OF A NON-COMMENT CARD.  PREVIOUS VERSIONS   
C     HAD 'DOUBLE PRECISION' IN THE FUNCTION CARD.                      
C         HERE THE FIRST 'D' IS ENCOUNTERED IN THE                      
C          DOUBLE PRECISION DM(...),..........      STATEMENT.          
C                                                                       
C        IN THIS VERSION...WE MAKE THE ARRAYS IE AND IA INTO L*1 AND    
C   I*2 RESPECTIVELY TO SAVE ABOUT 1300 BYTES OF CORE.. WE ALSO RETURN  
C   Z*EXCESS OF A PROTON FOR CALLS WITH Z=A SO THAT MULTI-PROTON        
C   CLUSTER TRANSFERS WILL RECEIVE A VALID RESULT IN THE DWBA CODE.     
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
C                                                                       
      FUNCTION EXCESS(KZ,KA,NOTTAB)                                     
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CIB         LOGICAL*1 IE,IE1,IE2,IE3                                    
      INTEGER*2 IE,IE1,IE2,IE3                                          
      INTEGER*2 IA,IA1,IA2,IA3                                          
C .. THIS COMMENT EXISTS SO THAT MODMAS CAN FIND THE DIMENSION OF 'AM'  
      DIMENSION AM(1980),IE(270),IA(270)                                
      DIMENSION IE1(90),IE2(90),IE3(90),IA1(90),IA2(90),IA3(90)         
     *,AM 1(45),AM 2(45),AM 3(45),AM 4(45),AM 5(45),AM 6(45)            
     *,AM 7(45),AM 8(45),AM 9(45),AM10(45),AM11(45),AM12(45)            
     *,AM13(45),AM14(45),AM15(45),AM16(45),AM17(45),AM18(45)            
     *,AM19(45),AM20(45),AM21(45),AM22(45),AM23(45),AM24(45)            
     *,AM25(45),AM26(45),AM27(45),AM28(45),AM29(45),AM30(45)            
     *,AM31(45),AM32(45),AM33(45),AM34(45),AM35(45),AM36(45)            
     *,AM37(45),AM38(45),AM39(45),AM40(45),AM41(45),AM42(45)            
     *,AM43(45),AM44(45)                                                
      EQUIVALENCE (IE(1),IE1),(IE(91),IE2),(IE(181),IE3)                
      EQUIVALENCE (IA(1),IA1),(IA(91),IA2),(IA(181),IA3)                
     *,(AM(   1),AM 1),(AM(  46),AM 2),(AM(  91),AM 3),(AM( 136),AM 4)  
     *,(AM( 181),AM 5),(AM( 226),AM 6),(AM( 271),AM 7),(AM( 316),AM 8)  
     *,(AM( 361),AM 9),(AM( 406),AM10),(AM( 451),AM11),(AM( 496),AM12)  
     *,(AM( 541),AM13),(AM( 586),AM14),(AM( 631),AM15),(AM( 676),AM16)  
     *,(AM( 721),AM17),(AM( 766),AM18),(AM( 811),AM19),(AM( 856),AM20)  
     *,(AM( 901),AM21),(AM( 946),AM22),(AM( 991),AM23),(AM(1036),AM24)  
     *,(AM(1081),AM25),(AM(1126),AM26),(AM(1171),AM27),(AM(1216),AM28)  
     *,(AM(1261),AM29),(AM(1306),AM30),(AM(1351),AM31),(AM(1396),AM32)  
     *,(AM(1441),AM33),(AM(1486),AM34),(AM(1531),AM35),(AM(1576),AM36)  
     *,(AM(1621),AM37),(AM(1666),AM38),(AM(1711),AM39),(AM(1756),AM40)  
     *,(AM(1801),AM41),(AM(1846),AM42),(AM(1891),AM43),(AM(1936),AM44)  
      DATA IE1/                                                         
     *    0,   0,   1,   1,   1,   1,   2,   2,   2,   3                
     *,   3,   3,   4,   4,   4,   5,   5,   5,   6,   6                
     *,   7,   7,   8,   8,   9,   9,  10,  10,  11,  11                
     *,  11,  11,  11,  12,  13,  13,  14,  14,  15,  15                
     *,  16,  16,  17,  17,  18,  18,  18,  19,  19,  20                
     *,  20,  21,  22,  22,  23,  23,  24,  24,  25,  25                
     *,  26,  26,  27,  27,  27,  28,  28,  28,  29,  29                
     *,  29,  30,  30,  30,  30,  30,  30,  30,  31,  32                
     *,  32,  33,  33,  34,  34,  35,  35,  35,  36,  36/               
      DATA IE2/                                                         
     *   36,  36,  36,  36,  37,  37,  37,  38,  39,  39                
     *,  40,  40,  41,  41,  42,  42,  43,  43,  44,  44                
     *,  45,  45,  46,  46,  47,  47,  47,  47,  48,  48                
     *,  49,  49,  49,  49,  49,  49,  49,  49,  49,  49                
     *,  49,  50,  50,  51,  51,  52,  52,  53,  53,  54                
     *,  54,  54,  54,  55,  55,  55,  56,  57,  58,  58                
     *,  59,  59,  60,  60,  61,  61,  62,  62,  63,  63                
     *,  63,  64,  64,  65,  65,  66,  66,  67,  67,  67                
     *,  67,  68,  68,  68,  69,  69,  69,  70,  70,  71/               
      DATA IE3/                                                         
     *   71,  72,  72,  72,  72,  73,  73,  74,  74,  74                
     *,  75,  75,  76,  76,  76,  76,  77,  77,  77,  78                
     *,  78,  78,  79,  79,  79,  80,  80,  81,  81,  81                
     *,  81,  82,  82,  82,  82,  83,  83,  84,  84,  85                
     *,  85,  86,  86,  87,  87,  87,  87,  88,  88,  88                
     *,  88,  89,  89,  90,  90,  91,  91,  91,  91,  92                
     *,  92,  93,  93,  94,  94,  94,  94,  95,  95,  96                
     *,  96,  97,  97,  98,  98,  99,  99, 100, 101, 102                
     *, 103, 104, 105, 106, 107, 107, 108, 108, 109, 200/               
      DATA IA1/                                                         
     *    0,   0,   2,   3,   5,   8,  11,  14,  18,  23                
     *,  27,  32,  37,  42,  47,  53,  58,  64,  70,  76                
     *,  82,  88,  94, 100, 106, 112, 118, 124, 130, 136                
     *, 142, 149, 156, 164, 171, 178, 185, 192, 199, 206                
     *, 213, 220, 227, 234, 241, 248, 255, 263, 270, 277                
     *, 284, 291, 297, 302, 308, 313, 319, 324, 330, 335                
     *, 341, 346, 352, 357, 363, 369, 375, 381, 388, 394                
     *, 401, 408, 415, 422, 429, 436, 443, 451, 459, 466                
     *, 472, 478, 484, 490, 496, 502, 508, 514, 521, 528/               
      DATA IA2/                                                         
     *  535, 543, 551, 559, 568, 576, 585, 594, 603, 611                
     *, 620, 628, 637, 646, 656, 665, 675, 684, 694, 703                
     *, 712, 720, 728, 735, 743, 750, 758, 767, 776, 784                
     *, 793, 801, 809, 817, 825, 833, 841, 849, 858, 867                
     *, 876, 885, 894, 903, 911, 920, 928, 937, 945, 954                
     *, 962, 971, 980, 990, 999,1009,1019,1029,1038,1047                
     *,1057,1067,1078,1088,1099,1109,1120,1130,1141,1151                
     *,1161,1172,1182,1193,1203,1213,1222,1231,1240,1249                
     *,1259,1269,1279,1289,1300,1310,1321,1332,1342,1353/               
      DATA IA3/                                                         
     * 1363,1373,1382,1391,1401,1411,1421,1431,1440,1449                
     *,1459,1468,1477,1485,1494,1503,1512,1521,1530,1539                
     *,1547,1556,1565,1574,1583,1593,1602,1611,1619,1627                
     *,1636,1645,1653,1661,1670,1679,1687,1695,1702,1709                
     *,1715,1721,1726,1732,1737,1742,1747,1753,1758,1763                
     *,1769,1775,1780,1786,1791,1797,1802,1808,1814,1821                
     *,1827,1834,1840,1846,1852,1858,1865,1872,1878,1885                
     *,1891,1897,1903,1909,1914,1919,1924,1929,1934,1938                
     *,1941,1944,1946,1948,1949,1950,1951,1952,1953,1954/               
      DATA AM 1/                                                        
     *    8071.43,   7289.03,  13135.84,  14949.93,  14931.31           
     *,  25920.00,   2424.93,  25130.00,  33790.00,  11390.00           
     *,  11680.00,  17596.70,  14086.90,  18375.00,  26110.00           
     *,  14907.80,  15769.60,  27940.00,  31603.00,  20946.50           
     *,   4941.75,  22921.60,  35190.00,  24955.40,  11347.97           
     *,  12416.00,  28911.90,  33330.00,  12607.50,  12051.80           
     *,  15702.90,  39500.00,  40940.00,  20176.00,   8667.90           
     *,  10649.90,  25230.00,  25030.00,  13369.50,      0.0            
     *,  17338.20,  32070.00,  34900.00,  16562.00,   3125.03/          
      DATA AM 2/                                                        
     *    5345.60,  23106.00,  40970.00,  23657.00,   3019.92           
     *,   2863.44,   8008.63,  33610.00,  30130.00,   9873.20           
     *,    101.51,   2855.20,  17660.00,  39200.00,  13693.00           
     *,   5681.70,  -4737.02,  10692.00,  24110.00,  45670.00           
     *,  21260.00,   7870.00,   -810.50,   1951.65,  16478.00           
     *,  25370.00,  13274.00,   -783.01,    872.70,   5319.00           
     *,  25320.00,  34450.00,  16350.00,   3331.30,  -1487.38           
     *,   1750.60,  12828.00,  22800.00,   3799.00,    -17.00           
     *,  -7043.00,   6848.00,  17750.00,  27020.00,   8620.00/          
      DATA AM 3/                                                        
     *     -47.00,  -5733.10,  -2185.80,  10912.00,  11530.00           
     *,   2826.00,  -8026.20,  -5184.00,   -395.00,  18200.00           
     *,  18750.00,   3350.00,  -5155.10,  -9530.10,  -5471.40           
     *,   6767.00,   9250.00,  -5949.00,  -8418.10, -13931.50           
     *,    -48.60,  10750.00,  13140.00,  -2150.00,  -9358.00           
     *, -13191.30,  -8913.70,   3824.00,    310.00,  -6888.00           
     *, -16212.70, -12207.90,  -7144.20,  11260.00,   7070.00           
     *,  -5630.00, -14585.30, -17194.50, -12384.10,   -480.00           
     *,  -1130.00, -15016.60, -16848.40, -21491.50,  -7154.60/          
      DATA AM 4/                                                        
     *    4200.00,   2660.00, -10750.00, -18213.00, -21893.90           
     *, -16949.50,  -3160.00,   8380.00,  -9790.00, -15890.00           
     *, -24432.00, -20204.80, -14062.10,   4840.00,  10610.00           
     *,  -3900.00, -15100.00, -22948.90, -24439.80, -19044.20           
     *,  -7050.00,  16410.00,  -1390.00, -11090.00, -24092.00           
     *, -24304.90, -26015.20, -13324.00,  -2200.00,   5430.00           
     *,  -8970.00, -20570.00, -26337.10, -26586.10, -21004.30           
     *,  -9384.00,  -3150.00, -20250.00, -24550.00, -29931.58           
     *, -24438.80, -18379.30,  -1480.00,    660.00, -14540.00/          
      DATA AM 5/                                                        
     *  -24940.00, -28846.37, -29013.73, -23048.90, -11250.00           
     *, -12170.00, -20770.00, -30666.00, -29522.10, -30231.39           
     *, -17421.00,  -6640.00,  -6510.00, -19010.00, -26908.00           
     *, -31761.76, -30948.00, -24799.50, -13161.00, -14560.00           
     *, -26862.00, -29798.00, -34715.00, -28802.00, -22051.00           
     *,  -4450.00, -12300.00, -23000.00, -29803.00, -33241.00           
     *, -33806.00, -27282.00, -14080.00, -22240.00, -27540.00           
     *, -35040.10, -33534.90, -34846.60, -20521.90,  -9030.00           
     *, -18300.00, -27400.00, -33067.50, -35559.40, -35138.20/          
      DATA AM 6/                                                        
     *  -28643.30, -15780.00, -24420.00, -34420.00, -35022.40           
     *, -38542.40, -32119.20, -25122.00,  -8020.00, -23280.00           
     *, -31980.00, -36587.00, -38403.90, -36183.30, -29324.00           
     *, -18020.00, -32270.00, -35805.00, -41464.20, -37809.40           
     *, -37546.10, -23850.00, -13500.00, -29730.00, -36611.00           
     *, -40808.00, -41067.50, -39005.00, -31879.00, -19460.00           
     *, -29730.00, -35421.00, -43138.10, -41756.60, -44123.60           
     *, -37071.70, -29462.00, -12470.00, -35699.00, -42342.80           
     *, -44330.40, -44930.80, -42002.10, -34610.00, -22910.00/          
      DATA AM 7/                                                        
     *  -32420.00, -44217.00, -44494.00, -48487.10, -44472.30           
     *, -42818.00, -29170.00, -41287.00, -46555.00, -48558.00           
     *, -47955.80, -45332.30, -37613.00, -24470.00, -39572.00           
     *, -44540.00, -51431.70, -49219.20, -50258.40, -42626.20           
     *, -34430.00, -43221.00, -49732.70, -52198.90, -51448.30           
     *, -48240.20, -40228.00, -49469.00, -51438.70, -55416.10           
     *, -50707.00, -48335.00, -46260.00, -51863.00, -55284.70           
     *, -54687.60, -50944.80, -42640.00, -49930.00, -56933.30           
     *, -55555.30, -56251.90, -48010.20, -49010.00, -55108.20/          
      DATA AM 8/                                                        
     *  -57710.70, -57479.10, -54024.30, -45334.00, -55267.00           
     *, -56909.50, -60604.00, -56035.70, -53903.00, -52390.00           
     *, -57493.00, -60178.50, -59342.70, -56100.00, -47620.00           
     *, -56210.00, -62151.30, -59843.90, -60224.70, -51659.10           
     *, -55660.00, -60661.10, -62226.30, -61153.30, -56352.60           
     *, -47590.00, -61426.00, -61646.70, -64470.30, -58341.50           
     *, -54185.00, -59010.00, -62897.40, -64219.80, -61980.20           
     *, -56580.00, -47750.00, -61573.00, -66745.69, -62798.00           
     *, -61169.00, -51970.00, -61851.00, -65512.90, -65578.81/          
      DATA AM 9/                                                        
     *  -62213.50, -56690.00, -47550.00, -59792.00, -67098.31           
     *, -65423.30, -66001.00, -58836.00, -54430.00, -65124.80           
     *, -67261.31, -65909.37, -62650.00, -56450.00, -47190.00           
     *, -66021.00, -66256.62, -68898.37, -63723.40, -61621.00           
     *, -51720.00, -63555.00, -67305.00, -67879.69, -66878.69           
     *, -62450.00, -56650.00, -47080.00, -65390.00, -70006.37           
     *, -67085.31, -66971.00, -58970.00, -54270.00, -65940.00           
     *, -68417.12, -69321.62, -67096.00, -63130.00, -56330.00           
     *, -46650.00, -63230.00, -69560.00, -68905.31, -70561.12/          
      DATA AM10/                                                        
     *  -64339.00, -61590.00, -51140.00, -67324.00, -70144.12           
     *, -69908.62, -67900.00, -63100.00, -56300.00, -46310.00           
     *, -68136.00, -68593.62, -72583.62, -68233.00, -67893.00           
     *, -58930.00, -53880.00, -65030.00, -69730.00, -71293.81           
     *, -70957.00, -68217.00, -63580.00, -56380.00, -65820.00           
     *, -67920.00, -73422.31, -70859.62, -72211.12, -65294.00           
     *, -62060.00, -62460.00, -68560.00, -71856.31, -73031.81           
     *, -72167.00, -69157.00, -64160.00, -62510.00, -66110.00           
     *, -73212.87, -72288.69, -75257.62, -70301.00, -69100.00/          
      DATA AM11/                                                        
     *  -60200.00, -58910.00, -66410.00, -71213.69, -73921.00           
     *, -74604.62, -73240.00, -70240.00, -65240.00, -63160.00           
     *, -71760.00, -72740.00, -77029.87, -73456.00, -74150.00           
     *, -66950.00, -69420.00, -73720.00, -75919.00, -76075.00           
     *, -74444.00, -70860.00, -69160.00, -71760.00, -77757.00           
     *, -75886.00, -77897.00, -72190.00, -72590.00, -76387.00           
     *, -77971.00, -77660.00, -75398.00, -71410.00, -69990.00           
     *, -77587.00, -77503.00, -80596.00, -76218.00, -75999.00           
     *, -75443.00, -79022.00, -79984.62, -78987.00, -76737.00/          
      DATA AM12/                                                        
     *  -72240.00, -75943.00, -77760.00, -82432.00, -79752.00           
     *, -80641.00, -73692.00, -78670.00, -81472.19, -82159.19           
     *, -81095.00, -77835.00, -73130.00, -75960.00, -83264.00           
     *, -82738.12, -84512.50, -79240.00, -77940.00, -74210.00           
     *, -80706.00, -84595.87, -84869.31, -83008.31, -79430.00           
     *, -74230.00, -79697.00, -82605.00, -87911.00, -84292.00           
     *, -83615.00, -76410.00, -72810.00, -76790.00, -81718.00           
     *, -86204.00, -87696.31, -84865.00, -80614.00, -75210.00           
     *, -75230.00, -79620.00, -85937.00, -86483.12, -88758.69/          
      DATA AM13/                                                        
     *  -82648.00, -80161.00, -69960.00, -71760.00, -77960.00           
     *, -83664.00, -86347.81, -87890.81, -86634.00, -82198.00           
     *, -75980.00, -69220.00, -75190.00, -82891.00, -84821.00           
     *, -88454.87, -86447.31, -86807.00, -78935.00, -65040.00           
     *, -73040.00, -80040.00, -84226.00, -87116.31, -87208.62           
     *, -86802.00, -83603.00, -77300.00, -69460.00, -78960.00           
     *, -82381.00, -87264.00, -86366.50, -88412.00, -84152.00           
     *, -82571.00, -66950.00, -75540.00, -81236.00, -85666.00           
     *, -86788.19, -87713.69, -86014.00, -83452.00, -78340.00/          
      DATA AM14/                                                        
     *  -61440.00, -73540.00, -78640.00, -85441.00, -85609.00           
     *, -88796.50, -85823.00, -86075.00, -79634.00, -69650.00           
     *, -76850.00, -82955.00, -85617.00, -87543.87, -87224.00           
     *, -86070.00, -82560.00, -77760.00, -73390.00, -81288.00           
     *, -83510.00, -88114.87, -86433.00, -88226.00, -83168.00           
     *, -81370.00, -71250.00, -77850.00, -82345.00, -85969.50           
     *, -87326.31, -87619.81, -85517.00, -82112.00, -76070.00           
     *, -76890.00, -80190.00, -86189.00, -86019.00, -89221.62           
     *, -85592.00, -85230.00, -77890.00, -73320.00, -79420.00/          
      DATA AM15/                                                        
     *  -83516.00, -86327.00, -87951.50, -87410.00, -85428.00           
     *, -81030.00, -75500.00, -76560.00, -83562.00, -84600.00           
     *, -89100.37, -86777.00, -87925.00, -82330.00, -79330.00           
     *, -69630.00, -75410.00, -80810.00, -84910.00, -87261.31           
     *, -88024.00, -87478.00, -84800.00, -80400.00, -73800.00           
     *, -65900.00, -80300.00, -82700.00, -88100.00, -86953.00           
     *, -89400.00, -85150.00, -83850.00, -75650.00, -70750.00           
     *, -77140.00, -82540.00, -85938.00, -87856.00, -88423.00           
     *, -87073.00, -84333.00, -79230.00, -72630.00, -63230.00/          
      DATA AM16/                                                        
     *  -80030.00, -86332.00, -86372.00, -89912.00, -86930.00           
     *, -87132.00, -80587.00, -76890.00, -65890.00, -79510.00           
     *, -83710.00, -86860.00, -88371.00, -88404.00, -86987.00           
     *, -83500.00, -78200.00, -70000.00, -60070.00, -83820.00           
     *, -85020.00, -89524.00, -87601.00, -89251.00, -84100.00           
     *, -82000.00, -72100.00, -65130.00, -80810.00, -85110.00           
     *, -87606.00, -88722.00, -88540.00, -86524.00, -82620.00           
     *, -76020.00, -67570.00, -82930.00, -88335.00, -87456.00           
     *, -90349.00, -86409.00, -85833.00, -77630.00, -72330.00/          
      DATA AM17/                                                        
     *  -82530.00, -86030.00, -88226.00, -89254.00, -88405.00           
     *, -85940.00, -80840.00, -73470.00, -86326.00, -86620.00           
     *, -90577.81, -87999.00, -88657.00, -81740.00, -77640.00           
     *, -83540.00, -87040.00, -89050.00, -89372.00, -88332.00           
     *, -84431.00, -78530.00, -71330.00, -85160.00, -90019.37           
     *, -88575.00, -90560.00, -84870.00, -82070.00, -73270.00           
     *, -84910.00, -88092.00, -89541.00, -90034.50, -87004.00           
     *, -82460.00, -76760.00, -68580.00, -82620.00, -88717.37           
     *, -88253.00, -91525.37, -86930.00, -85370.00, -78070.00/          
      DATA AM18/                                                        
     *  -73170.00, -62680.00, -82240.00, -86416.00, -88945.00           
     *, -90399.87, -88655.00, -85165.00, -80860.00, -73980.00           
     *, -66660.00, -86706.00, -87450.00, -91654.19, -87959.00           
     *, -87671.00, -81370.00, -78070.00, -68870.00, -84230.00           
     *, -87728.00, -90067.37, -89484.00, -87190.00, -83820.00           
     *, -78830.00, -72430.00, -63680.00, -85780.00, -91100.12           
     *, -88420.00, -89404.00, -84000.00, -82050.00, -73830.00           
     *, -68550.00, -85835.00, -89200.62, -89587.31, -88590.00           
     *, -86220.00, -82430.00, -77130.00, -70370.00, -83440.00/          
      DATA AM19/                                                        
     *  -89944.00, -88322.12, -90302.00, -86160.00, -85060.00           
     *, -77910.00, -74060.00, -83440.00, -87819.00, -89215.50           
     *, -89164.00, -87960.00, -85290.00, -80990.00, -75270.00           
     *, -80840.00, -88239.00, -87611.31, -90516.00, -87359.00           
     *, -87450.00, -81530.00, -78650.00, -80480.00, -85899.00           
     *, -88255.00, -89021.00, -88844.00, -87110.00, -84040.00           
     *, -79460.00, -77820.00, -86022.00, -86500.00, -90066.00           
     *, -87910.00, -89161.00, -84210.00, -82410.00, -77300.00           
     *, -83500.00, -86704.00, -88285.00, -88979.00, -88315.00/          
      DATA AM20/                                                        
     *  -86205.00, -82760.00, -77760.00, -74490.00, -83390.00           
     *, -84740.00, -88990.69, -87733.00, -89861.19, -85954.00           
     *, -85481.00, -78680.00, -73630.00, -80630.00, -84628.00           
     *, -87004.00, -88508.00, -88697.87, -87562.00, -85115.00           
     *, -81120.00, -70680.00, -80380.00, -82380.00, -87347.00           
     *, -86897.00, -89881.31, -86862.00, -87302.00, -81600.00           
     *, -77310.00, -82100.00, -85200.00, -87450.00, -88421.00           
     *, -88066.00, -86725.00, -83760.00, -79460.00, -76380.00           
     *, -79600.00, -85201.00, -85706.00, -89286.00, -87183.00/          
      DATA AM21/                                                        
     *  -88452.00, -83740.00, -82340.00, -78980.00, -82930.00           
     *, -85901.00, -87661.00, -88088.00, -87568.00, -85570.00           
     *, -82170.00, -73870.00, -82570.00, -83970.00, -88125.00           
     *, -86908.00, -88966.00, -85266.00, -84770.00, -78470.00           
     *, -77600.00, -83795.00, -86505.00, -87664.00, -87869.00           
     *, -86669.00, -84550.00, -80990.00, -75020.00, -79420.00           
     *, -86425.00, -86356.00, -88904.00, -86030.00, -86490.00           
     *, -81400.00, -79190.00, -76720.00, -82215.00, -86558.00           
     *, -87731.00, -87130.00, -85930.00, -83230.00, -79430.00/          
      DATA AM22/                                                        
     *  -72370.00, -80370.00, -83110.00, -88271.00, -86522.00           
     *, -87562.00, -83125.00, -82030.00, -75030.00, -75750.00           
     *, -80630.00, -84923.00, -87228.00, -86968.00, -84858.00           
     *, -82058.00, -77560.00, -73170.00, -77230.00, -83283.00           
     *, -84318.00, -88078.00, -84690.00, -84220.00, -78320.00           
     *, -75520.00, -69000.00, -75000.00, -79980.00, -83005.00           
     *, -85435.00, -86016.00, -84201.00, -80470.00, -75910.00           
     *, -66040.00, -70940.00, -77810.00, -80014.00, -84531.00           
     *, -83788.00, -85948.00, -81060.00, -78977.00, -71480.00/          
      DATA AM23/                                                        
     *  -68360.00, -74010.00, -78310.00, -81615.00, -83066.00           
     *, -83999.00, -82959.00, -79511.00, -74410.00, -63930.00           
     *, -72030.00, -74930.00, -80434.00, -80749.00, -83746.00           
     *, -81416.00, -81963.00, -75636.00, -71940.00, -61740.00           
     *, -67840.00, -72940.00, -77140.00, -79625.00, -81430.00           
     *, -81270.00, -80654.00, -77934.00, -72930.00, -65560.00           
     *, -69460.00, -75760.00, -76840.00, -80924.00, -79444.00           
     *, -80986.00, -77113.00, -75910.00, -67810.00, -67540.00           
     *, -72240.00, -75440.00, -78145.00, -79041.00, -79266.00/          
      DATA AM24/                                                        
     *  -77535.00, -75207.00, -70510.00, -70710.00, -72510.00           
     *, -77407.00, -76872.00, -79336.00, -76236.00, -76267.00           
     *, -70640.00, -67770.00, -67490.00, -71390.00, -74386.00           
     *, -76064.00, -77136.00, -76380.00, -75130.00, -71433.00           
     *, -67530.00, -61530.00, -68680.00, -73684.00, -73550.00           
     *, -77051.00, -74757.00, -75767.00, -71100.00, -69140.00           
     *, -62040.00, -57940.00, -67420.00, -70921.00, -73388.00           
     *, -74576.00, -74652.00, -74170.00, -71608.00, -68601.00           
     *, -63440.00, -58200.00, -50800.00, -70148.00, -71290.00/          
      DATA AM25/                                                        
     *  -74763.00, -72886.00, -74706.00, -70856.00, -70115.00           
     *, -63710.00, -60410.00, -51810.00, -67360.00, -70760.00           
     *, -72559.00, -73366.00, -73123.00, -71420.00, -69148.00           
     *, -64953.00, -60310.00, -53870.00, -47210.00, -68460.00           
     *, -72456.00, -71732.00, -73707.00, -70250.00, -70393.00           
     *, -64637.00, -62440.00, -54530.00, -50040.00, -67100.00           
     *, -70198.00, -71827.00, -72073.00, -71256.00, -69157.00           
     *, -66055.00, -62058.00, -56450.00, -50450.00, -42600.00           
     *, -69370.00, -70085.00, -72538.00, -70100.00, -70527.00/          
      DATA AM26/                                                        
     *  -65430.00, -63930.00, -56950.00, -53060.00, -43820.00           
     *, -66870.00, -69467.00, -70827.00, -70769.00, -69426.00           
     *, -66890.00, -63090.00, -58490.00, -53270.00, -46470.00           
     *, -38960.00, -67240.00, -70693.00, -69476.00, -70410.00           
     *, -66433.00, -65030.00, -58430.00, -55530.00, -47230.00           
     *, -42210.00, -65930.00, -68564.00, -69533.00, -69168.00           
     *, -67315.00, -64360.00, -60160.00, -55260.00, -49460.00           
     *, -42800.00, -63550.00, -67945.00, -67837.00, -69674.00           
     *, -66388.00, -66053.00, -60130.00, -57550.00, -49930.00/          
      DATA AM27/                                                        
     *  -45740.00, -35790.00, -65509.00, -67472.00, -68056.00           
     *, -67204.00, -65198.00, -61680.00, -57400.00, -52080.00           
     *, -46130.00, -38840.00, -64360.00, -65760.00, -68181.00           
     *, -66046.00, -66336.00, -61550.00, -59350.00, -52350.00           
     *, -48760.00, -39710.00, -34120.00, -64680.00, -66382.00           
     *, -66379.00, -65168.00, -62770.00, -59170.00, -54370.00           
     *, -48770.00, -42370.00, -34860.00, -62110.00, -65965.00           
     *, -64937.00, -65941.00, -61979.00, -60880.00, -54580.00           
     *, -51280.00, -43080.00, -38040.00, -63609.00, -64894.00/          
      DATA AM28/                                                        
     *  -64519.00, -62925.00, -60162.00, -56160.00, -51260.00           
     *, -45360.00, -38670.00, -62582.00, -63066.00, -64922.00           
     *, -61875.00, -61582.00, -56100.00, -53480.00, -46100.00           
     *, -41480.00, -62317.00, -63287.00, -62538.00, -60582.00           
     *, -57510.00, -53210.00, -48010.00, -42010.00, -34710.00           
     *, -60270.00, -62986.00, -61307.00, -61565.00, -57100.00           
     *, -55100.00, -48400.00, -44500.00, -35700.00, -58870.00           
     *, -60918.00, -61269.00, -60361.00, -57881.00, -54530.00           
     *, -50030.00, -44900.00, -38130.00, -30550.00, -56100.00/          
      DATA AM29/                                                        
     *  -60105.00, -59791.00, -60759.00, -57319.00, -56120.00           
     *, -50120.00, -46920.00, -38920.00, -33530.00, -57715.00           
     *, -59205.00, -59302.00, -57820.00, -55300.00, -51600.00           
     *, -46900.00, -41100.00, -34220.00, -26240.00, -56493.00           
     *, -57382.00, -59252.00, -56726.00, -56330.00, -51410.00           
     *, -48810.00, -41510.00, -36840.00, -27320.00, -53730.00           
     *, -56228.00, -57548.00, -56872.00, -55270.00, -52370.00           
     *, -48470.00, -43370.00, -37410.00, -29910.00, -21790.00           
     *, -53850.00, -56941.00, -55563.00, -55830.00, -51980.00/          
      DATA AM30/                                                        
     *  -50080.00, -43580.00, -39620.00, -30890.00, -24930.00           
     *, -52290.00, -54692.00, -55160.00, -54553.00, -52350.00           
     *, -49450.00, -45150.00, -39710.00, -33160.00, -25700.00           
     *, -17220.00, -49400.00, -53491.00, -53381.00, -54567.00           
     *, -51470.00, -50570.00, -44970.00, -41810.00, -33840.00           
     *, -28540.00, -18400.00, -50986.00, -52382.00, -52879.00           
     *, -51721.00, -49720.00, -46120.00, -41620.00, -35820.00           
     *, -29350.00, -21190.00, -49660.00, -50300.00, -52434.00           
     *, -50520.00, -50430.00, -45770.00, -43350.00, -36270.00/          
      DATA AM31/                                                        
     *  -31630.00, -22410.00, -15930.00, -49110.00, -50463.00           
     *, -50349.00, -49285.00, -46600.00, -42900.00, -37900.00           
     *, -32020.00, -24750.00, -16860.00, -46680.00, -49780.00           
     *, -48916.00, -49626.00, -45831.00, -44230.00, -37930.00           
     *, -34130.00, -25630.00, -19860.00, -47404.00, -48427.00           
     *, -48239.00, -46440.00, -43410.00, -39340.00, -34060.00           
     *, -27650.00, -20790.00, -45990.00, -46418.00, -48230.00           
     *, -45430.00, -44580.00, -38980.00, -35980.00, -28180.00           
     *, -23210.00, -43242.00, -45282.00, -46350.00, -45794.00/          
      DATA AM32/                                                        
     *  -43490.00, -40090.00, -35630.00, -30010.00, -23690.00           
     *, -15830.00, -41480.00, -42824.00, -45690.00, -44194.00           
     *, -44207.00, -39490.00, -37210.00, -30220.00, -26040.00           
     *, -16910.00, -41362.00, -43372.00, -43805.00, -42790.00           
     *, -40290.00, -36490.00, -31740.00, -26140.00, -19120.00           
     *, -11740.00, -38600.00, -42502.00, -41912.00, -42988.00           
     *, -39157.00, -37830.00, -31690.00, -28350.00, -19850.00           
     *, -14330.00, -39897.00, -41210.00, -41212.00, -39710.00           
     *, -36810.00, -32880.00, -28060.00, -21880.00, -14940.00/          
      DATA AM33/                                                        
     *  -38661.00, -39010.00, -41129.00, -38306.00, -37766.00           
     *, -32470.00, -29890.00, -22290.00, -17500.00, -35470.00           
     *, -37972.00, -38982.00, -38480.00, -36580.00, -33420.00           
     *, -29220.00, -24030.00, -17860.00,  -9880.00, -35520.00           
     *, -38704.00, -36700.00, -37320.00, -32878.00, -30960.00           
     *, -24160.00, -20220.00, -10840.00, -34490.00, -36393.00           
     *, -36702.00, -35702.00, -33795.00, -30430.00, -25620.00           
     *, -20230.00, -13000.00, -35880.00, -34830.00, -36287.00           
     *, -32773.00, -31970.00, -25590.00, -22290.00, -13670.00/          
      DATA AM34/                                                        
     *  -33359.00, -34491.00, -34430.00, -33278.00, -30938.00           
     *, -26940.00, -21990.00, -15560.00,  -8310.00, -32389.00           
     *, -32486.00, -34727.00, -32218.00, -32168.00, -26770.00           
     *, -23770.00, -15980.00, -10810.00, -29670.00, -31675.00           
     *, -32785.00, -32555.00, -31030.00, -27830.00, -23530.00           
     *, -17630.00, -11060.00, -29420.00, -32635.00, -31151.00           
     *, -31836.00, -27340.00, -25140.00, -17670.00, -13210.00           
     *,  -4050.00, -28430.00, -30431.00, -31150.00, -30735.00           
     *, -28330.00, -24630.00, -19330.00, -13150.00,  -6040.00/          
      DATA AM35/                                                        
     *  -25520.00, -29921.00, -29591.00, -30964.00, -27500.00           
     *, -25900.00, -19200.00, -15030.00,  -6670.00, -27420.00           
     *, -29104.00, -29557.00, -28160.00, -25160.00, -20590.00           
     *, -15040.00,  -8430.00, -26600.00, -27300.00, -29514.00           
     *, -27060.00, -26160.00, -20250.00, -16730.00,  -8650.00           
     *,  -3750.00, -23740.00, -26400.00, -27672.00, -27184.00           
     *, -25327.00, -21410.00, -16410.00, -10440.00,  -3860.00           
     *, -23860.00, -27356.00, -25987.00, -25942.00, -20740.00           
     *, -17780.00, -10430.00,  -5840.00,   3160.00, -22980.00/          
      DATA AM36/                                                        
     *  -25277.00, -25768.00, -24796.00, -21610.00, -17240.00           
     *, -11950.00,  -5980.00,   1270.00, -20200.00, -24702.00           
     *, -24353.00, -25116.00, -20820.00, -18250.00, -11760.00           
     *,  -7760.00,    890.00,   6280.00, -22299.00, -23838.00           
     *, -23776.00, -21069.00, -17576.00, -12960.00,  -7600.00           
     *,   -960.00,   6060.00, -20956.00, -22269.00, -23796.00           
     *, -20132.00, -18190.00, -12430.00,  -8970.00,  -1080.00           
     *,   4000.00, -21042.00, -22464.00, -20059.00, -17151.00           
     *, -13310.00,  -8570.00,  -2630.00,   3720.00, -16768.00/          
      DATA AM37/                                                        
     *  -21760.00, -18880.00, -17475.00, -12640.00,  -9570.00           
     *,  -2560.00,   1940.00, -13650.00, -17625.00, -18269.00           
     *, -16373.00, -12887.00,  -8994.00,  -3760.00,   1970.00           
     *,   9200.00,  -9252.00, -14739.00, -14802.00, -15963.00           
     *, -12075.00,  -9607.00,  -3340.00,    610.00,   8950.00           
     *, -10493.00, -11866.00, -12445.00, -11654.00,  -8762.00           
     *,  -4220.00,    900.00,   7420.00,  -7563.00,  -8136.00           
     *, -10381.00,  -8626.00,  -8665.00,  -3690.00,   -110.00           
     *,   7390.00,  -3140.00,  -5244.00,  -6664.00,  -6590.00/          
      DATA AM38/                                                        
     *   -5705.00,  -3555.00,    290.00,   6170.00,  12240.00           
     *,   -185.80,  -1210.00,  -4480.00,  -3390.00,  -4329.00           
     *,  -1064.00,     91.00,   6440.00,  10860.00,   1710.00           
     *,   -542.00,  -1262.00,  -1180.00,    308.00,   2528.00           
     *,   5950.00,  10990.00,   5970.00,   1769.00,   2239.00           
     *,    245.00,   2975.00,   3285.00,   7980.00,  10390.00           
     *,   5960.00,   4382.00,   3649.00,   4306.00,   5881.00           
     *,   8701.00,  12139.00,   8354.00,   8098.00,   5211.00           
     *,   7050.00,   6643.00,  10739.00,  12363.00,  10520.00/          
      DATA AM39/                                                        
     *    8830.00,   8616.00,   9377.00,  11560.00,  14467.00           
     *,  14200.00,  10598.00,  11472.00,  10263.00,  13746.00           
     *,  14663.00,  14380.00,  13265.00,  12956.00,  14517.00           
     *,  16934.00,  16369.40,  16337.00,  14312.00,  16616.00           
     *,  17197.00,  21861.00,  18381.00,  17233.00,  17825.00           
     *,  19256.00,  22329.00,  21710.00,  18812.00,  20221.00           
     *,  19992.00,  23798.00,  23790.00,  21986.70,  21625.00           
     *,  22302.00,  24320.00,  27460.00,  23665.10,  24300.40           
     *,  23188.00,  26028.00,  27186.00,  27184.00,  25849.00/          
      DATA AM40/                                                        
     *   25805.00,  26832.00,  28880.00,  28940.00,  28895.00           
     *,  26757.00,  28871.00,  29221.00,  32720.00,  30720.00           
     *,  29580.30,  29886.00,  31201.00,  33757.00,  34560.00           
     *,  33760.00,  30860.70,  32164.90,  31606.00,  35231.00           
     *,  35910.00,  33812.00,  33422.10,  33780.00,  35625.00           
     *,  39150.00,  35446.80,  35933.00,  34596.00,  37300.00           
     *,  38362.00,  38731.90,  37486.50,  36914.10,  38010.00           
     *,  40042.00,  40612.00,  40350.00,  38142.00,  39950.00           
     *,  40341.00,  44460.00,  42320.00,  40915.80,  41038.80/          
      DATA AM41/                                                        
     *   42160.00,  44650.00,  45540.00,  42441.20,  43426.00           
     *,  42889.00,  46020.00,  47890.00,  47640.00,  45387.70           
     *,  44868.70,  45086.00,  46640.00,  49170.00,  51270.00           
     *,  47307.40,  47452.70,  46160.20,  48417.00,  49398.00           
     *,  54280.00,  50572.60,  49306.10,  48584.40,  49388.00           
     *,  51090.00,  54280.00,  52715.00,  52210.00,  50122.10           
     *,  51520.00,  51711.00,  55710.00,  58030.00,  54310.00           
     *,  52952.30,  52931.50,  53695.00,  56100.00,  59190.00           
     *,  57510.00,  54714.70,  55466.00,  54800.90,  57800.00/          
      DATA AM42/                                                        
     *   59332.00,  57752.00,  57169.80,  57176.80,  58684.00           
     *,  60910.00,  64800.00,  59806.00,  59877.90,  58448.90           
     *,  60720.00,  61464.00,  65970.00,  63157.00,  61896.70           
     *,  61000.60,  61810.00,  63376.00,  66380.00,  70020.00           
     *,  65290.00,  64920.00,  62615.60,  64020.00,  64095.60           
     *,  67930.00,  70130.00,  67130.00,  65530.00,  65484.00           
     *,  66150.00,  68550.00,  71540.00,  70490.00,  67391.00           
     *,  67990.00,  67243.00,  70300.00,  71890.00,  77000.00           
     *,  70750.00,  69847.37,  69721.00,  71116.00,  73500.00/          
      DATA AM43/                                                        
     *   77260.00,  72988.00,  72947.00,  71169.50,  73170.00           
     *,  74068.00,  78600.00,  75250.00,  74130.00,  74502.00           
     *,  76000.00,  79020.00,  82760.00,  78530.00,  76034.00           
     *,  77160.00,  76821.00,  80570.00,  82861.00,  79301.00           
     *,  79011.81,  79346.00,  81240.00,  84330.00,  81344.00           
     *,  81997.00,  80898.00,  83390.00,  84728.00,  84080.00           
     *,  83796.00,  84880.00,  86870.00,  90250.00,  87260.00           
     *,  85483.00,  87420.00,  87800.00,  91900.00,  88590.00           
     *,  89040.00,  90223.00,  92970.00,  95950.00,  91820.00/          
      DATA AM44/                                                        
     *   91520.00,  94820.00,  96550.00,  94026.00,  96000.00           
     *,  98490.00,  98150.00,  99220.00, 103720.00, 101250.00           
     *, 104490.00, 106040.00,      0.0 ,      0.0 ,      0.0            
     *,      0.0 ,      0.0 ,      0.0 ,      0.0 ,      0.0            
     *,      0.0 ,      0.0 ,      0.0 ,      0.0 ,      0.0            
     *,      0.0 ,      0.0 ,      0.0 ,      0.0 ,      0.0            
     *,      0.0 ,      0.0 ,      0.0 ,      0.0 ,      0.0            
     *,      0.0 ,      0.0 ,      0.0 ,      0.0 ,      0.0            
     *,      0.0 ,      0.0 ,      0.0 ,      0.0 ,      0.0 /          
      DATA NTAB/268/                                                    
C                                                                       
C  PROGRAMMING NOTE:  THE ENTRY BEMEV IS NEVER EXPLICITLY DEFINED.      
C           IT WORKS ANYWAY ON AN IBM/360 SINCE ALL FUNCTION RETURNS    
C           ARE STORED IN FP REGISTER 0 REGARDLESS OF THE ENTRY NAME    
C                                                                       
C  IE HAS LOWEST Z FOR EACH A-SERIES...                                 
C  IA HAS ADDRESS OF LOWEST Z FOR EACH A-SERIES IN AM ARRAY...          
C  AM HAS MASS-EXCESS ES STORED IN ORDER OF INCREASING A, AND WITHIN    
C  EACH A-SERIES IN ORDER OF INCREASING Z.  MISSING INNER Z'S INDICATED 
C  BY 0.0 EXCEPT CARBON-12 IS OK...                                     
C  NEUTRAL PARTICLES  KA=X KZ=0   ACCEPTABLE                            
C  E.G. FOR XN .....KZ=0 KA=0 FOR GAMMA...RETURNS 0                     
C                                                                       
C  ALL EXCESSES ARE STORED IN KEV TO SIMPLIFY COMPARISON WITH THE ORNL  
C  DATA TAPES..HOWEVER ALL FUNCTION ENTRIES RETURN 'MEV'                
C                                                                       
C --- THIS IS THE 'NORMAL'   'EXCESS'  ENTRY                            
      SIGNUM = -1.0D-3                                                  
      DM = 0.0D0                                                        
      GO TO 1                                                           
C                                                                       
C ------ THIS IS THE BEMEV ENTRY .........                              
      ENTRY BEMEV(KZ,KA,NOTTAB)                                         
      SIGNUM = +1.0D-3                                                  
      DM = KZ*AM(2) + (KA-KZ)*AM(1)                                     
C                                                                       
C -- PERFORM VALIDITY CHECKS ON Z AND N                                 
1     NOTTAB=0                                                          
      EXCESS = 0.0                                                      
C   .... CHECK FOR XN OR GAMMA (Z=0 N>=0 .. THESE ARE OK)               
      IF ( KZ.EQ.0 .AND. KA.GE.0 ) GO TO 10                             
C   .... CHECK FOR YP  (Z=A N=0...THESE ARE ALSO OK  1/76 )             
      IF ( KZ.EQ.KA ) GO TO 20                                          
C  GREATEST A IS 268, LEAST IS 1...                                     
      IF(KA.LE.0.OR.KA.GT.NTAB) GO TO 9001                              
      KZLO=IE(KA+1)                                                     
      KZHI=IA(KA+2)-IA(KA+1)+KZLO-1                                     
C  CHECK FOR VALID Z...                                                 
      IF(KZ.GT.KZHI.OR.KZ.LT.KZLO) GO TO 9001                           
C  CALCULATE POSITION IN AM ARRAY...                                    
      IT=KZ-KZLO+IA(KA+1)                                               
      DMEX=AM(IT+1)                                                     
C  CHECK FOR MISSING ENTRY...                                           
      IF(DMEX.EQ.0.0.AND..NOT.(KZ.EQ.6.AND.KA.EQ.12)) GO TO 9001        
C                                                                       
C  ----  ALL CHECKS PASS...RETURN THE RESULT IN MEV                     
      EXCESS = SIGNUM * (DM-DMEX)                                       
      RETURN                                                            
C                                                                       
C ----  RETURN FOR NEUTRAL PARTICLES  (XN AND GAMMA)                    
10    EXCESS = SIGNUM * (DM - KA*AM(1))                                 
      RETURN                                                            
C                                                                       
C ----  RETURN FOR Y-PROTON CLUSTER ENERGIES                            
20    EXCESS = SIGNUM * (DM - KA*AM(2))                                 
      RETURN                                                            
C                                                                       
C                                                                       
C --- ERROR RETURN..SPECIFIED Z,A NOT IN TABLE                          
9001  NOTTAB=1                                                          
      RETURN                                                            
      END
C      
      SUBROUTINE FFACST ( IRTN )                                        
C                                                                       
C     GETS THE COULOMB BORN S MATRIX ELEMENTS FOR C.C.                  
C                                                                       
C     THE COULOMB FF2 INTEGRALS ARE EVALUATED FOR ALL CHANNELS          
C     WITH FIRST-ORDER COULOMB COUPLING TO THE GROUND STATE.            
C     THESE ARE THEN CONVERTED TO THE REAL OR IMAGINARY PART            
C     OF THE BORN S-MATRIX:                                             
C                                                                       
C     S(BORN) = I**(LX-1) X(1) SQRT((2LX+1)/4PI) *                      
C               !CLEBSCH( LOUT, LX, 0, 0; LIN, 0 )! *                   
C               2MU/HBAR**2 * 6*ZP*ZT*ALPHA*HBARC/SQRT(KIN*KOUT) *      
C               INTEGRAL( F(IN) F(OUT) / R**(LX+1) )                    
C                                                                       
C     THE SIGN OF THE I**(LX-1) FACTOR IS INCLUDED; ALL THAT            
C     IS LEFT TO DETERMIN IS WETHER S IS REAL (LX ODD) OR               
C     IMAGINARY (LX EVEN).                                              
C                                                                       
C     3/21/80 - FIRST VERSION - S.P.                                    
C     7/4/80 - USE MXLXGS INSTEAD OF LXMAX - S.P.                       
C     8/11/80 - CALL SETLOG - S.P.                                      
C     9/25/80 - TOTAL NMFFAC NOW FOUND BY GENBNX                        
C     7/12/81 - STORE DIFFERENCES IN DELTASR, DELTASI - S.P.            
C     3/8/82 - FIX DIMENSION BUGS FOR LXMAX = 1, 0 - 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) )                                                          
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /GRIDCM/ RCUEFF, GRDCM1(2), IBINDX, MBINDX, NBINDX, NMFFAC,
     * MXLXGS, NMBFAC, IINHR, IINHI, IRHSR, IRHSI, INUCH, ICOULH, ILOR, 
     *ILOI, ILIR, ILII, NPTMIN, NOFLO, NUMPT, NCRIT, ISMX, ISMSQ, IPADE,
     * IHOMO, ISMTSV, IRPTS4, IRPTS, IGRDC4(5), IDW, IGRDC5(2), IABS1, I
     *GRDC6(2), GRDCM2, IGRDC7(2), IRWTS, IGRDC8(2), ICL1FF, ICL1FG, ICL
     *1GF, ICL1GG                                                       
      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 R2S(4)                                                  
      EQUIVALENCE ( R2S(1), RBNDS(1) )                                  
C                                                                       
      LOGICAL ONELSW, IDENSW                                            
      COMMON /INELCM/ JBPF,JBTF,LXMIN,LXMAX,ILILOR,ILILOI,MSTOP,IA12M, 
     *NMLOLX,ONELSW,NUMLX,IRDINT,IELCUP,LILOSZ,NUMLIS,ILIS,IBETAS(4), 
     *ICL2FF,LXSTEP,IDENSW,LSKIP,JPMIN,JPMAX,JPBASE,NJP,JTMIN,JTMAX, 
     *JTBASE,NJT,IINDXS,ISMATR,ISMATI,NSMAT,NLX,NSPLI,ITOCS,NASPLI, 
     *IUNITR,LIFIT,ILIFIT,NOLFIT,IDELSR,IDELSI
      INTEGER INDXJS(4,2)                                               
      EQUIVALENCE ( INDXJS(1,1), JPMIN )                                
      COMMON /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
C                                                                       
      IRTN = 1                                                          
      IF ( NMFFAC .EQ. 0 ) RETURN                                       
      WRITE(6,3) REACT, HEADER                                            
  3   FORMAT ( X, T60, 'P T O L E M ' /  T33, 'EVALUATION OF COULOMB B
     *ORN S-MATRIX ELEMENTS FOR',  ' EXTRAPOLATION' /  1X, 45A1, 22X, 65
     *A1 )                                                              
C                                                                       
      ICL2FF = NALLOC( (NMFFAC+1)/FACFR4, 'FF2INTS ' )                  
      CALL INIT4 ( ICL2FF, 0. )                                         
      IDELSR = NALLOC( NASPLI*NUMLIS, 'DELTASR ' )                      
      IDELSI = NALLOC( NASPLI*NUMLIS, 'DELTASI ' )                      
C                                                                       
      MAXDL1 = MAX0(2, MXLXGS)                                          
      LDLDIM = MAXDL1 + 1                                               
      LMXMX = LOMOST                                                    
      LMNMN1 = MAX0( LMIN-MAXDL1, 0 )                                   
      IDIM1 = LDLDIM*(2*(LMXMX-LMNMN1)+1)                               
      IWRKFF = NALLOC( IDIM1, 'FFWORK ' )                               
      IDIM2 = MAX0( LMXMX+MAXDL1, 4*MXCOUL ) + 1                        
      IWRKFI = NALLOC( 4*IDIM2, 'FIWORK ' )                             
      IWRKWK = NALLOC( MAX0(2*NPCOUL+4*MXCOUL, 2*(LMXMX+MAXDL1)+1,  2*NP
     *COUL+LMXMX+MAXDL1)+1, 'COULWORK' )                                
      IWRKST = NALLOC( 16*LDLDIM, 'COULSTRT' )                          
C                                                                       
      CALL SETLOG ( 2*(LOMOST+MAXDL1) )                                 
C                                                                       
      LBASCP = FACFR4*(Z(IBASCP)-1) + 1                                 
      MBASCP = ILLOC(LBASCP+1)                                          
      LBASCP = LBASCP + ILLOC(LBASCP+2)                                 
C                                                                       
      LBASDF = FACFR4*(Z(IBASDF)-1) + 1                                 
      MBASDF = ILLOC(LBASDF+1)                                          
      LBASDF = LBASDF + ILLOC(LBASDF+2)                                 
C                                                                       
      LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      MCHNDF = ILLOC(LCHNDF+1)                                          
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2)                                 
C                                                                       
      LBINDX = FACFR4*(Z(IBINDX)-1) + 1                                 
      LCL2FF = FACFR4*(Z(ICL2FF)-1) + 1                                 
      LSIG1 = Z(ISIGS(1))                                               
      LSIG2 = Z(ISIGS(2))                                               
C                                                                       
C     MOVE COMPUTED S-MATRICES IN TO DELTA ARRAY                        
C                                                                       
      LDELSR = Z(IDELSR)                                                
      LDELSI = Z(IDELSI)                                                
      II = NASPLI*NUMLIS                                                
      DO 159 I = 1, II                                                  
      ALLOC(LDELSR+I-1) = ALLOC(Z(ISMATR)+I-1)                          
      ALLOC(LDELSI+I-1) = ALLOC(Z(ISMATI)+I-1)                          
 159  CONTINUE                                                          
C                                                                       
      CALL SETBFC ( NBINDX, MBINDX, ILLOC(LBINDX),  MCHNDF, ILLOC(LCHNDF
     *), ALLOC4(LCHNDF), NUMJS, 2*LMIN,  R2S, LMXMX, ALLOC(LSIG1), ALLOC
     *(LSIG2),  0.D0, .FALSE., 1, NMFFAC, ALLOC4(LCL2FF),  ALLOC(Z(IWRKF
     *F)), IDIM1, LDLDIM, ALLOC(Z(IWRKWK)),  ALLOC(Z(IWRKFI)), IDIM2, AL
     *LOC(Z(IWRKST)), IRET)                                    
      IF ( IRET .NE. 0 ) GO TO 9960                                     
C                                                                       
      Z(IWRKFF) = -Z(IWRKFF)                                            
      Z(IWRKFI) = -Z(IWRKFI)                                            
      Z(IWRKWK) = -Z(IWRKWK)                                            
      Z(IWRKST) = -Z(IWRKST)                                            
C                                                                       
C     NOW CONVERT FF2 INTS TO THE COMPLETE BORN S-MATRIX                
C     AND SUBTRACT FROM C.C. VALUES                                     
C                                                                       
      CALL SETBRN ( NBINDX, MBINDX, ILLOC(LBINDX),  MCHNDF, ILLOC(LCHNDF
     *), MBASDF, ILLOC(LBASDF),  MBASCP, ILLOC(LBASCP), ALLOC4(LBASCP), 
     * NUMLIS, ALLOC(Z(ILIS)), 2*LMIN,  ALLOC4(LCL2FF), ALLOC(Z(IINDXS))
     *,  ALLOC(LDELSR), ALLOC(LDELSI) )                                 
C                                                                       
      RETURN                                                            
C                                                                       
 9960 WRITE(6,9963)                                                        
 9963 FORMAT ( ' **** ERROR IN SETBFC' )                                
      IRTN = 0                                                          
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE FITEL(IRET)                                            
C                                                                       
C  ELASTIC FITTER - SETUP WORK AREA AND WAVELJ VALUES FOR FIT           
C                                                                       
C                                                                       
C   THIS ROUTINE MAY CHANGE SOME VALUES IN TH E COMMON FLOAT            
C   RI0,ELAB,E,ETC  MAY BE CHANGED                                      
C                                                                       
C                                                                       
C     IFITER DETERMINS WHICH FITTER TO USE:                             
C      1 - POWELL65 - AMD ROUTINE VA02A                                 
C      2 - ROCORD - THE MINROD VERSION OF PIEPER'S ROCORD.              
C      3 - OCOPTR - FROM MINPACK.                                       
C      4 - LMGENV - DLSMIN FROM MINPACK = VA05A OF HARWELL              
C      5 - CHECKDERIV - CHECK THE SEMI-ANALYTIC DERIVATIVES - NO FIT.   
C      6 - LMCHOL - LEAST SQUARES WITH ANALYTIC DERIVATIVES.            
C      7 - MINIM - DAVIDON AND FLETCHER-DAVIDON FITTERS.                
C      8 - QUAVER - STRAIGHT JTJ TYPE FITTER.                           
C      9 - DAVIDON - ORIGINAL AMD VERSION OF DAVIDON ( Z013S ).         
C                                                                       
C   8/17/75   FIRST VERSION   D.G.                                      
C     10/1/75 - MERGE IN TO SEPT. PTOLEMY - S.P.                        
C     10/10/75 - USE MINROD INPLACE OF ROCORD                           
C     10/12/75 - TABLE OF SIN/COS(SIGMA); ALLOW THINGS DEFINED AFTER FIT
C     10/15/75 - ENERGY DEPENDENT LMIN/LMAX AND STEPSIZE.               
C     10/20/75 - MORE FITTERS ADDED                                     
C     10/23/75 - MAXITE CHANGED TO MAXFUN                               
C     10/29/75 - WORK AREAS FOR GRADIENT CALCULATION                    
C     11/6/75 - SPLIT INTO TWO PIECES - FITEL AND FITEL2                
C     12/28/75 - CHECK FOR UNDEFINED DATA                               
C     1/15/76 - ADD MINIM, QUAVER, DAVIDON                              
C     7/31/76 - DATA ARRAY IS ALL REAL*4                                
C     4/14/77 - EXPANDED DATA ARRAY; MAKE DATA STANDARD HERE            
C     4/20/77 - RENORM AND SHIFT MAY BE FIT                             
C     4/26/77 - IDENTICAL PARTICLES                                     
C     11/22/77 - CHANGES FOR NEW WAVSET, WAVPOT - S.P.                  
C     12/1/77 - SAVE STUFF FOR LINKULES; NEW LCRIT - S.P.               
C     4/24/78 - REVERSE LOMOST FOR LIMOST - S.P.                        
C     5/4/79 - RATMAS, MASS EXCESS IN DATA - S.P.                       
C     12/27/79 - STANDARD MORTRAN - RPG                                 
C     5/3/82 - ALLOW FOR ECM IN INPUT - S.P.                            
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
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 )                                                   
      REAL*8 FLOATK(1)                                                   
      EQUIVALENCE ( FLOATK(1), A )                                       
C                                                                       
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      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                      
      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 / TEMPVS / TVR, TVI, TVSOR, TVSOI, TAR, TAI                
      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
     *) )                                                               
      REAL*4 TBEGIN, TIMES                                              
      COMMON /FTIME/ TBEGIN, NUMLOP, NUMWAV, TIMES(6), NUMCAL, NUMGRA   
      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    
      REAL*4 T0                                                         
      COMMON /FITCOM/ T0, IP, IPL, IEPARM, IFS, MAXCAL, NROC, ISCSIG    
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
C                                                                       
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      INTEGER REACT4(11)                                                
      EQUIVALENCE ( REACT4(1), REACT(1) )                               
C                                                                       
      CHARACTER*8 FITERS(14), STATWD(3), ANGLWD(2), SIGMWD(3), ERRWD(3) 
      DATA FITERS / 'POWELL65', 'ROCORD','OCOPTR','LMGENV','CHECKDER', 
     *'LMCHOL', 'MINIM', 'QUAVER', 'DAVIDON',  'FITTER10', 'FITTER11',
     *'FITTER12', 'FITTER13', 'FITTER14' /                            
C                                                                       
      DATA IBLANK / ' ' /                                               
      LOGICAL PRTSW, ERRSW, SIGMSW, ANGLSW                              
C                                                                       
      DATA STATWD / 'BOSE', 'FERMI', 'NONE' /                           
      DATA ANGLWD / 'C.M.', 'LAB.' /                                    
      DATA SIGMWD / '/RUTHER', 'C.M.(MB)', 'LAB.(MB)' /                 
      DATA ERRWD / ' MB', '  %', 'UNITS' /                              
C                                                                       
      DO 1 I=1, 6                                                       
1     TIMES(I)=0                                                        
      NUMCAL = 0                                                        
      NUMGRA = 0                                                        
      NUMLOP = 0                                                        
C                                                                       
      IP=NAMLOC('PARAMETE')                                             
      IF(IP.EQ.0)GO TO 900                                              
      IDATA=NAMLOC('DATA ')                                             
      IF ( IDATA .EQ. 0 ) GO TO 902                                     
      IEQUAL=NAMLOC('EQUAL ')                                           
      IMASK=NAMLOC('MASK ')                                             
C                                                                       
      NPARA=LENG(IP)                                                    
C                                                                       
      LDATA4 = FACFR4*(Z(IDATA)-1) + 1                                  
      NPTS=ILLOC(LDATA4)                                                
      IESETS=ILLOC(LDATA4+1)                                            
      LENPRE = ILLOC(LDATA4+2)                                          
      LENKEY = ILLOC(LDATA4+3)                                          
      LENHED = ILLOC(LDATA4+4)                                          
      IFS=NALLOC(NPTS,'EXPMINTH')                                       
C                                                                       
      MAXCAL = MAXFUN                                                   
      IF ( IREINI .NE. 0 ) MAXCAL = MIN0( MAXFUN,  MAX0( (NPARA*IREINI)/
     *3, 3*NPARA ) )                                                    
C                                                                       
C  MAXITER KEYWORD NOW USED FOR FIRST ROCORD CALL                       
C     WHEN FLETPOW IS TO FOLLOW                                         
      NROC=MAXFUN                                                       
      IF(IREINI.NE.0)NROC=MAXITR                                        
C                                                                       
C                                                                       
      WRITE(6,5)                                                        
5     FORMAT(X,T48,'P T O L E M Y')                                   
      IWORDS=NAMLOC('FITWORDS')                                         
      WRITE(6,6)(ALLOC(Z(IWORDS)+I-1),I=1,NPARA)                        
6     FORMAT(10X,' ELASTIC SCATTERING FIT',T75,'FITTING:', ( T85,6A8 ) )
      WRITE(6,7) HEADER                                                   
 7    FORMAT ( 65X, 65A1 )                                              
C                                                                       
      WRITE(6,13) FITERS(IFITER)                                          
 13   FORMAT ( / ' THE ', A8, ' MINIMIZER IS BEING USED.' / )           
C                                                                       
C     CHECK THAT ALL FIT PARAMETERS WERE INITIALIZED                    
C     AND INITIALIZE THE PARAMETER VECTOR                               
C                                                                       
      LMASK = FACFR4*(Z(IMASK)-1)                                       
      LDATA4 = FACFR4*(Z(IDATA)-1)+1                                    
      DO 39 I = 1, NPARA                                                
      KEY = ILLOC(LMASK+I)                                              
      IF ( KEY .LT. 0 ) GO TO 25                                        
      TEMP = FLOATK(KEY)                                                 
      GO TO 35                                                          
C     FITTING TO RENORM OR SHIFT                                        
 25   ISET = MOD( -KEY/10000, 100 )                                     
      KEY = -KEY/100 0000                                               
      IF ( KEY .EQ. 1 .AND. IFITER .GE. 5 ) GO TO 935                   
      IF ( ISET .GT. IESETS ) GO TO 930                                 
      LEKEY = LDATA4 + LENPRE-1                                         
      LEHED = LEKEY + LENKEY+1                                          
      IDTSET = 1                                                        
 30   IF ( IDTSET .EQ. ISET ) GO TO 32                                  
      IDTSET = IDTSET + 1                                               
      LEKEY = LEKEY + LENKEY+LENHED + ILLOC(LEHED)*ILLOC(LEKEY+5)       
      LEHED = LEKEY + LENKEY+1                                          
      GO TO 30                                                          
 32   K = LEHED+2+KEY                                                   
      KEY = K-LDATA4 + 10000*(ISET +100*KEY)                            
      TEMP = ALLOC4(K)                                                  
      ILLOC(LMASK+I) = -KEY                                             
C                                                                       
 35   ALLOC(Z(IP)-1+I) = TEMP                                           
      IF ( TEMP .EQ. UNDEF ) GO TO 914                                  
 39   CONTINUE                                                          
C                                                                       
C     INITIALIZE THE "=" ASSIGNMENTS TO THE FIRST GUY OF THE CHAIN      
C                                                                       
      LEQUAL = FACFR4*(Z(IEQUAL)-1) + 1                                 
 40   IMANY = ILLOC(LEQUAL)                                             
      IF ( IMANY .LE. 0 ) GO TO 100                                     
      IMANY = IMANY + 1                                                 
      DO 59 I = 1, IMANY                                                
      KEY = ILLOC(LEQUAL+I)                                             
      IF ( KEY .GT. 0 ) GO TO 55                                        
C     FITTING TO RENORM OR SHIFT                                        
      ISET = MOD( -KEY/10000, 100 )                                     
      KEY = -KEY/100 0000                                               
      IF ( KEY .EQ. 1 .AND. IFITER .GE. 5 ) GO TO 935                   
      IF ( ISET .GT. IESETS ) GO TO 930                                 
      LEKEY = LDATA4 + LENPRE-1                                         
      LEHED = LEKEY + LENKEY+1                                          
      IDTSET = 1                                                        
 45   IF ( IDTSET .EQ. ISET ) GO TO 47                                  
      IDTSET = IDTSET + 1                                               
      LEKEY = LEKEY + LENKEY+LENHED + ILLOC(LEHED)*ILLOC(LEKEY+5)       
      LEHED = LEKEY + LENKEY+1                                          
      GO TO 45                                                          
 47   K = LEHED+2+KEY                                                   
      KEY = K-LDATA4 + 10000*(ISET +100*KEY)                            
      ILLOC(LEQUAL+I) = -KEY                                            
      IF ( I .EQ. 1 ) TEMP = ALLOC4(K)                                  
      ALLOC4(K) = TEMP                                                  
      GO TO 59                                                          
C                                                                       
 55   IF ( I .EQ. 1 ) TEMP = FLOATK(KEY)                                 
      FLOATK(KEY) = TEMP                                                 
 59   CONTINUE                                                          
C                                                                       
      LEQUAL = LEQUAL + IMANY+ 1                                        
      GO TO 40                                                          
C                                                                       
C     INITIALIZE FOR WAVELJ                                             
C                                                                       
 100  ICHANW=1                                                          
      NUMFIT = IESETS                                                   
C                                                                       
C     LOOP THROUGH THE DATA ARRAY.                                      
C     ADD CHANNEL AND ELAB SPECIFICATIONS IF NOT THERE                  
C     CONVERT ELAB TO ECM                                               
C                                                                       
C     FIND THOSE PARAMETERS (LMIN, LMAX, STEPSIZE) THAT MIGHT DEPEND    
C     ON ELAB.  THESE ARE NOW FOUND AND STORED FOR EACH ELAB.           
C                                                                       
C     WE STORE MOST MAXIMUM LMAX IN LOMOST;  AND MOST MAXIMUM NSTEP     
C     IN NSTPSS(2).                                                     
C                                                                       
      LOMOST = 0                                                        
      NSTPSS(2) = 0                                                     
      LLMIN = LMIN                                                      
      LLMAX = LMAX                                                      
      IESIZE = 7 + 4/FACFR4                                             
      IEPARM = NALLOC( IESIZE*IESETS, 'EPARAMS ' )                      
      ILNKBL = NALLOC( (3*NUMLNK*IESETS+FACFR4-1)/FACFR4, 'LNKBLKS ' )  
      ICNT = LENPRE                                                     
      WRITE(6,113)                                                          
 113  FORMAT ('   ELAB', 5X, 'ECM', 5X, 'LMIN', 3X, 'LMAX',  5X, 'STEPSI
     *ZE',  5X, 'ASYMPTOPIA', 4X, 'STATISTICS', 4X, 'CHANNEL' / )       
C                                                                       
      DO 159 IOFFIT = 1, IESETS                                         
      LEKEY = FACFR4*(Z(IDATA)-1) + ICNT                                
      LEHED = LEKEY + LENKEY+1                                          
      TEMP = ALLOC4(LEHED+4)                                            
      IF ( TEMP .EQ. UNDEF ) GO TO 115                                  
      ELAB = UNDEF                                                      
      ECM = UNDEF                                                       
      IF ( ILLOC(LEHED+29) .EQ. 0 ) ELAB = TEMP                         
      IF ( ILLOC(LEHED+29) .EQ. 1 ) ECM = TEMP                          
 115  IF ( ILLOC(LEHED+5) .NE. NOTDEF ) IZP = ILLOC(LEHED+5)            
      ILLOC(LEHED+5) = IZP                                              
      IF ( ILLOC(LEHED+6) .NE. NOTDEF ) IZT = ILLOC(LEHED+6)            
      ILLOC(LEHED+6) = IZT                                              
      IF ( ALLOC4(LEHED+7) .NE. UNDEF ) AMP = ALLOC4(LEHED+7)           
      ALLOC4(LEHED+7) = AMP                                             
      IF ( ALLOC4(LEHED+8) .NE. UNDEF ) AMT = ALLOC4(LEHED+8)           
      ALLOC4(LEHED+8) = AMT                                             
      IF ( ALLOC4(LEHED+25) .NE. UNDEF ) AMXGPT(1) = ALLOC4(LEHED+25)   
      ALLOC4(LEHED+25) = AMXGPT(1)                                      
      IF ( ALLOC4(LEHED+26) .NE. UNDEF ) AMXGPT(2) = ALLOC4(LEHED+26)   
      ALLOC4(LEHED+26) = AMXGPT(2)                                      
      IF ( ALLOC4(LEHED+27) .NE. UNDEF ) EXSPT(1) = ALLOC4(LEHED+27)    
      ALLOC4(LEHED+27) = EXSPT(1)                                       
      IF ( ALLOC4(LEHED+28) .NE. UNDEF ) EXSPT(2) = ALLOC4(LEHED+28)    
      ALLOC4(LEHED+28) = EXSPT(2)                                       
      IF ( ILLOC(LEHED+9) .NE. IBLANK ) GO TO 120                       
      DO 119 I = 9, 19                                                  
      ILLOC(LEHED+I) = REACT4(I-8)                                      
 119  CONTINUE                                                          
C                                                                       
C     IF THE REACTION HAD NOT BEEN READ, THE STATISTICS MAY NOT BE SET  
C                                                                       
      IF ( ILLOC(LEHED+20) .EQ. NOTDEF ) ILLOC(LEHED+20) = JSP          
      IF ( ILLOC(LEHED+21) .EQ. NOTDEF ) ILLOC(LEHED+21) = JST          
C                                                                       
C     GET THE STUFF THAT SETCHN AND WAVSET NORMALLY GET                 
C     GET POTENTIAL PARAMETERS AT THIS ENERGY AND VERIFY THAT INITIAL   
C     PARAMETER VECTOR IS LEGAL.                                        
C     WE MUST FIND R0MASS, RCP, RCT, FOR EACH CHANNEL                   
C                                                                       
 120  IF ( IOFFIT .NE. 1 ) CALL CLRCHN(21)                              
      JSP = ILLOC(LEHED+20)                                             
      JST = ILLOC(LEHED+21)                                             
      CALL SETCHN(6,IRET)                                               
      IF(IRET.EQ.0)GO TO 910                                            
      CALL SETPOT ( IRET )                                              
      IF ( IRET .EQ. 0 ) GO TO 910                                      
      CALL WAVSET(IRET, .TRUE., .TRUE. )                                
      IF ( IRET .EQ. 0 ) GO TO 910                                      
      LEKEY = FACFR4*(Z(IDATA)-1) + ICNT                                
      LEHED = LEKEY + LENKEY+1                                          
      ALLOC4(LEHED+4) = ELAB                                            
      ILLOC(LEHED+29) = 0                                               
      ALLOC4(LEHED+24) = RATMAS                                         
      IF ( ILLOC(LEHED+22) .NE. 0 ) GO TO 125                           
      ILLOC(LEHED+22) = LSKIPS(1)                                       
      ILLOC(LEHED+23) = ISTATS(1)                                       
C                                                                       
C                                                                       
C     IS AUTOMATIC LMIN/LMAX BEING USED                                 
C                                                                       
 125  LCRIT = LCRITS(1)                                                 
C                                                                       
      IF ( LMIN .EQ. NOTDEF )  LLMIN = MIN0( INT(LCRIT*ALMNMT), LCRIT-LM
     *INSB )                                                            
      LLMIN = MAX0( LLMIN, 0 )                                          
      IF ( LMAX .EQ. NOTDEF )  LLMAX = MAX0( INT(LCRIT*ALMXMT), LCRIT+LM
     *AXAD )                                                            
C                                                                       
 130  LSKIP = ILLOC(LEHED+22)                                           
      ISTAT = ILLOC(LEHED+23)                                           
      IF ( LSKIP .EQ. 2 ) LLMIN = IABS( LLMIN - MOD(LLMIN,2) )          
      IF ( LSKIP .EQ. 2 ) LLMAX = LLMAX + MOD(LLMAX,2)                  
C                                                                       
      NSTEP = NSTPSS(1)                                                 
C                                                                       
C     SHOW WHAT WE CHOSE                                                
C                                                                       
      WRITE(6,143) ELAB,ECM,LLMIN,LLMAX,STEPSZ,ASYMPS(1),STATWD(ISTAT), 
     *( ILLOC(LEHED+I), I = 9, 19 )                                
 143  FORMAT ( 2F8.3, 2I7, F13.4, F15.2, 8X, A5, 6X, 11A4 )             
CDC 143     FORMAT ( 2F8.3, 2I7, F13.4, F15.2, 8X, A5, 6X, 11A1 )       
C                                                                       
      IF ( ISTAT .NE. 3 .AND. JSP .NE. 0 ) GO TO 940                    
C                                                                       
C     WE STORE STUFF FOR EACH ENERGY AS FOLLOWS                         
C                                                                       
C           IBM              CDC                                        
C     LMIN    LMAX          LMIN                                        
C     NSTEP     -           LMAX                                        
C         STEPSIZE          NSTEP                                       
C         ETA                 -                                         
C         K                 STEPSIZE                                    
C         E (C.M.)          ETA                                         
C         R0MASS            K                                           
C         RCP               E                                           
C         RCT               R0MASS                                      
C                           RCP                                         
C                           RCT                                         
C                                                                       
C     IN THE IBM COLUMN, EACH LINE IS ONE 8-BYTE UNIT.                  
C                                                                       
      LEPARM = Z(IEPARM) + IESIZE*IOFFIT - IESIZE - 1                   
      ILLOC(FACFR4*LEPARM+1) = LLMIN                                    
      ILLOC(FACFR4*LEPARM+2) = LLMAX                                    
      ILLOC(FACFR4*LEPARM+3) = NSTEP                                    
CDC      LEPARM = LEPARM + 2                                            
      ALLOC(LEPARM+3) = STEPSZ                                          
      ALLOC(LEPARM+4) = ETAS(1)                                         
      ALLOC(LEPARM+5) = AKS(1)                                          
      ALLOC(LEPARM+6) = E                                               
      ALLOC(LEPARM+7) = R0MASS                                          
      ALLOC(LEPARM+8) = RCP                                             
      ALLOC(LEPARM+9) = RCT                                             
C                                                                       
      LOMOST = MAX0( LOMOST, LLMAX )                                    
      ICNT = ICNT + LENKEY+LENHED + ILLOC(LEHED)*ILLOC(LEKEY+5)         
C                                                                       
C     SAVE LINKULE STUFF                                                
C                                                                       
      LLNKBL = Z(ILNKBL)*FACFR4-FACFR4 + 3*NUMLNK*(IOFFIT-1) - 3        
      DO 149 I = 1, NUMLNK                                              
      DO 149 II = 1, 3                                                  
      ILLOC(LLNKBL+3*I+II) = LNKADR(3+II,I)                             
 149  CONTINUE                                                          
C                                                                       
 159  CONTINUE                                                          
C                                                                       
C  ALLOCATE PLM AND SIN/COS(SIGMA) SPACE                                
C                                                                       
      IPL=NALLOC(LOMOST+1, 'PL ' )                                      
      ISCSIG = NALLOC( 2*IESETS*(LOMOST+1), 'SINCOSSG' )                
C                                                                       
C     LOOP OVER ALL ELABS AND GET COULOMB WAVEFUNCS AND SIGMAS          
C                                                                       
      DO 179 IOFFIT = 1, NUMFIT                                         
      LEPARM = Z(IEPARM) - 1 + IESIZE*(IOFFIT-1)                        
      LLMAX = ILLOC(FACFR4*LEPARM+2)                                    
      NSTPSS(1) = ILLOC(FACFR4*LEPARM+3)                                
CDC      LEPARM = LEPARM+2                                              
      RSTEPS(1) = ALLOC(LEPARM+3)                                       
      ETAS(1) = ALLOC(LEPARM+4)                                         
      AKS(1) = ALLOC(LEPARM+5)                                          
      HS(1)=AKS(1)*RSTEPS(1)                                            
      ES(1) = ALLOC(LEPARM+6)                                           
      CALL WAVPOT ( IRET )                                              
      IF ( IRET .EQ. 0 ) GO TO 910                                      
      LSIG = Z(ISIGS(1)) + (IOFFIT-1)*(LOMOST+1)                        
      LSC = Z(ISCSIG) + (IOFFIT-1)*(LOMOST+1)*2                         
      IZERO = 0                                                         
      DO 169 LL = IZERO, LLMAX                                          
      SIGMA = 2*ALLOC(LSIG+LL)                                          
      ALLOC(LSC+2*LL) = DSIN(SIGMA)                                     
      ALLOC(LSC+2*LL+1) = DCOS(SIGMA)                                   
 169  CONTINUE                                                          
C                                                                       
 179  CONTINUE                                                          
C                                                                       
C     CONVERT DATA INTO STANDARD FORM OF                                
C        C.M. ANGLE,  C.M. SIGMA (MB),  % ERROR                         
C                                                                       
      LEKEY = FACFR4*(Z(IDATA)-1) + LENPRE                              
C                                                                       
      DO 499 IE = 1, IESETS                                             
C                                                                       
      LEHED = LEKEY + LENKEY+1                                          
      LADATA = LEHED + LENHED                                           
      LEPARM = Z(IEPARM) + IESIZE*(IE-1) - 1                            
CDC         LEPARM = LEPARM + 2                                         
      NPTSE = ILLOC(LEHED)                                              
      ERRSW = ILLOC(LEKEY+1) .NE. 1                                     
      SIGMSW = ILLOC(LEKEY+2) .NE. 1                                    
      ANGLSW = ILLOC(LEKEY+4) .NE. 0                                    
      LENDAT = ILLOC(LEKEY+5)                                           
      PRTSW = ANGLSW .OR. ERRSW .OR. ILLOC(LEKEY+2) .GE. 2              
      IF ( .NOT. (PRTSW .OR. SIGMSW) ) GO TO 490                        
      PRTSW = PRTSW .AND. MOD(IPRINT/10 000, 10) .GE. 1                 
C                                                                       
C     MUST DO A CONVERSION                                              
C                                                                       
      ELAB = ALLOC4(LEHED+4)                                            
      RATMAS = ALLOC4(LEHED+7)/ALLOC4(LEHED+8)                          
      ETA = ALLOC(LEPARM+4)                                             
      RUTHFC = 10 * (.5*ETA/ALLOC(LEPARM+5))**2                         
      ISTAT = ILLOC(LEHED+23)                                           
      IERR = ILLOC(LEKEY+1) + 1                                         
      ISIGM = ILLOC(LEKEY+2) + 1                                        
      IANGL = ILLOC(LEKEY+4) + 1                                        
C                                                                       
      IF ( PRTSW ) WRITE(6,403) IE, ELAB, ANGLWD(IANGL), SIGMWD(ISIGM), 
     *ERRWD(IERR)                                                        
 403  FORMAT ( / ' CONVERSION OF DATA TO STANDARD FORM FOR',' DATA SET
     *', I3, ',  ELAB =', F6.1 /  7X, '(ANGLESHIFT AND RENORMALIZAT
     *ION NOT INCLUDED)' /  X, T14, 'INPUT VALUES', T57, 'STANDARD FOR
     *M' /  2( 5X, 'ANGLE', 6X, 'SIGMA', 10X, 'ERROR', 9X ) /  6X, A8, 1
     *X, A8, 8X, A8, 12X, 'C.M.', 5X, '/RUTHER',  9X, '  %' / )         
 407  FORMAT ( 2 ( F10.2, G15.4, G15.4, 5X ) )                          
C                                                                       
      ILLOC(LEKEY+1) = 1                                                
      ILLOC(LEKEY+2) = 1                                                
      ILLOC(LEKEY+4) = 0                                                
C                                                                       
      DO 479 IANG = 1, NPTSE                                            
      ANGLIN = ALLOC4(LADATA)                                           
      ANGLE = ANGLIN*DEGREE                                             
      ANGLOT = ANGLIN                                                   
      ERRIN = ALLOC4(LADATA+1)                                          
      ERROT = ERRIN                                                     
      SIGMIN = ALLOC4(LADATA+2)                                         
      SIGMOT = SIGMIN                                                   
C                                                                       
      GO TO ( 430, 425 ), IANGL                                         
C     CONVERT LAB ANGLE                                                 
 425  TEMP = 1 - (RATMAS*DSIN(ANGLE))**2                                
      IF ( TEMP .LT. 0 ) TEMP = 0                                       
      TEMP = DSQRT(TEMP)                                                
      IF ( ANGLE .LT. 0 ) TEMP = -TEMP                                  
      ANGLE = ACOS( DCOS(ANGLE)*TEMP - RATMAS*DSIN(ANGLE)**2 )          
      ANGLOT = RADIAN*ANGLE                                             
C                                                                       
 430  RUTH = 1                                                          
      IF ( ISTAT .NE. 3 ) RUTH = 1 + TAN(.5*ANGLE)**2 *  ( TAN(.5*ANGLE)
     ***2  + 2*COS(2*ETA*DLOG(TAN(.5*ANGLE))) )                         
      RUTH = RUTHFC * RUTH/SIN(.5*ANGLE)**4                             

      IF ( RUTH .EQ. 0 ) RUTH = 1                                       
      GO TO ( 432, 440, 434 ), ISIGM                                    
C     SIG/RUTH                                                          
 432  SIGMOT = RUTH*SIGMIN                                              
      GO TO 440                                                         
C     LAB SIGMA                                                         
 434  TEMP = 1 + RATMAS*(RATMAS + 2*DCOS(ANGLE))                        
      AJACOB = (1+RATMAS*DCOS(ANGLE)) / (TEMP*DSQRT(TEMP))              
      SIGMOT = AJACOB*SIGMIN                                            
C                                                                       
 440  GO TO ( 442, 450, 444 ), IERR                                     
C     MB ERROR                                                          
 442  ERROT = 100*ERRIN/SIGMOT                                          
      IF ( ISIGM .EQ. 3 ) ERROT = ERROT*AJACOB                          
      GO TO 450                                                         
C     SAME UNITS AS SIGMA                                               
 444  ERROT = 100*ERRIN/SIGMIN                                          
C                                                                       
 450  CONTINUE                                                          
C                                                                       
      RUTH = SIGMOT/RUTH                                                
      IF ( PRTSW ) WRITE(6,407) ANGLIN,SIGMIN,ERRIN,ANGLOT,RUTH,ERROT
      ALLOC4(LADATA) = ANGLOT                                           
      ALLOC4(LADATA+1) = ERROT                                          
      ALLOC4(LADATA+2) = SIGMOT                                         
C                                                                       
      LADATA = LADATA + LENDAT                                          
C                                                                       
 479  CONTINUE                                                          
C                                                                       
C     NEXT SET                                                          
C                                                                       
 490  LEKEY = LEKEY + LENKEY+LENHED + NPTSE*LENDAT                      
 499  CONTINUE                                                          
C                                                                       
      IRET = 1                                                          
C                                                                       
      RETURN                                                            
C                                                                       
900   WRITE(6,901)                                                      
901   FORMAT ( '0**** PARAMETER VECTOR LOST')                           
      GO TO 990                                                         
 902  WRITE(6,903)                                                         
 903  FORMAT ( '0**** DATA MUST BE DEFINED FOR FIT' )                   
      GO TO 990                                                         
910   WRITE(6,911)                                                      
911   FORMAT ( '0**** ALL PARAMETERS MUST BE DEFINED BEFORE WE FIT')    
      GO TO 990                                                         
 914  WRITE(6,915)                                                         
 915  FORMAT ( '0**** ALL FIT PARAMETERS MUST BE INITIALIZED.' )        
      GO TO 990                                                         
C                                                                       
C                                                                       
 930  WRITE(6,933) ISET, IESETS                                           
 933  FORMAT ( '0*** ERROR:  ATTEMPTING TO FIT RENORM OR ANGLE',  ' SHIF
     *T FOR DATA SET', I3, ' BUT THERE ARE ONLY',  I3, ' DATA SETS' )   
      GO TO 990                                                         
 935  WRITE(6,937)                                                         
 937  FORMAT ( '0*** CANNOT VARY LAB ANGLE SHIFT WITH A MINIMIZER',  ' T
     *HAT REQUIRES DERIVATIVES -' /  '     USE POWELL65 OR ROCORD.' )   
      GO TO 990                                                         
C                                                                       
 940  WRITE(6,943)                                                         
 943  FORMAT ( ' **** ERROR:  FOR NOW WE CAN FIT ONLY SPIN 0',  ' IDENTI
     *CAL PARTICLES.' )                                                 
      GO TO 990                                                         
C                                                                       
 990  IRET = 0                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE FITEL2 (IRET)                                          
C                                                                       
C  ELASTIC FITTER - SELECT METHOD OF FITTING AND DO IT                  
C                                                                       
C                                                                       
C   THIS ROUTINE MAY CHANGE SOME VALUES IN TH E COMMON FLOAT            
C   RI0,ELAB,E,ETC  MAY BE CHANGED                                      
C                                                                       
C                                                                       
C     IFITER DETERMINS WHICH FITTER TO USE:                             
C      1 - POWELL65 - AMD ROUTINE VA02A                                 
C      2 - ROCORD - THE MINROD VERSION OF PIEPER'S ROCORD.              
C      3 - OCOPTR - FROM MINPACK.                                       
C      4 - LMGENV - DLSMIN FROM MINPACK = VA05A OF HARWELL              
C      5 - DERIVCHECK - CHECK THE SEMI-ANALYTIC DERIVATIVES - NO FIT.   
C      6 - LMCHOL - LEAST SQUARES WITH ANALYTIC DERIVATIVES.            
C      7 - MINIM : DAVIDON FITTER                                       
C      8 - QUAVER - JTJ TYPE FIT WITH OPTIONAL LINEAR SEARCH            
C      9 - DAVIDON - AMD VERSION OF DAVIDON  ( Z013S = VMMIN )          
C                                                                       
C     THE FOLLOWING ARE KEYWORDS FOR THE FITTERS:                       
C                                                                       
C     KEYWORD (COMMON NAME) (DEFAULT VALUE)                             
C                                                                       
C     FITACCURACY (FITACC) (.001) - FOR ALL FITTERS THIS IS THE         
C          RELATIVE ACCURACY WITH WHICH EACH PARAMETER IS TO BE FOUND.  
C          DERIVCHECK: THE STEPSIZE FOR THE NUMERICAL DERIVATIVES       
C                                                                       
C     FITMULTIPLE (FITMUL) (500)                                        
C        VA02A - MAXIMUM RELATIVE STEP ALLOWED IS FITMUL*FITACC         
C        OCOPTR - (FL0) SHOULD BE ABOUT 3.                              
C        LMGENV -                                                       
C        MINIM, QUAVER - STEP IS REDUCED BY FITMUL WHEN IT RESULTS      
C            IN A LARGER FUNCTION VALUE.  ALSO THE SIGN AND MAGNITUDE   
C            DETERMIN THE METHOD OF FITTING.  IF > 100, 5 IS USED.      
C        VMMIN - IF 0 OR >100, JTJ IS USED AS INITIAL METRIC; ELSE      
C            FITMUL*(UNIT MAT) IS THE INITIAL METRIC.                   
C                                                                       
C     FITRATIO (FITRAT) (.0001) -                                       
C        OCOPTR - ABSOLUTE STEPSIZE FOR GRADIENT CALCULATIONS           
C        LMGENV - STEP SIZE FOR INITIAL NUMERIC DERIVATIVES.            
C        QUAVER - RATIO OF MINIMUM USED SINGULAR VALUE TO THE LARGEST   
C            SINGULAR VALUE.                                            
C                                                                       
C     FITMODE (MODEFT) (1) -                                            
C        LMCHOL - DETERMINS HOW THE MARQUEDT SCALLING ARRAY IS CHOSEN.  
C        ROCORD - INITIAL VALUE OF IRET                                 
C        SECDER - 1 MEANS FIRST DERIV CHECK, 2 IS 2ND DERIV.            
C                                                                       
C     NUMRANDOM (NUMRAN) (0)                                            
C        ROCORD AND VMMIN - NUMBER OF RANDOM STEPS USED TO COMFIRM MINIM
C                                                                       
C     DERIVSTEP (DERIVS) (1E-6) - FOR ALL FITTERS THAT REQUIRE GRADIENTS
C        THIS IS THE RELATIVE STEP USED IN COMPUTING THE GRADIENT       
C        OF THE POTENTIALS.                                             
C                                                                       
C                                                                       
C                                                                       
C   8/17/75   FIRST VERSION   D.G.                                      
C     10/1/75 - MERGE IN TO SEPT. PTOLEMY - S.P.                        
C     10/10/75 - USE MINROD INPLACE OF ROCORD                           
C     10/12/75 - TABLE OF SIN/COS(SIGMA); ALLOW THINGS DEFINED AFTER FIT
C     10/15/75 - ENERGY DEPENDENT LMIN/LMAX AND STEPSIZE.               
C     10/20/75 - MORE FITTERS ADDED                                     
C     10/23/75 - MAXITE CHANGED TO MAXFUN                               
C     10/29/75 - WORK AREAS FOR GRADIENT CALCULATION                    
C     2/14/78 - NUMERICAL DERIVATIVES (KEY >= 4)                        
C                                                                       
C     11/6/75 - SPLIT INTO TWO PIECES - FITEL AND FITEL2                
C     12/28/75 - ADD PRTDER CALL                                        
C     1/5/76 - ADD MINIM                                                
C     1/8/76 - ADD QUAVER                                               
C     1/14/76 - ADD VMMIN = AMD VERSION OF DAVIDON                      
C     1/22/76 - CHANGES TO VA02A                                        
C     1/29/76 - DERIVCHECK CHANGES                                      
C     7/31/76 - REMOVE SOME FITTERS.                                    
C     4/20/77 - RENORM AND SHIFT MAY BE FIT                             
C     2/78 - NUMERIC DERIVATIVES FOR NON-POTENTIAL PARAMS - S.P.        
C     4/7/78 - SAVE COVARIEANCE EIGENVALS AND VECS - S.P.               
C     4/24/78 - REVERSE LOMOST FOR LIMOST - S.P.                        
C     6/12/79 - CMS VERSION DOES NOT HAVE MINROD - S.P.                 
C     4/3/81 - REMOVE ROCORD - S.P.                                     
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      LOGICAL*4 ALONSW                                                  
      DATA ALONSW / .TRUE. /                                            
C                                                                       
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
C                                                                       
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      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                      
      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
     *) )                                                               
      REAL*4 TBEGIN, TIMES                                              
      COMMON /FTIME/ TBEGIN, NUMLOP, NUMWAV, TIMES(6), NUMCAL, NUMGRA   
      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    
      REAL*4 T0                                                         
      COMMON /FITCOM/ T0, IP, IPL, IEPARM, IFS, MAXCAL, NROC, ISCSIG    
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
C                                                                       
C     FOLLOWING ARE THE FUNCTION ROUTINES FOR OCOPTR AND LMGENV         
C                                                                       
CXX      EXTERNAL  OCOFCN, DLSFCN                                       
      EXTERNAL LMCFUN                                                   
      EXTERNAL MINMON                                                   
C                                                                       
      REAL*4 T1                                                         
C                                                                       
      LOGICAL GRADSW, HESNSW                                            
C                                                                       
      IPRT = MOD(IPRINT, 10)                                            
C                                                                       
C                                                                       
C     ALLOCATE THE WORK AREAS SPECIFIC TO EACH FITTER                   
C                                                                       
      GRADSW = .FALSE.                                                  
      HESNSW = .FALSE.                                                  
      GO TO ( 220, 240, 300, 350, 375, 400, 425, 425, 425 ) , IFITER    
C                                                                       
C     ALLOCATE WORK AREA ( W )  FOR POWELL65                            
C                                                                       
 220  I = (NPARA+1)*(NPTS+NPARA+1) + ((NPARA+1)*NPARA)/2                
      IWORK = NALLOC( I, 'POWELL ' )                                    
      GO TO 490                                                         
C                                                                       
CXXC     ALLOCATE AREAS FOR ROCORD/MINROD                               
CXXC                                                                    
CXX 240  IUP=NAMLOC('UPPERB ')                                          
CXX      IF(IUP.NE.0)GO TO 260                                          
CXX      IUP=NALLOC(NPARA,'UPPERB ')                                    
CXXC                                                                    
CXXC  DEFAULT UPPER BOUND                                               
CXXC                                                                    
CXX      DO 249 I=1,NPARA                                               
CXX         TEMP = 100*DABS( ALLOC(Z(IP)-1+I) )                         
CXX         IF ( TEMP .EQ. 0 )  TEMP = 1                                
CXX         ALLOC(Z(IUP)-1+I) = TEMP                                    
CXX 249  CONTINUE                                                       
CXX 260  IDO=NAMLOC('LOWERB ')                                          
CXX      IF(IDO.NE.0)GO TO 280                                          
CXX      IDO=NALLOC(NPARA,'LOWERB ')                                    
CXXC                                                                    
CXXC  DEFALUT LOWER BOUND                                               
CXXC                                                                    
CXX      DO 269 I=1,NPARA                                               
CXX 269  ALLOC(Z(IDO)+I-1) = -ALLOC(Z(IUP)-1+I)                         
CXXC                                                                    
CXXC     FOR NOW WE DO NOT PUT THE ROBLK INTO THE ALLOCATOR             
CXXC                                                                    
CXX 280  IWORK = 0                                                      
CXX      IF ( IREINI .NE. 0 )  GO TO 220                                
CXX      GO TO 500                                                      
 240  GO TO 300                                                         
C                                                                       
C                                                                       
CXXC     WORK AREAS FOR  OCOPTR                                         
CXXC                                                                    
CXX 300  IX0 = NALLOC( NPARA, 'OCOPTRX0' )                              
CXX      IWORK = NALLOC( NPARA**2, 'OCOPTR ' )                          
CXX      LWORK = Z(IWORK) - 1                                           
CXX      IPARA = Z(IP)-1                                                
CXX      DO 329  I = 1, NPARA                                           
CXX         DO 325  II = 1, NPARA                                       
CXX            ALLOC(LWORK+(I-1)*NPARA+II) = 0                          
CXX 325     CONTINUE                                                    
CXX         TEMP = DSQRT( DABS(ALLOC(IPARA+I)) )                        
CXX         IF ( TEMP .EQ. 0 )  TEMP = FITACC                           
CXX         ALLOC(LWORK+(I-1)*NPARA+I) = TEMP                           
CXX 329  CONTINUE                                                       
CXX      GO TO 500                                                      
CXXC                                                                    
CXXC     WORK AREAS FOR LMGENV                                          
CXXC                                                                    
CXX 350  I = 2*NPTS*(NPARA+1) + NPARA*(2*NPARA+5)                       
CXX      IWORK = NALLOC( I, 'DLSMIN ' )                                 
CXX      GO TO 500                                                      
C                                                                       
C     DERIVCHECK CHECKS THE SEMI-ANALYTIC DERIVATIVES                   
C     OR IT COMPUTES THE COMPLETE SECOND DERIVATIVE MATRIX              
C                                                                       
 375  I = NPARA*( 2*NPARA + 2*NPTS + 1 ) + NPTS                         
      IWORK = NALLOC( I, 'DERIVCHE' )                                   
      GO TO 475                                                         
 300  WRITE(6,303)                                                         
 303  FORMAT ( '0**** THE CHOSEN FITTER IS NOT AVAILABLE IN',  ' THIS VE
     *RSION OF PTOLEMY.' )                                              
      IRET = 0                                                          
      RETURN                                                            
 350  GO TO 300                                                         
C                                                                       
C     LMCHOL - A LEAST SQUARES FITTER WITH DERIVATIVES                  
C                                                                       
 400  I = NPTS + 4*NPARA                                                
      IWORK = NALLOC( I, 'LMCHOL ' )                                    
      GO TO 475                                                         
C                                                                       
C     MINIM - DAVIDON-FLETCHER TYPE FITTER; QUAVER - JTJ;               
C     VMMIN - ORIGINAL DAVIDON                                          
C                                                                       
 425  I = 6*NPARA                                                       
      IWORK = NALLOC( I, 'DAVIDON ' )                                   
      GO TO 475                                                         
C                                                                       
C     THE FITTER WILL WANT ANALYTIC DERIVATIVES - GET WORK AREAS        
C                                                                       
 475  IDVTYP = NAMLOC('DERIVTYP')                                       
      IF ( IDVTYP .EQ. 0 ) GO TO 900                                    
      GRADSW = .TRUE.                                                   
C                                                                       
C     HOW MANY "RAW" DERIVATIVES WILL WE COMPUTE                        
C                                                                       
      MAXVS = 0                                                         
      DO 479 I = 1, NPARA                                               
      KEY = ILLOC(FACFR4*Z(IDVTYP)-FACFR4+I)                            
      IF ( KEY .LT. 4 ) MAXVS = MAXVS + (KEY+1)/2                       
 479  CONTINUE                                                          
      MAXVS = MAX0( MAXVS, 1 )                                          
C                                                                       
      IVDERV = NALLOC( MAXVS*(NSTPSS(2)+1), 'VDERIV ' )                 
      ISDELS = NALLOC( 4*NPARA, 'DSDXK ' )                              
      IDSDP = NALLOC( 2*NPARA*(LOMOST+1), 'DSDP ' )                     
      IDFDX = NALLOC( 2*NPARA, 'DFDX ' )                                
      IFGRAD = NALLOC( NPARA*NPTS, 'FGRADS ' )                          
      ITGRAD = NALLOC( NPARA, 'TGRAD ' )                                
C                                                                       
 490  IGNVAL = NALLOC( NPARA, 'CHIGNVAL' )                              
      IGNVEC = NALLOC( NPARA**2, 'CHIGNVEC' )                           
C                                                                       
      LGNVAL = Z(IGNVAL)                                                
      LGNVEC = Z(IGNVEC)                                                
      IF ( IFITER .EQ. 1 ) GO TO 500                                    
C                                                                       
      LVDERV = Z(IVDERV)                                                
      LSDELS = Z(ISDELS)                                                
      LDSDP = Z(IDSDP)                                                  
      LDFDX = Z(IDFDX)                                                  
      LFGRAD = Z(IFGRAD)                                                
      LTGRAD = Z(ITGRAD)                                                
      LDVTYP = Z(IDVTYP)                                                
C                                                                       
C  NO ALLOCATIONS EXPECTED BEFORE FITTING IS OVER                       
C  ---  SO FILL IN FITCOM                                               
C                                                                       
 500  IPARA=Z(IP)                                                       
      LEQUAL = FACFR4*(Z(IEQUAL)-1) + 1                                 
      LMASK = FACFR4*(Z(IMASK)-1) + 1                                   
      LPL=Z(IPL)                                                        
      IDATA = FACFR4*(Z(IDATA)-1) + 1                                   
      LSIGMA=Z(ISIGS(1))                                                
      LSMAT=Z(ISMATS(1))                                                
      LSCSIG = Z(ISCSIG)                                                
      LWORK = Z(IWORK)                                                  
      LEPARM = Z(IEPARM) - 1                                            
      LFS = Z(IFS)                                                      
      LEQNAM = Z(NAMLOC('EQUALNAM'))                                    
      MAXEQL = ILLOC(FACFR4*(LEQNAM-1)+1)                               
C                                                                       
C  PRINT INITIAL GUESS -  THIS IN NOW AUTOMATIC                         
C                                                                       
      ITEMP=1                                                           
      IF ( IPRT .NE. 0 ) CALL CALFUN ( NPTS, NPARA, ALLOC(LFS),  ALLOC(I
     *PARA) )                                                           
      ITEMP=2                                                           
C                                                                       
C                                                                       
C     USE DESIRED FITTER                                                
C                                                                       
 505  GO TO ( 510, 600, 650, 675, 700, 725, 750, 750, 750 ) , IFITER    
C                                                                       
C     POWELL 1965 FITTER ( VA02A )                                      
C                                                                       
C                                                                       
 510  CALL VA02A(NPTS, NPARA, ALLOC(LFS), ALLOC(IPARA), FITACC,  1.D-12,
     * FITMUL, IPRT, MAXCAL, IRTN, ALLOC(LWORK) )                       
C                                                                       
C                                                                       
C     THIS TERMINATION ROUTINE IS USED BY ALL THE FITTERS               
C     HOW DID IT STOP0                                                  
C                                                                       
 520  IF ( IRTN .EQ. 0 ) GO TO 530                                      
      IF ( IRTN .NE. 1 ) GO TO 538                                      
C                                                                       
C     WE COME HERE WHEN WE HAVE RUN OUT OF FUNCTION REFS AND MAY        
C     BE ABOUT TO REINITIALIZE THE FITTER AGAIN.                        
C                                                                       
      IF ( IREINI .EQ. 0 ) GO TO 535                                    
      IF ( NUMCAL .GE. MAXFUN ) GO TO 535                               
      GO TO 505                                                         
C                                                                       
 530  WRITE(6,531)                                                         
 531  FORMAT(/'     FIT COMPLETE.  FINAL RESULTS FOLLOW')               
      GO TO 540                                                         
 535  WRITE(6,533)                                                         
 533  FORMAT( '***** NOT ENOUGH  ITERATIONS TO ACHIEVE A GOOD FIT -  -',
     * '  - WHAT YOU GOT :')                                            
      GO TO 540                                                         
 538  WRITE(6,539) IRTN                                                   
 539  FORMAT ('0**** ABNORMAL TERMINATION OF THE FITTER - RETURN CODE ='
     * , I12 /  '0 SITUATION AT TERMINATION -' )                        
C                                                                       
 540  IF ( IFITER .NE. 1 ) GO TO 545                                    
C                                                                       
C     FOR POWELL65 GET THE METRIC MATRIX                                
C                                                                       
      CALL SV01A(NPTS,NPARA,ALLOC(LGNVEC),NPARA,2, ALLOC(LWORK) )       
      HESNSW = .TRUE.                                                   
      LTGRAD = LWORK + NPARA                                            
C                                                                       
C     HAVE CALFUN PRINT THE FINAL FIT                                   
C                                                                       
 545  ITEMP=3                                                           
      CALL CALFUN(NPTS,NPARA,ALLOC(LFS),ALLOC(IPARA))                   
C                                                                       
C                                                                       
C     IF AVAILABLE, PRINT GRADIENT AND/OR COVARIANCE MATRIX             
C     ALSO PRINT FIT TIMES                                              
C                                                                       
      IF ( IPRT .EQ. 0 ) GO TO 800                                      
      CALL PRTDER ( ALLOC(IPARA),  GRADSW, ALLOC(LTGRAD), HESNSW, ALLOC(
     *LGNVEC), ALLOC(LGNVAL),  NPARA, T1 )                              
C                                                                       
      GO TO 800                                                         
C                                                                       
C                                                                       
CXXC  THIS SECTION FOR ROCORD/MINROD                                    
CXXC                                                                    
CXX600   IRET=-1021                                                     
CXX      IF(MODEFT.NE.1)IRET=MODEFT                                     
CXX      CALL MINROD ( ALLOC(IPARA), F, ALLOC(Z(IDO)), ALLOC(Z(IUP)),   
CXX     1  NPARA, NUMRAN, FITACC/200., NROC, IRET )                     
CXX630   CALL CALFUN(NPTS,NPARA,ALLOC(LFS),ALLOC(IPARA))                
CXX      F=0                                                            
CXX      DO 639 I=1,NPTS                                                
CXX639   F=F+ALLOC(Z(IFS)+I-1)**2                                       
CXX      CALL MINEXT(F,IRET)                                            
CXX      GO TO ( 630, 630, 530, 640 ), IRET                             
CXX      GO TO 538                                                      
CXXC                                                                    
CXXC  IF ROCORD SPECIFIED AND REINTIALIZE ALSO SPECIFIED  THEN CALL     
CXXC        FLETPOW AFTER FIRST ITERATION                               
CXX 640  I = 5                                                          
CXX      CALL MINEXT ( F, I )                                           
CXX      IF(IREINI.EQ.0)GO TO 535                                       
CXX      IFITER=1                                                       
CXX      GO TO 510                                                      
 600  GO TO 300                                                         
C                                                                       
C                                                                       
CXXC     OCOPTR                                                         
CXXC                                                                    
CXX 650  EPS = FITACC**2                                                
CXX      CALL OCOPTR ( NPARA, NPARA, NPARA, ALLOC(IPARA), DUMMY,        
CXX     1  ALLOC(Z(IX0)), F0, OCOFCN, I, ALLOC(LWORK),                  
CXX     2  MAXFUN, IRET, EPS, FITRAT, FITMUL, 0.D0, IPRT-1 )            
CXX      IF ( IRTN .EQ. 1 )  GO TO 530                                  
CXX      IF ( IRTN .EQ. 0 )  GO TO 535                                  
CXX      GO TO 538                                                      
CXXC                                                                    
CXXC     LMGENV  (DLSMIN)                                               
CXXC                                                                    
CXX 675  I = MAXCAL                                                     
CXX      CALL DLSMIN ( NPARA, NPTS, ALLOC(IPARA), FITMUL, FITACC,       
CXX     1  I, DLSFCN, IRTN, ALLOC(LFS), ALLOC(LWORK), MINMON, IPRT,     
CXX     2  FITRAT, 1.D-15 )                                             
CXX      GO TO 520                                                      
 650  CONTINUE                                                          
 675  GO TO 300                                                         
C                                                                       
C     CHECKDERIVATIVE                                                   
C                                                                       
 700  L3 = LWORK + NPTS                                                 
      L4 = L3 + NPARA**2                                                
      L5 = L4 + NPARA**2                                                
      L6 = L5 + NPARA*NPTS                                              
      L8 = L6 + NPARA*NPTS                                              
C                                                                       
C                                                                       
      CALL SECDER ( MODEFT, NPARA, NPTS, FITACC, ALLOC(IPARA),  ALLOC(LF
     *S), ALLOC(LFGRAD), ALLOC(LTGRAD), ALLOC(LWORK),  ALLOC(LGNVEC), AL
     *LOC(L3), ALLOC(L4), ALLOC(L5),  ALLOC(L6), ALLOC(LGNVAL), ALLOC(L8
     *) )                                                               
      GO TO 800                                                         
C                                                                       
C     LMCHOL                                                            
C                                                                       
 725  L3 = LWORK                                                        
      L4 = L3 + NPARA                                                   
      L5 = L4 + NPARA                                                   
      L6 = L5 + NPARA                                                   
      L7 = L6 + NPARA                                                   
      IPRT = MIN0( IPRT, 1 )                                            
C                                                                       
      CALL LMCHOL ( NPARA, NPTS, ALLOC(IPARA), MODEFT, MAXCAL,  ALLOC(LG
     *NVAL), LMCFUN, FITACC, 1.D-12, ALLOC(LFS), ALLOC(LFGRAD) , ALLOC(L
     *GNVEC), IRTN, I, II, ALLOC(L3), ALLOC(L4), ALLOC(L5),  ALLOC(L6), 
     *ALLOC(L7), DUMMY, MINMON, IPRT )                                  
C                                                                       
      GO TO 760                                                         
C                                                                       
C     MINIM - DAVIDON-FLETCHER                                          
C     QUAVER - JTJ TYPE                                                 
C     VMMIN  - ORIGINAL AMD DAVIDON VARIABLE METRIC                     
C                                                                       
 750  L2 = LWORK                                                        
      L3 = L2 + NPARA                                                   
      L4 = L3 + NPARA                                                   
      L5 = L4 + NPARA                                                   
      L6 = L5 + NPARA                                                   
      L7 = L6 + NPARA                                                   
      DMODE = 5                                                         
      IF ( IFITER .EQ. 9 ) DMODE = 0                                    
      IF ( FITMUL .LT. 100 ) DMODE = FITMUL                             
C                                                                       
C                                                                       
      IF ( IFITER .EQ. 8 ) GO TO 755                                    
      IF ( IFITER .EQ. 9 ) GO TO 758                                    
C                                                                       
      CALL MINIM ( DMODE, FITACC, ALLOC(IPARA), ALLOC(LGNVAL),  ALLOC(LT
     *GRAD), ALLOC(L2), ALLOC(L3), ALLOC(L4), ALLOC(L5),  ALLOC(L6), ALL
     *OC(L7), ALLOC(LGNVEC), ALLOC(LFS),  ALLOC(LFGRAD), NPTS, NPARA, IP
     *RT, MAXCAL, IRTN )                                                
      GO TO 760                                                         
C                                                                       
 755  CALL QUAVER ( DMODE, FITACC, FITRAT, ALLOC(IPARA), ALLOC(LGNVAL), 
     * ALLOC(LTGRAD), ALLOC(L2), ALLOC(L3), ALLOC(L4), ALLOC(L5),  ALLOC
     *(L6), ALLOC(L7), ALLOC(LGNVEC), ALLOC(LFS),  ALLOC(LFGRAD), NPTS, 
     *NPARA, IPRT, MAXCAL, IRTN )                                       
      GO TO 760                                                         
C                                                                       
 758  CALL VMMIN ( DMODE, FITACC, ALLOC(IPARA), ALLOC(LGNVAL),  ALLOC(LT
     *GRAD), ALLOC(L2), ALLOC(L3), ALLOC(L4), ALLOC(L5),  ALLOC(L6), ALL
     *OC(L7), ALLOC(LGNVEC), ALLOC(LFS),  ALLOC(LFGRAD), NPTS, NPARA, IP
     *RT, NUMRAN, MAXCAL, IRTN )                                        
C                                                                       
 760  HESNSW = .TRUE.                                                   
      GO TO 520                                                         
C                                                                       
C                                                                       
C     ALL DONE WITH FITTING, CLEAN UP AND LEAVE                         
C                                                                       
 800  IRET=1                                                            
      IF ( IWORK .NE. 0 ) Z(IWORK) = -Z(IWORK)                          
      Z(IFS) = -Z(IFS)                                                  
      Z(IPL) = -Z(IPL)                                                  
      Z(IEPARM) = -Z(IEPARM)                                            
      Z(NFS(1)) = -Z(NFS(1))                                            
      Z(NGS(1)) = -Z(NGS(1))                                            
      Z(NF1S(1)) = -Z(NF1S(1))                                          
      Z(NG1S(1)) = -Z(NG1S(1))                                          
      Z(IRLVS(1)) = -Z(IRLVS(1))                                        
      Z(IIMVS(1)) = -Z(IIMVS(1))                                        
      Z(IWAVR) = -Z(IWAVR)                                              
      Z(IWAVI) = -Z(IWAVI)                                              
      Z(ISCSIG) = -Z(ISCSIG)                                            
      Z(ISIGS(1)) = -Z(ISIGS(1))                                        
      Z(ISMATS(1)) = -Z(ISMATS(1))                                      
C                                                                       
      IF ( .NOT. GRADSW ) GO TO 850                                     
      Z(IVDERV) = -Z(IVDERV)                                            
      Z(ISDELS) = -Z(ISDELS)                                            
      Z(IDSDP) = -Z(IDSDP)                                              
      Z(IDFDX) = -Z(IDFDX)                                              
      Z(IFGRAD) = -Z(IFGRAD)                                            
      Z(ITGRAD) = -Z(ITGRAD)                                            
C                                                                       
C                                                                       
 850  RETURN                                                            
C                                                                       
 900  WRITE(6,903)                                                         
 903  FORMAT ( '0**** INTERNAL ERROR:  DERIVTYP LOST' )                 
      IRET = 0                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE FITINP(IRET, NUMFLT, FLTWRD, NUMALI, ALIAI )           
C                                                                       
C  INPUT ROUTINE FOR FIT KEYWORD.                                       
C  READS INPUT IN THE FOLLOWING FORMAT: (R0,RI0,A=AI,V,VI)  ETC.        
C                                                                       
C     EACH PARAMETER MAY BE FOLLOWED BY DERIV OR NODERIV TO             
C     INDICATE WHETER THE DERIVATIVES MAY BE COMPUTED ANALYTICALLY      
C     OR NOT.                                                           
C     IF THIS IS NOT DONE, THEN ONLY THE WORDS LISTED IN REALS AND      
C     IMAGS BELOW WILL BE DONE ANALYTICALLY.                            
C                                                                       
C  THIS VERSION 8/13/75  D.GLOECKNER                                    
C     10/2/75 - EXPAND NAMLOC NAMES TO 8 CHARACTERS - S.P.              
C     10/19/75 - USE THE FLTWRD ARRAY FROM CONTRL.                      
C     10/23/75 - MAKE AN ARRAY OF EQUAL NAMES FOR CALFUN TO PRINT       
C     10/29/75 - STORE ARRAY INDICATING REAL OR IMAG NATURE OF PARAMETER
C     4/13/77 - PROCESS AIASES                                          
C     4/20/77 - RENORM AND SHIFT CAN BE FIT                             
C     2/14/78 - INDICATE NUMERIC DERIVS FOR UNKNOWNS - S.P.             
C     3/26/78 - DERIV/NODERIV ADDED; MUNICH CHANGES - S.P.              
C     12/27/79 - STANDARD MORTRAN - RPG                                 
C     6/3/80 - DERIVS DATA REQUIRES TWO LINES - S.P.                    
C     6/24/80 - CHARACTER*8 STATEMENTS - S.P.                           
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      CHARACTER*8 FLTWRD(NUMFLT), ALIAI(NUMALI)                         
C                                                                       
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               

      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      CHARACTER*8 CH8LOC(1)                                             
      EQUIVALENCE ( CH8LOC(1), ALLOC(1) )                               
C                                                                       
      DATA NUMREN / 22 /                                                
      CHARACTER*8 RENWRD(22)                                            
      DATA RENWRD/'RENORM', 'RENORMAL', 'RENORM1', 'RENORM2', 'RENORM3',
     *'RENORM4', 'RENORM5', 'RENORM6', 'RENORM7', 'RENORM8', 'RENORM9',
     *'RENORM10','RENORM11','RENORM12','RENORM13','RENORM14','RENORM15', 
     *'RENORM16', 'RENORM17', 'RENORM18', 'RENORM19', 'RENORM20'/
      CHARACTER*8 SHFWRD(22)                                            
      DATA SHFWRD/'SHIFT','ANGLESHI','SHIFT1', 'SHIFT2','SHIFT3', 
     *'SHIFT4','SHIFT5','SHIFT6', 'SHIFT7', 'SHIFT8', 'SHIFT9', 
     *'SHIFT10','SHIFT11', 'SHIFT12', 'SHIFT13','SHIFT14','SHIFT15', 
     *'SHIFT16', 'SHIFT17', 'SHIFT18', 'SHIFT19', 'SHIFT20'/                     
C                                                                       
C  ADDITIONAL KEYWORDS                                                  
C                                                                       
      CHARACTER*8 DERIVS(4)                                             
      DATA DERIVS/'DERIV', 'DERIVATI', 'NODERIV', 'NODERIVA'/           
      CHARACTER*8 UP,DOWN                                               
      DATA DOWN/'LOWERBOU'/
      DATA UP / 'UPPERBOU' /                                            
      CHARACTER*8 BLANK, EQUAL                                          
      DATA EQUAL/'  =  '/
      DATA BLANK / ' ' /                                                
      CHARACTER*8 AKEY, AKEYP                                           
C                                                                       
C     THE FOLLOWING KEYWORDS AFFECT THE REAL PART OF THE POTENTIAL      
C                                                                       
      DATA NUMRL / 22 /                                                 
      CHARACTER*8 REALS(22)                                             
      DATA REALS/'A','ASO','TAU', 'R', 'R0', 'RC', 'RC0', 'RSO','RSO0',
     *'V', 'VSO', 'R0E', 'AE', 'VE', 'R0ESQ', 'AESQ', 'VESQ', 'RCP', 
     *'RCT', 'RC0P', 'RC0T', 'REALPOWE'/                                
C                                                                       
C     THE FOLLOWING KEYWORDS AFFECT THE IMAGINARY PART OF THE POTENTIAL 
C                                                                       
      DATA NUMIM / 20 /                                                 
      CHARACTER*8 IMAGS(20)                                             
      DATA IMAGS/'AI','ASOI','TAUI','RI','RI0','RSOI','RSOI0','VI', 
     *'VSOI','ASI','RSI','RSI0', 'VSI', 'RI0E', 'AIE', 'VIE', 
     *'RI0ESQ', 'AIESQ', 'VIESQ', 'IMAGPOWE'/                               
C                                                                       
CUN      LOR(I,J) = OR(I,J)                                             
CVX      LOR(I,J) = IOR(I,J)                                            
C                                                                       
C  TEMPORAY STORAGE FOR PARAMETER VECTOR                                
      IRET=0                                                            
      IWORD = NALLOC( NUMFLT, 'FITWORDS' )                              
      ILONG=NUMFLT/FACFR4+1                                             
      IMASK=NALLOC(ILONG,'MASK ')                                       
      IL=NALLOC(ILONG,'EQUAL ')                                         
      ITMPNM = NALLOC( NUMFLT, 'TMPEQNAM' )                             
      IDRSET = NALLOC(NUMFLT, 'TMPDERIV' )                              
      LTMPNM = Z(ITMPNM)                                                
      IQ = FACFR4*(Z(IL)-1) + 1                                         
      LMASK = FACFR4*(Z(IMASK)-1)                                       
      LDRSET = FACFR4*Z(IDRSET) - FACFR4                                
      DO 5 I=1,ILONG                                                    
      ALLOC(Z(IMASK)+I-1)=0                                             
5     ALLOC(Z(IL)+I-1)=0                                                
C                                                                       
C     WE DEFINE THE FOLLOWING OBJECTS                                   
C                                                                       
C     Z(IWORD)                                                          
C       EACH WORD CONTAINS THE NAME OF A PRIMARY QUANTITY THAT          
C       IS BEING VARIED.  EQUAL NAMES ARE NOT STORED HERE.              
C                                                                       
C     Z(IMASK)                                                          
C       EACH INTEGER WORD CONTAINS THE OFF-SET IN FLOAT TO              
C       THE PRIMARY QUANTITY IN Z(IWORD).                               
C       FOR RENORM OR SHIFT KEYWORDS IT IS                              
C         -TII0000     WHERE                                            
C           T = 0 MEANS RENORM;  = 1 MEANS SHIFT                        
C           II IS THE DATASET TO BE AFFECTED.                           
C                                                                       
C     Z(IL)                                                             
C       CONTAINS A BLOCK FOR EACH SET OF EQUAL THINGS.                  
C       THE LAST BLOCK IS FOLLOWED BY 0.                                
C       EACH BLOCK HAS THE INTEGER STRUCTURE                            
C         WORD1  NUMBER OF EQUAL SIGNS                                  
C         WORD2  POINTER TO PRIMARY QUANTITY IN FLOAT.                  
C         THEREAFTER  WORD1 POINTERS TO THE SECONDARY QUANTITIES IN     
C                     FLOAT.                                            
C                                                                       
C     Z(IDRSET)                                                         
C       EACH INTEGER RELATES TO A PRIMARY FIT-WORD.                     
C       0 = DERIV CONTROL KEYWORDS NOT SPECIFIED                        
C       1 = DERIV SPECIFIED FOR THIS FIT WORD                           
C       2 = NODERIV.                                                    
C                                                                       
      NUMFIT=0                                                          
      IEKEY=0                                                           
      IECNT=0                                                           
      IEFST=0                                                           
      MAXEQL = 0                                                        
      IECNTS = 0                                                        
C                                                                       
C  IEKEY=1  FOR NEXT KEY AFTER =                                        
C  IEKEY=0  MEANS NEXT KEY AFTER KEYWORD                                
C                                                                       
C  IEFST=1  MEANS NOT THE FIRST = ENCOUNTERED                           
C  IEFST=0  MEANS THE FIRST = ENCOUNTERED                               
C                                                                       
C  REQUIRE ( TO PROCEED                                                 
      CALL FITKEY(AKEY,&100,&900,&900,&900)                             
      GO TO 900                                                         
100   CALL FITKEY(AKEY,&200,&300,&400,&905)                             
      AKEYP = AKEY                                                      
      IF(AKEY.EQ.UP)GO TO 500                                           
      IF(AKEY.EQ.DOWN)GO TO 550                                         
C                                                                       
C     FIND THE FIT WORD AND CONSTRUCT KEY ( POINTER TO FLOAT OR         
C     ELSE   -TII0000   FOR RENORM OR SHIFT )                           
C                                                                       
C     LOOK FIRST FOR RENORM OR SHIFT                                    
C                                                                       
      DO 119 I = 1, NUMREN                                              
      IF ( AKEY .NE. RENWRD(I) ) GO TO 105                              
      K = 0                                                             
      GO TO 110                                                         
 105  IF ( AKEY .NE. SHFWRD(I) ) GO TO 119                              
      K = 1                                                             
 110  KEY = I-2                                                         
      IF ( KEY .LE. 0 ) KEY = 1                                         
      KEY = -10000*( 100*K + KEY )                                      
      GO TO 150                                                         
 119  CONTINUE                                                          
C                                                                       
C     NOW TRY WORDS IN FLOAT                                            
C                                                                       
 120  DO 129 I=1,NUMFLT                                                 
      IF(AKEY.NE. FLTWRD(I))GO TO 129                                   
      KEY = I                                                           
      GO TO 150                                                         
129   CONTINUE                                                          
C                                                                       
C     IS IT AN ALIAS                                                    
C                                                                       
      DO 139 I = 1, NUMALI, 2                                           
      IF ( AKEY .NE. ALIAI(I) ) GO TO 139                               
      AKEY = ALIAI(I+1)                                                 
      GO TO 120                                                         
 139  CONTINUE                                                          
C                                                                       
C     IS IT A DERIVATIVE CONTROL WORD                                   
C                                                                       
      DO 144 I = 1, 4                                                   
      IF ( AKEY .NE. DERIVS(I) ) GO TO 144                              
      IF ( NUMFIT .EQ. 0 ) GO TO 940                                    
      ILLOC(LDRSET+NUMFIT) = (I+1)/2                                    
      GO TO 100                                                         
 144  CONTINUE                                                          
      GO TO 910                                                         
C                                                                       
C     FIT WORD HAS BEEN IDENTIFIED                                      
C                                                                       
 150  IF(IEKEY.EQ.1)GO TO 310                                           
      NUMFIT=NUMFIT+1                                                   
      IEFST=0                                                           
      CH8LOC(Z(IWORD)+NUMFIT-1)= AKEYP                                  
      ILLOC(LMASK+NUMFIT) = KEY                                         
      IKEY=KEY                                                          
      GO TO 100                                                         
C                                                                       
C  (  ENCOUNTERED --  THIS IS AN EXTRA ONE                              
C                                                                       
200   GO TO 100                                                         
C                                                                       
C   =  ENCOUNTERED                                                      
C                                                                       
300   IEKEY=1                                                           
      IF(IEFST.EQ.1)GO TO 100                                           
      IEFST=1                                                           
      IECNT=IECNT+2                                                     
      LTMPNM = LTMPNM+2                                                 
      ILLOC(IQ+IECNT-1)= IKEY                                           
      MAXEQL = MAX0( MAXEQL, IECNTS )                                   
      IECNTS=0                                                          
      GO TO 100                                                         
C                                                                       
C  PROCESS EQUAL                                                        
C                                                                       
310   IECNT=IECNT+1                                                     
      LTMPNM = LTMPNM+1                                                 
      ILLOC(IQ+IECNT-1)= KEY                                            
      CH8LOC(LTMPNM) = AKEYP                                            
      IECNTS=IECNTS+1                                                   
      ILLOC(IQ+IECNT-IECNTS-2)=IECNTS                                   
      IEKEY=0                                                           
      GO TO 100                                                         
C                                                                       
C  ALL FINISHED.  ) ENCOUNTERED                                         
C                                                                       
400   IPARA=NALLOC(NUMFIT,'PARAMETE')                                   
      CALL IREDEF ( NUMFIT, IWORD )                                     
      CALL IREDEF ( (NUMFIT+FACFR4-1)/FACFR4, IMASK )                   
      CALL IREDEF ( (IECNT+FACFR4)/FACFR4, IL )                         
C                                                                       
C     FOR POSSIBLE USE BY THE GRADIENT CALCULATION, WE SETUP AN ARRAY   
C     INDICATING WHICH PART OF THE POTENTIAL EACH PARAMETER AFFECTS:    
C       0 - EFFECTS NEITHER (RENORM OR SHIFT)                           
C       1 - PARAM EFFECTS REAL(V)                                       
C       2 - PARAM EFFECTS IMAG(V)                                       
C       3 - PARAM EFFECTS BOTH ( POSSIBLE THROUGH EQUALS ).             
C     >=4 - UNKNOWN - DERIVATIVE MUST BE FOUND NUMERICALLY              
C                                                                       
C     ALSO SETUP A TWO-DIM ARRAY OF THE EQUALS TO BE PRINTED BY CALFUN. 
C                                                                       
      IDVTYP = NALLOC( (NUMFIT+FACFR4-1)/FACFR4, 'DERIVTYP' )           
C                                                                       
C     MAXEQL IS TWICE THE NUMBER OF EQUALS IN ONE STRING.               
C                                                                       
      MAXEQL = 2*MAX0( MAXEQL, IECNTS )                                 
      IENAME = NALLOC( 1+MAXEQL*NUMFIT, 'EQUALNAM' )                    
      LENAME = Z(IENAME)                                                
      LDVTYP = FACFR4*Z(IDVTYP) - FACFR4                                
      ILLOC(FACFR4*(LENAME-1)+1) = MAXEQL                               
      IQ = FACFR4*(Z(IL)-1) + 1                                         
      LTMPNM = Z(ITMPNM)                                                
      LMASK = FACFR4*Z(IMASK) - FACFR4                                  
      LDRSET = FACFR4*Z(IDRSET) - FACFR4                                
      DO 459 NF = 1, NUMFIT                                             
C                                                                       
C     IS IT REAL OR IMAG                                                
C                                                                       
      IREAL = 0                                                         
      IIMAG = 0                                                         
      INUMER = 0                                                        
      KEY = ILLOC(LMASK+NF)                                             
      KEYDR = ILLOC(LDRSET+NF)                                          
      IF ( KEYDR .EQ. 2 ) INUMER = 4                                    
      IF ( KEY .LT. 0 ) GO TO 425                                       
      IF ( INUMER .EQ. 4 ) GO TO 425                                    
C                                                                       
      AKEY = FLTWRD(KEY)                                                
      DO 422 II = 1, NUMRL                                              
      IF ( AKEY .NE. REALS(II) ) GO TO 422                              
      IREAL = 1                                                         
      GO TO 425                                                         
 422  CONTINUE                                                          
      DO 424 II = 1, NUMIM                                              
      IF ( AKEY .NE. IMAGS(II) ) GO TO 424                              
      IIMAG = 2                                                         
      GO TO 425                                                         
 424  CONTINUE                                                          
C                                                                       
C     WE DON'T KNOW SO DO NUMERICALLY OR BOTH                           
C                                                                       
      INUMER = 4                                                        
      IF ( KEYDR .EQ. 1 ) INUMER = 3                                    
C                                                                       
 425  IF ( MAXEQL .EQ. 0 ) GO TO 450                                    
      DO 429 I = 1, MAXEQL                                              
      CH8LOC(LENAME+(NF-1)*MAXEQL+I) = BLANK                            
 429  CONTINUE                                                          
      IMANY = ILLOC(IQ)                                                 
      IF ( IMANY .EQ. 0 ) GO TO 450                                     
      IF ( ILLOC(IQ+1) .NE. KEY ) GO TO 450                             
      IQ = IQ + 2                                                       
      LTMPNM = LTMPNM+2                                                 
      DO 439 I = 1, IMANY                                               
      CH8LOC(LENAME+(NF-1)*MAXEQL+2*I-1) = EQUAL                        
      AKEYP = CH8LOC(LTMPNM+1)                                          
      KEY = ILLOC(IQ)                                                   
      CH8LOC(LENAME+(NF-1)*MAXEQL+2*I) = AKEYP                          
      IQ = IQ + 1                                                       
      LTMPNM = LTMPNM+1                                                 
      IF ( KEY .LT. 0 ) GO TO 439                                       
      IF ( INUMER .GT. 0 ) GO TO 439                                    
      AKEY = FLTWRD(KEY)                                                
      DO 435 II = 1, NUMRL                                              
      IF ( AKEY .NE. REALS(II) ) GO TO 435                              
      IREAL = 1                                                         
      GO TO 439                                                         
 435  CONTINUE                                                          
      DO 437 II = 1, NUMIM                                              
      IF ( AKEY .NE. IMAGS(II) ) GO TO 437                              
      IIMAG = 2                                                         
      GO TO 439                                                         
 437  CONTINUE                                                          
C                                                                       
C     WE DON'T KNOW SO DO NUMERICALLY OR BOTH                           
C                                                                       
      INUMER = 4                                                        
      IF ( KEYDR .EQ. 1 ) INUMER = 3                                    
C                                                                       
 439  CONTINUE                                                          
 450  ILLOC(LDVTYP+NF) = IOR(IREAL+IIMAG,INUMER)                        
 459  CONTINUE                                                          
C                                                                       
      IRET=1                                                            
      Z(ITMPNM) = -Z(ITMPNM)                                            
      Z(IDRSET) = -Z(IDRSET)                                            
      RETURN                                                            
C                                                                       
C  FOR NOW ASSUME UPPERB OR LOWERB COME AFTER ALL FIT KEYWORDS          
C                                                                       
500   IUP=NALLOC(NUMFIT,'UPPERB ')                                      
      DO 510 I=1,NUMFIT                                                 
      CALL NXVAL(VAL,&930,&930,&930)                                    
510   ALLOC(Z(IUP)+I-1)=VAL                                             
      GO TO 100                                                         
550   IDO=NALLOC(NUMFIT,'LOWERB ')                                      
      DO 560 I=1,NUMFIT                                                 
      CALL NXVAL(VAL,&930,&930,&930)                                    
560   ALLOC(Z(IDO)+I-1)=VAL                                             
      GO TO 100                                                         
C                                                                       
900   WRITE(6,901)                                                      
901   FORMAT ( ' *** EXPECT ( FIRST IMMEDIATELY AFTER KEYWORD FIT')     
      RETURN                                                            
905   WRITE(6,906)                                                      
906   FORMAT ( ' *** MISPLACED SPECIAL CHARACTER OR NUMBER')            
      RETURN                                                            
910   WRITE(6,911)AKEY                                                  
911   FORMAT ( ' *** INPUT ERROR. ',A8,' IS NOT A VALID FIT PARAMETER') 
      RETURN                                                            
930   WRITE(6,931)                                                      
931   FORMAT(' ERROR IN READING BOUNDS. NOTE BOUNDS MUST FOLLOW ALL F', 
     * 'IT PARAMETERS')                                                 
      RETURN                                                            
 940  WRITE(6,941)                                                         
 941  FORMAT ( '0**** DERIV/NODERIV MUST FOLLOW A KEYWORD.' )           
      RETURN                                                            
      END                                                               
      SUBROUTINE GENBNX ( IPASS, NBINDX, MBINDX, BINDEX, NBASCP,  MBASCP
     *, BASCUP, MBASDF, BASDEF, MCHNDF, CHNDEF,  NMBFAC, NMFFAC, MXLXGS,
     * MXLXBF, COULSW, PBUGSW )                                         
C                                                                       
C     DETERMINS THE SIZE OF THE B-FACTORS ARRAY AND CONSTRUCTS INDEX    
C                                                                       
C     FOR COUPLED CHANNES WE GO THROUGH THE BASIS COUPLING ARRAY        
C     AND FOR ALL COULOMB COUPLINGS                                     
C     1)  FIND THE REQUIRED STORAGE SIZE FOR B-FACTORS,                 
C         CONSTRUCT THE B INDEX ARRAY, AND STORE POINTERS               
C         TO IT.                                                        
C     2)  STORE THE MINIMUM LX IN CHNDEF(15,..) OF EACH CHANNEL         
C         THAT REQUIRES COULOMB FF2 INTEGRALS.  OTHER CHNDEF(15,..)     
C         ARE LEFT AS NOTDEF.                                           
C     3)  CONSTRUCT POINTERS FOR THE FF2 INTEGRALS FOR ALL              
C         COULOMB COUPLINGS TO THE G.S.  THE SIZE OF THE FF2            
C         ARRAY IS ALSO FOUND.                                          
C                                                                       
C     THIS ROUTINE MUST FIRST BE CALLED WITH IPASS=1 AND THEN           
C     WITH IPASS=2.  IN BETWEEN THESE CALLS, LIMOST MUST BE             
C     COMPUTED FOR EACH CHANNEL REQUIRING COULOMB FF2 INTS              
C     (EACH CHANNEL WITH A MINIMUM LX STORED IN CHNDEF(15,..))          
C     AND STORED IN CHNDEF(15,..).                                      
C                                                                       
C     THE BFACTOR INDEX ARRAY HAS THE FOLLOWING ENTRIES FOR             
C     EACH COMBINATION OF (LX, CHANNEL 1, CHANNEL 2)  FOR WHICH         
C     B FACTORS ARE NEEDED.                                             
C                                                                       
C     1  LX  (TOTAL LAMBDA)                                             
C     2  CHANNEL 1                                                      
C     3  CHANNEL 2                                                      
C     4  2*MAX(L1-J)                                                    
C     5  2*MAX(L2-J)                                                    
C     6  2*MIN(L1-J)                                                    
C     7  2*MIN(L2-J)                                                    
C     8  POINTER TO THE B FACTORS.FOR C.C. MATCHING.  THE LEAST         
C        VALUE IS 1. (0 MEANS B-FACTORS WERE SUPPRESSED).               
C     9  POINTER TO FF2 INTS FOR EXTRAPOLATION.  THE LEAST              
C        VALUE IS 1 (0 MEANS NO FF2 INTS FOR THIS COUPLING).            
C                                                                       
C                                                                       
C     IPASS - =1 OR 2 TO INDICATE THE PASS.                             
C     NBINDX, MBINDX, BINDEX - THE B INDEX ARRAY THAT IS CONSTRUCTED.   
C     NBASCP, MBASCP, BASCUP - THE BASIS COUPLING ARRAY                 
C     MBASDF, BASDEF - THE BASIS DEFINITION ARRAY                       
C     MCHNDF, CHNDEF - THE CHANNEL DEFINITION ARRAY                     
C     NMBFAC - SET TO THE  NUMBER OF BFACTORS THAT WILL BE              
C              PER J-VALUE.                                             
C     NMFFAC - SET TO THE NUMBER/NUMJVALS OF FF2 INTS THAT WILL BE      
C              NEEDED.                                                  
C     MXLXGS - SET TO THE MAXIMUM LX FOR WHICH FF2 INTS ARE NEEDED.     
C     MXLXBF - MAX LX NEEDED FOR B FACTORS                              
C     COULSW - SET TO .TRUE. IF ANY CHANNELS ARE 1ST ORDER COULOMB      
C              COUPLED TO THE G.S.                                      
C     PBUGSW - MUST BE .TRUE. TO GET DEBUGGING OUTPUT.                  
C                                                                       
C     1/8/80 - FIRST VERSION - S.P.                                     
C     2/18/80 - STORE INFO NEEDED FOR FF2 INTEGRALS - S.P.              
C     3/15/80 - STORE IN J-BLOCKS INSTEAD OF CHANNEL BLOCKS - S.P.      
C     3/27/80 - ALWAYS STORE POINTERS IN BASCUP - S.P.                  
C     9/25/80 - STORE LX IN CHNDEF(15,), CHNDEF(14,) NOBORNSUB          
C               SWITCH; IPASS - S.P.                                    
C     12/18/80 - REVERSE N1 AND N2 (WERE INCORRECT) IN FF2 - S.P.       
C                 THIS HAS EFFECT ONLY FOR UPONLY COUPLING.             
C     9/3/81 - MXLXBF ADDED - S.P.                                      
C     9/12/81 - DISREGARD ORDER - S.P.                                  
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      INTEGER BINDEX(MBINDX,1), BASCUP(MBASCP, NBASCP), BASDEF(MBASDF,1)
     *, CHNDEF(MCHNDF,1)                                                
      LOGICAL PBUGSW, COULSW                                            
C                                                                       
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                                           
      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                                                                 
C                                                                       
      LOGICAL BFACSW                                                    
C                                                                       
C     WE START OUT WITH THESE 1 TOO LARGE FOR GENERATING POINTERS       
C                                                                       
      BFACSW = NOBFAC .NE. 1                                            
      NMBFAC = 1                                                        
      NMFFAC = 1                                                        
      IF ( IPASS .EQ. 2 ) GO TO 305                                     
      MXLXGS = 0                                                        
      MXLXBF = 0                                                        
      NBINDX = 0                                                        
C                                                                       
C     PASS 1 -- PROCESS ALL BASIS-STATE COUPLINGS AND DETERMIN          
C     MAXIMUM RANGES OF L NEEDED FOR THE B FACTORS.  HERE               
C     WE ARE INTERESETED ONLY IN COULOMB COUPLINGS.                     
C                                                                       
      DO 299 IBC = 1, NBASCP                                            
      BASCUP(9,IBC) = 0                                                 
      IF ( BASCUP(6,IBC) .EQ. 0 )  GO TO 299                            
C                                                                       
C     FIND THE INVOLVED CHANNELS                                        
C                                                                       
      IB1 = BASCUP(1,IBC)                                               
      N1 = BASDEF(1,IB1)                                                
      IB2 = BASCUP(2,IBC)                                               
      N2 = BASDEF(1,IB2)                                                
C                                                                       
C                                                                       
C     WE NEED B-FACTORS FOR THIS PAIR OF STATES.                        
C     SEE IF THEY HAVE ALREADY BEEN PROCESSED.                          
C                                                                       
      LAMBDA = BASCUP(4,IBC)/2                                          
      LMJ1 = BASDEF(3,IB1)                                              
      LMJ2 = BASDEF(3,IB2)                                              
      IF ( NBINDX .EQ. 0 ) GO TO 200                                    
      DO 149 IBF = 1, NBINDX                                            
      IF ( LAMBDA .NE. BINDEX(1,IBF) ) GO TO 149                        
      NN1 = BINDEX(2,IBF)                                               
      NN2 = BINDEX(3,IBF)                                               
      IF ( N1 .EQ. NN1 .AND. N2 .EQ. NN2 ) GO TO 220                    
      IF ( N1 .EQ. NN2 .AND. N2 .EQ. NN1 ) GO TO 230                    
 149  CONTINUE                                                          
C                                                                       
C     WE NEED A NEW SET OF B FACTORS FOR THIS PAIR OF CHANNELS          
C     AND LAMBDA.  START COLLECTING STATISTICS.                         
C                                                                       
 200  NBINDX = NBINDX+1                                                 
      BINDEX(1,NBINDX) = LAMBDA                                         
      BINDEX(2,NBINDX) = N1                                             
      BINDEX(3,NBINDX) = N2                                             
      BINDEX(4,NBINDX) = LMJ1                                           
      BINDEX(5,NBINDX) = LMJ2                                           
      BINDEX(6,NBINDX) = LMJ1                                           
      BINDEX(7,NBINDX) = LMJ2                                           
      BINDEX(9,NBINDX) = 0                                              
      BASCUP(9,IBC) = NBINDX                                            
      IBF = NBINDX                                                      
      MXLXBF = MAX0( MXLXBF, LAMBDA )                                   
      GO TO 250                                                         
C                                                                       
C     THIS CHANNEL HAS BEEN PROCESSED, COLLECT MAXIMUM REQUIREMENTS.    
C                                                                       
  220 BINDEX(4,IBF) = MAX0( BINDEX(4,IBF), LMJ1 )                       
      BINDEX(5,IBF) = MAX0( BINDEX(5,IBF), LMJ2 )                       
      BINDEX(6,IBF) = MIN0( BINDEX(6,IBF), LMJ1 )                       
      BINDEX(7,IBF) = MIN0( BINDEX(7,IBF), LMJ2 )                       
      BASCUP(9,IBC) = IBF                                               
      GO TO 250                                                         
C                                                                       
C     FOUND IN REVERSE ORDER                                            
C                                                                       
  230 BINDEX(4,IBF) = MAX0( BINDEX(4,IBF), LMJ2 )                       
      BINDEX(5,IBF) = MAX0( BINDEX(5,IBF), LMJ1 )                       
      BINDEX(6,IBF) = MIN0( BINDEX(6,IBF), LMJ2 )                       
      BINDEX(7,IBF) = MIN0( BINDEX(7,IBF), LMJ1 )                       
      BASCUP(9,IBC) = -IBF                                              
C                                                                       
C     STORE MINIMUM LX FOR CHANNELS REQUIRING FF2 INTS                  
C                                                                       
 250  IF ( N1 .EQ. 1 .OR. N2 .NE. 1 ) GO TO 299                         
      IF ( IBRNSB .EQ. 1 ) GO TO 299                                    
      COULSW = .TRUE.                                                   
      L = LAMBDA                                                        
      IF ( CHNDEF(15,N1) .NE. NOTDEF )  L = MIN0( L, CHNDEF(15,N1) )    
      CHNDEF(15,N1) = L                                                 
C                                                                       
C     INDICATE THAT THIS PAIR OF CHANNELS NEEDS COULOMB FF2 INTEGRALS   
C                                                                       
      BINDEX(9,IBF) = 1                                                 
      MXLXGS = MAX0( MXLXGS, LAMBDA)                                    
C                                                                       
 299  CONTINUE                                                          
C                                                                       
      IF ( PBUGSW ) WRITE(6,303) NBINDX, MXLXGS, MXLXBF                   
 303  FORMAT ( X, I8, ' SETS OF B-FACTORS NEEDED;',  3X, 'MAXIMUM LX F
     *OR F, B FACTORS =', 2I5 )                                         
      RETURN                                                            
C                                                                       
 305  IF ( NBINDX .EQ. 0 ) GO TO 800                                    
C                                                                       
C     PASS 2 -- PROCESS THE B-INDEX ARRAY.   ORDER THE CHANNELS         
C     SO THAT  L(1)-J < L(2)-J  TO MIMIMIZE STORAGE USED FOR THE        
C     B FACTORS.  COMPUTE THE REQUIRED BSFACTOR SIZE AND STORE          
C     POINTERS TO THE BSFACTORS.                                        
C                                                                       
      DO 399 IBF = 1, NBINDX                                            
      INEG = +1                                                         
      IF ( BINDEX(6,IBF) .GT. BINDEX(7,IBF) ) GO TO 330                 
      INEG = -1                                                         
      DO 309 I = 2, 6, 2                                                
      II = BINDEX(I,IBF)                                                
      BINDEX(I,IBF) = BINDEX(I+1,IBF)                                   
      BINDEX(I+1,IBF) = II                                              
 309  CONTINUE                                                          
C                                                                       
 330  BINDEX(8,IBF) = INEG*NMBFAC                                       
C                                                                       
C     THE SUBSCRIPTING SCHEME FOR THE B FACTORS IS GIVEN                
C     IN SETBFC.                                                        
C                                                                       
      NM1FRJ = (BINDEX(4,IBF)-BINDEX(6,IBF))/4 + 1                      
      NMBFRJ = (BINDEX(1,IBF)+1)*NM1FRJ                                 
      IF ( BFACSW ) NMBFAC = NMBFAC + NMBFRJ                            
C                                                                       
C     STORE NUMBER OF FF2 INTEGRALS PER J-VALUE                         
C                                                                       
      IF ( BINDEX(9,IBF) .NE. 1 ) GO TO 390                             
      BINDEX(9,IBF) = NMFFAC                                            
      N2 = BINDEX(3,IBF)                                                
      NUMLIS = CHNDEF(15,N2)-LMIN+1                                     
      NMFFAC = NMFFAC + NMBFRJ*NUMLIS                                   
 390  IF ( PBUGSW ) WRITE(6,393) ( BINDEX(I,IBF), I=1,9 )                 
 393  FORMAT ( ' LX, CH1, CH2, L-J, ..., BPTR =', 9I10 )                
 399  CONTINUE                                                          
C                                                                       
C                                                                       
C     PASS 3 -- SCAN BASIS-STATE COUPLING ARRAY AND INDICATE            
C     THOSE BFACTORS THAT WILL BE STORED IN REVERSE ORDER.              
C                                                                       
      DO 449 IBC = 1, NBASCP                                            
      IBF = BASCUP(9,IBC)                                               
      IF ( IBF .EQ. 0 ) GO TO 449                                       
      IF ( BINDEX(8,IABS(IBF)) .LT. 0 ) BASCUP(9,IBC) = -IBF            
 449  CONTINUE                                                          
C                                                                       
C     PASS 4 -- SCAN B-INDEX ARRAY AND MAKE ALL POINTERS > 0            
C                                                                       
      DO 499 IBF = 1, NBINDX                                            
      BINDEX(8,IBF) = IABS(BINDEX(8,IBF))                               
 499  CONTINUE                                                          
C                                                                       
 800  NMBFAC = NMBFAC - 1                                               
      NMFFAC = NMFFAC - 1                                               
      IF ( PBUGSW ) WRITE(6,803) NMBFAC, NMFFAC                           
 803  FORMAT ( ' TOTAL NUMBER OF B AND FF2 FACTORS:', I10,  1X, '(PER J-
     *VALUE)', I10 )                                                    
      RETURN                                                            
      END                                                               
      SUBROUTINE GETBFC ( ILI, J, DELTA, RASYMP, NMBFC, BFACIN, BFACOT, 
     * MBNDX, BINDEX, MCHNDF, CHNDEF, RCHNDF,  MBASDF, BASDEF, NBASDF, F
     *G )                                                               
C                                                                       
C     COMPUTES THE B-FACTORS AT  RASYMP-DELTA  FROM THOSE AT  RASYMP.   
C                                                                       
C     ILI - INDEX OF J IN THE LIS ARRAY                                 
C     J - 2*TOTAL J                                                     
C     DELTA - NBACK*STEPSZ - MATCHING DELTA IN FERMIS.                  
C     RASYMP- ASYMPTOPIA IN FERMIS                                      
C     BFACIN IS THE BFACTORS AT R FOR ALL J'S AS FOUND BY SETBFC        
C            THIS IS POINTED TO BY ICL1FF                               
C     BFACOT WILL BE THE B-FACTORS AT R-DELTA AND R FOR THIS J:         
C            (THIS IS POINTED TO BY ICL1FG)                             
C                                                                       
C        BFACOT(IC,IR,K):                                               
C           IC=1 FOR REAL, 2 FOR IMAG PART;                             
C           IR=1 FOR R-DELTA, 2 FOR R;                                  
C           K = BINDEX(8,IB) + L2-L1+LX + (LX+1)(L1-J - MIN(L1-J))      
C                                                                       
C     THE X(1,2) TERM IS STILL OMITTED SO THAT                          
C        B(2,1) = X(1,2) * BFACOT                                       
C                                                                       
C     BINDEX - B-FACTORS INDEX ARRAY (IBINDX) STORED BY GNBNDX.         
C     MCHNDF - NUMBER OF WORDS PER CHANNEL IN CHANDEF.                  
C     CHNDEF, RCHNDF - THE CHANNEL DEFINITION ARRAY (CHNDEF).           
C           THIS IS THE TWO-DIMENSIONAL PART FOLLOWING THE HEADER.      
C     MBASDF - NUMBER OF WORDS PER BASIS STATE IN BASDEF.               
C     BASDEF - THE BASIS DEFINITION ARRAY (IBASDF).  THIS IS THE        
C              PART FOLLOWING THE HEADER.                               
C     NBASDF - THE NUMBER OF BASIS STATES                               
C     FG - THE FANDG (NFS(1)) ARRAY.                                    
C                                                                       
C     2/15/80 - FIRST VERSION - S.P.                                    
C     3/15/80 - STORED BY J-BLOCKS - S.P.                               
C      6/2/80 - NMBFC, MBNDX PASSED TO ALLOW CDC COMPATIBILITY - S.P.   
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      REAL*4 BFACIN(2,NMBFC,1), BFACOT(2,2,NMBFC)                       
      INTEGER BINDEX(MBNDX, 1), CHNDEF(MCHNDF, 1)                       
      INTEGER BASDEF(MBASDF, NBASDF)                                    
      REAL*4 RCHNDF(MCHNDF, 1), FG(4,NBASDF,1)                          
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                      
      COMMON /GRIDCM/ RCUEFF, GRDCM1(2), IBINDX, MBINDX, NBINDX, NMFFAC,
     * MXLXGS, NMBFAC, IINHR, IINHI, IRHSR, IRHSI, INUCH, ICOULH, ILOR, 
     *ILOI, ILIR, ILII, NPTMIN, NOFLO, NUMPT, NCRIT, ISMX, ISMSQ, IPADE,
     * IHOMO, ISMTSV, IRPTS4, IRPTS, IGRDC4(5), IDW, IGRDC5(2), IABS1, I
     *GRDC6(2), GRDCM2, IGRDC7(2), IRWTS, IGRDC8(2), ICL1FF, ICL1FG, ICL
     *1GF, ICL1GG                                                       
C                                                                       
      LOGICAL DBUGSW                                                    
C                                                                       
      DBUGSW = MOD(IPRINT, 10) .GE. 5                                   
C                                                                       
      FAC = 3*IZS(1)*IZS(3)*HBARC*DELTA/(4*AFINE) * 2*AM/HBARC**2       
C                                                                       
      IF ( DBUGSW ) WRITE(6,13) ILI, J, DELTA, RASYMP, FAC                
 13   FORMAT ( ' BFACTORS:', 2I5, '/2', 3G16.6 )                        
C                                                                       
C     LOOP OVER ALL SETS OF BFACTORS                                    
C                                                                       
      DO 899 IBSET = 1, NBINDX                                          
      LX = BINDEX(1,IBSET)                                              
      IC1 = BINDEX(2,IBSET)                                             
      IC2 = BINDEX(3,IBSET)                                             
      MXLMJ1 = BINDEX(4,IBSET)                                          
      MNLMJ1 = BINDEX(6,IBSET)                                          
      LB = BINDEX(8,IBSET)                                              
C                                                                       
      MINL1 = (MNLMJ1+J)/2                                              
C                                                                       
      AK1 = RCHNDF(7,IC1)                                               
      IB1ST = CHNDEF(8,IC1)                                             
      IB1END = IB1ST + CHNDEF(9,IC1) - 1                                
      AK2 = RCHNDF(7,IC2)                                               
      IB2ST = CHNDEF(8,IC2)                                             
      IB2END = IB2ST + CHNDEF(9,IC2) - 1                                
C                                                                       
      IF ( DBUGSW ) WRITE(6,203) IC1, IC2, LB                             
 203  FORMAT ( ' CHANNELS', 2I4, 5X, 'LB =', I6 )                       
C                                                                       
      FACTOR = FAC/SQRT(AK1*AK2)                                        
C                                                                       
C     THINGS GET A BIT CONTORTED HERE BECAUSE WE NEED THE COULOMB       
C     FUNCTIONS F AND G WHICH WERE STORED IN THE ORDER OF THE           
C     BASIS STATES.  THEREFORE WE LOOP THROUGH BOTH SETS OF             
C     BASIS STATES AND COMPUTE THE B'S FOR EVERY VALID PAIR OF          
C     L1 AND L2.  THIS MEANS THAT WE MAY COMPUTE SOME PAIRS             
C     SEVERAL TIMES BUT TOO BAD.                                        
C                                                                       
      DO 879 IB1 = IB1ST, IB1END                                        
C                                                                       
      L1 = J + BASDEF(3,IB1)                                            
      IF ( L1 .LT. 0 ) GO TO 879                                        
      L1 = JISHFT(L1,-1)                                                
C                                                                       
      DO 859 IB2 = IB2ST, IB2END                                        
C                                                                       
      L2 = J + BASDEF(3,IB2)                                            
      IF ( L2 .LT. 0 ) GO TO 859                                        
      L2 = JISHFT(L2,-1)                                                
      IF ( IABS(L1-L2) .GT. LX ) GO TO 859                              
      I = (LX+1)*(L1-MINL1) + LX - L1 + L2                              
      I = JISHFT(I,-1) + LB                                             
C                                                                       
C     HERE WE USE ONE TRAPEZIOD TO INTEGRATE FROM RASYMP TO RASYMP-DELTA
C                                                                       
      BFACOT(1,1,I) = BFACIN(1,I,ILI) + FACTOR*(  (FG(1,IB1,ILI)*FG(2,IB
     *2,ILI) -  FG(2,IB1,ILI)*FG(1,IB2,ILI))/(RASYMP-DELTA)**(LX+1)  + (
     *FG(3,IB1,ILI)*FG(4,IB2,ILI) -  FG(4,IB1,ILI)*FG(3,IB2,ILI))/RASYMP
     ***(LX+1) )                                                        
C                                                                       
      BFACOT(1,2,I) = BFACIN(1,I,ILI)                                   
C                                                                       
      BFACOT(2,1,I) = BFACIN(2,I,ILI) + FACTOR*(  (FG(1,IB2,ILI)*FG(1,IB
     *1,ILI) +  FG(2,IB2,ILI)*FG(2,IB1,ILI))/(RASYMP-DELTA)**(LX+1)  + (
     *FG(3,IB2,ILI)*FG(3,IB1,ILI) +  FG(4,IB2,ILI)*FG(4,IB1,ILI))/RASYMP
     ***(LX+1) )                                                        
C                                                                       
      BFACOT(2,2,I) = BFACIN(2,I,ILI)                                   
C                                                                       
      IF ( DBUGSW ) WRITE(6,833) L1,L2,I,BFACOT(1,1,I),BFACOT(2,1,I),
     * BFACOT(1,2,I), BFACOT(2,2,I)                                     
 833  FORMAT ( 3I4, 2( G20.10, G18.10 ) )                               
C                                                                       
 859  CONTINUE                                                          
 879  CONTINUE                                                          
 899  CONTINUE                                                          
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE GETNUM ( NUM, * )                                      
CDC      SUBROUTINE GETNUM ( NUM ), RETURNS ( IRTRN1 )                  
C                                                                       
C     GETS THE NUMBER OF AN OBJECT FROM THE INPUT.                      
C                                                                       
C     THE INPUT MAY BE EITHER THE OBJECT NUMBER OR NAME.                
C     IF THE OBJECT IS UNDEFINED, OR THERE IS AN ERROR IN INPUT THEN    
C     RETURN 1  IS MADE (WITH NUM = 0).                                 
C                                                                       
C     8/30/76 - ORIGINAL VERSION?                                       
C     12/27/79 - STANDARD MORTRAN - RPG                                 
C                                                                       
      COMMON /USAGE/ IBASE, NWRDS, IMAX                                 
      COMMON /LOCKT/ LOC(1)                                               
      COMMON /LENGTH/ LENG(1)                                           
C                                                                       
      CHARACTER*8 NAME                                                  
C                                                                       
      CALL NXINT ( NUM, &200, &900, &200 )                              
C                                                                       
C     NUMBER HAS BEEN FOUND, IS IT DEFINED                              
C                                                                       
      IF ( NUM .GT. IMAX .OR. NUM .LE. 0 ) GO TO 150                    
      IF ( LOC(NUM) .GT. 0 .AND. LENG(NUM) .GT. 0 ) RETURN              
 150  WRITE(6,153) NUM                                                    
 153  FORMAT ( '0***** NUMBERED OBJECT', I8, ' IS NOT DEFINED *****' /) 
      NUM = 0                                                           
      RETURN 1                                                          
C                                                                       
C     TRY TO FIND IT BY NAME                                            
C                                                                       
 200  CALL NXWORD ( NAME, &900, &900, &900 )                            
      NUM = NAMLOC( NAME )                                              
      IF ( NUM .NE. 0 ) RETURN                                          
      WRITE(6,253) NAME                                                   
 253  FORMAT ( '0******  ', A8, ' IS NOT A DEFINED NAME. ******' /)     
      NUM = 0                                                           
      RETURN 1                                                          
C                                                                       
C                                                                       
 900  WRITE(6,903)                                                         
 903  FORMAT ('0***** INPUT ERROR - EXPECTING NAME OR NUMBER *****')    
      NUM = 0                                                           
      RETURN 1                                                          
      END                                                               
      SUBROUTINE GETSCT (IRET)                                          
C                                                                       
C     COMPUTES SCATTERING WAVES AT LMIN AND LCRIT FOR GRDSET            
C                                                                       
C     7/8/75 - FIRST VERSION - S. P.                                    
C     8/3/75 - LCRIT IS ALREADY IN COMMON                               
C     9/4/75 - MULTIPLIER FOR LCRIT                                     
C     11/7/75 - REMOVE ABOVE MULTIPLIER                                 
C     9/1/76 - FIX FOR VERY LARGE L'S                                   
C     11/20/77 - NEW ORDERING OF WAVSET, WAVPOT, ETC - S.P.             
C     12/20/77 - FIX ERROR IN ABOVE CHANGE - S.P.                       
C     5/23/78 - NEW CALLING SEQUENCE FOR WAVELJ - S.P.                  
C     8/27/78 - FORCE WAVELJ TO ALWAYS START OVER - S.P.                
C     10/9/79 - TURN OFF SPIN-ORBIT AND TENSOR POTENTIALS - RPG         
C     4/14/80 - ZERO STORED S-MATRICES TO STOP DOUBLE COUNTING - S.P.   
C     12/14/81 - ALSO FOR C.C.; SAVE LNKBLK - S.P.                      
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      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 ONELSW, IDENSW                                            
      COMMON /INELCM/ JBPF,JBTF,LXMIN,LXMAX,ILILOR,ILILOI,MSTOP,IA12M, 
     *NMLOLX,ONELSW,NUMLX,IRDINT,IELCUP,LILOSZ,NUMLIS,ILIS,IBETAS(4), 
     *ICL2FF,LXSTEP,IDENSW,LSKIP,JPMIN,JPMAX,JPBASE,NJP,JTMIN,JTMAX, 
     *JTBASE,NJT,IINDXS,ISMATR,ISMATI,NSMAT,NLX,NSPLI,ITOCS,NASPLI, 
     *IUNITR,LIFIT,ILIFIT,NOLFIT,IDELSR,IDELSI
      INTEGER INDXJS(4,2)                                               
      EQUIVALENCE ( INDXJS(1,1), JPMIN )                                
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
      COMMON /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
      DIMENSION ISCRTS(2),DUMMM(1)
      EQUIVALENCE ( ISCRTS(1), ISCTMN )                                 
      LOGICAL IOUTSW, PINFSW                                            
      REAL*4 PHISGN                                                     
      COMMON /BSBLK/ S1, S2, T1, T2, BNDMXP, BNDMXT, RLPMAX, RLTMAX, VPM
     *AX, VTMAX, SCTMAX, SCTSP, BNDSPT, BNDSPP, BNDSPV, NSPBDT, NSPBDP, 
     *NSPBDV, JBDT, JBDP, JPOT, IOUTSW, NSPSCT, ALPHAP, ALPHAT, PINFSW, 
     *PHISGN, ROFMAX                                                    
      DIMENSION RLMAXS(2), VMAXS(2)                                     
      EQUIVALENCE ( RLMAXS(1), RLPMAX ), ( VMAXS(1), VPMAX )            
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
C                                                                       
C     THIS IS A DUPLICATE OF LNKBLK                                     
C                                                                       
      DIMENSION LNKAD3(6,12)                                            
      REAL*4 FG(4)                                                      
C                                                                       
      CHARACTER*8 NAMES(2)                                              
      DATA NAMES/'MAGSCTMN', 'MAGSCTCR'/                                
      LOGICAL SSOSW, STCSW, CCSW                                        
C                                                                       
      IPRNT = MOD(IPRINT, 10)                                           
      CCSW = PROBLM .EQ. 24                                             
      ITOP = 2                                                          
      IF (CCSW) ITOP = 1                                                
C                                                                       
C     INITIALIZE THE COULOMB FUNCTIONS, ETC.                            
C                                                                       
      DO 59 ICHANW = 1, ITOP                                            
      CALL WAVPOT ( IRET )                                              
      IF ( IPRNT .GE. 5 ) WRITE(6,53) ICHANW, IRET, IHSAVE                
 53   FORMAT (' ++++ WAVPOT CALL, ICHANW, IRET, IHSAVE =', 4I10 )       
      IF ( IRET .EQ. 0 ) RETURN                                         
 59   CONTINUE                                                          
C                                                                       
      IF ( IHSAVE .EQ. 2 ) RETURN                                       
C                                                                       
C                                                                       
      LC = LCRIT                                                        
      IF ( LC .LT. LMIN .OR. LC .GT. LMAX ) LC = (LMIN+LMAX)/2          
C                                                                       
C                                                                       
      IF ( IPRNT .GE. 3 ) WRITE(6,83) LCRIT, LC                           
 83   FORMAT ( '  L CRITICAL:  AVERAGE =', I4, 5X,  'USED FOR GRID SETUP
     * =', I4 )                                                         
C                                                                       
C     COMPUTE THE WAVEFUNCTIONS, USING CENTRAL POTENTIALS ONLY.         
C                                                                       
      STANSW = .TRUE.                                                   
      SSOSW = SOSWS(1)                                                  
      SOSWS(1) = .FALSE.                                                
      STCSW = TCSWS(1)                                                  
      TCSWS(1) = .FALSE.                                                
C                                                                       
      L = MAX0( 0, LMIN-LXMAX )                                         
      NSTEPS = NSTPSS(1) + 1                                            
      RSTEP = RSTEPS(1)                                                 
C                                                                       
C     WAVELJ WILL SET LNKBLK BACK TO THE STATUS FOR THE INCOMING        
C     CHANNEL.  IT MAY HAVE BEEN CHANGED JUST FOR THE FORM FACTOR.      
C     THEREFORE WE SAVE ITS STATUS.                                     
C                                                                       
      DO 152 II = 1, NUMLNK                                             
      DO 152 I = 1, 6                                                   
      LNKAD3(I,II) = LNKADR(I,II)                                       
 152  CONTINUE                                                          
C                                                                       
      DO 399 II = 1, ITOP                                               
      LWAVR = Z(IWAVR)                                                  
      LWAVI = Z(IWAVI)                                                  
      LVREAL = Z(IRLVS(1))                                              
      LVIMAG = Z(IIMVS(1))                                              
      LCENTR = Z(ICENTR(1))                                             
      LSMATS = Z(ISMATS(1))                                             
C                                                                       
C     ALWAYS FORCE WAVELJ TO START OVER AND STEP OUT SLOWLY LOOKING FOR 
C     OVERFLOWS.  THIS IS NECESSARY SINCE WE MAKE A LARGE JUMP IN L THAT
C     WAVELJ IS NOT EXPECTING.                                          
C                                                                       
      LASTL(1) = 999999                                                 
      FG(1) = ALLOC(Z(NF1S(1))+L)                                       
      FG(2) = ALLOC(Z(NG1S(1))+L)                                       
      FG(3) = ALLOC(Z(NFS(1))+L)                                        
      FG(4) = ALLOC(Z(NGS(1))+L)                                        
      CALL WAVELJ( L, 2*L+JSPS(1), 1, 0, dummm, FG, dummm,  ALLOC(LWAVR)
     *, ALLOC(LWAVI),  ALLOC(LVREAL), ALLOC(LVIMAG), ALLOC(LCENTR) )
C                                                                       
C     JPTOLX HAS STORED AN S-MATRIX.  LATER ON WE WILL ACCUMULATE A     
C     SUM OF CONTRIBUTIONS IN THIS SPOT SO WE MUST ZERO IT AGAIN.       
C                                                                       
      ALLOC(LSMATS+2*L) = 0                                             
      ALLOC(LSMATS+2*L+1) = 0                                           
C                                                                       
C     COMPUTE AND STORE   RPSI                                          
C                                                                       
      IF ( CCSW ) GO TO 400                                             
      PSIMX = 0                                                         
      RPSIMX = 0                                                        
      ISCRTS(II) = NALLOC(NSTEPS, NAMES(II))                            
      LSCRTS = Z(ISCRTS(II)) - 1                                        
      RVAL = -RSTEP                                                     
C                                                                       
      DO 389 I = 1, NSTEPS                                              
      RVAL = RVAL + RSTEP                                               
      PSI = DABS(ALLOC(LWAVR-1+I)) +  DABS(ALLOC(LWAVI-1+I))            
      IF ( PSI .GT. PSIMX ) ROFMAX = RVAL                               
      PSIMX = DMAX1( PSIMX, PSI )                                       
      RPSIMX = DMAX1( RPSIMX, RVAL*PSI )                                
      ALLOC(LSCRTS+I) = RVAL*PSI                                        
 389  CONTINUE                                                          
      IF ( IPRNT .GE. 4 ) WRITE(6,393) L, PSIMX, ROFMAX, RPSIMX, PSI      
 393  FORMAT (' FOR L =', I4, ', MAX(PSI) =', G11.3,  '   IS AT R =', F5
     *.1, 5X, 'MAX(R*PSI) =', G11.3,  5X, 'FINAL PSI =', G11.3 )        
C                                                                       
      L = LC                                                            
 399  CONTINUE                                                          
C                                                                       
 400  STANSW = .FALSE.                                                  
      SOSWS(1) = SSOSW                                                  
      TCSWS(1) = STCSW                                                  
C                                                                       
      DO 159 II = 1, NUMLNK                                             
      DO 159 I = 1, 6                                                   
      LNKADR(I,II) = LNKAD3(I,II)                                       
 159  CONTINUE                                                          
C                                                                       
      IF ( .NOT. CCSW ) GO TO 500                                       
C                                                                       
C     WAVPOT ESPECIALLY SETUP COULOMB FUNCITONS FOR THIS ONE CALL       
C     THEY ARE NOLONGER NEEDED SO RESTORE TO NORMAL C.C. MODE.          
C                                                                       
      Z(NFS(1)) = -Z(NFS(1))                                            
      Z(NGS(1)) = -Z(NGS(1))                                            
      Z(NF1S(1)) = -Z(NF1S(1))                                          
      Z(NG1S(1)) = -Z(NG1S(1))                                          
C                                                                       
C     SAVE STUFF FOR BSPROD                                             
C                                                                       
 500  NSPSCT = NSTEPS                                                   
      SCTMAX = ASYMPS(1)                                                
      SCTSP = 1/RSTEP                                                   
      RETURN                                                            
      END                                                               
      SUBROUTINE GRDSET ( IRTN )                                        
C                                                                       
C     SETS UP INTEGRATION GRIDS FOR THE TRANSFER INTEGRALS I(LI,LO,LX)  
C                                                                       
C     THIS ROUTINE PREPARES THE THREE-DIMENSIONAL GRID FOR THE          
C     INELDC INTEGRALS.  IT COMPUTES ALL THE NECESSARY BOUND STATE      
C     PRODUCTS ON THIS GRID.                                            
C     THIS ROUTINE IS CALLED BEFORE THE WAVPOT CALLS.  BASED ON         
C     THE VALUES OF THE BOUND STATE PRODUCTS IT DETERMINES THE          
C     MAXIMUM RI AND RO VALUES THAT WILL BE REQUIRED.  THESE ARE        
C     USED BY WAVPOT TO ALLOCATE SCRATCH SPACE FOR WAVELJ.              
C                                                                       
C       SEE INELDC FOR HISTORY PRIOR TO THE SPLIT                       
C     2/7/75 - SPLIT OFF FROM INELDC - S. PIEPER                        
C     2/13/75 - REMOVE  */RIX  STUFF FROM BOUND STATES - S.P.           
C     2/19/75 - CUBIC MAPPINGS IN U V INTEGRALS; VARIABLE NO OF PTS     
C               IN V INTEGRAL (DENSITY CONSTANT) -MHM                   
C     2/21/75 - USE AITLAG                                              
C     2/23/75 - USE REAL*4 FOR THE VERY LARGE ARRAYS                    
C     3/5/75 - USE NEW GRID KEYWORDS, DIFFERENT MAPTYPES                
C     3/7/75 - CHANGE CHOICE OF TRANSFERRED L                           
C     3/17/75 - USE IXADD TO INCREASE X-RANGES.                         
C     3/20/75 - WAVEFUNCTIONS IN SINGLE PRECISION                       
C     3/23/75 - NEW ARRANGEMENT OF A12                                  
C     3/27/75 - COSINE TABLE TO 2PI; ONE MSVAL ARRAY                    
C     4/7/75 - NEW LA, LX STUFF; REMOVE VARIABLE POINTS                 
C     4/18/75 - NEW COMMON; VERTEX CHOICE; AUTO FLIP OF LINES           
C     5/20/75 - USE LSTEP; NEW RT AND RP NAMES                          
C     5/21/75 - ALLOC SPACE FOR ALL LA'S FOR GIVEN LB'S.                
C     5/24/75 - V*PHI INCLUDES CORE-COULOMB CORRECTION (NUCONL=3)       
C     5/28/75 - GOOD GOD, WE MUST SPLIT IT AGAIN - 3-WAY SPLIT -        
C               PRBPRT, GRDSET AND ANGSET PRODUCED.                     
C     6/1/75  - GATHER ALL BOUND-STATE INTERPOLATIONS INTO NEW          
C               SUBPROGRIM. FUNCTION BSPROD RETURNS BS PRODUCT          
C               INCLUDING CORE-COULOMB CONTRIBUTION TO VEFF             
C               IF NUCONL=2.   (MHM)                                    
C     6/2/75  - MODIFIED ALSO TO HANDLE CORE CORRECTIONS FOR PICK-UP    
C     6/11/75 - SAVEHS/USEHS                                            
C     6/14/75 - MIDMULT ADDED                                           
C     6/28/75 - USE GAUSSL; PRINT WARNINGS FOR EXCEEDING ASYMPT         
C     7/1/75 - DO NOT ALLOW SMALL RP, RT VALUES OF PHI OR V*PHI         
C              LIMIT THE INTEGRATION RANGES.                            
C     7/7/75 - MOVE RP, RT, RCORE AND RSCAT CALCS INTO BSPROD           
C     7/10/75 - INCLUDE SCAT WAVE IN MAPPING PROCESS; COMPUT GAMMAS     
C     8/2/75 - REMOVE AUTO GAMMA (DIDN'T WORK); NOTHING FOR PRINT=2     
C     8/3/75 - RECTANGULAR GRIDS FOR CONTOUR MAPPING                    
C     9/8/75 - SMALL CLEANUPS                                           
C     9/15/75 - NEW DWCUT DEFINITION                                    
C     9/25/75 - FIX LOGIC ARRAY FOR USEHS                               
C     10/6/75 - NEW COMMON BLOCKS                                       
C     2/21/76 - WHEN FINDING UMAX, CHECK FIVE V'S AT EACH U.            
C     4/29/76 - MOVE SECTION SETTING UP RADII ETC. FOR USE              
C               IN CALCULATING CORE TERMS IN VEFF INTO BSPROD           
C               ALLOW FOR NUCONL = 3.  MHM                              
C      5/17/76 MAKE V-MAPPING PARAMETERS CONTINUOUS - S.P.              
C      5/23/76 - USE SUMPOINTSPER; TWO SUM ARRAYS, ETC - S.P.           
C     9/1/76 - FIX ERRORS FOR LARGE L                                   
C     11/22/77 - NEW WAVPOT; MUST EXPAND WAVER,I HERE - S.P.            
C     3/13/78 - DON'T USE POLYNOMIALS WHEN NPSUM=NPSUMI                 
C               IMPROVEMENTS IN KEEPING VMID IN BOUNDS                  
C     5/24/78 - BIGGER WAVR, WAVI ARRAYS FOR NEW WAVELJ - S.P.          
C     5/4/79 - PROPER KINEMATIC MASSES - S.P.                           
C     6/6/79 - EXTEND "WAVE_" FOR TENSORS, USE BIGNUM - RPG             
C     6/8/79 - STANDARD PREFIXES - RPG                                  
C     7/6/79 - DON'T UNALLOCATE B.S. WF & POT. FOR MULTIPASS - RPG      
C     9/12/79 - INTEGRATE OVER PHI, NOT COS(PHI); MAKE "LOGIC"          
C        INTEGER AND DON'T SAVE IT; PUT RI*RO*JACOB IN "RIROWTS". - RPG 
C     6/3/79 - ALWAYS USE CORE MASSES TO GET CORRECT NON-RELATIVISTIC   
C              KINEMATICS WHEN BINDING ENERGIES CANNOT BE IGNORED - S.P.
C     10/11/79 - IGNORE MOST ASYMPTOPIA VIOLATIONS IN SUMMAX SEARCH -RPG
C     11/26/79 - MAKE SURE THE FINAL V RANGES ARE LEGAL. - RPG          
C     12/12/79 - OPTIONAL SCRATCH FILE, CORRECT ABOVE, USE RI*RO WEIGHT 
C        IN V SEARCH - RPG                                              
C     2/12/80 - CVX TO CVA, USE NBLKSZ FOR SCRATCH FILE - RPG           
C     2/20/80 - MAP PHI USING MAPPHI, PHIMID, GAMPHI - RPG              
C     2/29/80 - REDUCE U-V RECTANGLE SIZE; CHECK LEGALITY OF INTERP. V; 
C        CALL WRITSC - RPG                                              
C     3/15/80 - WRITSC CALL MADE VAX ONLY - S.P.                        
C     4/14/80 - PRINT ERROR MESSAGE WHEN DIF-GRID EXCEEDS BOUNDS - S.P. 
C     6/12/81 - DON'T FAIL LOOKING FOR SUMMIN WHEN IT IS GIVEN - S.P.   
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      COMMON /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
      REAL*8 JACOB                                                      
      COMMON /GRIDCM/ JACOB, STPINV, COSSTP, IMSVAL, IINTS, INTOFF, IA12
     *VL, ICOSIN, IPHIT, IPHIP, IPHI, LOGIC, LOCTRP, IRI, IRO, ILOR, ILO
     *I, ILIR, ILII, IWIO, NOFLO, NRIROI, NCRIT, IXLAM, INLAM, IA12N, MS
     *KCOS, MAXCNT, ISMHPT, ISMIPT, ICOSS4, IJA12S, IHS, IIINDX, IA12TM,
     * IDW, IHINT, IHABS, IABS1, IGRDC1, NPSUMI, RVRLIM, ISMHWK, ISMHVL,
     * ISMIVL, IRIOEX, NUMHS, IGRDC2(4), IWFII, IWFIO, NWFI, NWFO, IDWI 
      COMMON /FORMF/ IBDS(2), NPOTS(2), LBP, LBT, NBP, NBT, JBP, JBT, BN
     *DMAX(2), BNDSTP(2), NSTPBD(2), RBNDS(2), ABNDS(2), RCBNDS(2), BNDM
     *AS(2), BRATMS(2), RSOBDS(2), ASOBDS(2), VBNDS(2), VSOBDS(2), TAUBD
     *S(2), LNKADB(6,2,12)                                              
      LOGICAL IOUTSW, PINFSW                                            
      REAL*4 PHISGN                                                     
      COMMON /BSBLK/ S1, S2, T1, T2, BNDMXP, BNDMXT, RLPMAX, RLTMAX, VPM
     *AX, VTMAX, SCTMAX, SCTSP, BNDSPT, BNDSPP, BNDSPV, NSPBDT, NSPBDP, 
     *NSPBDV, JBDT, JBDP, JPOT, IOUTSW, NSPSCT, ALPHAP, ALPHAT, PINFSW, 
     *PHISGN, ROFMAX                                                    
      DIMENSION RLMAXS(2), VMAXS(2)                                     
      EQUIVALENCE ( RLMAXS(1), RLPMAX ), ( VMAXS(1), VPMAX )            
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      INTEGER IZDUMY(45)                                                
      EQUIVALENCE ( IZDUMY(1), IMSVAL )                                 
C                                                                       
      LOGICAL PAS1SW, ZEROSW                                            
      LOGICAL PRNTSW, PGRDSW                                            
C                                                                       
C     NPLYSW = .TRUE. MEANS V-POLYNOMIALS ARE NOT TO BE USED            
C                                                                       
      LOGICAL NPLYSW                                                    
C                                                                       
      DIMENSION VS(5), XS(2)                                            
      DATA XS / 1.D0, 0.D0 /                                            
      DIMENSION VRANGE(3)                                               
C                                                                       
      TINTRP = 0                                                        
      NINTRP = 0                                                        
      IRTN = 0                                                          
C                                                                       
      IPRNT = MOD( IPRINT, 10 )                                         
      PGRDSW = IPRNT .GE. 5                                             
      PINFSW = IPRNT .GE. 4                                             
      PRNTSW = IPRNT .GE. 1                                             
      IF ( PINFSW ) WRITE(6,3)                                             
  3   FORMAT ( / ' SETUP OF THE INTEGRATION GRIDS:' )                   
C                                                                       
C     MAKE THINGS EASY FOR INELDC WHEN  USEHS  IS IN EFFECT BY          
C     ALLOWING DUMMY  Z(I...)'S.                                        
C                                                                       
      DO 39 I = 1, 45                                                   
 39   IZDUMY(I) = 1                                                     
C                                                                       
C     RESTORE STUFF FROM H  S FILE IF NEEDED                            
C                                                                       
      IF ( IHSAVE .NE. 2 ) GO TO 50                                     
      READ ( 1, END=9950, ERR=9950 ) NPSUM, NPDIF, NPPHI,  MAXCNT, JSIZE
     *, GAMSUM, SUMMIN, SUMMID, SUMMAX,  GAMDIF, VRNGMN, VRNGMX, X0MIN, 
     *X0AV, RPMAX, RTMAX,  NRIROH, ALPHAP, ALPHAT, AREA, WVWMAX, NPLYSW 
C                                                                       
 50   INADD=2                                                           
      IF(NUCONL.GE.2) INADD=3                                           
C                                                                       
C********  TEMPORARY  ******************************************        
      IRECT = ISW3                                                      
C*******************  END OF TEMPORARIES  **********************        
C                                                                       
C     THE CODE IS BASED ON THE ASSUMPTION THAT THE INCOMING PROJECTILE  
C     IS COMPOSITE ( A = B+X ).  IF THIS IS NOT SO, WE CHANGE THE       
C     DEFINITION OF S1, T1, S2, T2 SO THAT                              
C        RT = S1*RI + T1*RO                                             
C        RP = S2*RI + T2*RO                                             
C     WHERE                                                             
C        RT = VECTOR FROM CORE TO X IN TARGET                           
C        RP = VECTOR FROM CORE TO X IN PROJECTILE.                      
C     FOR BOTH CASES.  IN THIS WAY IT IS NOT NECESSARY TO FLIP          
C     AROUND THE BOUND STATE WAVEFUNCTIONS NOR L1 AND L2.  HOWEVER,     
C     THE FLIP DOES REQUIRE THAT THE SYNES OF PHI1 AND PHI2 BE          
C     MADE NEGATIVE.                                                    
C                                                                       
CCCC      TEMP = 1/(AMX*(AMB+AMBIGA+AMX))                               
CCCC      S1 =  (AMB+AMX)*(AMBIGA+AMX)*TEMP                             
CCCC      T1 = -AMB * ((AMBIGA+AMX)*TEMP)                               
CCCC      S2 =  AMBIGA * (AMB+AMX)*TEMP                                 
C                                                                       
C     THE FOLLOWING EXPRESS THE ABOVE COMMENTED LINES IN TERMS          
C     OF THE KINEMATICALLY CORRECT MASS RATIOS                          
C        X/B   X/BIGA                                                   
C                                                                       
      TEMP = 1 / ( BRATMS(1) + BRATMS(2) * (1+BRATMS(1)) )              
      S1 = ( 1 + BRATMS(1) ) * ( (1 + BRATMS(2) ) * TEMP )              
      T1 = - ( 1 + BRATMS(2) ) * TEMP                                   
      S2 = ( 1 + BRATMS(1) ) * TEMP                                     
C                                                                       
      T2 = -S1                                                          
      JACOB = S1**3                                                     
      PHISGN = 1                                                        
      IF ( ISTRIP .EQ. 1 ) GO TO 170                                    
C                                                                       
C     B = A+X, FLIP THINGS                                              
C                                                                       
C                                                                       
C     IN THE FOLLOWING NOTE THAT BRATMS(1) NOW HAS X/A                  
C                                                                       
      T2 = S2                                                           
      S2 = -S1                                                          
      S1 = T1                                                           
C                                                                       
      T1 = -S2                                                          
      JACOB = T1**3                                                     
      PHISGN = -1                                                       
C                                                                       
  170 IF (PINFSW) WRITE(6,173) S1, T1, S2, T2, JACOB                      
 173  FORMAT (' R TO RX MAPPING PARAMETERS (S1, T1, S2, T2) =',  4G15.5,
     * 5X, 'JACOB =', G15.5 )                                           
      ST1=2.D0*S1*T1                                                    
      ST2=2.D0*S2*T2                                                    
C                                                                       
      IF ( IHSAVE .EQ. 2 ) GO TO 400                                    
C                                                                       
C     INITIALIZE THE COMPUTATION OF  (PHI V PHI)                        
C                                                                       
      CALL BSSET                                                        

CDC      CALL BSSET (FIFO,1,U,U,XS,ISCTMN,1,RP,RT),RETURNS(180)         
CDC 180  CONTINUE                                                       
C                                                                       
      IF(LOOKST.GT.254) LOOKST=254                                      
      DXV=2.D0/LOOKST**2                                                
      XS(2) = 1 - DXV                                                   
C                                                                       
C     FIND THE MAXIMUM  ( R PSI PHI V PHI PSI R )   THAT WE WILL        
C     ENCOUNTER AND USE THIS TO SCALE DWCUT                             
C                                                                       
      WVWMAX = 0                                                        
      U = .5*ROFMAX                                                     
      N = 1.5*ROFMAX/.20D0 + 1                                          
      VS(3) = 0                                                         
      DO 269 IU = 1, N                                                  
C                                                                       
C     WE LOOK AT 5 DIFFERENT V'S FOR EACH U                             
C                                                                       
      D = 2*(RLMAXS(2)-(S1+T1)*U)/(S1-T1)                               
      IF ( DABS(D) .GT. 2*U ) D = DSIGN(2*U, D)                         
      VS(1) = D                                                         
      VS(2) = .5*D                                                      
      D = 2*(RLMAXS(1)-(S2+T2)*U)/(S2-T2)                               
      IF ( DABS(D) .GT. 2*U ) D = DSIGN(2*U, D)                         
      VS(4) = .5*D                                                      
      VS(5) = D                                                         
      DO 265 IV = 1, 5                                                  
      VVAL = VS(IV)                                                     
      DO 265 I = 1, 2                                                   
      CALL BSPROD ( FIFO, 3, U+.5*VVAL, U-.5*VVAL, XS(I),  ISCTMN, 1, RP
     *, RT, &264 )                                                      
      IF ( DABS(FIFO) .LE. WVWMAX ) GO TO 264                           
      WVWMAX = DABS(FIFO)                                               
      UMAX = U                                                          
      VMAX = VVAL                                                       
      RPMAX = RP                                                        
      RTMAX = RT                                                        
 264  CONTINUE                                                          
 265  CONTINUE                                                          
      U = U + .20D0                                                     
 269  CONTINUE                                                          
      NINTRP = NINTRP + 10*N*(INADD+2)                                  
      IF ( PINFSW ) WRITE(6,273) UMAX, VMAX, RPMAX, RTMAX, WVWMAX         
 273  FORMAT ( ' MAX(RI PSI PHI V PHI PSI RO) OCCURS AT',  ' SUM, DIF, R
     *P, RT =', 4F8.2, 5X, 'VALUE =', G13.3 )                           
      RVRLIM = DWCUT*WVWMAX                                             
C                                                                       
C     STEP OUT FROM  U = 0  LOOKING FOR SUMMIN.                         
C     WE LOOK FOR U SUCH THAT                                           
C       PSI(LMIN) PHI' V PHI' PSI(LMIN)                                 
C     EXCEEDS VZERO.                                                    
C                                                                       
      USTEP = .20D0                                                     
      U = 0                                                             
 320  DO 324 I = 1, 2                                                   
      CALL BSPROD ( FIFO, 4, U, U, XS(I), ISCTMN, 1,  RP, RT, &325 )    
      IF ( DABS(FIFO) .GE. RVRLIM ) GO TO 330                           
 324  CONTINUE                                                          
      NINTRP = NINTRP + 2*(INADD+2)                                     
      U = U + USTEP                                                     
      GO TO 320                                                         
C                                                                       
 325  WRITE(6,326)                                                         
 326  FORMAT ('0**** ASYMPTOPIA IS FAR TOO SMALL - CANNOT FIND',  ' SUMM
     *IN.' )                                                            
      U = U-USTEP                                                       
      IF ( SUMMIN .NE. UNDEF ) GO TO 330                                
      IRTN = 0                                                          
      RETURN                                                            
C                                                                       
C     SUMMIN FOUND, DO WE OVERRIDE IT                                   
C                                                                       
 330  U = DMAX1( 0.D0, U-USTEP )                                        
      IF ( SUMMIN .EQ. UNDEF ) SUMMIN = U                               
      IF ( PINFSW ) WRITE(6,333) U, SUMMIN                                
 333  FORMAT ( ' SUMMIN:  PROPOSED =', G14.5, 5X, 'USED =', G14.5 )     
C                                                                       
C     NOW FIND SUMMAX USING                                             
C       PSI(L CRIT) PHI V PHI PSI(L CRIT)                               
C     AND COMPUTE MOMENTS OF THE WEIGHT FUNCTION.  NOTE THAT WE         
C     MAKE SURE THAT WE DON'T STOP TOO SOON DUE TO SMALL RP OR RT.      
C                                                                       
      SUM0 = 0                                                          
      SUM1 = 0                                                          
      SUM2 = 0                                                          
      PVPMAX = 0                                                        
      IF ( IPRNT .GE. 7 ) WRITE(6,347)                                     
 347  FORMAT ( 7X, 'U', 9X, 'SUM(F  S)', 6X, 'MAX(F)',  5X, 'V OF M
     *AX', 4X, 'RP OF MAX', 4X, 'RT OF MAX' / )                         
      U = SUMMIN                                                        
      ULIM = DMAX1( RSCTS(1)+10*ASCTS(1), ROFMAX+5 )                    
C                                                                       
 350  TEMP = 0                                                          
      WVWMAX = 0                                                        
      ZEROSW = .TRUE.                                                   
C                                                                       
C     WE LOOK AT 5 DIFFERENT V'S FOR EACH U                             
C     AT EACH U, V PAIR WE LOOK AT 2 X'S                                
C     FOR THIS SEARCH, VIOLATIONS OF BOUND-STATE ASYMPTOPIA ARE         
C     IGNORED (TREATED AS ZERO) UNLESS ALL TEST POINTS ARE BAD.         
C                                                                       
      D = 2*(RLMAXS(2)-(S1+T1)*U)/(S1-T1)                               
      IF ( DABS(D) .GT. 2*U ) D = DSIGN(2*U, D)                         
      VS(1) = D                                                         
      VS(2) = .5*D                                                      
      D = 2*(RLMAXS(1)-(S2+T2)*U)/(S2-T2)                               
      IF ( DABS(D) .GT. 2*U ) D = DSIGN(2*U, D)                         
      VS(4) = .5*D                                                      
      VS(5) = D                                                         
      DO 359 IV = 1, 5                                                  
      VVAL = VS(IV)                                                     
      DO 359 I = 1, 2                                                   
      CALL BSPROD ( FIFO, 3, U+.5*VVAL, U-.5*VVAL, XS(I),  ISCTCR, 1, RP
     *, RT, &359 )                                                      
      TEMP = TEMP + DABS(FIFO)                                          
      IF ( WVWMAX .GT. DABS(FIFO) ) GO TO 359                           
      WVWMAX = DABS(FIFO)                                               
      VMAX = VVAL                                                       
      RPMAX = RP                                                        
      RTMAX = RT                                                        
      ZEROSW = .FALSE.                                                  
 359  CONTINUE                                                          
      IF ( ZEROSW ) GO TO 375                                           
      NINTRP = NINTRP + 10*(INADD+2)                                    
      SUM0 = SUM0 + TEMP                                                
      SUM1 = SUM1 + TEMP*U                                              
      SUM2 = SUM2 + TEMP*U*U                                            
      IF ( PVPMAX .GT. TEMP ) GO TO 364                                 
      PVPMAX = TEMP                                                     
      UMAX = U                                                          
 364  IF ( IPRNT .GE. 7 ) WRITE(6,367) U,TEMP,WVWMAX,VMAX,RPMAX,RTMAX
 367  FORMAT ( 6G13.3 )                                                 
      IF ( WVWMAX .GE. RVRLIM .OR. U .LT. ULIM ) GO TO 365              
      IF ( RP .GT. RLMAXS(1) .AND. RT .GT. RLMAXS(2) ) GO TO 380        
 365  U = U + USTEP                                                     
      GO TO 350                                                         
C                                                                       
C     COMPLAIN IF ALL TEST POINTS FOR A GIVEN VALUE OF U ARE BEYOND     
C     BOUND-STATE ASYMPTOPIA.                                           
C                                                                       
 375  WRITE(6,378)                                                         
 378  FORMAT ( '0**** WARNING:  SEARCH FOR SUMMAX WAS STOPPED',  'BY THE
     * BOUND STATE ASYMPTOPIA.' /  '0**** IN FUTURE RUNS INCREASE ONE OR
     * BOTH ASYMPTOPIA.' )                                              
      U = U - USTEP                                                     
C                                                                       
C     SUMMAX IS FOUND.                                                  
C                                                                       
 380  IF ( SUMMAX .EQ. UNDEF ) SUMMAX = U                               
      IF ( PINFSW ) WRITE(6,381) U, SUMMAX                                
 381  FORMAT ( ' SUMMAX:  PROPOSED =', G14.5, 5X, 'USED =', G14.5 )     
C                                                                       
C     COMPUTE SUMMID AS THE FIRST MOMENT OF U.                          
C                                                                       
      U = SUM1/SUM0                                                     
      SUM2 = SUM2/SUM0                                                  
      SUM2 = DSQRT(SUM2)                                                
      IF ( SUMMID .EQ. UNDEF ) SUMMID = U*AMDMLT                        
      IF ( PINFSW ) WRITE(6,388) U, SUM2, UMAX, U, SUMMID                 
 388  FORMAT (' <SUM> =', G14.5, 5X, 'SQRT<SUM**2> =', G14.5,  5X, 'SUM
     *(MAX TERM) =', G14.5 /  ' SUMMID:  PROPOSED =', G14.5, 5X, 'USED =
     *', G14.5 )                                                        
C                                                                       
C     ADJUST SUMMIN, SUMMID TO REQUIREMENTS OF CUBIC MAP.  THESE ARE    
C     LIKELY TO BE REASONABLE CONDITIONS EVEN WHEN NOT USING CUBIC MAP  
C                                                                       
      SUMMIN = DMIN1( SUMMIN, 7.D0*(SUMMID-SUMMAX/7.D0)/6.D0 )          
      SUMMID = DMIN1( SUMMID, .5*(SUMMIN+SUMMAX) )                      
      IF (PINFSW) WRITE(6,393) SUMMIN, SUMMID, SUMMAX                     
  393 FORMAT ( ' FINAL CHOICE OF SUMMIN, SUMMID, SUMMAX =', 5G15.5 )    
C                                                                       
C     SUMMIN AND SUMMAX NOW KNOWN; PERFORM SINH MAP OF @SUMMIN,SUMMAX@  
C     TO @-1,1@ ; COMPUTE AND STORE GAUSS-LEGENDRE PTS                  
C        FOR BOTH THE H'S AND THE INTERPOLATED INTEGRAL GRID            
C                                                                       
 400  ISMHPT=NALLOC( NPSUM, 'SUMHPTS ' )                                
      ISMHWK=NALLOC( 3*NPSUM, 'SUMHWORK' )                              
C                                                                       
C     THE NUMBER OF POINTS FOR THE INTERPOLATED INTEGRAL GRID           
C     IS BASED ON THE WAVE-LENGTH                                       
C                                                                       
      NPSUMI = (SUMMAX-SUMMIN)*SUMPTS*(AKI+AKO)/(4*PI)                  
      NPSUMI = MAX0( NPSUMI, NPSUM )                                    
      IF ( IHSAVE .NE. 2 ) NPLYSW = NPSUMI .EQ. NPSUM                   
      IF ( .NOT. NPLYSW .OR. NPSUM .EQ. NPSUMI ) GO TO 404              
      WRITE(6,403) NPSUMI, NPSUM                                          
 403  FORMAT ( '0**** WARNING:  NPSUMI WAS COMPUTED TO BE', I5 /  6X, 'B
     *UT DUE TO LIMITATIONS OF THE SAVEHS RUN',  ' IT WILL BE LIMITED TO
     *', I5 )                                                           
      NPSUMI = NPSUM                                                    
C                                                                       
 404  ISMIPT = NALLOC( NPSUMI, 'SUMIPTS ' )                             
      ISMIVL = NALLOC( NPSUMI, 'SUMIVALS' )                             
C     GENERATE GAUSS POINTS FOR U                                       
      CALL CUBMAP ( MAPSUM, SUMMIN, SUMMID, SUMMAX, GAMSUM,  ALLOC(Z(ISM
     *IPT)), ALLOC(Z(ISMIVL)), NPSUMI )                                 
C                                                                       
      NRIROI = NPSUMI*NPDIF                                             
      N4RIO = (NRIROI+FACFR4-1)/FACFR4                                  
      IWIO = NALLOC( N4RIO, 'RIROWTS ' )                                
      IRI = NALLOC( N4RIO, 'RIPTS ' )                                   
      IRO = NALLOC( N4RIO, 'ROPTS ' )                                   
      IDIFPT = NALLOC( NPDIF, 'DIFPTS ' )                               
      IDIFWT = NALLOC( NPDIF, 'DIFWTS ' )                               
      NPOLSV = 3*NVPOLY+3                                               
      IVPOLS = NALLOC( NPOLSV, 'VPOLYS ' )                              
C                                                                       
C     IF USING H'S, RESTORE GENERATED SUM POINTS AND POLYS              
C                                                                       
      IF ( IHSAVE .NE. 2 ) GO TO 405                                    
      READ ( 1, END=9950, ERR=9950 )  ( ALLOC(Z(IVPOLS)-1+I), I = 1, NPO
     *LSV ),  ( ALLOC(Z(ISMHPT)-1+I), I = 1, NPSUM )                    
      II = 3*NPSUM                                                      
      IF ( NPLYSW ) READ ( 1, END=9950, ERR=9950 )  ( ALLOC(Z(ISMHWK)-1+
     *I), I = 1, II )                                                   
      GO TO 700                                                         
C                                                                       
 405  CALL CUBMAP ( MAPSUM, SUMMIN, SUMMID, SUMMAX, GAMSUM,  ALLOC(Z(ISM
     *HPT)), ALLOC(Z(ISMHWK)), NPSUM )                                  
C                                                                       
C                                                                       
C     SETUP THE DIFFERENCE GRID.                                        
C                                                                       
C                                                                       
C     THE STAGES ARE                                                    
C                                                                       
C     1)  DETERMINE THE RANGE OF V FOR EACH VALUE OF U.                 
C                                                                       
C     2)  INSIDE EACH V-RANGE, FIND THE MOMENTS OF V AND THUS           
C         THE "MID-POINT".                                              
C                                                                       
C     3)  MAKE A LOW-DEGREE POLYNOMIAL FIT TO THE MID- AND END-         
C         POINTS.  THIS POLY IS THEN USED TO PROVIDE CONTINUOUS         
C         U-V CONTOURS.                                                 
C                                                                       
C     4)  GENERATE ALL THE RI, RO PAIRS FOR FINDING H'S                 
C                                                                       
C     5)  GENERATE ALL RI, RO PAIRS FOR THE INTERPOLATED INTEGRATION    
C         GRID.                                                         
C                                                                       
C     IN ALL THESE OPERATIONS WE DO NOT INCLUDE THE SCATTERING          
C     WAVEFUNCTIONS SINCE  V << U  SO THAT RI, RO WILL VARY ONLY        
C     A LITTLE FOR FIXED U.  THIS ASSUMPTION IS NOT NECESSARILY TRUE    
C     FOR LIGHT IONS.                                                   
C                                                                       
C     IN FINDING THE EXTREMA OF THE V'S, WE USE                         
C       PHI' V PHI'                                                     
C                                                                       
      NRIROH = NPDIF*NPSUM                                              
      IRIOEX = NALLOC( NRIROH, 'RIROEXPS' )                             
      IRIH = NALLOC( NRIROH, 'RIH ' )                                   
      IROH = NALLOC( NRIROH, 'ROH ' )                                   
C     WORK AREAS FOR STAGE 3                                            
      IVWORK = NALLOC( 4*NPSUM+3+(NVPOLY+1)**2, 'VPOLYWRK' )            
      LVPOLS = Z(IVPOLS)                                                
      LVWTS = Z(IVWORK)                                                 
      LVRESD = LVWTS+NPSUM                                              
      LVSMSQ = LVRESD + 3*NPSUM                                         
      LVAMAT = LVSMSQ + 3                                               
      LVMIN=Z(ISMHWK)-1                                                 
      LVMID = LVMIN + NPSUM                                             
      LVMAX = LVMID + NPSUM                                             
      LRIH = Z(IRIH) - 1                                                
      LROH = Z(IROH) - 1                                                
      LRIOEX = Z(IRIOEX) - 1                                            
      LDIFPT=Z(IDIFPT)-1                                                
      LDIFWT=Z(IDIFWT)-1                                                
      LSUMPT = Z(ISMHPT) - 1                                            
C                                                                       
C        STAGE 1)  END POINTS OF EACH V-RANGE.                          
C                                                                       
      VMAX = 1                                                          
      VMIN = 1                                                          
      NBUMPS = 0                                                        
      RPMAX = 0                                                         
      RTMAX = 0                                                         
      DV = 1.D0/LOOKST                                                  
C                                                                       
      DO 489 IU=1,NPSUM                                                 
C                                                                       
      U=ALLOC(LSUMPT+IU)                                                
      VLEN=2.D0*U                                                       
      IF ( U .LT. 1 ) GO TO 465                                         
      VVAL=VMAX                                                         
      SYNE= +.5*VLEN                                                    
C                                                                       
 420  VVAL = DMIN1( 1.D0, VVAL+3*DV )                                   
 422  IF ( VVAL .LE. .5*DV ) GO TO 450                                  
      RI=U+VVAL*SYNE                                                    
      RO=U-VVAL*SYNE                                                    
      ULIM = RVRLIM/DMAX1( 1.D-2, RI*RO )                               
      DO 429 I = 1, 2                                                   
      CALL BSPROD ( FIFO, 2, RI, RO, XS(I), ISCTMN, 1, RP, RT,  &435 )  
      NINTRP=NINTRP+INADD                                               
      IF ( DABS(FIFO) .GT. ULIM ) GO TO 450                             
 429  CONTINUE                                                          
 435  VVAL=VVAL-DV                                                      
      GO TO 422                                                         
C                                                                       
 450  VVAL = DMIN1( 1.D0, VVAL+DV )                                     
C                                                                       
C     MAKE SURE THIS DESIRED VALUE OF V DOES NOT VIOLATE ASYMPTOPIA     
C                                                                       
C     BECAUSE  S1*T1 < 0  AND  S2*T2 < 0,  RP2 > RP1 AND                
C     RT2 > RT1 ALWAYS.                                                 
C                                                                       
      RI=U+VVAL*SYNE                                                    
      RO=U-VVAL*SYNE                                                    
      RT=DSQRT((S1*RI)**2+(T1*RO)**2+ST1*RI*RO*(1.D0-DXV))              
      RP=DSQRT((S2*RI)**2+(T2*RO)**2+ST2*RI*RO*(1.D0-DXV))              
      RTMAX = DMAX1( RTMAX, RT )                                        
      RPMAX = DMAX1( RPMAX, RP )                                        
      IF ( RT .LE. BNDMXT .AND. RP .LE. BNDMXP ) GO TO 455              
C                                                                       
C     CANNOT USE DESIRED VALUE                                          
C                                                                       
      NBUMPS = NBUMPS + 1                                               
      VVAL = VVAL - DV                                                  
C                                                                       
 455  IF(SYNE .GT. 0) VMAX=VVAL                                         
      IF(SYNE .LT. 0 ) VMIN=VVAL                                        
      IF(SYNE .LT. 0 ) GO TO 460                                        
      VVAL=VMIN                                                         
      SYNE=-SYNE                                                        
      GO TO 420                                                         
C                                                                       
460   CONTINUE
C                                                                       
C     COME HERE IF U < 1.                                               
C                                                                       
 465  IF ( PGRDSW ) WRITE(6,468) U, VMIN, VMAX,  RP, RT, FIFO            
 468  FORMAT ( ' U VMIN VMAX =', 8G13.5 )                               
C     THESE ARE EXTREMA OF V=DIF FOR EACH POINT IN THE U=SUM GRID.      
      ALLOC(LVMIN+IU) = -VMIN*VLEN                                      
      ALLOC(LVMAX+IU) = VMAX*VLEN                                       
C                                                                       
C     CHECK FOR RANGES CONTRACTED TO ZERO BY ASYMPTOPIA LIMITATIONS     
C                                                                       
      VVAL = 2*U*(VMIN+VMAX)                                            
      IF ( VVAL .LT. .1*DV*U ) WRITE(6,473) U, VVAL                       
 473  FORMAT ( '0**** ERROR:  THE DIF GRID RANGE FOR SUM =', F8.2,  ' IS
     * ESSENTIALLY ZERO DUE TO BOUND STATE ASYMPTOPIA ',  'LIMITATIONS; 
     *RANGE =', G13.3 /  ' **** IN FUTURE RUNS ASYMPTOPIA MUST BE INCREA
     *SED.' )                                                           
C                                                                       
 489  CONTINUE                                                          
C                                                                       
C     END OF IU (SUM) LOOP                                              
C                                                                       
      IF ( NBUMPS .NE. 0 ) WRITE(6,493) NBUMPS                            
 493  FORMAT ('0**** WARNING:  SEARCH FOR THE DIF GRIDS WAS STOPPED',  I
     *4, ' TIMES BY BOUND STATE ASYMPTOPIA.' )                          
      IF ( NBUMPS .NE. 0 ) WRITE(6,897) RPMAX, RTMAX                      
C                                                                       
C     STAGE 2)  FIND V-MOMENTS OF THE WEIGHT FUNC. FOR EACH VALUE OF U  
C     FOR EACH U, VMID IS                                               
C     DETERMINED AS THE POINT AT WHICH <PHI@V@PHI> IS MAXIMUM.          
C                                                                       
      IF ( PGRDSW ) WRITE(6,503)                                           
 503  FORMAT ('  IU',8X, 'U', 11X, 'VMIN', 10X, 'VMID', 10X, 'VMAX',  9
     *X, 'V(MAX)', 9X, 'PVPMAX',  11X, '<V>', 9X, '<V**2>', 8X, '<V VAR>
     *' )                                                               
C                                                                       
      DO 559 IU = 1, NPSUM                                              
      U = ALLOC(LSUMPT+IU)                                              
      VMIN = ALLOC(LVMIN+IU)                                            
      VMAX = ALLOC(LVMAX+IU)                                            
      ALLOC(LVWTS-1+IU) = 1/(VMAX-VMIN)**2                              
      IMAX = 2*NPDIF                                                    
      DV = (VMAX-VMIN)/(IMAX+1)                                         
      VVAL = VMIN                                                       
      PVPMAX = 0                                                        
      SUM0 = 0                                                          
      SUM1 = 0                                                          
      SUM2 = 0                                                          
      DO 539 IV = 1, IMAX                                               
      VVAL = VVAL + DV                                                  
      RI = U + .5*VVAL                                                  
      RO = U - .5*VVAL                                                  
      TEMP = 0                                                          
      DO 529 I = 1, 2                                                   
      CALL BSPROD ( FIFO, 1, RI, RO, XS(I), ISCTCR, 1, RP, RT,  &539 )  
      NINTRP=NINTRP+INADD                                               
      TEMP = DABS(FIFO) + TEMP                                          
 529  CONTINUE                                                          
      SUM0 = SUM0 + TEMP                                                
      SUM1 = SUM1 + TEMP*VVAL                                           
      SUM2 = SUM2 + TEMP*VVAL*VVAL                                      
      IF ( TEMP .LE. PVPMAX ) GO TO 539                                 
      PVPMAX = TEMP                                                     
      VOFMAX = VVAL                                                     
 539  CONTINUE                                                          
C                                                                       
      SUM1 = SUM1/SUM0                                                  
      SUM2 = SUM2/SUM0                                                  
      SUM0 = DSQRT(SUM2-SUM1**2)                                        
      SUM2 = DSQRT(SUM2)                                                
C                                                                       
C     DO NOT ALLOW VMID TO BE TOO CLOSE TO AN EDGE                      
C                                                                       
      VMID = VOFMAX                                                     
      TEMP = .3*(VMAX-VMIN)                                             
      VMID = DMIN1( DMAX1( VMID, VMIN+TEMP ), VMAX-TEMP )               
      IF ( PGRDSW ) WRITE(6,553) IU,U,VMIN,VMID,VMAX,VOFMAX,PVPMAX,
     * SUM1, SUM2, SUM0                                                 
 553  FORMAT ( I4, 9G14.4 )                                             
C                                                                       
C     STORE VMID AS THE RELATIVE DISTANCE ACROSS THE RANGE.             
C     THIS WILL IMPROVE THE POLYNOMIAL FIT                              
C                                                                       
      VMID = (VMID-VMIN)/(VMAX-VMIN)                                    
      ALLOC(LVMID+IU) = VMID                                            
 559  CONTINUE                                                          
C                                                                       
C     END OF IU (SUM) LOOP                                              
C                                                                       
C     STAGE 3)  FIND THE POLYNOMIAL FITS                                
C                                                                       
C     THE POLYNOMIALS ARE ALWAYS GENERATED BUT ARE NOT USED IF          
C     NPSUMI = NPSUM.                                                   
C                                                                       
      NVTERM = NVPOLY+1                                                 
      CALL LSQPOL ( ALLOC(LSUMPT+1), ALLOC(LVMIN+1), ALLOC(LVWTS),  ALLO
     *C(LVRESD), NPSUM, ALLOC(LVSMSQ), 3, ALLOC(LVAMAT),  ALLOC(LVPOLS),
     * NVTERM, NPSUM, NVTERM )                                          
C                                                                       
      IF ( PINFSW ) WRITE(6,573) NVPOLY,((ALLOC(LVPOLS+N-1+NVTERM*(I-1)
     *), I = 1,3), N = 1, NVTERM)                                       
 573  FORMAT ( / X, I2, '-DEGREE POLYNOMIAL FITS TO DIF RANGES:' /  
     *8X, 'V LO', 11X, 'V MID', 10X, 'V HI' /  (3G15.5) )            
      IF ( PGRDSW ) WRITE(6,574)                                           
 574  FORMAT ( 8X, 'U', 14X, 'V LO', 5X, 'RESID', 15X,  'V MID', 5X
     *, 'RESID', 15X, 'V HI', 5X, 'RESID' / )                           
C                                                                       
      VRNGMX = 0                                                        
      VRNGMN = BIGNUM                                                   
      VMAXMX = 0                                                        
      DO 589 IU = 1, NPSUM                                              
      IF ( NPLYSW ) GO TO 585                                           
      DO 584 I = 1, 3                                                   
      ALLOC(LVMIN+(I-1)*NPSUM+IU) = ALLOC(LVMIN+(I-1)*NPSUM+IU)  +ALLOC(
     *LVRESD-1+(I-1)*NPSUM+IU)                                          
 584  CONTINUE                                                          
C                                                                       
 585  VMIN = ALLOC(LVMIN+IU)                                            
      VMAX = ALLOC(LVMAX+IU)                                            
      VMID = (VMAX-VMIN)*ALLOC(LVMID+IU) + VMIN                         
      ALLOC(LVMID+IU) = VMID                                            
      IF ( PGRDSW ) WRITE(6,587) ALLOC(LSUMPT+IU),(ALLOC(LVMIN+
     *(I-1)*NPSUM+IU), ALLOC(LVRESD-1+(I-1)*NPSUM+IU), I = 1,3)
 587  FORMAT ( G14.4, 3( 3X, G14.4, G12.2 ) )                           
      VRNGMX = DMAX1( VRNGMX, VMAX-VMIN )                               
      VRNGMN = DMIN1( VRNGMN, VMAX-VMIN )                               
      VMAXMX = DMAX1( VMAXMX, VMAX, -VMIN )                             
      TEMP = .2*(VMAX-VMIN)                                             
      IF ( VMIN .GT. VMID-TEMP .OR. VMAX .LT. VMID+TEMP )  WRITE(6,588) 
     *VMIN, VMID, VMAX                                                    
 588  FORMAT ( ' **** INVALID VMIN, VMID, VMAX:', 3G15.5 )              
  589 CONTINUE                                                          
C                                                                       
C     4)  GENERATE THE POINTS                                           
C                                                                       
C     FOR RECTANGULAR GRIDS EXPAND THE V-RANGE.                         
C                                                                       
      IF ( IRECT .EQ. 1 ) VRNGMX = 2.*VMAXMX                            
      IF ( IRECT .EQ. 1 ) VRNGMN = VRNGMX                               
C                                                                       
      DO 689 IU=1,NPSUM                                                 
C                                                                       
      U=ALLOC(LSUMPT+IU)                                                
      VMIN=ALLOC(LVMIN+IU)                                              
      VMAX=ALLOC(LVMAX+IU)                                              
      VMID = ALLOC(LVMID+IU)                                            
      IF ( IRECT .NE. 1 ) GO TO 620                                     
      VMAX = .5*VRNGMX                                                  
      VMIN = -VMAX                                                      
      VMID = 0                                                          
C                                                                       
C     MAKE SURE THE FINAL V RANGES ARE LEGAL.                           
C                                                                       
 620  IF ( VMIN .LT. -2*U .OR. VMAX .GT. 2*U )  WRITE(6,623) IU, U, 
     *VMIN,VMAX                                                              
 623  FORMAT ( '0*** ILLEGAL VMIN OR VMAX:', I3, 3G15.5 /  ' *** VALUES 
     *SET TO MAXIMUM ALLOWED.' )                                        
C                                                                       
      VMIN = DMAX1( VMIN, -2*U )                                        
      VMAX = DMIN1( VMAX, 2*U )                                         
      TEMP = .3*(VMAX-VMIN)                                             
      VMID = DMIN1( DMAX1( VMID, VMIN+TEMP ), VMAX-TEMP )               
C                                                                       
      SYNE=1                                                            
      IF(VMID.LE.(.5*(VMAX+VMIN))) GO TO 630                            
      VMID=-VMID                                                        
      TEMP=VMAX                                                         
      VMAX=-VMIN                                                        
      VMIN=-TEMP                                                        
      SYNE=-1                                                           
C                                                                       
 630  CALL CUBMAP (MAPDIF, VMIN, VMID, VMAX, GAMDIF, ALLOC(LDIFPT+1), AL
     *LOC(LDIFWT+1), NPDIF )                                            
C                                                                       
      DO 689 IV=1,NPDIF                                                 
C                                                                       
      IPLUNK = IV - 1                                                   
      IF ( SYNE .LT. 0 ) IPLUNK = NPDIF - IV                            
      IPLUNK = NPSUM*IPLUNK + IU                                        
      VVAL=ALLOC(LDIFPT+IV)                                             
      RI=U+.5*VVAL*SYNE                                                 
      RO=U-.5*VVAL*SYNE                                                 
      ALLOC(LRIH+IPLUNK)=RI                                             
      ALLOC(LROH+IPLUNK)=RO                                             
C                                                                       
C     WE REMOVE A FACTOR                                                
C        EXP( -(ALPHAP*RP' + ALPHAT*RT') )                              
C     FROM THE H'S FOR INTERPOLATION.  RP' AND RT' ARE RP AND RT        
C     WITH THE ABSOLUTE VALUE SINGULARITY REMOVED.                      
C                                                                       
      RP = SQRT( 1 + (S1*RI+T1*RO)**2 )                                 
      RT = SQRT( 1 + (S2*RI+T2*RO)**2 )                                 
      ALLOC(LRIOEX+IPLUNK) = EXP( ALPHAP*RP + ALPHAT*RT )               
C                                                                       
 689  CONTINUE                                                          
C                                                                       
C     DONE WITH U AND V GAUSS PARAMETERS; FREE THEM                     
C                                                                       
      Z(IVWORK) = -Z(IVWORK)                                            
      Z(ISCTMN) = -Z(ISCTMN)                                            
      Z(ISCTCR) = -Z(ISCTCR)                                            
C                                                                       
C                                                                       
C     5)  GENERATE THE POINTS FOR THE INTERPOLATED INTEGRAL GRID        
C         COMPUTE THE AREA OF THE INTEGRATION REGION                    
C                                                                       
 700  AREA = 0                                                          
      LVPOLS = Z(IVPOLS) - 1                                            
      LSMIVL = Z(ISMIVL) - 1                                            
      LSUMPT = Z(ISMIPT) - 1                                            
      LWIO = FACFR4*Z(IWIO) - FACFR4                                    
      LRI = FACFR4*Z(IRI) - FACFR4                                      
      LRO=FACFR4*Z(IRO)-FACFR4                                          
      LVMIN = Z(ISMHWK) - 1                                             
C                                                                       
C     ALSO FIND THE MAX RI AND RO THAT WILL BE REQUIRED OF WAVELJ       
C                                                                       
      RIMAX = 0                                                         
      ROMAX = 0                                                         
      LDIFPT=Z(IDIFPT)-1                                                
      LDIFWT=Z(IDIFWT)-1                                                
C                                                                       
      DO 749 IU = 1, NPSUMI                                             
      WOW = ALLOC(LSMIVL+IU)                                            
      U = ALLOC(LSUMPT+IU)                                              
C                                                                       
C     EVALUATE THE POLYNOMIAL-DETERMINED RANGES                         
C                                                                       
      ITEMP = LVPOLS                                                    
      DO 709 I = 1, 3                                                   
C                                                                       
C     ARE WE USING POLYNOMIALS OR JUST COPYING THE H-POINTS             
C                                                                       
      VRANGE(I) = ALLOC(LVMIN+(I-1)*NPSUM+IU)                           
      IF ( NPLYSW ) GO TO 709                                           
      ITEMP = ITEMP + NVPOLY + 1                                        
      VRANGE(I) = ALLOC(ITEMP)                                          
      DO 704 N = 1, NVPOLY                                              
      VRANGE(I) = ALLOC(ITEMP-N) + U*VRANGE(I)                          
 704  CONTINUE                                                          
 709  CONTINUE                                                          
      VMIN = VRANGE(1)                                                  
      VMID = VRANGE(2)                                                  
      VMAX = VRANGE(3)                                                  
      IF ( NPLYSW ) GO TO 715                                           
      VMID = (VMAX-VMIN)*VMID + VMIN                                    
 715  IF ( IRECT .NE. 1 ) GO TO 720                                     
      VMAX = .5*VRNGMX                                                  
      VMIN = -VMAX                                                      
      VMID = 0                                                          
C                                                                       
 720  IF ( VMIN .LT. -2*U .OR. VMAX .GT. 2*U )  WRITE(6,723) IU, U, 
     *VMIN,VMAX
 723  FORMAT ( '0*** ILLEGAL INTERPOLATED VMIN OR VMAX:', I4,  3G15.5 / 
     * ' *** VALUES SET TO MAXIMUM ALLOWED.' )                          
C                                                                       
      AREA = AREA + WOW*(VMAX-VMIN)                                     
      VMIN = DMAX1( VMIN, -2.*U )                                       
      VMAX = DMIN1( VMAX, 2.*U )                                        
      TEMP = .3*( VMAX - VMIN )                                         
      VMID = DMIN1( DMAX1( VMID, VMIN+TEMP ), VMAX-TEMP )               
      SYNE=1                                                            
      IF(VMID.LE.(.5*(VMAX+VMIN))) GO TO 730                            
      VMID=-VMID                                                        
      TEMP=VMAX                                                         
      VMAX=-VMIN                                                        
      VMIN=-TEMP                                                        
      SYNE=-1                                                           
C                                                                       
 730  CALL CUBMAP (MAPDIF, VMIN, VMID, VMAX, GAMDIF, ALLOC(LDIFPT+1), AL
     *LOC(LDIFWT+1), NPDIF )                                            
C                                                                       
      DO 749 IV=1,NPDIF                                                 
C                                                                       
      IPLUNK = IV - 1                                                   
      IF ( SYNE .LT. 0 ) IPLUNK = NPDIF - IV                            
      IPLUNK = NPSUMI*IPLUNK + IU                                       
      VVAL=ALLOC(LDIFPT+IV)                                             
      RI=U+.5*VVAL*SYNE                                                 
      RO=U-.5*VVAL*SYNE                                                 
      RIMAX = DMAX1( RIMAX, RI )                                        
      ROMAX = DMAX1( ROMAX, RO )                                        
      ALLOC4(LRI+IPLUNK)=RI                                             
      ALLOC4(LRO+IPLUNK)=RO                                             
C                                                                       
C     HERE WE MAKE THE EXP FACTORS TO PUT BACK IN AFTER INTERPOLATION   
C                                                                       
      RP = DSQRT( 1 + (S1*RI+T1*RO)**2 )                                
      RT = DSQRT( 1 + (S2*RI+T2*RO)**2 )                                
      TEMP = DEXP( -(ALPHAP*RP + ALPHAT*RT ) )                          
C                                                                       
C     "RIROWTS" CONTAINS ALL WEIGHTING FACTORS FOR THE RI,RO            
C     INTEGRATION, INCLUDING THE SUM AND DIF GAUSS WEIGHTS,             
C     RI, RO, THE JACOBIAN, AND THE EXPONENTIAL FACTOR.                 
C                                                                       
      ALLOC4(LWIO+IPLUNK) = JACOB*RI*RO*WOW*ALLOC(LDIFWT+IV)*TEMP       
C                                                                       
 749  CONTINUE                                                          
C                                                                       
      Z(IDIFPT) = -Z(IDIFPT)                                            
      Z(IDIFWT) = -Z(IDIFWT)                                            
      Z(ISMIVL) = -Z(ISMIVL)                                            
C                                                                       
      IF (PINFSW) WRITE(6,753) RIMAX, ROMAX                              
 753  FORMAT ( ' MAXIMUM RI AND RO:', 2G15.5 )                          
C                                                                       
C     IF WAVEFUNCTIONS ARE NEEDED BEYOND ASYMPTOPIA,                    
C     MUST EXPAND THE WORK AREA NOW.                                    
C                                                                       
      NSTP2S(1) = RIMAX/RSTEPS(1) + 3.5                                 
      NSTP2S(2) = ROMAX/RSTEPS(2) + 3.5                                 
      I = MAX0( NSTP2S(1), NSTP2S(2) ) + 6                              
      IF ( I .LE. NWAVEF ) GO TO 800                                    
      NWAVEF = I                                                        
      IF ( TCSWS(1) .OR. TCSWS(2) ) I = 4*I                             
      IWAVR = NALLOC( I, 'WAVER ' )                                     
      IWAVI = NALLOC( I, 'WAVEI ' )                                     
C                                                                       
C     THE SUM, DIF GRIDS ARE SET UP.                                    
C     THE PHI GRID IS NOT NEEDED FOR USEHS RUNS.                        

C                                                                       
 800  IF ( IHSAVE .EQ. 2 ) GO TO 900                                    
C                                                                       
C                                                                       
C     FIND ALL THE PRODUCTS OF THE BOUNDSTATES AND V ON THE             
C     (RI, RO, PHI) GRID.                                               
C                                                                       
C                                                                       
C     TWO PASSES OVER (RI,RO)                                           
C     FIRST TIME ; FIND AND STORE END-PTS X0(RI,RO) FOR PHI-INTEGRALS   
C     SECOND ; COMPUTE AND STORE BOUND STATE PRODUCTS                   
C                                                                       
C                                                                       
C     "LOGIC" WILL CONTAIN THE NUMBER OF POINTS FOR WHICH THE           
C     INTEGRAND IS BIG ENOUGH.                                          
C                                                                       
      INEED=NRIROH/FACFR4+1                                             
      LOGIC=NALLOC( INEED, 'LOGIC ' )                                   
C                                                                       
C     FIRST PASS; SET PHI-INTEGRATION LIMITS                            
C                                                                       
      IXTOPZ = LOOKST + 1                                               
      DXV = 2.D0/LOOKST**2                                              
      NNAIT = 2                                                         
      IBSTYP = 2                                                        
      PAS1SW = .TRUE.                                                   
      X0MIN = 1                                                         
      X0AV = 0                                                          
C                                                                       
C     SETUP GAUSS-LEGENDRE POINTS, MAPPED AND SCALED TO (0,1).          
C                                                                       
      IPHIPT = NALLOC( NPPHI, 'PHIPTS ' )                               
      IPHIWT = NALLOC( NPPHI, 'PHIWTS ' )                               
      PHIMID = DMAX1( PHIMID, 0.10D0 )                                  
      PHIMID = DMIN1( PHIMID, 0.90D0 )                                  
      GAMPHI = DMAX1( GAMPHI, 1.D-6 )                                   
      CALL CUBMAP ( MAPPHI, 0.D0, PHIMID, 1.D0, GAMPHI,  ALLOC(Z(IPHIPT)
     *), ALLOC(Z(IPHIWT)), NPPHI )                                      
C                                                                       
C     COME BACK HERE TO START PASS 2.                                   
C                                                                       
 810  JCNT = 0                                                          
      RTMAX = 0                                                         
      RPMAX = 0                                                         
      NBUMPS = 0                                                        
      LLOGIC = FACFR4*Z(LOGIC)-FACFR4                                   
      LPHIPT = Z(IPHIPT)-1                                              
      LPHIWT = Z(IPHIWT)-1                                              
      LRIH = Z(IRIH) - 1                                                
      LROH = Z(IROH) - 1                                                
C                                                                       
C     LOOP THROUGH ALL RI, RO COMBINATIONS.                             
C                                                                       
      DO 869 IPLUNK = 1,NRIROH                                          
      RI=ALLOC(LRIH+IPLUNK)                                             
      RO = ALLOC(LROH+IPLUNK)                                           
      ULIM = RVRLIM / ( DMAX1(1.D0, RI) * DMAX1(1.D0, RO) )             
      IF ( PAS1SW ) GO TO 820                                           
C                                                                       
C     PASS 2:  SET UP END POINT.                                        
C     WE ALWAYS INTEGRATE AT LEAST TO THE SECOND TEST POINT.            
C                                                                       
      IEND = ILLOC(LLOGIC+IPLUNK)                                       
      IEND = MAX0( IEND, 2 )                                            
      X0 = 1.D0-DXV*(IEND-1)**2                                         
      PHI0 = DACOS( X0 )                                                
C                                                                       
  820 CONTINUE
C                                                                       
C     LOOP THROUGH PHI TEST POINTS (PASS 1) OR GAUSS POINTS (PASS 2).   
C                                                                       
      DO 859 II=1, IXTOPZ                                               
C                                                                       
      X = 1.D0 - DXV*(II-1)**2                                          
      IF ( PAS1SW ) GO TO 825                                           
C                                                                       
C     PASS 2:  GET GAUSS POINT AND WEIGHT.                              
C                                                                       
      PHI = PHI0*ALLOC(LPHIPT+II)                                       
      DPHI = PHI0*ALLOC(LPHIWT+II)*DSIN( PHI )                          
      X = DCOS( PHI )                                                   
C                                                                       
C     CALCULATE BOUND-STATE PRODUCT.                                    
C                                                                       
 825  NBUMPS = NBUMPS + 1                                               
      CALL BSPROD ( FIFO, IBSTYP, RI, RO, X, ISCTMN, NNAIT,  RP, RT, &83
     *0 )                                                               
      NBUMPS = NBUMPS - 1                                               
      NINTRP = NINTRP + INADD                                           
 830  RTMAX = DMAX1( RTMAX, RT )                                        
      RPMAX = DMAX1( RPMAX, RP )                                        
      IF ( PAS1SW ) GO TO 840                                           
C                                                                       
C     PASS 2:  KEEP PHIT, PHIP, PHI, AND WEIGHTED B. S. PRODUCT.        
C                                                                       
      JCNT = JCNT + 1                                                   
      TEMP = (T1*RO + S1*RI*X)/RT                                       
      ALLOC4(LPHIT+JCNT) = PHISGN*DACOS(TEMP)                           
      TEMP = (T2*RO + S2*RI*X)/RP                                       
      ALLOC4(LPHIP+JCNT) = PHISGN*DACOS(TEMP)                           
      ALLOC4(LPHI+JCNT) = PHI                                           
      ALLOC4(LTRP+JCNT) = DPHI*FIFO                                     
      RTMAX = DMAX1( RTMAX, RT )                                        
      RPMAX = DMAX1( RPMAX, RP )                                        
      GO TO 859                                                         
C                                                                       
C     PASS 1, FINDING X0                                                
C                                                                       
  840 FIFO = DABS(FIFO)                                                 
      IF ( II .EQ. 1 ) GO TO 845                                        
      IF ( FIFO .LT. ULIM .AND. WOW .LT. ULIM ) GO TO 865               
  845 WOW = FIFO                                                        
C                                                                       
  859 CONTINUE                                                          
C                                                                       
C     END OF LOOP THROUGH PHI TEST OR GAUSS POINTS.                     
C                                                                       
      IF ( PAS1SW ) GO TO 864                                           
C                                                                       
C     PASS 2:  DUMP WEIGHTED B. S. PRODUCT IF REQUIRED.                 
C                                                                       
      N = JCNT - NPPHI + 1                                              
      IF ( IPRNT .GE. 9 ) WRITE(6,863) RI,RO,PHI0,(ALLOC4(LTRP+I),I=
     * N, JCNT )                                                        
 863  FORMAT ( 1X, 2F7.2, F7.4, (T24, 1P 13G9.1) )                      
C                                                                       
C     PASS 2:  WRITE THE "PHIANG", "PHIANG1", "PHIANG2", AND "FIFODX"   
C     ARRAYS ON THE SCRATCH FILE IF REQUIRED.                           
C                                                                       
      IF ( ISCRFL .EQ. 0 ) GO TO 869                                    
      CALL WRITSC ( NPPHI, ALLOC4(LPHI+1), ALLOC4(LPHIP+1),  ALLOC4(LPHI
     *T+1), ALLOC4(LTRP+1), &874 )                                      
CNV         WRITE ( 2, ERR=874 )                                        
CNV     1      ( ALLOC4(LPHI+I), I = 1, NPPHI ),                        
CNV     2      ( ALLOC4(LPHIP+I), I = 1, NPPHI ),                       
CNV     3      ( ALLOC4(LPHIT+I), I = 1, NPPHI ),                       
CNV     4      ( ALLOC4(LTRP+I), I = 1, NPPHI )                         
      JCNT = 0                                                          
      GO TO 869                                                         
C                                                                       
 864  II = LOOKST + 2                                                   
 865  CONTINUE
      IEND = MIN0 ( II - 1 + NPHIAD, IXTOPZ )                           
C                                                                       
C     NOTE:  ADDING NPHIAD CAN RESULT IN PHI'S THAT GIVE RP'S AND RT'S  
C     THAT ARE OUT OF BOUNDS.  WE COULD CHECK FOR THAT HERE BUT INSTEAD 
C     WE LET THEM GET CAUGHT ON PASS 2 AND SUBSTITUTE 0'S.              
C                                                                       
      ILLOC(LLOGIC+IPLUNK) = IEND                                       
      IF ( IEND .NE. 1 ) JCNT = JCNT + NPPHI                            
      X0 = 1.D0 - DXV*(IEND-1)**2                                       
      X0MIN = DMIN1( X0MIN, X0 )                                        
      X0AV = X0AV + X0                                                  
C                                                                       
 869  CONTINUE                                                          
C                                                                       
C     END OF LOOP THROUGH RI, RO COMBINATIONS.                          
C                                                                       
      IF ( .NOT. PAS1SW ) GO TO 890                                     
C                                                                       
C     END OF PASS 1 - ALLOCATE SPACE AND SETUP FOR PASS 2               
C                                                                       
      IF ( NBUMPS .NE. 0 ) WRITE(6,873) NBUMPS                            
  873 FORMAT (' **** WARNING:  IN THE PHI-GRID SEARCHES', I8,  ' BOUND S
     *TATE WAVEFUNCTIONS WERE NEEDED BEYOND THE',  ' BOUND STATE ASYMPTO
     *PIA.' )                                                           
      IF ( NBUMPS .NE. 0 ) WRITE(6,897) RPMAX, RTMAX                      
C                                                                       
C     OPEN THE SCRATCH FILE IF REQUIRED.                                
C                                                                       
      NBLKSZ = ( (NBLKSZ+511)/512 )*512                                 
      IF ( ISCRFL .NE. 0 .AND. IBSPAS .LE. 1 )  OPEN ( UNIT = 2, TYPE = 
     *'SCRATCH',  BLOCKSIZE = NBLKSZ, FORM = 'UNFORMATTED',  INITIALSIZE
     * = (16*JCNT+2*NRIROH+NBLKSZ)/NBLKSZ,  ERR = 874 )                 
C                                                                       
      GO TO 876                                                         
C                                                                       
C     SCRATCH FILE ERROR.                                               
C                                                                       
 874  WRITE(6,875)                                                         
 875  FORMAT ( '0**** ERROR IN OPENING OR WRITING SCRATCH FILE.' /  ' **
     *** ARRAYS WILL BE KEPT IN MEMORY IF POSSIBLE.' )                  
      ISCRFL = 0                                                        
C                                                                       
C     THE SIZE OF THESE FOUR ARRAYS MAY BE DRASTICALLY REDUCED IF A     
C     SCRATCH FILE IS USED (KEYWORD "SCRFILE").                         
C                                                                       
 876  JSIZE = (JCNT+FACFR4-1)/FACFR4                                    
      IF ( ISCRFL .NE. 0 ) JSIZE = (NPPHI+FACFR4-1)/FACFR4              
      LOCTRP = NALLOC( JSIZE , 'FIFODX ' )                              
      IPHIT = NALLOC( JSIZE , 'PHIANG1 ' )                              
      IPHIP = NALLOC( JSIZE , 'PHIANG2 ' )                              
      IPHI = NALLOC( JSIZE , 'PHIANG ' )                                
      MAXCNT = JCNT                                                     
      X0AV = X0AV/NRIROH                                                
C                                                                       
      IF ( IPRNT .GE. 9 ) WRITE(6,878)                                     
 878  FORMAT ( X, 4X, 'RI', 5X, 'RO', 15X,  'PHI V PHI  AT EACH X' / )
     *                                                                  
C                                                                       
      LPHIT = FACFR4*Z(IPHIT) - FACFR4                                  
      LPHIP = FACFR4*Z(IPHIP) - FACFR4                                  
      LPHI = FACFR4*Z(IPHI) - FACFR4                                    
      LTRP = FACFR4*Z(LOCTRP) - FACFR4                                  
      IXTOPZ = NPPHI                                                    
      NNAIT = NAITKN                                                    
      IBSTYP = 1                                                        
      INADD = 0                                                         
      PAS1SW = .FALSE.                                                  
C                                                                       
C     GO START PASS 2.                                                  
C                                                                       
      GO TO 810                                                         
C                                                                       
C     END OF PASS 2.  CHECK FOR ASYMPTOPIA OVERRUNS.                    
C                                                                       
 890  IF ( NBUMPS .NE. 0 ) WRITE(6,893) NBUMPS                            
  893 FORMAT (' **** ERROR:', I8,  ' BOUND STATE WAVEFUNCTIONS WERE NEED
     *ED BEYOND THE',  ' BOUND STATE ASYMPTOPIA.' )                     
      IF ( NBUMPS .NE. 0 ) WRITE(6,897) RPMAX, RTMAX                      
 897  FORMAT ( ' **** IN FUTURE RUNS INCREASE ASYMPTOPIA TO MORE THAN:',
     * F15.2, ' (PROJECTILE)', F15.2, ' (TARGET)' )                     
C                                                                       
C     BOUND STATE PRODUCTS HAVE BEEN COMPUTED AND STORED.               
C                                                                       
      IF ( IBSPAS .EQ. 0 ) Z(IBDS(1)) = -Z(IBDS(1))                     
      IF ( IBSPAS .EQ. 0 ) Z(IBDS(2)) = -Z(IBDS(2))                     
      Z(IPHIPT) = -Z(IPHIPT)                                            
      Z(IPHIWT) = -Z(IPHIWT)                                            
      IF ( NUCONL .GE. 2 .AND. IBSPAS .EQ. 0 ) Z(JPOT) = -Z(JPOT)       
      I = NAMLOC( 'VPHI    ' )                                          
      Z(I) = -Z(I)                                                      
      Z(LOGIC) = -Z(LOGIC)                                              
      IF ( ISCRFL .NE. 0 ) REWIND 2                                     
C                                                                       
C                                                                       
C     PRINT IT NICELY                                                   
C                                                                       
 900  IF ( .NOT. PRNTSW ) GO TO 950                                     
C                                                                       
      WRITE(6,903) NPSUMI,MAPSUM,GAMSUM,SUMMIN,SUMMID,SUMMAX,NPSUM, 
     * NPDIF, MAPDIF, GAMDIF, VRNGMN, VRNGMX,  NPPHI, MAPPHI, GAMPHI, NP
     *HIAD, X0MIN, X0AV, PHIMID                                         
 903  FORMAT ( // 13X, ' SUMMARY OF THE INTEGRATION GRIDS' / 10X,   
     *'NUM. PTS.   MAP TYPE   GAMMA    MINIMUM',  '   "MID. PT."   M
     *AXIMUM' /  ' (RI+RO)/2:', I5, I11, F11.2, F10.2, 2F11.2 ,  5X, '(H
     *  S FOUND AT', I4, ' (RI+RO)/2 VALUES)' /  41X, 'MIN. WIDTH  
     * MAX. WIDTH' /  ' RI-RO:', I9, I11, F11.2, F11.3, F13.3 /  43X, 
     *'NPHIADD    MIN. START   AV. START     PHIMID' /  ' COS(PHI):',
     * I6, I11, F11.2, I9, F16.5, F12.5, F12.4 )                        
C                                                                       
      IF ( IRECT .EQ. 1 ) WRITE(6,908)                                     
 908  FORMAT ( ' "SW3ON" WAS SPECIFIED:  (RI,RO) GRID IS RECTANGULAR.') 
      WRITE(6,913) DWCUT, RPMAX, RTMAX, RIMAX, ROMAX                      
 913  FORMAT ( ' DWCUTOFF =', 1P G12.2, 0P /  ' MAXIMUM R  S USED FOR BO
     *UND STATES:  PROJECTILE =',  F5.1, 5X, 'TARGET =', F5.1 /  ' MAXIM
     *UM R  S USED FOR SCATTERING STATES:  INCOMING =',  F5.1, 5X, 'OUTG
     *OING =', F5.1 )                                                   
C                                                                       
      WRITE(6,933) NRIROH, MAXCNT, NRIROI, AREA                           
 933  FORMAT ( ' THERE ARE', I6, ' POINTS IN THE (RI, RO) GRID',  ' ON W
     *HICH THE H  S ARE FOUND, ',  ' AND', I8, ' POINTS IN THE COMPLETE 
     *3-D GRID.' /  ' THERE ARE', I6, ' POINTS IN THE (RI, RO) INTERPOLA
     *TED',  ' INTEGRATION GRID.' /  ' AREA OF  SUM X DIF  INTEGRATION R
     *EGION =',  F9.3, ' FM**2.' / )                                    
C                                                                       
C     IF SAVING H'S, SAVE THE (RI, RO) GRID STUFF                       
C                                                                       
 950  IF ( IHSAVE .NE. 1 ) GO TO 1000                                   
      TEMP = 0                                                          
      ITEMP = 0                                                         
      WRITE ( 1, ERR=9950 ) NPSUM, NPDIF, NPPHI,  MAXCNT, JSIZE, GAMSUM,
     * SUMMIN, SUMMID, SUMMAX,  GAMDIF, VRNGMN, VRNGMX, X0MIN, X0AV, RPM
     *AX, RTMAX,  NRIROH, ALPHAP, ALPHAT, AREA, WVWMAX, NPLYSW,  ITEMP, 
     *TEMP, TEMP, TEMP                                                  
      WRITE ( 1, ERR=9950 )  ( ALLOC(Z(IVPOLS)-1+I), I = 1, NPOLSV ),  (
     * ALLOC(Z(ISMHPT)-1+I), I = 1, NPSUM ),  ( ALLOC(Z(IRIOEX)-1+I), I 
     *= 1, NRIROH ),  ( ALLOC(Z(IRIH)-1+I), I = 1, NRIROH ),  ( ALLOC(Z(
     *IROH)-1+I), I = 1, NRIROH )                                       
      II = 3*NPSUM                                                      
      IF ( NPLYSW ) WRITE ( 1, ERR=9950 )  ( ALLOC(Z(ISMHWK)-1+I), I = 1
     *, II )                                                            
C                                                                       
 1000 IRTN = 1                                                          
      Z(IVPOLS) = -Z(IVPOLS)                                            
      IF ( IHSAVE .EQ. 2 ) GO TO 1100                                   
      Z(IRIH) = -Z(IRIH)                                                
      Z(IROH) = -Z(IROH)                                                
C                                                                       
C     FIX DWCUT FOR SAVEHS TO BE SURE STUFF IS AVAILABLE FOR USEHS      
C                                                                       
 1100 TEMP = DWCUT                                                      
      IF ( IHSAVE .EQ. 1 ) TEMP = DMIN1( 1.D-30, DWCUT )                
      RVRLIM = WVWMAX*TEMP                                              
C                                                                       
      RETURN                                                            
C                                                                       
 9950 WRITE(6,9953)                                                        
 9953 FORMAT ( '0**** ERROR IN READING OR WRITING H  S FILE.' )         
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE GSINFO ( KZ, KA, JVAL, PARITY, JPI, NOTTAB )           
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -   
C     RETURNS GROUND STATE PROPERTIES OF NUCLEII.                       
C   THE DATA ARE FROM THE MASS-CARD BY AJENBERG-SELOVE                  
C   INFORMATION IS RETURNED IN LITERAL FORM                             
C                                                                       
C  DESCRIPTION OF PARAMETERS:                                           
C  KZ      I*4 CHARGE Z OF THE NUCLEUS                                  
C  KA      I*4 ATOMIC NUMBER A OF THE NUCLEUS                           
C  JVAL    I*4 INTEGER SET TO 2*J OF GROUND STATE                       
C  PARITY  I*4 SET TO +1, -1, OR 0 IF NOT KNOWN                         
C  JPI     R*4 4-BYTE LITERAL DESCRIBING G.S. SPIN OF NUCLEUS           
C                                                                       
C  NOTTAB  I*4 DENOTES WHETHER THE NUCLEAR PROPERTIES WERE FOUND IN     
C              THE TABLE                                                
C              NOTTAB= 0 MEANS PROPERTIES FOUND                         
C              NOTTAB=+1 MEANS NOT TABULATED..JPI='X' ON RETURN         
C                                                                       
C                        FRANK SERDUKE 3/10/74                          
C     5/8/75 - MODIFIED FOR PTOLEMY - S.P.  SEVERAL 11/- CHANGED        
C              TO 11/2, JVAL ADDED; TAW REMOVED; IE IS L*1, IA IS I*2   
C     5/16/78 - USE 'X' INSTEAD OF '?' FOR UNDEFINED G.S. - S.P.        
C     5/4/79 - RETURN PARITY; 11/2 GOES BACK TO 11/- - S.P.             
C     12/31/79 - STANDARD MORTRAN - RPG                                 
C     1/16/80 - 4H____ TO '____'; ICHAR TO KCHAR; CHARACTER*4 QMARK;    
C        CDC%M FOR DATA; MOVE NOW DOWN - RPG                            
C     6/3/80 - FOR CDC BYPASS DATA PICKUP -S.P.                         
C     7/15/80 - CHR, CWD PREFIXES - S.P.                                
C                                                                       
C  SUBROUTINES REQUIRED                                                 
C     NONE                                                              
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -   
C                                                                       
      INTEGER PARITY                                                    
CIB      LOGICAL*1  IE, IE1, IE2, IE3                                   
      INTEGER*2 IE, IE1, IE2, IE3                                       
      INTEGER*2 IA, IA1, IA2, IA3                                       
C                                                                       
      CHARACTER*4 AJ(1485)                                              
      DIMENSION IE(270), IA(270)                                        
      DIMENSION IE1(90),IE2(90),IE3(90),IA1(90),IA2(90),IA3(90)         
C                                                                       
      EQUIVALENCE (IE(1),IE1(1)),(IE(91),IE2(1)),(IE(181),IE3(1))       
      EQUIVALENCE (IA(1),IA1(1)),(IA(91),IA2(1)),(IA(181),IA3(1))       
C                                                                       
C                                                                       
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
C                                                                       
C                                                                       
C    MERGED STUFF FOR J-PI DATA GOES HERE......                         
C                                                                       
      CHARACTER*4 AJ1(45), AJ2(45), AJ3(45), AJ4(45), AJ5(45), AJ6(45) ,
     * AJ7(45), AJ8(45), AJ9(45), AJ10(45), AJ11(45), AJ12(45) , AJ13(45
     *), AJ14(45), AJ15(45), AJ16(45), AJ17(45), AJ18(45) , AJ19(45), AJ
     *20(45), AJ21(45), AJ22(45), AJ23(45), AJ24(45) , AJ25(45), AJ26(45
     *), AJ27(45), AJ28(45), AJ29(45), AJ30(45) , AJ31(45), AJ32(45), AJ
     *33(45)                                                            
C                                                                       
      EQUIVALENCE  (AJ( 1),AJ 1(1)), (AJ( 46),AJ 2(1)),  (AJ( 91),AJ 3(1
     *)), (AJ( 136),AJ 4(1)),  (AJ( 181),AJ 5(1)), (AJ( 226),AJ 6(1)),  
     *(AJ( 271),AJ 7(1)), (AJ( 316),AJ 8(1)),  (AJ( 361),AJ 9(1)), (AJ( 
     *406),AJ10(1)),  (AJ( 451),AJ11(1)), (AJ( 496),AJ12(1)),  (AJ( 541)
     *,AJ13(1)), (AJ( 586),AJ14(1)),  (AJ( 631),AJ15(1)), (AJ( 676),AJ16
     *(1)),  (AJ( 721),AJ17(1)), (AJ( 766),AJ18(1)),  (AJ( 811),AJ19(1))
     *, (AJ( 856),AJ20(1)),  (AJ( 901),AJ21(1)), (AJ( 946),AJ22(1)),  (A
     *J( 991),AJ23(1)), (AJ(1036),AJ24(1)),  (AJ(1081),AJ25(1)), (AJ(112
     *6),AJ26(1)),  (AJ(1171),AJ27(1)), (AJ(1216),AJ28(1)),  (AJ(1261),A
     *J29(1)), (AJ(1306),AJ30(1)),  (AJ(1351),AJ31(1)), (AJ(1396),AJ32(1
     *)),  (AJ(1441),AJ33(1))                                           
C                                                                       
      DATA NTAB/268/                                                    
C                                                                       
      CHARACTER*4 QMARK                                                 
      DATA QMARK / 'X   ' /                                             
      CHARACTER*4 JPI, JCHAR                                            
      CHARACTER*1 QMARK1, BLANK, SLASH                                  
      DATASLASH/'/'/                                                    
      DATABLANK/' '/                                                    
      DATA QMARK1 / 'X' /                                               
      CHARACTER*1 PLUS, MINUS                                           
      DATAMINUS/'-'/                                                    
      DATA PLUS / '+' /                                                 
      CHARACTER*1 CHAR(4)                                               
      EQUIVALENCE ( JCHAR, CHAR(1) )                                    
C                                                                       
      DATA IE1/                                                         
     *    0,   0,   1,   1,   1,   1,   2,   3,   2,   3                
     *,   4,   4,   5,   5,   6,   6,   6,   7,   8,   8                
     *,   8,   9,   9,  10,  10,  11,  11,  12,  12,  13                
     *,  13,  14,  14,  15,  15,  16,  16,  16,  16,  17                
     *,  17,  18,  18,  19,  19,  19,  19,  19,  20,  20                
     *,  20,  21,  22,  23,  23,  24,  24,  25,  25,  26                
     *,  26,  26,  27,  27,  28,  28,  28,  28,  29,  30                
     *,  30,  30,  30,  31,  31,  32,  32,  32,  32,  33                
     *,  33,  33,  33,  34,  34,  35,  35,  35,  35,  35/               
      DATA IE2/                                                         
     *   36,  36,  36,  36,  36,  37,  38,  39,  40,  40                
     *,  41,  41,  42,  42,  42,  42,  43,  44,  44,  45                
     *,  45,  46,  46,  46,  46,  47,  47,  48,  48,  48                
     *,  49,  49,  49,  49,  49,  50,  50,  50,  50,  50                
     *,  51,  51,  51,  51,  52,  53,  53,  53,  54,  54                
     *,  54,  54,  54,  54,  57,  58,  58,  59,  59,  59                
     *,  60,  60,  61,  61,  61,  62,  62,  62,  63,  63                
     *,  63,  64,  64,  65,  65,  66,  66,  67,  67,  67                
     *,  67,  68,  68,  68,  69,  69,  69,  70,  70,  71/               
      DATA IE3/                                                         
     *   71,  72,  72,  72,  73,  73,  73,  74,  74,  74                
     *,  75,  75,  75,  76,  76,  76,  77,  77,  77,  78                
     *,  78,  78,  79,  79,  80,  80,  80,  81,  81,  81                
     *,  81,  82,  82,  82,  82,  83,  83,  84,  84,  85                
     *,  85,  86,  86,  86,  87,  88,  88,  88,  88,  89                
     *,  89,  89,  90,  90,  90,  91,  91,  91,  92,  92                
     *,  92,  93,  93,  94,  94,  94,  94,  95,  96,  96                
     *,  96,  97,  98,  98,  98,  99,  99, 100, 101, 104                
     *, 105, 105, 106, 106, 107, 107, 108, 108, 109, 200/               
C                                                                       
      DATA IA1/                                                         
     *    0,   0,   2,   3,   5,   7,  10,  13,  15,  19                
     *,  23,  26,  29,  32,  35,  38,  41,  45,  49,  52                
     *,  55,  59,  63,  67,  71,  75,  79,  83,  86,  90                
     *,  93,  97, 100, 104, 107, 111, 114, 118, 123, 128                
     *, 132, 137, 141, 146, 150, 154, 158, 163, 168, 173                
     *, 178, 184, 189, 194, 198, 203, 207, 212, 216, 221                
     *, 225, 229, 234, 238, 243, 247, 252, 257, 262, 266                
     *, 270, 275, 280, 285, 290, 296, 301, 306, 311, 317                
     *, 322, 327, 332, 338, 343, 349, 354, 360, 366, 373/               
      DATA IA2/                                                         
     *  380, 387, 394, 402, 410, 419, 427, 434, 441, 447                
     *, 455, 462, 469, 476, 483, 490, 497, 504, 510, 517                
     *, 523, 529, 534, 540, 546, 553, 559, 565, 571, 578                
     *, 585, 591, 597, 603, 609, 615, 622, 629, 636, 644                
     *, 652, 660, 668, 676, 684, 692, 700, 708, 716, 722                
     *, 729, 736, 744, 754, 764, 771, 778, 785, 792, 799                
     *, 806, 813, 821, 828, 836, 844, 851, 857, 864, 870                
     *, 876, 882, 888, 894, 899, 905, 910, 915, 920, 926                
     *, 932, 938, 943, 949, 955, 961, 967, 977, 983, 989/               
      DATA IA3/                                                         
     *  994,1000,1005,1011,1017,1025,1033,1041,1048,1055                
     *,1062,1068,1074,1081,1087,1093,1100,1106,1112,1119                
     *,1125,1132,1139,1146,1153,1160,1167,1175,1182,1189                
     *,1196,1203,1210,1217,1225,1233,1239,1245,1250,1255                
     *,1259,1263,1267,1271,1276,1280,1284,1288,1292,1297                
     *,1301,1306,1311,1316,1321,1326,1330,1335,1340,1345                
     *,1350,1355,1360,1365,1370,1375,1381,1387,1392,1397                
     *,1402,1407,1412,1416,1421,1426,1430,1435,1440,1444                
     *,1445,1446,1447,1448,1449,1450,1451,1452,1453,1454/               
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
C                                                                       
C                                                                       
CDC%M                                                                   
CDC%';DATA' = '";DATA "'                                                
      DATA AJ 1/                                                        
     * '1/2+'    ,'1/2+'    ,' 1+ '    ,'1/2+'    ,'1/2+'               
     *,'X   '    ,' 0+ '    ,'X   '    ,'3/2-'    ,'3/2-'               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,'3/2-'    ,'3/2-'               
     *,' 0+ '    ,' 2+ '    ,' 0+ '    ,' 2+ '    ,'3/2-'               
     *,'3/2-'    ,'3/2-'    ,'3/2-'    ,' 0+ '    ,' 3+ '               
     *,' 0+ '    ,'1/2+'    ,'3/2-'    ,'3/2-'    ,' 1+ '               
     *,' 0+ '    ,' 1+ '    ,'3/2-'    ,'1/2-'    ,'1/2-'               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,'1/2+'    ,'1/2-'               
     *,'1/2-'    ,' 0+ '    ,' 2- '    ,' 0+ '    ,' 0- '    /          
      DATA AJ 2/                                                        
     * '1/2-'    ,'5/2+'    ,'5/2+'    ,'1/2-'    ,' 0+ '               
     *,' 1+ '    ,' 0+ '    ,'5/2+'    ,'1/2+'    ,'1/2+'               
     *,' 0+ '    ,' 2+ '    ,' 0+ '    ,' 2+ '    ,'5/2+'               
     *,'3/2+'    ,'3/2+'    ,'5/2+'    ,'    '    ,' 0+ '               
     *,' 3+ '    ,' 0+ '    ,'5/2+'    ,'3/2+'    ,'3/2+'               
     *,'5/2+'    ,' 0+ '    ,' 4+ '    ,' 0+ '    ,' 4+ '               
     *,'5/2+'    ,'5/2+'    ,'5/2+'    ,'5/2+'    ,',3+ '               
     *,' 0+ '    ,' 5+ '    ,' 0+ '    ,'1/2+'    ,'5/2+'               
     *,'5/2+'    ,' 0+ '    ,' 3+ '    ,' 0+ '    ,' 3+ '    /          
      DATA AJ 3/                                                        
     * '5/2+'    ,'1/2+'    ,'1/2+'    ,'2,3+'    ,' 0+ '               
     *,' 1+ '    ,' 0+ '    ,'3/2+'    ,'1/2+'    ,'1/2+'               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 2+ '    ,'1/2+'               
     *,'3/2+'    ,'3/2+'    ,' 1+ '    ,' 0+ '    ,' 0+ '               
     *,' 0+ '    ,'3/2+'    ,'3/2+'    ,'3/2+'    ,' 0+ '               
     *,' 2+ '    ,' 0+ '    ,'X   '    ,'7/2-'    ,'3/2+'               
     *,'3/2+'    ,'3/2+'    ,'3/2+'    ,' 0+ '    ,' 2- '               
     *,' 0+ '    ,' 3+ '    ,' 0+ '    ,'3/2+'    ,'7/2-'               
     *,'3/2+'    ,'3/2+'    ,' 2- '    ,' 0+ '    ,' 4- '    /          
      DATA AJ 4/                                                        
     * ' 0+ '    ,' 4- '    ,'7/2-'    ,'3/2+'    ,'7/2-'               
     *,'7/2-'    ,' 0+ '    ,' 2- '    ,' 0+ '    ,' 0+ '               
     *,' 0+ '    ,'3/2+'    ,'7/2-'    ,'7/2-'    ,'7/2-'               
     *,' 2- '    ,' 0+ '    ,' 2+ '    ,' 0+ '    ,'3/2+'               
     *,'7/2-'    ,'7/2-'    ,'7/2-'    ,' 2- '    ,' 0+ '               
     *,' 4+ '    ,' 0+ '    ,' 0+ '    ,'1/2+'    ,'7/2-'               
     *,'7/2-'    ,'5/2-'    ,'3/2-'    ,' 0+ '    ,' 6+ '               
     *,' 0+ '    ,' 4+ '    ,' 0+ '    ,'3/2-'    ,'7/2-'               
     *,'7/2-'    ,'7/2-'    ,'5/2-'    ,' 0+ '    ,' 5+ '    /          
      DATA AJ 5/                                                        
     * ' 0+ '    ,' 6+ '    ,' 0+ '    ,' 0+ '    ,'7/2-'               
     *,'3/2-'    ,'7/2-'    ,'7/2-'    ,'5/2-'    ,' 0+ '               
     *,' 3+ '    ,' 0+ '    ,' 6+ '    ,' 0+ '    ,'7/2-'               
     *,'3/2-'    ,'7/2-'    ,'7/2-'    ,' 5+ '    ,' 0+ '               
     *,' 3+ '    ,' 0+ '    ,' 0+ '    ,'3/2-'    ,'5/2-'               
     *,'3/2-'    ,'7/2-'    ,' 0+ '    ,' 3+ '    ,' 0+ '               
     *,' 4+ '    ,' 0+ '    ,'5/2-'    ,'1/2-'    ,'7/2-'               
     *,'3/2-'    ,'    '    ,' 0+ '    ,' 2+ '    ,' 0+ '               
     *,' 1+ '    ,'3/2-'    ,'7/2-'    ,'3/2-'    ,'3/2-'    /          
      DATA AJ 6/                                                        
     * ' 0+ '    ,' 5+ '    ,' 0+ '    ,' 2+ '    ,'3/2-'               
     *,'7/2-'    ,'3/2-'    ,'3/2-'    ,'3/2-'    ,' 5+ '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,'    '    ,'1/2-'               
     *,'3/2-'    ,'3/2-'    ,'3/2-'    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,' 0+ '    ,'5/2-'    ,'3/2-'    ,'5/2-'               
     *,'3/2-'    ,'    '    ,' 0+ '    ,' 1+ '    ,' 0+ '               
     *,' 0+ '    ,' 0+ '    ,'    '    ,'3/2-'    ,'5/2-'               
     *,'3/2-'    ,'    '    ,' 1+ '    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,'1/2-'    ,'3/2-'    ,'5/2-'    ,'    '    /          
      DATA AJ 7/                                                        
     * ' 0+ '    ,' 1+ '    ,' 0+ '    ,' 4  '    ,' 0+ '               
     *,'1/2-'    ,'3/2-'    ,'1/2-'    ,'5/2-'    ,'5/2-'               
     *,' 0+ '    ,' 3- '    ,' 0+ '    ,' 2- '    ,' 0+ '               
     *,'3/2-'    ,'9/2+'    ,'3/2-'    ,'9/2+'    ,'X   '               
     *,' 3- '    ,' 0+ '    ,' 2- '    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,'1/2-'    ,'3/2-'    ,'5/2+'    ,'3/2-'               
     *,'    '    ,' 0+ '    ,' 2- '    ,' 0+ '    ,' 1  '               
     *,' 0+ '    ,'7/2+'    ,'3/2-'    ,'1/2-'    ,'3/2-'               
     *,'7/2+'    ,' 0+ '    ,' 2- '    ,' 0+ '    ,' 1+ '    /          
      DATA AJ 8/                                                        
     * ' 0+ '    ,'    '    ,'3/2-'    ,'7/2+'    ,'3/2-'               
     *,'1/2-'    ,'3/2-'    ,' 1+ '    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,' 1+ '    ,'3/2-'    ,'1/2-'    ,'3/2-'               
     *,'7/2+'    ,'3/2-'    ,' 5- '    ,' 0+ '    ,' 5- '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,'9/2+'    ,'3/2-'               
     *,'9/2+'    ,'5/2-'    ,'7/2+'    ,' 0+ '    ,' 2- '               
     *,' 0+ '    ,' 2- '    ,' 0+ '    ,' 4- '    ,'3/2-'               
     *,'9/2+'    ,'5/2-'    ,'9/2+'    ,'9/2+'    ,'1,2 '               
     *,' 0+ '    ,' 2- '    ,' 0+ '    ,' 4- '    ,' 0+ '    /          
      DATA AJ 9/                                                        
     * '    '    ,'5/2+'    ,'3/2-'    ,'9/2+'    ,'1/2-'               
     *,'    '    ,'    '    ,' 0+ '    ,' 2- '    ,' 0+ '               
     *,' 4- '    ,' 0+ '    ,' 8+ '    ,'    '    ,'5/2+'               
     *,'3/2-'    ,'5/2+'    ,'1/2-'    ,'9/2+'    ,'9/2+'               
     *,' 0+ '    ,' 1- '    ,' 0+ '    ,' 2- '    ,' 0+ '               
     *,' 8+ '    ,' 0+ '    ,'5/2+'    ,' -  '    ,'5/2+'               
     *,'1/2-'    ,'5/2+'    ,'9/2+'    ,'9/2+'    ,' 0+ '               
     *,'    '    ,' 0+ '    ,' 2- '    ,' 0+ '    ,' 7+ '               
     *,' 0+ '    ,' 8+ '    ,'    '    ,'    '    ,'    '    /          
      DATA AJ10/                                                        
     * '1/2-'    ,'5/2+'    ,'9/2+'    ,'5/2+'    ,'9/2+'               
     *,' 0+ '    ,'    '    ,' 0+ '    ,' 2- '    ,' 0+ '               
     *,' 6+ '    ,' 0+ '    ,'6,7+'    ,' 0+ '    ,'    '               
     *,'    '    ,' -  '    ,'5/2+'    ,'9/2+'    ,'5/2+'               
     *,'9/2+'    ,'5/2+'    ,' 0+ '    ,'    '    ,' 0+ '               
     *,' 5+ '    ,' 0+ '    ,' 7+ '    ,' 0+ '    ,'1/2-'               
     *,'1/2+'    ,'9/2+'    ,'5/2+'    ,'9/2+'    ,'5/2+'               
     *,'9/2+'    ,' 0+ '    ,' 1+ '    ,' 0+ '    ,'7,6+'               
     *,' 0+ '    ,' 2+ '    ,'    '    ,'9/2+'    ,'1/2+'    /          
      DATA AJ11/                                                        
     * '9/2+'    ,'5/2+'    ,'1/2-'    ,'5/2+'    ,'    '               
     *,'    '    ,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 1- '               
     *,' 0+ '    ,' 5+ '    ,'    '    ,'1/2+'    ,'9/2+'               
     *,'5/2+'    ,'1/2-'    ,'5/2+'    ,'9/2+'    ,' 0+ '               
     *,' 1+ '    ,' 0+ '    ,' 1- '    ,' 0+ '    ,' 5+ '               
     *,' 0+ '    ,'    '    ,'    '    ,'5/2+'    ,'1/2-'               
     *,'5/2+'    ,'7/2+'    ,'    '    ,' 0+ '    ,'    '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 5+ '    ,' 0+ '               
     *,'    '    ,'    '    ,'5/2+'    ,'7/2+'    ,'5/2+'    /          
      DATA AJ12/                                                        
     * '1/2-'    ,'5/2+'    ,'    '    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,'    '    ,'    '               
     *,'5/2+'    ,'5/2+'    ,'1/2-'    ,'5/2+'    ,'9/2+'               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 1+ '    ,' 0+ '               
     *,' 2+ '    ,' 0+ '    ,'    '    ,'5/2+'    ,'1/2-'               
     *,'5/2+'    ,'9/2+'    ,'    '    ,' 1+ '    ,' 0+ '               
     *,' 1+ '    ,' 0+ '    ,' 2+ '    ,' 0+ '    ,'5/2+'               
     *,'1/2-'    ,'1/2+'    ,'9/2+'    ,'7/2+'    ,' 0+ '               
     *,' 2- '    ,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 3+ '    /          
      DATA AJ13/                                                        
     * '    '    ,'1/2-'    ,'1/2+'    ,'9/2+'    ,'1/2+'               
     *,'5/2+'    ,' 0+ '    ,'    '    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,' 3+ '    ,' 0+ '    ,'1/2-'    ,'1/2+'               
     *,'9/2+'    ,'1/2+'    ,'5/2+'    ,'1/2+'    ,'    '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 3+ '    ,' 0+ '               
     *,'1/2+'    ,'9/2+'    ,'1/2+'    ,'5/2+'    ,'1/2+'               
     *,'5/2+'    ,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,'    '    ,' 0+ '    ,'    '    ,'9/2+'               
     *,'1/2+'    ,'5/2+'    ,'1/2+'    ,'5/2+'    ,'    '    /          
      DATA AJ14/                                                        
     * ' 1+ '    ,' 0+ '    ,' 1+ '    ,' 0+ '    ,'    '               
     *,' 0+ '    ,'9/2+'    ,'3/2+'    ,'5/2+'    ,'1/2+'               
     *,'5/2+'    ,'    '    ,'    '    ,' 0+ '    ,' 2- '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,'9/2+'    ,'11/-'               
     *,'7/2+'    ,'1/2+'    ,'5/2+'    ,'1/2+'    ,'    '               
     *,' 0+ '    ,' 3- '    ,' 0+ '    ,' 2- '    ,' 0+ '               
     *,'11/-'    ,'7/2+'    ,'1/2+'    ,'5/2+'    ,'1/2+'               
     *,'1/2+'    ,'    '    ,' 0+ '    ,' 8- '    ,' 0+ '               
     *,' 2- '    ,' 0+ '    ,' 1+ '    ,' 0+ '    ,'11/-'    /          
      DATA AJ15/                                                        
     * '7/2+'    ,'3/2+'    ,'5/2+'    ,'1/2+'    ,'1/2+'               
     *,'    '    ,' 0+ '    ,' 8- '    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,'    '    ,'    '               
     *,'7/2+'    ,'3/2+'    ,'7/2+'    ,'1/2+'    ,'1/2+'               
     *,'    '    ,'3/2+'    ,' 5+ '    ,' 0+ '    ,' 5- '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 3+ '    ,' 0+ '               
     *,'7/2+'    ,'3/2+'    ,'7/2+'    ,'3/2+'    ,'5/2+'               
     *,'1/2+'    ,'1/2+'    ,'    '    ,'7,8-'    ,' 0+ '               
     *,' 4+ '    ,' 0+ '    ,' 2- '    ,' 0+ '    ,' 2- '    /          
      DATA AJ16/                                                        
     * ' 0+ '    ,'7/2+'    ,'3/2+'    ,'7/2+'    ,'3/2+'               
     *,'7/2+'    ,'1/2+'    ,'5/2+'    ,'5/2+'    ,' 0+ '               
     *,' 4+ '    ,' 0+ '    ,' 4+ '    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,'    '    ,'7/2+'    ,'3/2+'    ,'7/2+'               
     *,'3/2+'    ,'5/2+'    ,'1/2+'    ,'5/2+'    ,'    '               
     *,' 2- '    ,' 0+ '    ,' 5+ '    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,' 2+ '    ,' 0+ '    ,'    '    ,'7/2-'               
     *,'7/2+'    ,'3/2+'    ,'7/2+'    ,'3/2+'    ,'5/2+'               
     *,'1/2+'    ,' 0+ '    ,' 3- '    ,' 0+ '    ,' 5- '    /          
      DATA AJ17/                                                        
     * ' 0+ '    ,' 1+ '    ,'    '    ,'    '    ,'7/2-'               
     *,'7/2+'    ,'3/2+'    ,'5/2+'    ,'3/2+'    ,' 0+ '               
     *,'    '    ,' 0+ '    ,' 3- '    ,' 0+ '    ,' 1+ '               
     *,' 0+ '    ,'    '    ,'    '    ,'    '    ,'    '               
     *,'7/2-'    ,'5/2+'    ,'3/2+'    ,'5/2+'    ,' 0+ '               
     *,'    '    ,' 0+ '    ,' 2- '    ,' 0+ '    ,' 2- '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 1+ '    ,'    '               
     *,'    '    ,'    '    ,'    '    ,'3/2-'    ,'7/2+'               
     *,'7/2-'    ,'5/2+'    ,'3/2+'    ,'5/2+'    ,'X   '    /          
      DATA AJ18/                                                        
     * ' 0+ '    ,' 0- '    ,' 0+ '    ,' 6- '    ,' 0+ '               
     *,' 1+ '    ,'    '    ,'7/2+'    ,'7/2-'    ,'5/2+'               
     *,'7/2-'    ,'5/2+'    ,'1/2+'    ,' 0+ '    ,' 3- '               
     *,' 0+ '    ,'3,4-'    ,' 0+ '    ,' 4- '    ,' 0+ '               
     *,'    '    ,'5/2-'    ,'7/2+'    ,'7/2-'    ,'5/2+'               
     *,'7/2-'    ,'5/2-'    ,'    '    ,' 0+ '    ,' 1- '               
     *,' 0+ '    ,' 5- '    ,' 0+ '    ,'    '    ,'    '               
     *,'5/2-'    ,'7/2+'    ,'7/2-'    ,'5/2+'    ,'7/2-'               
     *,'    '    ,' 0+ '    ,' 1  '    ,' 0+ '    ,'0,1-'    /          
      DATA AJ19/                                                        
     * ' 0+ '    ,'    '    ,' 0+ '    ,'    '    ,'5/2+'               

     *,'3/2-'    ,'5/2+'    ,'7/2-'    ,'1/2 '    ,'7/2 '               
     *,'    '    ,'    '    ,' 0+ '    ,' 3- '    ,' 0+ '               
     *,' 2- '    ,' 0+ '    ,'    '    ,'    '    ,'3/2+'               
     *,'5/2+'    ,'3/2+'    ,'5/2-'    ,'7/2 '    ,'    '               
     *,'    '    ,'    '    ,' 0+ '    ,' 3- '    ,' 0+ '               
     *,'    '    ,' 0+ '    ,' 1  '    ,' 0+ '    ,'3/2-'               
     *,'5/2+'    ,'3/2-'    ,'3/2+'    ,'3/2-'    ,'5/2 '               
     *,'    '    ,' 0+ '    ,' 0+ '    ,' 0+ '    ,' 3- '    /          
      DATA AJ20/                                                        
     * ' 0+ '    ,' 1  '    ,'    '    ,'    '    ,'3/2-'               
     *,'3/2+'    ,'3/2-'    ,'7/2 '    ,'3/2 '    ,'    '               
     *,' 0+ '    ,' 3- '    ,' 0+ '    ,' 5+ '    ,' 0+ '               
     *,'5/2+'    ,'3/2-'    ,'3/2+'    ,'3/2-'    ,'7/2-'               
     *,'3/2-'    ,'X   '    ,' 0+ '    ,' 3- '    ,' 0+ '               
     *,' 5+ '    ,' 0+ '    ,'5/2-'    ,'3/2+'    ,'5/2+'               
     *,'7/2-'    ,'3/2-'    ,'7/2 '    ,'X   '    ,' 1- '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 1- '    ,'    '               
     *,'5/2-'    ,'7/2-'    ,'5/2-'    ,'1/2+'    ,'    '    /          
      DATA AJ21/                                                        
     * ' 0+ '    ,' 1+ '    ,' 0+ '    ,' 1+ '    ,' 0+ '               
     *,'7/2+'    ,'7/2-'    ,'5/2-'    ,'1/2+'    ,'5/2-'               
     *,' 0+ '    ,' 0- '    ,' 0+ '    ,' 2+ '    ,' 0+ '               
     *,'7/2-'    ,'7/2+'    ,'1/2+'    ,'5/2-'    ,'    '               
     *,'    '    ,' 0+ '    ,' 3+ '    ,' 0+ '    ,' 1- '               
     *,' 0+ '    ,'    '    ,'1/2-'    ,'1/2+'    ,'7/2+'               
     *,'7/2+'    ,'5/2-'    ,'X   '    ,' 0+ '    ,' 1- '               
     *,' 0+ '    ,' 0+ '    ,' 0+ '    ,'5/2-'    ,'1/2+'               
     *,'1/2-'    ,'7/2+'    ,'    '    ,' 0+ '    ,' 2- '    /          
      DATA AJ22/                                                        
     * ' 0+ '    ,' 4- '    ,' 0+ '    ,'    '    ,'    '               
     *,'1/2+'    ,'5/2-'    ,'7/2+'    ,'1/2-'    ,'7/2+'               
     *,' 4- '    ,' 0+ '    ,' 1- '    ,' 0+ '    ,' 4- '               
     *,' 0+ '    ,'1/2+'    ,'7/2-'    ,'7/2+'    ,'5/2-'               
     *,'7/2+'    ,'1/2-'    ,'    '    ,' 0+ '    ,' 7- '               
     *,' 0+ '    ,' 1- '    ,' 0+ '    ,'X   '    ,'X   '               
     *,'X   '    ,' 0+ '    ,'9/2+'    ,'7/2+'    ,'7/2-'               
     *,'7/2+'    ,'    '    ,'    '    ,'X   '    ,' 1+ '               
     *,' 0+ '    ,' 1+ '    ,' 0+ '    ,' 5- '    ,'7/2+'    /          
      DATA AJ23/                                                        
     * '9/2+'    ,'7/2+'    ,'7/2-'    ,'5/2+'    ,' 3- '               
     *,' 0+ '    ,' 8+ '    ,' 0+ '    ,' 1- '    ,' 0+ '               
     *,'1/2-'    ,'7/2+'    ,'9/2+'    ,'5/2+'    ,'    '               
     *,' 0+ '    ,' 3- '    ,' 0+ '    ,' 7+ '    ,' 0+ '               
     *,' 5- '    ,'3/2-'    ,'7/2+'    ,'1/2-'    ,'5/2+'               
     *,'9/2+'    ,'    '    ,' 5- '    ,' 0+ '    ,' 3- '               
     *,' 0+ '    ,'    '    ,' 0+ '    ,'    '    ,' 0+ '               
     *,'7/2+'    ,'3/2-'    ,'5/2+'    ,'1/2-'    ,'3/2+'               
     *,'    '    ,'    '    ,'    '    ,'    '    ,' 0+ '    /          
      DATA AJ24/                                                        
     * ' 1- '    ,' 0+ '    ,' 6- '    ,' 0+ '    ,'    '               
     *,' 0+ '    ,'3/2-'    ,'5/2+'    ,'1/2-'    ,'3/2+'               
     *,'    '    ,'    '    ,'    '    ,' 0+ '    ,' 1- '               
     *,' 0+ '    ,' 2- '    ,' 0+ '    ,'    '    ,' 0+ '               
     *,'    '    ,'5/2+'    ,'3/2-'    ,'3/2+'    ,'    '               
     *,'    '    ,'    '    ,'    '    ,' 0+ '    ,' 4+ '               
     *,' 0+ '    ,' 1- '    ,' 0+ '    ,'    '    ,'9/2-'               
     *,'3/2+'    ,'3/2-'    ,'3/2+'    ,'    '    ,'    '               
     *,' 0+ '    ,' 4- '    ,' 0+ '    ,' 1- '    ,' 0+ '    /          
      DATA AJ25/                                                        
     * ' 2- '    ,'3/2-'    ,'3/2+'    ,'1/2-'    ,'3/2+'               
     *,'3/2-'    ,'1/2+'    ,' 0+ '    ,' 1- '    ,' 0+ '               
     *,' 1- '    ,' 0+ '    ,'(2-)'    ,'X   '    ,'11/-'               
     *,'1/2-'    ,'3/2+'    ,'1/2-'    ,'1/2+'    ,'    '               
     *,'    '    ,' 0+ '    ,' 2- '    ,' 0+ '    ,' 2- '               
     *,' 0+ '    ,'    '    ,'1/2-'    ,'3/2+'    ,'1/2-'               
     *,'1/2+'    ,'3/2-'    ,'X   '    ,' 0+ '    ,' 2- '               
     *,' 0+ '    ,' 2- '    ,' 0+ '    ,'    '    ,'5/2-'               
     *,'3/2+'    ,'1/2-'    ,'1/2+'    ,'5/2-'    ,'9/2 '    /          
      DATA AJ26/                                                        
     * ' 0+ '    ,' 1- '    ,' 0+ '    ,' 2- '    ,' 0+ '               
     *,' 7+ '    ,' 0+ '    ,'X   '    ,'    '    ,'3/2-'               
     *,'1/2+'    ,'5/2-'    ,'9/2-'    ,'3/2-'    ,' 1- '               
     *,' 0+ '    ,' 2- '    ,' 0+ '    ,' 5+ '    ,' 0+ '               
     *,'X   '    ,'    '    ,'5/2-'    ,'1/2+'    ,'5/2-'               
     *,'9/2-'    ,'5/2-'    ,'X   '    ,' 0+ '    ,' 2- '               
     *,' 0+ '    ,' 6+ '    ,' 0+ '    ,'X   '    ,'X   '               
     *,'1/2-'    ,'1/2+'    ,'5/2-'    ,'9/2-'    ,'5/2-'               
     *,'X   '    ,'X   '    ,'X   '    ,' 0- '    ,' 0+ '    /          
      DATA AJ27/                                                        
     * ' 6+ '    ,' 0+ '    ,'    '    ,'X   '    ,'X   '               
     *,'1/2+'    ,'1/2-'    ,'9/2-'    ,'5/2-'    ,'    '               
     *,'X   '    ,'X   '    ,' 5+ '    ,' 0+ '    ,' 5+ '               
     *,' 0+ '    ,' 7+ '    ,'X   '    ,'X   '    ,'1/2+'               
     *,'9/2+'    ,'9/2-'    ,'1/2-'    ,'9/2-'    ,'X   '               
     *,'X   '    ,'4,5 '    ,' 0+ '    ,' 1- '    ,' 0+ '               
     *,' 5+ '    ,' 0+ '    ,'X   '    ,'9/2+'    ,'9/2-'               
     *,'9/2+'    ,'9/2-'    ,'1/2-'    ,'X   '    ,'X   '               
     *,' 0+ '    ,' 1- '    ,' 0+ '    ,' 1- '    ,' 0+ '    /          
      DATA AJ28/                                                        
     * 'X   '    ,'X   '    ,'    '    ,'9/2-'    ,'9/2+'               
     *,'    '    ,'    '    ,'X   '    ,'X   '    ,'X   '               
     *,' 0+ '    ,' 1- '    ,' 0+ '    ,'    '    ,' 0+ '               
     *,' 1- '    ,'X   '    ,'X   '    ,'9/2-'    ,'9/2+'               
     *,'    '    ,'    '    ,'X   '    ,'X   '    ,'X   '               
     *,' 0+ '    ,' 1- '    ,' 0+ '    ,'    '    ,'X   '               
     *,'X   '    ,'    '    ,'9/2+'    ,'    '    ,'X   '               
     *,' 0+ '    ,'    '    ,' 0+ '    ,'    '    ,'X   '               
     *,'    '    ,'3/2+'    ,'    '    ,'    '    ,'X   '    /          
      DATA AJ29/                                                        
     * ' 0+ '    ,'    '    ,' 0+ '    ,'    '    ,'    '               
     *,'    '    ,'    '    ,' 0+ '    ,'    '    ,' 0+ '               
     *,'    '    ,'    '    ,'3/2+'    ,'1/2+'    ,'5/2-'               
     *,'X   '    ,'    '    ,' 0+ '    ,'    '    ,' 0+ '               
     *,'5/2-'    ,'3/2-'    ,'3/2+'    ,'X   '    ,' 0+ '               
     *,'    '    ,' 0+ '    ,'    '    ,'    '    ,'3/2-'               
     *,'3/2+'    ,'5/2-'    ,' 0+ '    ,' 3+ '    ,' 0+ '               
     *,' 3+ '    ,' 0+ '    ,'X   '    ,'5/2+'    ,'5/2-'               
     *,'3/2+'    ,'X   '    ,' 0+ '    ,' 2- '    ,' 0+ '    /          
      DATA AJ30/                                                        
     * 'X   '    ,'X   '    ,'5/2+'    ,'3/2-'    ,'5/2-'               
     *,'X   '    ,' 0+ '    ,'2,3 '    ,' 0+ '    ,'X   '               
     *,'X   '    ,'1/2+'    ,'3/2-'    ,'5/2+'    ,'    '               
     *,'X   '    ,' 0+ '    ,' 4+ '    ,' 0+ '    ,' 0+ '               
     *,'X   '    ,'3/2-'    ,'7/2-'    ,'5/2+'    ,'5/2+'               
     *,' 1- '    ,' 0+ '    ,' 6- '    ,' 0+ '    ,'X   '               
     *,'3/2-'    ,'1/2+'    ,'5/2+'    ,'7/2-'    ,'X   '               
     *,' 0+ '    ,' 2+ '    ,' 0+ '    ,'    '    ,'X   '               
     *,'5/2+'    ,'5/2+'    ,'1/2+'    ,'5/2-'    ,'X   '    /          
      DATA AJ31/                                                        
     * ' 0+ '    ,' 5+ '    ,' 0+ '    ,' 3- '    ,' 0+ '               
     *,'5/2+'    ,'5/2+'    ,'5/2-'    ,'1/2+'    ,'X   '               
     *,'X   '    ,' 0+ '    ,' 1- '    ,' 0+ '    ,'X   '               
     *,'7/2+'    ,'5/2-'    ,'5/2+'    ,'3/2-'    ,'X   '               
     *,' 0+ '    ,' 6- '    ,' 0+ '    ,' 4- '    ,' 0+ '               
     *,'9/2-'    ,'5/2+'    ,'7/2+'    ,'3/2-'    ,'1/2+'               
     *,'X   '    ,' 0+ '    ,' 2+ '    ,' 0+ '    ,' 2- '               
     *,' 0+ '    ,'X   '    ,'5/2 '    ,'9/2-'    ,'3/2-'               
     *,'7/2+'    ,'X   '    ,' 0+ '    ,' 8- '    ,' 0+ '    /          
      DATA AJ32/                                                        
     * '    '    ,' 0+ '    ,'1/2+'    ,'7/2+'    ,'9/2-'               
     *,'7/2+'    ,'7/2+'    ,' 0+ '    ,' 2- '    ,' 0+ '               
     *,'    '    ,' 0+ '    ,'7/2+'    ,'1/2+'    ,'3/2-'               
     *,'9/2-'    ,'X   '    ,' 0+ '    ,' 7+ '    ,' 0+ '               
     *,'X   '    ,'7/2+'    ,'7/2+'    ,'1/2+'    ,'X   '               
     *,'9/2-'    ,' 0+ '    ,' 7+ '    ,' 0+ '    ,'X   '               
     *,'    '    ,'    '    ,'7/2+'    ,'7/2-'    ,'1/2+'               
     *,'    '    ,' 0+ '    ,' 0- '    ,' 0+ '    ,'    '               
     *,'9/2+'    ,'    '    ,'    '    ,'    '    ,'    '    /          
      DATA AJ33/                                                        
     * '    '    ,'X   '    ,'X   '    ,'X   '    ,'X   '               
     *,'X   '    ,'X   '    ,'X   '    ,'X   '    ,'X   '               
     *,'X   '    ,'X   '    ,'X   '    ,'X   '    ,'X   '               
     *,'X   '    ,'X   '    ,'X   '    ,'X   '    ,'X   '               
     *,'X   '    ,'X   '    ,'X   '    ,'X   '    ,'X   '               
     *,'X   '    ,'X   '    ,'X   '    ,'X   '    ,'X   '               
     *,'X   '    ,'X   '    ,'X   '    ,'X   '    ,'X   '               
     *,'X   '    ,'X   '    ,'X   '    ,'X   '    ,'X   '               
     *,'X   '    ,'X   '    ,'X   '    ,'X   '    ,'X   '    /          
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -     
C                                                                       
CDC%';DATA' = ';INITDATA'                                               
C                                                                       
C  IE HAS LOWEST Z FOR EACH A-SERIES...                                 
C  IA HAS ADDRESS OF LOWEST Z FOR EACH A-SERIES IN AM ARRAY...          
C  AM HAS MASS-EXCESS ES STORED IN ORDER OF INCREASING A, AND WITHIN    
C  EACH A-SERIES IN ORDER OF INCREASING Z.  MISSING INNER Z'S INDICATED 
C  BY A QUESTION MARK '0' IN AA OR AJ OR BOTH.                          
C                                                                       
      NOTTAB=0                                                          
      JVAL = NOTDEF                                                     
      PARITY = 0                                                        
C  GREATEST A IS 268, LEAST IS 1...                                     
      IF(KA.LE.0.OR.KA.GT.NTAB) GO TO 5                                 
      KZLO=IE(KA+1)                                                     
      KZHI=IA(KA+2)-IA(KA+1)+KZLO-1                                     
C  CHECK FOR VALID Z...                                                 
      IF(KZ.GT.KZHI.OR.KZ.LT.KZLO) GO TO 5                              
C  CALCULATE POSITION IN AM ARRAY...                                    
      IT=KZ-KZLO+IA(KA+1)                                               
      JPI = AJ(IT+1)                                                    
C  CHECK FOR MISSING ENTRY...                                           
      IF ( JPI.EQ.QMARK ) GO TO 5                                       
C                                                                       
C     DECODE THE J VALUE                                                
C                                                                       
      JVL = 0                                                           
      JCHAR = JPI                                                       
      JFND = 0                                                          
CWD      DECODE ( 8, 123, JCHAR )  CHAR                                 
CWD  123 FORMAT ( 4A1 )                                                 
      DO 159 I = 1, 4                                                   
      IF ( CHAR(I) .EQ. BLANK ) GO TO 159                               
      IF ( CHAR(I) .EQ. QMARK1 ) RETURN                                 
      IF ( CHAR(I) .EQ. SLASH ) GO TO 180                               
      KCHAR = ICHAR(CHAR(I)) - 48                                       
      IF ( KCHAR .LT. 0 .OR. KCHAR .GT. 9 ) GO TO 170                   
      JFND = 1                                                          
      JVL = 10*JVL + KCHAR                                              
 159  CONTINUE                                                          
C                                                                       
C     DONE WITH FIELD AND NO SLASH FOUND - EITHER NOTHING OR INTEGER    
C                                                                       
 170  IF ( JFND .NE. 1 ) RETURN                                         
      JVAL = 2*JVL                                                      
      GO TO 200                                                         
C                                                                       
C     SLASH FOUND SO IT IS HALF-INTEGER AND IS DEFINED                  
C                                                                       
 180  JVAL = JVL                                                        
C                                                                       
C     NOW SCAN FOR THE PARITY                                           
C                                                                       
 200  DO 209 I = 1, 4                                                   
      IF ( CHAR(I) .EQ. PLUS ) PARITY = +1                              
      IF ( CHAR(I) .EQ. MINUS ) PARITY = -1                             
 209  CONTINUE                                                          
      RETURN                                                            
    5 NOTTAB=1                                                          
      JPI = QMARK                                                       
      RETURN                                                            
      END                                                               

      SUBROUTINE INELDC ( IRTN )                                        
C                                                                       
C     COMPUTES THE TRANSFER REACTION RADIAL INTEGRALS.                  
C                                                                       
C                                                                       
C         THE ROUTINE GRDSET IS CALLED BEFORE THIS ROUTINE TO           
C     INITIALIZE THE THREE-DIMENSIONAL GRIDS AND SETUP THE REQUIRED     
C     BOUND STATE PRODUCTS.  ALSO  WAVSET  IS CALLED FOR EACH           
C     CHANNEL TO INITIALIZE THE COMPUTATION OF THE SCATTERING WAVES.    
C     INELDC CALLS WFGET EACH TIME IT NEEDS A NEW WAVE FUNCTION.        
C                                                                       
C     THIS ROUTINE THEN CALCULATES H(LI,LO,LX) WHICH IS THE INTEGRAL OF 
C     A12, V, AND THE BOUND STATE WAVEFUNCTIONS                         
C                                                                       
C     IT THEN INTEGRATES H(LI,LO,LX) OVER THE DISTORTED WAVES.          
C     SFROMI IS THEN CALLED TO RENORMALIZE THE RESULTS AND SAVE         
C     THEM AS S(LI,LO,LX,JP,JT).                                        
C                                                                       
C                                                                       
C   D.GLOECKNER 10/15/73                                                
C                                                                       
C     THIS VERSION ASSUMES GAUSS INTEGRATION FOR ALL L-VALUES HAS SAME  
C     GRID.  THIS ALLOWS SOME R-DEPENDENT (AND L-INDEPENDENT) SUMS TO   
C     BE TAKEN OUT OF INNER LOOP AT THE EXPENSE OF LARGE ARRAYS.        
C     6/74  D.G.                                                        
C                                                                       
C        7/29/74  D.GLOECKNER                                           
C                                                                       
C     1/16/75 - ADD DG CORRECTIONS; USE YLM AND REMOVE AFAC.            
C               BY S.P.                                                 
C     1/21/75 - FINAL INELDC74 VERSION.  ADD LOTS OF COMMENTS.          
C                                                                       
C     1/23/75 - SPLIT INTO TWO PIECES - INELDC AND XSECTN - S.P.        
C     1/26/75 - REVISE TIMES; REMOVE MUCH Z(...) STUFF FROM DX LOOP;    
C               USE TABLE OF INTEGERS; IMPROVE INITIAL INTERPOLATIONS;  
C                IMPROVE FAST COSINE (SMALL); OTHER SMALL FIXES         
C     1/27/75 - FIX LOWER LIMIT X0(RI,RO) OF X-INTEGRATION (MHM)        
C               BS PRODUCT LT VZERO WHEN X LT X0                        
C     1/29/75 - REWRITE INLINE COSINE - S.P.                            
C     1/30/75 - REVAMP A12 USING DOUBLE PRE. ARRAYS FOR M'S;            
C               AVOID USING LARGE RIX, ROX.                             
C     1/31/75 - CONTROL OVER PRINTING; USE J1 J2 OF BOUND STATE         
C     2/4/75  - REWRITE RI,RO INTEGRATION                               
C     2/6/75  - SPLIT  GRDSET  OFF FROM INELDC - S. P.                  
C             VARIABLES U=(RI+RO)/2 V=RI-RO WITH SINH MAPPINGS TO BUNCH 
C             GAUSS POINTS AROUND U=R V=0                               
C             CALL WAVEF (NEW ENTRY WAVELJ) DURING LI-LO LOOP           
C             STORE SCATTERING WAVE FUNCTIONS IN A CLOCKWISE PATTERN    
C             (MHM FEB 4 1975)                                          
C     2/7/75 - SPLIT OFF GRDSET. S.P.                                   
C     CALL DUMMY1 TO SETUP OVERLAY                                      
C     2/23/75 - USE REAL*4 ARRAYS                                       
C     2/27/75 - AVOID UNDERFLOWS FOR SMALL R, LARGE L.                  
C     3/6/75 - FIX BUG FOR LO = 0, OTHER STUFF IN LO,LI LOOPS           
C     3/7/75 - USE INPUT VALUE OF JX; ALLOW FREE OVERRIDE.              
C     3/20/75 - WAVEFUNCTIONS IN SINGLE PRECISION                       
C     3/23/75 - NEW A12 ARRANGEMENT; USE COS(THETA-2PHI) METHOD         
C     3/27/75 - ONE MSVAL ARRAY; COSINE TABLE TO 2PI                    
C     4/7/75 - LI, LX LOOPS INSIDE.                                     
C     4/10/75 - USE OVERRIDING ASM. LANG. ROUTINE FOR INNER LOOPS       
C     4/18/75 - NEW COMMON                                              
C     5/20/75 - USE LOS ARRAY AND DO ONLY SOME I(LI,LO,LX).             
C     6/3/75 - CHANGE PHASE OF I(LI,LO,LX)                              
C     6/9/75 - DO NOT INCLUDE COULOMB PHASES IN INPUT TO INTERPOLATION  
C              BUT DO INCLUDE THEM IN XSECTION INPUT.                   
C     6/11/75 - SAVEHS/USEHS                                            
C     7/19/75 - ALLOW DIFFERENT LO'S IN USEHS;  INTEGRAND  CHECKS       
C     8/26/75 - SMALLER ILILOLX TABLES                                  
C     9/8/75 - SMALL FIXES                                              
C     9/15/75 - NEW DWCUTOFF                                            
C     9/17/75 - SAVEHS AS REAL*4                                        
C     2/11/76 - INELD2 SPLIT OFF - S. P.                                
C     2/24/76 - SIGN CONVENTIONS AND NOTATION OF CHAPTER II OF MANUAL   
C     5/26/76 - INTERPOLATION IN U                                      
C     6/20/76 - FIX USEHS BUG INTRODUCED ABOVE                          
C     4/28/78 - LI & LO INTERCHANGED - S.P.                             
C     5/24/78 - NEW WAVELJ CALLS - S.P.                                 
C     7/9/78 - PUT SALLOC IN /SCMALO/                                   
C     6/25/78 - AVOID 0/0 IN CANCELLATIONS                              
C     3/6/79 - S-MATRICES - S.P.                                        
C     5/17/79 - FULL ARG LIST ON FIRST SETLOP CALL TO FORCE STORES      
C     6/6/79 - MANY CHANGES FOR S.O., TENSOR POTENTIALS - RPG           
C     6/8/79 - STANDARD PREFIXES, ETC. - RPG                            
C     6/19/79 - PASS INIA12 TO A12 TO ALLOW NO OVERLAY - S.P.           
C     6/20/79 - OMIT REWIND; SCAN TO END ON MULTIPASS USEHS - RPG       
C     9/12/79 - DELETE REFERENCES TO DEFUNCT "LOGIC" ARRAY - RPG        
C     11/20/79 - PASS ILI TO SFROMI - S.P.                              
C     12/12/79 - OPTIONAL SCRATCH FILE, ADD /SWITCH/ - RPG              
C     1/21/80 - CIB PREFIX ON SETLOP CALLS - RPG                        
C     2/5/80 - CVA NPFAUL CALLS TO COUNT PAGE FAULTS - RPG              
C     2/29/80 - CALL READSC, WRITHS, READHS FOR EFFICIENT I/O - RPG     
C     3/15/80 - CALL ABOVE ONLY IN VAX VERSION - S.P.                   
C     4/14/80 - FIGURE OUT WHERE TO START IN THE IWFIO BUFFER - S.P.    
C     4/22/80 - FIX BUG IN ABOVE FIX - S.P.                             
C     4/26/80 - PBUGSW NOLONGER IN WAVCOM - S.P.                        
C     8/11/80 - CALL SETLOG - S.P.                                      
C     10/28/81 - ROOT 2 FOR IDENTICAL PARTICLES - S.P.                  
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      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 /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)                                              
      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 /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      REAL*4 TBEGIN, TIMES                                              
      COMMON /FTIME/ TBEGIN, NUMLOP, NUMWAV, TIMES(8)                   
C                                                                       
CDLC                                                                    
CDLC     FOLLOWING TINY ALLOCATOR IS USED FOR THE H'S                   
CDLC                                                                    
      DIMENSION SALLOC(1)                                               
CDL      COMMON /SCMALO/  SALLOC                                        
CDS      EQUIVALENCE ( SALLOC(1), ALLOC(1) )                            
      EQUIVALENCE ( SALLOC(1), ALLOC(1) )                               
C                                                                       
CIB      REAL*8  HOLD / Z 46800000 80000000 /                           
CIB      INTEGER  MASK8 / Z FF7F FFFF /                                 
CIB      DATA  RNN / 0.D0 /                                             
CIB      EQUIVALENCE  (DNN, NN4),  (RNN, IRNN)                          
C                                                                       
      LOGICAL PBUGSW, PINFSW                                            
      LOGICAL NXLISW                                                    
      LOGICAL FIRSTL                                                    
C
      DATA HAFNEG / -.50D0 /                                            
C
      IRTN = 0                                                          
      DO 14 III=1, 8                                                    
  14  TIMES(III)=0.0                                                    
      NUMTIM = 4                                                        
      XNUMANG = 0
      XNUMTRM = 0
      NUM3 = 0                                                          
      NUM4 = 0                                                          
      NUM5 = 0                                                          
      NUM6 = 0                                                          
      NUMHIN = 0                                                        
      FIRSTL = .TRUE.                                                   
C                                                                       
      IPRNT = MOD( IPRINT, 10 )                                         
      PBUGSW = IPRNT .GE. 4                                             
      PINFSW = IPRNT .GE. 2                                             
      INIA12 = 5                                                        
C                                                                       
C                                                                       
      WRITE(6,23) REACT, ELAB, HEADER                                     
 23   FORMAT ( X, T60, 'P T O L E M Y' /  10X, 'COMPUTATION OF TRANSFE
     *R S-MATRIX ELEMENTS',  T95, 'WHEELS WITHIN WHEELS' /  X, 45A1, '
     *ELAB =', F7.2, ' MEV', 5X, 65A1 / )                               
C                                                                       
      NLINE = 1000                                                      
C                                                                       
      CALL SETLOG ( 2*(LOMOST+LXMAX) )                                  
C                                                                       
C     HERE WE START THE REAL GUTS OF THE CALCULATION.                   
C                                                                       
C                                                                       
C     THE PRINCIPAL LOOPS ARE IN THE ORDER:                             
C                                                                       
C     PARITY OF LI                                                      
C       LI   LMIN <= LI <= LMAX                                         
C         RI-RO  NPDIF TERMS                                            
C           (RI+RO)2  NPSUM TERMS                                       
C             DX   (NPPHI POINTS)                                       
C               MP AND MT   (LIMITS FROM A12)                           
C                 MU       (LIMITS FROM A12)                            
C                   LX&LO - COMBINED LOOP WITH LIMITS FROM A12          
C           INTERPOLATION AND THEN:                                     
C           (RI+RO)/2  NPSUMI TERMS                                     
C             JPI,JPO,LO COMBINED LOOP FOR WF PRODUCTS                  
C             JPI,JPO,LO',LX' COMBINED LOOP FOR INTEGRALS I             
C         CALL SFROMI TO CONVERT TO S MATRIX                            
C                                                                       
C                                                                       
C     WE WILL HAVE NO MORE  IALLOC  CALLS SO GET ADDRESSES              
C                                                                       
      LMSVAL = Z(IMSVAL) - 1                                            
      LJA12S = FACFR4*Z(IJA12S) - FACFR4                                
      LINTS = Z(IINTS) - 1 + INTOFF                                     
      LA12VL = Z(IA12VL)-1                                              
      LHS = Z(IHS)                                                      
CDL      LHS = 1                                                        
      LHSM1 = LHS - 1                                                   
      LIINDX = FACFR4*Z(IIINDX) - FACFR4                                
      LA12T1 = Z(IA12TM)                                                
      LA12T2 = LA12T1 + NUMLX                                           
      LA12T3 = LA12T2 + 2*LXMAX + 2                                     
      IF ( IHSAVE .EQ. 2 ) LA12T3 = LA12T1                              
      LCOSIN = Z(ICOSIN)                                                
      LPHIT = FACFR4*Z(IPHIT) - FACFR4                                  
      LPHIP = FACFR4*Z(IPHIP) - FACFR4                                  
      LPHI = FACFR4*Z(IPHI) - FACFR4                                    
      LTRP = FACFR4*Z(LOCTRP) - FACFR4                                  
      LRI = FACFR4*Z(IRI) - FACFR4                                      
      LRO = FACFR4*Z(IRO) - FACFR4                                      
      LLIR = FACFR4*Z(ILIR) - FACFR4                                    
      LLII = FACFR4*Z(ILII) - FACFR4                                    
      LLOR = FACFR4*Z(ILOR) - FACFR4                                    
      LLOI = FACFR4*Z(ILOI) - FACFR4                                    
      LWIO = FACFR4*Z(IWIO) - FACFR4                                    
      LDW = Z(IDW) - 1                                                  
      LLIS = FACFR4*Z(ILIS) - FACFR4                                    
      LLILOR = Z(ILILOR) - 1                                            
      LLILOI = Z(ILILOI) - 1                                            
      LHINT = Z(IHINT) - 1                                              
      LHABS = Z(IHABS) - 1                                              
      LABS1 = Z(IABS1) - 1                                              
      LSMHPT = Z(ISMHPT)                                                
      LSMIPT = Z(ISMIPT)                                                
      LSMHVL = Z(ISMHVL) - 1                                            
      LSMIVL = Z(ISMIVL) - 1                                            
      LSMHWK = Z(ISMHWK)                                                
      LRIOEX = Z(IRIOEX) - 1                                            
      LWAVR = Z(IWAVR)                                                  
      LWAVI = Z(IWAVI)                                                  
      LVRL1 = Z(IRLVS(1))                                               
      LVRL2 = Z(IRLVS(2))                                               
      LVIM1 = Z(IIMVS(1))                                               
      LVIM2 = Z(IIMVS(2))                                               
      LCENT1 = Z(ICENTR(1))                                             
      LCENT2 = Z(ICENTR(2))                                             
      LATERM = Z(IBETAS(1))                                             
      LDWI = FACFR4*Z(IDWI) - FACFR4                                    
      LWFIO = FACFR4*Z(IWFIO) - FACFR4                                  
      LWFII = FACFR4*Z(IWFII) - FACFR4                                  
      LINDXS = FACFR4*Z(IINDXS) - FACFR4                                
C                                                                       
C     WE ASSUME THAT                                                    
C       L1+L2+LX <= 256   AND   NUMCOSIN <= 16384                       
C                                                                       
      PI256 = 256*PI                                                    
C                                                                       
C                                                                       
C                                                                       
C     FORCE THE OVERLAYS TO GET THE THREEJ COMMON BLOCKS IN.            
C     THREEJ IS USED BY A12 WHICH IS                                    
C     CALLED REPTIVELY BELOW.  HOWEVER, NOTHING WILL HAPPEN             
C     FROM NOW ON THAT WOULD CAUSE THE OVERLAYS TO CHANGE.              
C                                                                       
      CALL DUMMY1                                                       
C                                                                       
      FACTOR = 2*DSQRT( AKI*AKO/(ES(1)*ES(2)) )                         
      IF ( IDENSW ) FACTOR = SQRT(2.D0) * FACTOR                        
C                                                                       
C                                                                       
C     THE LOOPS BEGIN NOW                                               
C                                                                       
C     LOOP OVER LI                                                      
C                                                                       
C                                                                       
C     TWO PASSES OVER LI LOOP NOW; EVEN LI FIRST,THEN ODD               
C                                                                       
      LIMIN=LMIN+1                                                      
      LIL=LMIN                                                          
      IF(MOD(LMIN,2) .EQ. 1 ) GO TO 150                                 
      LIMIN=LMIN                                                        
      LIL=LMIN+1                                                        
C                                                                       
C     LIPRTY = 1 FOR LI EVEN,  = 2 FOR LI ODD                           
C                                                                       
 150  DO 989 LIPRTY = 1, 2                                              
C                                                                       
      IF(LIMIN.GT.LMAX) GO TO 980                                       
      NXLISW = .FALSE.                                                  
      ILI = 1                                                           
C                                                                       
      DO 959 LI=LIMIN,LMAX,2                                            
C                                                                       
C     GET THE REQUIRED SCATTERING WAVEFUNCTIONS.                        
C     WE ALWAYS DO THIS EVEN IF LI WON'T BE USED SO AS TO GET THE       
C     ELASTIC S-MATRIX ELEMENTS.                                        
C                                                                       
      IF ( NXLISW ) GO TO 250                                           
C                                                                       
C     FOR FIRST LI, FILL UP THE OUT-CHANNEL WAVEFUNCTION ARRAY          
C                                                                       
      ITRK=0                                                            
C                                                                       
      DO 239 KWO = 1, NWFO                                              
      LO = ILLOC(LWFIO+4*KWO-3) + LI                                    
      LASO = ILLOC(LWFIO+4*KWO-2) + LI                                  
      JPO = ILLOC(LWFIO+4*KWO-1) + 2*LI                                 
      ILLOC(LWFIO+4*KWO) = ITRK                                         
      CALL WFGET ( LO, LASO, JPO, 2, NRIROI, ALLOC4(LRO+1),  ALLOC4(LLOR
     *+ITRK+1), ALLOC4(LLOI+ITRK+1),  ALLOC(LWAVR), ALLOC(LWAVI),  ALLOC
     *(LVRL2), ALLOC(LVIM2), ALLOC(LCENT2) )                            
 239  ITRK=ITRK+NRIROI                                                  
C                                                                       
      ITRK=0                                                            
      NXLISW = .TRUE.                                                   
      GO TO 280                                                         
C                                                                       
C     ON SUBSEQUENT LI'S WE NEED OUT-CHANNEL WAVE FUNCTIONS FOR ONE     
C     NEW LO.                                                           
C     WE MUST DETERMIN WHERE THE NEW LO STARTS.                         
C                                                                       
 250  LO = ILLOC(LWFIO+1) + 2                                           
      LASO = ILLOC(LWFIO+2) + 2                                         
      JPO = ILLOC(LWFIO+3) + 4                                          
      DO 254 II = 1, NWFO                                               
      IF ( LO .NE. ILLOC(LWFIO+4*II-3)  .OR. LASO .NE. ILLOC(LWFIO+4*II-
     *2)  .OR. JPO .NE. ILLOC(LWFIO+4*II-1) ) GO TO 254                 
      I = NWFO-II+1                                                     
      GO TO 255                                                         
 254  CONTINUE                                                          
      I = 0                                                             
      GO TO 260                                                         
C                                                                       
C     MOVE POINTERS DOWN.                                               
C                                                                       
 255  DO 259 KWO = 1, I                                                 
      K = KWO + (NWFO-I)                                                
      ILLOC(LWFIO+4*KWO) = ILLOC(LWFIO+4*K)                             
 259  CONTINUE                                                          
C     NOW PUT THE NEW WAVE FUNCTIONS INTO THE CIRCULAR BUFFER.          
 260  I = I + 1                                                         
      DO 269 KWO = I, NWFO                                              
      LO = ILLOC(LWFIO+4*KWO-3) + LI                                    
      LASO = ILLOC(LWFIO+4*KWO-2) + LI                                  
      JPO = ILLOC(LWFIO+4*KWO-1) + 2*LI                                 
      ILLOC(LWFIO+4*KWO) = ITRK                                         
      CALL WFGET ( LO, LASO, JPO, 2, NRIROI, ALLOC4(LRO+1),  ALLOC4(LLOR
     *+ITRK+1), ALLOC4(LLOI+ITRK+1),  ALLOC(LWAVR), ALLOC(LWAVI),  ALLOC
     *(LVRL2), ALLOC(LVIM2), ALLOC(LCENT2) )                            
      ITRK=ITRK+NRIROI                                                  
      IF(ITRK.GT.NCRIT) ITRK=0                                          
 269  CONTINUE                                                          
C                                                                       
C     FOR EACH LI, WE MUST GET THE IN-CHANNEL WAVE FUNCTIONS            
C                                                                       
C                                                                       
 280  DO 289 KWI = 1, NWFI                                              
      LASI = ILLOC(LWFII+3*KWI-2) + LI                                  
      JPI = ILLOC(LWFII+3*KWI-1) + 2*LI                                 
      I = ILLOC(LWFII+3*KWI) + 1                                        
      CALL WFGET ( LI, LASI, JPI, 1, NRIROI, ALLOC4(LRI+1),  ALLOC4(LLIR
     *+I), ALLOC4(LLII+I),  ALLOC(LWAVR), ALLOC(LWAVI),  ALLOC(LVRL1), A
     *LLOC(LVIM1), ALLOC(LCENT1) )                                      
 289  CONTINUE                                                          
C                                                                       
C     WAVEFUNCTIONS ALL FOUND, WILL WE DO THIS VALUE OF LI              
C                                                                       
C                                                                       
 290  IF ( LI - ILLOC(LLIS+ILI) ) 959, 300, 295                         
 295  IF ( ILI .GE. NUMLIS ) GO TO 959                                  
      ILI = ILI + 1                                                     
      GO TO 290                                                         
C                                                                       
C     THIS IS AN LI TO DO, FIND THE A12 COEFFICENTS                     
C                                                                       
 300  CONTINUE
C                                                                       
      CALL A12 ( LI, LXMIN, LXMAX, LMIN, LMAX,  ALLOC(Z(IXLAM)), ALLOC(Z
     *(INLAM)), ALLOC(LA12VL+1),  ALLOC(LMSVAL+1),  ILLOC(LJA12S+1), JA1
     *2M, JA12N, JA12AN, ILLOC(LIINDX+1),  IHMAX, LOMNMN, LOMXMX, ALLOC(
     *LINTS+1), ALLOC(LA12T1),  ALLOC(LA12T2), ALLOC(LA12T3), LHSM1, LA1
     *2VL, IPRINT, INIA12,  ILLOC(LDWI+1), NDW, NI, ILLOC(LWFII+1),ILLOC
     *(LWFIO+1) )                                                       
      NUMHSU = IHMAX*NPSUM                                              
C                                                                       
      IF ( ( JA12M .GT. IA12M .OR. JA12N .GT. IA12N ) .AND. IHSAVE .NE. 
     *2 ) WRITE(6,303)  IA12M, JA12M, IA12N, JA12N                        
 303  FORMAT(' **** ERROR *** A12 HAS TOO MANY TERMS:', 4I8 )           
      NUMTIM = NUMTIM + 2                                               
C                                                                       
      IF ( LOMNMN .GT. LOMXMX ) GO TO 959                               
C                                                                       
C     NOW PROCEED TO THE (RI, RO) INTEGRATION LOOP                      
C                                                                       
      LHEND = LHSM1 + IHMAX                                             
      MCNT=1                                                            
      NSKIP = 0                                                         
      DWRIOS=10.0D0                                                     
      DWRIOL=0                                                          
      DWRIOC=0                                                          
      DWCONT = 0                                                        
C                                                                       
C     INITIALIZE "I1REAL", "I1IMAG" (= FULL INTEGRALS)                  
C     AND "RIROABS" (= INTEGRALS OF ABSOLUTE VALUES, OVER               
C     RI, RO) FOR THIS LI.                                              
C                                                                       
      DO 329 II = 1, NI                                                 
      ALLOC(LLILOR+II) = 0                                              
      ALLOC(LLILOI+II) = 0                                              
      ALLOC(LABS1+II) = 0                                               
 329  CONTINUE                                                          
C                                                                       
C     LOOP OVER THE V-GRID AND FOR EACH ONE DO A COMPLETE               
C     U-INTEGRAL.                                                       
C                                                                       
      DO 859 IV = 1, NPDIF                                              
C                                                                       
C                                                                       
C     GET THE H'S FOR INTERPOLATION INPUT                               
C                                                                       
C     INDEX TO THE H'S FILE                                             
C                                                                       
      LIIP = 1000*( 1000*LIPRTY + LI ) + IV                             
      IF ( IHSAVE .EQ. 2 ) GO TO 560                                    
C                                                                       
C     LOOP OVER U-VALUES AND COMPUTE THE H'S                            
C                                                                       
      IPLUNK = NPSUM*(IV-1)                                             
      DO 549 IU = 1, NPSUM                                              
C                                                                       
      IPLUNK = IPLUNK+1                                                 
C                                                                       
      DO 409 IH = 1, IHMAX                                              
      SALLOC(LHSM1+IH) = 0                                              
      ALLOC(LHINT+IH) = 0                                               
      ALLOC(LHABS+IH) = 0                                               
 409  CONTINUE                                                          
      IF ( ISCRFL .EQ. 0 ) GO TO 420                                    
      CALL READSC ( NPPHI, ALLOC4(LPHI+1), ALLOC4(LPHIP+1),  ALLOC4(LPHI
     *T+1), ALLOC4(LTRP+1), &9960 )                                     
CNV      READ ( 2, END=9960, ERR=9960 )                                 
CNV     1   ( ALLOC4(LPHI+II), II = 1, NPPHI ),                         
CNV     2   ( ALLOC4(LPHIP+II), II = 1, NPPHI ),                        
CNV     3   ( ALLOC4(LPHIT+II), II = 1, NPPHI ),                        
CNV     4   ( ALLOC4(LTRP+II), II = 1, NPPHI )                          
      MCNT = 1                                                          
C                                                                       
C                                                                       
C     THE DX INTEGRAL  (AT LAST)                                        
C                                                                       
C                                                                       
 420  DO 489 II=1,NPPHI                                                 
C                                                                       
      PHI = ALLOC4(LPHI+MCNT)                                           
      KMEND = LMSVAL + JA12M                                            
      PHIP = ALLOC4(LPHIP+MCNT)                                         
      ARG = PHI+PHI                                                     
      PHIT =ALLOC4(LPHIT+MCNT)                                          
      PVPDX = ALLOC4(LTRP+MCNT)                                         
      JA12OF = LJA12S - LMSVAL + 1                                      
C                                                                       
C     FOLLOWING IS THE HIGH SPEED INLINE COSINE AND SINE(ARG)           
C     FOR THIS CASE   ARG = 2*PHI    AND WE ARE FINDING COS(2PHI)       
C     AND SIN(2PHI) WHICH WE USE IN THE RECURSION TO N*PHI              
C                                                                       
CIB      DNN = ARG*STPINV + HOLD                                        
CIB      NN = LAND( NN4, MSKCOS )                                       
CIB      IRNN = LAND( NN4, MASK8 )                                      
      RNN=AINT(ARG*STPINV+.5)                                           
      NN=RNN                                                            
      NN = MOD(NN, NCOSIN)                                              
      DELTAC = ARG - RNN*COSSTP                                         
      S2PHI = ( (1+HAFNEG*DELTAC**2)*ALLOC(LCOSIN+IABS(NN-ICOSS4))  + DE
     *LTAC*ALLOC(LCOSIN+NN) )                                           
      C2PHI = (1+HAFNEG*DELTAC**2)*ALLOC(LCOSIN+NN)  - DELTAC*ALLOC(LCOS
     *IN+IABS(NN-ICOSS4))                                               
CDC      S2PHI = SIN(ARG)                                               
CDC      C2PHI = COS(ARG)                                               
C                                                                       
C     THE COSINE AND SINE(ARG) HAS BEEN FOUND                           
      S2PHI2 = S2PHI**2                                                 
C                                                                       
C     LOOP OVER TERMS IN A12                                            
C                                                                       
      DO 479 KA12M = LMSVAL, KMEND, 5                                   
C                                                                       
C     THE MAGIC ANGLE FOR THE FIRST VALUE OF MU-2                       
C     WE ADD 256*PI TO FORCE IT POSITIVE                                
C                                                                       
      ARG = PI256 + ALLOC(KA12M+1) * PHIT + ALLOC(KA12M+2) * PHIP  - ALL
     *OC(KA12M+3) * PHI                                                 
C                                                                       
      LA12OF = ILLOC(JA12OF+KA12M)                                      
C                                                                       
C     FOLLOWING IS THE HIGH SPEED INLINE COSINE AND SINE(ARG)           
C                                                                       
      NUMMU = ILLOC(JA12OF+KA12M+1)                                     
CIB      DNN = ARG*STPINV + HOLD                                        
CIB      NN = LAND( NN4, MSKCOS )                                       
CIB      IRNN = LAND( NN4, MASK8 )                                      
      RNN=AINT(ARG*STPINV+.5)                                           
      NN=RNN                                                            
      NN = MOD(NN, NCOSIN)                                              
      DELTAC = ARG - RNN*COSSTP                                         
C                                                                       
C     COSTHE = COS(MT*PHIT+MP*PHIP-MU*PHI)                              
C     SINSIN = SIN(MT*PHIT+MP*PHIP-MU*PHI) * SIN(2*PHI)                 
C                                                                       
      COSTHE = (1+HAFNEG*DELTAC**2)*ALLOC(LCOSIN+NN)  - DELTAC*ALLOC(LCO
     *SIN+IABS(NN-ICOSS4))                                              
      SINSIN = ( (1+HAFNEG*DELTAC**2)*ALLOC(LCOSIN+IABS(NN-ICOSS4))  + D
     *ELTAC*ALLOC(LCOSIN+NN) ) * S2PHI                                  
CDC      COSTHE = COS(ARG)                                              
CDC      SINSIN = SIN(ARG) * S2PHI                                      
C                                                                       
C     THE COSINE AND SINE(ARG) HAS BEEN FOUND                           
C                                                                       
      LHSTRT = ILLOC(JA12OF+KA12M+2)                                    
      COSTHE = PVPDX*COSTHE                                             
      NUMIH = ILLOC(JA12OF+KA12M+3)                                     
      SINSIN = PVPDX*SINSIN                                             
C                                                                       
C     FOLLOWING IS THE INNERMOST AND INNERMOST INNERMOST LOOP.          
C     WE DO ALL THE MU'S HERE.                                          
C     EACH ONE IS 2 GREATER THAN THE PREVIOUS, SO THETA IS DECREMENTED  
C     BY 2PHI AND COS(THETA) IS FOUND ITERATIVELY.                      
C                                                                       
CNV      CALL SETLOP ( LA12OF, LHSTRT, COSTHE, LHEND, NUMIH, C2PHI,     
CNV     1  NUMMU, SINSIN, 8, S2PHI2, ALLOC, SALLOC )                    
C                                                                       
      DO 469 NMU = 1, NUMMU                                             
      COSNEW = COSTHE*C2PHI + SINSIN                                    
      SINSIN = SINSIN*C2PHI - COSTHE*S2PHI2                             
      COSTHE = COSNEW                                                   
C                                                                       
C     LOOP OVER ALL (LX, LO) PAIRS FOR THIS LI                          
      DO 459 LH = LHSTRT, LHEND                                         
      SALLOC(LH) = SALLOC(LH) + COSNEW*ALLOC(LA12OF+LH)                 
 459  CONTINUE                                                          
      LA12OF = LA12OF + NUMIH                                           
 469  CONTINUE                                                          
C                                                                       
CNV      CALL SETLOP ( LA12OF, LHSTRT, COSTHE, LHEND, NUMIH, C2PHI,     
CNV     1  NUMMU, SINSIN, 8, S2PHI2, ALLOC, SALLOC )                    
C                                                                       
C                                                                       
 479  CONTINUE                                                          
C                                                                       
C     END OF LOOP OVER A12 TERMS                                        
C                                                                       
      MCNT = MCNT + 1                                                   
C                                                                       
C     ACCUMULATE THE DESIRED INTEGRAL IN  LHINT  AND THE INTEGRAL       
C     OF  INTEGRAND  IN  LHABS.  THE LATTER IS USED FOR CHECKS ON       
C     LOSS OF SIGNIFICANCE                                              
C                                                                       
      DO 485 IH = 1, IHMAX                                              
      ALLOC(LHINT+IH) = ALLOC(LHINT+IH) + SALLOC(LHSM1+IH)              
      ALLOC(LHABS+IH) = ALLOC(LHABS+IH) + DABS(SALLOC(LHSM1+IH))        
      SALLOC(LHSM1+IH) = 0                                              
 485  CONTINUE                                                          
C                                                                       
 489  CONTINUE                                                          
C                                                                       
C     END OF DX INTEGRAL TERMS                                          
C                                                                       
C                                                                       
      XNUMTRM = XNUMTRM + JA12N
      XNUMANG = XNUMANG + JA12AN
      NUM3 = NUM3 + JA12M 
      NUM4 = NUM4 + 1  
C                                                                       
C     STORE THE H'S WITH THE FACTOR                                     
C        EXP( -ALPHAP*RP - ALPHAT*RT )                                  
C     REMOVED IN THE INTERPOLATION INPUT ARRAY                          
C                                                                       
      DO 509 IH = 1, IHMAX                                              
      ALLOC(LSMHVL+IU+NPSUM*(IH-1)) = ALLOC(LHINT+IH)  * ALLOC(LRIOEX+IP
     *LUNK)                                                             
 509  CONTINUE                                                          
C                                                                       
      IF ( IPRNT .GE. 9 ) WRITE(6,513) LIIP,IPLUNK,(ALLOC(LHINT+IH), I
     *H = 1, IHMAX )                                                    
 513  FORMAT ( ' CMPTED:', I9, I5, ( T23, 7G14.5 ) )                    
C                                                                       
 549  CONTINUE                                                          
C                                                                       
C     END OF LOOP ON U                                                  
C                                                                       
      NUMTIM = NUMTIM + 2                                               
C                                                                       
C     SAVE H'S NOW                                                      
C                                                                       
      IF ( IHSAVE .EQ. 1 ) CALL WRITHS ( NUMHSU, LIIP,  ALLOC(LSMHVL+1),
     * &9950 )                                                          
CNV      IF ( IHSAVE .EQ. 1 )  WRITE ( 1, ERR=9950 )                    
CNV     1  LIIP, ( ALLOC(LSMHVL+I), I = 1, NUMHSU )                     
C                                                                       
      GO TO 590                                                         
C                                                                       
C     HERE WE READ SAVED H'S.  MAKE SURE WE DO NOT GET OUT OF           
C     SYNCHRONIZATION.                                                  
C                                                                       
 560  CALL READHS ( NUMHSU, LIIPH, ALLOC(LSMHVL+1), &9950 )             
CNV 560  READ ( 1, END=9950, ERR=9950 )                                 
CNV     1  LIIPH, ( ALLOC(LSMHVL+I), I = 1, NUMHSU )                    
      IF ( LIIPH .EQ. LIIP ) GO TO 590                                  
      IF ( LIIPH .LT. LIIP ) GO TO 560                                  
      WRITE(6,563) LIIP, LIIPH                                            
 563  FORMAT ( '0**** SYNCHRONIZATION ERROR:', 2I12 )                   
      GO TO 9950                                                        
C                                                                       
 590  NUM5 = NUM5 + NPSUM                                               
      NUM6 = NUM6 + NUMHSU                                              
C                                                                       
C                                                                       
C     NOW INTERPOLATE                                                   
C                                                                       
      DO 609 IH = 1, IHMAX                                              
      ITEMP = LSMHVL+1 + (IH-1)*NPSUM                                   
      CALL SPLNCB ( NPSUM, ALLOC(LSMHPT), ALLOC(ITEMP),  ALLOC(LSMHWK), 
     *ALLOC(LSMHWK+NPSUM), ALLOC(LSMHWK+2*NPSUM) )                      
      CALL INTRPC ( NPSUM, ALLOC(LSMHPT), ALLOC(ITEMP),  ALLOC(LSMHWK), 
     *ALLOC(LSMHWK+NPSUM), ALLOC(LSMHWK+2*NPSUM),  NPSUMI, ALLOC(LSMIPT)
     *, ALLOC(LSMIVL+1+(IH-1)*NPSUMI) )                                 
      NUMHIN = NUMHIN + NPSUMI                                          
 609  CONTINUE                                                          
      NUMTIM = NUMTIM + 2                                               
C                                                                       
C     NOW DO INTEGRAL DU FOR FIXED V.                                   
C                                                                       
      IPLUNK = NPSUMI*(IV-1)                                            
      DO 789 IU = 1, NPSUMI                                             
      IPLUNK = IPLUNK + 1                                               
C                                                                       
C        COMPUTE IMAG AND REAL PARTS OF PRODUCT OF THE DISTORTED        
C        SCATTERING WAVES.                                              
C                                                                       
      DWMAX = 0                                                         
      DO 739 KDW = 1, NDW                                               
      I = ILLOC(LDWI+4*KDW-1) + IPLUNK                                  
      FIR = ALLOC4(LLIR+I)                                              
      FII = ALLOC4(LLII+I)                                              
      I = ILLOC(LDWI+4*KDW) + IPLUNK                                    
      FOR = ALLOC4(LLOR+I)                                              
      FOI = ALLOC4(LLOI+I)                                              
      DWR=FOR*FIR-FOI*FII                                               
      DWI=FOR*FII+FOI*FIR                                               
      DWLIM=DMAX1(DABS(DWR),DABS(DWI))                                  
      IF(DWLIM.GT.DWRIOL) DWRIOL=DWLIM                                  
      IF((DWLIM.LT.DWRIOS).AND.(DWLIM.NE.0)) DWRIOS=DWLIM               
      DWRIOC=DWRIOC+DWLIM                                               
      DWMAX = DMAX1( DWMAX, DWLIM )                                     
      ALLOC(LDW+2*KDW-1) = DWR                                          
      ALLOC(LDW+2*KDW) = DWI                                            
      DWCONT = DWCONT + 1                                               
 739  CONTINUE                                                          
C                                                                       
C        SKIP THE NEXT PART IF ALL DISTORTED-WAVE PRODUCTS ARE SMALL.   
C                                                                       
      IF ( DWMAX .LT. 1.D-30 ) GO TO 780                                
C                                                                       
      TERM = ALLOC4(LWIO+IPLUNK)                                        
C                                                                       
C                                                                       
C        NOW ADD THESE H'S INTO THE APPROPRIATE I(JO,JI,LO,LX)          
C        ALONG WITH THE PRODUCT OF THE DISTORTED WAVES                  
C                                                                       
      DO 779 II = 1, NI                                                 
      ITEMP = ILLOC(LIINDX+4*II-3) + IU                                 
      KDW = ILLOC(LIINDX+4*II-2)                                        
      ALLOC(LLILOR+II) = ALLOC(LLILOR+II)  + TERM*ALLOC(ITEMP)*ALLOC(KDW
     *-1)                                                               
      ALLOC(LLILOI+II) = ALLOC(LLILOI+II)  + TERM*ALLOC(ITEMP)*ALLOC(KDW
     *)                                                                 
C                                                                       
C        COMPUTE AN INDICATION OF LOSS OF SIGNIFICANCE:                 
C           "RIROABS" = INTEGRAL(RI,RO)  \ INTEGRAL(PHI) INTEGRAND \    
C                                                                       
      IF ( PINFSW ) ALLOC(LABS1+II) = ALLOC(LABS1+II)  + DABS(TERM*ALLOC
     *(ITEMP))  * ( DABS(ALLOC(KDW-1)) + DABS(ALLOC(KDW)) )             
 779  CONTINUE                                                          
C                                                                       
C                                                                       
      GO TO 789                                                         
C                                                                       
C        WE COME HERE WHEN SKIPPING I CALCULATION DUE TO THE PRODUCT    
C        OF THE DISTORTED WAVES BEING SMALL.                            
C                                                                       
 780  NSKIP = NSKIP + 1                                                 
C                                                                       
C                                                                       
 789  CONTINUE                                                          
 859  CONTINUE                                                          
C                                                                       
      NUMTIM = NUMTIM + 2                                               
C                                                                       
C     END OF (RI,RO) INTEGRATION                                        
C                                                                       
      DWRIOC=DWRIOC/DWCONT                                              
      IF (PBUGSW) WRITE(6, 863)DWRIOS,DWRIOL,DWRIOC                     
 863  FORMAT(' SMALLEST, LARGEST AND AVERAGE DABS(DWRIRO)=', 3G15.5 / ) 
C                                                                       
C                                                                       
C     SUBROUTINE SFROMI CALCULATES S-MATRIX ELEMENTS FROM THE           
C     RADIAL INTEGRALS.                                                 
C                                                                       
      CALL SFROMI ( LI, ILI, ALLOC(Z(ISMATR)), ALLOC(Z(ISMATI)),  ILLOC(
     *LINDXS+1), ALLOC(LLILOR+1), ALLOC(LLILOI+1),  ILLOC(LIINDX+1), NI,
     * ILLOC(LDWI+1), ILLOC(LWFII+1),  ILLOC(LWFIO+1), ALLOC(LABS1+1), A
     *LLOC(LATERM),  FACTOR, PINFSW, NLINE )                            
C                                                                       
      IF ( IHSAVE .EQ. 2 ) GO TO 955                                    
C                                                                       
      IF ( ISCRFL .NE. 0 ) REWIND 2                                     
      IF ( MCNT-1 .GT.MAXCNT )  WRITE(6,923) MCNT, MAXCNT                 
 923  FORMAT (' **** ERROR ****  PHI COUNTS MESSED UP:', 5I10 )         
      I = LHSTRT+LA12OF - LA12VL - 1                                    
      IF ( I .NE. JA12N ) WRITE(6,933) I, JA12N,  LI, JA12M, IHMAX, LHSTRT
     *, LA12OF, LA12VL                                                  
 933  FORMAT (' ******* A12 COUNTS MESSED UP:', 8I10 )                  
C                                                                       
C     FOR VAX/VMS, START THE PAGE-FAULT COUNT AFTER THE FIRST L.        
C                                                                       
 955  CONTINUE                                                          
CVMS      IF ( FIRSTL ) NPAGF = NPFAUL( 0 )                                 
      FIRSTL = .FALSE.                                                  
C                                                                       
C                                                                       
 959  CONTINUE                                                          
C                                                                       
C     END OF THE LI LOOP FOR A GIVEN PARITY OF LI                       
C     IF LI IS EVEN HAVE ANOTHER BASH AT LI LOOP WITH ODD LI            
C                                                                       
 980  LIMIN=LIL                                                         
 989  CONTINUE                                                          
C                                                                       
C                                                                       
C     VAX/VMS:  PRINT THE NUMBER OF PAGE FAULTS SINCE THE FIRST L.      
C                                                                       
CVMS      NPAGF = NPFAUL( NPAGF )                                           
CVMS      WRITE(6,993) NPAGF                                                  
CVMS 993  FORMAT ( ' THERE HAVE BEEN', I8,  ' PAGE FAULTS SINCE THE FIRST L.
CVMS     *' )                                                               
C                                                                       
C     END OF THE 2 LI LOOPS (EVEN AND ODD PARITY OF LI)                 
C                                                                       
C     IF NECESSARY, CLEAN UP AFTER SAVEHS/USEHS                         
C                                                                       
      IF ( IHSAVE-1 ) 2000, 1600, 1700                                  
C                                                                       
C     WRITE A DUMMY RECORD AT THE END                                   
C                                                                       
 1600 LIIP = 300000000                                                  
      CALL WRITHS ( NUMHS, LIIP, ALLOC(LSMHVL+1), &9950 )               
CNV      WRITE ( 1, ERR=9950 )                                          
CNV     1  LIIP, ( ALLOC(LSMHVL+I), I = 1, NUMHS )                      
      GO TO 1780                                                        
C                                                                       
C                                                                       
C     FOR A MULTIPASS, USEHS RUN, READ PAST THE DUMMY RECORD.           
C                                                                       
 1700 IF ( IBSPAS .EQ. 0 ) GO TO 1780                                   
 1720 IF ( LIIPH .EQ. 300000000 ) GO TO 1780                            
      CALL READHS ( 1, LIIPH, DUMMY, &1780 )                            
CNV      READ ( 1, ERR=9950, END=1780 ) LIIPH                           
      GO TO 1720                                                        
C                                                                       
 1780 CONTINUE                                                          
C                                                                       
C                                                                       
C                                                                       
C     A L L    D O N E                                                  
C                                                                       
 2000 IRTN = 1                                                          
C                                                                       
      CALL INELD2 (TSTART,NUMHIN,NUMTIM,XNUMTRM,XNUMANG,NUM3,NUM4,
     * NUM5, NUM6 )                                                     
C                                                                       
      RETURN                                                            
C                                                                       
 9950 WRITE(6,9953)                                                        
 9953 FORMAT ( '0**** ERROR IN READING OR WRITING H  S FILE.' )         
      RETURN                                                            
C                                                                       
 9960 WRITE(6,9963)                                                        
 9963 FORMAT ( '0**** ERROR IN READING SCRATCH FILE (UNIT 2).' )        
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE INELD2 (TSTART,NUMHIN,NUMTIM,XNUMTRM,XNUMANG,NUM3,
     * NUM4, NUM5, NUM6 )                                               
C                                                                       
C     FINISH-UP INELDC - FREE AREAS AND PRINT TIMING                    
C                                                                       
C     2/11/76 - SPLIT OFF FROM INELDC - S.P.                            
C     5/29/76 - INTERPOLATION TIMES                                     
C     6/26/78 - LI AND LO INTERCHANGED                                  
C     6/6/79 - REMOVE IABS2, DEALLOCATE NEW AREAS USED FOR              
C        S.O. AND TENSOR DISTORTIONS ETC. - RPG                         
C     6/8/79 - STANDARD PREFIXES - RPG                                  
C     7/21/79 - ADD /SWITCH, KEEP SCATTERING AREAS FOR MULTIPASS - RPG  
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) )                                                          
      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                                                                 
      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 )                                
      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*4 TBEGIN, TIMES                                              
      COMMON /FTIME/ TBEGIN, NUMLOP, NUMWAV, TIMES(8)                   
C                                                                       
      LOGICAL FREESW                                                    
C                                                                       
      FREESW = MOD( IPRINT/100, 10 ) .EQ. 0                             
C                                                                       
C     FREE WORK ARRAYS CREATED FOR INELDC AND WAVELJ                    
C                                                                       
      IF ( .NOT. FREESW ) GO TO 1500                                    
      IF ( IHSAVE .EQ. 2 ) GO TO 995                                    
C                                                                       
C     FIRST THE AREAS THAT ARE NOT MADE FOR USEHS RUNS                  
C                                                                       
      Z(IHS) = -Z(IHS)                                                  
      Z(IHINT) = -Z(IHINT)                                              
      Z(IHABS) = -Z(IHABS)                                              
      Z(IPHI) = -Z(IPHI)                                                
      Z(IPHIP) = -Z(IPHIP)                                              
      Z(IPHIT) = -Z(IPHIT)                                              
      Z(LOCTRP) = -Z(LOCTRP)                                            
      Z(IA12VL) = -Z(IA12VL)                                            
      Z(IMSVAL) = -Z(IMSVAL)                                            
      Z(IJA12S) = -Z(IJA12S)                                            
      Z(IINTS) = -Z(IINTS)                                              
      Z(IA12TM) = -Z(IA12TM)                                            
      Z(ICOSIN) = -Z(ICOSIN)                                            
      Z(IXLAM) = -Z(IXLAM)                                              
      Z(INLAM) = -Z(INLAM)                                              
      Z(IRIOEX) = -Z(IRIOEX)                                            
C                                                                       
C     FREE AREAS USED IN ALL CALCULATIONS                               
C                                                                       
 995  Z(IRI) = -Z(IRI)                                                  
      Z(IRO) = -Z(IRO)                                                  
      Z(ILOR) = -Z(ILOR)                                                
      Z(ILOI) = -Z(ILOI)                                                
      Z(ILIR) = -Z(ILIR)                                                
      Z(ILII) = -Z(ILII)                                                
      Z(IWIO) = -Z(IWIO)                                                
      Z(ISMHPT) = -Z(ISMHPT)                                            
      Z(ISMIPT) = -Z(ISMIPT)                                            
      Z(ISMHVL) = -Z(ISMHVL)                                            
      Z(ISMIVL) = -Z(ISMIVL)                                            
      Z(ISMHWK) = -Z(ISMHWK)                                            
C                                                                       
      Z(LOGIC) = -Z(LOGIC)                                              
      Z(IDW) = -Z(IDW)                                                  
      Z(IABS1) = -Z(IABS1)                                              
      Z(ILILOR) = -Z(ILILOR)                                            
      Z(ILILOI) = -Z(ILILOI)                                            
      Z(IIINDX) = -Z(IIINDX)                                            
      Z(IDWI) = -Z(IDWI)                                                
      Z(IWFII) = -Z(IWFII)                                              
      Z(IWFIO) = -Z(IWFIO)                                              
C                                                                       
C     AREAS FOR WAVELJ, WAVETC - ONE FOR INCOMING AND ONE FOR OUTGOING  
C                                                                       
C     KEEP THESE FOR MULTIPASS CALCULATIONS.                            
C                                                                       
      IF ( IBSPAS .GT. 0 ) GO TO 1500                                   
      DO 1099 I = 1, 2                                                  
      Z(NFS(I)) = -Z(NFS(I))                                            
      Z(NGS(I)) = -Z(NGS(I))                                            
      Z(NF1S(I)) = -Z(NF1S(I))                                          
      Z(NG1S(I)) = -Z(NG1S(I))                                          
      Z(IRLVS(I)) = -Z(IRLVS(I))                                        
      Z(IIMVS(I)) = -Z(IIMVS(I))                                        
      Z(ICENTR(I)) = -Z(ICENTR(I))                                      
      IF ( V0SORS(I) .NE. 0 ) Z(ISORS(I)) = -Z(ISORS(I))                
      IF ( V0SOIS(I) .NE. 0 ) Z(ISOIS(I)) = -Z(ISOIS(I))                
      DO 1059 ITEN = 1, 6                                               
      IF ( VTENS(I,ITEN) .NE. 0 )  Z(ITENS(I,ITEN)) = -Z(ITENS(I,ITEN)) 
 1059 CONTINUE                                                          
      IF ( TCSWS(I) ) Z(IWAVRS(I)) = -Z(IWAVRS(I))                      
      IF ( TCSWS(I) ) Z(IWAVIS(I)) = -Z(IWAVIS(I))                      
 1099 CONTINUE                                                          
      Z(IWAVR) = -Z(IWAVR)                                              
      Z(IWAVI) = -Z(IWAVI)                                              
C                                                                       
C     PRINT SOME TIMING INFO.                                           
C                                                                       
C     BEFORE WE START MESSING AROUND HERE:                              
C     I  TIMES(I)                                                       
C     1  WAVELJ INITIALIZATION                                          
C     2  WAVELJ LOOP                                                    
C     3  WAVELJ INTERPOLATION AND NORMALIZATIONS                        
C     4  A12                                                            
C     5  PHI, A12 AND FIRST U LOOPS                                     
C     6  H-INTERPOLATIONS                                               
C     7  COMPLETE V-LOOP WITH ALL INTERNALS (5 & 6)                     
C     8  COMPLETE LO-LOOP WITH ALL INTERNALS (1, 2, 3, 4, & 7)          
C                                                                       
 1500 CONTINUE
      RETURN                                                            
      END                                                               

      SUBROUTINE INGRST ( IRET )                                        
C                                                                       
C     INITIALIZES THE GRID FOR THE INELASTIC SCATTERING RADIAL INTEGRAL 
C                                                                       
C     THIS ROUTINE IS CALLED BY MAIN.  IT SETS UP THE ONE-DIMENSIONAL   
C     GRID AND POTENTIAL VALUES FOR INRDIN.                             
C                                                                       
C     1/77 - FIRST VERSION - S.P.                                       
C     11/22/77 - NEW SCTASYOPIA - S.P.                                  
C     12/4/77 - LINKULES - S.P.                                         
C     5/7/78 - STUFF TO ALLOW 2 COUPLED STATES - S.P.                   
C     5/23/78 - FIX BUG IN 11/22/77 - ALWAYS DEFINE VWORK - S.P.        
C               BIGGER WAVR, WAVI ARRAYS FOR NEW WAVELJ - S.P.          
C     3/12/79 - CLEAN UP DEF OF SUMMAX, NSTEPS; DEFINE MORE FOR LINKULES
C     12/20/79 - INELASTIC NAMES INPLACE OF TRANSFER NAMES - S.P.       
C                START OF FULL COUPLED CHANNELS CHANGES - S.P.          
C      1/2/80 PUT IN FULL COUPLED CHANNELS FOR ROTATIONAL MODEL         
C            UP TO 2 ORDER M.R.B.                                       
C     3/18/80 - FIX BUG IN FREEING ITEMP - S.P.                         
C     4/27/80 - GET NPTMIN, FREE UNNEEDED ARRAYS FOR C.C. - S.P.        
C     4/28/80 - REASSIGN LRPTS AFTER GIVALL - S.P.                      
C     6/24/80 - SAVE RC IN RCUEFF - S.P.                                

C     7/9/80 - FIX BUG IN FREEING COULH, DON'T OVERFLOW AREA            
C              RETURNED BY GIVEAL - S.P.                                
C     8/25/80 - FIX TYPING ERROR AT STMNT 820 - S.P.                    
C     12/9/80 - MAKPOT NOLONGER COMPUTES COULOMB; DON'T                 
C               DEFINE COULOMB COUPLING FOR BETAC=0 - S.P.              
C     12/30/80 - FIX ERRORS IN 2ND ORDER NUCLEAR - S.P.                 
C     1/11/81 - ALWAYS 1/R**(LX+1); NO MORE COUPL2 - S.P.               
C     7/13/81 - FIX BUG FROM 1/11/81 (JUMPSZ) - S.P.                    
C     7/16/81 - SAVE LNKBLK TO ALLOW FORM-FACTOR CHANGES - S.P.         
C     7/29/81 - FIRST CRUDE STUFF FOR DEFORMED POTENTIALS - S.P.        
C     8/28/81 - MORE FOR DEFORMED POTENTIALS - S.P.                     
C     9/21/81 - DON'T LOOK WHEN THERE ARE NO POTENTIALS - S.P.          
C     10/16/81 - DONT' CONDISDER LXTOT FOR MUTUAL - S.P.                
C     12/14/18 - LET GETSCT GET WAVEFUNC ALSO FOR C.C. - S.P.           
C     4/14/82 - FORMASIS ALSO WORKS FOR DWBA - 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 /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 /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
      COMMON /GRIDCM/ RCUEFF, GRDCM1(2), IBINDX, MBINDX, NBINDX, NMFFAC,
     * MXLXGS, NMBFAC, IINHR, IINHI, IRHSR, IRHSI, INUCH, ICOULH, ILOR, 
     *ILOI, ILIR, ILII, NPTMIN, NOFLO, NUMPT, NCRIT, ISMX, ISMSQ, IPADE,
     * IHOMO, ISMTSV, IRPTS4, IRPTS, IGRDC4(5), IDW, IGRDC5(2), IABS1, I
     *GRDC6(2), GRDCM2, IGRDC7(2), IRWTS, IGRDC8(2), ICL1FF, ICL1FG, ICL
     *1GF, ICL1GG                                                       
      LOGICAL ONELSW, IDENSW                                            
      COMMON /INELCM/ JBPF,JBTF,LXMIN,LXMAX,ILILOR,ILILOI,MSTOP,IA12M, 
     *NMLOLX,ONELSW,NUMLX,IRDINT,IELCUP,LILOSZ,NUMLIS,ILIS,IBETAS(4), 
     *ICL2FF,LXSTEP,IDENSW,LSKIP,JPMIN,JPMAX,JPBASE,NJP,JTMIN,JTMAX, 
     *JTBASE,NJT,IINDXS,ISMATR,ISMATI,NSMAT,NLX,NSPLI,ITOCS,NASPLI, 
     *IUNITR,LIFIT,ILIFIT,NOLFIT,IDELSR,IDELSI
      INTEGER INDXJS(4,2)                                               
      EQUIVALENCE ( INDXJS(1,1), JPMIN )                                
      COMMON /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      COMMON /FORMF/ IBDS(2), NPOTS(2), LBP, LBT, NBP, NBT, JBP, JBT, BN
     *DMAX(2), BNDSTP(2), NSTPBD(2), RBNDS(2), ABNDS(2), RCBNDS(2), BNDM
     *AS(2), BRATMS(2), RSOBDS(2), ASOBDS(2), VBNDS(2), VSOBDS(2), TAUBD
     *S(2), LNKADB(6,2,12)                                              
      DIMENSION R2S(4)                                                  
      EQUIVALENCE ( R2S(1), RBNDS(1) )                                  
C                                                                       
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
      COMMON / TEMPVS / TVR, TVI, TVSOR, TVSOI, TAR, TAI                
      COMMON/NAMCOM/ANAMES(1)                                           
C                                                                       
      REAL*8 POTTYP(5)                                                  
      DATA POTTYP/'    REAL', 'IMAGINAR', ' REAL SO', ' IMAG SO', 
     *' COULOMB'/                                                             
      LOGICAL*1 LINKID(4)                                               
      DATA LINKID/'*', '3', '0', '0'/                                   
C                                                                       
      LOGICAL IMAGSW, SOSW, SOISW, DRIVSW, DBUGSW                       
      LOGICAL CCSW                                                      
      REAL*4 FG(4)                                                      
      INTEGER GIVEAL,CHOPIT                                             
C                                                                       
      IRET = 0                                                          
      IPRT = MOD( IPRINT, 10 )                                          
      DBUGSW = IPRT .GE. 4                                              
      CCSW = PROBLM .EQ. 24                                             
C                                                                       
      I = 1                                                             
      IF ( CCSW ) GO TO 150                                             
C                                                                       
C     FIND WHERE LMIN SCATTERING WAVE EXCEEDS 1E-15                     
C                                                                       
 110  NSTEPS = NSTPSS(1)                                                
      LSCTMN = Z(ISCTMN)                                                
      DO 129 I = 1, NSTEPS                                              
      IF ( DABS(ALLOC(LSCTMN+I)) .GT. 1.D-15 ) GO TO 140                
 129  CONTINUE                                                          
      WRITE(6,133)                                                         
 133  FORMAT ( '0**** ERROR:  U(LMIN) < 1E-15 EVERYWHERE.' )            
      RETURN                                                            
C                                                                       
C     USE THIS AS THE LOWER POINT OF THE INTEGRAL, EXCEPT FOR C.C.      
C                                                                       
 140  Z(ISCTMN) = -Z(ISCTMN)                                            
      Z(ISCTCR) = -Z(ISCTCR)                                            
      GO TO 160                                                         
C                                                                       
C     FOR C.C. WE START AT NFIRST OF THE LOWEST L.                      
C                                                                       
 150  I = MAX0( 1, LASTNF(1)-5 )                                        
C                                                                       
 160  IF ( SUMMIN .EQ. UNDEF ) SUMMIN = RSTEPS(1)*(I-1)                 
      NPTMIN = SUMMIN/RSTEPS(1) + 0.5                                   
      IF ( SUMMAX .EQ. UNDEF ) SUMMAX = SCTASY                          
      IF ( CCSW ) SUMMAX = ASYMPS(1)                                    
      IF ( SUMMID .EQ. UNDEF ) SUMMID = .5*(SUMMIN+SUMMAX)              
C                                                                       
C     NUMBER OF GAUSS POINTS IS DETERMINED FROM SUMPTSPER,              
C     EXCEPT FOR C.C. IT IS NUMBER OF INCOMING STEPS                    
C                                                                       
      NUMPT = (SUMMAX-SUMMIN) * ( SUMPTS*(AKI+AKO)/(4*PI) )             
      NUMPT = MAX0( NUMPT, NPSUM )                                      
      NMPTSV = NUMPT                                                    
      IF ( CCSW ) NUMPT = NSTPSS(1) + 1                                 
      IF ( CCSW ) NMPTSV = NUMPT-NPTMIN                                 
      RMAXS(1) = SUMMAX                                                 
      RMAXS(2) = SUMMAX                                                 
C                                                                       
C     MAY HAVE TO REDEFINE WAVELJ WORK AREAS                            
C                                                                       
      I = SUMMAX/RSTEPS(1) + .5                                         
      NSTP2S(1) = MAX0( I, NSTP2S(1) )                                  
      I = SUMMAX/RSTEPS(2) + .5                                         
      NSTP2S(2) = MAX0( I, NSTP2S(2) )                                  
      I = MAX0( NSTP2S(1), NSTP2S(2) )                                  
      IF ( I .LE. MAX0( NSTPSS(1), NSTPSS(2) ) ) GO TO 200              
      IWAVR = NALLOC( I+6, 'WAVER ' )                                   
      IWAVI = NALLOC( I+6, 'WAVEI ' )                                   
C                                                                       
C     THE ARRAYS WILL BE:                                               
C       IRPTS, IRWTS - GAUSS POINTS  AND WEIGHTS                        
C       IRPTS4 - REAL*4 GAUSS POINTS FOR WAVELJ INTERPOLATOR            
C       INUCH - COMPLEX NUCLEAR POTENTIAL PART OF H WITH R'S AND GAUSS  
C             WEIGHT BUT NO BETA.                                       
C       ICOULH - COULOMB PART OF H WITH RC AND GAUSS WEIGHT BUT NO BETAS
C                                                                       
 200  IF ( CCSW ) GO TO 210                                             
      IRPTS = NALLOC( NUMPT, 'RPTS ' )                                  
      IRWTS = NALLOC( NUMPT, 'RWTS ' )                                  
      IRPTS4 = NALLOC( (NUMPT+FACFR4-1)/FACFR4, 'RPTS4 ' )              
      INUCH = NALLOC( 2*NUMPT, 'NUCH ' )                                
      ICOULH = NALLOC( NUMPT, 'COULH ' )                                
      IFIRST = 1                                                        
      GO TO 300                                                         
C                                                                       
C     DEFINE NUCLEAR AND COULOMB H-ARRAYS (RADIAL PART)                 
C     FOR COUPLED CHANNELS.                                             
C                                                                       
C     DETERMIN HOW MANY DIFFERENT RADIAL FORMS WILL BE NEEDED           
C     AND SET UP THE POINTERS FOR THE NUCLEAR FORM FACTORS              
C                                                                       
 210  LBASCP=FACFR4*Z(IBASCP)-FACFR4+1                                  
      NBASCP=ILLOC(LBASCP)                                              
      MBASCP=ILLOC(LBASCP+1)                                            
      LBASCP=ILLOC(LBASCP+2)+LBASCP                                     
      NNUCFF = 0                                                        
      IFIRST = 0                                                        
      ISECND = 0                                                        
      DO 229 I = 1, NBASCP                                              
      K = LBASCP + (I-1)*MBASCP                                         
      IF ( ALLOC4(K+4) .NE. 0 ) GO TO 215                               
      ILLOC(K+9) = 0                                                    
      GO TO 229                                                         
 215  IPT = ILLOC(K+7)                                                  
      IF ( ILLOC(K+9) .NE. NOTDEF ) GO TO 229                           
C                                                                       
C     THIS IS A NEW RADIAL FORM                                         
C                                                                       
      LX = ILLOC(K+3)                                                   
      NNUCFF = NNUCFF+1                                                 
      IF ( IPT .EQ. 1 ) IFIRST = NNUCFF                                 
      IF ( IPT .EQ. 2 ) ISECND = NNUCFF                                 
      DO 219 II = I, NBASCP                                             
      KK = LBASCP + (II-1)*MBASCP                                       
      IF ( ILLOC(KK+7) .NE. IPT ) GO TO 219                             
C                                                                       
C     FOR DEFORMED MUST ALSO CONSIDER LX EXCEPT FOR MUTUAL              
C                                                                       
      ITEMP = MOD( IPT, 100 )                                           
      IF ( ( ITEMP .EQ. 3 .OR. ITEMP .EQ. 4 ) .AND. LX .NE. ILLOC(KK+3) 
     *) GO TO 219                                                       
      IF ( ALLOC4(KK+4) .EQ. 0 ) GO TO 219                              
      ILLOC(KK+9) = 2*NNUCFF-1                                          
 219  CONTINUE                                                          
 229  CONTINUE                                                          
C                                                                       
C     NOW DETERMIN HOW MANY COULOMB COUPLING RADIAL FORMS               
C     ARE NEEDED AND ASSIGN THE COULOMB FORM FACTOR POINTERS            
C                                                                       
      NCOUFF = 0                                                        
      DO 259 I = 1, NBASCP                                              
      K = LBASCP + (I-1)*MBASCP                                         
      IF ( ALLOC4(K+5) .NE. 0 ) GO TO 235                               
      ILLOC(K+10) = 0                                                   
      GO TO 249                                                         
 235  IF ( ILLOC(K+10) .NE. NOTDEF ) GO TO 249                          
      IORDER = ILLOC(K+2)                                               
      IMULT = ILLOC(K+3)                                                
      NCOUFF = NCOUFF + 1                                               
      DO 249 II = 1, NBASCP                                             
      KK = LBASCP + (II-1)*MBASCP                                       
      IF ( ILLOC(KK+2) .NE. IORDER .OR. ILLOC(KK+3) .NE. IMULT .OR. ALLO
     *C4(KK+5) .EQ. 0 ) GO TO 249                                       
      ILLOC(KK+10) = NCOUFF                                             
 249  CONTINUE                                                          
 259  CONTINUE                                                          
C                                                                       
      WRITE(6,263) NNUCFF, NCOUFF                                         
 263  FORMAT ( ' THERE ARE',I3, ' NUCLEAR AND', I3,  ' COULOMB FORM-FAC
     *TOR RADIAL FUNCTIONS.' )                                          
C                                                                       
C     NUCLEAR STORAGE FOR DERIVATIVE OF W.S.                            
C                                                                       
      I = MAX0( (2*NUMPT*NNUCFF+FACFR4-1)/FACFR4, 1 )                   
      INUCH=NALLOC(I, 'NUCH ')                                          
      I = MAX0( (NUMPT*NCOUFF+FACFR4-1)/FACFR4, 1 )                     
      ICOULH=NALLOC( I, 'COULH ')                                       
C                                                                       
C     NOW SETUP THE POTENTIALS * GAUSS WEIGHTS * R'S                    
C                                                                       
C     FIRST WE GET THE POTENTIALS ON THE ARRAY ( 0, SUMMAX )            
C     THEN WE DEFINE CUBICS AND USE THEM TO GET THE DERIVATIVES.        
C                                                                       
C     TO GET THE POTENTIALS WE SETUP SOME WORK AREAS INPLACE OF         
C     THE CHANNEL 1 ARRAYS.                                             
C                                                                       
 300  ICHANW = 1                                                        
      NSTEP1 = NSTPSS(1)                                                
      IREAL1 = IRLVS(1)                                                 
      IIMAG1 = IIMVS(1)                                                 
      ICENT1 = ICENTR(1)                                                
C                                                                       
C     WE USE THE STEPSIZE OF THE FIRST CHANNEL                          
C     WE GO SLIGHTLY FURTHER TO GIVE THE SPLINES TIME TO SETTLE DOWN    
C                                                                       
      STEPSZ = RSTEPS(1)                                                
      H = HS(1)                                                         
      E = ES(1)                                                         
      NSTEP = SUMMAX/STEPSZ + 20.5                                      
      NSTEPS = NSTEP+1                                                  
      NSTPSS(1) = NSTEP                                                 
      IRLVS(1) = NALLOC(NSTEPS, 'INELREAL')                             
      IIMVS(1) = NALLOC(NSTEPS, 'INELIMAG')                             
      ICENTR(1) = NALLOC(NSTEPS, 'INELCENT')                            
      IVWORK = NALLOC(NSTEPS, 'VWORK ' )                                
C                                                                       
C     SETUP STUFF AS IF IN FIRST CHANNEL                                
C                                                                       
      AMP = AMA                                                         
      AMT = AMBIGA                                                      
      AM = REDMI                                                        
      IZP = IZS(1)                                                      
      IZT = IZS(3)                                                      
C                                                                       
C     INITIALIZE LINKULES IF NEEDED                                     
C                                                                       
      DO 359 I = 1, 5                                                   
      IF ( LNKADR(3,I) .EQ. 0 ) GO TO 359                               
C                                                                       
C     GENERATE THE SPECIAL UNIQUE NAME                                  
C                                                                       
      IUNIQU = IUNIQU + 1                                               
CCCCCCCCCCCCC ADDED  3/27/87 JRB CCCCCCCCCCCCCCCCCCCCCCC
C   NOTHING WAS BEING PUT IN LINKID IN VMS VERSION
C   SO THAT SECOND EXTERNAL FF OVERWROTE FIRST
            LINKID(3) = 48  + MOD(IUNIQU/10, 10)
            LINKID(4) = 48  + MOD(IUNIQU, 10)
CCCCCCCCCCCCC END ADDITION    JRB CCCCCCCCCCCCCCCCCCCCCCC
CIB         LINKID(3) = 240 + MOD(IUNIQU/10, 10)                        
CIB         LINKID(4) = 240 + MOD(IUNIQU, 10)                           
CDC         ENCODE ( 4, 333, LINKID ) IUNIQU                            
CDC 333     FORMAT ( 1H*, I3 )                                          
C                                                                       
C     MAKE INITIALIZING CALL                                            
C                                                                       
      CALL LINKUL (LNKADR(3,I), LNKNAM(1,I), LNKADR(5,I),I,1,IRET,
     * L, J, 0.D0, STEPSZ, NSTEP+1, DUMMY, DUMMY, LINKID )               
CVMS     *L, J, 0.D0, STEPSZ, NSTEP+1, DUMMY, DUMMY, DESCR(LINKID) )        
      IF ( IRET .GE. 0 ) GO TO 340                                      
      IRET = 0                                                          
      RETURN                                                            
 340  LNKADR(4,I) = IRET                                                
 359  CONTINUE                                                          
C                                                                       
C                                                                       
C     NOW COMPUTE THE POTENTIAL, NWP=3 IS CONVERT TO NWP=1              
C    BY MAKPOT EXCEPT THE COULOMB IS NOT COMPUTED.1                     
C                                                                       
C     FOR C.C. THE RESULTS OF THIS CALL ARE USED FOR THE                
C     FIRST AND SECOND DERIVATIVE FORMS.  LX=-1 INDICATES THIS          
C                                                                       
      LX = -1                                                           
      IRET = 1                                                          
      J = NOTDEF                                                        
      IF ( IFIRST+ISECND .NE. 0 ) CALL MAKPOT ( 3, IRET )               
      DRIVSW = KFRMTP .EQ. 1                                            
      IF ( IRET .GE. 0 ) GO TO 400                                      
      IRET = 0                                                          
      RETURN                                                            
C                                                                       
C     SUMMARIZE THE POTENTIALS TO BE USED                               
C                                                                       
C     FOLLOWING LIFTED FROM WAVSET                                      
C                                                                       
 400  IF ( .NOT. DRIVSW ) WRITE(6,403)
 403  FORMAT ( '-POTENTIALS WHOSE DERIVATIVES ARE THE',  ' EFFECTIVE INT
     *ERACTION OPERATOR:' )                                             
      IF ( DRIVSW ) WRITE(6,408)
 408  FORMAT ( '-RADIAL FORM FACTORS FOR FIRST-ORDER COUPLINGS.' )      
      IF ( DRIVSW .AND. ISECND .NE. 0 ) WRITE(6,409)
 409  FORMAT ( ' (DERIVATIVES OF THESE ARE USED FOR SECOND ORDER.)' )   
C                                                                       
      IMAGSW = TVI .NE. 0                                               
      SOSW = .FALSE.                                                    
      SOISW = .FALSE.                                                   
      ETA = ETAS(1)                                                     
C                                                                       
C     IF POSSIBLE, RECOMPUTE R0'S FOR PRINTING                          
C                                                                       
      TEMP1 = 0                                                         
      TEMP2 = 0                                                         
      TEMP3 = 0                                                         
      TEMP4 = 0                                                         
      TEMP5 = 0                                                         
      TEMP6 = 0                                                         
      IF ( R0MASS .EQ. UNDEF ) GO TO 420                                
      TEMP1 = R/R0MASS                                                  
      IF ( TVI .NE. 0 ) TEMP2 = RI/R0MASS                               
      IF ( SOSW ) TEMP3 = RSO/R0MASS                                    
      IF ( SOISW ) TEMP4 = RSOI/R0MASS                                  
      IF ( VSI .NE. 0 ) TEMP5 = RSI/R0MASS                              
      TEMP6 = RC/R0MASS                                                 
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 )                                                     
      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,483) ETA, RC, TEMP6                                         
 483  FORMAT ( ' COULOMB', T20, G14.5, T37, F7.4, T67, F7.4 )           
      IF((RCP.EQ.0).OR.(RCT.EQ.0)) GO TO 500                            
      WRITE(6,487) RCP, RCT, RC0P, RC0T                                   
  487 FORMAT( ' FOLDED COULOMB POTENTIALS - RCP = ',F7.4,2X, 'RCT = ',F7
     *.4,2X,'RC0P = ',F7.4,2X,'RC0T = ',F7.4)                           
C                                                                       
 500  WRITE(6,503)
 503  FORMAT ( ' ' )                                                    
      GO TO 600                                                         
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                                                                       
      CALL LINKUL ( LNKADR(3,I), LNKNAM(1,I), LNKADR(5,I),  I, 2, IRET, 
     * L, J, 0.D0, STEPSZ, NSTEP+1, DUMMY, DUMMY, 0 )                   
      WRITE(6,563)
 563  FORMAT ( ' ' )                                                    
      IF ( IRET .GE. 0 ) GO TO ( 440, 450, 460, 470, 500 ), I           
      IRET = 0                                                          
      RETURN                                                            
C                                                                       
C     PREPARE TO COMPUTE DERIVATIVE OF POTENTIAL                        
C     IF THE DERIVATIVE WAS DIRECTLY SUPPLIED, THEN WE                  
C     DON'T NEED TO COMPUTE IT UNLESS IF THERE IS 2ND ORDER.            
C                                                                       
 600  ICUBIC = 0                                                        
      IF ( IFIRST+ISECND .EQ. 0 ) GO TO 605                             
      IF ( ISECND .EQ. 0 .AND. DRIVSW .AND. CCSW ) GO TO 605            
      ICUBIC = NALLOC( 4*NSTEPS, 'INELCUBS' )                           
      LR = Z(ICUBIC)                                                    
      LB = LR+NSTEPS                                                    
      LC = LB+NSTEPS                                                    
      LD = LC+NSTEPS                                                    
 605  LREALV = Z(IRLVS(1))-1                                            
      LIMAGV = Z(IIMVS(1))-1                                            
      LVWORK = Z(IVWORK)                                                
      LNUCH = Z(INUCH) - 2                                              
      LCOULH = Z(ICOULH) - 1                                            
      IF ( IFIRST+ISECND .EQ. 0 ) GO TO 630                             
      IF ( CCSW ) GO TO 620                                             
C                                                                       
C     GET THE GAUSS POINTS FOR DWBA                                     
C                                                                       
      LRPTS = Z(IRPTS) - 1                                              
      LRWTS = Z(IRWTS) - 1                                              
      LRPTS4 = FACFR4*Z(IRPTS4) - FACFR4                                
      CALL CUBMAP ( MAPSUM, SUMMIN, SUMMID, SUMMAX, GAMSUM,  ALLOC(LRPTS
     *+1), ALLOC(LRWTS+1), NUMPT )                                      
C                                                                       
C                                                                       
C     FIRST DO THE REAL AND COULOMB PARTS                               
C                                                                       
C     GET THE SPLINES                                                   
C     GENERATE INPUT GRID FOR THE SPLINES                               
C                                                                       
 620  RVAL = 0                                                          
      IF ( ISECND .EQ. 0 .AND. DRIVSW .AND. CCSW ) GO TO 630            
      DO 629 I = 1, NSTEPS                                              
      ALLOC(LR-1+I) = RVAL                                              
      RVAL = RVAL + STEPSZ                                              
 629  CONTINUE                                                          
C                                                                       
      CALL SPLNCB ( NSTEPS, ALLOC(LR), ALLOC(LREALV+1),  ALLOC(LB), ALLO
     *C(LC), ALLOC(LD) )                                                
C                                                                       
 630  VC = R2S(4)                                                       
      RCUEFF = RC                                                       
C                                                                       
      IF ( CCSW ) GO TO 670                                             
C                                                                       
      ASSIGN 652 TO IGOTO                                               
      IF ( DRIVSW ) ASSIGN 654 TO IGOTO                                 
      DO 659 I = 1, NUMPT                                               
      RVAL = ALLOC(LRPTS+I)                                             
      WT = ALLOC(LRWTS+I)                                               
      ALLOC4(LRPTS4+I) = RVAL                                           
      N = RVAL/STEPSZ                                                   
      X = RVAL - N*STEPSZ                                               
      GO TO IGOTO, (652, 654)                                           
 652  XX = ( ALLOC(LB+N) + X*(2*ALLOC(LC+N) + X*3*ALLOC(LD+N) ))        
      GO TO 655                                                         
 654  XX = ALLOC(LREALV+N+1) + X*( ALLOC(LB+N) + X*( ALLOC(LC+N)  + X*AL
     *LOC(LD+N) ) )                                                     
 655  TERM = + (12*E/H**2) * R2S(1) * WT * XX                           
      ALLOC(LNUCH+2*I) = TERM                                           
      IF ( RVAL .LT. RC ) XX = (RVAL/RC**2)**LXMIN / RC                 
      IF ( RVAL .GE. RC ) XX = 1 / RVAL**(LXMIN+1)                      
      ALLOC(LCOULH+I) = -WT*VC*XX                                       
 659  CONTINUE                                                          
      GO TO 700                                                         
C                                                                       
C     SET UP RADIAL PARTS OF REAL POT FOR COUPLED CHANNELS              
C     WE STORE                                                          
C        - (2*MU/HBARC**2) (STEPSIZE**2/12) DV/DR                       
C                                                                       
C     NOTE THAT MAKPOT HAS GENERATED ESPECIALLY FOR US                  
C        - (H**2/12) (V/E)                                              
C                                                                       
 670  LNUCH=FACFR4*Z(INUCH)-FACFR4+1                                    
      WT = - (2*REDMI/HBARC**2) * (STEPSZ**2/12.) * (12.*E/H**2)        
      IF ( IFIRST .EQ. 0 ) GO TO 672                                    
      K = LNUCH + 2*NUMPT*(IFIRST-1)                                    
      IF (DRIVSW) LB = LREALV+1                                         
C                                                                       
      DO 671 I=1,NUMPT                                                  
      ALLOC4(K+2*I-2) = -WT * ALLOC(LB+I-1)                             
 671  CONTINUE                                                          
C                                                                       
 672  IF ( ISECND .EQ. 0 ) GO TO 700                                    
C                                                                       
C     NOW GO ON TO SECOND ORDER                                         
C     WE STORE                                                          
C        + (2*MU/HBARC**2) (STEPSIZE**2/12) D**2 V / DR**2              
C                                                                       
      CALL SPLNCB ( NSTEPS, ALLOC(LR), ALLOC(LB),  ALLOC(LC), ALLOC(LD),
     * ALLOC(LVWORK) )                                                  
C                                                                       
      K = LNUCH + 2*NUMPT*(ISECND-1)                                    
      DO 675 I=1,NUMPT                                                  
      ALLOC4(K+2*I-2) = +WT * ALLOC(LC+I-1)                             
 675  CONTINUE                                                          
C                                                                       
C     NOW GO ON TO THE IMAGINARY PART                                   
C                                                                       
 700  IF ( IFIRST+ISECND .EQ. 0 ) GO TO 770                             
      IF ( ISECND .EQ. 0 .AND. DRIVSW .AND. CCSW ) GO TO 750            
      CALL SPLNCB ( NSTEPS, ALLOC(LR),  ALLOC(LIMAGV+1), ALLOC(LB), ALLO
     *C(LC), ALLOC(LD) )                                                
C                                                                       
      IF ( CCSW ) GO TO 750                                             
C                                                                       
      ASSIGN 732 TO IGOTO                                               
      IF ( DRIVSW ) ASSIGN 734 TO IGOTO                                 
      DO 739 I = 1, NUMPT                                               
      RVAL = ALLOC(LRPTS+I)                                             
      WT = ALLOC(LRWTS+I)                                               
      N = RVAL/STEPSZ                                                   
      X = RVAL - N*STEPSZ                                               
      GO TO IGOTO, (732, 734)                                           
 732  XX = ( ALLOC(LB+N) + X*(2*ALLOC(LC+N) + X*3*ALLOC(LD+N) ))        
      GO TO 735                                                         
 734  XX = ALLOC(LIMAGV+N+1) + X*( ALLOC(LB+N) + X*( ALLOC(LC+N)  + X*AL
     *LOC(LD+N) ) )                                                     
 735  TERM = + (12*E/H**2) * R2S(2) * WT * XX                           
      ALLOC(LNUCH+2*I+1) = TERM                                         
 739  CONTINUE                                                          
      GO TO 950                                                         
C                                                                       
C     SET UP RADIAL PARTS OF IMAG POT FOR COUPLED CHANNELS              
C                                                                       
 750  IF ( DRIVSW ) LB = LIMAGV+1                                       
      IF ( IFIRST .EQ. 0 ) GO TO 760                                    
      K = LNUCH + 2*NUMPT*(IFIRST-1)                                    
      DO 759 I=1,NUMPT                                                  
      ALLOC4(K+2*I-1) = -WT * ALLOC(LB+I-1)                             
 759  CONTINUE                                                          
C                                                                       
 760  IF ( ISECND .EQ. 0 ) GO TO 770                                    
C                                                                       
C      NOW GO ON TO SECOND ORDER                                        
C                                                                       
      CALL SPLNCB ( NSTEPS, ALLOC(LR), ALLOC(LB),  ALLOC(LC), ALLOC(LD),
     * ALLOC(LVWORK) )                                                  
C                                                                       
      K = LNUCH + 2*NUMPT*(ISECND-1)                                    
      DO 769 I=1,NUMPT                                                  
      ALLOC4(K+2*I-1) = +WT * ALLOC(LC+I-1)                             
 769  CONTINUE                                                          
C                                                                       
C     NOW PROCESS DEFORMED REQUESTS FOR C.C.                            
C                                                                       
 770  LBASCP=FACFR4*Z(IBASCP)-FACFR4+1                                  
      LBASCP=ILLOC(LBASCP+2)+LBASCP                                     
      IB1 = 1                                                           
      IF ( NNUCFF .EQ. 0 ) GO TO 800                                    
      DO 799 IP = 1, NNUCFF                                             
      IF ( IP .EQ. IFIRST .OR. IP .EQ. ISECND ) GO TO 799               
C                                                                       
C     FIND AN EXAMPLE OF THIS RADIAL FORM                               
C                                                                       
 775  IPP = (ILLOC(LBASCP+9)+1)/2                                       
      IF ( IPP .EQ. IP ) GO TO 780                                      
      LBASCP = LBASCP + MBASCP                                          
      IB1 = IB1+1                                                       
      IF ( IB1 .LE. NBASCP ) GO TO 775                                  
      WRITE(6,778) IP, IPP                                                
 778  FORMAT ('0*** INTERNAL ERROR AT 778 IN INGRST', 2I8 )             
      IRET = 0                                                          
      RETURN                                                            
 780  L = ILLOC(LBASCP+2)                                               
      LX = ILLOC(LBASCP+3)/2                                            
      J = ILLOC(LBASCP+7)                                               
      IF ( DBUGSW ) WRITE(6,783) IP, IB1, L, LX, J                        
 783  FORMAT ( ' GENERATING NUCLEAR FF:', 5I10 )                        
      CALL MAKPOT ( 3, IRET )                                           
C                                                                       
C     IN THIS CASE WE JUST COPY THE RESULTS OF MAKPOT                   
C                                                                       
      K = LNUCH + 2*NUMPT*(IP-1)                                        
      DO 789 I = 1, NUMPT                                               
      ALLOC4(K+2*I-2) = -WT*ALLOC(LREALV+I)                             
      ALLOC4(K+2*I-1) = -WT*ALLOC(LIMAGV+I)                             
 789  CONTINUE                                                          
 799  CONTINUE                                                          
C                                                                       
C     SET UP RADIAL PARTS OF COULOMB POT FOR COUPLED CHANNELS           
C                                                                       
 800  IF ( NCOUFF .EQ. 0 ) GO TO 950                                    
      LCOULH=Z(ICOULH)                                                  
      LCOULH=FACFR4*(LCOULH-1)+1                                        
      LBASCP=FACFR4*Z(IBASCP)-FACFR4+1                                  
      LBASCP=ILLOC(LBASCP+2)+LBASCP                                     
      IP = 1                                                            
C                                                                       
C     LOOP OVER ALL COUPLINGS FINDING 1ST INSTANCE                      
C     OF EACH RADIAL FORM.                                              
C                                                                       
C                                                                       
      DO 869 J=1,NBASCP                                                 
      LABEL=(J-1)*MBASCP+LBASCP                                         
      IORDER=ILLOC(LABEL+2)                                             
      IMULT=ILLOC(LABEL+3)                                              
      IPOINT=ILLOC(LABEL+10)                                            
      IF(IPOINT.NE. IP )GO TO 869                                       
      IMT=IMULT/2                                                       
C                                                                       
C     THE RADIAL FACTORS IN INGRST ARE COMPUTED SUCH THAT               
C     WHEN MULTIPLIED BY THE X FACTORS IN BASCPL THE CORRECT            

C     ANSWER RESULTS                                                    
C                                                                       
C     THEY ARE                                                          
C                                                                       
C       - (2*MU/HBARC**2) (STEPSIZE**2/12) (3 ZP ZT ALPHA HBARC) F(R)   
C     WHERE                                                             
C       FIRST ORDER:                                                    
C         F(R) = R**LX / RC**(2LX+1)    R < RC                          
C              = 1/R**(LX+1)            R > RC                          
C       SECOND ORDER:                                                   
C         F(R) = (1-LX)/(2+LX) R**LX / R**(2LX+1)   R < RC              
C              = 1 / R**(LX+1)                      R > RC              
C                                                                       
C     THE FOLLOWING FORMULAS ARE CORRECT FOR A POINT AND SINGLE         
C     DEFORMED SPHERE OF DEFORMATION RADIUS RC.  IN THIS CASE WE        
C     WOULD ALSO HAVE RT=RC IN THE COUPLING CONSTANTS.  WE USE          
C     THESE FORMULAS EVEN WHEN RP IS NOT ZERO.  THIS GIVES THE          
C     CORRECT RESULT FOR R > RC  BUT IS INCORRECT FOR R < RC.           
C     HOWEVER, R < RC IS NOT IMPORTANT.                                 
C                                                                       
      RVAL = -STEPSZ                                                    
      WT = -(2*REDMI/HBARC**2) * (STEPSZ**2/12.) * VC                   
      IPOW = IMT                                                        
      TMPFAC = 1/RC**(IMULT+1)                                          
      IF (IORDER .EQ. 2) TMPFAC = (1.D0-IMT)/(2+IMT) * TMPFAC           
      ASSIGN 830 TO IGOTO                                               
      IF ( DBUGSW ) WRITE(6,823) IP,J,IORDER,IMULT,ILLOC(LABEL+7)    
 823  FORMAT ( ' GENERATING COULOMB FF:', 4I10, '/2', I10 )             
      DO 849 I1=1,NUMPT                                                 
      RVAL = RVAL + STEPSZ                                              
C                                                                       
      GO TO IGOTO, ( 830, 835 )                                         
C                                                                       
C     CHECK TO SEE IF  R < RC  STILL                                    
C                                                                       
 830  IF ( RVAL .LT. RC ) GO TO 835                                     
      ASSIGN 835 TO IGOTO                                               
      IPOW = -(IMT+1)                                                   
      TMPFAC = 1                                                        
C                                                                       
 835  XX = TMPFAC * RVAL**IPOW                                          
      ALLOC4(LCOULH+I1-1+(IP-1)*NUMPT) = WT*XX                          
 849  CONTINUE                                                          
      IP = IP+1                                                         
      IF ( IP .GT. NCOUFF ) GO TO 950                                   
 869  CONTINUE                                                          
C                                                                       
C                                                                       
C     FREE WORK AREAS                                                   
C                                                                       
 950  IF (ICUBIC .NE. 0) Z(ICUBIC) = -Z(ICUBIC)                         
      Z(IRLVS(1)) = -Z(IRLVS(1))                                        
      Z(IIMVS(1)) = -Z(IIMVS(1))                                        
      Z(ICENTR(1)) = -Z(ICENTR(1))                                      
      Z(IVWORK) = -Z(IVWORK)                                            
C                                                                       
C     RESTORE FIRST CHANNEL                                             
C                                                                       
      NSTPSS(1) = NSTEP1                                                
      IRLVS(1) = IREAL1                                                 
      IIMVS(1) = IIMAG1                                                 
      ICENTR(1) = ICENT1                                                
C                                                                       
      IF ( IPRT .EQ. 0 ) GO TO 990                                      
C                                                                       
C     SUMMARIZE THINGS NICELY                                           
C                                                                       
      WRITE(6,983)  NMPTSV, MAPSUM, GAMSUM, SUMMIN, SUMMID, SUMMAX        
 983  FORMAT (' ONE-DIMENSIONAL INTEGRATION GRID:' / ' NUM. PTS.   MA
     *P TYPE   GAMMA    MINIMUM',  '   "MID. PT."   MAXIMUM' /  I6, I11,
     * F11.2, F10.2, F12.2, F14.2 )                                     
C                                                                       
 990  IRET = 1                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE INIT8 ( I, X8 )                                        
C                                                                       
C     INITIALIZES ALLOCATOR ARRAY I TO CONSTANT X, ANY LENGTH.          
C                                                                       
C                                                                       
C     8/7/79 - NEW ROUTINE - RPG                                        
C     6/3/80 - CDC VERSION - 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 /LENGTH/ LENG(1)                                           
C                                                                       
      REAL*4 X4                                                         
      INTEGER*2 X2                                                      
      LOGICAL*1 X1                                                      
C                                                                       
C     ENTRY  INIT8  IS FOR LENGTH 8.                                    
CDCC                                                                    
CDCC      ON CDC WE DON'T HAVE ENTRIES AND ALL DATA TYPES ARE THE SAME  
CDCC      SO WE DO IT ALL HEERE                                         
CDCC                                                                    
CDC      ENTRY INIT4                                                    
CDC      ENTRY INIT2                                                    
CDC      ENTRY INIT1                                                    
C                                                                       
      N = LENG(I)                                                       
      LL = Z(I) - 1                                                     
      DO 99 K = 1, N                                                    
      ALLOC(LL+K) = X8                                                  
 99   CONTINUE                                                          
      RETURN                                                            
C                                                                       
C                                                                       
C     ENTRY  INIT4  IS FOR LENGTH 4                                     
C                                                                       
      ENTRY INIT4 ( I, X4 )                                             
      N = LENG(I)*FACFR4                                                
      LL = Z(I)*FACFR4 - FACFR4                                         
      DO 199 K = 1, N                                                   
      ALLOC4(LL+K) = X4                                                 
 199  CONTINUE                                                          
      RETURN                                                            
C                                                                       
C                                                                       
C     ENTRY  INIT2  IS FOR LENGTH 2                                     
C                                                                       
      ENTRY INIT2 ( I, X2 )                                             
      N = LENG(I)*FACFR2                                                
      LL = Z(I)*FACFR2 - FACFR2                                         
      DO 299 K = 1, N                                                   
      ILLOC2(LL+K) = X2                                                 
 299  CONTINUE                                                          
      RETURN                                                            
C                                                                       
C                                                                       
C     ENTRY  INIT1  IS FOR LENGTH 1                                     
C                                                                       
      ENTRY INIT1 ( I, X1 )                                             
      N = LENG(I)*FACFR1                                                
      LL = Z(I)*FACFR1 - FACFR1                                         
      DO 399 K = 1, N                                                   
      MLLOC(LL+K) = X1                                                  
 399  CONTINUE                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE INRDIN ( IRTN )                                        
C                                                                       
C     COMPUTES THE INELASTIC EXCITATION RADIAL INTEGRALLS  I(LI,LO,LX)  
C                                                                       
C     COMPUTES THE INELASTIC EXCITATION INTEGRALS                       
C       INTEGRAL(0 TO SUMMAX) DR U(R) H U(R)                            
C     WHERE H IS THE FULL H                                             
C     AND THEN COMPUTES                                                 
C       I(NUCLEAR) = I(0 TO SUMMAX) + I(SUMMAX TO INF) - I(COULOMB)     
C                                                                       
C     12/15/76 - BASED ON INELDC - S. P.                                
C     4/24/78 - INTERCHANGE LI AND LO - S.P.                            
C     5/24/78 - NEW WAVELJ CALLS - S.P.                                 
C     3/6/79 - COMPUTE S-MATRIX - S.P.                                  
C     5/12/79 - CLINTS TIME PRINTED SEPARATELY - S.P.                   
C     11/3/79 - USE BOB'S S-MATRIX ADDRESSES - S.P.                     
C               INTRODUCE FINAL EXTRA I INTO THE S-MATRICES - S.P.      
C     11/20/79 - S-MATRICES STORED BY LO-LI - S.P.                      
C     12/27/79 - STANDARD MORTRAN.  NOTE VAX WARNING - RPG              
C     1/18/80 - CVA%M,%F FOR VAX COMPLEX*16 - RPG                       
C     4/18/80 - GRIDCMFORINEL -- HOW WAS THIS LOST? - S.P.              
C     4/26/80 - PBUGSW NOLONGER IN WAVCOM; FREE MORE - S.P.             
C     6/2/80 - COMMA IN DATA LIST FOR PHASES - S.P.                     
C     6/24/80 - USE RCUEFF INSTEAD OF RC - S.P.                         
C     8/11/80 - CALL SETLOG - S.P.                                      
C     9/23/80 - EXTRA (-)**LX TO MAKE I**(-LX-1) - S.P.                 
C     10/28/81 - ROOT 2 FOR IDENTICAL PARTICLES - S.P.                  
C     5/4/82 - FIX K TO INDXS FOR 1/2 INTEGER SPINS - S.P.              
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      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 /GRIDCM/ RCUEFF, GRDCM1(2), IBINDX, MBINDX, NBINDX, NMFFAC,
     * MXLXGS, NMBFAC, IINHR, IINHI, IRHSR, IRHSI, INUCH, ICOULH, ILOR, 
     *ILOI, ILIR, ILII, NPTMIN, NOFLO, NUMPT, NCRIT, ISMX, ISMSQ, IPADE,
     * IHOMO, ISMTSV, IRPTS4, IRPTS, IGRDC4(5), IDW, IGRDC5(2), IABS1, I
     *GRDC6(2), GRDCM2, IGRDC7(2), IRWTS, IGRDC8(2), ICL1FF, ICL1FG, ICL
     *1GF, ICL1GG                                                       
      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 /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      REAL*4 TBEGIN, TIMES                                              
      COMMON /FTIME/ TBEGIN, NUMLOP, NUMWAV, TIMES(8)                   
C                                                                       
C     WARNING:  VAX VERSION MAY BE INACCURATE (NO COMPLEX*16).          
      COMPLEX INUC, ICOMP, IRTOIN, ITOTAL, SIN, SOUT, IFACTR            
CNV      DATA  IFACTR / (0.D0, 1.D0) /                                  
      DATA IFACTR / (0., 1.) /                                          
C                                                                       
C                                                                       
      LOGICAL PBUGSW, PINFSW                                            
      LOGICAL NXLISW                                                    
C                                                                       
C     FOLLOWING ARE  -(I)**LX                                           
C                                                                       
      COMPLEX PHASE                                                     
CNV      COMPLEX*16  PHASES(4) / (0.D0, -1.D0),                         
CNV     1  (-1.D0, 0.D0), (0.D0, 1.D0), (+1.D0, 0.D0) /                 
      COMPLEX PHASES(4)                                                 
      DATA PHASES / (0., -1.), (-1., 0.), (0., 1.), (+1., 0.) /         
C                                                                       
      IRTN = 0                                                          
      DO 14 I=1, 3                                                      
  14  TIMES(I)=0.0                                                      
C                                                                       
      IPRNT = MOD( IPRINT, 10 )                                         
CCCC      PEAKSW = IPRNT .GE. 7                                         
      PBUGSW = IPRNT .GE. 4                                             
      PINFSW = IPRNT .GE. 2                                             
C                                                                       
C                                                                       
      WRITE(6,23) REACT, ELAB, HEADER                                     
 23   FORMAT ( X, T60, 'P T O L E M Y' /  49X, 'COMPUTATION OF INELAST
     *IC S-MATRIX ELEMENTS' /  X, 45A1, 'ELAB =', F7.2, ' MEV', 5X, 65
     *A1 / )                                                            
C                                                                       
      NLINE = 1000                                                      
C                                                                       
C****************************************************************       
C         NOTE -- NO SPIN ORBIT FORCE                                   
      ISPUN=1                                                           
C****************************************************************       
C                                                                       
      CALL SETLOG ( 2*(LOMOST+LXMAX) )                                  
C                                                                       
C     HERE WE START THE REAL GUTS OF THE CALCULATION.                   
C                                                                       
C                                                                       
C     THE PRINCIPAL LOOPS ARE IN THE ORDER:                             
C                                                                       
C       LI   LMIN <= LI <= LMAX                                         
C           (RI+RO)2  NPSUM TERMS                                       
C                                                                       
C                                                                       
C     WE WILL HAVE NO MORE  IALLOC  CALLS SO GET ADDRESSES              
C                                                                       
      LNUCH = Z(INUCH) - 2                                              
      LCOULH = Z(ICOULH) - 1                                            
      LRPTS = Z(IRPTS) - 1                                              
      LRPTS4 = FACFR4*(Z(IRPTS4)-1) + 1                                 
      LLIR = FACFR4*Z(ILIR) - FACFR4                                    
      LLII = FACFR4*Z(ILII) - FACFR4                                    
      LLOR = FACFR4*Z(ILOR) - FACFR4                                    
      LLOI = FACFR4*Z(ILOI) - FACFR4                                    
      LDW = Z(IDW)                                                      
      LLIS = FACFR4*Z(ILIS) - FACFR4                                    
      LSMATR = Z(ISMATR) - 1                                            
      LSMATI = Z(ISMATI) - 1                                            
      LCL1FF = Z(ICL1FF) - 1                                            
      LCL1FG = Z(ICL1FG) - 1                                            
      LCL1GF = Z(ICL1GF) - 1                                            
      LCL1GG = Z(ICL1GG) - 1                                            
      LCL2FF = Z(ICL2FF) - 1                                            
      LSIN = Z(ISMATS(1))                                               
      LSOUT = Z(ISMATS(2))                                              
      LABS1 = Z(IABS1) - 1                                              
      LBNRAT = Z(IBETAS(2)) - LXMIN/2                                   
      LBRAT = Z(IBETAS(3)) - LXMIN/2                                    
      LWAVR = Z(IWAVR)                                                  
      LWAVI = Z(IWAVI)                                                  
      LVRL1 = Z(IRLVS(1))                                               
      LVRL2 = Z(IRLVS(2))                                               
      LVIM1 = Z(IIMVS(1))                                               
      LVIM2 = Z(IIMVS(2))                                               
      LCENT1 = Z(ICENTR(1))                                             
      LCENT2 = Z(ICENTR(2))                                             
      LINDXS = FACFR4*Z(IINDXS) - FACFR4                                
C                                                                       
      FACTOR = DSQRT( AKI*AKO/(ES(1)*ES(2)*PI) )                        
      IF ( IDENSW ) FACTOR = SQRT(2.D0)*FACTOR                          
C                                                                       
C                                                                       
C     FORCE THE OVERLAYS TO GET THE THREEJ COMMON BLOCKS IN.            
C     CALLED REPTIVELY BELIW.  HOWEVER, NOTHING WILL HAPPEN             
C     FROM NOW ON THAT WOULD CAUSE THE OVERLAYS TO CHANGE.              
C                                                                       
      CALL DUMMY1                                                       
C                                                                       
C                                                                       
C                                                                       
      LRANGE = NOFLO - 1                                                
C                                                                       
C     THE LOOPS BEGIN NOW                                               
C                                                                       
C                                                                       
C                                                                       
C     LOOP OVER LI                                                      
C                                                                       
C                                                                       
C     TWO PASSES OVER LI LOOP NOW; EVEN LI FIRST,THEN ODD               
C                                                                       
      LIMIN=LMIN+1                                                      
      LIL=LMIN                                                          
      IF(MOD(LMIN,2) .EQ. 1 ) GO TO 150                                 
      LIMIN=LMIN                                                        
      LIL=LMIN+1                                                        
C                                                                       
C     LIPRTY = 1 FOR LI EVEN,  = 2 FOR LI ODD                           
C                                                                       
 150  DO 989 LIPRTY = 1, 2                                              
C                                                                       
      IF(LIMIN.GT.LMAX) GO TO 980                                       
      NXLISW = .FALSE.                                                  
      ILI = 1                                                           
C                                                                       
      DO 959 LI=LIMIN,LMAX,2                                            
C                                                                       
C     GET THE REQUIRED SCATTERING WAVEFUNCTIONS.                        
C     WE ALWAYS DO THIS EVEN IF LI WON'T BE USED SO AS TO GET THE       
C     ELASTIC S-MATRIX ELEMENTS.                                        
C                                                                       
      LOMIN=LI - LRANGE                                                 
      LOMAX=LI + LRANGE                                                 
C                                                                       
      IF ( NXLISW ) GO TO 250                                           
C                                                                       
C     FOR FIRST LI, FILL UP THE OUT-CHANNEL WAVEFUNCTION ARRAY          
C                                                                       
      ITRK=0                                                            
C                                                                       
      DO 239 LO=LOMIN,LOMAX,2                                           
      CALL WAVELJ(LO, ISPUN, 2, NUMPT, ALLOC4(LRPTS4),  ALLOC4(LLOR+ITRK
     *+1), ALLOC4(LLOI+ITRK+1),  ALLOC(LWAVR), ALLOC(LWAVI),  ALLOC(LVRL
     *2), ALLOC(LVIM2), ALLOC(LCENT2) )                                 
 239  ITRK=ITRK+NUMPT                                                   
C                                                                       
      ITRK=0                                                            
      LOBASE = LOMIN                                                    
      NXLISW = .TRUE.                                                   
      GO TO 280                                                         
C                                                                       
C     ON SUBSEQUENT LI'S WE NEED ONE NEW OUT-CHANNEL WAVEFUNC.          
C                                                                       
 250  LO=LI + LRANGE                                                    
      CALL WAVELJ(LO, ISPUN, 2, NUMPT, ALLOC4(LRPTS4),  ALLOC4(LLOR+ITRK
     *+1), ALLOC4(LLOI+ITRK+1),  ALLOC(LWAVR), ALLOC(LWAVI),  ALLOC(LVRL
     *2), ALLOC(LVIM2), ALLOC(LCENT2) )                                 
      IF ( ITRK .EQ. 0 ) LOBASE = LO                                    
      ITRK=ITRK+NUMPT                                                   
      IF(ITRK.GT.NCRIT) ITRK=0                                          
C                                                                       
C     FOR EACH LI, WE MUST GET THE O-CHANNEL WAVE FUNCTION              
C                                                                       
C                                                                       
 280  CALL WAVELJ(LI, ISPUN, 1, NUMPT, ALLOC4(LRPTS4), ALLOC4(LLIR+1),  
     *ALLOC4(LLII+1),  ALLOC(LWAVR), ALLOC(LWAVI),  ALLOC(LVRL1), ALLOC(
     *LVIM1), ALLOC(LCENT1) )                                           
C                                                                       
C     WAVEFUNCTIONS ALL FOUND, WILL WE DO THIS VALUE OF LI              
C                                                                       
C                                                                       
 290  IF ( LI - ILLOC(LLIS+ILI) ) 959, 300, 295                         
 295  IF ( ILI .GE. NUMLIS ) GO TO 959                                  
      ILI = ILI + 1                                                     
      GO TO 290                                                         
C                                                                       
C     THIS IS AN LI TO DO                                               
C                                                                       
 300  LOMNMN = MAX0( MOD(LOMAX,2) , LOMIN )                             
      LOMXMX = LOMAX                                                    
      NSKIP = 0                                                         
      DWRIOS=10.0D0                                                     
      DWRIOL=0                                                          
      DWRIOC=0                                                          
      DWCONT = 0                                                        
C                                                                       
C     IN ABS1 WE ACCUMULATE INTEGRAL !INTEGRAND! FOR                    
C     THIS LI.                                                          
C                                                                       
      DO 329 IH = 1, NMLOLX                                             
      ALLOC(LABS1+IH) = 0                                               
 329  CONTINUE                                                          
C                                                                       
C                                                                       
C     LOOP OVER R-VALUES AND COMPUTE THE H'S                            
C                                                                       
      DO 489 IU = 1, NUMPT                                              
      RVAL = ALLOC(LRPTS+IU)                                            
      RAT = 1/RVAL                                                      
      IF ( RVAL .LT. RCUEFF ) RAT = RVAL/RCUEFF**2                      
      RAT = RAT**2                                                      
C                                                                       
C     COMPUTE IMAG AND REAL PARTS OF PRODUCT OF THE DISTORTED           
C     SCATTERING WAVES.                                                 
C                                                                       
      FIR=ALLOC4(LLIR+IU)                                               
      FII=ALLOC4(LLII+IU)                                               
      IF ( DABS(FIR)+DABS(FII) .LT. 1.D-20 ) GO TO 480                  
C                                                                       
C     UNDO THE WRAP AROUND A STORAGE AND COMPUTE ALL PSI(A)*PSI(B)'S    
C     FOR THIS (RI, RO).                                                
C                                                                       
      DO 439 LO = LOMNMN, LOMXMX, 2                                     
      ITRKLO = NUMPT*( (LO-LOBASE)/2 )                                  
      IF ( ITRKLO .LT. 0 ) ITRKLO = ITRKLO + NUMPT+NCRIT                
      FOR = ALLOC4(LLOR+ITRKLO+IU)                                      
      FOI = ALLOC4(LLOI+ITRKLO+IU)                                      
      IF ( DABS(FOR) .LT. 1.D-20 ) FOR = 0                              
      IF ( DABS(FOI) .LT. 1.D-20 ) FOI = 0                              
      DWR=FOR*FIR-FOI*FII                                               
      DWI=FOR*FII+FOI*FIR                                               
      DWLOM=DMAX1(DABS(DWR),DABS(DWI))                                  
      IF(DWLOM.GT.DWRIOL) DWRIOL=DWLOM                                  
      IF((DWLOM.LT.DWRIOS).AND.(DWLOM.NE.0)) DWRIOS=DWLOM               
      DWRIOC=DWRIOC+DWLOM                                               
      ALLOC(LDW+LO-LOMNMN) = DWR                                        
      ALLOC(LDW+LO-LOMNMN+1) = DWI                                      
      DWCONT = DWCONT + 1                                               
 439  CONTINUE                                                          
C                                                                       
C                                                                       
      HNUCR = ALLOC(LNUCH+2*IU)                                         
      HNUCI = ALLOC(LNUCH+2*IU+1)                                       
      HCOUL = ALLOC(LCOULH+IU)                                          
C                                                                       
C                                                                       
C     NOW ADD THESE H'S INTO THE APPROPRIATE I(LI,LO,LX)                
C     ALONG WITH THE PRODUCT OF THE DISTORTED WAVES                     
C     NOTE THAT THE BETA ARRAYS ALSO CONTAIN                            
C          CLEBSCH( JIN LX K 0 : JOUT K )                               
C                                                                       
      IH = 0                                                            
      DO 479 LX = LXMIN, LXMAX, 2                                       
      HR = HNUCR*ALLOC(LBNRAT+LX/2) + HCOUL*ALLOC(LBRAT+LX/2)           
      HI = HNUCI*ALLOC(LBNRAT+LX/2)                                     
      HCOUL = RAT * HCOUL                                               
      LOMN = IABS(LI-LX)                                                
      LOMX = LI+LX                                                      
      K = LX+1 + NLX*(LX-INDXJS(3,IEXCIT)/2)                            
      KBASE = ILLOC(LINDXS+3*K-2)                                       
      LDELMN = ILLOC(LINDXS+3*K-1)                                      
      DO 479 LO = LOMN, LOMX, 2                                         
      KOFFS = KBASE + (LO-LI-LDELMN)/2                                  
      I = (ILI-1)*NSPLI + KOFFS                                         
      LDWBAS = LDW-LOMNMN+LO                                            
      IH = IH + 1                                                       
      TERMR = HR*ALLOC(LDWBAS) - HI*ALLOC(LDWBAS+1)                     
      ALLOC(LSMATR+I) = ALLOC(LSMATR+I) + TERMR                         
      TERMI = HR*ALLOC(LDWBAS+1) + HI*ALLOC(LDWBAS)                     
      ALLOC(LSMATI+I) = ALLOC(LSMATI+I) + TERMI                         
C                                                                       
C     COMPUTE INDICATION OF LOSS OF SIGNIFICANCE:                       
C       ABS1 = INTEGRAL(R) !INTEGRAND!                                  
C                                                                       
      ALLOC(LABS1+IH) = ALLOC(LABS1+IH) + DABS(TERMR)  + DABS(TERMI)    
 479  CONTINUE                                                          
C                                                                       
C                                                                       
      GO TO 489                                                         
C                                                                       
C     WE COME HERE WHEN SKIPPING H CALCULATION DUE TO THE PRODUCT       
C     OF THE DISTORTED WAVES BEING SMALL.                               
C                                                                       
 480  NSKIP = NSKIP + 1                                                 
C                                                                       
C                                                                       
 489  CONTINUE                                                          
C                                                                       
C                                                                       
C     END OF INTEGRATION                                                
C                                                                       
      DWRIOC=DWRIOC/DWCONT                                              
      IF (PBUGSW) WRITE(6, 533)DWRIOS,DWRIOL,DWRIOC                     
 533  FORMAT(' SMALLEST, LARGEST AND AVERAGE DABS(DWRIRO)=', 3G15.5 / ) 
C                                                                       
      IF ( .NOT. PINFSW ) GO TO 550                                     
      NLINE = NLINE + NMLOLX + 1                                        
      IF ( NLINE .LE. 58 ) GO TO 550                                    
      IF ( NLINE .LT. 1000 ) WRITE(6,23) REACT, ELAB, HEADER              
      WRITE(6,538)
 538  FORMAT ( '  L   L  LX', T25, 'INTEGRAL(0, SUMMAX)',  T55, 'COULOMB
     *', T70, 'NUCLEAR PART', T94, 'TOTAL AMPLITUDE' /  '  IN OUT', 11X,
     * 'MAG.', 6X, 'PHASE', 4X, 'CANCELLATION',  T54, 'AMPLITUDE',  T68,
     * 2( 'MAG.', 6X, 'PHASE', 9X ) / )                                 
      NLINE = 7+NMLOLX                                                  
C                                                                       
C                                                                       
C     ADD ON PIECE FROM SUMMAX TO INFINITY,                             
C     MULTIPLY IN CLEBSH GORDEN FACTOR,                                 
C     COMPUTE CANCELLATIONS,                                            
C     AND SEPARATE INTO NUCLEAR AND COULOMB PIECES                      
C     ALSO PUT IN THE I**(-LX-1)                                        
C                                                                       
C                                                                       
 550  SIN = CMPLX(SNGL(ALLOC(LSIN+2*LI)),SNGL(ALLOC(LSIN+2*LI+1)))      
      IH = 0                                                            
      DO 559 LX = LXMIN, LXMAX, 2                                       
      LOMN = IABS(LI-LX)                                                
      LOMX = LI+LX                                                      
      BETRAT = ALLOC(LBRAT+LX/2)                                        
      PHASE = PHASES(IAND(LX,3)+1)                                      
      K = LX+1 + NLX*(LX-INDXJS(3,IEXCIT)/2)                            
      KBASE = ILLOC(LINDXS+3*K-2)                                       
      LDELMN = ILLOC(LINDXS+3*K-1)                                      
      DO 559 LO = LOMN, LOMX, 2                                         
      KOFFS = KBASE + (LO-LI-LDELMN)/2                                  
      IH = IH + 1                                                       
      I1 = (ILI-1)*NSPLI + KOFFS                                        
      I2 = (LI-LMIN)*NSPLI + KOFFS                                      
      C = FACTOR * DABS( CLEBSH( 2*LI, 2*LX, 0, 0, 2*LO, 0 ) )          
      ICOMP = C*CMPLX(SNGL(ALLOC(LSMATR+I1)),SNGL(ALLOC(LSMATI+I1)))    
      SOUT = CMPLX(SNGL(ALLOC(LSOUT+2*LO)),SNGL(ALLOC(LSOUT+2*LO+1)))   
      IRTOIN = .25*C*BETRAT*( (1+SOUT)*(1+SIN)*ALLOC(LCL1FF+I1)  - (1-SO
     *UT)*(1-SIN)*ALLOC(LCL1GG+I1)  + IFACTR*( (1+SOUT)*(1-SIN)*ALLOC(LC
     *L1FG+I1)  + (1-SOUT)*(1+SIN)*ALLOC(LCL1GF+I1) ) )                 
      FFI = C*BETRAT*ALLOC(LCL2FF+I2)                                   
      ITOTAL = ICOMP + IRTOIN                                           
      INUC = ITOTAL - FFI                                               
      INUC = PHASE*INUC                                                 
      ALLOC(LSMATR+I1) = REAL(INUC)                                     
      ALLOC(LSMATI+I1) = AIMAG(INUC)                                    
      IF ( .NOT. PINFSW ) GO TO 559                                     
      ICOMP = PHASE*ICOMP                                               
      ITOTAL = PHASE*ITOTAL                                             
      AMPCOM = CABS(ICOMP)                                              
      THISR = C*ALLOC(LABS1+IH)/AMPCOM                                  
      AMPNUC = CABS(INUC)                                               
      AMPTOT = CABS(ITOTAL)                                             
      PHSCOM = ATAN2( AIMAG(ICOMP), REAL(ICOMP) )                       
      PHSNUC = ATAN2( AIMAG(INUC), REAL(INUC) )                         
      PHSTOT = ATAN2( AIMAG(ITOTAL), REAL(ITOTAL) )                     
C                                                                       
      WRITE(6,553) LI,LO,LX,AMPCOM,PHSCOM,THISR,FFI,AMPNUC,PHSNUC,
     * AMPTOT, PHSTOT                                                  
  553 FORMAT ( 2I4, I3, G16.4, G11.4, F9.2, G16.4,  2( G13.4, G11.4 ) ) 
 559  CONTINUE                                                          
C                                                                       
      IF ( PINFSW ) WRITE(6,563)
 563  FORMAT ( ' ' )                                                    
C                                                                       
 959  CONTINUE                                                          
C                                                                       
C     END OF THE LI LOOP FOR A GIVEN PARITY OF LI                       
C     IF LI IS EVEN HAVE ANOTHER BASH AT LI LOOP WITH ODD LI            
C                                                                       
 980  LIMIN=LIL                                                         
 989  CONTINUE                                                          
C                                                                       
C                                                                       
C     END OF THE 2 LI LOOPS (EVEN AND ODD PARITY OF LI)                 
C                                                                       
C                                                                       
C     FREE WORK AREAS                                                   
C                                                                       
      IF ( MOD(IPRINT/100,10) .GE. 1 ) GO TO 1500                       
C                                                                       
      Z(INUCH) = -Z(INUCH)                                              
      Z(ICOULH) = -Z(ICOULH)                                            
      Z(ILIR) = -Z(ILIR)                                                
      Z(ILII) = -Z(ILII)                                                
      Z(ILOR) = -Z(ILOR)                                                
      Z(ILOI) = -Z(ILOI)                                                
      Z(IDW) = -Z(IDW)                                                  
      Z(IRPTS) = -Z(IRPTS)                                              
      Z(IRWTS) = -Z(IRWTS)                                              
      Z(IRPTS4) = -Z(IRPTS4)                                            
      Z(IABS1) = -Z(IABS1)                                              
      Z(ICL1FF) = -Z(ICL1FF)                                            
      Z(ICL1FG) = -Z(ICL1FG)                                            
      Z(ICL1GF) = -Z(ICL1GF)                                            
      Z(ICL1GG) = -Z(ICL1GG)                                            
C                                                                       
C     THE AREAS FOR WAVELJ - ONE FOR INCOMING AND ONE FOR OUTGOING      
C                                                                       
      DO 1099 I = 1, 2                                                  
      Z(NFS(I)) = -Z(NFS(I))                                            
      Z(NGS(I)) = -Z(NGS(I))                                            
      Z(NF1S(I)) = -Z(NF1S(I))                                          

      Z(NG1S(I)) = -Z(NG1S(I))                                          
      Z(IRLVS(I)) = -Z(IRLVS(I))                                        
      Z(IIMVS(I)) = -Z(IIMVS(I))                                        
      Z(ICENTR(I)) = -Z(ICENTR(I))                                      
      IF ( V0SORS(I) .NE. 0 ) Z(ISORS(I)) = -Z(ISORS(I))                
      IF ( V0SOIS(I) .NE. 0 ) Z(ISOIS(I)) = -Z(ISOIS(I))                
 1099 CONTINUE                                                          
      Z(IWAVR) = -Z(IWAVR)                                              
      Z(IWAVI) = -Z(IWAVI)                                              
C                                                                       
C                                                                       
C     TIMING INFO                                                       
C                                                                       
 1500 CONTINUE
C                                                                       
C     A L L    D O N E                                                  
C                                                                       
      IRTN = 1                                                          
      RETURN                                                            
      END                                                               

      SUBROUTINE INTRCF ( NCHN, JP, JT, LX, LDEL,  NUMLIS, LIS, LSTEP, L
     *XMAX, SR, SI, LOFF1, ISDIM1, LISW,  LSTRT, LMAX, SOUT, SOUT4, LOFF
     *2, ISDIM2, LBASE2,  FOURSW, BIGBOY, LPEAK, CMPLXL, CMPLXS )       
C                                                                       
C     USES CONTINUED FRACTION TO INTERPOLATE S-MATRICES                 
C                                                                       
C     ARGUMENTS:                                                        
C                                                                       
C     NCHN, JP, JT, LX, LDEL - IDENTIFIERS FOR DIAGNOSTIC PRINTOUT      
C     NUMLIS, LIS - ARRAY OF L'S ATWHICH S IS DEFINED.                  
C     LSTEP - IF LSTEP=1, NO INTERP IS DONE, ONLY COPING.               
C     LXMAX - MINIMUM LI TO USE AS INTERP INPUT, FOR LI<LXMAX           
C             INPUT MUST BE DENSE AND IS JUST COPIED.                   
C     SR, SI - REAL AND IMAG PARTS OF INPUT S'S                         
C     LOFF1 - FIRST SUBSCRIPT OF THE SR, SI ARRAYS (FIXED).             
C     ISDIM1 - FIRST DIMENSTION OF THE SR, SI ARRAYS.                   
C     LISW - IF .TRUE., SECOND SUBSCRIPT IS LI+1, ELSE ILI.             
C     LSTRT, LMAX - RANGE OF OUTPUT.                                    
C     SOUT, SOUT4 - COMPLEX*16 OR COMPLEX*8 OUTPUT ARRAYS.              
C     LOFF2, ISDIM2 - AS ABOVE FOR THE OUTPUT ARRAYS                    
C     LBASE2 - SECOND SUBSCRIPT OF THE OUTPUT IS LI-LBASE2              
C     FOURSW - IF .TRUE., OUTPUT IS IN SOUT4, ELSE SOUT.                
C     BIGBOY, LPEAK - SET TO MAXIMUM MAGNITUDE                          
C     CMPLXL, CMPLXS - COMPLEX*16 WORK ARRAYS OF DIMENSION NUMLIS.      
C                                                                       
C     NOTE THAT THE INPUT IS IN SEPARATE REAL AND IMAG ARRAYS WHILE     
C     THE OUTPUT IS IN ONE COMPLEX ASRRAY (EITHER *8 OR *16).           
C                                                                       
C     4/7/80 - SEPARATED FROM LINTRP - S.P.                             
C     4/24/80 - FIX PHASEING OF LIS ARRAY BUG - S.P.                    
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      INTEGER LIS(NUMLIS)                                               
      REAL*8 SR(ISDIM1, 1), SI(ISDIM1, 1), SOUT(2, ISDIM2, 1)           
      REAL*4 SOUT4(2, ISDIM2, 1)                                        
      LOGICAL FOURSW, LISW                                              
      REAL*8 CMPLXS(2, NUMLIS)                                          
	COMPLEX*16 CMPLXL(NUMLIS)
C                                                                       
	COMPLEX*16 CFLI,CTEMP
C                                                                       
      BIGBOY=0                                                          
      LPEAK=LSTRT                                                       
C                                                                       
C     SKIP INTERPOLATION IF LSTEP = 1.                                  
C                                                                       
      IF ( LSTEP .EQ. 1 ) GO TO 800                                     
C                                                                       
C     FIT CONTINUED FRACTION TO S-MATRICES WITH DESIGNATED              
C     LI VALUES.                                                        
C                                                                       
      ICOUNT=0                                                          
      DO 149 ILI=1,NUMLIS                                               
      LI=LIS(ILI)                                                       
      IF( LI .LT. LXMAX ) GO TO 149                                     
      ICOUNT=ICOUNT+1                                                   
	CMPLXL(ICOUNT)=LI
      II = ILI                                                          
      IF (LISW) II=LI+1                                                 
	CMPLXS(1,ICOUNT)=SR(LOFF1,II)
      CMPLXS(2,ICOUNT)=SI(LOFF1,II)                                     
  149 CONTINUE                                                          
C                                                                       
      CALL CCNFRC ( ICOUNT, CMPLXL, CMPLXS )                            
CDC     1         , X, Y )                                              
C                                                                       
C     COMPUTE S(LO,LI,LX) FOR THIS (LX,DEL) AND LI TO LMAX USING        
C     THE CONTINUED-FRACTION INTERPOLATION DETERMINED ABOVE             
C                                                                       
      ILI = 1                                                           
C                                                                       
      DO 799 LI = LSTRT, LMAX                                           
	CFLI=LI
      CALL CCONTF ( ICOUNT, CMPLXL, CMPLXS,  CFLI, CTEMP )              
	RE=DREAL(CTEMP)
      HIM=DIMAG(CTEMP)                                                  
      SIZE=(RE**2+HIM**2)                                               
C                                                                       
C        WHEN AVAILABLE, USE INELDC COMPUTED VALUES TO CHECK            
C        THE CONTINUED FRACTION.                                        
C                                                                       
 500  IF ( LIS(ILI) - LI ) 510, 550, 780                                
 510  IF ( ILI .EQ. NUMLIS ) GO TO 550                                  
      ILI = ILI+1                                                       
      GO TO 500                                                         
 550  II = ILI                                                          
      IF (LISW) II=LI+1                                                 
      F = SR(LOFF1,II)                                                  
      G = SI(LOFF1,II)                                                  
      SIZE = F**2 + G**2                                                
      ILI = ILI + 1                                                     
      IF ( LI .LT. LXMAX ) GO TO 775                                    
      IF ( (F-RE)**2 + (G-HIM)**2 .GT. 1.D-6*(SIZE) )  WRITE(6,773) 
     *NCHN, JP, JT, LX, LDEL, LI, RE, HIM, F, G                               
 773  FORMAT ( ' **** WARNING: FOR CHAN, 2*JP, 2*JT, LX, LO-LI',  ', LI 
     *=', 6I5 /  5X, 'CONT. FRAC. =', 2G13.5, 5X, 'EXACT =', 2G13.5 )   
 775  RE = F                                                            
      HIM = G                                                           
 780  IF ( FOURSW ) GO TO 785                                           
      SOUT(1,LOFF2,LI-LBASE2) = RE                                      
      SOUT(2,LOFF2,LI-LBASE2) = HIM                                     
      GO TO 790                                                         
 785  SOUT4(1,LOFF2,LI-LBASE2) = RE                                     
      SOUT4(2,LOFF2,LI-LBASE2) = HIM                                    
 790  IF(SIZE.LT.BIGBOY) GO TO 799                                      
      BIGBOY=SIZE                                                       
      LPEAK=LI                                                          
  799 CONTINUE                                                          
      GO TO 850                                                         
C                                                                       
C        NO INTERPOLATION  (LSTEP = 1).                                 
C        JUST TRANSFER AND SCAN.                                        
C                                                                       
 800  LBASE1 = LIS(1)-1                                                 
      IF ( LISW ) LBASE1 = -1                                           
      DO 849 LI = LSTRT, LMAX                                           
      F = SR(LOFF1,LI-LBASE1)                                           
      G = SI(LOFF1,LI-LBASE1)                                           
      IF ( FOURSW ) GO TO 835                                           
      SOUT(1,LOFF2,LI-LBASE2) = F                                       
      SOUT(2,LOFF2,LI-LBASE2) = G                                       
      GO TO 840                                                         
 835  SOUT4(1,LOFF2,LI-LBASE2) = F                                      
      SOUT4(2,LOFF2,LI-LBASE2) = G                                      
 840  SIZE = F**2 + G**2                                                
      IF ( SIZE .LT. BIGBOY ) GO TO 849                                 
      BIGBOY = SIZE                                                     
      LPEAK = LI                                                        
 849  CONTINUE                                                          
C                                                                       
 850  RETURN                                                            
      END                                                               
      SUBROUTINE JPTOLX ( L, LAS, JP, NWP, SJR, SJI, INDX, SLX )        
C                                                                       
C     TRANSLATES ELASTIC S-MATRIX FROM (L',L,JP) TO (L',L,LX) SYSTEM.   
C                                                                       
C                                                                       
C     L = ORBITAL ANGULAR MOMENTUM.                                     
C     LAS = ASYMPTOTIC L.                                               
C     JP = 2 * TOTAL PROJECTILE ANGULAR MOMENTUM (L + JSPS(NWP)).       
C     NWP = 1 FOR INCOMING, 2 FOR OUTGOING.                             
C     (SJR,SJI) = THE JP-SYSTEM ELEMENT TO BE TRANSLATED.               
C     INDX = INDEX ARRAY (SEE BELOW).                                   
C     SLX = OUTPUT S-MATRIX, IN THE LX SYSTEM.  SLX MUST BE INITIALIZED 
C        TO ZERO BEFORE THE FIRST JPTOLX CALL.                          
C                                                                       
C                                                                       
C           THE  INDX  ARRAY HAS THE FOLLOWING STRUCTURE:               
C     INDX(1,K) = KOFFS = OFFSET INTO THE S-MATRIX.                     
C     INDX(2,K) = LDELMN = MINIMUM (LI-LO).                             
C     INDX(3,K) = NDEL = NUMBER OF (LI-LO) VALUES.                      
C     WHERE K = 1 + LX*(JSPS(NWP)+2).                                   
C                                                                       
C     THIS FORMAT FOLLOWS FROM THE "INDXS" FORMAT (SEE ANGSET COMMENTS) 
C     IF JT = 0, I. E. NO TARGET SPIN EFFECTS.                          
C                                                                       
C                                                                       
C     8/1/79 - NEW ROUTINE - RPG                                        
C     11/20/79 - S-MATRICES STORED BY L-LAS - S.P.                      
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
C                                                                       
      DIMENSION INDX(3,1), SLX(1)                                       
C                                                                       
C     IF NO SPIN-ORBIT, JUST TRANSFER IT.                               
C                                                                       
      IF ( SOSWS(NWP) ) GO TO 100                                       
      I = 2*L + 1                                                       
      SLX(I) = SJR                                                      
      SLX(I+1) = SJI                                                    
      RETURN                                                            
C                                                                       
C     SPIN-ORBIT EXISTS.  MULTIPLY BY RACAH'S ETC., AND ADD             
C     TO EXISTING VALUES FOR EACH LX.                                   
C                                                                       
 100  LXMN = MAX0( 0, IABS( L-LAS ) )                                   
      LXMX = MIN0( JSPS(NWP), L+LAS )                                   
      COEF = (JSPS(NWP)+1)*(2*LAS+1)                                    
      COEF = (JP+1)/DSQRT(COEF)                                         
      I = ( JSPS(NWP) - JP + L + LAS )/2                                
      IF ( MOD(I, 2) .NE. 0 ) COEF = -COEF                              
      DO 199 LX = LXMN, LXMX                                            
      LX2 = 2*LX                                                        
      T = LX2 + 1                                                       
      T = COEF * DSQRT(T) * RACAH ( 2*L, 2*LAS, JSPS(NWP), JSPS(NWP), LX
     *2, JP )                                                           
      K = 1 + LX*( JSPS(NWP) + 2 )                                      
      IF ( INDX(1,K) .LE. 0 ) GO TO 199                                 
      I = LAS*NUMJS(NWP) + INDX(1,K) + (L-LAS-INDX(2,K))/2              
      I = 2*I - 1                                                       
      SLX(I) = SLX(I) + T*SJR                                           
      SLX(I+1) = SLX(I+1) + T*SJI                                       
 199  CONTINUE                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE LCRITL ( E, FK, ETA, RC, NSTEPS, RSTART, STEPSZ,  IV, I
     *W, NGAUSS, IPRINT, LC1, LC2, LC )                                 
C                                                                       
C     USE CLASSICAL DEFLECTION AND WKB PHASES TO ESTIMATE CRITICAL L    
C     LC IS TAKEN TO BE GREATER OF TWO ESTIMATES LC1 AND LC2            
C     LC1 IS THE FIRST L FOR WHICH !S(L)! > (!S!MIN + 1)/2.             
C     LC2 IS L-VALUE OF ALGEBRAICALLY MINIMUM THETA(L)                  
C     WHERE THETA(L) IS THE CLASSICAL DEFLECTION FUNCTION.              
C     IF IPRINT.NE.0 PRINT OUT WKB PHASES AND CLASSICAL TURNING PTS     
C     IF NEITHER LC1 NOR LC2 EXISTS (ABOVE NOISE), LC IS SET TO THE     
C     L FOR WHICH THE COULOMB CLASSICAL TURNING POINT = MAX( RC, 1.2 ). 
C                                                                       
C     9/18/75 - VERSION WITH WKB - MHM                                  
C     9/22/75 - CORRECTED AND CHANGED TO HANDLE V OR VI OR BOTH  =  0   
C     12/1/77 - USE POTENTIAL DEFINED BY ARRAYS - S.P.                  
C               DO NOT GO ON TO LARGE L-VALUES; INTERPOLATE TO LCRIT    
C     2/14/78 - AVOID UNDERFLOWS FOR EXTREME ABSORBTION                 
C     4/3/78 - AVOID UNDERFLOWS FOR SMALL ABSORBTION AT LARGE R - S.P.  
C     7/27/79 - INITIALIZE MINSW, CHANGE DEFINITION OF LC1 FOR WEAK     
C        ABSORPTION, START AT L=0 FOR LIGHT IONS - RPG                  
C     11/7/79 - INTRODUCE NOISE CONSTANT; INCREASE EPS; SET LC TO L FOR 
C        WHICH COULOMB CTP=RC IF THE OTHER 2 ESTIMATES FAIL - RPG       
C     12/27/79 - MAKE EPS 1E-14 AGAIN; IT MUST BE SMALL TO ALLOW        
C                THE INTEGRAL WITH SINGULAR END POINT - S.P.            
C     1/16/80 - CORRECT MYSTERIOUS SCREWED-UP COMMENTS - RPG            
C     5/8/80 - PASS VCONS TO SWKB - S.P.                                
C     5/8/80 - IN DESPERATION MAKE EPS 1E-12 - S.P.                     
C     6/3/80 - LMAX=1.5*ROW, DO NOT SET TO LMAX FOR S=1 ALWAYS - S.P.   
C     6/16/80 - DO NOT LOOK FOR MIN(1/2-PT) IF MIN > .99 - 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) )                                                          
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
C                                                                       
      LOGICAL MINSW                                                     
C     EPS IS THE ACCURACY REQUIRED IN SWKB.                             
      DATA EPS / 1.D-12 /                                               
C                                                                       
C     SET MINIMUM AND MAXIMUM L FOR SEARCH                              
C     ROW IS THE L WHERE COULOMB CLASSICAL TURNING POINT IS MAX(RC,1.2) 
C                                                                       
      MINSW = .FALSE.                                                   
      RCL = DMAX1( RC, 1.20D0 )                                         
      ROW = FK*RCL                                                      
      ROW = ROW**2 - 2*ETA*ROW + .25                                    
      IF ( ROW .LT. 0 ) ROW = 0                                         
      IF ( ROW .GT. 0 ) ROW = 0.5 + DSQRT( ROW )                        
      LMIN = .2*ROW - 4.                                                
      LMIN = MAX0( LMIN, 0 )                                            
      LMAX = 1.5*ROW                                                    
      LMAX = MAX0( LMAX, LMIN+50 )                                      
      LC1 = 0                                                           
      LC2 = 0                                                           
      LC = 0                                                            
      DLSMAT = 0                                                        
      DLDFLC = 0                                                        
      NOLS = LMAX-LMIN+1                                                
      AMPMIN = 1.D20                                                    
      VCONS = 1                                                         
      IF ( PROBLM .EQ. 24 ) VCONS = 0                                   
C                                                                       
C     ALLOCATE SPACE FOR GAUSS POINTS AND WKB STUFF                     
C     SET UP STARTING ADDRESSES                                         
C                                                                       
    5 IWKBPT = NALLOC(NGAUSS,'WKBPTS')                                  
      IWKBWT = NALLOC(NGAUSS,'WKBWTS')                                  
      NSEMIC = 5*NOLS                                                   
      ISEMIC = NALLOC(NSEMIC,'SCSTUF')                                  
      ICUBIC = NALLOC(7*NSTEPS, 'WKBCUBIC' )                            
      LRVAL = Z(ICUBIC)                                                 
      LVCUB = LRVAL + NSTEPS                                            
      LWCUB = LVCUB + 3*NSTEPS                                          
      LV = Z(IV)                                                        
      LW = Z(IW)                                                        
      IAMP = Z(ISEMIC)                                                  
      LAMP = IAMP-1                                                     
      IDNUC = IAMP+NOLS                                                 
      LDNUC = IDNUC-1                                                   
      IDEFL = IDNUC+NOLS                                                
      LDEFL = IDEFL-1                                                   
      ICTP = IDEFL+NOLS                                                 
      LCTP = ICTP-1                                                     
      ICTPC = ICTP+NOLS                                                 
      LCTPC = ICTPC-1                                                   
C                                                                       
C     DETERMINE UNMAPPED GAUSS POINTS FOR (-1,1)                        
C                                                                       
      CALL GAUSSL(NGAUSS,ALLOC(Z(IWKBPT)),ALLOC(Z(IWKBWT)))             
C                                                                       
C     GET CUBIC SPLINES FOR THE POTENTIALS                              
C                                                                       
      ROSTRT = FK*RSTART                                                
      RHO = ROSTRT                                                      
      H = FK*STEPSZ                                                     
      DO 159 I = 1, NSTEPS                                              
      ALLOC(LRVAL-1+I) = RHO                                            
      RHO = RHO+H                                                       
 159  CONTINUE                                                          
      ROEND = RHO - H - EPS                                             
C                                                                       
      CALL SPLNCB ( NSTEPS, ALLOC(LRVAL), ALLOC(LV), ALLOC(LVCUB),  ALLO
     *C(LVCUB+NSTEPS), ALLOC(LVCUB+2*NSTEPS) )                          
C                                                                       
      CALL SPLNCB ( NSTEPS, ALLOC(LRVAL), ALLOC(LW), ALLOC(LWCUB),  ALLO
     *C(LWCUB+NSTEPS), ALLOC(LWCUB+2*NSTEPS) )                          
C                                                                       
C     CALCULATE AND STORE WKB S-MATRIX ELEMENTS (AMP AND ARG)           
C     CLASSICAL DEFLECTION FUNCTIONS(DEFL) AND CLASSICAL TPS(CTP CTPC)  
C                                                                       
C     WE GO TO LMAX OR TO BOTH                                          
C     1)  !S! > .95 + .05*MIN(!S!)   AND                                
C     2)  DEFLECT FUNCT HAS A MIN FOLLOWED BY A MAX WHILE !S! > .05     
C                                                                       
      DO 299 I = 1,NOLS                                                 
      L = LMIN+I-1                                                      
      CALL SWKB ( E, FK, L, EPS, IPRINT, ETA, RC,  NSTEPS, ROSTRT, H, VC
     *ONS, ALLOC(LV), ALLOC(LVCUB), ALLOC(LW), ALLOC(LWCUB), NGAUSS, ALL
     *OC(Z(IWKBPT)), ALLOC(Z(IWKBWT)),  DELTR, DELTIM, THETA, THETC, RHO
     *T, ROTC, DUEFF )                                                  
      IF((DELTR.NE.5.D0).OR.(DELTIM.NE.5.D0)) GO TO 250                 
      WRITE(6,213)
  213 FORMAT( '0**** ERROR RETURN IN LCRITL FROM SWKB ')                
      GO TO 640                                                         
  250 ALLOC(LCTP+I) = RHOT                                              
      ALLOC(LCTPC+I) = ROTC                                             
      AMPL = 0                                                          
      IF ( DELTIM .LT. 20 ) AMPL = DEXP(-2.D0*DELTIM)                   
      ALLOC(LAMP+I) = AMPL                                              
      AMPMIN = DMIN1( AMPMIN, AMPL )                                    
      IF(THETA.GT.THETC) THETA = THETC                                  
      ALLOC(LDEFL+I) = THETA                                            
      ALLOC(LDNUC+I) = 2*DELTR                                          
      IF ( RHOT .GE. ROEND ) GO TO 280                                  
C                                                                       
C     CHECK ON THE PROGRESS OF THE DEFLECTION FUNCTION                  
C                                                                       
      IF ( AMPL .LT. .05 .OR. I .EQ. 1 ) GO TO 299                      
      IF ( MINSW ) GO TO 260                                            
      MINSW = THETA .GT. ALLOC(LDEFL+I-1)+EPS                           
      GO TO 299                                                         
 260  IF ( THETA .GT. ALLOC(LDEFL+I-1)-EPS ) GO TO 299                  
C                                                                       
C     DEFLECTION FUNCTION IS FALLING FROM A MAX AFTER A MIN.            
C     IF !S! IS CLOSE TO 1 WE STOP                                      
C                                                                       
      IF ( AMPL .LT. .95+.05*AMPMIN ) GO TO 299                         
 280  LMAX = L                                                          
      GO TO 300                                                         
 299  CONTINUE                                                          
C                                                                       
 300  NOLS = LMAX-LMIN+1                                                
C                                                                       
C     PRINT WKB PHASES AND CLASSICAL DEFLECTION FUNCTION                
C                                                                       
      IF(IPRINT.EQ.0) GO TO 500                                         
      WRITE(6,303)
  303 FORMAT(5X,'---  WKB S-MATRIX ELEMENTS AND CLASSICAL TPS ---'/ 
     *1X,' L ',4X,' AMP(S(L))  ',4X,' ARG(S(L))  ',4X,' DEFL.ANGLE ', 4X
     *,'CLASSICAL TP',4X,'  COULOMB TP')                                
      DO 349 I = 1,NOLS                                                 
      L = LMIN+I-1                                                      
      CTR = ALLOC(LCTP+I)/FK                                            
      CTRC = ALLOC(LCTPC+I)/FK                                          
      AMP = ALLOC(LAMP+I)                                               
      DNUC = ALLOC(LDNUC+I)                                             
      DEFL = ALLOC(LDEFL+I)                                             
      WRITE(6,343)L,AMP,DNUC,DEFL,CTR,CTRC                                
  343 FORMAT(1H , 1X, I3, G16.5, G16.5, 3(G16.5))                       
 349  CONTINUE                                                          
C                                                                       
C     ESTIMATE CRITICAL L FROM PHASE-SHIFTS AND DEFLECTION FN           
C                                                                       
 500  MINSW = .FALSE.                                                   
      AMPMIN = 0.5*(AMPMIN+1.)                                          
C                                                                       
      DO 599 I = 1, NOLS                                                
      I1 = NOLS-I+1                                                     
      L = LMAX +1 - I                                                   
      IF ( DLSMAT .NE. 0 ) GO TO 550                                    
      IF ( ALLOC(LAMP+I1) .GT. AMPMIN ) GO TO 550                       
C                                                                       
C     !S! < .5*(MIN(!S!)+1).  INTERPOLATE UNLESS LAST POINT             
C                                                                       
      IF ( AMPMIN .GT. .99 ) GO TO 550                                  
      IF ( I .GT. 1 ) GO TO 520                                         
      WRITE(6,513) LMAX, ALLOC(LAMP+I1)                                   
 513  FORMAT ( ' **** LCRITL PICKED LMAX TOO SMALL TO FIND',  ' !S! > .5
     **(MIN(!S!)+1):', I5, G15.5,  '  LCRIT SET TO LMAX' )              
      DLSMAT = LMAX                                                     
      GO TO 550                                                         
C                                                                       
 520  DLSMAT = L + (AMPMIN-ALLOC(LAMP+I1))/(ALLOC(LAMP+I1+1)  -ALLOC(LAM
     *P+I1))                                                            
C                                                                       
C     LOOK FOR OUTERMOST MINIMUM OF DEFLECT FUNCTION                    
C                                                                       
 550  IF ( DLDFLC .NE. 0 .OR. L .EQ. LMAX ) GO TO 599                   
      IF ( MINSW ) GO TO 560                                            
      MINSW = ALLOC(LDEFL+I1) .LT. ALLOC(LDEFL+I1+1)-EPS                
      GO TO 599                                                         
C     HAVE WE PASSED A MINIMUM                                          
 560  IF ( ALLOC(LDEFL+I1) .LT. ALLOC(LDEFL+I1+1)+EPS ) GO TO 599       
      C = ALLOC(LDEFL+I1) - 2*ALLOC(LDEFL+I1+1)  + ALLOC(LDEFL+I1+2)    
      DLDFLC = L + 1 + (ALLOC(LDEFL+I1)-ALLOC(LDEFL+I1+2))/(2*C)        
C                                                                       
 599  CONTINUE                                                          
C                                                                       
      LC1 = DLSMAT + .5                                                 
      LC2 = DLDFLC + .5                                                 
      LC = MAX0( LC1, LC2 )                                             
C                                                                       
      IF(IPRINT.NE.0) WRITE(6,623) DLSMAT, DLDFLC, LC                     
  623 FORMAT(3X,'--- 1/2 POINT OF !S(L)!  =  ',G15.5,  5X, 'MINIMUM 
     *OF DEFLECTION FUNC =', G15.5,  5X, 'L CRIT =', I5 )               
 640  IF ( DLSMAT .NE. 0 .OR. DLDFLC .NE. 0 ) GO TO 700                 
      LC = ROW + .5                                                     
      WRITE(6,643) LC, RCL                                                
 643  FORMAT ( '0**** NO CRITICAL L FOUND; SET LC =', I5,  ' = L FOR WHI
     *CH CLASSICAL COULOMB TURNING POINT =', F10.3 )                    
C                                                                       
C     FREE ALLOCATOR AREAS                                              
C                                                                       
 700  Z(IWKBPT) = -Z(IWKBPT)                                            
      Z(IWKBWT) = -Z(IWKBWT)                                            
      Z(ISEMIC) = -Z(ISEMIC)                                            
      Z(ICUBIC) = -Z(ICUBIC)                                            
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE LINLSQ ( IFUNC,N,XVALS,SVALS,CVAL,AVAL,B,CHI,PBUGSW )  
C                                                                       
C     TWO-TERM LINEAR LEAST-SQUARES FIT                                 
C                                                                       
C     FINDS AVAL AND CVAL SUCH THAT                                     
C        F(X) = AVAL + CVAL*F2(X)                                       
C     WHERE F AND F2 ARE:                                               
C                                                                       
C     IFUNC    F2        F          USED FOR                            
C       1      -X      LN(S)      S = A*EXP(-C*L)                       
C       2    EXP(B*X)   1/S       S = 1/(A + C*EXP(B*L) )               
C       3     LN(X)    LN(S)      S = A/L**C                            
C       4       X      S/X**B     S = (A + C/L)/L**B                    
C       5      X**B     S         PHASE(S) = A + C/L**B                 
C                                NOTE THAT LINTRP THEN REVERSES         
C                                THE NAMES A=CP, C=AP.                  
C                                                                       
C     NOTE THAT IN THE FIRST TWO FORMS  X IS L-LBAR  WHILE              
C     IN THE LAST THREE IT IS LBAR/L.                                   
C                                                                       
C     THE LEAST-SQUARES FIT IS WEIGHTED BY 1/F**2                       
C                                                                       
C     THERE ARE N INTEGRALS TO BE FITTED                                
C                                                                       
C     THIS IS A LINEAR LEAST SQUARES PROBLEM SOLVED BY                  
C     MATRIX INVERSION                                                  
C                                                                       
C     MHM - 9/1/76                                                      
C     2/15/80 - USE  SCAL  TO AVOID UNDERFLOW (DELTA ^ \S\**4) - RPG    
C     4/11/80 - ADD IFUNC AND VARIOUS FUNCTION FORMS; REMOVE            
C               TEST ON A<0 - S.P.                                      
C     5/6/80 - TYPE 5. - S.P.                                           
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      DIMENSION XVALS(N),SVALS(N)                                       
C                                                                       
CDC      ALLOCLEVEL XVALS, SVALS                                        
C                                                                       
      LOGICAL PBUGSW                                                    
C                                                                       
      G1=0                                                              
      G2=0                                                              
      G11=0                                                             
      G12=0                                                             
      G22=0                                                             
C                                                                       
C     SCALE THE S MATRIX ELEMENTS BY THE AVERAGE OF THE FIRST TWO       
C     TO AVOID UNDERFLOW.                                               
C                                                                       
      SCAL = 1                                                          
      IF ( IFUNC .EQ. 2 .OR. IFUNC .EQ. 4 )  SCAL = .5 * (SVALS(1)+SVALS
     *(2))                                                              
      IF ( IFUNC .EQ. 4 ) SCAL = (.5*(XVALS(1)+XVALS(2)))**B / SCAL     
      DO 299 I=1,N                                                      
      X = XVALS(I)                                                      
      S = SVALS(I)                                                      
C                                                                       
      GO TO ( 110, 120, 130, 140, 150 ), IFUNC                          
C                                                                       
 110  F2 = -X                                                           
      F = DLOG(S)                                                       
      GO TO 200                                                         
C                                                                       
 120  F2 = DEXP( B*X )                                                  
      F = 1/S                                                           
      GO TO 200                                                         
C                                                                       
 130  F2 = DLOG(X)                                                      
      F = DLOG(S)                                                       
      GO TO 200                                                         
C                                                                       
 140  F2 = X                                                            
      F = S/X**B                                                        
      GO TO 200                                                         
C                                                                       
 150  F2 = X**B                                                         
      F = S                                                             
C                                                                       
 200  F = SCAL*F                                                        
      WT = 1/F**2                                                       
C                                                                       
      G1=G1+WT*F                                                        
      G2=G2+WT*F*F2                                                     
      G11=G11+WT                                                        
      G12=G12+WT*F2                                                     
      G22=G22+WT*F2*F2                                                  
 299  CONTINUE                                                          
C                                                                       
      DELTA=G11*G22-G12*G12                                             
      A=(G22*G1-G12*G2)*(1/(SCAL*DELTA))                                
      C=(G11*G2-G12*G1)*(1/(SCAL*DELTA))                                
C                                                                       
C     THIS IS REALLY  CHISQ * SCAL**2                                   
C                                                                       
      CHI = N - ( A*G1 + C*G2 )* SCAL                                   
      AVAL = A                                                          
      CVAL=C                                                            
      IF ( PBUGSW ) WRITE(6,403) B, AVAL, CVAL, CHI, SCAL                 
 403  FORMAT ( ' LINLSQ:', G16.9, 2G14.6, G16.9, G11.2 )                
      RETURN                                                            
      END                                                               
      SUBROUTINE LINTRP                                                 
C                                                                       
C     INTERPOLATION AND EXTRAPOLATION IN L OF THE REACTION S-MATRICES   
C                                                                       
C     THIS SUBROUTINE TAKES S-MATRIX ELEMENTS S(LI,LO,LX)               
C     COMPUTED AT A SET OF VALUES OF LI SPACED BY LSTEP, AND            
C     ALL POSSIBLE (LO,LX) VALUES FOR EACH LO CONSISTENT WITH           
C     A.M. AND PARITY SELECTION RULES ,FITS THOSE S(LI,LO,LX) WITH      
C     CONTINUED FRACTIONS (ONE FOR EACH LX AND  LO-LI)                  
C     THEN USES THIS REPRESENTATION TO FILL IN THE SPACES               
C                                                                       
C     THE CONTINUED FRACTION IS USED FROM LMIN TO LMAX                  
C     THEN IT IS ASSUMED THAT THE MAGNITUDE OF S(L)                     
C     IS DESCENDING TOWARD ZERO EXPONENTIALLY                           
C     I.E.  S(L)  = A / (1 + C * EXP (B*L) )  FOR LARGE L               
C     THE CONSTANTS A ,B AND C ARE FIXED BY A LEAST SQUARES FIT         
C     TO THE LAST FEW INTEGRALS (AT LEAST 3) UP TO LMAX                 
C                                                                       
C     LARGE-L PHASES ARE REPRESENTED BY A * ( SUM OF ELASTIC PHASES)    
C                                                                       
C     THE EXPONENTIAL IS THEN USED TO CONTINUE S(L) OUT TO LIMOST       
C     (THE SMALLEST L SUCH THAT !S(L)!  IS LESS THAN BOTH               
C     MAX(!S(L)!)/500 AND MIN( (!S(L)!)/5 (FOR L LESS                   
C     THAN LPEAK))                                                      
C     FOR INELASTIC EXCITATION, LIMOST WAS PREVIOUSLY DETERMINED BY     
C     ANGSET BASED ON THE ASYMPTOTIC (IN L) FORM OF THE COULOMB         
C     INTEGRALS AND IS NOT CHANGED HERE.                                
C                                                                       
C     8/1/75 - MHM                                                      
C     8/11/75 - USE WOODS SAXON FORM FOR EXTRAPOLATION - S.P.           
C     8/28/75 - FIT ONLY TO THE INELDC COMPUTED STUFF                   
C     9/2/75 - TURN INSIDE OUT TO BE CORRECT, ADD MAXLEXTRAP            
C     4/28/76 - CHANGE DEBUG CONTROL; GO ON EVEN AFTER ERROR            
C     9/3/76 - FIX ERRORS FOR LMIN = 0;  ALWAYS PRINT SUMMARY           
C     9/10/76 - COMPLETE REWRITE OF EXTRAPOLATION - MHM                 
C     9/26/76 - TOTAL SKIP OF EXTRAP FOR MAXLEXTRAP=0 - SP              
C     9/30/76 - DO NOT INCLUDE 2L+1 IN DETERMINING HOW FAR TO           
C               EXTRAPOLATE; SMALL CLEANUP; CHANGE SIGN OF DEL - S.P.   
C     12/26/76 - INELASTIC SCATTERING                                   
C     12/30/76 - EXPRESS WOODS-SAXON INTERMS OF L(WS) INSTEAD OF C      
C     4/19/77 - MORE EFFORTS TO AVOID OVERFLOWS                         
C     2/6/78 - EXTRAPOLATION OF ELASTIC MADE SAFER - S.P.               
C     4/21/78 - EXTRAPOLATE EXCITATION; DON'T NEEDLESSLY REDEFINE       
C               ELASTIC ARRAYS - S.P.                                   
C     4/24/78 - REVERSE LI AND LO - S.P.                                
C     4/26/78 - NO COULOMB PHASES; DEFINE COMPLEX "I" ARRAY - S.P.      
C      4/27/78 - DON'T EXTRAPOLATE PAST 1E-30 - S.P.                    
C     10/18/78 - MULTIPLY BETABAR INTO FF CORRECTION FOR COUPL2         
C     3/6/79 - NO MORE BETABAR DUE TO S-MATRICES - S.P.                 
C              INTERPOLATE ELASTIC S-MATRIX; AVOID UNDERFLOWING         
C              IMAG(S-ELASTIC)                                          

C     3/25/79 - EXTRAPOLATION OF S(EL) FOR COUPLED CHANS - S.P.         
C     5/10/79 - FIX TRANSFER ERROR IN ABOVE - S.P.                      
C     4/12/79 - IMPROVED S(EL) EXTRAPOLATION - S.P.                     
C     7/26/79 - STANDARD PREFIXES ETC, MANY CHANGES FOR                 
C        SPIN-ORBIT, MULTIPASS, ETC. - RPG                              
C     11/3/79 - FIXUP INELASTIC CALCS IN BOB'S VERSION - S.P.           
C               INTRODUCE EXTRA FACTOR OF I IN INELASTIC S - S.P.       
C     11/20/79 - S-MATRICES STORED BY LO-LI - S.P.                      
C     11/22/79 - USE (2L+1)!S(L)! DO DETERM HOW FAR TO EXTRAP - S.P.    
C     1/16/80 - USE BIGNUM, BIGLOG - RPG                                
C     3/26/80 - C.C. VERSION; OUTPUT IS REAL*4; RENUMBER - S.P.         
C     4/7/80 - USE INTRCF SUBROUTINE; DO NOT USE LI<LXMAX INPUT - S.P.  
C     4/12/80 - USE LXTRP1, LXTRP2; POWER EXTRAPOLATIONS - S.P.         
C               ALWAYS USE 4 INPUT VALUES TO THE EXTRAP FIT - S.P.      
C     4/26/80 - PBUGSW NOT IN WAVCOM - S.P.                             
C     4/30/80 - SKIP ELAS PHASE EXTRAP WHEN ONLY NOISE - S.P.           
C     5/6/80 - EXTRAP PHASES BY POWERS WHEN IFUNC=2 - S.P.              
C     5/9/80 - FIX BLUNDER IN 339 LOOP -- HOW DID IT WORK? - S.P.       
C     7/2/80 - USE NCHN, NOT MCHN, IN 979 LOOP - S.P.                   
C     7/17/80 - REMOVE ,, IN FORMAT - S.P.                              
C     7/31/80 - CALL SETLOG - S.P.                                      
C     8/4/80 - IVDEP'S FOR CRAY - S.P.                                  
C     8/8/80 - DEFINE MWORK FOR MAXLEXTRAP = 0 - S.P.                   
C     9/23/80 - FIX BORN ADD-BACK FOR EXTRA (-)**LX - S.P.              
C     9/25/80 - GET LIMOST FROM CHNDEF; MARK'S ATAN; LXTRPM - S.P.      
C     9/29/80 - GRIND OUT TO SMLNUM - S.P.                              
C     7/12/81 - USE DELTA S ARRAYS FOR C.C. EXTRAPOLATION - S.P.        
C     10/28/81 - BORN S REQUIRES ROOT 2 FOR IDENTICAL - S.P.            
C     1/27/82 - FIX BUG WHEN A, AI NOT DEFINED - 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 /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      COMMON /FORMF/ IBDS(2), NPOTS(2), LBP, LBT, NBP, NBT, JBP, JBT, BN
     *DMAX(2), BNDSTP(2), NSTPBD(2), RBNDS(2), ABNDS(2), RCBNDS(2), BNDM
     *AS(2), BRATMS(2), RSOBDS(2), ASOBDS(2), VBNDS(2), VSOBDS(2), TAUBD
     *S(2), LNKADB(6,2,12)                                              
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      LOGICAL ONELSW, IDENSW                                            
      COMMON /INELCM/ JBPF,JBTF,LXMIN,LXMAX,ILILOR,ILILOI,MSTOP,IA12M, 
     *NMLOLX,ONELSW,NUMLX,IRDINT,IELCUP,LILOSZ,NUMLIS,ILIS,IBETAS(4), 
     *ICL2FF,LXSTEP,IDENSW,LSKIP,JPMIN,JPMAX,JPBASE,NJP,JTMIN,JTMAX, 
     *JTBASE,NJT,IINDXS,ISMATR,ISMATI,NSMAT,NLX,NSPLI,ITOCS,NASPLI, 
     *IUNITR,LIFIT,ILIFIT,NOLFIT,IDELSR,IDELSI
      INTEGER INDXJS(4,2)                                               
      EQUIVALENCE ( INDXJS(1,1), JPMIN )                                
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      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
     *) )                                                               
      CHARACTER*8 NAMES                                                 
      COMMON /NAMCOM/ NAMES(1)                                          
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      LOGICAL PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
      COMMON /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
      COMMON /GRIDCM/ RCUEFF, GRDCM1(2), IBINDX, MBINDX, NBINDX, NMFFAC,
     * MXLXGS, NMBFAC, IINHR, IINHI, IRHSR, IRHSI, INUCH, ICOULH, ILOR, 
     *ILOI, ILIR, ILII, NPTMIN, NOFLO, NUMPT, NCRIT, ISMX, ISMSQ, IPADE,
     * IHOMO, ISMTSV, IRPTS4, IRPTS, IGRDC4(5), IDW, IGRDC5(2), IABS1, I
     *GRDC6(2), GRDCM2, IGRDC7(2), IRWTS, IGRDC8(2), ICL1FF, ICL1FG, ICL
     *1GF, ICL1GG                                                       
C                                                                       
	COMPLEX*16 CFLI
C                                                                       
C                                                                       
C     NOTE:  LDEL = LO - LI                                             
C                                                                       
C                                                                       
      LOGICAL BADSW, XTRPSW, TRANSW, BIGRSW, IMAGSW, INVRSW, CCSW       
      LOGICAL PBUGSW                                                    
	COMPLEX*16 CTEMP
C                                                                       
      CHARACTER*2 WRDS(2)                                               
      DATA WRDS/'RE', 'IM'/                                             
      CHARACTER*8 XWORDS(2,6)                                           
      DATA XWORDS/'WOODS-SA', 'XON', 'POWER-LA', 'W', 'POWER-LA', 'W 2',
     * 'WKB POWE', 'R-LAW', 'LEXTRAP4', ' ', 'LEXTRAP5', ' '/           
C                                                                       
C     MWORK IS THE NUMBER OF ENTRIES PER LX, LDEL IN THE                
C     EXTRAPOLATION WORK TABLE.                                         
C                                                                       
      DATA MWORK / 12 /                                                 
C                                                                       
      TRANSW = ISTRIP .NE. 0                                            
      IPRNT = MOD( IPRINT, 10 )                                         
      PBUGSW = MOD(IPRINT/100, 10) .GE. 4                               
      CCSW = PROBLM .EQ. 24                                             
C                                                                       
      XTRPSW = MAXLEX .GT. 0                                            
C                                                                       
      WRITE(6,13) REACT, ELAB, HEADER                                     
 13   FORMAT ( X, T60, 'P T O L E M Y' /  T48, 'INTERPOLATION AND EXTR
     *APOLATION IN L' /  X, 45A1, 'ELAB =', F7.2, ' MEV', 5X, 65A1 / )
     *                                                                  
C                                                                       
      WRITE(6,17) XWORDS(1,IEXTYP), XWORDS(2,IEXTYP)                      
 17   FORMAT ( ' USING ', A8, A8, 'EXTRAPOLATION FUNCTIONS.' )          
C                                                                       
      DLMAX = LMAX                                                      
      LIPREV = LIMOST                                                   
      IF (TRANSW) LIMOST = LMAX                                         
C     THESE 2 WORK AREAS ARE USED FOR CONTINUED-FRACTION INTERPOLATION. 
      ICL = NALLOC( 2*NUMLIS, 'CMPLXLS ' )                              
      ICINTS = NALLOC( 2*NUMLIS, 'CMPLXIS ' )                           
      IF ( .NOT. XTRPSW ) GO TO 90                                      
C                                                                       
C     "LWORK" WILL CONTAIN EXTRAPOLATION PARAMETERS.                    
C     "FITLS" WILL CONTAIN A LIST OF L'S TO BE USED FOR EXTRAPOLATION.  
C     "FITIS" WILL CONTAIN THE CORRESPONDING !S!'S.                     
C                                                                       
      IWORK = NALLOC( MWORK*NASPLI, 'LWORK ' )                          
      ILVALS = NALLOC( 2*NOLFIT, 'FITLS ' )                             
      IXINTS = NALLOC( 2*NOLFIT, 'FITIS ' )                             
      CALL INIT8 ( IWORK, 0.D0 )                                        
C                                                                       
C     ALLOCATION IS FINISHED FOR NOW.                                   
C                                                                       
      LTOCS = Z(ITOCS)*FACFR4 - FACFR4                                  
      LLIS = FACFR4*Z(ILIS)-FACFR4                                      
      LWORK = Z(IWORK) - MWORK                                          
      LLVALS = Z(ILVALS)-1                                              
      LLVAL2 = LLVALS+NOLFIT                                            
      LXINTS=Z(IXINTS)-1                                                
      LXINT2 = LXINTS+NOLFIT                                            
C                                                                       
      WRITE(6,83) LIFIT, LMAX                                             
 83   FORMAT (' EXTRAPOLATION AND CONTINUED FRACTION OVERLAP',  ' REGIO
     *N:', I4, ' < LI <', I4 / )                                        
C                                                                       
C     POSSIBLY SETUP FOR MULTIPLE CHANNELS                              
C                                                                       
 90   NCHNDF = 2                                                        
      KSMAT = 0                                                         
      KSMAT2 = 0                                                        
      JMOST = 0                                                         
      IF ( .NOT. CCSW ) GO TO 100                                       
      LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      NCHNDF = ILLOC(LCHNDF)                                            
      MCHNDF = ILLOC(LCHNDF+1)                                          
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2) + MCHNDF                        
      LTOCSV = LTOCS                                                    
      LBINDX = FACFR4*(Z(IBINDX)-1)                                     
C                                                                       
C                                                                       
C     LOOP OVER ALL CHANNELS FOR C.C. CALCULATIONS                      
C     AND OVER ALL VALUES OF JT, JP, LX,                                
C     AND OVER ALL VALUES OF DEL=LO-LI FOR EACH LX                      
C                                                                       
C     FIRST PASS ;                                                      
C                                                                       
C     FIT WOODS SAXON AND DETERMINE LIMOST                              
C                                                                       
C                                                                       
C                                                                       
 100  DO 299 NCHN = 2, NCHNDF                                           
      MCHN = NCHN                                                       
      LMAXL = LMAX                                                      
      IF ( .NOT. CCSW ) GO TO 110                                       
C                                                                       
      MCHN = ILLOC(LCHNDF)                                              
      ETAS(2) = ALLOC4(LCHNDF+5)                                        
      KSMAT = ILLOC(LCHNDF+9)                                           
      NSPLI = ILLOC(LCHNDF+10)                                          
      LTOCS = LTOCSV + ILLOC(LCHNDF+12)                                 
C                                                                       
C     CHECK TO SEE FI THERE ARE FIRSTORDER COULOMB COUPLINGS            
C     TO THE G.S.  IF NOT THEN DO NOT FORCE EXTRAPOLATION               
C     TO LIMOST.  IF SO USE ALREADY DETERMINED LIMOST.                  
C                                                                       
      LIMOST = ILLOC(LCHNDF+14)                                         
      IF ( LIMOST .EQ. NOTDEF ) LIMOST = LMAX                           
C                                                                       
 110  IF ( .NOT. XTRPSW ) GO TO 290                                     
C                                                                       
C                                                                       
      DO 289 KOFFS = 1, NSPLI                                           
      JT = ILLOC(LTOCS+4*KOFFS)                                         
      IF ( JT .LT. 0 ) GO TO 289                                        
      JP = ILLOC(LTOCS+4*KOFFS-1)                                       
      LX = ILLOC(LTOCS+4*KOFFS-2)                                       
      LDEL = ILLOC(LTOCS+4*KOFFS-3)                                     
      LDELSR = Z(IDELSR) + ( KOFFS + KSMAT - 1 )                        
      LDELSI = Z(IDELSI) + ( KOFFS + KSMAT - 1 )                        
C                                                                       
C        LOCATE L-PEAK AND CHECK FOR DECAYING FORM OF S.                
C         THIS IS IN TERMS OF DELTA S                                   
C                                                                       
 120  LPEAK=LMIN                                                        
      BIGBOY=0                                                          
      BADSW = .FALSE.                                                   
C                                                                       
      DO 179 ILI=1,NUMLIS                                               
      LI=ILLOC(LLIS+ILI)                                                
      LO = LI + LDEL                                                    
      IF ( LO+LI .LT. LX ) GO TO 179                                    
      IADD=(ILI-1)*NSPLI                                                
      RE = ALLOC(LDELSR+IADD)                                           
      HIM = ALLOC(LDELSI+IADD)                                          
      SIZE = RE**2 + HIM**2                                             
      IF ( LI .LT. LIFIT ) GO TO 170                                    
      SIGNR = SIGN( 1.D0, RE )                                          
      SIGNI = SIGN( 1.D0, HIM )                                         
      IF(LI.EQ.LIFIT) GO TO 160                                         
      IF ( SIZLAS .GT. SIZE ) GO TO 155                                 
      BADSW = .TRUE.                                                    
      B = DSQRT(SIZE)                                                   
      C = DSQRT(SIZLAS)                                                 
      WRITE(6,153) MCHN, JP, JT, LX, LDEL, LI, B, C                       
 153  FORMAT ('***** ERROR:  CANNOT EXTRAPOLATE FOR ',  'CHANNEL', I3, 2
     *X,  '(JP,JT,LX,LO-LI) = (', 2(I3,'/2'), I2, I3, ') ****' /  ' ****
     *', 9X, 'SINCE FOR LI =', I4,  ' !S! EXCEEDS PREVIOUS:', 2G11.4, ' 
     *****' )                                                           
      GO TO 160                                                         
 155  IF ( SIGNR .NE. SIGNRL .OR. SIGNI .NE. SIGNIL ) WRITE(6,157) MCHN, 
     *JP, JT, LX, LDEL, LI                                              
  157 FORMAT( '***** WARNING:  PHASE OF S(L) FOR ',  'CHANNEL', I3, 2X, 
     * '(JP,JT,LX,LO-LI,LI) = (', 2(I3,'/2'),I3,1X,I3,1X,I3,  ') HAS FLU
     *CTUATING SIGN' )                                                  
 160  SIZLAS = SIZE                                                     
      SIGNRL = SIGNR                                                    
      SIGNIL = SIGNI                                                    
 170  SIZE = (2*LI+1)*SIZE                                              
      IF(SIZE.LT.BIGBOY) GO TO 179                                      
      LPEAK=LI                                                          
      BIGBOY=SIZE                                                       
  179 CONTINUE                                                          
C                                                                       
C        HAS EXTRAPOLATION BEEN SUPPRESSED FOR THIS ( LX, DELTA )       
C                                                                       
      IF ( BADSW ) GO TO 289                                            
C                                                                       
C        LOCATE MINIMAL (2LI+1)\S\**2 FOR LI < LPEAK                    
C                                                                       
      WEEBOY=1.E+06                                                     
C                                                                       
      DO 189 ILI=1,NUMLIS                                               
      LI=ILLOC(LLIS+ILI)                                                
      LO = LI + LDEL                                                    
      IF ( LO+LI .LT. LX ) GO TO 189                                    
      IF(LI.GT.LPEAK) GO TO 189                                         
      IADD=(ILI-1)*NSPLI                                                
      SIZE=(ALLOC(LDELSR+IADD)**2+ALLOC(LDELSI+IADD)**2)                
      SIZE = (2*LI+1)*SIZE                                              
      IF(SIZE.GT.WEEBOY) GO TO 189                                      
      WEEBOY=SIZE                                                       
  189 CONTINUE                                                          
C                                                                       
C     WE EXTRAPOLATE TILL SQRT(2LI+1)!S(L)! HAS FALLEN TO WEEBOY        
C     WHICH WE USE AS THE MINIMUM OF                                    
C       .2*MIN( SQRT(2L+1)!S! ),  DWCUTOFF*MAX( SQRT(2L+1)!S! )         
C                                                                       
C                                                                       
      WEEBOY=.2*SQRT(WEEBOY)                                            
      BIGBOY= DWCUT*SQRT(BIGBOY)                                        
      WEEBOY = DMIN1( WEEBOY, BIGBOY )                                  
C                                                                       
C     FIT WOODS-SAXON FORM   AA / (1 + C * EXP(B*LI) ) IN L             
C     TO MODULI !S(L)! OF REACTION S-MATRICES                           
C     OR FIT POWER LAW OR OTHER SPECIFIED EXTRAP FUNCIION.              
C                                                                       
      DO 209 ILI=ILIFIT,NUMLIS                                          
      I=ILI-ILIFIT+1                                                    
      ALLOC(LLVALS+I)=ILLOC(LLIS+ILI)                                   
      ALLOC(LLVAL2+I) = ILLOC(LLIS+ILI)                                 
      IADD=(ILI-1)*NSPLI                                                
      F=DSQRT(ALLOC(LDELSR+IADD)**2+ALLOC(LDELSI+IADD)**2)              
      ALLOC(LXINTS+I)=F                                                 
      F = DATAN2( ALLOC(LDELSI+IADD), ALLOC(LDELSR+IADD) )              
      ALLOC(LXINT2+I) = F                                               
 209  CONTINUE                                                          
      CALL LXTRP1 ( IEXTYP,NOLFIT,ISIG,IPRNT,ALLOC(LLVALS+1),  ALLOC(LXI
     *NTS+1), FLCRIT, AA, WID, .30D0, 1.D-5,  BARL, BARA, B, BARC, DLMAX
     *, CHISQ, LX, LDEL, ETAS,  MCHN, JP, JT )                          
      IF(ISIG.GE.0) GO TO 220                                           
 212  WRITE(6,213) MCHN, JP, JT, LX, LDEL                                 
  213 FORMAT(3X,'**** ERROR RETURN FROM L-EXTRAP SUBROUTINE'/  3X, '
     *CHANNEL', I3, 2X,  7X, 'EXTRAPOLATION SUPPRESSED FOR (JP,JT,LX,LO-
     *LI)=(',  2(I3,'/2'), 2I4, ') ')                                   
      BADSW=.TRUE.                                                      
      GO TO 289                                                         
  220 IF(ISIG.NE.0) WRITE(6,223) MCHN, JP, JT, LX, LDEL                   
  223 FORMAT(3X,'SIMPLE EXP OR POWER  USED FOR !S(L)! ',  3X, 'CHANN
     *EL', I3, 2X,  '(JP,JT,LX,LO-LI)=(', 2(I3, '/2'), 2I4, ')' )       
C                                                                       
C                                                                       
C     FOR POWER LAW EXTRAP, USE A POWER LAW FOR THE PHASES              
C                                                                       
 240  IF ( IEXTYP .EQ. 1 ) GO TO 250                                    
      CALL LXTRP1 ( 3, NOLFIT, ISIG, IPRNT, ALLOC(LLVAL2+1),  ALLOC(LXIN
     *T2+1), X, Y, X2, .30D0, 1.D-5,  X3, CP, BP, AP, DLMAX, CHISQ, LX, 
     *LDEL, ETAS,  MCHN, JP, JT )                                       
      IF ( ISIG .GE. 0 ) GO TO 250                                      
      WRITE(6,241)
 241  FORMAT ('0**** FOLLOWING REFERS TO PHASE EXTRAP.' )               
      GO TO 212                                                         
C                                                                       
C                                                                       
C     NOW FIND LIMOST                                                   
 250  LI = LXTRPM( IEXTYP, BARA, B, BARC, BARL, DLMAX, LX,  LDEL, ETAS, 
     *WEEBOY )                                                          
      IF (PBUGSW) WRITE(6,263) MCHN, JP, JT, LX, LDEL, LI                 
 263  FORMAT ( ' FOR CHANNEL', I3, 3X,  ' FOR 2*JP, 2*JT, LX, LO-LI =', 
     *4I3, 3X,  'ESTIMATED LARGEST SIGNIFICANT LI IS', I4 )             
      LMAXL = MAX0( LMAXL, LI )                                         
C                                                                       
C        SAVE STUFF FOR LATER                                           
C                                                                       
C        ALLOC(LAREA)  CONTENTS                                         
C          +0          A = NUMERATOR OF W.S.                            
C           1          B = INVERSE WIDTH OF W.S.                        
C           2          BARL = ACTUAL PARAMETER FOR GENERALIZED W.S.     
C           3          LC = L(1/2) OF W.S.                              
C           4          AP = NORM OF PHASE EXTRAP.                       
C           5          CP = 0 OR PI FOR PHASE EXTRAP                    
C           6          BARA = ACTUAL PARAMETER FOR GENERALIZED W.S.     
C           7          BARC = ACTUAL PARAMETER FOR GENERALIZED W.S.     
C           8          LMAX AS PREDICTED BY W.S.                        
C           9          LPEAK                                            
C          10          PEAK VALUE                                       
C          11          BP = POWER OF PHASE EXTRAP                       
C                                                                       
      LAREA = LWORK + MWORK*KOFFS                                       
      ALLOC(LAREA) = AA                                                 
      ALLOC(LAREA+1) = B                                                
      ALLOC(LAREA+2) = BARL                                             
      ALLOC(LAREA+3) = FLCRIT                                           
      ALLOC(LAREA+4) = AP                                               
      ALLOC(LAREA+5) = CP                                               
      ALLOC(LAREA+6) = BARA                                             
      ALLOC(LAREA+7) = BARC                                             
      ALLOC(LAREA+8) = LI                                               
      ALLOC(LAREA+11) = BP                                              
C                                                                       
C        END OF FIRST LOOP ON JP, JT, LX, AND LO-LI                     
C                                                                       
 289  CONTINUE                                                          
C                                                                       
C     COMPUTE SIZE REQUIREMENTS OF THIS CHANNEL                         
C     IF LIMOST HAS BEEN PICKED BY COULOMB BORN EXTRAP, WE CANNOT       
C     CHANGE IT NOW.                                                    
C                                                                       
  290 IF ( LIMOST .LE. LMAX ) LIMOST = MIN0( LMAXL, LMAX+MAXLEX )       
      JMOST = MAX0( JMOST, LIMOST )                                     
      LNSMAT = NSPLI*(LIMOST-LMIN+1)                                    
      IF ( .NOT. CCSW ) GO TO 295                                       
      ILLOC(LCHNDF+13) = KSMAT2                                         
      ILLOC(LCHNDF+14) = LIMOST                                         
C                                                                       
C     POSSIBLY GO ON TO NEXT CHANNEL                                    
C                                                                       
      LCHNDF = LCHNDF + MCHNDF                                          
      LWORK = LWORK + MWORK*NSPLI                                       
C                                                                       
 295  KSMAT2 = KSMAT2 + LNSMAT                                          
C                                                                       
 299  CONTINUE                                                          
C                                                                       
      LILOSZ = KSMAT2                                                   
C                                                                       
C     ALLOCATE SPACE FOR REACTION S-MATRICES TO XSECTN                  
C                                                                       
      I1 = 2*LILOSZ                                                     
      IRDINT = NALLOC( I1/FACFR4, 'S ' )                                
      IUNITR = NALLOC( (JMOST-LMIN+2)/FACFR4, 'UNITARIT' )              
      CALL INIT4 ( IUNITR, 0. )                                         
      CALL INIT4 ( IRDINT, 0. )                                         
      BIGRSW = TRANSW .OR. JMOST .GT. LIPREV                            
C                                                                       
C     EXTEND ARRAYS OF ELASTIC S-MATRIX ELEMENTS OUT TO                 
C     MAXIMUM L-S NEEDED IN TRANSFER CALCULATION                        
C     USING BORN APPROXIMATION L-DEPENDENCE WHICH IS                    
C                                                                       
C        S(L) = EXP( -2 I DELTA(L) )                                    
C        DELTA(L) = DELTA(LMAX) * EXP( -(RT(L)-RT(LMAX))/A' )           
C     WHERE                                                             
C        RT = ( ETA + SQRT(L(L+1)+ETA**2) ) / K  =  TURNING POINT       
C        A' = A      FOR RE(DELTA)                                      
C           = AI (OR ASI)  FOR IM(DELTA)                                
C           IS THE DIFFUSNESS OF THE RELEVANT POTENTIAL.                
C                                                                       
C     NOTE THAT THIS FORM ASSUMES AN EXPONENTIAL DECAY OF V+IW THAT     
C     IS GIVEN BY A AND AI OR ASI.                                      
C                                                                       
C     NOTE THAT ONLY THE LX=0 (CENTRAL) S-MATRIX ELEMENTS ARE           
C     EXTRAPOLATED; OTHERS ARE SET TO 0 FOR LARGE L.                    
C                                                                       
C     NOTE THAT IN THE CASE OF COUPLED CHANNELS, SIN IS STILL THE       
C     OPTICAL MODEL SIN.                                                
C                                                                       
C                                                                       
      LOMOST = JMOST + LXMAX                                            
      IF ( JMOST.LE.LMAX ) GO TO 500                                    
C                                                                       
      IF ( CCSW ) NUMJS(2) = NUMJS(1)                                   
C                                                                       
      DO 399 I=1,2                                                      
C                                                                       
C        EXTEND THE S-MATRIX AND COULOMB PHASE ARRAYS,                  
C        AND SET THE NEW PART OF S TO 0.                                
C                                                                       
      IF (BIGRSW) CALL IREDEF(LOMOST+1,ISIGS(I))                        
      N = 2*NUMJS(I)*(LMAX+1) + 1                                       
      NN = 2*NUMJS(I)*(LOMOST+1)                                        
      CALL IREDEF ( NN, ISMATS(I) )                                     
      LSMAT = Z(ISMATS(I))                                              
      LSIG = Z(ISIGS(I))                                                
      DO 339 II = N, NN                                                 
      ALLOC(LSMAT+II-1) = 0                                             
 339  CONTINUE                                                          
C                                                                       
C        SET UP THE EXTRAPOLATION PARAMETERS.                           
C                                                                       
      IF ( I .EQ. 2 .AND. CCSW ) GO TO 399                              
      CPH=ALLOC(LSIG+LMAX)                                              
      E2=ETAS(I)**2+ DLMAX*(DLMAX+1)                                    
      E2=DSQRT(E2)                                                      
      EXRFAC = 1.D10                                                    
      IF ( ASCTS(I) .NE. UNDEF ) EXRFAC = 1/(AKS(I)*ASCTS(I))           
      EXIFAC = 1.D10                                                    
      IF ( AIS(I) .NE. UNDEF ) EXIFAC = 1/(AKS(I)*AIS(I))               
      IF ( ASIS(I) .NE. UNDEF ) EXIFAC = 1/(AKS(I)*ASIS(I))             
      BADSW = EXRFAC .EQ. 1.D10 .OR. EXIFAC .EQ. 1.D10                  
      IF ( BADSW ) WRITE(6,348) I                                         
 348  FORMAT ('***** WARNING:  ELASTIC S MATRIX FOR CHANNEL',  I2, ' NOT
     * EXTRAPOLATED BECAUSE A OR AI IS',  ' NOT DEFINED.' )             
      IF ( BADSW ) GO TO 350                                            
      LOC = LSMAT + 2*LMAX*NUMJS(I)                                     
      SIZE=DSQRT(ALLOC(LOC)**2+ALLOC(LOC+1)**2)                         
      DTIM=-.5*DLOG(SIZE)                                               
      DTRE = .5*DATAN2(ALLOC(LOC+1),ALLOC(LOC))                         
 350  IF ( PBUGSW ) WRITE(6,353) I,E2,EXRFAC,EXIFAC, SIZE, DTRE, DTIM  
 353  FORMAT ( ' EXTRAPOLATION OF OPTICALS:', I2, 6G15.5 )              
C                                                                       
C        NOW LOOP THROUGH THE L VALUES, EXTRAPOLATING S FOR LX=0.       
C     FOR CHECKING AND TO FILL IN GAPS IN C.C. CALCS, WE START FROM     
C      A LOWER L-VALUE AND COMPARE OR STORE                             
C                                                                       
      LO = LIFIT-LXMAX                                                  
      RE = 1                                                            
      HIM = 0                                                           
      DO 389 L = LO, LOMOST                                             
      LOC = LSMAT + 2*NUMJS(I)*L                                        
      IF ( BADSW ) GO TO 380                                            
      E1=ETAS(I)**2+L*(L+1)                                             
      DRO=DSQRT(E1)-E2                                                  
      EXR = 0                                                           
      X = DRO*EXRFAC                                                    
      IF ( X .LT. BIGLOG ) EXR = DEXP(-X)                               
      EXI = 0                                                           
      X = DRO*EXIFAC                                                    
      IF ( X .LT. BIGLOG ) EXI = DEXP(-X)                               
      DRE=EXR*DTRE                                                      
      DIM=EXI*DTIM                                                      
      SIZE=DEXP(-2.D0*DIM)                                              
      RE =SIZE*DCOS(2.D0*DRE)                                           
      HIM =SIZE*DSIN(2.D0*DRE)                                          
      IF ( L .GT. LMAX ) GO TO 380                                      
      IF ( DABS(ALLOC(LOC))+DABS(ALLOC(LOC+1)) .EQ. 0 ) GO TO 380       
      IF ( DABS(ALLOC(LOC)-RE)+DABS(ALLOC(LOC+1)-HIM) .GT. .1*(LMAX+1-L)
     **(DABS(DRE)+DIM) ) WRITE(6,373) I,L,RE,HIM,ALLOC(LOC),ALLOC(LOC
     *+1), DRE, DIM, EXR, EXI                                           
 373  FORMAT ( '0*** POOR OPTICAL EXTRAP:', 2I4 /  4X, 4G16.6, 4G14.4 ) 
      GO TO 389                                                         
 380  ALLOC(LOC) = RE                                                   
      ALLOC(LOC+1) = HIM                                                
      IF ( L .LE. LMAX .OR. .NOT. BIGRSW ) GO TO 389                    
      CPH=CPH+DATAN(ETAS(I)/L)                                          
      ALLOC(LSIG+L) = CPH                                               
  389 CONTINUE                                                          
C                                                                       
  399 CONTINUE                                                          
C                                                                       
C     END OF ELASTIC S-MATRIX EXTRAPOLATION.                            
C                                                                       
C                                                                       
C     PREPARE FOR THE SECOND INTERPOLATION/EXTRAPOLATION PASS.          
C                                                                       
 500  CALL SETLOG ( 2*(LOMOST+LXMAX) )                                  
      LCL = Z(ICL)                                                      
      LCINTS = Z(ICINTS)                                                
      LLIS = FACFR4*Z(ILIS)-FACFR4                                      
      LTOCS = Z(ITOCS)*FACFR4 - FACFR4                                  
      LELIN=Z(ISMATS(1))                                                
      LELOUT=Z(ISMATS(2))                                               
      LUNITR = FACFR4*(Z(IUNITR)-1) + 1 - LMIN                          
      IF (TRANSW .OR. CCSW ) GO TO 680                                  
      FACTOR = DSQRT( AKI*AKO/(ES(1)*ES(2)*PI) )                        
      LBRAT = Z(IBETAS(3)) - LXMIN/2                                    
 680  IF ( .NOT. XTRPSW ) GO TO 700                                     
      LLVALS = Z(ILVALS)-1                                              
      LXINTS=Z(IXINTS)-1                                                
      LWORK = Z(IWORK) - MWORK                                          
C                                                                       
C     LOOP AGAIN OVER CHANNELS, (JT,JP,LX,LO-LI)                        
C                                                                       
C     SECOND PASS ;                                                     
C     MAKE CONTINUED FRACTION INTERPOLATION (LMIN TO LMAX)              
C     AND EXPONENTIAL EXTRAPOLATION (LIFIT TO LIMOST)                   
C     USE THESE TO COMPLETE TABLE OF S(L)                               
C     ACCUMULATE UNITARITY CONTRIBUTIONS                                
C                                                                       
C     DO THIS FOR EACH CHANNEL, JT, JP, LX, LO-LI                       
C                                                                       
C     LIFIT < LMAX  IS START OF EXPONENTIAL REGION                      
C                                                                       
C                                                                       
C                                                                       
C     START OF PHASE EXTRAPOLATION.                                     
C                                                                       
      I = LELIN + 2*NUMJS(1)*LMAX                                       
      ELFIN = .5 * DATAN2 ( ALLOC(I+1), ALLOC(I) )                      
C                                                                       
C     INITIALIZE CLEBSCH ROUTINE                                        
C                                                                       
 700  IF ( .NOT. TRANSW ) CALL DUMMY1                                   
C                                                                       
      KSMAT2 = 0                                                        
      IF ( .NOT. CCSW ) GO TO 710                                       
C                                                                       
      LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2) + MCHNDF                        
      LCHNSV = LCHNDF                                                   
      LTOCSV = LTOCS                                                    
      LBINDX = FACFR4*(Z(IBINDX)-1)                                     
C                                                                       
C     FOR CC PHASE EXTRAPOLATION WE ARE CRUDE AND USE                   
C       OPTICAL PHASE SHIFT(OUTGOING) = OPTICAL PHASE(INCOMING)         
C                                                                       
      LELOUT = LELIN                                                    
C                                                                       
 710  DO 999 NCHN = 2, NCHNDF                                           
      MCHN = NCHN                                                       
C                                                                       
      IF ( .NOT. CCSW ) GO TO 720                                       
      MCHN = ILLOC(LCHNDF)                                              
      ETAS(2) = ALLOC4(LCHNDF+5)                                        
      KSMAT = ILLOC(LCHNDF+9)                                           
      NSPLI = ILLOC(LCHNDF+10)                                          
      LTOCS = LTOCSV + ILLOC(LCHNDF+12)                                 
      KSMAT2 = ILLOC(LCHNDF+13)                                         
      LIMOST = ILLOC(LCHNDF+14)                                         
C                                                                       
C                                                                       
 720  DO 989 KOFFS = 1, NSPLI                                           
      JT = ILLOC(LTOCS+4*KOFFS)                                         
      IF ( JT .LT. 0 ) GO TO 989                                        
      JP = ILLOC(LTOCS+4*KOFFS-1)                                       
      LX = ILLOC(LTOCS+4*KOFFS-2)                                       
      LDEL = ILLOC(LTOCS+4*KOFFS-3)                                     
      LSMATR = Z(ISMATR) + ( KOFFS + KSMAT - 1 )                        
      LSMATI = Z(ISMATI) + ( KOFFS + KSMAT - 1 )                        
      LDELSR = Z(IDELSR) + ( KOFFS + KSMAT - 1 )                        
      LDELSI = Z(IDELSI) + ( KOFFS + KSMAT - 1 )                        
      LRDINT = FACFR4*(Z(IRDINT)-1)+1 + 2*(KOFFS-1 + KSMAT2)            
      LISTRT = MAX0( LMIN, (LX-LDEL+1)/2 )                              
C                                                                       
C        FIT CONTINUED FRACTION TO S-MATRICES WITH DESIGNATED           
C        LI VALUES.                                                     
C                                                                       
C     FOR C.C. THIS IS IN TERMS OF THE COMPLETE S-MATRIX                
C                                                                       
      CALL INTRCF ( MCHN, JP, JT, LX, LDEL,  NUMLIS, ILLOC(LLIS+1), LSTE
     *P, LXMAX, ALLOC(LSMATR),  ALLOC(LSMATI), 1, NSPLI, .FALSE., LISTRT
     *, LMAX,  DUMMY, ALLOC4(LRDINT), 1, NSPLI, LMIN-1, .TRUE.,  BIGBOY,
     * LPEAK, ALLOC(LCL), ALLOC(LCINTS) )                               
C                                                                       
      IF ( TRANSW .AND. ( ( LPEAK.EQ.LMIN .AND. LMIN .GT. 0 ) .OR. LPEAK
     * .GE. LMAX ) ) WRITE(6,853) JP, JT, LX, LDEL, LPEAK                 
  853 FORMAT( '0**** WARNING:  FOR (2*JP,2*JT,LX,LO-LI) = (', 4I3,  ')  
     *  LPEAK = ',I3,' IS AT END OF L-RANGE (FISHY) ***')               
C                                                                       
      IF ( .NOT. XTRPSW ) GO TO 950                                     
C                                                                       
C        GET EXPONENTIAL EXTRAPOLATING FUNCTIONS                        
C                                                                       
      LAREA=LWORK+MWORK*KOFFS                                           
      B = ALLOC(LAREA+1)                                                
      BARL = ALLOC(LAREA+2)                                             
      BARA = ALLOC(LAREA+6)                                             
      BARC = ALLOC(LAREA+7)                                             
      ALLOC(LAREA+9) = LPEAK                                            
      ALLOC(LAREA+10) = DSQRT(BIGBOY)                                   
C                                                                       
C        COULD WE DO IT ?                                               
C                                                                       
      IF ( BARA .EQ. 0 ) GO TO 950                                      

C                                                                       
      AP = ALLOC(LAREA+4)                                               
      CP = ALLOC(LAREA+5)                                               
      BP = ALLOC(LAREA+11)                                              
      IF ( IEXTYP .GE. 2 ) GO TO 890                                    
C                                                                       
C        DETERMINE SIGN AND MULTIPLIER FOR PHASE-EXTRAPOLATION          
C        COMPUTE PHI EXTRAPOLATION USING ONLY INELDC STUFF              
C     THIS IS THE PHASE OF S - S(BORN)                                  
C                                                                       
      LO = LMAX + LDEL                                                  
      IADD = (NUMLIS-1)*NSPLI                                           
      PHASE=DATAN2(ALLOC(LDELSI+IADD), ALLOC(LDELSR+IADD))              
      CP = 0                                                            
      IF ( DABS(PHASE) .GT. .25*PI ) CP = SIGN( .5*PI, PHASE )          
      IF ( DABS(PHASE) .GT. .75*PI ) CP = SIGN( PI, PHASE )             
      PHASE = PHASE - CP                                                
      I = LELOUT + 2*NUMJS(2)*LO                                        
      ELFOUT = .5*DATAN2 ( ALLOC(I+1), ALLOC(I) )                       
      ELPH=ELFOUT+ELFIN                                                 
      AP= (PHASE/ELPH)                                                  
      ALLOC(LAREA+4)=AP                                                 
      ALLOC(LAREA+5)=CP                                                 
C                                                                       
C                                                                       
C        USE EXPONENTIAL TO EXTRAPOLATE TO LIMOST                       
C        STORE REACTION S-MATRICES FOR XSECTN                           
C                                                                       
C                                                                       
C        FOR FIRST 2 S-MATRICES BEYOND LAST I COMPUTED BY INELDC        
C        CHECK THAT EXPONENTIAL AND CONTINUED-FRACTION EXTRAPOLATION    
C        AGREE TO WITHIN 10%                                            
C                                                                       
 890  IF (PBUGSW) WRITE(6,893) MCHN, JP, JT, LX, LDEL                     
  893 FORMAT(3X,'* EXTRAPOLATED S-MATRICES WITH ',  ' CHANNEL =', I3
     *, 3X,  '(JP,JT,LX,LO-LI) = (', 2(I3,'/2'),I3,1X,I3,') *' /  '  LI'
     *, 12X, 'WOODS-SAXON', T42, 'CONTINUED FRACTION' ,  T74, 'DIFFERENC
     *E' /  12X, 2( 'MAG', 8X, ' PHASE ', 11X ) / )                     
C                                                                       
      DO 949 LI=LIFIT, LIMOST                                           
      LO = LI + LDEL                                                    
      CALL LXTRP2 ( IEXTYP, BARA, B, BARC, BARL, DLMAX, LI,  SIZE, LX, L
     *DEL, ETAS )                                                       
      IF ( SIZE .LT. SMLNUM ) GO TO 950                                 
      I = LELOUT + 2*NUMJS(2)*LO                                        
      II = LELIN + 2*NUMJS(1)*LI                                        
      IF ( IEXTYP .GE. 2 ) GO TO 915                                    
      ELPH = .5 * ( DATAN2(ALLOC(I+1),ALLOC(I))  + DATAN2(ALLOC(II+1),AL
     *LOC(II)) )                                                        
      PHASE = CP + AP*ELPH                                              
      GO TO 920                                                         
 915  CALL LXTRP2 ( 3, AP, BP, CP, DLMAX, DLMAX, LI,  PHASE, LX, LDEL, E
     *TAS )                                                             
 920  RE= SIZE*DCOS(PHASE)                                              
      HIM= SIZE*DSIN(PHASE)                                             
      IF ( DABS(RE) .LT. 1.D-30 ) RE = 0                                
      IF ( DABS(HIM) .LT. 1.D-30 ) HIM = 0                              
C                                                                       
C        HERE THE EXPONENTIAL AND CF EXTRAPOLATIONS ARE COMPARED        
C                                                                       
      IF ( LSTEP .EQ. 1 .OR. CCSW ) GO TO 940                           
      IF ( LI .GT. LMAX+2 .AND. .NOT. PBUGSW ) GO TO 945                
      CFLI=LI                                                           
      CALL CCONTF(ICOUNT,ALLOC(LCL),ALLOC(LCINTS),  CFLI,CTEMP)         
	RRE=DREAL(CTEMP)
      HUM=DIMAG(CTEMP)                                                  
      SIZEC = DSQRT( RRE**2 + HUM**2 )                                  
      PHC = DATAN2( HUM, RRE )                                          
      RRE = RE-RRE                                                      
      HUM = HIM-HUM                                                     
      F = DSQRT( RRE**2+HUM**2 )                                        
      IF ( PBUGSW .AND. ( LI .LE. LMAX .OR. MOD(LI,5) .EQ. 0 ) ) 
     * WRITE(6,933) LI, SIZE, PHASE,  SIZEC, PHC, F 
  933 FORMAT ( 1X, I4, 2X, 3( 2G13.5, 3X ) )                            
      IF ( LI .GT. LMAX+2 ) GO TO 945                                   
      F = 50 * F/DMIN1( SIZE, SIZEC )                                   
      IF (F .GT. 100 ) WRITE(6,938) MCHN, JP, JT, LX, LDEL, LI, F         
  938 FORMAT(1H ,'**** WARNING:  AT (2*JP,2*JT,LX,LO-LI,LI) = (',  4I4, 
     *I3, I4,')    CF AND EXPONENTIAL EXTRAPOLANTS',  ' DIFFER BY', F6.0
     *, '% ***' )                                                       
C                                                                       
C        IN OVERLAP REGION DON'T OVER-WRITE WITH THE EXTRAPOLATED       
C        VALUE.                                                         
C                                                                       
 940  IF ( LI .LE. LMAX ) GO TO 949                                     
  945 IADD = 2*(LI-LMIN)*NSPLI                                          
      ALLOC4(LRDINT+IADD) = RE                                          
      ALLOC4(LRDINT+IADD+1) = HIM                                       
  949 CONTINUE                                                          
C                                                                       
C        FINALLY ADD THE COULOMB EXCITATION FOR INELASTIC SCATTERING    
C                                                                       
  950 IF ( TRANSW ) GO TO 980                                           
      IF ( CCSW ) GO TO 960                                             
C                                                                       
      FACTR = +FACTOR                                                   
      IF ( IDENSW ) FACTR = SQRT(2.D0)*FACTR                            
C                                                                       
C     SETUP FOR  I**(-LX-1)                                             
C                                                                       
      IF ( MOD(LX, 4) .LT. 2 ) FACTR = -FACTR                           
      IMAGSW = MOD(LX, 2) .EQ. 0                                        
      LCL2FF = Z(ICL2FF) + KOFFS - 1                                    
C                                                                       
      DO 959 LI = LISTRT, LIMOST                                        
      LO = LI + LDEL                                                    
      IADD = (LI-LMIN)*NSPLI                                            
      C = FACTR*ALLOC(LBRAT+LX/2) *  DABS( CLEBSH( 2*LI, 2*LX, 0, 0, 2*L
     *O, 0 ) )                                                          
      FFI = C*ALLOC(LCL2FF+IADD)                                        
      IF ( .NOT. IMAGSW )  ALLOC4(LRDINT+2*IADD) = ALLOC4(LRDINT+2*IADD)
     * + FFI                                                            
      IF ( IMAGSW )  ALLOC4(LRDINT+2*IADD+1) = ALLOC4(LRDINT+2*IADD+1) +
     * FFI                                                              
  959 CONTINUE                                                          
      GO TO 980                                                         
C                                                                       
C     ADD BACK THE BORN COULOMB FOR C.C. CALCULATIONSA                  
C                                                                       
C     FIND ALL RELAVANT BORN TERMS                                      
C                                                                       
 960  IF ( NMFFAC .EQ. 0 .OR. .NOT. XTRPSW ) GO TO 980                  
      LMAXP1 = LMAX+1                                                   
      LCL2FF = FACFR4*(Z(ICL2FF)-1)                                     
      DO 979 IB = 1, NBINDX                                             
      LBIN = LBINDX+(IB-1)*MBINDX                                       
      LB = ILLOC(LBIN+9)                                                
      IF ( LB .EQ. 0 ) GO TO 979                                        
      IF ( ILLOC(LBIN+1) .NE. LX .OR. ILLOC(LBIN+3) .NE. NCHN ) GO TO 97
     *9                                                                 
      NMBFRJ = (LX+1)*((ILLOC(LBIN+4)-ILLOC(LBIN+6))/4+1)               
      INDX1 = LB + JISHFT(LDEL+LX, -1)                                  
      ASSIGN 967 TO IGOTO                                               
      IF ( MOD(LX,2).EQ.0 ) ASSIGN 968 TO IGOTO                         
      DO 974 LI = LMAXP1, LIMOST                                        
      I = LRDINT + 2*NSPLI*(LI-LMIN)                                    
      SBORN = ALLOC4(LCL2FF+INDX1+NMBFRJ*(LI-LMIN))                     
      GO TO IGOTO, ( 967, 968 )                                         
 967  ALLOC4(I) = ALLOC4(I) + SBORN                                     
      GO TO 974                                                         
 968  ALLOC4(I+1) = ALLOC4(I+1) + SBORN                                 
 974  CONTINUE                                                          
 979  CONTINUE                                                          
C                                                                       
C     NOW COMPUTE THE UNITARITY CONTRIBUTIONS                           
C                                                                       
CRACDIR$ IVDEP                                                          
 980  DO 984 LI = LISTRT, LIMOST                                        
      I = LRDINT + 2*NSPLI*(LI-LMIN)                                    
      ALLOC4(LUNITR+LI) = ALLOC4(LUNITR+LI)  + ALLOC4(I)**2 + ALLOC4(I+1
     *)**2                                                              
 984  CONTINUE                                                          
C                                                                       
C                                                                       
C        END OF SECOND PASS OVER  JT, JP, LX, LO-LI                     
C                                                                       
  989 CONTINUE                                                          
C                                                                       
C     ADVANCE TO THE NEXT CHANNEL                                       
C                                                                       
      IF ( .NOT. CCSW ) GO TO 999                                       
C                                                                       
      LCHNDF = LCHNDF + MCHNDF                                          
      LWORK = LWORK + MWORK*NSPLI                                       
C                                                                       
 999  CONTINUE                                                          
C                                                                       
C                                                                       
      IF ( .NOT. CCSW ) GO TO 2800                                      
C                                                                       
C                                                                       
C     PASS 3                                                            
C                                                                       
C     COUPLED CHANNELS CALCULATION - MUST NOW PROPERLY EXTRAPOLATE      
C     THE INCOMING ELASTIC S-MATRICES.  WE USE UNITARITY BY ASSUMING    
C     FOR EACH  LI > LMAX:                                              
C                                                                       
C       !S(EL)!**2 = 1 - SUM(CHAN,LX,LO)!S(INEL)!**2 - ABSORBTION       
C                                                                       
C     WHERE THE S(INEL) HAVE ALREADY BEEN EXTRAPOLATED AND ABSORBTION   
C     IS FOUND BY                                                       
C                                                                       
C       ABSORBTION(L) = ABSORBTION(LMAX) *                              
C                        EXP( -(RT(L)-RT(LMAX))/AI )                    
C       ABSORBTION(LMAX) = 1 - !S(EL,LMAX)!**2 - SUM!S(INEL,LMAX)!**2   
C                                                                       
C     (SEE EXTRAPOLATION OF S(EL) AT END OF PASS 1).  THUS THE          
C     ABSORBTION IS ASSUMED TO BE "NUCLEAR" IN ORIGIN AND DECAYS        
C     EXPONENTIALLY.  THE REST OF UNITARITY IS ASSUMED TO BE EXACTLY    
C     ACCOUNTED FOR BY THE (COULOMB) REAL COUPLED CHANNELS WHICH        
C     GIVE EFFECTS THAT DECAY ONLY AS L**POWER.                         
C                                                                       
C     THE PHASE SHIFT IS FOUND BY FITTING                               
C                                                                       
C     RAT(L) = A / ( 1 + EXP( (L-LWS)*B ) )                             
C            = BARA / ( BARC + EXP( (L-BARL)*B ) )                      
C                                                                       
C     WHERE                                                             
C       RAT(L) = RE(SDIF(L))/IM(SDIF(L))                                
C       SDIF(L) = S(ELAS,C.C.,L) - S(ELAS,OPTICAL,L)                    
C                                                                       
C     IN THE OVERLAP REGION AND USING THIS TO EXTRAPOLATE.              
C                                                                       
C                                                                       
C     FIRST MOVE THE INCOMING OPTICAL ELASTIC S-MATRICES TO THE OUTGOING
C     ARRAYS.  FROM NOW ON WE WILL HAVE THE FOLLOWING:                  
C       C.C. EXCITATION IN 'S'   (IRDINT)                               
C       C.C. ELASTIC IN 'SIN'    (ISMATS(1))                            
C       OPTICAL INCOMING IN 'SOUT'  (ISMATS(2))                         
C                                                                       
C     * * * * * NOTE * * * * *                                          
C                                                                       
C     THIS COUPLED-CHANNELS SECTION (HERE TO 2800) WILL NOT WORK        
C     IN THE PRESENCE OF SPIN-ORBIT POTENTIALS.                         
C                                                                       
C     * * * * * * * * * * * *                                           
C                                                                       
      LELOUT = Z(ISMATS(2))                                             
      IZERO = 0                                                         
CRACDIR$ IVDEP                                                          
      DO 2019 L = IZERO, LOMOST                                         
      ALLOC(LELOUT+2*L) = ALLOC(LELIN+2*L)                              
      ALLOC(LELOUT+2*L+1) = ALLOC(LELIN+2*L+1)                          
 2019 CONTINUE                                                          
C                                                                       
C     NOW INTERPOLATE THE C.C. ELASTIC S-MATRICES                       
C     AND STORE IN SIN                                                  
C                                                                       
C     FOR COUPLN CALCULATIONS WE MUST ALSO INTERPOLATE THE              
C     OPTICAL S-MATRICES.                                               
C                                                                       
      LELCUP = Z(IELCUP)                                                
      LOTPUT = LELIN                                                    
C                                                                       
      DO 2059 I = 1, 2                                                  
C                                                                       
      CALL INTRCF ( I, 0, 0, 0, 0,  NUMLIS, ILLOC(LLIS+1), LSTEP, LXMAX,
     * ALLOC(LELCUP),  ALLOC(LELCUP+1), 1, 2, I.EQ.2, LMIN, LMAX,  ALLOC
     *(LOTPUT), DUMMY, 1, 1, -1, .FALSE.,  BIGBOY, LPEAK, ALLOC(LCL), AL
     *LOC(LCINTS) )                                                     
C                                                                       
      LOTPUT = LELOUT                                                   
      LELCUP = LELOUT                                                   
 2059 CONTINUE                                                          
C                                                                       
      IF ( .NOT. XTRPSW ) GO TO 3000                                    
C                                                                       
C     DETERMINE THE ABSORPTION EXTRAPOLATION FACTORS                    
C                                                                       
      X = ALLOC4(LUNITR+LMAX)                                           
      Y = ALLOC(LELIN+2*LMAX)**2 + ALLOC(LELIN+2*LMAX+1)**2             
      RE = 1 - (X+Y)                                                    
      ABSORB = DMAX1( RE, 0.D0 )                                        
      E2 = DSQRT( ETAS(1)**2 + LMAX*(LMAX+1) )                          
      EXIFAC = -1.E10                                                   
      IF ( AIS(1) .NE. UNDEF ) EXIFAC = -1/(AKS(1)*AIS(1))              
      IF ( ASIS(1) .NE. UNDEF ) EXIFAC = -1/(AKS(1)*ASIS(1))            
      WRITE(6,2153) LMAX, Y, X, RE, ABSORB, EXIFAC                        
 2153 FORMAT (/ ' EXTRAPOLATION OF COUPLED-CHANNELS INCOMING',  ' ELAST
     *IC S-MATRICES:' / ' UNITARITY AT LI = LMAX =', I4, ':   ELASTIC T
     *ERM =',  F7.4, 3X, 'INELASTIC SUM =', F7.4,  3X, 'RESIDUAL ABSORBT
     *ION =', G12.4 /  ' UNITARITY DEFECT (RESIDUAL ABSORBTION) IS EXTRA
     *POLATED AS' /  15X, '( ', G12.4, ' ) * EXP(', F8.4,  ' * (RHOTURN(
     *L)-RHOTURN(LMAX)) )' )                                            
      IF ( RE .LT. -.01 ) WRITE(6,2163)                                    
 2163 FORMAT ( ' **** NOTE SERIOUS VIOLATION OF UNITARITY ',  'IN THE AB
     *OVE ****' )                                                       
C                                                                       
C     NOW FIT WOODS-SAXON TO RAT(L)                                     
C                                                                       
C     WE USE                                                            
C                                                                       
C       SR, SI = S(COUPLED) - S(OPTICAL)                                
C       RRE, HUM = S(OPTICAL)                                           
C       PH = SR/SI                                                      
C                                                                       
      INVRSW = .FALSE.                                                  
      DO 2249 I = 1, NOLFIT                                             
      II = NOLFIT+1-I                                                   
      L = ILLOC(LLIS+NUMLIS+1-I)                                        
      ALLOC(LLVALS+II) = L                                              
      SR = ALLOC(LELIN+2*L) - ALLOC(LELOUT+2*L)                         
      SI = ALLOC(LELIN+2*L+1) - ALLOC(LELOUT+2*L+1)                     
      PH = SR/SI                                                        
      IF ( L .NE. LMAX ) GO TO 2220                                     
C                                                                       
C     DETERMIN SIGNS ON FIRST L (=LAST) L-VALUE                         
C     THEY ARE                                                          
C        CPH = SIGN(PH) = SIGN(SR/SI)                                   
C        CCPH = SIGN OF SQRT IN QUADRATIC FORMULA FOR SI                
C                                                                       
      CPH = DSIGN(1.D0, PH)                                             
      RRE = ALLOC(LELOUT+2*L)                                           
      HUM = ALLOC(LELOUT+2*L+1)                                         
      CR = DSQRT( Y*(1+PH**2) - (RRE-PH*HUM)**2 )                       
      CI = -(HUM+PH*RRE)                                                
      CCPH = ((1+PH**2)*SI-CI)/CR                                       
      IF (DABS(DABS(CCPH)-1).GT.1.D-10)WRITE(6,2213)L,CCPH,CR,CI,
     * RRE, HUM, PH, SR, SI                                            
 2213 FORMAT ( '0**** ERROR \CCPH\ ^= 1:', I4, G20.10 /  7G15.5 )       
 2220 PH = PH*CPH                                                       
      IF ( PH .GT. 0 ) GO TO 2230                                       
      WRITE(6,2223) L                                                     
 2223 FORMAT ( '0**** ERROR, PHASE OF RE(SDIF)/IM(SDIF) CHANGES',  ' SIG
     *N IN FITTING REGION AT L =', I5 )                                 
      IF ( DABS(ALLOC(LELIN+2*L+1)) .GT. .005 ) GO TO 2255              
C                                                                       
C     THE PROBLEM IS PROBABLY DUE TO NOISE IN SMALL IMAG PARTS          
C                                                                       
 2225 WRITE(6,2228)
 2228 FORMAT ( '0**** PHASE OF S-DIF ASSUMMED TO BE 0 ****' )           
      LMAXL = 0                                                         
      INVRSW = .TRUE.                                                   
      GO TO 2300                                                        
C                                                                       
 2230 IF ( I .NE. 2 ) GO TO 2240                                        
C                                                                       
C     ON SECOND L, DETERMIN IF !SR/SI! IS INCREASING AND                
C     IF SO, EXTRAPOLATE !SI/SR!                                        
C                                                                       
      INVRSW = ALLOC(LXINTS+NOLFIT) .GT. PH                             
      IF (INVRSW) ALLOC(LXINTS+NOLFIT) = 1/ALLOC(LXINTS+NOLFIT)         
 2240 IF (INVRSW) PH = 1/PH                                             
      IF ( I .LT. 2 .OR. ALLOC(LXINTS+II+1) .LT. PH ) GO TO 2245        
      WRITE(6,2243) L, PH, ALLOC(LXINTS+II+1), INVRSW                     
 2243 FORMAT ( '0**** WARNING: MAGNITUDE OF RE(S-DIF)/IM(S-DIF)',  ' FLU
     *CTUATES:', I5, 2G15.5, L4 )                                       
      IF ( DABS(ALLOC(LELIN+2*L+1)) .LT. .005 ) GO TO 2225              
 2245 ALLOC(LXINTS+II)=PH                                               
 2249 CONTINUE                                                          
      CALL LXTRP1 ( 1,NOLFIT,ISIG,IPRNT,ALLOC(LLVALS+1),ALLOC(LXINTS+1),
     * FLCRIT,AA,WID, .30D0, 1.D-5, BARL, BARA, B, BARC, DLMAX,  CHISQ, 
     *0, 0, ETAS, 1, 0, 0 )                                             
      IF ( ISIG .GE. 0 ) GO TO 2260                                     
 2255 WRITE(6,2257)
 2257 FORMAT ( '0**** ERROR EXTRAPOLATING RE(SDIF)/IM(SDIF)' /  6X, 'RE/
     *IM ASSUMED TO BE CONSTANT' /  1X, 20('*'), ' ELASTIC CROSS SECTION
     *S ARE SUSPECT ', 20('*') /)                                       
      B = SMLNUM                                                        
      BARC = 1                                                          
      BARA = 2*ALLOC(LXINTS+1)                                          
 2260 LMAXL = DLOG(BARA*BIGNUM)/B + BARL                                
      AA = CPH*AA                                                       
      BARA = CPH*BARA                                                   
      I = 1                                                             
      IF ( INVRSW ) I = 2                                               
      WRITE(6,2263) WRDS(I), WRDS(3-I), AA, FLCRIT, WID                   
 2263 FORMAT (' ELASTIC ', A2, '(S-DIF)/', A2, '(S-DIF) EXTRAPOLATED', 
     * ' AS' /  G30.5, ' / ( 1 + EXP( ( L -', G12.4, ' ) /', F10.6, ' )'
     * )                                                                
      IF ( PBUGSW ) WRITE(6,2267) BARA,BARC,BARL,ISIG,CCPH,EXPLIM    
 2267 FORMAT ( ' BARS:', 3G15.5, I10, '  CCPH =', G15.5, G15.2 )        
C                                                                       
C     NOW DO IT                                                         
C                                                                       
2300  LSKP = LSKIPS(1)                                                  
      LO = LMAX+LSKP                                                    
      I1 = 0                                                            
      I2 = 0                                                            
      DO 2399 LI = LO, JMOST, LSKP                                      
      X = ALLOC4(LUNITR+LI)                                             
      Y = (DSQRT(ETAS(1)**2+LI*(LI+1))-E2)*EXIFAC                       
      EXI = 0                                                           
      IF ( Y .GT. -BIGLOG ) EXI = DEXP(Y)                               
      RE = ABSORB*EXI                                                   
      SIZE = 1 - X - RE                                                 
      IF ( SIZE .GE. 0 ) GO TO 2350                                     
      I1 = I1+1                                                         
      IF ( I1 .LT. 10 ) WRITE(6,2343) LI, X, Y, EXI, RE, SIZE             
 2343 FORMAT ( '0**** INTERNAL ERROR IN ELASTIC MAG. EXTRAP:' /  I4, 6G1
     *5.5 )                                                             
      SIZE = 0                                                          
 2350 PH = CPH*SMLNUM                                                   
      IF ( LI .LE. LMAXL )  CALL LXTRP2 ( 1, BARA, B, BARC, BARL, DLMAX,
     * LI, PH,  0, 0, ETAS )                                            
      IF ( INVRSW ) PH = 1/PH                                           
C                                                                       
C     AT THIS POINT WE HAVE                                             
C                                                                       
C       SIZE = !S!**2                                                   
C       PH = RE(SDIF)/IM(SDIF)                                          
C                                                                       
C     SOME ALGEBRA IS NEEDED TO GET SR AND SI.                          
C                                                                       
      RRE = ALLOC(LELOUT+2*LI)                                          
      HUM = ALLOC(LELOUT+2*LI+1)                                        
      RE = SIZE*(1+PH**2) - (RRE-PH*HUM)**2                             
      IF ( RE .GE. 0 ) GO TO 2360                                       
      I2 = I2+1                                                         
      IF ( I2 .LT. 10 .AND. RE .LT. -1.D-10 )  WRITE(6,2353) LI,SIZE,PH,
     * RE, RRE, HUM                                                     
 2353 FORMAT ( '0**** INTRNAL ERROR IN ELASTIC PHASE EXTRAP:',  I5, 5G15
     *.5 )                                                              
      RE = 0                                                            
 2360 SI = (-HUM-PH*RRE + CCPH*DSQRT(RE))/(1+PH**2)                     
      SR = PH*SI                                                        
      RE = SR + RRE                                                     
      HIM = SI + HUM                                                    
      IF ( DABS(HIM) .LT. SMLNUM ) HIM = 0                              
      ALLOC(LELIN+2*LI) = RE                                            
      ALLOC(LELIN+2*LI+1) = HIM                                         
      IF ( .NOT. PBUGSW ) GO TO 2399                                    
      IF ( LI .GT. LMAX+10 .AND. MOD(LI, 5) .NE. 0 ) GO TO 2399         
      X = .5 * DATAN2( HIM, RE )                                        
      SIZE = DSQRT(SIZE)                                                
      WRITE(6,2383) LI, SIZE, X, RE, HIM, PH, RRE, HUM                    
 2383 FORMAT ( ' ++', I5, 7G14.5 )                                      
 2399 CONTINUE                                                          
C                                                                       
C                                                                       
C     PASS 4;  TABULATE THE EXTRAPOLATION PARAMETERS                    
C                                                                       
 2800 IF ( .NOT. XTRPSW ) GO TO 3000                                    
      IF ( IBRNSB .EQ. 0 .AND. .NOT. TRANSW ) WRITE(6,2823)
 2823 FORMAT ( / 33X,  'FOLLOWING REFER TO THE "NUCLEAR" PART OF TH
     *E INELASTIC ',  'AMPLITUDES.' )                                   
      WRITE(6,2833) DLMAX, DLMAX                                          
 2833 FORMAT ( / X, T49, 'SUMMARY OF EXTRAPOLATION PARAMETERS' / 20X,
     * '!S! = A/( C + EXP( (LI-LCRIT)/LWIDTH ) )' ,  T72, 'PHASE = 
     *CP + AP*(SUM OF ELASTIC PHASE-SHIFTS)' /  16X, 'OR', 6X, '= A*(', 
     *F6.0, '/L)**B * (1+LCRIT/L)',  T72, 6X, '= CP + AP*(', F6.0, '/L)*
     **BP' /  16X, 'OR', 6X, '= ABOVE * SIN(ATAN(ETA/L))**LX' /  26X, '*
     * EXP(-(ETA2-ETA1)(ATAN(ETA/L)+L/ETA))' / ' CHANNEL   JP   JT  LX 
     *LO-LI', T34, 'PEAK',  T47, 'MAX L',  T69, 'MAGNITUDE EXTRAPOLATION
     *',  T108, 'PHASE EXTRAPOLATION' /  T31, 'LI', 5X, 'VALUE', T48, 'U
     *SED', T62, 'A', 9X, 'C',  4X, 'LWIDTH', T87,  'LCRIT', 3X, 'MAX L'
     *, T109, 'CP', 8X, 'AP', 8X, 'BP' /  T77, 'OR B', T95, 'NEEDED' / )
     *                                                                  
C                                                                       
      LTOCS = Z(ITOCS)*FACFR4 - FACFR4                                  
      LCHNDF = LCHNSV                                                   
      LWORK = Z(IWORK)-MWORK                                            
C                                                                       
      DO 2899 NCHN = 2, NCHNDF                                          
      MCHN = NCHN                                                       
C                                                                       
      IF ( .NOT. CCSW ) GO TO 2860                                      
      MCHN = ILLOC(LCHNDF)                                              
      NSPLI = ILLOC(LCHNDF+10)                                          
      LTOCS = LTOCSV + ILLOC(LCHNDF+12)                                 
      LIMOST = ILLOC(LCHNDF+14)                                         
C                                                                       
 2860 DO 2889 KOFFS = 1, NSPLI                                          
      JT = ILLOC(LTOCS+4*KOFFS)                                         
      IF ( JT .LT. 0 ) GO TO 2889                                       
      JP = ILLOC(LTOCS+4*KOFFS-1)                                       
      LX = ILLOC(LTOCS+4*KOFFS-2)                                       
      LDEL = ILLOC(LTOCS+4*KOFFS-3)                                     
      LAREA = LWORK + MWORK*KOFFS                                       
      WID = ALLOC(LAREA+1)                                              
      IF ( IEXTYP .EQ. 1 .AND. WID .NE. 0 ) WID = 1/WID                 
      I = ALLOC(LAREA+7)                                                
      LMAXL = ALLOC(LAREA+8)                                            
      LPEAK = ALLOC(LAREA+9)                                            
      WRITE(6,2873) MCHN,JP,JT,LX,LDEL,LPEAK,ALLOC(LAREA+10),LIMOST, 
     *ALLOC(LAREA), I, WID, ALLOC(LAREA+3),  LMAXL, ALLOC(LAREA+5), 
     *ALLOC(LAREA+4), ALLOC(LAREA+11)                                   
 2873 FORMAT ( I5, I6, '/2', I3, '/2', I3, I5, I6, G13.3, I6,  G17.5, I4
     *, F10.3, G12.3, I6, F13.3, F10.3, F10.3 )                         
 2889 CONTINUE                                                          
C                                                                       
      IF ( .NOT. CCSW ) GO TO 2899                                      
      WRITE(6,2893)
 2893 FORMAT ( ' ' )                                                    
      LWORK = LWORK + NSPLI*MWORK                                       
      LCHNDF = LCHNDF + MCHNDF                                          
 2899 CONTINUE                                                          
C                                                                       
      Z(IWORK) = -Z(IWORK)                                              
      Z(ILVALS) = -Z(ILVALS)                                            
      Z(IXINTS) = -Z(IXINTS)                                            
 3000 Z(ICL) = -Z(ICL)                                                  
      Z(ICINTS) = -Z(ICINTS)                                            
      IF ( TRANSW ) GO TO 3300                                          
      IF ( CCSW .AND. NMFFAC .EQ. 0 ) GO TO 3300                        
      Z(ICL2FF) = -Z(ICL2FF)                                            
C                                                                       
 3300 CONTINUE
      RETURN                                                            
      END                                                               
C                                                                       
      SUBROUTINE LSTKEY ( VALSW, NUMFLT, FLTWRD, NUMINT, INTWRD,  NUMJ, 
     *JWRDS, NUMSWW, SWTWRD, SWTNUM, SWTSET,  NUMKEY, KEYWRD, NUMALI, AL
     *IAI )                                                             
C                                                                       
C     LIST THE KEYWORDS AND THEIR VALUES                                
C                                                                       
C     4/15/75 - COMPLETE REWRITE.                                       
C     7/22/76 - CDC/IBM, REMOVE TEMPCM                                  
C     12/28/79 - STANDARD MORTRAN - RPG                                 
C     1/24/80 - MORE CHARACTER VARIABLES; QUOTES IN DATA STATEMENTS;    
C        CNDCNI USE A16 FOR VALUES; BRKFMT USED FOR CDC ONLY (WHY?) - RP
C     6/2/80 - FMTSI MUST HAVE SEPARATE CDC VERSION - S.P.              
C     6/24/80 - ALSO MUST AUNDF2 - S.P.                                 
C     7/16/80 - CDM, CDO PREFIX, ONLY ARRAYS AS FORMATS - S.P.          
C     7/21/80 - USE FMT(2) AT 125 - S. P.                               
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      real*8 FLTWRD(NUMFLT), INTWRD(NUMINT), JWRDS(NUMJ),  SWTWRD(NUMSWW
     *), KEYWRD(NUMKEY), ALIAI(NUMALI)                                  
      INTEGER SWTNUM(NUMSWW), SWTSET(NUMSWW)                            
      LOGICAL VALSW                                                     
C                                                                       
C                                                                       
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 /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                                                                 
C                                                                       
C                                                                       
      DIMENSION FLOATK(1), INTGER(1), JBLOCK(1)                          
      INTEGER SWITCH(1)                                                 
      EQUIVALENCE ( FLOATK(1), A ), ( INTGER(1), L ), ( JBLOCK(1), J ), 
     *( SWITCH(1), IASYMP )                                             
C                                                                       
C                                                                       
C                                                                       
      real*8 NAMES(250), BLANK /' '/, NOMORE /'*NOMORE*'/               
      real*8 SYNS(250)                                                  
      EQUIVALENCE ( SYNS(1), VALUES(1) )                                
Cvms      real*16 VALUES(250), BLANKC, AUNDEF                               
      real*8 VALUES(250), BLANKC, AUNDEF                               
      real*8 BLNKC2(2) / ' ', ' ' /,  AUNDF2(2)                         
      EQUIVALENCE ( BLANKC, BLNKC2(1) ), ( AUNDEF, AUNDF2(1) )          
C                                                                       
Cvms      real*16 VALWRD                                                    
      real*8 VALWRD                                                    
      real*8 FMT(3)                                                     
CDC      REAL  BRKFMT(1) / '(2A8)' /                                    
C                                                                       
      INTEGER INDEX(250)                                                
      real*8 FMTS(6) /'E14.6','F10.6','F10.0', 'F10.5', 'F10.3', 
     *'F10.1' /                                                            
      real*8 FMTSI(2)                                                   
      DATA FMTSI / 'I10', 'I8,2H/2' /                                   
CDO      DATA AUNDF2 / '  NOT DE',  'FINED   ' /                        
CDO      DATA FMT / '(', ' ', ')' /                                     
      DATA AUNDF2 / 8H  NOT DE, 5HFINED /                               
      DATA FMT / 1H(, 1H , 1H) /                                        
C                                                                       
C                                                                       
      DO 49 I = 1, 250                                                  
      NAMES(I) = BLANK                                                  
      VALUES(I) = BLANKC                                                
      INDEX(I) = I                                                      
  49  CONTINUE                                                          
C                                                                       
C                                                                       
C     COLLECT ALL THE DATA ENTRY KEYWORDS                               
C                                                                       
      K = 0                                                             
      DO 129 I = 1, NUMFLT                                              
      IF ( FLTWRD(I) .EQ. NOMORE ) GO TO 129                            
      K = K+1                                                           
      NAMES(K) = FLTWRD(I)                                              
      IF ( .NOT. VALSW ) GO TO 129                                      
      IF ( FLOATK(I) .NE. UNDEF ) GO TO 120                              
      VALUES(K) = AUNDEF                                                
      GO TO 129                                                         
C     SIMULATE G FORMAT                                                 
 120  X = DABS(FLOATK(I))                                                
      N = 3                                                             
      IF ( X .EQ. 0 ) GO TO 125                                         
      N = 1                                                             
      IF ( X .LT. .01D0 .OR. X .GT. 1.D6 ) GO TO 125                    
      N = 2                                                             
      IF ( X+1.D-6 .LT. 1 ) GO TO 125                                   
      N = 3                                                             
      IF ( DMOD(X+1.D-8, 1.D0) .LT. 1.D-7 ) GO TO 125                   
      N = 4                                                             
      IF ( X .LT. 100 ) GO TO 125                                       
      N = 5                                                             
      IF ( X .LT. 10000 ) GO TO 125                                     
      N = 6                                                             
 125  FMT(2) = FMTS(N)                                                  
CIB         CALL CONVO ( FMT, VALUES(K), 0, IW, FLOAT(I) )              
      ENCODE( 16, FMT, VALWRD ) FLOATK(I)                                

CDC      DECODE ( 16, BRKFMT, VALWRD )  VALUES(K)                       
      VALUES(K) = VALWRD                                                
 129  CONTINUE                                                          
C                                                                       
      DO 149 I = 1, NUMINT                                              
      IF ( INTWRD(I) .EQ. NOMORE ) GO TO 149                            
      K = K+1                                                           
      NAMES(K) = INTWRD(I)                                              
      IF ( .NOT. VALSW ) GO TO 149                                      
      IF ( INTGER(I) .NE. NOTDEF ) GO TO 140                            
      VALUES(K) = AUNDEF                                                
      GO TO 149                                                         
 140  FMT(2) = FMTSI(1)                                                 
CIB         CALL CONVO  ( FMT , VALUES(K), 0, IW, INTGER(I) )           
      ENCODE ( 16, FMT, VALWRD ) INTGER(I)                              
CDC      DECODE ( 16, BRKFMT, VALWRD )  VALUES(K)                       
      VALUES(K) = VALWRD                                                
 149  CONTINUE                                                          
C                                                                       
      DO 179 I = 1, NUMJ                                                
      IF ( JWRDS(I) .EQ. NOMORE ) GO TO 179                             
      K = K+1                                                           
      NAMES(K) = JWRDS(I)                                               
      IF ( .NOT. VALSW ) GO TO 179                                      
      IF ( JBLOCK(I) .NE. NOTDEF ) GO TO 160                            
      VALUES(K) = AUNDEF                                                
      GO TO 179                                                         
160   JVAL = JBLOCK(I)                                                  
      N = 2                                                             
      IF ( MOD(JVAL, 2) .NE. 0 ) GO TO 170                              
      JVAL = JVAL/2                                                     
      N = 1                                                             
 170  FMT(2) = FMTSI(N)                                                 
CIB      CALL CONVO ( FMT, VALUES(K), 0, IW, JVAL )                     
      ENCODE ( 16, FMT, VALWRD ) JVAL                                   
CDC      DECODE ( 16, BRKFMT, VALWRD )  VALUES(K)                       
      VALUES(K) = VALWRD                                                
 179  CONTINUE                                                          
C                                                                       
C     DATA ENTERING STUFF ALL COLLECTED, SORT AND PRINT                 
C                                                                       
      N = K                                                             
      CALL ALSORT ( NAMES, INDEX, N )                                   
      IF ( VALSW ) GO TO 250                                            
      NN = (N+5)/6                                                      
      NNN = 6*NN                                                        
      WRITE(6,223) ((NAMES(INDEX(II+I-1)),I=1,NNN,NN),II=1,NN)
     *                                                                  
 223  FORMAT ( / ' DATA ENTERING KEYWORDS ARE:' // ( 6A12 ) )           
      GO TO 300                                                         
C                                                                       
 250  ICOL = 4                                                          
      IF ( ITSO .EQ. 1 ) ICOL = 3                                       
      NN = (N+ICOL-1)/ICOL                                              
      NNN = ICOL*NN                                                     
      IF ( ITSO .EQ. 1 ) GO TO 270                                      
      WRITE(6,253)
 253  FORMAT ( / ' DATA ENTERING KEYWORDS AND THEIR VALUES ARE:' / )    
      WRITE(6,263) ((NAMES(INDEX(II+I-1)),VALUES(INDEX(II+I-1)),I=1,
     * NNN, NN), II = 1, NN )                                           
CNV 263  FORMAT (( 1X, 4( A8, 2A8, 8X ) ))                              
 263  FORMAT (( 1X, 4( A8, A16, 8X ) ))                                 
      GO TO 300                                                         
 270  WRITE(6,253)
      WRITE(6,273) ((NAMES(INDEX(II+I-1)),VALUES(INDEX(II+I-1)),I=1,
     * NNN, NN), II = 1, NN )                                           
CNV 273  FORMAT ( 1X, 3(A8, 2A8) )                                      
 273  FORMAT ( 1X, 3(A8, A16) )                                         
C                                                                       
C     NOW GET SWITCH SETTINGS                                           
C                                                                       
 300  K = 0                                                             
      DO 359 I = 1, NUMSWW                                              
      IF ( SWTWRD(I) .EQ. NOMORE ) GO TO 359                            
      IF ( .NOT. VALSW ) GO TO 350                                      
      IF ( SWITCH(SWTNUM(I)) .NE. SWTSET(I) ) GO TO 359                 
 350  K = K+1                                                           
      NAMES(K) = SWTWRD(I)                                              
 359  CONTINUE                                                          
C                                                                       
      CALL ALSORT ( NAMES, INDEX, K )                                   
      IF ( VALSW ) GO TO 380                                            
      WRITE(6,373) ( NAMES(INDEX(I)), I = 1, K )                          
 373  FORMAT ( / ' THE FOLLOWING KEYWORDS MAY BE USED TO ',  'SELECT OPT
     *IONS:' // ( 6A12 ) )                                              
      GO TO 400                                                         
 380  WRITE(6,383) ( NAMES(INDEX(I)), I = 1, K )                          
 383  FORMAT ( / ' THE FOLLOWING OPTIONS HAVE BEEN CHOSEN:' //  ( 6A12 )
     * )                                                                
C                                                                       
C     FINALLY THE CONTROL KEYWORDS                                      
C                                                                       
 400  IF ( VALSW ) GO TO 800                                            
      K = 0                                                             
      DO 409 I = 1, NUMKEY                                              
      IF ( KEYWRD(I) .EQ. NOMORE ) GO TO 409                            
      K = K + 1                                                         
      NAMES(K) = KEYWRD(I)                                              
 409  CONTINUE                                                          
      CALL ALSORT ( NAMES, INDEX, K )                                   
      WRITE(6,433) ( NAMES(INDEX(I)), I = 1, K )                          
 433  FORMAT ( / ' THE FOLLOWING ARE COMMAND KEYWORDS:' // (6A12) )     
C                                                                       
C     PRINT THE ALIAI                                                   
C                                                                       
      K = 0                                                             
      DO 519 I = 1, NUMALI, 2                                           
      K = K+1                                                           
      NAMES(K) = ALIAI(I)                                               
      SYNS(K) = ALIAI(I+1)                                              
 519  CONTINUE                                                          
      NAMES(K+1) = BLANK                                                
      NAMES(K+2) = BLANK                                                
      SYNS(K+1) = BLANK                                                 
      SYNS(K+2) = BLANK                                                 
      INDEX(K+1) = K+1                                                  
      INDEX(K+2) = K+2                                                  
      CALL ALSORT ( NAMES, INDEX, K )                                   
      NN = (K+2)/3                                                      
      NNN = 3*NN                                                        
      WRITE(6,533)((NAMES(INDEX(II+I-1)),SYNS(INDEX(II+I-1)),I=1,N
     *NN, NN ), II = 1, NN )                                            
 533  FORMAT ( / ' THE FOLLOWING ARE SYNONUMS FOR STANDARD',  ' PTOLEMY 
     *KEYWORDS' //  1X, 3( 'SYNONUM', 3X, 'KEYWORD', 6X ) //  ( 1X, 3( A
     *8, 2X, A8, 5X ) ) )                                               
C                                                                       
      CALL ALSORT ( SYNS, INDEX, K )                                    
      WRITE(6,533)((NAMES(INDEX(II+I-1)),SYNS(INDEX(II+I-1)),I=1,N
     *NN, NN ), II = 1, NN )                                            
C                                                                       
C                                                                       
 800  RETURN                                                            
C                                                                       
      END                                                               
      FUNCTION LXTRPM ( IEXTYP, BARA, B, BARC, BARL, DLMAX,  LX, LDEL, E
     *TAS, WEEBOY )                                                     
C                                                                       
C     RETURNS L SUCH THAT  WEEBOY = SQRT(2L) * EXTRAP FUNC(L)           
C                                                                       
C     THE EXTRAPOLATION FUNCTIONS ARE DEFINED IN LXTRP1                 
C                                                                       
C     9/24/80 - FIRST VERSION - S.P.                                    
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      DIMENSION ETAS(2)                                                 
C                                                                       
      DL = DLMAX                                                        
      GO TO ( 100, 200, 10, 300 ), IEXTYP                               
 10   WRITE(6,13) IEXTYP                                                  
 13   FORMAT ( '0*** CANNOT FIND LIMOST FOR FUNCTION TYPE', I3 )        
      LXTRPM = 2*DLMAX                                                  
      RETURN                                                            
C                                                                       
C     WOODS SAXON                                                       
C        WEEBOY = SQRT(2L)*BARA / (1 + EXP(B*(L-FLCRIT)) )              
C                                                                       
 100  DL = RTXLNX( B, -.50D0,  DLOG(WEEBOY/BARA) - .5*DLOG(2.0D0) - B*BA
     *RL, .010D0 )                                                      
      GO TO 900                                                         
C                                                                       
C     POWER LAW                                                         
C        WEEBOY = SQRT(2L)*BARA * (DLMAX/L)**B                          
C                                                                       
 200  IF ( B .GT. .5 ) DL = DEXP( (DLOG(1.41*DABS(BARA)/WEEBOY)  + B*DLO
     *G(DLMAX) )/(B-.5) )                                               
C                                                                       
C     WKB FORM                                                          
C     WEEBOY = SQRT(2L)*BARA*ETA**LX*DLMAX**B                           
C            * EXP((ETA2-ETA1)/ETA * L) / L**(LX+B)                     
C                                                                       
 300  ETA = .5*(ETAS(1)+ETAS(2))                                        
      IF ( LX+B-.5 .GT. 0 ) DL = RTXLNX( (ETAS(2)-ETAS(1))/ETA,  LX+B-.5
     *, DLOG( DABS( WEEBOY/( 1.4142*BARA*ETA**LX ) ) )  - B*DLOG(DLMAX),
     * .010D0 )                                                         
C                                                                       
 900  LXTRPM = DL+.5                                                    
      RETURN                                                            
      END                                                               
      SUBROUTINE LXTRP1 ( IEXTYP, N, ISIG, IPRINT, XVALS, SVALS,  FLCRIT
     *, AVAL, WID, STEPIN, DELIN, BARL, BARA, B,  BARC, DLMAX, CHISQ, LX
     *, LDEL, ETAS, MCHN, JP, JT )                                      
C                                                                       
C     LEAST-SQUARES FIT OF L-EXTRAPOLATING FUNCTIONS                    
C                                                                       
C     IEXTYP = 1  MEANS FIT WOODS SAXON OF THE FORM                     
C              S(L) = BARA/(BARC + EXP( B*(L-BARL) ) )                  
C                   = AVAL/(+-1 + EXP( (L-FLCRIT)/WID ) )               
C           = 2  MEANS FIT INVERSE POWER FUNCTION OF THE FORM           
C              S(L) = BARA * (DLMAX/L)**B * ( 1 + BARC*(BARL/L) )       
C                   = AVAL * (DLMAX/L)**B * ( 1 +- (LCRIT/L) )          
C           = 3  MEANS FIT INVERSE POWER LAW OF THE FORM                
C              S(L) = BARA + BARC*(DLMAX/L)**B                          
C              THIS IS USED FOR THE PHASE EXTRAPOLATION                 
C              NOTE THAT LINTRP REVERSES THE DEFINITIONS SO             
C              THAT  CP=BARA,  AP=BARC  BP=B                            
C           = 4  MEANS THE WKB FORM:                                    
C              S(L) = (SIN(ATAN(ETA/L)))**LX                            
C               * EXP(-(ETA2-ETA1)*(ATAN(ETA/L)+L/ETA))                 
C               * BARA*(DLMAX/L)**B * (1+BARC*(BARL/L))                 
C              THIS HAS THE SAME DEPENDANCE ON THE FITTED               
C              PARAMETERS AS IEXTYP=2.  HERE                            
C              ETA = .5*(ETA1+ETA2)   L = (L1+L2)/2                     
C        IN THE ABOVE THE FIRST LINE IS THE WAY THINGS ARE TO           
C        BE COMPUTED AND THE SECOND IS THE WAY THEY ARE TO BE           
C        PRINTED.                                                       
C     N    : NO OF S-MATRICES TO FIT                                    
C     ISIG : 0 IF ALLS WELL                                             
C          : NEGATIVE FOR FATAL ERROR - SUPPRESS EXTRAPOLATION          
C          : POSITIVE IF EXPONENTIAL RATHER THAN WS FORM USED           
C     XVALS: ARRAY OF LENGTH N. INPUT L-VALUES;                         
C            THESE WILL BE MODIFIED.                                    
C     SVALS:  ARRAY(LENGTH N) OF MAGNITUDES OF S-MATRIX ELEMENTS        
C               THESE WILL BE MODIFIED.                                 
C     FLCRIT: R*8 VALUE OF LC PARAMETER IN WOODS-SAXON FUNCTION         
C     AVAL : VALUE OF A (NORMALIZATION) PARAMETER                       
C     WID  : VALUE OF WIDTH PARAMETER                                   
C     STEPIN  : WIDTH STEP-SIZE IN FINDING MINIMUM W.R.T. WIDTH         
C     DELIN:  STEP SIZE USED TO COMPUTE DERIVATIVES                     
C                                                                       
C     BARL, BARA, B, BARC ARE TO BE USED TO COMPUTE THE FUNTION         
C           AS DEFINED ABOVE                                            
C     PRESENTLY BARA IS ALWAYS THE SAME AS                              
C     AVAL, BUT BARC WILL BE 0 FOR THE EXPONENTIAL FORM, AND            
C     BARL MAY BE CHOOSEN TO MINIMIZE THE CHANCE OF OVERFLOW.           
C                                                                       
C                                                                       
C     MHM - 9/1/76                                                      
C     4/19/77 - AVOID OVERFLOWS BY BIASING L; RETURN BAR STUFF - S.P.   
C     7/12/78 - AVOID UNLIKELY LOG(0)                                   
C     6/20/79 - DON'T REDEFINE THE STEP, AND DEL IN ARG LIST - S.P.     
C     1/15/80 - USE BIGNUM, BIGLOG, ADD /CNSTNT/ - RPG                  
C     4/11/80 - ADD POWER FITS - S.P.                                   
C     5/2/80 - AVOID DIVIDE BY 0 IN PARAB FITS; LEAVE DEL A RATIO - S.P.
C     5/7/80 - IEXTYP=3 ADDED - S.P.                                    
C     9/26/80 - IEXTYP=4 ADDED - S.P.                                   
C     10/6/80 - RELAX BMIN RESTRICTION FOR ELASTIC RE/IM - S.P.         
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      DIMENSION XVALS(N),SVALS(N), ETAS(2)                              
C                                                                       
CDC      ALLOCLEVEL XVALS, SVALS                                        
C                                                                       
      LOGICAL PBUGSW, PLINSW                                            
C                                                                       
      PBUGSW = IPRINT .GE. 4                                            
      PLINSW = IPRINT .GE. 6                                            
      DEL = DELIN                                                       
      STEP = STEPIN                                                     
      IXTYP2 = 2*IEXTYP                                                 
      IF ( IEXTYP .EQ. 4 ) IXTYP2 = 4                                   
      ISIG=0                                                            
      STPMUL=1                                                          
      BMIN = 0                                                          
      IF ( IEXTYP .EQ. 4 ) BMIN = -LX                                   
C                                                                       
C                                                                       
C     BIAS THE L'S TO 0 TO AVOID OVERFLOW PROBLEMS                      
C                                                                       
      ETA = .5*(ETAS(1)+ETAS(2))                                        
      XBAR = ( XVALS(1)+XVALS(2) )/2                                    
      IF ( IEXTYP .GE. 2 ) XBAR = DLMAX                                 
C                                                                       
      DO 99 I=1,N                                                       
      GO TO ( 50, 60, 60, 70 ), IEXTYP                                  
  50  XVALS(I) = XVALS(I) - XBAR                                        
      GO TO 99                                                          
  60  XVALS(I) = XBAR/XVALS(I)                                          
      GO TO 99                                                          
 70   DL = XVALS(I) + .5*LDEL                                           
      SVALS(I) = SVALS(I) / ( (DSIN(DATAN(ETA/DL)))**LX  * DEXP(-(ETAS(2
     *)-ETAS(1))*(DATAN(ETA/DL)+DL/ETA)) )                              
      XVALS(I) = XBAR/DL                                                
  99  CONTINUE                                                          
C                                                                       
      IF ( PBUGSW ) WRITE(6,101) MCHN, JP, JT, LX, LDEL,  IEXTYP, N       
 101  FORMAT ( ' EXTRAPOLATION FOR MCHN =', 5I5, 3X,  'IEXTYP =', 5I5 ) 
      IF ( PLINSW ) WRITE(6,102) ( I, XVALS(I), SVALS(I), I=1,N )         
 102  FORMAT (' X AND S:' / (I4, 2G17.5 ) )                             
C                                                                       
C     GET INITIAL GUESS OF THE NON-LINEAR PARAMETER                     
C     FOR IEXTYP=1 USE EXP. FIT; FOR 2 USE SIMPLE POWER LAW.            
C     FOR IEXTYP = 3  WE JUST USE B = 3                                 
C                                                                       
      CVAL = 1                                                          
      IF ( IEXTYP .EQ. 3 ) CVAL = 3                                     
      CALL LINLSQ ( IXTYP2-1, N, XVALS, SVALS, BEXP, AEXP, CVAL, F,  PLI
     *NSW )                                                             
      IF ( IEXTYP .NE. 3 ) GO TO 105                                    
      CEXP = BEXP                                                       
      IXTYP2 = 5                                                        
      BEXP = 3                                                          
      GO TO 110                                                         
C                                                                       
 105  IF(BEXP .GT. BMIN) GO TO 110                                      
      WRITE(6,108) BEXP                                                    
  108 FORMAT( '0***  INITIAL B = ',G12.6,' (OUT OF BOUNDS)--')          
      GO TO 940                                                         
C                                                                       
C     EVALUATE CHISQ AND DERIVATIVE AT INITIAL WIDTH                    
C                                                                       
  110 IF(PBUGSW) WRITE(6,120) BEXP                                         
  120 FORMAT( ' B FOR EXP OR POWER FORM = ',G12.6)                      
      STEP=STEP*DABS(BEXP/10)                                           
      IF ( IEXTYP .EQ. 3 ) STEP = .1                                    
      BMAX = 10*DABS(BEXP)                                              
      IF ( IEXTYP .EQ. 1 ) BMAX = 1.2                                   
	IF(IEXTYP.GE.2)BMAX=15
	IF(IEXTYP.GE.2)BMIN=.10001
C                                                                       
      X=BEXP                                                            
      CALL LINLSQ ( IXTYP2, N, XVALS, SVALS, C1, A1, X, F, PLINSW )     
      CHIEXP = F                                                        
C                                                                       
 130  XPL=X*(1+DEL)                                                     
      XMI=X*(1-DEL)                                                     
      CALL LINLSQ ( IXTYP2, N, XVALS, SVALS, CVAL, AVAL, XPL, FPL,  PLIN
     *SW )                                                              
      CALL LINLSQ ( IXTYP2, N, XVALS, SVALS, CVAL, AVAL, XMI, FMI,  PLIN
     *SW )                                                              
      DF=(FPL-FMI)/(2*X*DEL)                                            
      DTES=DABS(DF/F)                                                   
      IF(DTES.GT.1.D-10) GO TO 200                                      
      IF ( DEL .GE. .5 ) GO TO 700                                      
      DEL = 2*DEL                                                       
      GO TO 130                                                         
  200 S=DABS(STEP)                                                      
      IF(DF.GT.0) S =-S                                                 
C                                                                       
C     STEP DOWNHILL TO BOX IN MINIMUM                                   
C                                                                       
      IT=1                                                              
      F1=F                                                              
      X1=X                                                              
 220  X2=X1+S                                                           
C                                                                       
C     A WOODS-SAXON WITH WIDTH LESS THAN 1 DOESN'T MAKE SENSE IN        
C     IN THIS CONTEXT                                                   
C                                                                       
      IF ( IEXTYP .EQ. 1 .AND. X2 .GT. 1.2 ) GO TO 950                  
      IF ( IEXTYP .GE. 2 .AND. X2 .LT. BMIN ) GO TO 960                 
      IF ( IEXTYP .EQ. 1 .AND. X2 .LT. BMIN ) GO TO 700                 
      IF ( IEXTYP .GE. 2 .AND. X2 .GT. BMAX ) GO TO 700                 
C                                                                       
      CALL LINLSQ ( IXTYP2, N, XVALS, SVALS, C, A, X2, F2, PLINSW )     
      IF(F2.LE.F1) GO TO 250                                            
C                                                                       
C     PASSED A MINIMUM; TRY TO GET THREE POINTS WITH F2 THE LEAST       
C                                                                       
      S=.5*S                                                            
      X3=X2                                                             
      F3=F2                                                             
      X2=X3-S                                                           
      CALL LINLSQ ( IXTYP2, N, XVALS, SVALS, C, A, X2, F, PLINSW )      
      IF ( F .LT. F1 ) GO TO 240                                        
      X3 = X2                                                           
      F3 = F                                                            
      X2 = X1                                                           
      F2 = F1                                                           
      A2 = A1                                                           
      C2 = C1                                                           
      X1 = X2-S                                                         
      CALL LINLSQ ( IXTYP2, N, XVALS, SVALS, C, A, X1, F1, PLINSW )     
      GO TO 300                                                         
 240  F2=F                                                              
      C2=C                                                              
      A2=A                                                              
      GO TO 300                                                         
C                                                                       
C     STILL LOOKING FOR THE MINIMUM                                     
C                                                                       
  250 X1=X2                                                             
      F1=F2                                                             
      A1 = A                                                            
      C1 = C                                                            
      S=S*STPMUL                                                        
      IT=IT+1                                                           
      IF(IT.LE.1000) GO TO 220                                          
      WRITE(6,263)
  263 FORMAT( '*** MORE THAN 1000 STEPS TO BOX MINIMUM IN B-- ')       
      GO TO 700                                                         
C                                                                       
C     FIND MINIMUM OF FITTED PARABOLA                                   
C                                                                       
 300  F2P = F1-2*F2+F3                                                  
      IF ( F2P .EQ. 0 ) GO TO 310                                       
      SM=(.5*S*(F1-F3))/F2P                                             
      XM=X2+SM                                                          
      IF((XM.LE.BMIN).OR.(XM.GT.BMAX)) GO TO 700                        
      CALL LINLSQ ( IXTYP2, N, XVALS, SVALS, CVAL, AVAL, XM, F, PLINSW )
      IF(F.LE.F2) GO TO 320                                             
 310  XM=X2                                                             
      AVAL=A2                                                           
      CVAL=C2                                                           
      F=F2                                                              
  320 B=XM                                                              
      CHISQ=F                                                           
      GO TO 400                                                         
 350  IF ( PBUGSW ) WRITE(6,353)
  353 FORMAT( '--- BEST-FIT IS AN EXP OR SIMPLE POWER --')             
      GO TO 700                                                         
C                                                                       
C     USE LOCAL TAYLOR EXPANSION TO REFINE ESTIMATE OF MINIMUM          
C                                                                       
  400 DX=DEL*XM                                                         
      FM=F                                                              
      XPL=XM+DX                                                         
      CALL LINLSQ ( IXTYP2, N, XVALS, SVALS, C, A, XPL, FPL, PLINSW )   
      XMI=XM-DX                                                         
      CALL LINLSQ ( IXTYP2, N, XVALS, SVALS, C, A, XMI, FMI, PLINSW )   
      FP=(FPL-FMI)/(2*DX)                                               
      F2P=(FPL-2*FM+FMI)/DX**2                                          
      IF ( F2P .EQ. 0 ) GO TO 430                                       
      XNEW=XM-FP/F2P                                                    
      CALL LINLSQ ( IXTYP2, N, XVALS, SVALS, C, A, XNEW, FM, PLINSW )   
      IF(FM.GE.F) GO TO 430                                             
      AVAL=A                                                            
      CVAL=C                                                            
      B=XNEW                                                            
      CHISQ = FM                                                        
C                                                                       
  430 TES = CVAL + AVAL                                                 
      IF(PBUGSW) WRITE(6,433) AVAL,CVAL,B,X2,CHISQ                         
  433 FORMAT( ' -*  (A,C) = (',G12.6,1X,G12.6,')'/ 5X,'(B,B2,CH)=(',G12.
     *6,1X,G12.6,1X,G12.6,')')                                          
      IF ( TES .LE. 0 .AND. IEXTYP .NE. 3 ) GO TO 350                   
      IF(PBUGSW) WRITE(6,443) IT                                           
  443 FORMAT( ' -COMPLETE IN ',I6,' ITERATIONS')                        
C                                                                       
      GO TO ( 540, 550, 570, 550 ), IEXTYP                              
C                                                                       
C     RETURN VALUES FOR WOODS-SAXON                                     
C                                                                       
 540  BARA = 1/DABS(AVAL)                                               
      WID = 1/B                                                         
      BARC = DSIGN( 1.D0, AVAL )                                        
      FLCRIT = XBAR -WID*DLOG(BARA*CVAL)                                
      BARL = FLCRIT                                                     
      AVAL = BARA                                                       
      GO TO 800                                                         
C                                                                       
C     RETURN VALUES FOR POWER FIT                                       
C                                                                       
 550  POWER = 1                                                         
      WID = B                                                           
      IF ( AVAL .LT. 0 ) GO TO 700                                      
      BARA = AVAL                                                       
      BARC = 1                                                          
      BARL = CVAL*XBAR/AVAL                                             
      FLCRIT = BARL                                                     
      GO TO 800                                                         
C                                                                       
C     VALUES FOR PHASE POWER (IEXTYP=3)                                 
C                                                                       
 570  BARA = AVAL                                                       
      BARC = CVAL                                                       
      FLCRIT = CVAL                                                     
      WID = B                                                           
      GO TO 800                                                         
C                                                                       
C     WID-MINIMUM NOT LOCATED WITHIN BOUNDS                             
C     REVERT TO EXPONENTIAL FORM                                        
C                                                                       
 700  IF ( IEXTYP .EQ. 3 ) GO TO 730                                    
      BARA = DEXP(AEXP)                                                 
      B = BEXP                                                          
      CHISQ = CHIEXP                                                    
      BARC = 0                                                          
      ISIG=5                                                            
      IF ( IEXTYP .NE. 1 ) GO TO 720                                    
      BARL = XBAR                                                       
      AVAL = BARA                                                       
      WID = 1/BEXP                                                      
      FLCRIT = BARL                                                     
      GO TO 800                                                         
 720  WID = BEXP                                                        
      FLCRIT = 0                                                        
      BARL = 0                                                          
      AVAL = BARA                                                       
      GO TO 800                                                         
 730  AVAL = AEXP                                                       
      CVAL = CEXP                                                       
      B = BEXP                                                          
      GO TO 570                                                         
C                                                                       
C     MAKE A FINAL TEST OF THE CORRECTNESS OF EVERYTHING                
C                                                                       
 800  IF ( B .GT. BMIN ) GO TO 810                                      
      WRITE(6,803) B, BARA, BARC, BARL                                    
 803  FORMAT ( ' *** ERROR IN EXTRAP: B OUT OF BOUNDS:', 4G15.5 )       
      GO TO 940                                                         
C                                                                       
 810  IF ( PBUGSW ) WRITE(6,813) IEXTYP,BARA,B,BARC,BARL,AVAL,WID, 
     *CVAL, FLCRIT, CHISQ                                               
 813  FORMAT ( ' LXTRP1 END', I3, 9G13.5 / )                            
C                                                                       
C     CHECK FOR SLOWLY DECAYING EXTRAPOLATION                           
C                                                                       
      IF ( MCHN .EQ. 1 ) GO TO 900                                      
      GO TO ( 820, 830, 900, 830 ), IEXTYP                              
 820  IF ( B .GT. .01 ) GO TO 900                                       
      GO TO 890                                                         
 830  IF ( B .GT. BMIN+.6 ) GO TO 900                                   
      GO TO 890                                                         
 890  WRITE(6,893) AVAL, B, CVAL, FLCRIT                                  
 893  FORMAT ( '0*** WARNING:  EXTRAPOLATION DECAYS VERY SLOWLY;'  '  A,
     * B, C, LCRIT = ', 4G15.5 )                                        
      WRITE(6,958) MCHN, JP, JT, LX, LDEL                                 
C                                                                       
 900  RETURN                                                            
C                                                                       
C     ONE-PARAMETER MINIMIZATION W.R.T. WIDTH HAS FAILED                
C     ERROR RETURN ; SUPPRESS EXTRAPOLATION                             
C                                                                       
  940 WRITE(6,943)                                                         
  943 FORMAT( '0*** MINIMIZATION W.R.T. WIDTH HAS FAILED '/ 7X,'EXTRAPOL
     *ATION MUST BE SUPPRESSED --')                                     
      ISIG=-5                                                           
      RETURN                                                            
C                                                                       
 950  WRITE(6,953)
 953  FORMAT ( '0**** ATTEMPTING TO FIT VERY SHARP WOODS-SAXON -',  ' AT
     *TEMPT ABANDONED' )                                                
 955  WRITE(6,958) MCHN, JP, JT, LX, LDEL                                 
 958  FORMAT ( 6X, 'FOR CHANNEL', I3,  ', JP, JT, LX, LO-LI =', 2(I3, '/
     *2'), 2I4 )                                                        
      GO TO 700                                                         
C                                                                       
 960  WRITE(6,963)
 963  FORMAT ( '0*** ATTEMPTING TO FIT WITH POWER OF 0 --',  ' DEFAULT S
     *TARTING VALUE USED.' )                                            
      GO TO 955                                                         
      END                                                               
      SUBROUTINE LXTRP2 ( IEXTYP, BARA, B, BARC, BARL, DLMAX, LI,  SIZE,
     * LX, LDEL, ETAS )                                                 
C                                                                       
C     COMPUTES THE LEXTRAPOLATION FUNCTIONS                             
C                                                                       
C     SEE  LXTRP1 FOR THE PARAMETERS.                                   
C     EXCEPT NOTE THAT FOR IEXTYP=3, BARA AND BARC HAVE BEEN            
C     REVERSED.                                                         
C     SIZE IS SET TO THE COMPUTED VALUE AT LI.                          
C                                                                       
C     4/12/80 - FIRST VERSION - S.P.                                    
C     5/7/80 - IEXTYP=3 - S.P.                                          
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      DIMENSION ETAS(2)                                                 
C                                                                       
      DLI = LI                                                          
C                                                                       
      GO TO ( 110, 120, 130, 140 ), IEXTYP                              
C                                                                       
 110  X = B*(DLI-BARL)                                                  
      IF ( X .LT. -46 ) X = -46                                         
      SIZE = BARA / (BARC+DEXP(X))                                      
      RETURN                                                            
C                                                                       
 120  SIZE = BARA * (DLMAX/DLI)**B * (1+BARL/DLI)                       
      RETURN                                                            
C                                                                       
 130  SIZE = BARC + BARA*(DLMAX/DLI)**B                                 
      RETURN                                                            
C                                                                       
 140  ETA = .5*(ETAS(1)+ETAS(2))                                        
      DLI = DLI + .5*LDEL                                               
      SIZE = BARA * (DLMAX/DLI)**B * (1+BARL/DLI)                       
      SIZE = SIZE * (DSIN(DATAN(ETA/DLI)))**LX  * DEXP(-(ETAS(2)-ETAS(1)
     *) * ( DATAN(ETA/DLI) + DLI/ETA ) )                                
      RETURN                                                            
C                                                                       
      END                                                               
