      SUBROUTINE CCDUMP                                                 
C                                                                       
C     PRINTS THE VARIOUS COUPLED CHANNEL ARRAYS                         
C                                                                       
C     9/16/80 - FIRST VERSION - S.P.                                    
C     12/10/80 - ADD K QUANTUM NUMBER - S.P.                            
C     10/17/81 - MORE DIGITS FOR IPT PRINTOUT - 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 /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
C                                                                       
      IF ( ICHNDF .EQ. 0 ) GO TO 900                                    
C                                                                       
      LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      NCHNDF = ILLOC(LCHNDF)                                            
      MCHNDF = ILLOC(LCHNDF+1)                                          
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2)                                 
C                                                                       
      WRITE(6,103) HEADER, REACT, NCHNDF, MCHNDF                          
 103  FORMAT ( X, 65A1, 20X, 45A1 /  ' CHANNEL DEFINITION ARRAY:', I5,
     * ' CHANNELS,',  I5, ' ELEMENTS PER CHANNEL.' /  '   N  NAME   JT  
     *  KT    ET     JP    KP    EP',  T54, 'ETA', T63, 'K', T70, 'BASIS
     *',  T78, 'SMAT  NS', T91, 'POINTERS' /  T69, 'PNT NUM', T77, '  PN
     *T PLI', T87, 'INDX TOCS',  ' SMAT LIMOST' / )                     
 108  FORMAT ( 2I5, 2( 2( I4, '/2' ), F7.3 ), F9.2, F8.2, I6, I4, I6,  I
     *4, 2I5, 1X, 6I5 )                                                 
C                                                                       
      MCHN = MCHNDF-1                                                   
      DO 159 NCHN = 1, NCHNDF                                           
      L = LCHNDF + (NCHN-1)*MCHNDF                                      
      WRITE(6,108) NCHN,ILLOC(L),ILLOC(L+1),ILLOC(L+15),ALLOC4(L+2), 
     *ILLOC(L+3), ILLOC(L+16),  (ALLOC4(L+I), I=4, 6), (ILLOC(L+I), I=7,
     *MCHN)                                                             
 159  CONTINUE                                                          
C                                                                       
      IF ( IBASDF .EQ. 0 ) RETURN                                       
      LBASDF = FACFR4*(Z(IBASDF)-1) + 1                                 
      NBASDF = ILLOC(LBASDF)                                            
      MBASDF = ILLOC(LBASDF+1)                                          
      LBASDF = LBASDF + ILLOC(LBASDF+2)                                 
C                                                                       
      WRITE(6,203) NBASDF, MBASDF                                         
 203  FORMAT ( X / ' BASIS DEFINITION ARRAY:', I5,  ' BASIS STATES,', 
     *I5, ' ELEMENTS PER STATE.' /  '   N  CHAN   S    L-J', T24, 'BASIS
     * COUP',  T36, 'WAVE' /  T25, 'PTR  NUM', T36, 'STRT' )            
 208  FORMAT ( 2I5, I4, '/2', I4, '/2', 2I5, 2X, I5, 1X, 5I5 )          
C                                                                       
      LAST = -987654                                                    
      MBAS = MBASDF-1                                                   
      DO 259 NBAS = 1, NBASDF                                           
      L = LBASDF + (NBAS-1)*MBASDF                                      
      IF ( ILLOC(L) .EQ. LAST ) GO TO 240                               
      LAST = ILLOC(L)                                                   
      WRITE(6,213)
 213  FORMAT ( ' ' )                                                    
 240  WRITE(6,208) NBAS, ILLOC(L), (ILLOC(L+I), I=1, MBAS)                
 259  CONTINUE                                                          
C                                                                       
      LBASCP = FACFR4*(Z(IBASCP)-1) + 1                                 
      NBASCP = ILLOC(LBASCP)                                            
      MBASCP = ILLOC(LBASCP+1)                                          
      LBASCP = LBASCP + ILLOC(LBASCP+2)                                 
C                                                                       
      WRITE(6,303) NBASCP, MBASCP                                         
 303  FORMAT ( X / ' BASIS COUPLING ARRAY:', I6,  ' COUPLINGS,', I5, '
     * ELEMENTS PER COUPLINGS.' /  '   N1-N2  ORD MULT', T26, 'COUP. CON
     *S.',  T44, 'IFAC', 5X, 'IPT', T60, 'POINTERS' /  T23, 'NUCLEAR', T
     *34, 'COULOMB', T58, 'BFAC',  T64, 'NUC', T68, 'COUL' )            
 308  FORMAT ( I5, '-', I3, I4, I3, '/2', G13.4, G12.4,  I4, I8, 3I5, 1X
     *, 4I5 )                                                           
C                                                                       
      LAST = -987654                                                    
      MBAS = MBASCP-1                                                   
      DO 359 NBAS = 1, NBASCP                                           
      L = LBASCP + (NBAS-1)*MBASCP                                      
      IF ( ILLOC(L) .EQ. LAST ) GO TO 340                               
      LAST = ILLOC(L)                                                   
      WRITE(6,213)
 340  WRITE(6,308) ILLOC(L),(ILLOC(L+I),I=1,3),ALLOC4(L+4),ALLOC4(L+5)
     *,  ( ILLOC(L+I), I=6, MBAS )                                      
 359  CONTINUE                                                          
C                                                                       
      RETURN                                                            
C                                                                       
 900  WRITE(6,903)
 903  FORMAT ('0*** NO ARRAYS TO DUMP' )                                
      RETURN                                                            
      END                                                               
      SUBROUTINE CCHAN(IRET)                                            
C                                                                       
C    INPUT ROUTINE FOR CHANNEL SPECIFICATION                            
C    STRUCTURE OF DATA IN ALLOCATOR                                     
C    PREFACE                                                            
C     LDATA4 +0 #BLOCKS                                                 
C            +1 LENGTH OF BLOCK                                         

C            +2 LENGTH OF PREFACE                                       
C    LABEL  +0 NUMERICAL NAME FORCHANNEL                                
C           +1 TARGET LEVEL SPIN AND PARITY       2*PARITY*J            
C           +2 TARGET LEVEL ENERGY                                      
C           +3 PROJECTILE LEVEL SPIN AND PARITY   2*PARITY*J            
C           +4 PROJECTILE LEVEL ENERGY                                  
C           +5 CHANNEL ETA VALUE              SET BY BASLBL             
C           +6 CHANNEL MOMENTUM VALUE         SET BY BASLBL             
C           +7 POINTER FOR BASIS STATES       SET BY BASLBL             
C           +8 DEGENERACY OF BASIS STATES     SET BY BASLBL             
C           +9  POINTER TO S-MATRICES         SET BY ANGSET             
C           +10 NSPLI FOR THIS CHANNEL        SET BY ANGSET             
C           +11 POINTER TO S-MATRICES INDXS   SET BY ANGSET             
C           +12 POINTER TO S-MATRICES TOCS    SET BY ANGSET             
C           +13 KSMAT                         SET BY LINTRP             
C           +14 LIMOST                        SET BY LINTRP             
C           +15 KT QUANTUM NUMBER OF ROTATIONAL MODEL                   
C           +16 2*KP                                                    
C                                                                       
C           +5-+8 CALCULATED IN BASLBL(IRET)                            
C                                                                       
C     12/1/79 - FIRST VERSION - MRB                                     
C     1/15/80 - STORE ADDRESS IN CCBLK - S.P.                           
C     6/24/80 - PUT BACK WORDS 14&15 -- THIS WAS LOST - S.P.            
C     9/26/80 - SET +5 THROUGH +14 TO NOTDEF - S.P.                     
C     12/10/80 - K QUANTUM NUMBER - S.P.                                
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
C                                                                       
      CHARACTER*1 PLUS,MINUS                                            
      DATAMINUS/'-'/                                                    
      DATA PLUS / '+' /                                                 
C                                                                       
      DATA NUMKEY /7/                                                   
	CHARACTER*8 KEYS(7)
      DATA KEYS/'NAME','JT','ET','JP','EP', 'KT', 'KP'/                 
	CHARACTER*8 AKEY
C                                                                       
      DATA LENDAT /17/, LEKEY /3/, LAL/5/                               
      CHARACTER*1 IPM
	REAL*8 NAME8
      DATA NAME8 / 'CHANNELS' /                                         
	CHARACTER*8 NAME9 /'CHANNELS'/
      COMMON/NAMCOM/ANAMES(1)                                           
      INTEGER GIVEAL                                                    
C                                                                       
      ICD3I=0                                                           
      IRET=0                                                            
      INAME=0                                                           
      IJT=0                                                             
      IET=0                                                             
      IJP=0                                                             
      IEP=0                                                             
      IKP = 0                                                           
      IKT = 0                                                           
      ICH=0                                                             
      I=NAMLOC(NAME9)                                                   
      IF(I.NE.0)Z(I)=-Z(I)                                              
      ICHNDF=GIVEAL(IWRDS)                                              
      LDATA=Z(ICHNDF)                                                   
      ANAMES(ICHNDF)=NAME8                                              
      LDATA4=FACFR4*(LDATA-1)+1                                         
      ILLOC(LDATA4+1)=LENDAT                                            
      ILLOC(LDATA4+2)=LAL                                               
      ILLOC(LDATA4+3)=0                                                 
      ILLOC(LDATA4+4)=0                                                 
      LABEL=LDATA4+LAL                                                  
      CALL FITKEY(AKEY,&90,&900,&900,&900)                              
      GO TO 900                                                         
C                                                                       
C     FIRST GET THE KEYWORDS AND ORDER OF SPIN                          
C                                                                       
C    ( ENCOUNTERED LETS GO                                              
 90   IORDER=0                                                          
 100  CALL NXWORD(AKEY,&699,&900,&900)                                  
      DO 110 I=1,NUMKEY                                                 
      IF(KEYS(I).NE.AKEY)GO TO 110                                      
      GO TO (200,250,300,350,400,410,420 ),I                            
 110  CONTINUE                                                          
      GO TO 900                                                         
 200  IORDER=IORDER+1                                                   
      INAME=IORDER                                                      
      IF(INAME.NE.1)GO TO 930                                           
      GO TO 100                                                         
 250  IORDER=IORDER+1                                                   
      IJT=IORDER                                                        
      GO TO 100                                                         
 300  IORDER=IORDER+1                                                   
      IET=IORDER                                                        
      GO TO 100                                                         
 350  IORDER=IORDER+1                                                   
      IJP=IORDER                                                        
      GO TO 100                                                         
 400  IORDER=IORDER+1                                                   
      IEP=IORDER                                                        
      GO TO 100                                                         
 410  IORDER = IORDER+1                                                 
      IKT = IORDER                                                      
      GO TO 100                                                         
 420  IORDER = IORDER+1                                                 
      IKP = IORDER                                                      
      GO TO 100                                                         
 699  IF(IORDER.LT.LEKEY)GO TO 940                                      
      LABEL=LABEL-LENDAT                                                
C                                                                       
C     ADVANCE TO TAHE NEXT CHANNEL                                      
C                                                                       
 700  LABEL=LABEL+LENDAT                                                
      ILLOC(LABEL+1)=0                                                  
      ILLOC(LABEL+3)=0                                                  
      ALLOC4(LABEL+2)=0.0                                               
      ALLOC4(LABEL+4)=0.0                                               
      ALLOC4(LABEL+5) = UNDEF                                           
      ALLOC4(LABEL+6) = UNDEF                                           
      DO 709 I = 8, LENDAT                                              
      ILLOC(LABEL+I-1) = NOTDEF                                         
 709  CONTINUE                                                          
C                                                                       
C     KT AND KP ARE ZERO BY DEFAULT                                     
C                                                                       
      ILLOC(LABEL+15) = 0                                               
      ILLOC(LABEL+16) = 0                                               
      DO 799 I=1,IORDER                                                 
      IF(I.EQ.INAME)GO TO 720                                           
      IF(I.EQ.IJT)GO TO 730                                             
      IF(I.EQ.IJP)GO TO 740                                             
      IF ( I .EQ. IKT ) GO TO 750                                       
      IF ( I .EQ. IKP ) GO TO 760                                       
      CALL NXVALF(TEMP,&910,&910,&910,&910)                             
      IF(I.EQ.IET)ALLOC4(LABEL+2)=TEMP                                  
      IF(I.EQ.IEP)ALLOC4(LABEL+4)=TEMP                                  
      GO TO 799                                                         
 720  CALL NXINT(INT,&910,&910,&800)                                    
      ILLOC(LABEL)=INT                                                  
      GO TO 799                                                         
 730  CALL NXHINT(INT,&910,&910,&910)                                   
      IPM=IBUF(INCH-1)                                                  
      IF(IPM.EQ.PLUS)ILLOC(LABEL+1)=INT                                 
      IF(IPM.EQ.MINUS)ILLOC(LABEL+1)=-INT                               
      GO TO 799                                                         
 740  CALL NXHINT(INT,&910,&910,&910)                                   
      IPM=IBUF(INCH-1)                                                  
      IF(IPM.EQ.PLUS)ILLOC(LABEL+3)=INT                                 
      IF(IPM.EQ.MINUS)ILLOC(LABEL+3)=-INT                               
      GO TO 799                                                         
 750  CALL NXHINT ( ILLOC(LABEL+15), &910, &910, &910 )                 
      GO TO 799                                                         
 760  CALL NXHINT ( ILLOC(LABEL+16), &910, &910, &910 )                 
 799  CONTINUE                                                          
      ICH=ICH+1                                                         
      GO TO 700                                                         
 800  CALL FITKEY(AKEY,&900,&900,&810,&900)                             
      GO TO 900                                                         
 810  ILLOC(LDATA4)=ICH                                                 
      IWRDS=(LABEL-LDATA4)/FACFR4+1                                     
      IL=CHOPIT(IWRDS)                                                  
      IRET=1                                                            
      RETURN                                                            
C                                                                       
900   WRITE(6,901)(KEYS(I),I=1,NUMKEY)                                  
901   FORMAT ( '0****  CHANNEL DEFINITIONS NOT ENCLOSED IN',  ' PARENTHE
     *SES OR A KEYWORD IS MISPELLED;', ' CHANNELS KEYWORDS ARE:' // ( 1X
     *, 10A9 ) )                                                        
      RETURN                                                            
910   WRITE(6,911)I                                                     
911   FORMAT ( '0****  ERROR IN READING',I5,' NUMERICAL DATA ',  'IN SET
     *.' )                                                              
      RETURN                                                            
920   WRITE(6,921)LEKEY                                                 
921   FORMAT ( '0****  INPUT ERROR - NUMBER OF INPUT NUMBERS MUST BE',  
     *I5, '*N' )                                                        
      RETURN                                                            
930   WRITE(6,931)                                                      
931   FORMAT ( '0****  CHANNEL SPECIFICATION MUST BE FIRST KEYWORD')    
      RETURN                                                            
 940  WRITE(6,943)
 943  FORMAT ( '0*** AT LEAST THREE KEYWORDS ARE REQUIRED.')            
      RETURN                                                            
      END                                                               
      SUBROUTINE CCMTCH ( ILI, J, IB, SMATS, CFAC, NBASDF,  WAVR, WAVI, 
     *NPTSAV, HOMO, MBASDF, BASDEF,  MBASCP, BASCUP, RBASCP,  MCHNDF, RC
     *HNDF, BFACS, MBNDX, BINDEX, FG, VSCALE )                          
C                                                                       
C     EXTRACTS S-MATRIX ELEMENT AND HOMO C-FACTOR FROM C.C. SOLUTION    
C                                                                       
C     THE PARTICULAR SOLUTION IS IN WAVR AND WAVI.  IT IS EXPRESSED     
C     INTERMS OF INCOMING AND OUTGOING WAVES AND THE HOMO               
C     SOLUTION TO DETERMIN THE S-MATRIX AND CFAC:                       
C                                                                       
C       R'(IB) = 12*R(IB) --> (6I)*( IN(IB0,IB) -                       
C            SUM(IB') SQRT(K0/K') S(IB',0) OUT(IB',IB) )                
C           = Z'(IB) + CFAC*(IB)                                        
C                                                                       
C     HERE IN AND OUT ARE THE COUPLED INCOMING AND OUTGOING             
C     COULOMB SOLUTIONS.                                                
C                                                                       
C     NOTE THAT THE PARTICULAR SOLUTION IS 12*(CORRECT SOLUTION) AND WE 
C     GENERATE  R' = 12*(CORRECT R).                                    
C                                                                       
C     ILI & J - THE LIS POINTER AND 2*TOTAL J.                          
C     IB - BASIS STATE TO BE SOLVED FOR.                                
C     SMATS (COMPLEX*16) - COMPLETE ARRAY OF S-MATRICES AS FOUND        
C           SO FAR.  SMAT(IB) WILL BE UPDATED.                          
C           IT SHOULD BE INITIALIZED TO   S(HOMO), 0, 0, ... 0          
C           AT THE BEGINNING OF THE ITERATIONS.                         
C     CFAC (COMPLEX*8) - WILL BE SET TO THE C-FACTOR                    
C     NBASDF - NUMBER OF BASIS STATES.                                  
C     WAVR, WAVI - THE JUST COMPUTED Z'(IB) = 12*Z(IB)                  
C     HOMO (COMPLEX*8) - THE TWO-DIMENSIONAL ARRAY OF HOMO SOLUTIONS.   
C     MBASDF - LENGTH OF A BASIS STATE DEFINITION.                      
C     BASDEF - THE TWO-DIMENSIONAL PART OF THE BASIS STATE DEFS.        
C     MBASCP - LENGTH OF A BASIS COUPLING ENTRY.                        
C     BASCUP, RBASCP - THE BASIS COUPLING ARRAY PAST THE HEADER.        
C     MCHNDF, RCHNDF - THE LENGTH OF AND CHANNEL DEFINITION             
C     BFACS - THE BFACTORS AS RETURNED BY GETBFC                        
C     BINDEX - THE B-INDEX ARRAY (IBINDX)                               
C     FG - THE COULOMB FUNCS ARRAY  NFS(1)                              
C                                                                       
C     VSCALE - A FACTOR FOR THE ENTIRE COUPLING POTENTIAL               
C     2/17/80 - FIRST VERSION - S.P.                                    
C     3/9/80 - FIX UP USING REVERSED CHANNELS - S.P.                    
C     3/27/80 - FIX IT RIGHT THIS TIME - S.P.                           
C     4/27/80 - NPTSAV DIMENSION - S.P.                                 
C     5/29/80 - CDC HAS 3 DIMS FOR FG, WAVR(1) - S.P.                   
C               PASS MBNDX FOR CDC COMPATABILITY.                       
C     10/26/81 - MULT BY ROOT 2 FOR SYMMETRIC CHANNELS - S.P.           
C     3/15/82  TEMPORARY REAL8 VERSION                                  
C     3/15/82 - ADD VSCALE                                              
C     4/10/82 - BACK TO REAL*4 - S.P.                                   
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
	complex*16 smats(nbasdf)
      COMPLEX*8 CFAC, BFACS(2,1)                                        
      COMPLEX*8 HOMO(NPTSAV, NBASDF)                                    
      REAL*8 WAVR(1), WAVI(1)                                           
      INTEGER BASDEF(MBASDF, NBASDF), BASCUP(MBASCP, 1)                 
      REAL*4 RBASCP(MBASCP,1), RCHNDF(MCHNDF,1)                         
      REAL*4 FG(2,2,NBASDF,1)                                           
CDC      DIMENSION  FG(4, NBASDF, 1)                                    
CDC%'FG(#,#,#,#)' = 'FG(2*#2-2+#1, #3, #4)'                             
      INTEGER BINDEX(MBNDX, 1)                                          
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                                                            
      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 s1(2),s2(2),s3(2),a(2,2),d(2),bfac(2),outcou(2), inc
     *OU(2), FAC, FAC2, DET                                             
      REAL*8 RBFAC(2,2)                                                 
      EQUIVALENCE ( BFAC(1), RBFAC(1) )                                 
C                                                                       
C     MARK STORES -2, -1, 1, 2  TO MEAN  -I, -1, +1, +I (STRANGE)       
C                                                                       
	complex*16 itol(5)
      DATA ITOL/(0.D0,-1.D0), (-1.D0,0.D0), (0.D0, 0.D0), (1.D0,0.D0), (
     *0.D0,+1.D0)/                                                      
C                                                                       
      DATA ROOT2 / 1.41421 35623 731 0D0 /                              
C                                                                       
      LOGICAL PBUGSW                                                    
C                                                                       
      PBUGSW = MOD(IPRINT,10) .GE. 8                                    
C                                                                       
      DO 29 I = 1, 2                                                    
      S1(I) = 0                                                         
      S2(I) = 0                                                         
      S3(I) = 1                                                         
C                                                                       
C     FOLLOWING ARE 6I*INCOMING AND 6I*OUTGOING WAVES                   
C                                                                       
      INCOU(I) = CMPLX( 6*FG(1,I,IB,ILI), 6*FG(2,I,IB,ILI) )            
      OUTCOU(I) = CMPLX(-6*FG(1,I,IB,ILI), 6*FG(2,I,IB,ILI) )           
 29   CONTINUE                                                          
C                                                                       
      AK0 = RCHNDF(7,1)                                                 
      IC1 = BASDEF(1,IB)                                                
      AK1 = RCHNDF(7,IC1)                                               
      L1MJ = BASDEF(3,IB)                                               
C                                                                       
      IF ( NOBFAC .EQ. 1 ) GO TO 300                                    
C                                                                       
C     COMPUTE THE BFACTOR CONTRIBUTIONS                                 
C                                                                       
      ICPST = BASDEF(4,IB)                                              
      ICPEND = ICPST + BASDEF(5,IB) - 1                                 
C                                                                       
C     LOOP OVER ALL COUPLED STATES LOOKING FOR THOSE WITH B-FACTORS     
C                                                                       
      DO 289 ICUP = ICPST, ICPEND                                       
C                                                                       
      IBNDX = BASCUP(9,ICUP)                                            
      IF ( IBNDX .EQ. 0 ) GO TO 289                                     
      IBP = BASCUP(2,ICUP)                                              
      L2MJ = BASDEF(3,IBP)                                              
      IF ( J .LT. -L2MJ ) GO TO 289                                     
C                                                                       
C     HERE ARE THE ANGULAR-MOMENTUM COUPLING TERMS AND THE              
C     I**(L2-L1) OR WHATEVER                                            
C                                                                       
      FAC = RBASCP(6,ICUP)*RBASCP(8,ICUP)*ITOL(BASCUP(7,ICUP)+3)        
      FAC = VSCALE*FAC                                                  
C                                                                       
C     COMPUTE SUBSCRIPT TO B-FACTOR ARRAY                               
C                                                                       
      LL1MJ = L1MJ                                                      
      LL2MJ = L2MJ                                                      
      ASSIGN 185 TO IGOTO                                               
      IF ( IBNDX .GT. 0 ) GO TO 150                                     
      LL1MJ = L2MJ                                                      
      LL2MJ = L1MJ                                                      
      IBNDX = -IBNDX                                                    
      ASSIGN 180 TO IGOTO                                               
 150  LX = BINDEX(1,IBNDX)                                              
	i=((lx+1)*(ll1mj-bindex(6,ibndx))+ll2mj-ll1mj)/2+lx
	i=i/2+bindex(8,ibndx)
C                                                                       
C     PICK UP THE TWO BFACTORS AND IF NECESSARY ADJUST SIGN             
C     OF THE REAL PART FOR REVERSED CHANNELS.                           
C                                                                       
      DO 189 II = 1, 2                                                  
      BFAC(II) = BFACS(II,I)                                            
      GO TO IGOTO, ( 180, 185 )                                         
 180  RBFAC(1,II) = -RBFAC(1,II)                                        
 185  BFAC(II)=FAC*BFAC(II)                                             
 189  CONTINUE                                                          
C                                                                       
      IF ( IBP .EQ. IB ) GO TO 250                                      
C                                                                       
C     THIS IS NOT DIAGONAL COUPLING                                     
C                                                                       
      ICP = BASDEF(1,IBP)                                               
      FAC2 = SQRT(AK0/RCHNDF(7,ICP)) * SMATS(IBP)                       
      IF ( BASDEF(7,IBP) .EQ. 2 ) FAC2 = FAC2/ROOT2                     
      S2(1) = S2(1) + FAC2*BFAC(1)                                      
      S2(2) = S2(2) + FAC2*BFAC(2)                                      
C                                                                       
C     IF THIS IS THE G.S. COUPLED TO IB, THEN NEED AN INCOMING          
C     TERM ALSO.                                                        
C                                                                       
      IF ( ICP .NE. 1 ) GO TO 289                                       
      IF(MOD(LX,2).NE.0)GO TO 240                                       
      S1(1) = S1(1) + BFAC(1)                                           
      S1(2) = S1(2) + BFAC(2)                                           
      GO TO 289                                                         
240   S1(1)=S1(1)-BFAC(1)                                               
      S1(2)=S1(2)-BFAC(2)                                               
      GO TO 289                                                         
C                                                                       
C     DIAGONAL COUPLING IS SUMMED IN S3                                 
C                                                                       
 250  S3(1) = S3(1) + BFAC(1)                                           
      S3(2) = S3(2) + BFAC(2)                                           
C                                                                       
 289  CONTINUE                                                          
C                                                                       
C     NOW SOME OVERALL FACTORS FOR THE B-FACTOR STUFF                   
C                                                                       
      DO 299 I = 1, 2                                                   
      S1(I) = -CONJG(S1(I)) * INCOU(I)                                  
      S2(I) = S2(I)*OUTCOU(I)                                           
 299  CONTINUE                                                          
C                                                                       
      IF ( PBUGSW ) WRITE(6,293) S1, S2, S3                               
 293  FORMAT ( ' B-CONTRIBS:', ( T15, 4( G15.5, G13.5 ) ) )             
C     NOW CONSTRUCT THE COEFICENTS IN THE 2X2 EQUATIONS.                
C                                                                       
 300  N = NUMPT-NBACK                                                   
      DO 329 I = 1, 2                                                   
      A(I,1) = -SQRT(AK0/AK1) * S3(I)*OUTCOU(I)                         
      A(I,2) = -HOMO(N,IB)                                              
      D(I) = CMPLX( WAVR(N), WAVI(N) ) + S1(I)+S2(I)                    
      IF ( IC1 .EQ. 1 ) D(I) = D(I) - INCOU(I)                          
      N = NUMPT                                                         
 329  CONTINUE                                                          
C                                                                       
      DET = 1/( A(1,1)*A(2,2) - A(1,2)*A(2,1) )                         
C                                                                       
      IF ( PBUGSW ) WRITE(6,353) A, D, DET                                
 353  FORMAT ( ' MATCH:', ( T15, 4( G15.5, G13.5 ) ) )                  
C                                                                       
      SMATS(IB) = ( D(1)*A(2,2) - D(2)*A(1,2) )*DET                     
      CFAC = ( D(2)*A(1,1) - D(1)*A(2,1) )*DET                          
C                                                                       
      IF ( BASDEF(7,IB) .EQ. 2 ) SMATS(IB) = ROOT2*SMATS(IB)            
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE CCONV ( CSMATS, ITR, ITEST, NBASDF, PADE,  MAXIT1, ELAS
     *T, EXR, EXI, INDXS, CHNDEF, MCHNDF,  BASDEF, MBASDF, IJ, NCHNDF, J
     *T, NLINE )                                                        
C                                                                       
C     CHECK CONVERGENCE OF S-MATRIX ELEMENTS AND USE WYNN ALGORITHUM    
C                                                                       
C     FIRST VERSION 26/2/80 MRB                                         
C     6/22/81 - USE COMPLEX ARITHMATIC, FIX CONVERG CHECK - S.P.        
C     10/13/81 - CONTROL PRINTINT FOR PRINT=0 - S.P.                    
C                                                                       
C     THE WYNN ALGORITHUM HAS THE SAME EFFECT ON A BRAIN AS  VALLIUM    
C                                                                       
C     CSMATS IS A NUM.BASIS.STATES X 2  COMPLEX                         
C            ARRAY.  THE FIRST COLUMN IS THE LATEST ADDITION TO IT.     
C            THE SECOND COLUMN IS THE PREVIOUS ITERATION                
C     PADE IS A 3 X (MAXITR+1)/2 X NUM.BASIS.STATES  COMPLEX ARRAY OF   
C            THE LAST THREE DIAGONALS AND OFF-DIAGONALS OF THE          
C            WYNN ALGORITHYM.                                           
C                                                                       
	IMPLICIT COMPLEX*16 (C) ,REAL*8 (A, B, D-H, O-Z)
C                                                                       
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      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                                           
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
C                                                                       
      LOGICAL TBIT                                                      
	COMPLEX*16 CSMATS(NBASDF,1),PADE(3,MAXIT1,NBASDF)
      REAL*8 ELAST(1),EXR(1),EXI(1)                                     
      INTEGER*4 INDXS(1), CHNDEF(MCHNDF,1), BASDEF(MBASDF,1)            
      LOGICAL PRSW                                                      
C                                                                       
      PRSW = MOD(IPRINT, 10) .GT. 0                                     
      NADD = 1                                                          
      IF ( PRSW ) NADD = NBASDF                                         
C                                                                       
C     CHECK FOR CONVERGENCE OF S-MATRIX ELEMENTS  IN ALL CHANNELS       
C                                                                       
      ITEST = 0                                                         
      IF ( ITR .LT. 3 ) GO TO 700                                       
      DO 59 ICHAN = 1, NCHNDF                                           
      D1 = 0                                                            
      D2 = 0                                                            
      I1 = CHNDEF(8,ICHAN)                                              
      I2 = CHNDEF(9,ICHAN) + I1-1                                       
      DO 49 I3 = I1, I2                                                 
      CS1 = CSMATS(I3,1)                                                
      CS2 = CSMATS(I3,2)                                                
	SMOD=CDABS(CS1)
      IF ( SMOD .EQ. 0 ) GO TO 49                                       
	IF(SMOD.LT.1.0D-29)GO TO 49
      D2 = DMAX1( D2, SMOD )                                            
      CS1MS2 = CS1-CS2                                                  
	DIFMOD=CDABS(CS1MS2)
      IF ( CONVRG .EQ. 2 ) DIFMOD = DIFMOD/SMOD                         
      D1 = DMAX1( D1, DIFMOD )                                          
  49  CONTINUE                                                          
      IF ( CONVRG .EQ. 0 ) D1 = D1/D2                                   
      IF ( D1 .GT. ACCURA ) GO TO 100                                   
  59  CONTINUE                                                          
      ITEST = 1                                                         
C                                                                       
C                                                                       
C     USE PADE TABLE TO ACCELERATE CONVERGENCE                          
C     WE USE WYNN ALGORITHUM                                            
C     ONLY LOWER HALF TABLE CONSTRUCTED                                 
C     WE COMPARE DIAGONAL ELEMENTS FOR ODD ITERATION                    
C     WE COMPARE OFF DIAGONAL WITH PREVIOUS DIAGONAL FOR EVEN           
C                                                                       
 100  ITR1=(ITR-1)/2                                                    
      ITR1P1 = ITR1+1                                                   
      DO 199 I=1,NBASDF                                                 
      PADE(3,1,I) = CSMATS(I,1)                                         
      DO 189 J=1,ITR1                                                   
      CS1 = PADE(2,J,I)                                                 
      CS2 = PADE(1,J,I)-CS1                                             
      CS3 = PADE(3,J,I)                                                 
	IF(ABS(DREAL(CS3))+ABS(DIMAG(CS3)).EQ.0)GO TO 170
      CS3 = CS3-CS1                                                     
      CS4 = 0                                                           
      IF ( J .EQ. 1)GO TO 150                                           
      CS4 = PADE(1,J-1,I)-CS1                                           
      CS4 = 1/(CS4+1.D-30)                                              
 150  CS5 = 1/(CS2+1.D-30) + 1/(CS3+1.D-30) - CS4                       
      CS5 = 1/(CS5+1.D-30)                                              
      CS3 = CS5+CS1                                                     
 170  PADE(3,J+1,I) = CS3                                               
 189  CONTINUE                                                          
 199  CONTINUE                                                          
C                                                                       
C                                                                       
      IF ( ITEST .EQ. 1 .OR. ITR .LE. 3 ) GO TO 700                     
C                                                                       
C     CHECK FOR CONVERGENCE OF PADE S-MATRIX                            
C                                                                       
      DO 459 ICHAN = 1, NCHNDF                                          
      D1 = 0                                                            
      D2 = 0                                                            
      I1 = CHNDEF(8,ICHAN)                                              
      I2 = CHNDEF(9,ICHAN) + I1-1                                       
      DO 449 I3 = I1, I2                                                
      CS1 = PADE(3,ITR1P1,I3)                                           
      CS2 = PADE(2,ITR1P1,I3)                                           
      IF ( MOD(ITR,2).NE.0 ) CS2 = PADE(1,ITR1,I3)                      
      SMOD = CDABS(CS1)
      IF ( SMOD .EQ. 0 ) GO TO 449                                      
	IF(SMOD.LT.1.0D-29)GO TO 449
      D2 = DMAX1( D2, SMOD )                                            
      CS1MS2 = CS1-CS2                                                  
      DIFMOD = CDABS(CS1MS2)
      IF ( CONVRG .EQ. 2 ) DIFMOD = DIFMOD/SMOD                         
      D1 = DMAX1( D1, DIFMOD )                                          
 449  CONTINUE                                                          
      IF ( CONVRG .EQ. 0 ) D1 = D1/D2                                   
      IF ( D1 .GT. ACCURA ) GO TO 700                                   
 459  CONTINUE                                                          
      ITEST = 1                                                         
C                                                                       
 700  IF ( ITEST .EQ. 0 .AND. MOD(IPRINT,10) .LT. 3  .AND. ITR .LT. MAXI
     *TR ) GO TO 950                                                    
      IF ( NLINE .EQ. 5 ) GO TO 720                                     
      IF ( NLINE+NADD+3 .LE. 59 ) GO TO 750                             
      WRITE(6,713) REACT, ELAB, HEADER                                    
 713  FORMAT ( X, T60, 'P T O L E M Y' /  1X, 'COMPUTATION OF COUPLED 
     *INELASTIC CHANNELS S-MATRICES',  T95, 'WIN A FEW, LOOSE A FEW' /  
     *X, 45A1, 'ELAB =', F7.2, ' MEV', 5X, 65A1 / )                   
      NLINE = 5                                                         
 720  WRITE(6,723)
 723  FORMAT ( X, 'CHANNEL', 1X, 'SOUT', 1X, 'LOUT',  T27, 'S-MATRIX(I
     *TER)', T51, 'S-MATRIX(PADE)',  T72, '!S(PADE)!', T95, 'RELATIVE DI
     *FFERENCES' /  T88, 'PADE-ITER', T100, 'ITER CONVRG.', T114, 'PADE 
     *CONVRG.' )                                                        
      NLINE = NLINE+3                                                   
C                                                                       
 750  WRITE(6,753) JT, ITR                                                
 753  FORMAT ( ' J =', I5, ',', I5, ' ITERATIONS' / )                   
C                                                                       
C     STORE CONVERGED S-MATRIX ELEMENTS, PRINT CONVERGENCE              
C                                                                       
      DO 899 ICHAN = 1, NCHNDF                                          
      NAME = CHNDEF(1,ICHAN)                                            
      I1 = CHNDEF(8,ICHAN)                                              
      I2 = CHNDEF(9,ICHAN) + I1-1                                       
      IPOINT = CHNDEF(10,ICHAN)                                         
      NSPLI = CHNDEF(11,ICHAN)                                          
      IPINDX = CHNDEF(12,ICHAN)                                         
      DO 889 I3 = I1, I2                                                
      CS2 = CSMATS(I3,1)                                                
      CS1 = CS2                                                         
      IF ( ITR .GE. 3 ) CS1 = PADE(3,ITR1P1,I3)                         
      CS3 = 0                                                           
      IF ( ITR .GE. 2 .OR. I3 .EQ. 1 ) CS3 = CSMATS(I3,2)               
      JOUT = BASDEF(2,I3)/2                                             
      I4 = JOUT+1                                                       
      LOUT = BASDEF(3,I3)/2                                             
      SMOD = CDABS(CS1)+1.D-30                                          0
      D2 = 0                                                            
	D1=CDABS((CS3-CS2)/(CS2+1.D-30))
      IF ( ITR .LE. 3 ) GO TO 840                                       
      CS4 = PADE(2,ITR1P1,I3)                                           
      IF ( MOD(ITR,2).NE.0 ) CS4 = PADE(1,ITR1,I3)                      
      D2 = CDABS(CS4-CS1) / SMOD                                        0
 840  D3 = CDABS(CS1-CS2)/SMOD                                          0
C                                                                       
      IF(I3.EQ.1)GO TO 850                                              
      KBASE=INDXS(3*I4-1+IPINDX)                                        
      LDELMN=INDXS(3*I4+IPINDX)                                         
      KOFFS=KBASE+(LOUT-LDELMN)/2                                       
      LABEL=(IJ-1)*NSPLI+IPOINT+KOFFS+1                                 
      EXR(LABEL) = DREAL(CS1)                                           
      EXI(LABEL) = DIMAG(CS1)                                           
      GO TO 860                                                         
 850  ELAST(1) =DREAL(CS1)                                              
      ELAST(2) = DIMAG(CS1)                                             
 860  LOUT=LOUT+JT                                                      
      IF ( LOUT .LT. IABS(JT-JOUT) ) GO TO 889                          
      IF ( ICHAN .NE. 1 .AND. .NOT. PRSW ) GO TO 889                    
      NLINE = NLINE+1                                                   
      WRITE(6,873) NAME, JOUT,LOUT, CS2, CS1, SMOD, D3, D1, D2            
C 873  FORMAT ( 1X, I5, 2I6, 2X, 2(1PE12.6, '+',1PE9.3, 'I' ),  G16.5,  
C     *3G14.3 )                                                         
C FORMAT 873 MODIFIED  12/4/86 JRB ORNL
 873  FORMAT ( 1X, I5, 2I6, 2X, 2(1PE12.5, '+',1PE10.3, 'I' ),  G15.5,  
     *3G14.3 )                                                          
 889  CONTINUE                                                          
 899  CONTINUE                                                          
      NLINE = NLINE+3                                                   
C                                                                       
      IF ( ITR .LT. MAXITR .OR. ITEST .EQ. 1 ) GO TO 950                
      WRITE(6,913) JT, ACCURA                                             
 913  FORMAT ( '0*** ERROR - FOR J =', I5,  ', S-MATRICES NOT CONVERGED 
     *TO SPECIFIED ACCURACY OF', G12.3 )                                
      NLINE = NLINE+2                                                   
C                                                                       
C     NOW DEFINE PREVIOUS ITERATION FOR NEXT ITERATION                  
C                                                                       
 950  DO 959 I = 1, NBASDF                                              

      CSMATS(I,2) = CSMATS(I,1)                                         
 959  CONTINUE                                                          
      IF ( ITR .GE. 3 ) GO TO 970                                       
      DO 969 I = 1, NBASDF                                              
      PADE(ITR,1,I) = CSMATS(I,1)                                       
 969  CONTINUE                                                          
      RETURN                                                            
C                                                                       
C     STORE PADE APPROXIMANTS FOR NEXT ITERATION                        
C                                                                       
 970  DO 979 I=1,NBASDF                                                 
      DO 974 J=1,ITR1P1                                                 
      PADE(1,J,I) = PADE(2,J,I)                                         
      PADE(2,J,I) = PADE(3,J,I)                                         
 974  CONTINUE                                                          
979   CONTINUE                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE CCOUP(IRET)                                            
C                                                                       
C     INPUT ROUTINE FOR CHANNEL COUPLING SPECIFICATION                  
C                                                                       
C     STRUCTURE OF DATA IN ALLOCATOR                                    
C     PREFACE                                                           
C     LDATA4+0 TOTAL NO OF COUPLING SCHEMES                             
C      +1 LENGTH OF BLOCK   (17)                                        
C      +2 LENGTH OF PREFACE (3)                                         
C     DATA                                                              
C     LABEL  +0 CHANNEL COUPLED TO CHANNEL IN LABEL +1                  
C     +1 CHANNEL COUPLED TO CHANNEL IN LABEL +0                         
C     +2 ORDER OF TAYLOR EX. IN COUPLING POT(MAX=2)                     
C     +3 TYPE OF COUPLING I.E. UPDOWN=1                                 
C                              UPONLY=2                                 
C     +4,5 MULTIPOLE                                                    
C     +6,7 BELX                                                         
C     +8,9 BETAN                                                        
C     +10 NUCLEUS BEING COUPLED IE P(+1) T(+2) PT(+3)                   
C     +11,+12 - METHOD USED TO SPECIFY BETA COULOMB:                    
C           0 - BETAC                                                   
C           1 - DELTAC (DEFORMATION LENGTH)  (FM)                       
C           2 - R.ME. OF ALPHA                                          
C           3 - TOTAL LX (FOR 2ND ORDER RME)                            
C           4 - HALFLIFE  (SEC)                                         
C           5 - MEANLIFE   (SEC)                                        
C           6 - BE(DOWN)  (E**2 BARN**LX)                               
C           7 - REDUCED MATRIX ELEMENT OF M(E LX) (BOHR & MOTTELSON)    
C                   (E BARN**LX/2)                                      
C               THIS IS <J2,K2!! E(LX) !!J1,K1>  FOR E2 > E1.           
C           8 - BE(UP, WEISSKOPF UNITS WITH R0=1.2)                     
C           9 - BE(DOWN, WEISSKOPF UNITS WITH R0=1.2)                   
C          10 - BE(UP)  (E**2 BARN**LX)                                 
C          11 - Q (QUADRUPOLE MOMENT)    (E BARN)                       
C          12 - WIDTH IN MEV                                            
C     +13 - USE INDICATOR.  SET TO ZERO HERE.                           
C     +14 - MODEL   1 = ROTATIONAL MODEL                                
C                   2 = VIBRATIONAL MODEL                               
C                   3 = ROTVIB, 4 = VIBROT                              
C                   5 = MODEL5  6 = MODEL6                              
C     +15,+16 - METHOD USED TO SPECIFY BETA NUCLEAR                     
C          0 - BETAN                                                    
C          1 - DELTAN                                                   
C          2 - R.M.E. OF ALPHA                                          
C          3 - TOTAL LX FOR 2ND ORDER RME                               
C     +17,+18 - SCALE FACTORS FOR R.M.E. (DEFAULT=1)                    
C     +19 - TOTAL LX                                                    
C     +20 - MAXIMUM LX                                                  
C                                                                       
C     LABEL +0 AND +1 COMPULSORY                                        
C     IF ORDERMAX=2 NEED 2 MULTIPOLES/BETAN/BETAC AND NUCLEUS           
C     ; DENOTES NO MORE DATA FOR GIVEN CHANNEL-DEFAULT ASSSUMED         
C     IF ORDERMAX IS TO  BE SPECIFIED MUST BE SECOND INPUT KEYWORD      
C     IF ORDERMAX=2 TWO MULTIPOLES REQUIRED ALWAYS                      
C     FOR SECOND ORDER COUPLING MUST USE NUCLEAS KEY                    
C                                                                       
C     12/80 - FIRST VERSION - MRB                                       
C     1/16/80 - STORE ADDRESS IN CCBLK - S.P.                           
C     7/3/80 - FIX ORDER OF NXVALF RETURNS, ALLOW                       
C              SEMI-COLON AT END OF FULL SPECIFICATION - S.P.           
C     7/16/80 - ALLOW SEMICOLON INPLACE OF NUCLEUS, ORDER KEYWORD       
C     7/17/80 - CHARACTER*8 VARIABLES, IMPROVE ERROR MSGS - S.P.        
C     9/21/80 - CHANGE IPT(+10) TO BE 1=P, 2=T - S.P.                   
C     10/1/80 - CONVERT TP TO PT; BETAC KEYWORDS; MASSIVE REWRITE - S.P.
C     12/8/80 - ALLOW DEFAULTS TO BE READ; WEISSKOPF UNITS - S.P.       
C     1/6/81 - MODEL KEYWORD; DIFFERENT BETAN TYPES - S.P.              
C     1/22/81 - FIX SUBTLE BLUNDER  - S.P.                              
C     1/25/81 - SCALE FACTORS ADDED, BETTER TP FLIPS - S.P.             
C     6/28/81 - WIDTH KEYWORD - S.P.                                    
C     8/25/81 - TOTALLX, MAXLX, DEFORMED KEYWORDS - S.P.                
C     10/15/81 - ALLOC MULTIPOLARITY=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) )                                                          
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
C                                                                       
      DATA NUMKEY/16/                                                   
      CHARACTER*8 KEYS(16)                                              
      DATA KEYS/'COUPLED','ORDER','ORDERMAX','TYPE','MULTIPOL','LX',
     *'NUCLEUS','MODEL','SCALE','SCALEFAC','TOTALLX','TOTALMUL', 
     *'MAXLX','MAXIMUML','MAXMULTI','MAXIMUMM'/                       
C                                                                       
      DATA NMBCKY /21/                                                  
      CHARACTER*8 BCKEYS(21)                                            
      DATA BCKEYS/'BETAC','BETACOUL','DELTAC','DELTACOU','BE','BELX',
     *'BEUP','Q','QMOMENT','QUADRUPO','HALFLIFE','MEANLIFE', 
     *'BEDOWN','RMEC','RMECOULO','BEUPWU','BEDOWNWU','RMECALPH','LX',
     *'TOTALLX','WIDTH'/                                              
      INTEGERIBCKYS(21)                                                 
      DATAIBCKYS/0, 0, 1, 1, 10, 10, 10, 11, 11, 11, 4, 5, 6, 7, 7, 8, 9
     *, 2, 3, 3, 12/                                                    
C                                                                       
      DATA NMBNKY /9/                                                   
      CHARACTER*8 BNKEYS(9)                                             
      DATA BNKEYS/'BETAN', 'BETANUCL', 'DELTAN', 'DELTANUC', 'RMEN', 
     *'RMENUCLE', 'RMENALPH', 'LX', 'TOTALLX'/                             
      INTEGERIBNKYS(9)                                                  
      DATAIBNKYS/0, 0, 1, 1, 2, 2, 2, 3, 3/                             
C                                                                       
      DATA LENDAT /21/,LAL/3/                                           
      CHARACTER*8 NAME8                                                 
      DATA NAME8 / 'CHANCOUP' /                                         
      CHARACTER*8 ANAMES                                                
      COMMON/NAMCOM/ANAMES(1)                                           
C                                                                       
      DATA LISTN /4/                                                    
      CHARACTER*8 KEY1(4)                                               
      DATA KEY1/'UPDOWN','UPONLY','DIAGONAL','BORN'/                    
      INTEGERKEY1VL(4)                                                  
      DATAKEY1VL/1, 2, 1, 2/                                            
C                                                                       
      DATA LISTN1/10/                                                   
      CHARACTER*8 KEY2(10)                                              
      DATA KEY2/'P','T','PT','TP', 'PP', 'TT', 'PROJ','PROJECTI','TARG', 
     * 'TARGET'/                                                      
      INTEGERKEY2VL(10)                                                 
      DATAKEY2VL/1, 2, 3, 4, 1, 2, 1, 1, 2, 2/                          
C                                                                       
C                                                                       
C     MODELS                                                            
C                                                                       
      DATA NUMMOD /7/                                                   
      CHARACTER*8 MODELS(7)                                             
      DATA MODELS/'ROTATION', 'VIBRATIO', 'DEFORMED', 'ROTVIB', 'VIBROT'
     *, 'MODEL6', 'MODEL7'/                                             
C                                                                       
      CHARACTER*8 AKEY                                                  
      LOGICAL SCNDSW                                                    
C                                                                       
      INTEGER GIVEAL                                                    
C                                                                       
C     THE FOLLOWING ARE THE FIRST INDEX OF PAIRS THAT MUST BE           
C     FLIPPED TO CONVERT TP TO PT.                                      
C                                                                       
      DATA NUMFLP /6/                                                   
      INTEGERIFLIPS(6)                                                  
      DATAIFLIPS/4, 6, 8, 11, 15, 17/                                   
C                                                                       
C     ARRAYS FOR THE DEFAULT VALUES                                     
C                                                                       
      REAL*4 DFLTS(30)                                                  
	integer*4 idflts(30)
      CHARACTER*8 BLANK, AKEY2, AKEY3                                   
      DATA BLANK / ' ' /                                                
      LOGICAL EQULSW                                                    
C                                                                       
      IRET=0                                                            
      ICOP=0                                                            
      IOR=0                                                             
      ITY=0                                                             
      IMUL=0                                                            
      IBC=0                                                             
      IBN=0                                                             
      INC=0                                                             
      ICH=0                                                             
      IMD = 0                                                           
      ISC = 0                                                           
      ITOTMU = 0                                                        
      IMAXMU = 0                                                        
C                                                                       
C     INITIALIZE THE DEFAULT VALUES.  MOST ARE NOT DEF                  
C                                                                       
      DO 29 I = 1, 30                                                   
      DFLTS(I) = UNDEF                                                  
	idflts(i)=notdef
 29   CONTINUE                                                          
C                                                                       
C     DEFINED DEFALTS:                                                  
C        ORDER=1,  TYPE=UPDOWN,  USE=0,  MODEL=ROTATIONAL,   SCALE=1    
C                                                                       
      IDFLTS(2) = 1                                                     
      IDFLTS(3) = 1                                                     
      IDFLTS(13) = 0                                                    
      IDFLTS(14) = 1                                                    
      DFLTS(17) = 1                                                     
      DFLTS(18) = 1                                                     
C                                                                       
      I=NAMLOC(NAME8)                                                   
      IF ( I.NE.0)Z(I)=-Z(I)                                            
      ICHNCP=GIVEAL(IWRDS)                                              
      LDATA=Z(ICHNCP)                                                   
      ANAMES(ICHNCP)=NAME8                                              
      LDATA4=FACFR4*(LDATA-1)+1                                         
      ILLOC(LDATA4+2)=LAL                                               
      LABEL=LDATA4+LAL                                                  
      CALL FITKEY(AKEY,&90,&900,&900,&900)                              
      GO TO 900                                                         
C                                                                       
C     (ENCOUNTERED LETS GO                                              
C     PROCESS KEYWORDS FIRST                                            
C                                                                       
 90   IORDER=0                                                          
      AKEY2 = BLANK                                                     
C                                                                       
C     GET NEXT KEY WORD; MAY HAVE BEEN ALREAD READ                      
C                                                                       
 100  AKEY = AKEY2                                                      
      IF ( AKEY2 .EQ. BLANK )  CALL NXWORD(AKEY,&400,&900,&900)         
C                                                                       
C     LOOK FOR POSSIBLE = SIGN AFTER THIS KEYWORD                       
C                                                                       
      EQULSW = .FALSE.                                                  
      CALL FITKEY ( AKEY2, &900, &120, &900, &130 )                     
      GO TO 150                                                         
C                                                                       
C     = FOUND OR FIRST DATA FIELD                                       
C                                                                       
 120  EQULSW = .TRUE.                                                   
 130  AKEY2 = BLANK                                                     
C                                                                       
C     IDENTIFY THE KEYWORD                                              
C                                                                       
 150  DO 159 I=1,NUMKEY                                                 
      IF ( KEYS(I).NE.AKEY ) GO TO 159                                  
      GO TO ( 200, 210, 210, 220, 230, 230, 250, 260, 270, 270 ,  280, 2
     *80, 290, 290, 290, 290 ), I                                       
 159  CONTINUE                                                          
C                                                                       
C     IS IT A DEFAULT COULOMB BETA SPECIFICATION                        
C                                                                       
      DO 169 I = 1, NMBCKY                                              
      IF ( AKEY .NE. BCKEYS(I) ) GO TO 169                              
      IDFLTS(11) = IBCKYS(I)                                            
      IDFLTS(12) = IBCKYS(I)                                            
      IORDER = IORDER+1                                                 
      IBC = IORDER                                                      
      IF ( .NOT. EQULSW ) GO TO 100                                     
      CALL NXVAL ( DFLTS(6), &945, &945, &945 )                         
      DFLTS(7) = DFLTS(6)                                               
      GO TO 100                                                         
 169  CONTINUE                                                          
C                                                                       
C     IS IT A DEFAULT NUCLEAR BETA                                      
C                                                                       
      DO 179 I = 1, NMBNKY                                              
      IF ( AKEY .NE. BNKEYS(I) ) GO TO 179                              
      IDFLTS(15) = IBNKYS(I)                                            
      IDFLTS(16) = IBNKYS(I)                                            
      IORDER = IORDER+1                                                 
      IBN = IORDER                                                      
      IF ( .NOT. EQULSW ) GO TO 100                                     
      CALL NXVAL ( DFLTS(8), &945, &945, &945 )                         
      DFLTS(9) = DFLTS(8)                                               
      GO TO 100                                                         
 179  CONTINUE                                                          
C                                                                       
      GO TO 900                                                         
C                                                                       
C     COUPLED                                                           
C                                                                       
 200  IORDER=IORDER+1                                                   
      ICOP=IORDER                                                       
      IF ( ICOP.NE.1 ) GO TO 930                                        
      GO TO 100                                                         
C                                                                       
C     ORDER                                                             
C                                                                       
 210  IORDER=IORDER+1                                                   
      IOR=IORDER                                                        
      IF ( IOR.NE.2 ) GO TO 940                                         
      IF (EQULSW) CALL NXINT ( IDFLTS(2), &945, &945, &945 )            
      GO TO 100                                                         
C                                                                       
C     TYPE                                                              
C                                                                       
 220  IORDER=IORDER+1                                                   
      ITY=IORDER                                                        
      IF ( .NOT. EQULSW ) GO TO 100                                     
      CALL NXWORD ( AKEY3, &945, &945, &945 )                           
      AKEY = AKEY3                                                      
      GO TO 472                                                         
 225  IDFLTS(3) = INT                                                   
      GO TO 100                                                         
C                                                                       
C     MULTIPOLARITY                                                     
C                                                                       
 230  IORDER=IORDER+1                                                   
      IMUL=IORDER                                                       
      IF ( .NOT. EQULSW ) GO TO 100                                     
      CALL NXHINT ( INT, &945, &945, &945 )                             
      IDFLTS(4) = INT                                                   
      IDFLTS(5) = INT                                                   
      GO TO 100                                                         
C                                                                       
C     NUCLEUS                                                           
C                                                                       
250   IORDER=IORDER+1                                                   
      INC=IORDER                                                        
      IF ( .NOT. EQULSW ) GO TO 100                                     
      CALL NXWORD ( AKEY3, &945, &945, &945 )                           
      AKEY = AKEY3                                                      
      GO TO 555                                                         
 255  IDFLTS(10) = INT                                                  
      GO TO 100                                                         
C                                                                       
C     MODEL                                                             
C                                                                       
260   IORDER=IORDER+1                                                   
      IMD=IORDER                                                        
      IF ( .NOT. EQULSW ) GO TO 100                                     
      CALL NXWORD ( AKEY3, &945, &945, &945 )                           
      AKEY = AKEY3                                                      
      GO TO 572                                                         
 265  IDFLTS(14) = INT                                                  
      GO TO 100                                                         
C                                                                       
C     SCALE FACTOR                                                      
C                                                                       
 270  IORDER = IORDER+1                                                 
      ISC = IORDER                                                      
      IF ( .NOT. EQULSW ) GO TO 100                                     
      CALL NXVAL ( DFLTS(17), &945, &945, &945 )                        
      DFLTS(18) = DFLTS(17)                                             
      GO TO 100                                                         
C                                                                       
C     TOTALLX                                                           
C                                                                       
 280  IORDER=IORDER+1                                                   
      ITOTMU = IORDER                                                   
      IF ( .NOT. EQULSW ) GO TO 100                                     
      CALL NXHINT ( INT, &945, &945, &945 )                             
      IDFLTS(19) = INT                                                  
      GO TO 100                                                         
C                                                                       
C     MAXIMUMLX                                                         
C                                                                       
 290  IORDER=IORDER+1                                                   
      IMAXMU = IORDER                                                   
      IF ( .NOT. EQULSW ) GO TO 100                                     
      CALL NXHINT ( INT, &945, &945, &945 )                             
      IDFLTS(20) = INT                                                  
      GO TO 100                                                         
C                                                                       
C     DONE WITH KEYWORDS, GO ON TO DATA                                 
C                                                                       
 400  ILLOC(LDATA4+1)=LENDAT                                            
      LABEL=LABEL-LENDAT                                                
      EQULSW = .FALSE.                                                  
C                                                                       
C     GO TO NEXT BATCH OF DATA                                          
C                                                                       
 410  LABEL=LABEL+LENDAT                                                
      II=1                                                              
 420  CALL NXINT ( INT,&910,&420,&800)                                  
      ILLOC(LABEL)=INT                                                  
      I1=2                                                              
      II = 2                                                            
      CALL NXINT ( INT,&910,&910,&910)                                  
      ILLOC(LABEL+1)=-INT                                               
      IF ( INT .GT. 0 ) GO TO 915                                       
      ICH=ICH+1                                                         
C                                                                       
C     MOVE IN THE DEFAULTS                                              
C                                                                       
      DO 432 I = 2, 5                                                   
      ILLOC(LABEL+I) = IDFLTS(I)                                        
 432  CONTINUE                                                          
      DO 434 I=6,9                                                      
 434  ALLOC4(LABEL+I)=DFLTS(I)                                          
      L = LENDAT - 1                                                    
      DO 436 I = 10, L                                                  
      ILLOC(LABEL+I) = IDFLTS(I)                                        
 436  CONTINUE                                                          
	alloc4(label+17)=dflts(17)
	alloc4(label+18)=dflts(18)
      JORDER = ILLOC(LABEL+2)                                           
      SCNDSW = JORDER .EQ. 2                                            
C                                                                       
C     PROCESS THE COUPLING ORDER IF SPECIFIED                           
C                                                                       
      IF ( IOR.EQ.0 ) GO TO 440                                         
      II=3                                                              
      I1=3                                                              
      CALL NXINT ( JORDER,&910, &410, &810 )                            
      ILLOC(LABEL+2)=JORDER                                             
 440  IF ( JORDER .NE. 1 .AND. JORDER .NE. 2 ) GO TO 925                
      SCNDSW = JORDER .EQ. 2                                            
      IF ( SCNDSW .AND.(IMUL.EQ.0) ) GO TO 950                          
      IF ( SCNDSW .AND.(INC.EQ.0) ) GO TO 980                           
C                                                                       
C     PROCESS THE KEYWORDS AFTER ORDER.  THESE CAN BE IN ANY ORDER      
C                                                                       
      IF ( I1.GT.IORDER ) GO TO 410                                     
 450  II = II+1                                                         
      IF ( I1 .EQ. IMUL ) GO TO 490                                     
      IF ( I1 .EQ. IBC ) GO TO 500                                      
      IF ( I1 .EQ. IBN ) GO TO 530                                      
      IF ( I1 .EQ. INC ) GO TO 550                                      
      IF ( I1 .EQ. IMD ) GO TO 570                                      
      IF ( I1 .EQ. ITY ) GO TO 470                                      
      IF ( I1 .EQ. ISC ) GO TO 580                                      
      IF ( I1 .EQ. ITOTMU ) GO TO 590                                   
      IF ( I1 .EQ. IMAXMU ) GO TO 600                                   
C                                                                       
      WRITE(6,453) I1                                                     
 453  FORMAT ( '0*** THE', I3, ' INPUT FIELD CANNOT BE',  ' CLASSIFIED. 
     * DID YOU SPECIFY THE SAME TYPE OF DATA',  ' TWICE IN THE KEYWORD L
     *IST?' )                                                           
      GO TO 908                                                         
C                                                                       
C     COUPLING TYPE                                                     
C                                                                       
 470  CALL NXWORD(AKEY,&960,&700,&810 )                                 
 472  DO 479 J=1,LISTN                                                  
      IF ( KEY1(J).NE.AKEY ) GO TO 479                                  
      INT = KEY1VL(J)                                                   
      IF ( EQULSW ) GO TO 225                                           
      ILLOC(LABEL+3) = INT                                              
      GO TO 689                                                         
 479  CONTINUE                                                          
      GO TO 960                                                         
C                                                                       
C     MULTIPOLARITY                                                     
C                                                                       
 490  CALL NXHINT ( INT,&910, &700, &810 )                              
      ILLOC(LABEL+4)=INT                                                
      IF ( INT .LT. 0 ) GO TO 935                                       
      IF ( .NOT. SCNDSW ) GO TO 689                                     
      II = II+1                                                         
      CALL NXHINT ( INT, &910, &950, &950 )                             
      ILLOC(LABEL+5)=INT                                                
      IF ( INT .LT. 0 ) GO TO 935                                       
      GO TO 689                                                         
C                                                                       
C     BETA COULOMB                                                      
C                                                                       
 500  DO 529 J = 1, JORDER                                              
 505  CALL NXVAL ( TEMP, &510, &595, &805 )                             
      GO TO 525                                                         
C                                                                       
C     CHECK FOR KEYWORD SPECIFYING OTHER METHOD FOR BETAC               
C                                                                       
 510  CALL NXWORD ( AKEY, &910, &595, &805 )                            
      DO 519 I2 = 1, NMBCKY                                             
      IF ( AKEY .NE. BCKEYS(I2) ) GO TO 519                             
      ILLOC(LABEL+10+J) = IBCKYS(I2)                                    
      GO TO 505                                                         
 519  CONTINUE                                                          
      WRITE(6,523) AKEY, BCKEYS                                           
 523  FORMAT ( '0*** INVALID KEYWORD FOR SPECIFYING COULOMB',  ' DEFORMA
     *TION: ', A8, ',  VALID KEYWORDS ARE:' /  ( 6X, 10A10 ) )          
      RETURN                                                            
 525  ALLOC4(LABEL+5+J) = TEMP                                          
      II = II+1                                                         
 529  CONTINUE                                                          
      GO TO 689                                                         
C                                                                       
C     NUCLEAR DEFORMATION OR BETA                                       
C                                                                       
 530  DO 549 J = 1, JORDER                                              
 535  CALL NXVAL ( TEMP, &537, &595, &805 )                             
      GO TO 545                                                         
C                                                                       
C     CHECK FOR KEYWORD SPECIFYING OTHER METHOD FOR BETAN               
C                                                                       
 537  CALL NXWORD ( AKEY, &910, &595, &805 )                            
      DO 539 I2 = 1, NMBNKY                                             
      IF ( AKEY .NE. BNKEYS(I2) ) GO TO 539                             
      ILLOC(LABEL+14+J) = IBNKYS(I2)                                    
      GO TO 535                                                         
 539  CONTINUE                                                          
      WRITE(6,543) AKEY, BNKEYS                                           
 543  FORMAT ( '0*** INVALID KEYWORD FOR SPECIFYING NUCLEAR',  ' DEFORMA
     *TION: ', A8, ',  VALID KEYWORDS ARE:' /  ( 6X, 10A10 ) )          
      RETURN                                                            
 545  ALLOC4(LABEL+7+J) = TEMP                                          
      II = II+1                                                         
 549  CONTINUE                                                          
      GO TO 689                                                         
C                                                                       
C     NUCLEUS                                                           
C                                                                       
550   CALL NXWORD ( AKEY, &970,&700,&810 )                              
 555  DO 559 J=1,LISTN1                                                 
      IF ( KEY2(J).NE.AKEY) GO TO 559                                   
      INT = KEY2VL(J)                                                   
      IF ( EQULSW ) GO TO 255                                           
      ILLOC(LABEL+10) = INT                                             
      GO TO 689                                                         
559   CONTINUE                                                          
      GO TO 970                                                         
C                                                                       
C     MODEL                                                             
C                                                                       
 570  CALL NXWORD ( AKEY, &975, &700, &810 )                            
 572  DO 579 J = 1, NUMMOD                                              
      IF ( AKEY .NE. MODELS(J) ) GO TO 579                              
      INT = J                                                           
      IF ( EQULSW ) GO TO 265                                           
      ILLOC(LABEL+14) = INT                                             
      GO TO 689                                                         
 579  CONTINUE                                                          
      GO TO 975                                                         
C                                                                       
C     SCALE FACTOR                                                      
C                                                                       
 580  CALL NXVAL ( VAL, &910, &700, &810 )                              
      ALLOC4(LABEL+17) = VAL                                            
      IF ( .NOT. SCNDSW ) GO TO 689                                     
      II = II+1                                                         
      CALL NXVAL ( VAL, &910, &700, &810 )                              
      ALLOC4(LABEL+18) = VAL                                            
      GO TO 689                                                         
C                                                                       
C     TOTALLX                                                           
C                                                                       
 590  CALL NXHINT ( INT,&910, &700, &810 )                              
      ILLOC(LABEL+19)=INT                                               
      IF ( INT .LT. 0 ) GO TO 935                                       
      GO TO 689                                                         
C                                                                       
C     MAXIMUMLX                                                         
C                                                                       
 600  CALL NXHINT ( INT,&910, &700, &810 )                              
      ILLOC(LABEL+20)=INT                                               
      IF ( INT .LT. 0 ) GO TO 935                                       
      GO TO 689                                                         
689   I1 = I1+1                                                         
      IF ( I1 .LE. IORDER ) GO TO 450                                   
      GO TO 700                                                         
C                                                                       
C     ALL DATA FOR ONE COUPLING HAS BEEN READ.                          
C     MAKE SURE IT IS CONSISTANT                                        
C                                                                       
 595  IF ( J .NE. 1 ) GO TO 950                                         
 700  IPT = ILLOC(LABEL+10)                                             
      IF ( .NOT. SCNDSW ) GO TO 750                                     
      IF ( IPT .EQ. NOTDEF ) GO TO 980                                  
      IF ( ILLOC(LABEL+4) .EQ. NOTDEF ) GO TO 950                       
C                                                                       
C     CONVERT TP TO PT INPUT                                            
C                                                                       
      IF ( IPT .NE. 4 ) GO TO 790                                       
      DO 729 II = 1, NUMFLP                                             
      I = IFLIPS(II)                                                    
      ITEMP = ILLOC(LABEL+I)                                            
      ILLOC(LABEL+I) = ILLOC(LABEL+I+1)                                 
      ILLOC(LABEL+I+1) = ITEMP                                          
729   CONTINUE                                                          
      ILLOC(LABEL+10) = 3                                               
      GO TO 790                                                         
C                                                                       
C     FIRST ORDER CANNOT HAVE PT                                        
C                                                                       
 750  IF ( IPT .LE. 2 .OR. IPT .EQ. NOTDEF ) GO TO 790                  
      WRITE(6,753)
 753  FORMAT ('0*** NUCLEUS SPECIFICATION OF PT OR TP',  ' IS INVALID FO
     *R FIRST ODER.' )                                                  
      RETURN                                                            
 790  IF ( I1 .LT. 0 ) GO TO 840                                        
      GO TO 410                                                         
C                                                                       
C     CHECK FOR ) TO STOP THE INPUT                                     
C                                                                       
 800  CALL FITKEY(AKEY,&920,&920,&850,&920)                             
      GO TO 920                                                         
 805  IF ( J .NE. 1 ) GO TO 950                                         
 810  I1 = -1                                                           
      CALL FITKEY ( AKEY, &920, &920, &700, &920 )                      
      GO TO 920                                                         
 840  LABEL = LABEL + LENDAT                                            
 850  ILLOC(LDATA4)=ICH                                                 
      IWRDS=(LABEL-LDATA4)/FACFR4+1                                     
      IL=CHOPIT(IWRDS)                                                  
      IRET=1                                                            
      RETURN                                                            
C                                                                       
900   WRITE(6,901) KEYS, BCKEYS, BNKEYS                                 
901   FORMAT(' *** DATA NOT ENCLOSED IN PARENTHESIS OR KEYWORD',  'MISPE
     *LLED.   DATA KEYWORDS ARE:' // ( 1X, 10A9 ) )                     
 905  WRITE(6,907) AKEY                                                   
 907  FORMAT ( '0*** THIS OR LAST KEYWORD READ IS: ', A8 )              
 908  WRITE(6,909) ( IBUF(I), I = 1, INCH )                               
 909  FORMAT ( '0*** INPUT LINE UP TO ERROR IS:  ', 80A1 )              
      RETURN                                                            
910   WRITE(6,911) II                                                   
911   FORMAT ( '0*** ERROR IN READING',I5,' DATA VALUE IN SET')         
      GO TO 908                                                         
 915  WRITE(6,918)
 918  FORMAT ( '0*** CHANNELS TO BE COUPLED MUST BE SPECIFIED',  ' AS CH
     *1-CH2.  YOU HAVE LEFT OUT THE "-".' )                             
      GO TO 908                                                         
 920  WRITE(6,923)
 923  FORMAT ( '0*** INVALID OR MISPLACED PUNCTUATION.' )               
      GO TO 908                                                         
 925  WRITE(6,928) JORDER                                                 
 928  FORMAT ( '0*** INVALID ORDER OF COUPLING:', I12 )                 
      GO TO 908                                                         
930   WRITE(6,931)                                                      
931   FORMAT ( '0*** COUPLED MUST BE FIRST KEYWORD')                    
      GO TO 905                                                         
 935  WRITE(6,938) INT                                                    
 938  FORMAT ( '0*** ILLEGAL MULTIPOLARITY:', I12 )                     
      GO TO 908                                                         
940   WRITE(6,941)                                                      
941   FORMAT ( '0*** IF USING ORDER MUST BE SECOND KEYWORD')            
      GO TO 905                                                         
 945  WRITE(6,947)
 947  FORMAT ( '0*** INCORRECTLY SPECIFIED DEFAULT VALUE.' )            
      GO TO 905                                                         
950   WRITE(6,951)                                                      
951   FORMAT ( '0*** FOR SECOND ORDER COUPLING MUST DEFINE TWO ',  'MULT
     *IPOLES.' )                                                        
      GO TO 908                                                         
960   WRITE(6,961)(KEY1(I),I=1,LISTN)                                   
961   FORMAT ( '0*** COUPLING TYPE MISPELLED OR MISPLACED.  ',  'VALID K
     *EYWORDS ARE:' // (1X,10A9 ) )                                     
      GO TO 905                                                         
970   WRITE(6,971)(KEY2(I),I=1,LISTN1)                                  
971   FORMAT ( '0*** NUCLEUS KEYWORD MISPELLED OR MISPLACED.  ',  'VALID
     * KEYWORDS ARE:' // (1X,10A9))                                     
      GO TO 905                                                         
 975  WRITE(6,978) (MODELS(I), I = 1, NUMMOD )                            
 978  FORMAT ( '0*** MODEL SPECIFICATION MISSPELLED OR',  ' MISPLACED.  
     *VALID MODELS ARE' // (1X, 10A9) )                                 
      GO TO 905                                                         
980   WRITE(6,981)                                                      
981   FORMAT ( '0*** FOR SECOND ORDER COUPLING MUST USE NUCLEUS KEY')   
      GO TO 905                                                         
      END                                                               

      SUBROUTINE CHANEL ( IRET )                                        
C                                                                       
C     SCANS A CHANNEL SPECIFICATION                                     
C                                                                       
C     FORMS ARE                                                         
C        N15 + 209BI(9/2- 1.3)     ( FOR SCATTERING )                   
C        P + 208PB = BI209(7/2 .9)    ( FOR BOUND STATES )              
C        O16 = N15 + P                ( ALTERNATIVE B.S. )              
C     NOTE THAT PROJECTILE ALWAYS COMES FIRST.                          
C                                                                       
C                                                                       
C     AND STORES  Z'S,  M'S,  J'S,  E*'S   OF                           
C     THE 2 OR 3 PARTILCES INTO THE COMMON BLOCKS.                      
C     FOR BOUNDSTATES THE TOTAL J AND BINDING ENERGY ARE ALSO STORED.   
C                                                                       
C     9/22/75 - BASED ON REACTN - S. PIEPER                             
C     4/24/77 - STORE E* IN EXSPT                                       
C     9/24/77 - RECOGNIZE E*=0; ALLOW LATTER DEF OF MASS EXCESS         
C     12/10/77 - FIX ERROR IN ABOVE TO DEFINE J FOR B.S.                
C     5/6/79 - G.S. MASS EXCESS, PARITIES, L & NODES FROM LEVEL - S.P.  
C     12/31/79 - STANDARD MORTRAN - RPG                                 
C     1/14/80 - CHARDATAVALUE IS NUMERIC, " IN FORMAT 313 - RPG         
C     1/25/80 - CHARACTER SYMBOL, ALPHA - RPG                           
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      DIMENSION AMPTS(2)                                                
      EQUIVALENCE ( AMPTS(1), AMP )                                     
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      DIMENSION IZPTS(2)                                                
      EQUIVALENCE ( IZPTS(1), IZP )                                     
      COMMON /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
      INTEGER JSPTS(2)                                                  
      EQUIVALENCE ( JSPTS(1), JSP )                                     
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
C                                                                       
      CHARACTER*8 GUY(3)                                                
      CHARACTER*2 SYMBOL                                                
      CHARACTER*4 ALPHA                                                 
      REAL*8 ESTARS(3), XCESES(3)                                       
      INTEGER NODVLS(3), LVALS(3), JVALS(3), IPARYS(3)                  
      CHARACTER*1 BLANK1                                                
      DATA BLANK1 / ' ' /                                               
C                                                                       
      CHARACTER*16 NAMES(3)                                             
      DATA NAMES/'PROJECTILE', 'TARGET', 'BOUND STATE'/                 
CDC      INTEGER NAMES(3) / 'PROJECTILE', 'TARGET', 'BND STATE' /       
      INTEGERLETTRA, LETTRZ, NUM0, NUM9                                 
      DATANUM9/57/                                                      
      DATANUM0/48/                                                      
      DATALETTRZ/90/                                                    
      DATA LETTRA / 65 /                                                
C                                                                       
      IRET = 0                                                          
C                                                                       
C     GET PAST ANY INITIAL DELIMITORS ( ASSUME THE SPECIFICATION IS IN U
C      CASE ).                                                          
C                                                                       
 100  I = ICHAR(IBUF(INCH))                                             
      IF ( I .GE. LETTRA .AND. I .LE. LETTRZ  .OR. I .GE. NUM0 .AND. I .
     *LE. NUM9 ) GO TO 150                                              
      INCH = INCH + 1                                                   
      IF ( INCH .LE. NOCH ) GO TO 100                                   
      WRITE(6,123)
 123  FORMAT ( ' **** CHANNEL KEYWORD AND COMPLETE SPECIFICATION',  ' MU
     *ST BE ON ONE LINE.' )                                             
      RETURN                                                            
C                                                                       
C     START OF SPECIFICATION FOUND.  BREAK IT INTO 2 OR 3 PIECES.       
C                                                                       
 150  INCHST = INCH                                                     
      CALL CHNSCN ( GUY, ESTARS, NODVLS, LVALS, JVALS, IPARYS, IRTN )   
      IF ( IRTN .LT. 0 ) RETURN                                         
C                                                                       
C     NOW GET THE A AND Z VALUES                                        
C                                                                       
      NUMSYM = IRTN                                                     
      DO 239 I = 1, NUMSYM                                              
      CALL AZCODE ( GUY(I), IZ, IA, SYMBOL, IRTN )                      
      IF ( IRTN .EQ. 0 ) GO TO 230                                      
      IF (IRTN .NE. -2) WRITE(6,213) GUY(I)                               
 213  FORMAT ( '0**** A SYMBOL HAS INCORRECT SYNTAX:  ',  'SYMBOL = ', A
     *8 )                                                               
      IF ( IRTN .EQ. -2 ) WRITE(6,217) GUY(I)                             
 217  FORMAT ( '0**** THE SYMBOL ', A6, ' IS NOT A KNOWN ELEMENT.' )    
      RETURN                                                            
 230  IF ( I .EQ. 3 ) GO TO 250                                         
      IZPTS(I) = IZ                                                     
      AMPTS(I) = IA                                                     
      NODEPT(I) = NODVLS(I)                                             
      LSPCPT(I) = LVALS(I)                                              
      JSPTS(I) = JVALS(I)                                               
      EXSPT(I) = ESTARS(I)                                              
      IF ( EXSPT(I) .EQ. UNDEF ) EXSPT(I) = 0                           
      PARIPT(I) = IPARYS(I)                                             
 239  CONTINUE                                                          
      GO TO 300                                                         
C                                                                       
 250  J = JVALS(3)                                                      
      PARITY = IPARYS(3)                                                
      NODES = NODVLS(3)                                                 
      L = LVALS(3)                                                      
      IAB = IA                                                          
      IZB = IZ                                                          
      IF ( IAB .EQ. AMPTS(1)+AMPTS(2) .AND. IZ .EQ. IZPTS(1)  +IZPTS(2) 
     *) GO TO 300                                                       
      WRITE(6,253) IZPTS, IZ, AMPTS, IA                                   
 253  FORMAT ( '0**** BOUNDSTATE DOES NOT CONSERVE NUCLEON NUMBER',  ' O
     *R CHARGE:' /  ' ZP, ZT, Z(BOUND) =', 3I8 /  ' MP, MT, M(BOUND) =',
     * 2F8.0, I8 )                                                      
      RETURN                                                            
C                                                                       
C     NOW GET GROUND STATE MASS EXCESS AND DETERMIN IF THE NUCLEII      
C     EXIST.                                                            
C                                                                       
 300  DO 359 I = 1, NUMSYM                                              
      IA = IAB                                                          
      IZ = IZB                                                          
      IF ( I .EQ. 3 ) GO TO 310                                         
      IA = AMPTS(I)                                                     
      IZ = IZPTS(I)                                                     
 310  N = IA-IZ                                                         
      AMXCES = EXCESS( IZ, IA, IRTN )                                   
      IF ( IRTN .EQ. 0 ) GO TO 330                                      
      WRITE(6,313) IA, IZ, N                                              
 313  FORMAT ( '0**** THE NUCLEUS WITH A =', I4, ',  Z =', I4,  ',  N ='
     *, I4, '  IS NOT BOUND ',  'ACCORDING TO PTOLEMY"S MASS TABLE.' )  
      GO TO 359                                                         
 330  XCESES(I) = AMXCES                                                
      IF ( I .LE. 2 ) AMXGPT(I) = AMXCES                                
      IF ( I .LE. 2 ) XCESES(I) = XCESES(I) + EXSPT(I)                  
      IF ( I .EQ. 3 .AND. ESTARS(3) .NE. UNDEF )  XCESES(3) = XCESES(3) 
     *+ ESTARS(3)                                                       
 359  CONTINUE                                                          
C                                                                       
C     NOW GET J FOR EACH OF THE GROUND STATES                           
C                                                                       
      DO 459 I = 1, NUMSYM                                              
C                                                                       
      IA = IAB                                                          
      IZ = IZB                                                          
      JJ = J                                                            
      ESTAR = ESTARS(I)                                                 
      IF ( I .EQ. 3 ) GO TO 410                                         
      IA = AMPTS(I)                                                     
      IZ = IZPTS(I)                                                     
      JJ = JSPTS(I)                                                     
C                                                                       
C     IF E* HAS BEEN ENTERED THEN G.S. J IS MEANINGLESS                 
C                                                                       
 410  IF ( ESTAR .GT. 1.D-5 .AND. ESTAR .NE. UNDEF ) GO TO 459          
      N = IA - IZ                                                       
      CALL GSINFO ( IZ, IA, JVAL, IPARIT, ALPHA, IRTN )                 
      IF ( IRTN .EQ. 0 .AND. JVAL .NE. NOTDEF ) GO TO 430               
C     NO ERROR IF J IS ALREADY DEFINED OR IS EXPLICITLY GIVEN           
C     IN THE REACTION.                                                  
      IF ( JJ .NE. NOTDEF ) GO TO 459                                   
C                                                                       
C     DINEUTRON OR DIPROTON IS J = 0                                    
C                                                                       
      IF ( IA .NE. 2 .OR. IZ .EQ. 1 ) GO TO 420                         
      JVAL = 0                                                          
      GO TO 450                                                         
 420  WRITE(6,423) IA, IZ, N                                              
 423  FORMAT ( '0**** WARNING:  THE GROUND STATE SPIN OF THE',  ' NUCLEU
     *S WITH A =', I4, ',  Z =', I4, ',  N =', I4,  '  IS NOT KNOWN TO P
     *TOLEMY.' )                                                        
      GO TO 459                                                         
C                                                                       
C     IF J HAS BEEN DEFINED TO BE DIFFERENT FROM G.S. THEN NEED E*      
C                                                                       
 430  IF ( JJ .EQ. NOTDEF ) GO TO 450                                   
      IF ( JJ .EQ. JVAL .OR. ESTAR .NE. UNDEF ) GO TO 459               
      WRITE(6,433) NAMES(I), JVAL, JJ                                     
 433  FORMAT ( '0**** WARNING:  GROUND STATE SPIN FOR ',  A8, A3,  ' IS'
     *, I3, '/2.  YOU HAVE SPECIFIED J',  ' =', I3, '/2, BUT HAVE NOT SP
     *ECIFIED E*' )                                                     
      GO TO 459                                                         
C                                                                       
 450  IF ( I .NE. 3 ) GO TO 455                                         
      J = JVAL                                                          
      IF ( IPARIT .NE. 0 ) PARITY = IPARIT                              
      GO TO 459                                                         
 455  JSPTS(I) = JVAL                                                   
      IF ( IPARIT .NE. 0 ) PARIPT(I) = IPARIT                           
 459  CONTINUE                                                          
C                                                                       
C     DEFINE BINDING ENERGY                                             
C                                                                       
      IF ( NUMSYM .EQ. 3 )  E = XCESES(3) - XCESES(1) - XCESES(2)       
C                                                                       
C     IT WAS SUCCESFUL, COPY REACTION FOR HEADER                        
C                                                                       
      DO 649 I = 1, 45                                                  
      REACT(I) = BLANK1                                                 
 649  CONTINUE                                                          
      N = MIN0( 45, INCH-INCHST )                                       
      DO 659 I = 1, N                                                   
      REACT(I) = IBUF(INCHST-1+I)                                       
 659  CONTINUE                                                          
      IRET = 1                                                          
      RETURN                                                            
      END                                                               
      SUBROUTINE CHNSCN ( GUY, ESTARS, NODVLS, LVALS, JVALS, IPARYS,  IR
     *TN )                                                              
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
C  SCANS AN INPUT LINE FOR CHANNEL SPECIFICATIONS                       
C                                                                       
C  DESCRIPTION OF PARAMETERS:                                           
C  GUY    R*8 A 3-COMPONENT ARRAY THAT WILL CONTAIN THE PARTICIPANTS    
C  ESTARS R*8 WILL BE SET TO EXPLICITLY GIVEN EXCITED STATE E'S.        
C  NODVLS I*4 WILL BE SET TO THE GIVEN NODE VALUE FROM A LEVEL          
C             SPECIFICATION (2P3/2- MEANS NODVLS = 1).                  
C  LVALS  I*4 WILL BE SET TO THE L VALUES FROM LEVEL SPECS.             
C  JVALS  I*4 WILL BE SET TO EXPLICITLY GIVEN J'S.                      
C  IPARYS I*4 WILL BE SET TO THE PARITIES                               
C  IRTN   I*4 AN ERROR RETURN CODE                                      
C          > 0 = NUMBER OF FIELDS ( 2 OR 3 ) FOUND.  ALL O.K.           
C        = -1 - SYNTAX ERROR                                            
C                                                                       
C     IF AN = IS CODED, THE SUM IS STORED IN THE 3RD ELEMENT.           
C                                                                       
C     IN THIS VERSION, THE INPUT LINE IS IN   /INPBUF/.                 
C     THIS VERSION DOES NOT RECOGNIZE  *'S  OR  &'S.                    
C                                                                       
C     9/22/75 - BASED ON QVSCAN - S. PIEPER                             
C     10/13/75 - FIX END OF CHANNEL SPECIFICATION BUG.                  
C     8/25/76 - REMOVE FIELD                                            
C     9/24/77 - ESTAR = UNDEF WHEN NOT ENTERED                          
C     6/23/78 - ALWASY SET ALL 3 ITEMS TO UNDEIFNED FOR CDC             
C     5/6/79 - NODES, L-VALUES, PARITIES - S.P.                         
C     12/26/79 - STANDARD MORTRAN - RPG                                 
C     1/30/80 - SEPARATE CVALU ARG TO MSCAN; ESTARS, VALU REAL - RPG    
C     5/29/80 - SEPARATE '(' AND 1H( DATA STATEMENTS - S.P.             
C                                                                       
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
C                                                                       
      IMPLICIT INTEGER*4 (A-Z)                                          
C                                                                       
      DIMENSION NODVLS(3), LVALS(3), JVALS(3), IPARYS(3)                
C                                                                       
      REAL*8 UNDEF                                                      
      COMMON /INTRNL/ UNDEF, NOTDEF                                     
C                                                                       
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
C                                                                       
      CHARACTER*1 SLASH, PLUS, MINUS, EQUAL                             
      DATAEQUAL/'='/                                                    
      DATAMINUS/'-'/                                                    
      DATAPLUS/'+'/                                                     
      DATA SLASH / '/' /                                                
      CHARACTER*8 GUY(3), BLANK8, CVALU                                 
      DATABLANK8/' '/                                                   
      REAL*8 ESTARS(3), VALU, DUMVAL                                    
      CHARACTER*1 STPCHR, BLANK, COMMA                                  
      DATACOMMA/','/                                                    
      DATABLANK/' '/                                                    
      LOGICAL PREDSW, EREDSW                                            
C                                                                       
      CHARACTER*1 LEFTP                                                 
      DATA LEFTP / '(' /                                                
CDC%F                                                                   
CDC      DATA LEFTP / 1H( /                                             
CDC%M                                                                   
C                                                                       
      IRTN = 0                                                          
      INCHST = INCH                                                     
      PREDSW = .FALSE.                                                  
      EREDSW = .FALSE.                                                  
      DO 59 I = 1, 3                                                    
      GUY(I) = BLANK8                                                   
      NODVLS(I) = NOTDEF                                                
      LVALS(I) = NOTDEF                                                 
      IPARYS(I) = 0                                                     
      JVALS(I) = NOTDEF                                                 
      ESTARS(I) = UNDEF                                                 
  59  CONTINUE                                                          
C                                                                       
C --- LOOP ON THE REACTION PARTICIPANTS                                 
      I = 1                                                             
 100  CONTINUE                                                          
C                                                                       
      CALL MSCAN ( -20, ITOKEN, GUY(I), DUMVAL, IVALU, IBUF, IMESS,  STP
     *CHR )                                                             
      IF ( IMESS .GT. 5 ) GO TO 9004                                    
      IF ( IMESS .EQ. 0 ) GO TO 9005                                    
      INCH = INCH+1                                                     
C                                                                       
C                                                                       
C     IF STOPPED BY A  (  PROCESS EXCITED STATE                         
C     STATE.                                                            
C                                                                       
      IF ( STPCHR .NE. LEFTP ) GO TO 400                                
C                                                                       
C     GET E* AND J                                                      
C                                                                       
 200  CALL MSCAN ( 18, ITOKEN, CVALU, VALU, IVALU, IBUF, IMESS, STPCHR )
      IF ( ITOKEN .EQ. -9) GO TO 9900                                   
      IF ( ITOKEN .EQ. -8 ) GO TO 9007                                  
      IF ( ITOKEN .NE. -2 ) GO TO 230                                   
C                                                                       
C     IT IS E*                                                          
C                                                                       
      IF ( ESTARS(I) .EQ. UNDEF ) GO TO 220                             
      WRITE(6,213)
 213  FORMAT ( '0**** ATTEMPTING TO ENTER 2 VALUES FOR E*' )            
      GO TO 9900                                                        
 220  ESTARS(I) = VALU                                                  
      GO TO 200                                                         
C                                                                       
 230  IF ( ITOKEN .NE. -5 ) GO TO 270                                   
C                                                                       
C     IT IS J                                                           
C                                                                       
      IF ( JVALS(I) .EQ. NOTDEF ) GO TO 240                             
      WRITE(6,233)
 233  FORMAT ( '0**** ATTEMPTING TO ENTER 2 VALUES FOR J' )             
      GO TO 9900                                                        
 240  JVALS(I) = 2*IVALU                                                
      IF ( STPCHR .NE. SLASH ) GO TO 250                                
C                                                                       
C     BYPASS /2                                                         
C                                                                       
      INCH = INCH+1                                                     
      JVALS(I) = IVALU                                                  
C                                                                       
C     IT IS NECESSARY TO CODE THE 2 FOLLOWING THE /                     
C     MAKE SURE IT IS JUST A SIMPLE 2                                   
C                                                                       
      CALL MSCAN ( 18, ITOKEN, CVALU, VALU, IVALU, IBUF, IMESS, STPCHR )
      IF ( ITOKEN .EQ. -9 ) GO TO 9900                                  
      IF ( ITOKEN .EQ. -8 ) GO TO 9007                                  
      IF ( ITOKEN .EQ. -5 .AND. IVALU .EQ. 2 ) GO TO 250                
      WRITE(6,243)
 243  FORMAT ( '0**** INVALID J FIELD' )                                
      GO TO 9900                                                        
C                                                                       
C     PARITY MAY BE GIVEN BY TERMINAL + OR -                            
C                                                                       
 250  IP = +1                                                           
      IF ( STPCHR .EQ. PLUS ) GO TO 255                                 
      IP = -1                                                           
      IF ( STPCHR .NE. MINUS ) GO TO 200                                
 255  IPARYS(I) = IP                                                    
      INCH = INCH+1                                                     
      GO TO 200                                                         
C                                                                       
 270  IF ( ITOKEN .NE. -3 ) GO TO 280                                   
C                                                                       
C     IT IS A NODES AND L PART OF A LEVEL DESCRIPTOR                    
C                                                                       
      IF ( LVALS(I) .EQ. NOTDEF ) GO TO 275                             
      WRITE(6,273)
 273  FORMAT ( '0**** ATTEMPTING TO ENTER TWO LEVEL DESCRIPTORS' )      
      GO TO 9900                                                        
 275  LVALS(I) = IVALU                                                  
      NODVLS(I) = VALU                                                  
      GO TO 200                                                         
C                                                                       
C     IS IT THE CLOSING )                                               
C                                                                       
 280  IF ( ITOKEN .EQ. 11 ) GO TO 290                                   
      WRITE(6,283) ITOKEN                                                 
 283  FORMAT ( '0**** UNRECOGNIZABLE EXCITED STATE DESCRIPTOR (TOKEN =',
     * I4, ')' )                                                        
      GO TO 9900                                                        
C                                                                       
C     ALL DONE WITH THE EXCITED STATE; BYPASS FINAL ).                  
C                                                                       
 290  STPCHR = IBUF(INCH)                                               
      INCH = INCH + 1                                                   
C                                                                       
C                                                                       
C                                                                       
C     READY TO PROCESS THE NEXT FIELD IF THERE IS ONE TO                
C     PROCESS.                                                          
C     IF WE ARE DONE, WE WANT TO PROCESS THE FINAL STPCHR AS            
C     THE NEXT "FIELD".                                                 
C                                                                       
 400  INCH = INCH - 1                                                   
C     IS IT POSSIBLE TO HAVE ANOTHER FIELD                              
      IF ( PREDSW .AND. EREDSW ) GO TO 800                              
C                                                                       
C     BYPASS BLANKS                                                     
C                                                                       
 420  INCH = INCH + 1                                                   
      IF ( STPCHR .NE. BLANK ) GO TO 450                                
      IF ( INCH .GE. NOCH ) GO TO 460                                   
      STPCHR = IBUF(INCH)                                               
      GO TO 420                                                         
C                                                                       
C     ONLY + AND = ARE VALID DELIMATORS INSIDE THE SPECIFICATION.       
C                                                                       
 450  IF ( STPCHR .EQ. EQUAL ) GO TO 500                                
      IF ( STPCHR .EQ. PLUS ) GO TO 550                                 
C                                                                       
C     END OF CHANNEL - STPCHR WILL BE RECONSIDERED BY CONTRL.           
C     DID WE GET MINIMAL CHANNEL SPECIFICATION                          
C                                                                       
      INCH = INCH - 1                                                   
 460  IF ( PREDSW ) GO TO 800                                           
      WRITE(6,463)
 463  FORMAT ( '0**** CHANNEL SPECIFICATION REQUIRES TWO',  ' NUCLEAR SY
     *MBOLS SEPARATED BY A "+".' )                                      
      GO TO 9900                                                        
C                                                                       
C     = SIGN; IS THIS 1ST SUCH0                                         
C                                                                       
 500  IF ( EREDSW ) GO TO 9020                                          
      EREDSW = .TRUE.                                                   
C                                                                       
C     ALWAYS STORE RESULT OF = IN 3RD SPOT                              
C                                                                       
      IF ( I .EQ. 2 ) GO TO 520                                         
      GUY(3) = GUY(1)                                                   
      JVALS(3) = JVALS(1)                                               
      ESTARS(3) = ESTARS(1)                                             
      GO TO 100                                                         
C                                                                       
 520  I = 3                                                             
      GO TO 100                                                         
C                                                                       
C     + SIGN; IS THIS 1ST                                               
C                                                                       
 550  IF ( PREDSW ) GO TO 9022                                          
      PREDSW = .TRUE.                                                   
      I = I + 1                                                         
      GO TO 100                                                         
C                                                                       
 800  IRTN = 2                                                          
      IF ( EREDSW ) IRTN = 3                                            
      RETURN                                                            
C                                                                       
C     LOTS OF ERROR MESSAGEES                                           
C                                                                       
C  ONE OF THE GUYS HAS MORE THAN 5 CHARACTERS IN IT                     
9004  WRITE(6,9014)
 9014 FORMAT ( '0**** TOO MANY CHARACTERS IN SYMBOL AND ATOMIC MASS.' ) 
      GO TO 9900                                                        
 9005 WRITE(6,9015)
 9015 FORMAT ( '0**** UNEXPECTED DELIMITOR OR END OF LINE ENCOUNTERED', 
     * ' WHEN LOOKING FOR ELEMENT SYMBOL.' )                            
      GO TO 9900                                                        
 9007 WRITE(6,9017)
 9017 FORMAT ( '0**** COMPLETE SPECIFICATION MUST BE ON SAME LINE AS',  
     *' CHANNEL KEYWORD.' )                                             
      GO TO 9900                                                        
 9020 WRITE(6,9021)
 9021 FORMAT ( '0**** TWO "=" SIGNS ARE NOT ALLOWED' )                  
      GO TO 9900                                                        
 9022 WRITE(6,9023)
 9023 FORMAT ( '0**** TWO "+" SIGNS ARE NOT ALLOWED.' )                 
      GO TO 9900                                                        
C                                                                       
 9900 INCHM1 = INCH - 1                                                 
      WRITE(6,9903) I, ( IBUF(II), II = INCHST, INCHM1 )                  
 9903 FORMAT ( 6X, 'WAS PROCESSING FIELD', I2, ' OF THE SPECIFICATION' /
     * 6X, 'SPECIFICATION UP TO THE ERROR IS: ', 80A1 )                 
      IRTN = -1                                                         
      RETURN                                                            
      END                                                               
      SUBROUTINE CLINTS ( RLOWER, ETAI, ETAF, FKI, FKF, SIGI, SIGF,  ACC
     *URA, ASMULT, FFINT, FGINT, GFINT, GGINT,  PTS, WTS, FA, FPA, GA, G
     *PA, WORK,  N, LI, LF, NTERMS, NPTS, IRET, IPRINT )                
C                                                                       
C     EVALUATES INTEGRAL(RLOWER, INF) DR FCOUL FCOUL / R**N             
C                                                                       
C     THE FOUR INTEGRALS:                                               
C                                                                       
C     XYINT = INTEGRAL(RLOWER, INF) DR X(LF,ETAF,KF*R) Y(LI,ETAI,KI*R)  
C             /R**N                                                     
C                                                                       
C     WHERE X AND Y ARE EITHER F OR G (REG. AND IRREG. COUL. FUNCS)     
C     ARE EVALUATED.  THE INTEGRALS ARE DONE IN THREE PIECES:           
C        RLOWER  TO  R1  TO  R2  TO  INFINITY                           
C     RLOWER TO R1 - THE WHOLE WORKS IS DONE NUMERICALLY WITH NPTS      
C            GAUSS POINTS PER CYCLE OF THE COULOMB FUNCTIONS.           
C     R1 TO R2 - THE (PHI+PHI) PIECE (SEE BELOW) IS DONE BY BELLING     
C                AND THE (PHI-PHI) PIECE IS DONE NUMERICALLY.           
C     R2 TO INF. - BOTH PIECES ARE DONE BY BELLING.  DEPENDING ON       
C     THE CIRCUMSTANCES, THE FIRST AND/OR SECOND REGION MAY BE          
C     SKIPPED.                                                          
C                                                                       
C     EACH COULOMB FN = SIN(PHI) OR COS(PHI) / SQRT(Z)                  
C     THEN (BELLING J.PHYS.B1,136,(1968) THE INTEGRALS CAN BE           
C     GIVEN IN TERMS OF INT(R,INF)(R**-N)*(SQRT(ZI*ZF)**-1)*COS(ANGLE)  
C     OR SIN(ANGLE) WITH ANGLE = PHI(IN)+PHI(OUT) OR PHI(IN)-PHI(OUT)   
C     FOR + INTEGRAL USE BELLING'S ASYMPTOTIC EXPANSION IN R**-1        
C     THE - INTEGRAL (SLOWLY OSCILLATING INTEGRAND) IS DONE             
C     NUMERICALLY BY GAUSS-LEGENDRE QUADRATURE AFTER SPLITTING (R INF)  
C     INTO INTERVALS OF LENGTH PI/CHI                                   
C     WHERE CHI=D/DR(ANGLE)                                             
C     WITH THE VERY-LARGE L PART BY BELLINGS METHOD                     
C                                                                       
C                                                                       
C     ***  ARGUMENT LIST ***                                            
C     ***** FOLLOWING ARGUMENTS ARE REAL*8 *****                        
C     RLOWER: LOWER LIMIT OF INTEGRATION                                
C     ETAI  : COULOMB PARAMETER IN INGOING CHANNEL                      
C     ETAF  : COULOMB PARAMETER IN OUTGOING CHANNEL                     
C     FKI   : INGOING WAVE NUMBER                                       
C     FKF   : OUTGOING WAVE NUMBER                                      
C     SIGI  : SUPPLIED VALUE OF INCOMING COULOMB PHASE SHIFT            
C     SIGF  : SUPPLIED VALUE OF OUTGOING COULOMB PHASE SHIFT            
C     ACCURA:  REQUIRED RELATIVE ACCURACY OF THE INTEGRALS.  THIS IS    
C              USED TO CHECK THE BELLINGS RESULTS BUT THE GAUSS         
C              INTEGRATIONS ARE NOT CHECKED FOR CONVERGENCE.            
C     ASMULT: BELLING'S METHOD IS USED WHEN A CERTAIN QUANTITY          
C           : IS LESS THAN   ASMULT * ACCURA  .  REASONABLE             
C           : VALUES OF ASMULT ARE AROUND .1 TO .5 .  IF THE INPUT VALUE
C           : IS TOO LARGE, IT                                          
C           : IS AUTOMATICALLY (AT SOME COST) REDUCED.                  
C     FFINT, FGINT, GFINT, GGINT:  THE FOUR INTEGRALS DEFINED ABOVE     
C     PTS, WTS : WORK ARRAYS OF DIMENSION NPTS.                         
C     FA TO GPA, WORK : WORK ARRAYS OF DIMENSION                        
C          MAX( LI, LF, 4*NTERMS ) + 1                                  
C     ***** FOLLOWING ARGUMENTS ARE INTEGER*4 *****                     
C     N     : POWER OF R (INTEGRAL OF 1/(R**N))                         
C     LI,LF : L-VALUES OF PARTIAL WAVES FOR COULOMB FUNCTIONS           
C     NTERMS: MAXIMUM NO OF TERMS IN BELLING'S SERIES (20 IS REASONABLE)
C     NPTS  : ORDER OF GAUSS-LEGENDRE QUADRATURE (TYPICALLY 3 - 10)     
C     IRET  : ERROR INDICATOR FROM COULOMB SR. ALL'S WELL IF = 0        
C     IPRINT: = 4 YIELDS SOME DIAGNOSTIC PRINT-OUT                      
C           : = 8 YIELDS COPIOUS DIAGNOSTIC PRINT-OUT                   
C                                                                       
C     M.H.M - JUNE 1 1976                                               
C     NOV 1976 - IMPROVEMENTS - S.P.                                    
C     JAN 1977 - USE RCASYM - S. P.                                     
C     9/15/78 - IMPROVED DIAGNOSTIC PRINTOUT - S.P.                     
C     10/25/78 - FIX ERROR IN DECIDING WHEN TO GO TO BELLING - S.P.     
C     12/26/79 - STANDARD MORTRAN - RPG                                 
C                                                                       
C                                                                       
      IMPLICIT REAL*8(A-H,O-Z)                                          
C                                                                       
      DIMENSION PTS(NPTS), WTS(NPTS)                                    
      DIMENSION FA(1), FPA(1), GA(1), GPA(1), WORK(1)                   
C                                                                       
C                                                                       
C                                                                       
      DATA PI /3.14159 26535 89793 0D0/, ACCUR /1.D-14/                 
      LOGICAL ODDSW, ASYMSW                                             
C                                                                       
      IF ( IPRINT .GE. 3 ) WRITE(6,13) N,LI,LF,NTERMS,NPTS,RLOWER,E
     *TAI, ETAF, FKI, FKF, SIGI, SIGF                                   
 13   FORMAT ( / ' CLINTS:', I3, 2I4, 2I3, 7G15.6 )                     
C                                                                       
C     SETUP GAUSS POINTS                                                
C                                                                       
      CALL GAUSSL ( NPTS, PTS, WTS )                                    
C                                                                       
      ICHI = 0                                                          
      EPSILO = ASMULT * ACCURA                                          
      EPSIL = EPSILO                                                    
C                                                                       
C     INITIALIZE BELLING METHOD FOR SUM                                 
C                                                                       
      ISYN=1                                                            
      FFINT = 0                                                         
      FGINT = 0                                                         
      GFINT = 0                                                         
      GGINT = 0                                                         
      DELTA = PI/DMAX1(FKI,FKF)                                         
      IPIECE = 0                                                        
      RVAL = RLOWER                                                     
C                                                                       
C     GET TURNING POINT                                                 
C                                                                       
      RTURN = DMAX1( (ETAI + DSQRT(ETAI**2+LI*(LI+1)))/FKI,  (ETAF + DSQ
     *RT(ETAF**2+LF*(LF+1)))/FKF )                                      
      ASYMSW = .FALSE.                                                  
      IF ( IPRINT .GE. 3 ) WRITE(6,93) RTURN, EPSILO, DELTA               
  93  FORMAT ( ' RTURN, EPSILO, DELTA =', 3G15.6 )                      
C                                                                       
C     GET COULOMB WAVE FUNCTION AND BELLING PARAMETERS AT R = RVAL      
C                                                                       
 100  ROI=FKI*RVAL                                                      
      ROF=FKF*RVAL                                                      
C                                                                       
      IF ( ASYMSW ) GO TO 120                                           
      IF ( RVAL .LT. 1.2*RTURN ) GO TO 110                              
C                                                                       
C     GET ASYMPTOTIC EXPANSION PARAMETERS                               
C                                                                       
      NMAX = MAX0( LI, 4*NTERMS )                                       
      CALL RCASYM ( LI, ETAI, ROI, IPRINT-4, SIGI, ZI, PHSI, DZI,  FI, F
     *PI, GI, GPI, FA, GA, GPA, WORK,  ACCURA, NMAX, NASYI, IRET )      
      IF ( IRET .NE. 0 ) GO TO 110                                      
      CALL RCASYM ( LF, ETAF, ROF, IPRINT-4, SIGF, ZF, PHSF, DZF,  FF, F
     *PF, GF, GPF, FPA, GA, GPA, WORK,  ACCURA, NMAX, NASYF, IRET )     
      IF ( IRET .NE. 0 ) GO TO 110                                      
C                                                                       
C     FA NOW HAS EXPANSION PARAMETERS FOR INCOMING                      
C     FPA HAS PARAMETERS FOR FINAL.                                     
C                                                                       
      RHO0I = ROI                                                       
      RHO0F = ROF                                                       
      ASYMSW = .TRUE.                                                   
      GO TO 130                                                         
C                                                                       
 110  CALL RCWFN(ROI,ETAI,LI,LI,FA,FPA,GA,GPA,ACCUR,IRET)               
      IF(IRET.NE.0) GO TO 900                                           
      FI=FA(LI+1)                                                       
      GI=GA(LI+1)                                                       
      FPI=FPA(LI+1)                                                     
      GPI=GPA(LI+1)                                                     
      CALL RCWFN(ROF,ETAF,LF,LF,FA,FPA,GA,GPA,ACCUR,IRET)               
      IF(IRET.NE.0) GO TO 900                                           
      FF=FA(LF+1)                                                       
      GF=GA(LF+1)                                                       

      FPF=FPA(LF+1)                                                     
      GPF=GPA(LF+1)                                                     
      ZI=1/(FI**2+GI**2)                                                
      ZF=1/(FF**2+GF**2)                                                
      GO TO 130                                                         
C                                                                       
C     FIND STUFF FROM THE ASYMPTOTIC EXPANSION                          
C                                                                       
 120  RI = RHO0I/ROI                                                    
      RF = RHO0F/ROF                                                    
      ZI = 1                                                            
      ZF = 1                                                            
      DZI = 0                                                           
      DZF = 0                                                           
      WI = RI                                                           
      WF = RF                                                           
      PHSI = 0                                                          
      PHSF = 0                                                          
C                                                                       
      DI = 1                                                            
      TERM2 = 1                                                         
      DO 124 I = 2, NASYI                                               
      TERM = WI*FA(I)                                                   
      WI = WI*RI                                                        
      ZI = ZI + TERM                                                    
      DZI = DZI - DI*TERM                                               
      IF ( I .GT. 2 ) PHSI = PHSI + TERM/(DI-1)                         
      DI = DI + 1                                                       
      IF ( DABS(TERM)+TERM2 .LT. ACCURA*ZI ) GO TO 125                  
      TERM2 = DABS(TERM)                                                
 124  CONTINUE                                                          
      I = NASYI                                                         
 125  NASYI = I                                                         
      PHSI = ROI - ETAI*DLOG(2*ROI) + SIGI - .5*PI*LI - ROI*PHSI        
      DZI = DZI/ROI                                                     
C                                                                       
      DI = 1                                                            
      TERM2 = 1                                                         
      DO 127 I = 2, NASYF                                               
      TERM = WF*FPA(I)                                                  
      WF = WF*RF                                                        
      ZF = ZF + TERM                                                    
      DZF = DZF - DI*TERM                                               
      IF ( I .GT. 2 ) PHSF = PHSF + TERM/(DI-1)                         
      DI = DI + 1                                                       
      IF ( DABS(TERM)+TERM2 .LT. ACCURA*ZF ) GO TO 128                  
      TERM2 = DABS(TERM)                                                
 127  CONTINUE                                                          
      I = NASYF                                                         
 128  NASYF = I                                                         
      PHSF = ROF - ETAF*DLOG(2*ROF) + SIGF - .5*PI*LF - ROF*PHSF        
      DZF = DZF/ROF                                                     
      FI = DSIN(PHSI)/DSQRT(ZI)                                         
      GI = DCOS(PHSI)/DSQRT(ZI)                                         
      FPI = ZI*GI - (.5*DZI/ZI)*FI                                      
      GPI = -ZI*FI - (.5*DZI/ZI)*GI                                     
      FF = DSIN(PHSF)/DSQRT(ZF)                                         
      GF = DCOS(PHSF)/DSQRT(ZF)                                         
      FPF = ZF*GF - (.5*DZF/ZF)*FF                                      
      GPF = -ZF*FF - (.5*DZF/ZF)*GF                                     
 130  TI=FI*FPI+GI*GPI                                                  
      TF=FF*FPF+GF*GPF                                                  
 140  CHI = FKI*ZI + ISYN*FKF*ZF                                        
C                                                                       
C     FOR VERY SMALL CHI (DIFFERENCE PIECE FOR INITIAL = FINAL CASE)    
C     WE DO THE WHOLE THING NUMERICALLY                                 
C                                                                       
      B = 1.D-8*FKI*ZI                                                  
      IF ( IPRINT .GE. 4 ) WRITE(6,143) RVAL, ZI, ZF, CHI, B, TI, TF      
 143  FORMAT ( ' R, Z  S, CHI, TINY, T  S:', G12.4, 2G20.10,  2( G14.4, 
     *G12.4 ) )                                                         
C                                                                       
      IF ( DABS(CHI) .LT. B ) GO TO 150                                 
      IF ( DABS(GI) .GT. 1000 ) GO TO 200                               
C                                                                       
      F = 1 / ( DSQRT(ZI*ZF) * RVAL**N )                                
      A0=F/CHI                                                          
C                                                                       
C     FOR DIFFERENCE WE MAY NOT NEED MUCH CONVERGENCE DUE TO            
C     A LARGE NUMERIC CONTRIBUTION.                                     
C     CAN WE NOOW USE BELLING                                           
C                                                                       
      R = ( N/RVAL + 2*(FKI*ZI*DABS(TI)+FKF*ZF*DABS(TF)) ) / DABS(CHI)  
      EPS = EPSIL                                                       
      IF ( ISYN .EQ. -1 ) EPS = EPS * ( 1 + DABS(CUMC/A0) )             
      DB = R**3                                                         
      IF ( DB**2 .LE. EPS ) GO TO 300                                   
C                                                                       
C     NO, INTEGRATE ONE CYCLE OF THE WHOLE WORKS OR OF JUST             
C         THE DIFFERENCE PARTS.                                         
C                                                                       
 150  IF ( ISYN .EQ. -1 ) DELTA = PI/(DABS(CHI)+N/RVAL)                 
      GO TO 200                                                         
C                                                                       
C                                                                       
 200  IPIECE = IPIECE + 1                                               
      CI = 0                                                            
      SI = 0                                                            
C                                                                       
      DO 259 I = 1, NPTS                                                
      R = RVAL + .5*DELTA + .5*DELTA*PTS(I)                             
      ROI = FKI*R                                                       
      ROF = FKF*R                                                       
      IF ( ASYMSW ) GO TO 210                                           
      CALL RCWFN(ROI,ETAI,LI,LI,FA,FPA,GA,GPA,ACCUR,IRET)               
      IF(IRET.NE.0) GO TO 900                                           
      FI=FA(LI+1)                                                       
      GI=GA(LI+1)                                                       
      CALL RCWFN(ROF,ETAF,LF,LF,FA,FPA,GA,GPA,ACCUR,IRET)               
      IF(IRET.NE.0) GO TO 900                                           
      FF=FA(LF+1)                                                       
      GF=GA(LF+1)                                                       
      GO TO 230                                                         
C                                                                       
C     HERE USE ASYMPTOTIC EXPANSION                                     
C                                                                       
 210  RI = RHO0I/ROI                                                    
      ZI = FA(NASYI)*RI                                                 
      PHSI = 0                                                          
      DJ = NASYI - 2                                                    
      DO 214 JJ = 3, NASYI                                              
      J = NASYI+2-JJ                                                    
      ZI = RI*(FA(J) + ZI)                                              
      PHSI = RI*(FA(J+1)/DJ + PHSI)                                     
      DJ = DJ - 1                                                       
 214  CONTINUE                                                          
      ZI = 1 + ZI                                                       
      PHSI = ROI - ETAI*DLOG(2*ROI) + SIGI - .5*PI*LI - RHO0I*PHSI      
      FI = DSIN(PHSI)/DSQRT(ZI)                                         
      GI = DCOS(PHSI)/DSQRT(ZI)                                         
      RF = RHO0F/ROF                                                    
      ZF = FPA(NASYF)*RF                                                
      PHSF = 0                                                          
      DJ = NASYF - 2                                                    
      DO 219 JJ = 3, NASYF                                              
      J = NASYF+2-JJ                                                    
      ZF = RF*(FPA(J) + ZF)                                             
      PHSF = RF*(FPA(J+1)/DJ + PHSF)                                    
      DJ = DJ - 1                                                       
 219  CONTINUE                                                          
      ZF = 1 + ZF                                                       
      PHSF = ROF - ETAF*DLOG(2*ROF) + SIGF - .5*PI*LF - RHO0F*PHSF      
      FF = DSIN(PHSF)/DSQRT(ZF)                                         
      GF = DCOS(PHSF)/DSQRT(ZF)                                         
C                                                                       
 230  ZFAC = .5*DELTA*WTS(I)/R**N                                       
C                                                                       
      IF ( ISYN .EQ. -1 ) GO TO 250                                     
C                                                                       
      FFINT = FFINT + ZFAC*FF*FI                                        
      FGINT = FGINT + ZFAC*FF*GI                                        
      GFINT = GFINT + ZFAC*GF*FI                                        
      GGINT = GGINT + ZFAC*GF*GI                                        
      GO TO 259                                                         
C                                                                       
C     FOLLOWING ARE COS(PHII-PHIF) AND SIN(PHII-PHIF)                   
C                                                                       
 250  CI = CI + ZFAC*(GI*GF+FI*FF)                                      
      SI = SI + ZFAC*(FI*GF-GI*FF)                                      
C                                                                       
 259  CONTINUE                                                          
C                                                                       
      IF ( IPRINT .LT. 7 ) GO TO 280                                    
      IF ( ISYN .EQ. +1 ) WRITE(6,273) IPIECE,RVAL,FFINT,FGINT,GFINT,
     * GGINT                                                            
 273  FORMAT (' INTS:', I4, F6.1, 4G14.6 )                              
      IF ( ISYN .EQ. -1 ) WRITE(6,278) IPIECE, RVAL, CI, SI               
 278  FORMAT ( ' NUMERIC C-, S-:', I4, G12.4, 2G14.6 )                  
C                                                                       
 280  RVAL = RVAL + DELTA                                               
      IF ( ISYN .EQ. +1 ) GO TO 100                                     
      CUMC = CUMC + CI                                                  
      CUMS = CUMS + SI                                                  
C                                                                       
C     HAAVE WE GONE SO FAR IN DIFFERRENCE THAT THE BILLING'S            
C     PIECE WON'T MATTER.                                               
C                                                                       
      IF ( DABS(CI) .LT. ACCURA*DABS(FFINT+.5*(CUMC-CIP)) .AND. DABS(SI)
     * .LT. ACCURA*DABS(GFINT+.5*(CUMS+SIP)) ) GO TO 810                
      GO TO 100                                                         
C                                                                       
C     ALL DONE WITH NUMERIC PART OF TOTALS                              
C                                                                       
 300  IF ( IPRINT .LT. 3 .OR. IPIECE .EQ. 0 ) GO TO 350                 
      IF ( ISYN .EQ. +1 ) WRITE(6,303) IPIECE,FFINT,FGINT,GFINT,GGINT
 303  FORMAT ( ' NUMERIC VALUES FOR', I4, ' CYCLES:' / 4G15.8 )         
      IF ( ISYN .EQ. -1 ) WRITE(6,313) IPIECE, CUMC, CUMS                 
 313  FORMAT ( ' NUMERIC C-, S- FROM', I4, ' CYCLES:', 2G15.8 )         
C                                                                       
C     FOR SUM WE USE THE FF INTEGRAL AS A GUIDE TO ERRORS               
C                                                                       
 350  IF ( ISYN .EQ. -1 ) GO TO 400                                     
      CUMC = FFINT                                                      
      CUMS = FFINT                                                      
C                                                                       
C     BELLINGS METHOD FOR SUM OR DIF                                    
C     HERE WE SET UP  Y(I), Y(F), ..., DF/DK, D2F/DK2, ...              
C     WHICH ARE NEEDED FOR BELLING'S METHOD.  (SEE "SERIES              
C     EXPANSION OF COULOMB INTEGRALS" PP 1-5.)                          
C                                                                       
 400  PHSI=DATAN2(FI,GI)                                                
      PHSF=DATAN2(FF,GF)                                                
      DZI=-2*FKI*ZI*ZI*TI                                               
      DZF=-2*FKF*ZF*ZF*TF                                               
      DCHI=FKI*DZI+ISYN*FKF*DZF                                         
      D1=DZI/ZI+DZF/ZF                                                  
      C1=DFLOAT(N)/RVAL+.5*D1                                           
      DF=-F*C1                                                          
      WI=1-(2*ETAI)/ROI-(LI*(LI+1))/(ROI**2)                            
      WF=1-(2*ETAF)/ROF-(LF*(LF+1))/(ROF**2)                            
      DTI=FKI*(FPI**2+GPI**2-WI/ZI)                                     
      DTF=FKF*(FPF**2+GPF**2-WF/ZF)                                     
      D2ZI=-2*FKI*ZI*(2*DZI*TI+ZI*DTI)                                  
      D2ZF=-2*FKF*ZF*(2*DZF*TF+ZF*DTF)                                  
      D2CHI=FKI*D2ZI+ISYN*FKF*D2ZF                                      
      D12=(DZI/ZI)**2+(DZF/ZF)**2                                       
      D2=D2ZI/ZI+D2ZF/ZF                                                
      D2F=(F/RVAL-DF)*C1-(F*D1)/(2*RVAL)-.5*F*(D2-D12)                  
      IF ( IPRINT .GE. 4 ) WRITE(6,423) RVAL, ROI, ROF, R                 
 423  FORMAT (' R =', G12.4, '   RHO  S =', 2G12.4,  '   EPSILON =', G10
     *.2 )                                                              
      DB = 0                                                            
      TIMS=1/(RVAL*CHI)                                                 
      PHANG=PHSI+ISYN*PHSF                                              
      SN=DSIN(PHANG)                                                    
      CSN=DCOS(PHANG)                                                   
C                                                                       
C     EACH ITERATION ON NITS BRINGS IN A HIGHER DERIVATIVE OF BETA.     
C     RIGHT NOW WE ONLY HAVE 0TH AND 1ST DERIVATIVES                    
C                                                                       
      IF ( IPRINT .GE. 6 ) WRITE(6,433)
 433  FORMAT ( ' NIT  K', 6X, 'B', 9X, 'DB', 10X, 'A',  13X, 'EVEN', 13X
     *, 'ODD' )                                                         
C                                                                       
      DO 499 NIT = 1, 2                                                 
C                                                                       
      FACTOR=F/CHI                                                      
C                                                                       
C     BELLING'S EXPANSION ( SEE "SERIES...", P 6)                       
C     COLLECT ODD AND EVEN A-COEFFICIENTS INTO SIN AND COS INTEGRALS    
C                                                                       
C     SEE "LONG-RANGE PART OF COULOMB FUNCTION INTEGRALS", P 8,         
C     EQS 33-34                                                         
C                                                                       
      EVEN = A0                                                         
      AM1 = A0                                                          
      B = 1                                                             
      ODD = 0                                                           
      SIGN = +1.                                                        
      ODDSW = .TRUE.                                                    
      DO 469 I = 1, NTERMS                                              
      FACTOR=FACTOR*TIMS                                                
      C2=DF/F-(I*DCHI)/CHI                                              
      BM1 = B                                                           
      B=RVAL*DB+(C2*RVAL-I+1)*B                                         
      IF ( NIT .GT. 1 )  DB=(C2*RVAL-I+2)*DB+(C2-RVAL*((DF/F)**2  - I*(D
     *CHI/CHI)**2)+RVAL*(D2F/F-I*D2CHI/CHI))*BM1                        
      A=B*FACTOR                                                        
C                                                                       
      IF ( ODDSW ) GO TO 440                                            
      EVEN = EVEN + SIGN*A                                              
      GO TO 445                                                         
 440  ODD = ODD + SIGN*A                                                
      SIGN = -SIGN                                                      
 445  ODDSW = .NOT. ODDSW                                               
C                                                                       
      IF ( IPRINT .GE. 6 ) WRITE(6,447) NIT,I,B,DB,A,EVEN,ODD      
 447  FORMAT ( I3, I4, 3G11.4, 2G17.9 )                                 
      IF ( I .EQ. 1 ) GO TO 465                                         
      IF ( DABS(A) .GT. DABS(AM2) ) GO TO 700                           
      IF ( DABS(A) .LT. ACCURA*(DABS(A0)+DMIN1(DABS(CUMC),  DABS(CUMS)))
     * ) GO TO 470                                                      
C                                                                       
 465  AM2 = AM1                                                         
      AM1 = A                                                           
 469  CONTINUE                                                          
      GO TO 700                                                         
C                                                                       
 470  CI = -EVEN*SN-ODD*CSN                                             
      SI = -ODD*SN+EVEN*CSN                                             
      ARAT = A/A0                                                       
      IF ( IPRINT .GE. 4 ) WRITE(6,473) NIT, I, ARAT, CI, SI              
 473  FORMAT ( ' NIT =', I2, '   A(', I2, ')/A(0) =', G9.2,  '   COS, SI
     *N =', 2G15.8 )                                                    
      IF ( NIT .EQ. 1 ) GO TO 490                                       
      EVEN = DABS( (CILAST-CI)/(CUMC+CI) )                              
      ODD = DABS( (SILAST-SI)/(CUMS+SI) )                               
      IF ( IPRINT .GE. 4 ) WRITE(6,483) EVEN, ODD                         
 483  FORMAT ( 11X, 'REL. ERR. =', 2G10.2 / )                           
 490  CILAST = CI                                                       
      SILAST = SI                                                       
 499  CONTINUE                                                          
C                                                                       
C                                                                       
C     WAS THE DERIVATIVE A BIG CORRECTION?                              
C                                                                       
      IF ( DMAX1(EVEN, ODD)**2 .GT. ACCURA ) GO TO 700                  
C                                                                       
      ICHI = 0                                                          
      IF(ISYN.EQ.-1) GO TO 800                                          
      CIP = CI                                                          
      SIP = SI                                                          
C                                                                       
C     NOW DO  PH(IN)-PH(OUT)                                            
C                                                                       
      IPIECE = 0                                                        
      ISYN = -1                                                         
      CUMS=0                                                            
      CUMC=0                                                            
      EPSIL = EPSILO                                                    
      GO TO 140                                                         
C                                                                       
C                                                                       
C                                                                       
C     WE NEED TO MAKE ASMULT SMALLER                                    
C                                                                       
 700  R = DMIN1( .5*EPSIL, .75*R**6*(EPSIL/EPS) )                       
      ASMULT = ASMULT * R/EPSIL                                         
      EPSIL = R                                                         
      ICHI = ICHI + 1                                                   
      IF ( ICHI .GT. 20 ) GO TO 720                                     
      IF ( IPRINT .GE. 4 ) WRITE(6,703) ASMULT, EPSIL                     
 703  FORMAT (  '0+++ REDOING CALCULATION WITH NEW ASMULT:', 2G12.4 )   
      GO TO 140                                                         
C                                                                       
 720  WRITE(6,723)
 723  FORMAT ( '0*** COULD NOT GET CONVERGENCE IN CLINTS *** ' )        
      IRET = -1                                                         
      GO TO 50                                                          
C                                                                       
C                                                                       
C     ALL DONE, COLLECT PIECES AND LEAVE                                
C                                                                       
 800  CUMC = CUMC+CI                                                    
      CUMS = CUMS+SI                                                    
 810  FFINT = FFINT + .5*( CUMC - CIP )                                 
      GGINT = GGINT + .5*( CUMC + CIP )                                 
      FGINT = FGINT + .5*( SIP - CUMS )                                 
      GFINT = GFINT + .5*( SIP + CUMS )                                 
      IF ( IPRINT .GE. 3 ) WRITE(6,813) CIP,SIP,CUMC,CUMS,FFINT,FGIN
     *T, GFINT, GGINT                                                   
 813  FORMAT ( '0C+ S+ C- S-:', 4G15.8 / ' FF FG GF GG:', 4G15.8 )      
      GO TO 50                                                          
C                                                                       
C     ERROR IN RCWFN                                                    
C                                                                       
 900  WRITE(6,903) IRET, LI, LF, ETAI, ETAF, ROI, ROF                     
  903 FORMAT(1H0, '*** ERROR IRET = ',I5,' IN RCWFN ***' /  ' L  S, ETA 
     * S, RHO  S =', 2I5, 4G20.10 )                                     
C                                                                       
   50 RETURN                                                            
      END                                                               
      SUBROUTINE CLRCHN ( ICHAN )                                       
C                                                                       
C     CLEAR THE DEFINITIONS OF CHANNEL VARIABLES ( P, T, AND POTS )     
C                                                                       
C     THIS ROUTINE IS CALLED AFTER EACH BOUNDSTATE AND OPTICAL          
C     MODEL SCATTERING STATE.  IT SETS CHANNEL VARIABLES THAT ARE       
C     NOT LIKELY TO BE SIGNIFICANT FOR LATER CALCULATIONS TO            
C     UNDEFINED STATUS.                                                 
C                                                                       
C     FOR STAND ALONES, THINGS ARE SET TO UNDEFINED ONLY IF SOMETHING   
C     ELSE CAN STILL DEFINE THEM (E.G., R IS SET UNDEFINED IF R0,       
C     MP AND MT ARE ALL DEFINED).                                       
C                                                                       
C     5/2/75 - FIRST VERSION - S. PIEPER                                
C     5/17/75 - SELECTIVE CLEARS FOR STANDALONE CALCS.                  
C     5/22/75 - VSI ADDED                                               
C     8/28/75 - CLEAR R0'S WHEN CLEARING A'S.                           
C     10/13/75 - CLEAR RC0 WHICH WE FORGOT ABOUT.                       
C     10/23/75 - ESQ PARMS; DON'T CLEAR V'S BETWEEN SCAT STATES         
C     4/30/76 - MODIFIED COULOMB INPUT  (MHM)                           
C     4/20/77 - DO NOT FREE RC0 BETWEEN B.S. - S.P.                     
C     4/24/77 - USE WASSET FOR RC STUFF; EXSPT CLEARED.                 
C     9/24/77 - UNDJFINE JP, J, L WHEN SET BY SETCHN                    
C     11/20/77 - FREE ASYMPTOPIA                                        
C     11/25/77 - LINKULES                                               
C     12/5/77 - RESTORE STUFF FOR INELASTIC - S.P.                      
C     2/11/78 - FREE ELAB WHEN APPRORIATE                               
C     3/15/78 - DO NOT SET NEXT TO 0 (MUNICH CHANGE) - S.P.             
C     2/2/79 - ADD TENSOR POTENTIALS - RPG                              
C     3/22/79 - RESTORE ALL 6 WORDS OF /LNKBLK/ - S.P.                  
C     5/6/79 - AMXGPT, PARITIES, LEVEL DESCRIPTORS; FREE RCP, RCT LIKE  
C               OTHERS - S.P.                                           
C     7/6/79 - ICHAN=0 AFTER A MULTIPASS CALCULATION. - RPG             
C     2/25/79 - INITIALIZE LNKNAM FROM LNKNM2 - RPG                     
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      COMMON /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
      COMMON /LOCFIT/ LNKAD2(6,2,12)                                    
      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)                 
C                                                                       
      IF ( ICHAN .LT. 5 ) GO TO 200                                     
C                                                                       
C     CLEAR ONLY THINGS THAT CAN BE REDEFINED LATER                     
C                                                                       
      IF ( AMP .EQ. UNDEF .OR. AMT .EQ. UNDEF ) GO TO 150               
      AM = UNDEF                                                        
      IF ( R0 .NE. UNDEF ) R = UNDEF                                    
      IF ( RI0 .NE. UNDEF ) RI = UNDEF                                  
      IF ( RSO0 .NE. UNDEF ) RSO = UNDEF                                
      IF ( RSOI0 .NE. UNDEF ) RSOI = UNDEF                              
      IF ( RSI0 .NE. UNDEF ) RSI = UNDEF                                
      IF ( RC0 .NE. UNDEF ) RC = UNDEF                                  
      IF ( RC0P .NE. UNDEF ) RCP = UNDEF                                
      IF ( RC0T .NE. UNDEF ) RCT = UNDEF                                
      DO 129 I = 1, 6                                                   
      IF ( RTEN0(I) .NE. UNDEF ) RTEN(I) = UNDEF                        
 129  CONTINUE                                                          
      IF ( ELAB .NE. UNDEF ) E = UNDEF                                  
C                                                                       
 150  IF ( ECM .NE. UNDEF ) E = UNDEF                                   
      GO TO 400                                                         
C                                                                       
C     WHEN DOING DWBA; FREE LOTS                                        
C                                                                       
 200  E = UNDEF                                                         
      AM = UNDEF                                                        
      AMP = UNDEF                                                       
      AMT = UNDEF                                                       
      R = UNDEF                                                         
      RC = UNDEF                                                        
      RCP = UNDEF                                                       
      RCT = UNDEF                                                       
      RI = UNDEF                                                        
      RSO = UNDEF                                                       
      RSOI = UNDEF                                                      
      RSI = UNDEF                                                       
      DO 209 I = 1, 6                                                   
      RTEN(I) = UNDEF                                                   
 209  CONTINUE                                                          
      SPAM = UNDEF                                                      
      L = NOTDEF                                                        
      NODES = NOTDEF                                                    
      IZP = NOTDEF                                                      
      IZT = NOTDEF                                                      
      J = NOTDEF                                                        
      JP = NOTDEF                                                       
      JSP = NOTDEF                                                      
      JST = NOTDEF                                                      
      PARITY = 0                                                        
      DO 219 I = 1, 2                                                   
      PARIPT(I) = 0                                                     
      AMXGPT(I) = UNDEF                                                 
      EXSPT(I) = UNDEF                                                  
      LSPCPT(I) = NOTDEF                                                
      NODEPT(I) = NOTDEF                                                
 219  CONTINUE                                                          
C                                                                       
C     DO NOT SET POTENTIALS TO 0 WHEN GOING FROM ONE SCAT. STATE TO     
C     THE NEXT.                                                         
C                                                                       
      IF ( ICHAN .GE. 3 .AND. IDONE/4 .NE. 3 ) GO TO 400                
      TAU = 0                                                           
      TAUI = 0                                                          
      VSO = 0                                                           
      VSOI = 0                                                          
      VSI = 0                                                           
      VE = 0                                                            
      VIE = 0                                                           
      VESQ = 0                                                          
      VIESQ = 0                                                         
      DO 229 I = 1, 6                                                   
      VTEN(I) = 0                                                       
 229  CONTINUE                                                          
      V = 0                                                             
      VI = 0                                                            
C                                                                       
C     CANCEL LINKULE REFERENCES EXCEPT FROM ONE SCAT STATE TO ANOTHER   
C                                                                       
C     ALSO DO NOT CANCEL PRIOR TO EFFECTIVE EXCITATION POTENTIAL        
C                                                                       
      IF ( ISTRIP .EQ. 0 ) GO TO 300                                    
C                                                                       
      DO 259 I = 1, NUMLNK                                              
      LNKADR(3,I) = 0                                                   
 259  CONTINUE                                                          
C                                                                       
C                                                                       
C     WE LEAVE THE A'S DEFINED FROM ONE BOUND STATE TO ANOTHER AND      
C     FROM ONE SCATTERING TO ANOTHER BUT NOT FROM BOUND TO SCATTER      
C                                                                       
      IF ( ICHAN .EQ. 0 ) GO TO 310                                     
 300  IF ( IDONE .EQ. 2**(ICHAN-1) ) GO TO 400                          
      IF ( IDONE .EQ. 3 + 2**(ICHAN-1) ) GO TO 400                      
      IF ( IDONE .EQ. 12 + 2**(ICHAN-1) ) GO TO 400                     
 310  A = UNDEF                                                         
      AI = UNDEF                                                        
      ASO = UNDEF                                                       
      ASOI = UNDEF                                                      
      ASI = UNDEF                                                       
      R0 = UNDEF                                                        
      RI0 = UNDEF                                                       
      RSO0 = UNDEF                                                      
      RSOI0 = UNDEF                                                     
      RSI0 = UNDEF                                                      
      R0E = 0                                                           
      RI0E = 0                                                          
      R0ESQ = 0                                                         
      RI0ESQ = 0                                                        
      RC0 = UNDEF                                                       
      RC0P = UNDEF                                                      
      RC0T = UNDEF                                                      
      AE = 0                                                            
      AIE = 0                                                           
      AESQ = 0                                                          
      AIESQ = 0                                                         
      DO 319 I = 1, 6                                                   
      RTEN0(I) = UNDEF                                                  
      ATEN(I) = UNDEF                                                   
 319  CONTINUE                                                          
      ASYMPT = UNDEF                                                    
C                                                                       
C     WE ALWAYS UNDEFINE PARAMETERS THAT WERE SET TO OTHER PARAMETERS   
C     BY SETPOT                                                         
C                                                                       
 400  IF ( .NOT. WASSET(1) ) GO TO 410                                  
      RI0 = UNDEF                                                       
      RI0E = 0                                                          
      RI0ESQ = 0                                                        
 410  IF ( .NOT. WASSET(2) ) GO TO 420                                  
      AI = UNDEF                                                        
      AIE = 0                                                           
      AIESQ = 0                                                         
 420  IF ( WASSET(3) ) RSO = UNDEF                                      
      IF ( WASSET(4) ) ASO = UNDEF                                      
      IF ( WASSET(5) ) RSOI = UNDEF                                     
      IF ( WASSET(6) ) ASOI = UNDEF                                     
      IF ( WASSET(7) ) RSI = UNDEF                                      
      IF ( WASSET(8) ) ASI = UNDEF                                      
      IF ( WASSET(9) ) RC0 = UNDEF                                      
      IF ( WASSET(9) ) RC = UNDEF                                       
      IF ( WASSET(10) ) RCP = UNDEF                                     
      IF ( WASSET(11) ) RCT = UNDEF                                     
      IF ( WASSET(12) ) JP = NOTDEF                                     
      IF ( WASSET(13) ) J = NOTDEF                                      
      IF ( WASSET(14) ) L = NOTDEF                                      
      IF ( WASSET(15) ) ASYMPT = UNDEF                                  
      IF ( WASSET(16) ) ELAB = UNDEF                                    
      DO 439 I = 1, 6                                                   
      IF ( WASSET(2*I+15) ) RTEN(I) = UNDEF                             
      IF ( WASSET(2*I+16) ) ATEN(I) = UNDEF                             
 439  CONTINUE                                                          
      IF ( WASSET(29) ) PARITY = 0                                      
C                                                                       
C     IF THIS IS INELASTIC SCATTERING, SET BACK TO FIRST CHANNEL        
C     AFTER BOTH CHANNELS ARE DONE.                                     
C                                                                       
      IF ( ISTRIP .NE. 0 .OR. IDONE .NE. 12 ) GO TO 800                 
C                                                                       
C    DO 529 I=1,NUMLNK
C           LNKNAM(I,1) = LNKNM2(1,I)                                   
      DO 529 II = 1, 6                                                  
      LNKADR(II,I) = LNKAD2(II,1,I)                                     
 529  CONTINUE                                                          
      R = RSCTS(1)                                                      
      RI = RIS(1)                                                       
      RC = RCSCTS(1)                                                    
      A = ASCTS(1)                                                      
      AI = AIS(1)                                                       
      V = V0RS(1)                                                       
      VI = V0IS(1)                                                      
      RSI = RSIS(1)                                                     
      ASI = ASIS(1)                                                     
      VSI = V0SIS(1)                                                    
      POWRL = POWRLS(1)                                                 
      POWIM = POWIMS(1)                                                 
C                                                                       
 800  RETURN                                                            
      END                                                               
      SUBROUTINE CONTRL ( IGOTO, JGOTO, IPRM1, IPRM2, IPRM3, PRM1 )     
C                                                                       
C  CONTROL ROUTINE FOR PTOLEMY                                          
C                                                                       
C          * * *  P T O L E M Y  * * *                                  
C                                                                       
C     SOPHISTICATED PROGRAMS CONTAIN SUBTLE ERRORS.                     
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C     THE ARGUMENTS ARE:                                                
C                                                                       
C     IGOTO: SET BY CONTRL BEFORE RETURNING, TO DETERMINE THE NEXT STEP.
C        = 0 AFTER RETURN, TO STOP.                                     
C        = 1 AFTER ; AFTER PROJECTILE OR TARGET, TO CALL BOUND.         
C        = 2 AFTER ; AFTER FIT OR FITELASTIC, TO CAL FITEL & FITEL2.    
C        = 3 AFTER CALLTSO, TO CALL SUBROUTINE TSO.                     
C        = 4 NOT USED (COMES RIGHT BACK).                               
C        = 5 AFTER ; AFTER INCOMING OR OUTGOING, TO CALL WAVSET.        
C        = 6 AFTER ; AFTER GRIDSETUP, TO CALL PRBPRT, GETSCT,           
C              GRDSET OR INGRST, AND ANGSET.                            
C        = 7 AFTER ; AFTER RADIALIN, TO CALL INELDC, INRDIN, OR COUPLE2.

C        = 8 AFTER ; AFTER LINTERPO, TO CALL LINTER.                    
C        = 9 AFTER ; AFTER CROSSSEC, TO CALL XSECTN.                    
C        = 10 AFTER ; AFTER DOTEMP1, TO CALL TEMP1.                     
C        = 11 AFTER ; AFTER DOTEMP2, TO CALL TEMP2.                     
C        = 12 AFTER ; AFTER DOTEMP3, TO CALL TEMP3.                     
C        = 13 AFTER ; AFTER SCATTERING, TO CALL WAVEF.                  
C        = 14 AFTER ; AFTER ALL CHANNELS ARE SET UP:  DO THE WHOLE      
C           DWBA OR CC CALCULATION.                                     
C        = 15 AFTER ; AFTER CROSSSEC IF L INTERP. IS NOT DONE,          
C              TO CALL LINTERP AND XSECTN.                              
C                                                                       
C     JGOTO:  USED BY CONTRL TO TELL IT WHAT TO DO FIRST.               
C        = 1 TO GET THE NEXT KEYWORD.                                   
C        = 2 TO CHECK THE RETURN CODE (IPARM1) AFTER A CALCULATION      
C              STEP.                                                    
C        = 3 TO INITIALIZE THINGS ON THE FIRST CALL.                    
C        = 4 AFTER A BOUND STATE OR SCATTERING CALCULATION, TO          
C              UPDATE IDONE AND GET READY FOR THE NEXT CHANNEL.         
C        = 5 AFTER USEHS, TO READ THE SAVED COMMON BLOCKS.              
C        = 6 AFTER A PASS OF A MULTIPASS CALCULATION, TO PREPARE FOR    
C              CHANNEL CHANGES.                                         
C                                                                       
C     IPRM1 = 0 IF AN ERROR HAS OCCURRED IN THE PREVIOUS STEP.          
C                                                                       
C     IPRM2 = NALLOC TO B.S. POTENTIAL, SET BY BOUND.                   
C                                                                       
C     IPRM3 = NALLOC TO B.S. WAVE FUNCTION, SET BY BOUND.               
C                                                                       
C     PRM1 = THE PARAMETER PASSED TO SUBROUTINE TSO; NOT USED HERE.     
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C     1/18/75 - REARRANGED TO BE OVERLAYED - S. P.                      
C     1/24/75 - AMT, AMP IN AMU, ANGLES IN DEGREES INTERNALLY           
C     1/30/75 - CHANGE ASYMTOPIC BOUND STATE LIMIT; STORE J1, J2;       
C               PRINT, NINTS, TEMPORARY  KEYWORDS ADDED - S.P. & MHM    
C     2/9/75 - CALL GRIDSET, DSIGMA, TEMP1, TEMP2, TEMP3                
C     2/17/75 - RENAME AND KEEP KEYWORDS.  OTHER LITTLE THINGS          
C     3/4/75 - MAPTYPE ADDED; CHECK RETURN CODES; OTHER LITTLE THINGS   
C     3/5/75 - MAPSUM, MAPDIF, NPSUM, NPDIF, NPPHI (REPLACES NPLEG)     
C     4/14/75 - MAJOR REWRITE, MANY KEYWORD NAMES CHANGED.              
C     5/6/75 - USE SETCHN, SETPOT;  NEW USE OF SEMICOLON                
C     5/17/75 - REACTION, HEADER, RESET KEYWORDS; MUCH MOVING.          
C     5/26/75 - NEW NUCONLY WORDS; VSI; UNDEFINE; BETTER ERROR MSGS.    
C     6/11/75 - SAVEHS/USEHS ADDED                                      
C     6/24/75 - ADD COPY; DUMP=NSDUMP, DUMPALL; TSO=CALLTSO             
C     6/27/75 - ADD STEPSPER; FIX NEXT RESETTING FOR STANDALONE         
C     7/19/75 - NRNLIMS - LIMITS IN FM.                                 
C     8/7/75  - FIT,DATA,ETC KEYWRDS ADDED                              
C     8/28/75 - LMAXMULT, LMINMULT, LBACK, SPFACP, SPFACT               
C     9/24/75 - ADD CHANNEL, MAXLEXTRAP;  REMOVE VCUTOFF                
C     9/30/75 - LMAXMULT BECOMES LMAXADD                                
C     10/1/75 - MORE FITTING STUFF                                      
C     10/19/75 - MORE FITTERS; ESQ PARAMETERS; PARAM INSTEAD OF TEMP    
C     11/6/75 - DERIVSTEP, MAXFUNCTIONS KEYWORDS; MORE FITTERS          
C     1/29/76 - FITMULTI, FITRATIO, FITMODE % NUMRANDO KEYWORDS         
C     4/30/76 - MODIFY INPUT TO PERMIT FOLDED COULOMB AND INCLUSION     
C               OF NUCLEAR CORE TERMS IN VEFF (MHM)                     
C     6/20/76 - SUMPOINTS KEYWORDS - S.P.                               
C     7/30/76 - KORFRE REMOVED.                                         
C     9/15/76 - EPOWERS, EINVERSES KEYWORDS ADDED                       
C     11/7/76 - SAVEMXCR, SAVEB KEYWORDS; NEW KEEP                      
C     12/26/76 - INELASTIC SCATTERING; ALIAI; ALLOCATE REWRITTEN; NEWPAG
C     1/25/77 - LABANGLE SWITCH                                         
C     2/5/77 - REALWAVE/COMPLEXWAVE ADDED; SAVEWAVE/NOSAVEWAVE REMOVED  
C     4/15/77 - ALMXMT; LMINSB; ALIASES TO FITINP                       
C     10/16/77 - POWERS OF WOODS SAXONS                                 
C     11/20/77 - BOUNDASYM, SCATASYM KEYWORDS ADDED - S.P.              
C     11/25/77 - LINKULES                                               
C     11/27/77 - GET - S.P.                                             
C     12/6/77 - DO NOT PRINT ALLOC STATS FOR TSO - S.P.                 
C     12/10/77 - AUF DEUTSCH]; FIX PRINTWAVE BUG - S.P.                 
C     1/18/78 - BIG DATA AREAS BROKEN APART FOR CDC - S.P.              
C     4/14/78 - PARAM6 - PARAM20 ADDED - S.P.                           
C     5/8/78 - SET NSPTSW; PROBLM IN /SWITCH/; SEPARATE LINTERP CALL    
C     12/13/78 - ADD TENSOR POTENTIALS - RPG                            
C     5/6/79 - MXCGP, MXCGT, PARITIES - S.P.                            
C     6/14/79 - ALLOW MULTIPASS CALCULATIONS, REMOVE LAND,              
C        STANDARD LABELS, CHARACTER TYPE, REWIND 1 BEFORT QUITTING - RPG
C     6/7/79 - DOCUMENT ARGUMENTS, FIX MULTIPASS STUFF - RPG            
C     7/2/79 - SAVEF KEYWORDS REPLACE SAVEB WORDS - S.P.                
C     7/22/79 - SMALL FIX - RPG                                         
C     7/24/79 - NEW DUMP KEYWORDS AND NSDUMP CALL - S.P.                
C     9/20/79 - UNDEFINE LX IN RETURN FROM MULTIPASS - RPG              
C     11/10/79 - FIX ERROR AT STMNTS 750, 760 - S.P.                    
C     12/12/79 - ADD SCRFILE KEYWORD (/SWITCH/) - RPG                   
C     12/19/79 - COUPLED CHANNELS; FIX DOTEMPS - S.P.                   
C     1/17/80 - BFACTORS SWITCH - S.P.                                  
C     2/22/80 - CONVRG SWITCH - S.P.                                    
C     3/15/80 - DUMP IS NOT THE SAME AS DUMPR8;                         
C               MERGE IN FOLLOWING VAX CHANGES FROM BOB - S.P.          
C     1/21/80 - CHARACTER*8 WORD; SPLIT OFF DATA FOR SWTNUM, SWTSET;    
C        CVX TO CVA - RPG                                               
C     2/5/80 - ADD "BLOCKSIZE", "TIMELIMIT" - RPG                       
C     2/19/80 - ADD "MAPPHI", "PHIMID", "GAMMAPHI" - RPG                
C     2/25/80 - USE MACRO FOR INPBUF - RPG                              
C     7/22/80 - REMOVE LOR DEFS WHICH WERE NEVER USED - S.P.            
C     9/16/80 - CCDUMP; L-EXTRAP SWITCHES - S.P.                        
C     10/8/80 - MEORD SWITCH ADDED - S.P.                               
C     6/28/81 - NFIRSTOF, BLOCKRELATIVE KEYWORDS - S.P.                 
C     7/16/81 - KFRMTP FOR FORMFACTOR - FORMDERI, FORMASIS - S.P.       
C     9/17/81 - LEBACK ADDED - S.P.                                     
C     10/27/81 - BETAP, BETAT, WRITEWAV, WRITEITE KEYWORDS - S.P.       
C     5/3/82 - SET MAXLF=0 AFTER CLEAR FOR LOG TABLE - S.P.             
C     6/26/82 - ADD RELATIVISTIC AND SAVESITER SWITCHES - S.P.          
C                                                                       
C                                                                       
C                                                                       
C                                                                       
C     IN THE FOLLOWING COMMON BLOCKS, VARIABLE NAMES OF THE FORM        
C       D$$$$N  OR  I$$$$N                                              
C     MARK SPACES THAT ARE NOLONGER IN USE AND MAY BE RECYCLED.         
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      COMMON /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
C                                                                       
C     THE FOLLOWING TWO WORDS IN /SWITCH/ CONTROL THE COURSE OF         
C     THE CALCULATION.                                                  
C                                                                       
C     PROBLM - SPECIFIES THE PROBLEM BEING SOLVED:                      
C                                                                       
C        5 (BOUNDSTATE) - STAND-ALONE BOUND STATE.                      
C        6 (SCATTERING) - STAND-ALONE ELASTIC SCATTERING.               
C       20 (DWBA, NZRDWBA) - TRANSFER BY DWBA.                          
C       21 (FIT, FITELASTIC) - ELASTIC SCATTERING FIT                   
C       22 (INELASTIC) - EXCITATION BY COLLECTIVE DWBA                  
C       23 (COUPLE2) - 2-STATE COUPLED CHANNELS                         
C                                                                       
C       IF PROBLM IS NOT EXPLICITLY SET BY ONE OF THE ABOVE KEYWORDS,   
C       IT IS SET AS FOLLOWS:                                           
C                                                                       
C         1)  IF NO DWBA SUBCHANNELS (PROJECTILE, INCOMING, ETC.)       
C           HAVE BEEN SPECIFIED, THE STAND-ALONE CALCULATION SUITABLE   
C           FOR THE SPECIFIED ENERGY IS DONE.  IN THIS CASE PROBLM      
C           IS LEFT UNDEFINED (0).                                      
C         2)  OTHERWISE PROBLM IS SET TO 20 OR 22 DEPENDING ON          
C           THE VALUE OF ISTRIP (THE MASS TRANSFER).                    
C                                                                       
C     NEXT - SPECIFIES THE STEP OF THE CALCULATION THAT IS BEING DONE:  
C                                                                       
C        1 (PROJECTILE) - PROJECTILE BOUND-STATE FOR TRANSFER           
C        2 (TARGET) - TARGET BOUND-STATE FOR TRANSFER                   
C        3 (INCOMING) - INCOMING SCATTERING FOR DWBA AND COUPLED        
C        4 (OUTGOING) - OUTGOING SCATTERING FOR DWBA AND COUPLED        
C       10 (GRIDSETUP) - DWBA GRID SETUP.                               
C       11 (RADIALINTEGRAL) - DWBA INTEGRALS; COUPLED CHANNELS.         
C       12 (LINTERPOLATION) - L-INTERPOLATIONS.                         
C       13 (CROSSSECTIONS) - CROSS SECTIONS; IF NOT PRECEEDED BY 12     
C           THEN BOTH 12 AND 13 ARE DONE.                               
C                                                                       
C     IF NEXT IS NOT DEFINED (0) WHEN A ; IS ENCOUNTERED, IT IS SET TO  
C     PROBLM.  IF THE RESULT IS THEN NON-ZERO, THE COMPLETE CALCULATION 
C     SO SPECIFIED IS THEN DONE.  IF THE RESULT IS STILL ZERO, THE      
C     DEFAULT CALCULATION AS OUTLINED UNDER PROBLM IS CHOOSEN AND       
C     IS THEN DONE.                                                     
C                                                                       
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
C                                                                       
C     SOME WORDS IN /INTRNL/                                            
C                                                                       
C     UNDEF, NOTDEF - THE THINGS TO COMPARE AGAINST TO DETERMIN IF      
C            SOMETHING IS NOT DEFINED.                                  
C     ICHANB, ICHANW - CHANNEL NUMBER FOR BOUND AND SCATTERING STATES   
C     IDONE - BITS THAT ARE TURNED ON AS THE CALCULATION PROGRESSES:    
C      (1)  31 - PROJECTILE BOUND STATE                                 
C      (2)  30 - TARGET BOUND STATE                                     
C      (4)  29 - INCOMING SCATTERING                                    
C      (8)  28 - OUTGOING SCATTERING                                    
C     (16)  27 - DWBA OR INELASTIC CALCULATION (OR PIECE THEREOF)       
C     (32)  26 - L INTERPOLATION                                        
C     ISTRIP - -1 = PICKUP SCATTERING                                   
C               0 = INELASTIC EXCITATION                                
C              +1 = STRIPPING SCATTERING                                
C     IHSAVE - 0 = NO SAVEHS/USEHS                                      
C              1 = USEHS                                                
C              2 = SAVEHS                                               
C     IEXCIT - 1 = PROJECTILE EXCITATION                                
C              2 = TARGET EXCITATION                                    
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                                                                       
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
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                                                                       
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
C                                                                       
C                                                                       
C                                                                       
      COMMON/ALLOCS/ALLOC(1)                                            
CDC      ALLOCLEVEL ALLOC                                               
      COMMON/LENGTH/LENG(1)                                             
      COMMON/LOCKT/KLOC(1)                                                 
      CHARACTER*8 NAMES                                                 
      COMMON /NAMCOM/ NAMES(1)                                          
C                                                                       
      LOGICAL NSPTSW                                                    
      COMMON/USAGE/IBASE, NWORDS, IMAX, INAME, IGOT, NLOC, IPEAK, NAMPEK
     *, NUMCOM, ICHEC, THENAM, IWASAT, NAMLC2, NSPTSW                   
	REAL*8 LF
      COMMON /LOGFAC/ MAXLF, LFBIAS, LF(1)                              
C                                                                       
      CHARACTER*8 KYWORD, WORD                                          
      CHARACTER*1 BLANK1                                                
      DATA BLANK1 / ' ' /                                               
C                                                                       
      LOGICAL VALSW                                                     
C                                                                       
C                                                                       
C     FOLLOWING ARE ALL THE DATA ENTERING KEYWORDS.                     
C     THEY ARE IN THE GROUPS  FLOAT, INTEGER, JVALUES, SWITCHES         
C                                                                       
C                                                                       
      DATA NUMFLT /153/                                                 
      CHARACTER*8 FLTWRD(153)                                           
      CHARACTER*8 FLT1(100), FLT2(53)                                   
      EQUIVALENCE ( FLT1(1), FLTWRD(1) ), ( FLT2(1), FLTWRD(101) )      
      DATA FLT1 / 'A','ACCURACY','AI','ANGLESTE','ANGLEMIN','ANGLEMAX',
     *'ASO', 'ASOI', 'ASYMPTOP', 'DELTAVK',  'DWCUTOFF', 'E', 'ECM', 
     *'ELAB', 'E*A',  'E*B', 'E*BIGA', 'E*BIGB', 'E*X', 'GAMMADIF',  
     *'GAMMASUM', 'TAU','TAUI','M','MA','MB','MBIGA','MBIGB','MX', 
     *'MXCA',  'MXCB', 'MXCBIGA','MXCBIGB','MXCX','MXCGA','MXCGB', 
     *'MXCGBIGA', 'MXCGBIGB', 'MXCGX', 'MP',  'MT', 'Q', 'R', 'R0', 
     *'RC',  'RC0', 'RI', 'RI0', 'RSO', 'RSO0',  'RSOI','RSOI0','SPAM',
     *'SPAMP','SPAMT','STEPSIZE','STEP1R','STEP1I','SUMMAX','SUMMID',
     *'SUMMIN', 'V', 'VI', 'VSO', 'VSOI',  'FITMULTI', 'WRITESTE',
     *'ASI', 'RSI', 'RSI0','VSI','MIDMULT','STEPSPER','R0E','RI0E', 
     *'AE', 'AIE', 'VE', 'VIE', 'FITACCUR',  'LMINMULT', 'SPFACP', 
     *'SPFACT', 'R0ESQ', 'RI0ESQ',  'AESQ', 'AIESQ', 'VESQ', 'VIESQ', 
     *'DERIVSTE','FITRATIO', 'RCP', 'RCT', 'RC0P', 'RC0T','SUMPOINT', 
     *'INELASAC', 'COULOMBM', 'LMAXMULT', 'E*P' /                       
      DATA FLT2 /'E*T', 'REALPOWE', 'IMAGPOWE', 'BOUNDASY','SCATASYM',
     *'VTR', 'VTRI','VTL','VTLI','VTPR','VTPRI','PARAM1','PARAM2',
     *'PARAM3', 'PARAM4', 'PARAM5',  'PARAM6', 'PARAM7', 'PARAM8', 
     *'PARAM9','PARAM10','PARAM11','PARAM12','PARAM13', 'PARAM14', 
     *'PARAM15','PARAM16','PARAM17','PARAM18','PARAM19','PARAM20',
     * 'RTR','RTRI','RTL','RTLI','RTPR','RTPRI','RTR0', 'RTRI0',
     * 'RTL0', 'RTLI0', 'RTPR0', 'RTPRI0','ATR','ATRI','ATL','ATLI',
     * 'ATPR', 'ATPRI',  'MXCGP', 'MXCGT', 'PHIMID', 'GAMMAPHI' /      
C                                                                       
      DATA NUMINT /54/                                                  
      CHARACTER*8 INTWRD(54)                                            
      DATA INTWRD /  'L', 'LMAX', 'LMIN', 'LOOKSTEP', 'LX',  'MAPSUM', 
     *'MAPDIF','MAXITER','NAITKEN','NBACK','NCOSINE', 'NODES','NPDIF',
     *'NPHIADD','NPPHI','NPSUM','PRINT','SIZE','ZA','ZB','ZBIGA', 
     *'ZBIGB', 'ZX', 'ZP', 'ZT',  'LSTEP', 'LBACK', 'MAXLEXTR', 
     *'LMAXADD','MAXFUNCT','REINITIA','FITMODE','NUMRANDO','VPOLYORD',
     *'NPCOULOM','MAXCOULI','LMINSUB','PARA', 'PARB', 'PARBIGA',
     *'PARBIGB','PARX','PARP','PART','PARITY','IPARAM1','IPARAM2', 
     *'IPARAM3','IPARAM4','IPARAM5','BLOCKSIZ','MAPPHI',
     *'NFIRSTOF', 'LEPSBACK' /                                               
C                                                                       
      DATA NUMJ /12/                                                    
      CHARACTER*8 JWRDS(12)                                             
      DATA JWRDS / 'J', 'JA', 'JB', 'JBIGA', 'JBIGB',  'JX', 'JP', 'SP',
     * 'ST',  'JPARAM1', 'JPARAM2', 'JPARAM3' /                         
C                                                                       
      DATA NUMSW /34/, NUMSWW /110/                                     
      CHARACTER*8 SWTWRD(110)                                           
      DATA SWTWRD /'SKIPASYM','DOASYMPT','CHECKASY','NOCHECKA','ECHO',
     *'NOECHO', 'ELASTIC', 'NOELASTI', 'FITE', 'FITV', 'USEPROJE',
     *'USETARGE','REALWAVE', 'COMPLEXW','TSO','BATCH','LINEAR',
     *'QUADRATI','NUCONLY','USECOULO','USESIMPC','USECORE','PROJECTI', 
     *'TARGET','INCOMING','OUTGOING','GRIDSETU','RADIALIN','LINTERPO', 
     *'CROSSSEC','DOTEMP1','DOTEMP2','DOTEMP3','POWELL65','ROCORD', 
     *'OCOPTR','LMGENV','DERIVCHE',  'CHECKDER', 'LMCHOL','MINIM', 
     *'QUAVER','DAVIDON','FITTER10','FITTER11','FITTER12',
     *'FITTER13','EPOWERS','EPOWER','EINVERSE','SAVEMXCR','NOSAVEMX',
     *'SAVEF','NOSAVEF','LABANGLE','CMANGLES','BOUNDSTA','SCATTERI', 
     *'NZRDWBA', 'DWBA', 'FITELAST', 'INELASTI', 'COUPLE2','CCINELAS',
     *'TRUEMASS','INTEGERM','FLOATNUM','R0DEFAUL','R0TARGET', 
     *'R0SUM','R0MTOT','ONEPASS','MULTIPAS','NEXTPASS','SW1ON', 
     *'SW1OFF','SW2ON','SW2OFF','SW3ON','SW3OFF','SCRFILE','NOSCRFIL',
     *'BFACTORS','NOBFACTO','BLOCKREL','RELATIVE','ABSOLUTE',
     *'WOODSSAX','LPOWER','LPOWER2','WKBEXTRA','LEXTRAP5','LEXTRAP6', 
     *'SUBBORN', 'NOSUBBOR','ME1STORD', 'ME2NDORD', 'FORMDERI', 
     *'FORMASIS',  'NOWRITEW', 'WRITEWAV', 'WRITEITE', 'WRITEELA', 
     *'WRTELAIT',  'GALILEO', 'FITZGERA','POTNONRE', 'POTRELAT',  
     *'NOSAVESI', 'SAVESITE' /                                                
      INTEGERSWTNUM(110)                                                
      DATASWTNUM/1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 1
     *0, 10, 10, 10, 11*11, 14*12, 13, 13, 13, 14, 14, 15, 15, 16, 16, 8
     **17, 3*18, 4*19, 3*20, 21, 21, 22, 22, 23, 23, 24, 24, 25, 25, 3*2
     *6, 6*27, 2*28, 2*29, 2*30, 5*31, 2*32, 2*33, 2*34/                
      INTEGERSWTSET(110)                                                
      DATASWTSET/1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 1, 2, 1, 0, 1, 0, 1, 0, 1
     *, 2, 0, 3, 1, 2, 3, 4, 10, 11, 12, 13, 30, 31, 32, 1, 2, 3, 4, 5, 
     *5, 6, 7, 8, 9, 10, 11, 12, 13, 0, 0, 1, 1, 0, 1, 0, 1, 0, 5, 6, 20
     *, 20, 21, 22, 23, 24, 0, 1, 2, 0, 1, 2, 3, 0, 1, 2, 1, 0, 1, 0, 1,
     * 0, 1, 0, 0, 1, 0, 2, 1, 1, 2, 3, 4, 5, 6, 0, 1, 0, 1, 0, 1, 0, 1,
     * 2, 11, 12, 0, 1, 0, 1, 0, 1/                                     
C                                                                       
C                                                                       
C     FOLLOWING ARE THE CONTROL KEYWORDS THAT REQUIRE IMMEDIATE         
C     ACTION (BESIDES JUST STORING A VALUE).                            
C                                                                       
      DATA NUMKEY /59/                                                  
      CHARACTER*8 KEYWRD(59)                                            
      DATA KEYWRD /'LISTKEYS','RETURN', 'RENAME', 'REACTION','HEADER', 
     *'PRINTFIT', 'KEEP', 'CLEAR', 'RESET', 'PRINTWAV',  'DUMPR8', 
     *'DUMPR4','NSCATALO','FREE','NUMRNUM','CALLTSO','BETA','UNDEFINE', 
     *'PARAMETE', 'KEYWORDS',  'DUMPI2', 'NSSTATUS', 'ALLOCATE', 
     *'BIMULT', 'NRNLIMS',  'WRITENS', 'BETACOUL', 'SAVEHS', 'USEHS', 
     *'DUMPALL','COPY','FIT','DATA','CHANNEL','NEWPAGE','BELX', 
     *'REALPOTE','IMAGPOTE','REALSOPO','IMAGSOPO','COULOMBP','WAVEFUNC',
     *'GET', 'REALTRPO','IMAGTRPO','REALTLPO','IMAGTLPO','REALTPRP', 
     *'IMAGTPRP', 'DUMPI4',  'DUMPHEX', 'CHANNELS', 'COUPLING', 
     *'TRANSITI', 'TIMELIMI',  'DUMP', 'CCDUMP', 'BETAP', 'BETAT' /       
C                                                                       
C     FOLLOWING ARE SYNONUMS - THEY ARE IN PAIRS OF                     
C     (INPUT WORD, INTERNAL WORD)                                       
C                                                                       
      DATA NUMALI /142/                                                 
      CHARACTER*8 ALIAI(142)                                            
      CHARACTER*8 ALI1(82), ALI2(60)                                    
      EQUIVALENCE ( ALI1(1), ALIAI(1) ), ( ALI2(1), ALIAI(83) )         
C                                                                       
      DATA ALI1 /  'W', 'VI',  'VR', 'V', 'RR0', 'R0', 'AR', 'A', 'RR', 
     *'R', 'END','RETURN','QUIT', 'RETURN', 'STOP', 'RETURN','NAMES', 
     *'NSCATALO','BE2', 'BELX', 'BE', 'BELX',  'BETANUCL', 'BETA', 
     *'LMINSUBT', 'LMINSUB', 'TITLE', 'HEADER',  'GENAUIGK', 'ACCURACY', 
     *'WINKELMA', 'ANGLEMAX',  'WINKELMI', 'ANGLEMIN', 'WINKELSC', 
     *'ANGLESTE','DWENDPUN','DWCUTOFF','PASSENGE','FITACCUR','PASSENVE',
     *'FITRATIO', 'LMAXHINZ', 'LMAXADD',  'LMAXVERM', 'LMAXMULT', 
     *'LMINVERM', 'LMINMULT',  'LMINABZI', 'LMINSUB','LSCHRITT','LSTEP', 
     *'KNOTEN', 'NODES',  'SCHRITTL','STEPSIZE','SCHRITTE','STEPSPER', 
     *'SCHREIBS', 'WRITESTE', 'ELASTISC', 'ELASTIC',  'EINGANG', 
     *'INCOMING','LABWINKE','LABANGLE','KERNEINZ','NUCONLY','AUSGANG',
     *'OUTGOING','WURFGESC','PROJECTI','REELLEWE','REALWAVE',  
     *'STREUUNG','SCATTERI','ZIELSCHE', 'TARGET','MITCOULO','USECOULO',
     *'MITWURFG', 'USEPROJE'  /                                       
      DATA ALI2 /'MITZIELS','USETARGE','MITKERNG','USECORE','ZUTEILEN', 
     *'ALLOCATE','KANAL','CHANNEL','BESTIMMU','DATA', 'ANPASSEN', 
     *'FIT','UEBERSCH','HEADER','REAKTION', 'REACTION','VERLASSE', 
     *'QUIT','NAMEN','NSCATALO','SCHLUESS', 'KEYWORDS', 'ENDE', 
     *'QUIT', 'PROJEKTI','PROJECTI','MITPROJE','USEPROJE','DRUCKEN', 
     *'PRINT','IMAGHOCH','IMAGPOWE','REELLEHO','REALPOWE','GEBUNDAS', 
     *'BOUNDASY','STEUASYM','SCATASYM', 'SUMMEPUN', 'SUMPOINT', 
     *'EINLAGER', 'SAVEHS', 'GEBRAUCH', 'USEHS',  'DUMP8', 'DUMPR8', 
     *'NSDUMP', 'DUMPR8', 'DUMPINTE', 'DUMPI4',  'DUMPOCTA', 'DUMPHEX',
     *'DUMPHEXA', 'DUMPHEX',  'DUMP4', 'DUMPR4', 'BETAPROJ', 'BETAP', 
     *'BETATARG', 'BETAT' /                                            
C                                                                       
C     JGOTO IS USED TO RESUME AFTER RETURNING TO MAIN TO GET            
C     SOMETHING DONE.                                                   
C                                                                       
      GO TO ( 10, 990, 5, 750, 550, 740 ), JGOTO                        
C                                                                       
C     INITIALIZE ON FIRST CALL                                          
C                                                                       
  5   CALL DEFALT ( NUMFLT, NUMINT, NUMJ, NUMSW, .FALSE. )              
      CALL NEWCD                                                        
C                                                                       
C                                                                       
C  SEARCH FOR NEXT KEY                                                  
C                                                                       
C     GET NEXT KEYWORD AND LOOK FOR IT IN THE VARIOUS TABLES            
C     OF WORDS.                                                         
C                                                                       
 10   CALL NXWORD( KYWORD, &925, &600, &925 )                           
C                                                                       
C                                                                       
 20   DO 29 I = 1, NUMFLT                                               
      IF ( FLTWRD(I) .NE. KYWORD ) GO TO 29                             
      CALL NXVAL( VAL, &910, &910, &910 )                               
      FLOATK(I) = VAL                                                    
      GO TO 10                                                          
 29   CONTINUE                                                          
C                                                                       
      DO 34 I = 1, NUMINT                                               
      IF ( INTWRD(I) .NE. KYWORD ) GO TO 34                             
      CALL NXINT ( IVAL, &915, &915, &915 )                             
      INTGER(I) = IVAL                                                  
      GO TO 10                                                          
 34   CONTINUE                                                          
C                                                                       
      DO 39 I = 1, NUMJ                                                 
      IF ( JWRDS(I) .NE. KYWORD ) GO TO 39                              
      CALL NXHINT ( IVAL, &920, &920, &920)                             
      JBLOCK(I) = IVAL                                                  
      GO TO 10                                                          
 39   CONTINUE                                                          
C                                                                       
      DO 44 I = 1, NUMSWW                                               
      IF ( SWTWRD(I) .NE. KYWORD ) GO TO 44                             
      SWITCH(SWTNUM(I)) = SWTSET(I)                                     
      GO TO 10                                                          
 44   CONTINUE                                                          
C                                                                       
C     IF IT IS A CONTROL KEYWORD, DO IT NOW                             
C                                                                       
      NSPTSW = MOD( IPRINT/100 000, 10 ) .GT. 1                         
C                                                                       
      DO 69 I = 1, NUMKEY                                               
      IF ( KEYWRD(I) .NE. KYWORD ) GO TO 69                             
      GO TO (  110, 140, 270, 500, 510,  150, 290, 280, 130, 160,  236, 
     *231, 200, 260, 420,  350, 360, 480, 380, 120,  233, 210, 250, 400,
     * 430,  300, 360, 530, 540, 220,  320, 492, 496, 505, 470,  360, 56
     *0, 560, 560, 560,  560, 560, 295, 560, 560,  560, 560, 560, 560, 2
     *32,  234, 497, 498, 499, 570,  230, 340, 360, 360  ), I           
 69   CONTINUE                                                          
C                                                                       
C     IS THE WORD A SYNONUM.  IF SO START THE WHOLE SEARCH OVER AGAIN.  
C                                                                       
      DO 89 I = 1, NUMALI, 2                                            
      IF ( ALIAI(I) .NE. KYWORD ) GO TO 89                              
      KYWORD = ALIAI(I+1)                                               
      GO TO 20                                                          
 89   CONTINUE                                                          
C                                                                       
      WRITE(6,93) KYWORD                                                  
 93   FORMAT ( '0**** MISSPELLED KEYWORD: ', A8 )                       
      IF ( ITSO .EQ. 1 ) GO TO 980                                      
      ASSIGN 955 TO JUMP                                                
      VALSW = .FALSE.                                                   
      GO TO 125                                                         
C                                                                       
C                                                                       
C     LISTKEYS  (KEYWORD LIST WITHOUT VALUES)                           
C                                                                       
 110  VALSW = .FALSE.                                                   
      ASSIGN 10 TO JUMP                                                 
      GO TO 125                                                         
C                                                                       
C     KEYWORDS    (LIST WORDS AND VALUES)                               
C                                                                       
 120  VALSW = .TRUE.                                                    
      ASSIGN 10 TO JUMP                                                 
 125  CALL LSTKEY ( VALSW, NUMFLT, FLTWRD, NUMINT, INTWRD,  NUMJ, JWRDS,
     * NUMSWW, SWTWRD, SWTNUM, SWTSET,  NUMKEY, KEYWRD, NUMALI, ALIAI ) 
C
C     VAX PATCH 9/30/86 J BEENE ORNL
C
C 125  CALL LSTKEY ( VALSW, NUMFLT, %REF(FLTWRD),
C     *              NUMINT, %REF(INTWRD), NUMJ, %REF(JWRDS),
C     *              NUMSWW, %REF(SWTWRD), SWTNUM, %REF(SWTSET),
C     *              NUMKEY, %REF(KEYWRD), NUMALI, %REF(ALIAI) )
C
C     END VAX PATCH
C
      GO TO JUMP, ( 10, 955 )                                           
C                                                                       
C     RESET - RESET KEYWORDS AND ALLOCATOR                              
C                                                                       
 130  CALL DEFALT ( NUMFLT, NUMINT, NUMJ, NUMSW, .TRUE. )               
      GO TO 280                                                         
C                                                                       
C     RETURN                                                            
C                                                                       
 140  KEYRET=1                                                          
      IGOTO = 0                                                         
      IF ( IHSAVE .GT. 0 ) REWIND 1                                     
      IF ( ITSO .EQ. 1 ) RETURN                                         
      GO TO 215                                                         
C                                                                       
C     PRINTFIT                                                          
C                                                                       
 150  WRITE(6,153) E, V                                                  
 153  FORMAT ( ' ENERGY =', G16.7, 5X, 'V =', G16.7 )                   
      GO TO 10                                                          
C                                                                       
C     PRINTWAVE                                                         
C                                                                       
 160  WRITE(6, 163)                                                     
 163  FORMAT('    STEP       R          POT          WAVEFUNCTION')     
      IF ( WRITES .EQ. UNDEF ) GO TO 175                                
      IF ( IPOT .EQ. 0 ) GO TO 170                                      
      NWRITE = WRITES/STEPSZ + .5                                       
      IF ( NWRITE .LT. 1 ) NWRITE = 1                                   
      NSTEPS = BNDASY/STEPSZ + 1.5                                      
      IF ( ASYMPT .NE. UNDEF ) NSTEPS = ASYMPT/STEPSZ + 1.5             
      DO 169 III=1,NSTEPS,NWRITE                                        
      RRR=(III-1)*STEPSZ                                                
      WRITE(6,168)III,RRR,ALLOC(KLOC(IPOT)+III-1),ALLOC(KLOC(IWFN)+III-
     *1)                                                                
168   FORMAT(' ',I6,F12.5, 2G15.5 )                                     
 169  CONTINUE                                                          
      GO TO 10                                                          
 170  WRITE(6,173)
 173  FORMAT ( '0**** PRINTWAVE CAN BE USED ONLY AFTER BOUNDSTATE' )    
      GO TO 10                                                          
 175  WRITE(6, 178)                                                     
 178  FORMAT('0**** CANNOT---- WRITESTEP MUST BE SET NON-ZERO ')        
      GO TO 10                                                          
C                                                                       
C     NSCATALOG                                                         
C                                                                       
 200  IF ( ICNTT .NE. 0 ) CALL NSCAT(IDUM)                              
      GO TO 10                                                          
C                                                                       
C     NSSTATUS                                                          
C                                                                       
 210  KEYRET = 0                                                        
 215  IF ( ICNTT .NE. 0 ) CALL NSSTAT (IDUM)                            
      IF(KEYRET .NE. 1 ) GO TO 10                                       
      RETURN                                                            
C                                                                       
C     DUMPALL                                                           
C                                                                       
 220  CALL NSDUMP ( 0, 1 )                                              
      GO TO 10                                                          
C                                                                       
C     DUMPXX <NAME OR NUMBER>                                           
C       WHERE XX IS ONE OF  8, R8, 4, R4, I4, I2, HEX, HEXADECIMAL,     
C          OCTAL, INTEGER OR UNSPECIFIED.                               
C          NSDUMP IS ALSO THE SAME AS DUMP.                             
C                                                                       
C                                                                       
 230  I = 1                                                             
      GO TO 240                                                         
 231  I = 2                                                             
      GO TO 240                                                         
 232  I = 3                                                             
      GO TO 240                                                         
 233  I = 4                                                             
      GO TO 240                                                         
 234  I = 5                                                             
      GO TO 240                                                         
 236  I = 6                                                             
C                                                                       
 240  CALL GETNUM( IDUM, &980 )                                         
      CALL NSDUMP ( IDUM, I )                                           
      GO TO 10                                                          
C                                                                       
C     ALLOCATE <NAME> <COMPLETE LIST OF VALUES>                         
C                                                                       
 250  CALL NXWORD ( WORD, &930, &930, &930 )                            
      IF ( ICNTT .EQ. 0 ) CALL ISTART( ISIZE )                          
      ICNTT = 1                                                         
      CALL DEFINE ( WORD, NUM1, NUM2 )                                  
      WRITE(6,253) NUM1, WORD                                             
 253  FORMAT ( I8, ' NUMBERS READ TO DEFINE OBJECT ', A8 )              
      IF ( NUM1 .GT. NUM2 ) GO TO 950                                   
      GO TO 10                                                          
C                                                                       
C     FREE <NAME OR NUMBER>                                             
C                                                                       
 260  CALL GETNUM ( NUM1, &980 )                                        
      KLOC(NUM1)=-KLOC(NUM1)                                              
      GO TO 10                                                          
C                                                                       
C     RENAME  <NAME OR NUMBER>  <NEW NAME>                              
C                                                                       
  270 CALL GETNUM ( NUM1, &950 )                                        
      CALL NXWORD ( WORD, &930, &930, &930 )                            
      NAMES(NUM1) = WORD                                                
      GO TO 10                                                          
C                                                                       
C     CLEAR                                                             
C                                                                       
 280  IF ( ICNTT .NE. 0 ) CALL ICLEAR(IDUM)                             
      MAXLF = 0                                                         
      GO TO 10                                                          
C                                                                       
C     KEEP  <NAME>  <MEMBER NAME>                                       
C                                                                       
 290  CALL KEEPIT                                                       
CDC 290  PRINT 293                                                      
CDC 293  FORMAT ( '0**** SPEAKEASY KEEP NOT AVAILABLE IN CDC',          
CDC     1  ' VERSION -- USE WRITENS.' )                                 
CDC      GO TO 950                                                      
      GO TO 10                                                          
C                                                                       
C     GET  <PTOLEMY NAME>   <MEMBER NAME>                               
C                                                                       
 295  IF ( ICNTT .EQ. 0 ) CALL ISTART ( ISIZE )                         
      ICNTT = 1                                                         
      CALL GETIT ( IRET )                                               
      IF ( IRET ) 950, 950, 10                                          
CDC      PRINT 298                                                      
CDC 298  FORMAT ( '0**** SPEAKEASY GET NOT AVAILABLE IN CDC VERSION.',  
CDC     1  ' -- USE ALLOCATE.' )                                        
CDC      GO TO 950                                                      
C                                                                       
C     WRITENS <NAME OR NUM>                                             
C     WRITES TO FILE 15                                                 
C                                                                       
 300  CALL GETNUM ( ISEND, &980 )                                       
      WRITE(6, 303)ISEND                                                
 303  FORMAT(' NUMBERED STORAGE OBJECT ',I3,' WRITTEN TO FT15 WITH',  ' 
     *4G17.8 FORMAT')                                                   
      LLL=LENG(ISEND)                                                   
      LOCC=KLOC(ISEND)                                                   
      IF(LLL.GT.10000.OR.LLL.LE.0)GO TO 310                             
      WRITE(15, 308)(ALLOC(LOCC+III-1),III=1,LLL)                       
 308  FORMAT(' ',4G17.8)                                                
      GO TO 10                                                          
 310  WRITE(6, 313)                                                     
 313  FORMAT('  NUMBERED STORAGE OBJECT IS LONGER THAN 10000. GIVE UP') 
      GO TO 10                                                          
C                                                                       
C     COPY  <NAME1 OR NUM1>  <NAME2>                                    
C                                                                       
 320  CALL GETNUM ( NUM1, &900 )                                        
      INEED = LENG(NUM1)                                                
      CALL NXWORD ( WORD, &900, &900, &900 )                            
C     IS THE "TO" AREA ALREADY DEFINED                                  
      NUM2 = NAMLOC( WORD )                                             
      IF ( NUM2 .EQ. 0 ) GO TO 325                                      
C     YES, IS IT THE CORRECT SIZE                                       
      LLL = LENG(NUM2)                                                  
      IF ( INEED .EQ. LLL ) GO TO 326                                   
C     NO, FREE AND MAKE A NEW ONE                                       
      WRITE(6,323) WORD, LLL, INEED                                       
 323  FORMAT ( ' WARNING:  LENGTH OF ', A8, ' IS PRESENTLY', I6,  ' BUT 
     *COPY IS CHANGING IT TO', I6 )                                     
      KLOC(NUM2) = -KLOC(NUM2)                                            
 325  NUM2 = NALLOC( INEED, WORD )                                      
 326  DO 329 I = 1, INEED                                               
      ALLOC(KLOC(NUM2)-1+I) = ALLOC(KLOC(NUM1)-1+I)                       
 329  CONTINUE                                                          
      GO TO 10                                                          
C                                                                       
C     CCDUMP                                                            
C                                                                       
 340  CALL CCDUMP                                                       
      GO TO 10                                                          
C                                                                       
C     CALLTSO  KEYWORD ENTERED                                          
C                                                                       
 350  IGOTO = 3                                                         
      JGOTO = 1                                                         
      RETURN                                                            
C                                                                       
C     DEFINE A KEYWORD THAT HAS A VARIABLE NUMBER OF VALUES.            
C     THE VALUES ARE STORED IN THE ALOCATOR WITH THE KEYWORD NAME.      
C                                                                       
C     PRESENT CASES ARE BETA, BETAP, BETAT,  BETACOULOMB & BELX         
C                                                                       
 360  WORD = KYWORD                                                     
      IF ( ICNTT .EQ. 0 ) CALL ISTART( ISIZE )                          
      ICNTT = 1                                                         
      CALL DEFINE ( WORD, NUM1, NUM2 )                                  
      IF ( NUM1 .GT. NUM2 ) GO TO 950                                   
      GO TO 10                                                          
C                                                                       
C     PARAMETERSET KEYWORD IS USED TO INITIALIZE PARAMETER PACKAGES     
C                                                                       
 380  CALL PARAM ( IGOTO )                                              
      IF (IGOTO) 10, 900, 10                                            
C                                                                       
C     BIMULT <NAME OR NUM>  <NAME OR NUM>                               
C     OVERLAP OF TWO WAVEFUNCTIONS                                      
C                                                                       
  400 CALL GETNUM ( NUM1, &980 )                                        
      CALL GETNUM ( NUM2, &980 )                                        
      INEED=LENG(NUM1)                                                  
      ITWO = LENG(NUM2)                                                 
      IF ( INEED .NE. ITWO ) WRITE(6,403) INEED, ITWO                    
 403  FORMAT ( '0*** WARNING: LENGTHS NOT EQUAL, THEY ARE',  2I8, '.  TH
     *E SHORTER WILL BE USED.' )                                        
      INEED = MIN0( INEED, ITWO )                                       
      IALL=IALLOC(INEED)                                                
      DO 409 II=1,INEED                                                 
 409  ALLOC(KLOC(IALL)+II-1)=ALLOC(KLOC(NUM1)+II-1)*
     & ALLOC(KLOC(NUM2)+II-1) 
      WRITE(6, 413)INEED,NUM1,NUM2,IALL                                 
 413  FORMAT(' HAVE MULTIPLIED TWO ',I5,' ELEMENT ARRAYS ',I3,' AND',  I
     *3,' AND PUT THE RESULT IN ',I4)                                   
      GO TO 10                                                          
C                                                                       
C     NUMRNUM <NAME OR NUM>  <POWER>  <NAME OR NUM>                     
C     MATRIX ELEMENT OF A POWER OF R                                    
C                                                                       
 420  CALL GETNUM ( NUM1, &980 )                                        
      CALL NXINT(IARE,&900,&900,&900)                                   
      CALL GETNUM ( NUM2, &980 )                                        
      ISTP1 = 1                                                         
      INEED = LENG(NUM1)                                                
      ITWO = LENG(NUM2)                                                 
      IF ( INEED .NE. ITWO ) WRITE(6,403) INEED, ITWO                     
      ISTP2 = MIN0( INEED, ITWO )                                       
      GO TO 435                                                         
C                                                                       
C      NRNLIMS <NAME OR NUM> <POWER> <NAME OR NUM> <START INDEX>        
C                <END INDEX>                                            
C     PARTIAL MATRIX ELEMENT OF R**N                                    
C                                                                       
 430  CALL GETNUM ( NUM1, &980 )                                        
      CALL NXINT(IARE,&900,&900,&900)                                   
      CALL GETNUM ( NUM2, &980 )                                        
      CALL NXVAL( TEMP, &900, &900, &900)                               
      ISTP1 = TEMP/STEPSZ + 1.5                                         
      CALL NXVAL( TEMP, &900, &900, &900)                               
      ISTP2 = TEMP/STEPSZ + 1.5                                         
 435  WRITE(6, 438)NUM1,NUM2,IARE,ISTP1,ISTP2                           
 438  FORMAT(' AM CALCULATING ME BETWEEN OBJECTS',I3,' AND',I3,' OF R**'
     * ,I1,' FROM STEPS',I5,' TO ',I5)                                  
      AME=0.0D0                                                         
      LLLL = MIN0( LENG(NUM1), LENG(NUM2) )                             
      IF ( LLLL .GE. ISTP2 ) GO TO 445                                  
      TEMP = STEPSZ*(LLLL-1)                                            
      WRITE(6,443) TEMP                                                  
 443  FORMAT ( '0**** WARNING:  OBJECTS EXTEND ONLY TO R =', F10.2,  ' F
     *MS; WE WILL STOP AT END OF OBJECTS.' )                            
      ISTP2 = LLLL                                                      
 445  DO 449 II=ISTP1,ISTP2                                             
      RRR=(II-1)*STEPSZ                                                 
      TEMP = 1                                                          
      IF ( IARE .NE. 0 ) TEMP = RRR**IARE                               
      AME=AME+TEMP*STEPSZ*ALLOC(KLOC(NUM1)+II-1)*ALLOC(KLOC(NUM2)+II-1)
 449  CONTINUE                                                          
      WRITE(6, 453)AME                                                  
 453  FORMAT(/'        MATRIX ELEMENT =',E14.5/)                        
      GO TO 10                                                          
C                                                                       
C     NEWPAGE                                                           
C                                                                       
 470  WRITE(6,473)
 473  FORMAT ( '1' )                                                    
      GO TO 10                                                          
C                                                                       
C     UNDEFINE  < DATA KEYWORD >                                        
C                                                                       
 480  CALL NXWORD ( WORD, &900, &900, &900 )                            
      DO 482 I = 1, NUMFLT                                              
      IF ( FLTWRD(I) .NE. WORD ) GO TO 482                              
      FLOATK(I) = UNDEF                                                  
      GO TO 10                                                          
 482  CONTINUE                                                          
      DO 484 I = 1, NUMINT                                              
      IF ( INTWRD(I) .NE. WORD ) GO TO 484                              
      INTGER(I) = NOTDEF                                                
      GO TO 10                                                          
 484  CONTINUE                                                          
      DO 486 I = 1, NUMJ                                                
      IF ( JWRDS(I) .NE. WORD ) GO TO 486                               
      JBLOCK(I) = NOTDEF                                                
      GO TO 10                                                          
 486  CONTINUE                                                          
      WRITE(6,488) WORD                                                   
 488  FORMAT ( '0**** ', A8, ' IS NOT A DATA-DEFINING KEYWORD.' )       
      GO TO 950                                                         
C                                                                       
C   FIT BEING SPECIFIED--- READ INPUT                                   
C                                                                       
 492  IF ( ICNTT .EQ. 0 ) CALL ISTART ( ISIZE )                         
      ICNTT = 1                                                         
      CALL FITINP(IRET, NUMFLT, FLTWRD, NUMALI, ALIAI )                 
      PROBLM = 21                                                       
      GO TO 535                                                         
C                                                                       
C     DATA ( ... )  READS IN DATA FOR FITTER                            
C                                                                       
 496  IF ( ICNTT .EQ. 0 ) CALL ISTART ( ISIZE )                         
      ICNTT = 1                                                         
      CALL DATAIN(IRET)                                                 
      GO TO 535                                                         
C                                                                       
C     CHANNELS (...)  DEFINES CHANNS FOR COUPLED CHAN                   
C                                                                       
497   IF(ICNTT.EQ.0)CALL ISTART(ISIZE)                                  
      ICNTT=1                                                           
      CALL CCHAN(IRET)                                                  
      GO TO 535                                                         
C                                                                       
C     COUPLING (...)  DEFINES THE COUPLING SCHEME AND SETS              
C                     THE CCINELAS SWITCH                               
C                                                                       
498   IF(ICNTT.EQ.0)CALL ISTART(ISIZE)                                  
      ICNTT=1                                                           
      CALL CCOUP(IRET)                                                  
      PROBLM = 24                                                       
      GO TO 535                                                         
C                                                                       
C     TRANSITIONS (...)  DEFINES THE TRANSITIONS TO USE              
C                                                                       
499   IF(ICNTT.EQ.0)CALL ISTART(ISIZE)                                  
      ICNTT=1                                                           
      CALL CTRAN(IRET)                                                  
      GO TO 535                                                         
C                                                                       
C     REACTION  208PB(16O, N15)BI209(1/2- 3.23)  TYPE INPUT             
C                                                                       
 500  CALL REACTN( IRET )                                               
      GO TO 535                                                         
C                                                                       
C     CHANNEL   P + 208PB = 209BI(7/2- .9)                              
C                                                                       
 505  CALL CHANEL ( IRET )                                              
      GO TO 535                                                         
C                                                                       
C     HEADER < REST OF LINE IS HEADER >                                 
C                                                                       
 510  DO 514 I = 1, 65                                                  
 514  HEADER(I) = BLANK1                                                
      DO 519 I = INCH, NOCH                                             
      IF ( IBUF(I) .NE. BLANK1 ) GO TO 520                              
 519  CONTINUE                                                          
      GO TO 528                                                         
 520  NUM2 = MIN0( NOCH, I+64 )                                         
      II = 0                                                            
      DO 524 INCH = I, NUM2                                             
      IF ( IBUF(INCH) .NE. BLANK1 ) II = INCH                           
 524  CONTINUE                                                          
C                                                                       
C     RIGHT JUSTIFY HEADER FOR PRINTING ON RIGHT SIDE OF PAGE           
C                                                                       
      DO 526 INCH = I, II                                               
      HEADER(65-II+INCH) = IBUF(INCH)                                   
 526  CONTINUE                                                          
 528  INCH = NOCH + 1                                                   
      GO TO 10                                                          
C                                                                       
C     SAVEHS                                                            
C                                                                       
 530  CALL SAVEHS( IRET )                                               
 535  IF ( IRET ) 10, 950, 10                                           
C                                                                       
C     USEHS                                                             
C                                                                       
 540  IRET = 1                                                          
 545  CALL USEHS ( NUMFLT, FLOATK, NUMINT, INTGER, NUMJ, JBLOCK, NUMSW, 
     *SWITCH, IRET )                                                    
      IF ( IRET ) 10, 950, 547                                          
C                                                                       
C     ARE WE STILL PROCESSING BOUND STATE                               
C                                                                       
 547  JGOTO = 5                                                         
      IF ( NEXT .LE. 2 ) GO TO 720                                      
      NEXT = 0                                                          
C     INDICATE BOTH BOUND STATES DONE                                   
      IDONE = 3                                                         
      IF ( IBSPAS .GT. 1 ) IDONE = 15                                   
      GO TO 10                                                          
C                                                                       
C     DONE WITH A READIN BOUND STATE; GET NEXT SET OF COMMON BLOCKS     
C                                                                       
 550  IRET = 2                                                          
      GO TO 545                                                         
C                                                                       
C     REALPOTEN <NAME>  ,  IMAGPOTEN <NAME>   , ETC.                    
C                                                                       
 560  CALL GETLNK ( KYWORD, IRET )                                      
      IF ( IRET ) 950, 950, 10                                          
C                                                                       
C     TIMELIMIT (VAX/VMS ONLY)                                          
C                                                                       
 570  CALL NXVAL( TEMP, &900, &900, &900 )                              
CVMS      CALL TLIMIT( TEMP )                                               
      PRINT 573                                                      
 573  FORMAT ( '**** TIMELIMIT IS NOT IN THIS VERSION.  IGNORED.' ) 
      GO TO 10                                                          
C                                                                       
C     ; ENCOUNTERED.  DO A STAGE OF THE CALCULATION                     
C                                                                       
 600  NSPTSW = MOD( IPRINT/100 000, 10 ) .GT. 0                         
      IF(ICNTT.EQ.0)CALL ISTART(ISIZE)                                  
      ICNTT=1                                                           
C                                                                       
C  NUMBERED STORAGE INITIALIZED                                         
C  NOW ON OUR WAY                                                       
C                                                                       
C     NOW DETERMINE WHAT TO DO FOR THE ;                                
C                                                                       
      IF ( NEXT .EQ. 0 ) NEXT = PROBLM                                  
      IF ( NEXT .NE. 0 ) GO TO 700                                      
C                                                                       
C     HE DIDN'T SPECIFY; EITHER FINISH A DWBA OR DO A STAND ALONE       
C     CHANNEL.                                                          
C                                                                       
      IF ( IDONE .GT. 0 ) GO TO 650                                     
C                                                                       
C     IT IS STAND ALONE                                                 
C                                                                       
      IF ( E .NE. UNDEF ) GO TO 630                                     
      IF ( ELAB .NE. UNDEF .OR. ECM .NE. UNDEF ) GO TO 635              
      WRITE(6,623)
 623  FORMAT ( '0**** E OR ELAB OR ECM MUST BE SPECIFIED.' )            
      GO TO 950                                                         
 630  NEXT = 5                                                          
      IF ( E .LT. 0 ) GO TO 700                                         
 635  NEXT = 6                                                          
      GO TO 700                                                         
C                                                                       
C     ASSUME (FOR THE MOMENT) THAT ALL 2-BODY CHANNELS ARE              
C     DEFINED AND START A TRANSFER OR INELASTIC SCATTERING CALCULATION  
C                                                                       
 650  NEXT = 20                                                         
      IF ( ISTRIP .EQ. 0 ) NEXT = 22                                    
      PROBLM = NEXT                                                     
C                                                                       
C     NEXT SAYS WHAT TO DO NEXT                                         
C                                                                       
 700  IF ( NEXT .GE. 10 ) GO TO 770                                     
C                                                                       
C     INITIALIZE A CHANNEL AND ITS POTENTIAL                            
C                                                                       
      CALL SETCHN ( NEXT, IRET )                                        
      IF ( IRET .EQ. 0 ) GO TO 995                                      
      CALL SETPOT ( IRET )                                              
      IF ( IRET .EQ. 0 ) GO TO 995                                      
C                                                                       
C     NOW DO BOUND STATE OR SCATTERING.  UPON RETURN CLEAR MANY         
C     DEFINITIONS                                                       
C                                                                       
      JGOTO = 4                                                         
 720  IGOTO = 1                                                         
      GO TO ( 722, 724, 726, 728, 730, 732, 900, 736 ), NEXT            
C     PROJECTILE                                                        
 722  ICHANB = 1                                                        
      RETURN                                                            
C     TARGET                                                            
 724  ICHANB = 2                                                        
      RETURN                                                            
C     INCOMING                                                          
 726  ICHANW = 1                                                        
      IGOTO = 5                                                         
      RETURN                                                            
C     OUTGOING                                                          
 728  ICHANW = 2                                                        
      IGOTO = 5                                                         
      RETURN                                                            
 730  ICHANB = ICHANB + 1                                               
      RETURN                                                            
 732  ICHANW = ICHANW + 1                                               
      IGOTO = 13                                                        
      RETURN                                                            
C                                                                       
C********   THIS METHOD OF GETTING TO FITTER NOT USED                   
C                                                                       
736   ICHANW=1                                                          
      IGOTO=2                                                           
      RETURN                                                            
C                                                                       
C     WE HAVE RETURNED FROM A PASS OF A MULTIPASS CALCULATION.          
C     PREPARE FOR NEW BOUND STATE PARAMETERS.                           
C                                                                       
 740  NEXT = 0                                                          
      IDONE = 31                                                        
      IBSPAS = 2                                                        
      LX = NOTDEF                                                       
      IRET = 3                                                          
      IF ( IHSAVE .EQ. 2 ) GO TO 545                                    
      GO TO 760                                                         
C                                                                       
C     WE HAVE RETURNED FROM A BOUND STATE OR SCATTERING STATE           
C                                                                       
 750  IRET = 1                                                          
      IF ( IPRM1 .EQ. 0 ) GO TO 760                                     
      IF ( NEXT .LE. 4 ) IDONE = IOR(IDONE,2**(NEXT-1))                 
      IF ( E .GT. 0 ) GO TO 760                                         
      IPOT = IPRM2                                                      
      IWFN = IPRM3                                                      
      IF ( IHSAVE .EQ. 1 ) CALL SAVECM ( NUMFLT,FLOATK,NUMINT,INTGER, 
     *NUMJ, JBLOCK, NUMSW, SWITCH, IRET )                               
 760  CALL CLRCHN( NEXT )                                               
      IF ( IPRM1 .EQ. 0 ) GO TO 995                                     
      IF ( IRET .EQ. 0 ) GO TO 950                                      
 765  NEXT = 0                                                          
      GO TO 10                                                          
C                                                                       
C     WE ARE NOW DOING THINGS SUBSEQUENT TO THE CHANNEL INPUT           
C                                                                       
 770  JGOTO = 2                                                         
      IF ( NEXT .EQ. 21 ) GO TO 780                                     
      IF ( NEXT .LT. 30 ) GO TO 800                                     
C                                                                       
C     THIS IS A DOTEMP CALL                                             
C                                                                       
      IGOTO = NEXT - 20                                                 
      RETURN                                                            
C                                                                       
C     START ELASTIC SCATTERING FIT                                      
C                                                                       
 780  IGOTO = 2                                                         
      JGOTO = 4                                                         
      RETURN                                                            
C                                                                       
C     CARRY ON WITH THE DWBA OR C.C. IF ALL CHANNELS WERE DEFINED.      
C                                                                       
 800  IF ( ISTRIP .EQ. 0 ) GO TO 805                                    
      IF ( PROBLM .EQ. 0 ) PROBLM = 20                                  
      IF ( IBSPAS .GT. 0 ) JGOTO = 6                                    
      IF ( MOD(IDONE, 16) .EQ. 15 ) GO TO 810                           
      WRITE(6,803)
 803  FORMAT ( '0**** PROJECTILE, TARGET, INCOMING AND OUTGOING',  ' CHA
     *NNELS MUST ALL BE DEFINED' )                                      
      GO TO 950                                                         
 805  IF ( PROBLM .EQ. 0 ) PROBLM = 22                                  
      IF ( MOD(IDONE/4, 4) .EQ. 3 ) GO TO 810                           
      WRITE(6,808)
 808  FORMAT ( '0**** INCOMING AND OUTGOING CHANNELS MUST BE',  ' DEFINE
     *D FOR INELASTIC EXCITATION.' )                                    
      GO TO 950                                                         
C                                                                       
 810  IF ( NEXT .GE. 20 ) GO TO 850                                     
C                                                                       
C     HE IS DOING IT IN PIECES AND WE DON'T CHECK MUCH                  
C                                                                       
      IDONE = IOR(IDONE,16)                                             
      IGOTO = NEXT - 4                                                  
      IF ( NEXT .EQ. 10 ) GO TO 870                                     
C                                                                       
C     IF CROSSSECTIONS IS SPECIFIED, IT IMPLIES LINTERPOLATION ALSO     
C     UNLESS THAT HAS JUST BEEN DONE.                                   
C                                                                       
      IF ( NEXT .EQ. 13 .AND. MOD(IDONE/32, 2) .EQ. 0 ) IGOTO = 15      
      IF ( NEXT .EQ. 12 ) IDONE = IOR(IDONE,32)                         
      RETURN                                                            
C                                                                       
C     DO THE WHOLE THING; DON'T ALLOW REPEATS (EXCEPT MULTIPASS)        
C                                                                       
 850  IF ( MOD(IDONE/16, 2) .EQ. 0 ) GO TO 860                          
      IF ( IBSPAS .GT. 0 ) GO TO 855                                    
      WRITE(6,853)
 853  FORMAT ( '0**** YOU ARE REQUESTING THINGS OUT OF ORDER')          
      GO TO 950                                                         
 855  IBSPAS = 2                                                        
      IDONE = MOD(IDONE, 16)                                            
 860  IGOTO = 14                                                        
C                                                                       
C     FOR SAVEHS SAVE COMMONS AT ENTRY TO GRDSET                        
C                                                                       
 870  IRET = 1                                                          
      IF ( IHSAVE .EQ. 1 ) CALL SAVECM ( NUMFLT,FLOATK,NUMINT,INTGER, 
     *NUMJ, JBLOCK, NUMSW, SWITCH, IRET )                               
      IF ( IRET .EQ. 0 ) GO TO 950                                      
      RETURN                                                            
C                                                                       
C     ERRORS DETECTED, FOR TSO KEEP GOING, FOR BATCH QUIT               
C                                                                       
900   WRITE(6, 903) KYWORD                                              
 903  FORMAT('0****         ------  INPUT ERROR  -------' /  ' KEYWORD B
     *EING PROCESSED WAS  ', A8 / )                                     
      GO TO 950                                                         
C                                                                       
 910  WRITE(6,913) KYWORD                                                 
 913  FORMAT ( '0**** A NUMERIC DATA VALUE MUST FOLLOW THE ', A8,  ' KEY
     *WORD.' )                                                          
      GO TO 950                                                         
 915  WRITE(6,918) KYWORD                                                 
 918  FORMAT ( '0**** AN INTEGER DATA VALUE MUST FOLLOW THE ', A8,  ' KE
     *YWORD.' )                                                         
      GO TO 950                                                         
 920  WRITE(6,923) KYWORD                                                 
 923  FORMAT ( '0**** AN INTEGER OR HALF-INTEGER DATA VALUE MUST ',  'FO
     *LLOW THE ', A8, ' KEYWORD.' )                                     
      GO TO 950                                                         
 925  III = INCH - 1                                                    
      WRITE(6,928) ( IBUF(I), I = 1, III )                                
 928  FORMAT ( '0**** INVALID FIELD ENCOUNTERED WHEN LOOKING FOR A',  ' 
     *KEYWORD.' /  6X, 'INPUT UP TO ERROR IS: ', 80A1 )                 
      GO TO 950                                                         
 930  WRITE(6,933) KYWORD                                                 
 933  FORMAT ( '0**** A NAME MUST FOLLOW THE ', A8, ' KEYWORD.' )       
      GO TO 950                                                         
C                                                                       
 950  IF(ITSO.EQ.1) GO TO 980                                           
C                                                                       
C     IN BATCH, GIVE A LIST OF EVERYTHING AND TERMINATE                 
C                                                                       
      VALSW = .TRUE.                                                    
      ASSIGN 955 TO JUMP                                                
      GO TO 125                                                         
 955  IF ( ICNTT .NE. 0 ) CALL NSCAT ( IDUM )                           
      IF ( IHSAVE .GT. 0 ) REWIND 1                                     
      STOP 1230                                                         
C                                                                       
C     IN TSO GIVE HIM ANOTHER TRY                                       
C                                                                       
 980  WRITE(6,983)
 983  FORMAT (' ***** CONTINUING WITH NEXT INPUT LINE **** ' /)         
      CALL NEWCD                                                        
      GO TO 10                                                          
C                                                                       
C     CHECK RETURN CODE AFTER A STEP OF THE CALCULATION                 
C                                                                       
 990  IF ( IPRM1 .NE. 0 ) GO TO 765                                     
 995  WRITE(6,998)
 998  FORMAT ( '0**** ERROR DETECTED IN PREVIOUS STEP.'/)               
      GO TO 950                                                         
C                                                                       
      END                                                               
      SUBROUTINE COULIN ( N, MAXDEL, LMIN, LMAX, ETAOUT, AKOUT, SIGOUT, 
     * ETAIN, AKIN, SIGIN, R, ALLSW, FF, FG, GF, GG, LDLDIM,ACCURA, AS
     * MULT,NTERMS,NPTS,WORK,FI,FO,GI,GO,STARTS,IPRINT,IRET) 
C                                                                       
C     COULOMB INTEGRALS BY RECURSION                                    
C                                                                       
C     COMPUTES                                                          
C                                                                       
C       FF = INTEGRAL( R TO INF ) DR F(LOUT,ETAOUT,KOUT*R)              
C            * F(LIN,ETAIN,KIN*R) / R**N                                
C                                                                       
C     AND SIMILARLY FOR FG, GF, AND GG  FOR                             
C                                                                       
C       LMIN =< (LOUT+LIN)/2 =< LMAX                                    
C       -MAXDEL =< LIN-LOUT =< MAXDEL                                   
C                                                                       
C     THESE ARE STORED AS                                               
C                                                                       
C       FF( (LIN-LOUT+MAXDEL)/2+1, LIN+LOUT-2*LMIN+1 )                  
C                                                                       
C     WHICH MEANS THAT  FF(ID,IL)  CORRESPONDS TO                       
C                                                                       
C       LIN  = (IL+2*LMIN+MAXDEL)/2 + ID-1 - MAXDEL                     
C       LOUT = (IL+2*LMIN-1+MAXDEL)/2 + 1-ID                            
C            = IL+2*LMIN-1 - LIN   .                                    
C                                                                       
C     WE SEE THAT                                                       
C                                                                       
C       1  =<  IL  =<  2*(LMAX-LMIN) + 1                                
C       1  =<  ID  =<  MAXDEL + MOD(MAXDEL+IL, 2)                       
C                                                                       
C     SO THAT ONE MUST HAVE                                             
C                                                                       
C       DIMENSION  FF( LDLDIM, 2(LMAX-LMIN)+1 )                         
C     WITH                                                              
C       LDLDIM >= MAXDEL+1                                              
C                                                                       
C     ALSO THE METHOD WILL WORK ONLY FOR MAXDEL >= 2 SO MAXDEL = 2      
C     WILL BE ASSUMED IF MAXDEL = 0 OR 1.                               
C                                                                       
C     ARGUMENTS:                                                        
C                                                                       
C     N - INVERSE POWER OF R TO INCLUDE IN THE INTEGRALS.               
C     MAXDEL - MAXIMUM RANGE OF LIN-LOUT.                               
C     LMIN, LMAX - MAXIMUM RANGE OF THE AVERAGE OF LIN AND LOUT.        
C     ETAOUT, AKOUT - COULOMB PARAMETER AND WAVENUMBER IN OUTGOING      
C             STATE.                                                    
C     SIGIN - SUPPLIED ARRAY OF COULOMB PHASE SHIFTS FOR INGOING        
C              CHANNEL FOR                                              
C                LMIN-MAXDEL =< L =< LMAX+MAXDEL                        
C              WITH INDEX  L+1 .                                        
C     ETAIN, AKIN - COULOMB PARAMETER AND WAVENUMBER IN INCOMING        
C             STATE.                                                    
C     SIGOUT - SUPPLIED ARRAY OF COULOMB PHASE SHIFTS FOR OUTGOING      
C              CHANNEL FOR                                              
C                LMIN-MAXDEL =< L =< LMAX+MAXDEL                        
C              WITH INDEX  L+1 .                                        
C     R - STARTING POINT FOR THE INTEGRAL.  R >= 0.                     
C     ALLSW = .TRUE. MEANS ALL FOUR TYPES OF INTEGRAL ARE COMPUTED.     
C                    IN THIS CASE  R > 0  IS REQUIRED.                  
C           = .FALSE. MEANS FIND ONLY FF.  IN THIS CASE FG, GF, AND GG  
C              NEED BE ONLY SCALARS.                                    
C     FF, FG, GF, GG - OUTPUT ARRAYS DIMENSIONED AS DESCRIBED ABOVE.    
C     LDLDIM - FIRST DIMENSION OF THE ABOVE 4 ARRAYS.                   
C     ACCURA - APPROXIMATE DESIRED ACCURACY.  AN ERROR MESSAGE WILL BE  
C              PRINTED IF THE FINAL ERROR EXCEEDS 10*ACCURA             
C     ASMULT, NTERMS, NPTS - PARAMETERS FOR CLINTS WHICH SEE.           
C     WORK - WORK ARRAY OF DIMENSION                                    
C             MAX( 2*LMAX+2*MAXDEL+1, 2*NPTS+LMAX+MAXDEL,               
C                  2*NPTS+4*NTERMS ) + 1                                
C     FI, FO, GI, GO - WORK ARRAYS OF DIMENSION                         
C            MAX( LMAX+MAXDEL, 4*NTERMS ) + 1                           
C     STARTS - WORK ARRAY OF DIMENSION  16*LDLDIM .                     
C     IPRINT = 0 SUPPRESSES DIAGNOSTIC PRINT OUT.                       
C            = 1 CAUSES SOME PRINT OUT FROM COULIN.                     
C            >= 2 CAUSES INCREASING AMOUTS OF PRINTOUT FROM CLINTS.     
C     IRET - A RETURN CODE:                                             
C          = 0 MEANS ALL WENT WELL.                                     
C          =< -10  MEANS AN ERROR WAS DETECTED IN COULIN.               
C          -9 =< IRET < 0  MEANS CLINTS DETECTED TROUBLE.               
C          > 0 MEANS A FAILURE IN RCWFN.                                
C     12/10/76 - FIRST VERSION - S. PIEPER                              
C     1/27/77 - FF DONE FORWARD FOR R > 0.                              
C     3/9/77 - ALLOW VERY SMALL RHO IN THE NUMERIC INWARDS INTEGRAL     
C     6/27/78 - DIAGNOSTIC PRINTOUTS                                    
C     5/11/79 - DO NOT ASSUME KIN*ETAIN = KOUT*ETAOUT - S.P.            
C     12/27/79 - CIB TO CND PREFIX - RPG                                
C     7/31/80 - USE ACCURA AS LOWER POINT OF INWARDS INTEGRAL - S.P.    
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      DIMENSION SIGIN(1), SIGOUT(1)                                     
      DIMENSION FF(LDLDIM,1), FG(LDLDIM,1), GF(LDLDIM,1), GG(LDLDIM,1)  
      DIMENSION FI(1), FO(1), GI(1), GO(1), WORK(1)                     
      DIMENSION STARTS(LDLDIM, 2, 4, 2)                                 
CDC      DIMENSION STARTS(LDLDIM, 2, 8)                                 
CDC%'STARTS(#,#,#,#)' = 'STARTS(#1,#2,#3+4*#4-4)';;                     
C                                                                       
CDC      ALLOCLEVEL SIGIN, SIGOUT, FF, FG, GF, GG, FI, FO,              
CDC     1  GI, GO, WORK, STARTS                                         
C                                                                       
      DIMENSION RTURNS(2), RMINS(2), ACCS(2)                            
      LOGICAL ALLSW                                                     
C                                                                       
      MXDEL = MAX0(2, MAXDEL)                                           
      LMAXMX = LMAX+MXDEL                                               
      LMINMN = MAX0(0, LMIN-MXDEL)                                      
      IF ( LDLDIM .GT. MXDEL ) GO TO 20                                 
C     LDLDIM TOO SMALL                                                  
      IRET = -10                                                        
      RETURN                                                            
 20   MMXDEL = -MXDEL                                                   
      DN = N                                                            
      NTRM = MAX0( NTERMS, LMAX/4 )                                     
C                                                                       
C     FOLLOWING IS AN ATTEMPT TO ALLOW FOR LOSS OF ACCURACY             
C                                                                       
      ACC = ACCURA * DEXP( 10 - 5*N - 2*DABS(ETAIN-ETAOUT)  - (LMAX-LMIN
     *)/100. )                                                          
      ACC = DMAX1( ACC, 1.D-18 )                                        
C                                                                       
C     IF THE INTEGRAL IS TO BE FROM 0, FIND A SUITABLE STARTING         
C     POINT                                                             
C                                                                       
      RMINS(1) = R                                                      
      RMINS(2) = R                                                      
      ACCS(1) = ACC                                                     
      ACCS(2) = .01*ACCURA                                              
      IF ( R .GT. 0 ) GO TO 50                                          
      ACCS(1) = .1*ACCURA                                               
      ACCS(2) = .1*ACC                                                  
      IF ( .NOT. ALLSW ) GO TO 30                                       
      IRET = -12                                                        
      RETURN                                                            
 30   RTURNS(1) = DMAX1( (ETAIN+DSQRT(ETAIN**2+LMINMN*(LMINMN+1)))/AKIN,
     * (ETAOUT+DSQRT(ETAOUT**2+LMINMN*(LMINMN+1)))/AKOUT )              
      RTURNS(2) = DMAX1( (ETAIN+DSQRT(ETAIN**2+LMAXMX*(LMAXMX+1)))/AKIN,
     * (ETAOUT+DSQRT(ETAOUT**2+LMAXMX*(LMAXMX+1)))/AKOUT )              
      IF ( IPRINT .GE. 1 ) WRITE(6,33) RTURNS                             
 33   FORMAT ( ' RTURN  S =', 2G12.4 )                                  
C                                                                       
C     WE DO THE NUMERIC INTEGRAL MORE EFFICENTLY HERE SINCE WE DO       
C     ALL OF THEM AT ONCE.  SO FORCE CLINTS RIGHT TO THE PLACE WHERE    
C     IT STARTS TO USE RCASYM.                                          
C                                                                       
      RMINS(1) = 1.4*RTURNS(1)                                          
      RMINS(2) = 1.4*RTURNS(2)                                          
C                                                                       
C     GET STARTING VALUES FOR RECURSIONS AND FINAL VALUES               
C     TO CHECK THE STABILITY OF THE RECURSIONS.                         
C                                                                       
 50   LS = 2*LMIN                                                       
      IF ( IPRINT .GE. 1 ) WRITE(6,53) ACCS                               
 53   FORMAT ( ' REQUESTED CLINTS ACCURACIES ARE', 2G13.3 )             
C                                                                       
C     FOR RECURSION UPWARDS WE WILL NEED TO START WITH A                
C     FULL WIDTH SET.  ALSO THE DOWNWARDS RECURSION CAN NOT GO          
C     BENEATH  LIN+LOUT = N-2  EVEN THOUGH FOR R > 0 THE RESULTS        
C     WILL STILL BE FINITE.  THEREFORE WE GENERATE ALL THESE SMALL      
C     L VALUES NUMERICALLY.                                             
C                                                                       
      ISTOPR = MAX0( N-2*LMIN, 2 )                                      
      IF ( ALLSW ) ISTOPR = MAX0( MXDEL+1-2*LMIN, ISTOPR )              
      ISTOP = ISTOPR                                                    
      LSUMMN = 2*LMIN+1 + ISTOPR-2                                      
      LSUMMX = 2*LMAX-1                                                 
C                                                                       
      DO 79 II = 1, 2                                                   
C                                                                       
C     LIN+LOUT = LS+I-1                                                 
C                                                                       
      DO 69 I = 1, ISTOP                                                
      IL = LS-2*LMIN+I                                                  
      MD = MXDEL + MOD(MXDEL+IL, 2 )                                    
      IS = 1                                                            
      IF ( I .EQ. ISTOP ) IS = 2                                        
      DO 59 ID = 1, MD                                                  
      LIN = (LS+I+MXDEL)/2 + ID-1 - MXDEL                               
      LOUT = LS+I-1 - LIN                                               
      IF ( LIN .LT. 0 .OR. LOUT .LT. 0 ) GO TO 59                       
      A = ASMULT                                                        
      CALL CLINTS ( RMINS(II), ETAIN, ETAOUT, AKIN, AKOUT,  SIGIN(LIN+1)
     *, SIGOUT(LOUT+1),  ACCS(II), A, STARTS(ID,IS,1,II), STARTS(ID,IS,2
     *,II),  STARTS(ID,IS,3,II), STARTS(ID,IS,4,II),  WORK, WORK(NPTS+1)
     *, FI, FO, GI, GO, WORK(2*NPTS+1),  N, LIN, LOUT, NTRM, NPTS, IRET,
     * IPRINT )                                                         
      IF ( IRET .NE. 0 ) RETURN                                         
 59   CONTINUE                                                          
C                                                                       
C                                                                       
C     SAVE END OF THE FF RECURSION AND                                  
C     STORE START OF FG, GF, GG STUFF                                   
C                                                                       
      DO 64 ID = 1, MD                                                  
      FF(ID,IL) = STARTS(ID,IS,1,II)                                    
      IF ( .NOT. ALLSW ) GO TO 64                                       
      FG(ID,IL) = STARTS(ID,IS,2,II)                                    
      GF(ID,IL) = STARTS(ID,IS,3,II)                                    
      GG(ID,IL) = STARTS(ID,IS,4,II)                                    
 64   CONTINUE                                                          
C                                                                       
 69   CONTINUE                                                          
      LS = 2*LMAX - 1                                                   
      ISTOP = 2                                                         
 79   CONTINUE                                                          
C                                                                       
      IF ( R .NE. 0 ) GO TO 400                                         
C                                                                       
C     HERE WE DO THE INTEGRAL  0 < R < 1.4*RTURN  BACKWARDS UNTIL       
C     WE COME TO INSIGNIFICANT CONTRIBUTIONS.                           
C                                                                       
      DELTA = 3.1/AKIN                                                  
      ISTOP = ISTOPR                                                    
      LMN = LMINMN                                                      
      LMX = LMIN + (ISTOP+MXDEL+1)/2                                    
      LS = 2*LMIN                                                       
      DO 169 II = 1, 2                                                  
      RTOP = RMINS(II)                                                  
 110  RBOT = DMAX1( 0.D0, RTOP-DELTA )                                  
      IF ( RBOT .GE. RTOP ) GO TO 165                                   
      B = RTOP - RBOT                                                   
      DO 159 IPT = 1, NPTS                                              
      RVAL = RTOP - .5*B*(1+WORK(IPT))                                  
      CALL RCWFN( AKIN*RVAL, ETAIN, LMN, LMX, FI, FO,  GI, GO, 1.D-8, IR
     *ET )                                                              
      IF ( IRET .NE. 0 .AND. IRET .NE. 2 ) GO TO 900                    
      IF ( DABS(FI(LMN+1)) .LT. ACCURA .AND. RVAL .LT. RTURNS(II) ) GO T
     *O 165                                                             
      CALL RCWFN ( AKOUT*RVAL, ETAOUT, LMN, LMX, FO, GI,  GO, WORK(2*NPT
     *S+1), 1.D-8, IRET )                                               
      IF ( IRET .NE. 0 .AND. IRET .NE. 2 ) GO TO 900                    
      IF ( DABS(FO(LMN+1)) .LT. ACCURA .AND. RVAL .LT. RTURNS(II) ) GO T
     *O 165                                                             
      X = .5*B*WORK(NPTS+IPT)/RVAL**N                                   
      DO 149 I = 1, ISTOP                                               
      IL = LS-2*LMIN+I                                                  
      MD = MXDEL + MOD(MXDEL+IL, 2)                                     
      IS = 1                                                            
      IF ( I .EQ. ISTOP ) IS = 2                                        
      DO 149 ID = 1, MD                                                 
      LIN = (LS+I+MXDEL)/2 + ID-1-MXDEL                                 
      LOUT = LS+I-1 - LIN                                               
      IF ( LIN .LT. 0 .OR. LOUT .LT. 0 ) GO TO 149                      
      A = X*FI(LIN+1)*FO(LOUT+1)                                        
      FF(ID,IL) = FF(ID,IL) + A                                         
      STARTS(ID,IS,1,II) = FF(ID,IL)                                    
 149  CONTINUE                                                          
 159  CONTINUE                                                          
      RTOP = RBOT                                                       
      RVAL = RBOT                                                       
      GO TO 110                                                         
 165  RMINS(II) = RVAL                                                  
      LS = 2*LMAX-1                                                     
      ISTOP = 2                                                         
      LMN = (LS-MXDEL-1)/2                                              
      LMX = LMAXMX                                                      
 169  CONTINUE                                                          
      IF ( IPRINT .GE. 1 ) WRITE(6,173) RMINS                             
 173  FORMAT ( ' RMIN  S = ', 2G12.4 )                                  
      MD = MXDEL + 1                                                    
      IF ( IPRINT .GE. 2 ) WRITE(6,177)((STARTS(ID,IS,1,2),ID=1,MD),
     * IS = 1, 2 )                                                      
 177  FORMAT ( ' FF STARTING VALUES:' / ( 3G20.10 ) )                   
C                                                                       
C                                                                       
C     RECURSE DOWNWARD FOR FF                                           
C     WE GO FROM  LSUM  TO  LSUM-1  AND GENERATE ALL THE                
C     LIN-LOUT FOR EACH LSUM.                                           
C                                                                       
      DO 399 LS = LSUMMN, LSUMMX                                        
      LSUM = LSUMMX+LSUMMN-LS                                           
      DO 299 LDEL = MMXDEL, MXDEL                                       
C                                                                       
C     LIN, LOUT POINT TO THE CORNER WE WILL EXTRAPOLATE FROM            
C                                                                       
      LIN = (LSUM-LDEL)                                                 
      IF ( LIN .LT. 0 ) GO TO 299                                       
      LIN = LIN/2                                                       
      LOUT = (LSUM+LDEL)/2                                              
      IF ( LSUM .NE. LIN+LOUT ) GO TO 299                               
      LOUTP = LOUT-1                                                    
      IF ( IABS(LIN-LOUTP) .GT. MXDEL ) GO TO 299                       
      IF ( LOUTP .LT. 0 ) GO TO 299                                     
      IF ( IABS(LOUT+1-LIN) .GT. MXDEL ) GO TO 299                      
C                                                                       
C     LIN, LOUT-1  IS NEEDED AND WE HAVE ALL THE STUFF NEEDED TO        
C     FIND IT. BY RECURSION DOWNWARD ON LOUT.                           
C                                                                       
      DLI = LIN                                                         
      DLO = LOUT                                                        
      ID = (LIN-LOUT+MXDEL) + 2                                         
      IL = LIN+LOUT-2*LMIN+1                                            
      ID2 = (ID+1)/2                                                    
      ID = ID/2                                                         
C                                                                       
      E = (2*DLO+1)/((DLI+DLO-DN+2)*DSQRT(DLO**2+ETAOUT**2))            
      A = ETAOUT * (DLI-DN+2)/(DLO+1)  - (ETAIN*(AKIN/AKOUT)) * DLO/(DLI
     *+1)                                                               
      B = (AKIN/AKOUT)*(DLO/(DLI+1))*DSQRT((DLI+1)**2+ETAIN**2)         
      C = DLO*(DLO-DLI+DN-1)*DSQRT((DLO+1)**2+ETAOUT**2)  / ((DLO+1)*(2*
     *DLO+1))                                                           
      FF(ID2,IL-1) = E*( A*FF(ID,IL) + C*FF(ID2-1,IL+1)  + B*FF(ID2,IL+1
     *) )                                                               
 299  CONTINUE                                                          
C                                                                       
C     DLI, DLO, ETC, REFER TO THE LAST CASE FOR WHICH WE REDUCED        
C     LOUT.  NOW REDUCE LIN FOR THAT SAME CASE TO COMPLETE THE          
C     GENERATION OF LSUM-1 FROM LSUM.                                   
C                                                                       
      IF ( DLI .LE. 0 ) GO TO 399                                       
C                                                                       
      E = (2*DLI+1)/((DLI+DLO-DN+2)*DSQRT(DLI**2+ETAIN**2))             
      A = ETAIN * (DLO-DN+2)/(DLI+1)  - (ETAOUT*(AKOUT/AKIN)) * DLI/(DLO
     *+1)                                                               
      B = (AKOUT/AKIN)*(DLI/(DLO+1))*DSQRT((DLO+1)**2+ETAOUT**2)        
      C = DLI*(DLI-DLO+DN-1)*DSQRT((DLI+1)**2+ETAIN**2)  / ((DLI+1)*(2*D
     *LI+1))                                                            
      FF(ID2-1,IL-1) = E*( A*FF(ID,IL) + B*FF(ID2-1,IL+1)  + C*FF(ID2,IL
     *+1) )                                                             
C                                                                       
 399  CONTINUE                                                          
C                                                                       
      GO TO 800                                                         
C                                                                       
C     GET THE INHOMO TERMS                                              
C                                                                       
 400  CONTINUE
      CALL RCWFN ( AKIN*R, ETAIN, LMINMN, LMAXMX, FI, WORK,  GI, WORK(LM
     *AXMX+1), 1.D-14, IRET )                                           
      IF ( IRET .NE. 0 ) GO TO 910                                      
      CALL RCWFN ( AKOUT*R, ETAOUT, LMINMN, LMAXMX, FO, WORK,  GO, WORK(
     *LMAXMX+1), 1.D-14, IRET )                                         
      IF ( IRET .NE. 0 ) GO TO 910                                      
C                                                                       
C     RECURSE UPWARDS ON FG, GF, AND GG. AND FF WHEN R > 0.             
C                                                                       
      DO 599 LSUM = LSUMMN, LSUMMX                                      
      DO 499 LDEL = MMXDEL, MXDEL                                       
C                                                                       
C     LIN, LOUT POINT TO THE CORNER WE WILL EXTRAPOLATE FROM            
C                                                                       
      LIN = (LSUM+LDEL)/2                                               
      LOUT = (LSUM-LDEL)/2                                              
      IF ( LSUM .NE. LIN+LOUT ) GO TO 499                               
      LOUTP = LOUT+1                                                    
      IF ( IABS(LIN-LOUTP) .GT. MXDEL ) GO TO 499                       
      IF ( IABS(LOUT-1-LIN) .GT. MXDEL ) GO TO 499                      
C                                                                       
C     LIN, LOUT+1  IS NEEDED AND WE HAVE ALL THE STUFF NEEDED TO        
C     FIND IT. BY RECURSION UPWARD ON LOUT.                             
C                                                                       
      DLI = LIN                                                         
      DLO = LOUT                                                        
      LINLS = LIN                                                       
      LOUTLS = LOUT                                                     
      ID = (LIN-LOUT+MXDEL) + 2                                         
      IL = LIN+LOUT-2*LMIN+1                                            
      ID2 = (ID+1)/2                                                    
      ID = ID/2                                                         
      E = (2*DLO+1)/((DLI+DLO+DN)*DSQRT((DLO+1)**2+ETAOUT**2))          
      A = ETAOUT * (DLI+DN-1)/DLO - (ETAIN*(AKIN/AKOUT)) * (DLO+1)/DLI  
      B = (AKIN/AKOUT)*((DLO+1)/DLI)*DSQRT(DLI**2+ETAIN**2)             
      C = (DLO+1)*(DLO-DLI-DN+1)*DSQRT(DLO**2+ETAOUT**2)  / (DLO*(2*DLO+
     *1))                                                               
      D = (DLO+1)/(AKOUT*R**N)                                          
C                                                                       
      FF(ID2-1,IL+1) = E*( A*FF(ID,IL) + C*FF(ID2,IL-1) +  B*FF(ID2-1,IL
     *-1) + D*FO(LOUT+1)*FI(LIN+1) )                                    
      IF ( .NOT. ALLSW ) GO TO 499                                      
      FG(ID2-1,IL+1) = E*( A*FG(ID,IL) + C*FG(ID2,IL-1) +  B*FG(ID2-1,IL
     *-1) + D*FO(LOUT+1)*GI(LIN+1) )                                    
      GF(ID2-1,IL+1) = E*( A*GF(ID,IL) + C*GF(ID2,IL-1) +  B*GF(ID2-1,IL
     *-1) + D*GO(LOUT+1)*FI(LIN+1) )                                    
      GG(ID2-1,IL+1) = E*( A*GG(ID,IL) + C*GG(ID2,IL-1) +  B*GG(ID2-1,IL
     *-1) + D*GO(LOUT+1)*GI(LIN+1) )                                    
 499  CONTINUE                                                          
C                                                                       
C     DLI, DLO, ETC, REFER TO THE LAST CASE FOR WHICH WE INCREASED      
C     LOUT.  NOW INCREASE LIN FOR THAT SAME CASE TO COMPLETE THE        
C     GENERATION OF LSUM+1 FROM LSUM.                                   
C                                                                       
      E = (2*DLI+1)/((DLI+DLO+DN)*DSQRT((DLI+1)**2+ETAIN**2))           
      A = ETAIN * (DLO+DN-1)/DLI  - (ETAOUT*(AKOUT/AKIN)) * (DLI+1)/DLO 
      B = (AKOUT/AKIN)*((DLI+1)/DLO)*DSQRT(DLO**2+ETAOUT**2)            
      C = (DLI+1)*(DLI-DLO-DN+1)*DSQRT(DLI**2+ETAIN**2)  / (DLI*(2*DLI+1
     *))                                                                
      D = (DLI+1)/(AKIN*R**N)                                           
C                                                                       
      FF(ID2,IL+1) = E*( A*FF(ID,IL) + B*FF(ID2,IL-1)  + C*FF(ID2-1,IL-1
     *) + D*FO(LOUTLS+1)*FI(LINLS+1) )                                  
      IF ( .NOT. ALLSW ) GO TO 599                                      
      FG(ID2,IL+1) = E*( A*FG(ID,IL) + B*FG(ID2,IL-1)  + C*FG(ID2-1,IL-1
     *) + D*FO(LOUTLS+1)*GI(LINLS+1) )                                  
      GF(ID2,IL+1) = E*( A*GF(ID,IL) + B*GF(ID2,IL-1)  + C*GF(ID2-1,IL-1
     *) + D*GO(LOUTLS+1)*FI(LINLS+1) )                                  
      GG(ID2,IL+1) = E*( A*GG(ID,IL) + B*GG(ID2,IL-1)  + C*GG(ID2-1,IL-1
     *) + D*GO(LOUTLS+1)*GI(LINLS+1) )                                  
C                                                                       
 599  CONTINUE                                                          
C                                                                       
C                                                                       
C     CHECK THE ACCURACY OF THE RECURSIONS                              
C                                                                       
  800 DO 869 I = 1, 2                                                   
      IL = I + ISTOPR-2                                                 
      MD = MXDEL + MOD(MXDEL+IL,2)                                      
      IF ( R .GT. 0 ) GO TO 850                                         
      DO 849 ID = 1, MD                                                 
      LIN = (2*LMIN+IL+MXDEL)/2 + ID-1 - MXDEL                          
      LOUT = 2*LMIN+IL-1 - LIN                                          
      IF ( LIN .LT. 0 .OR. LOUT .LT. 0 ) GO TO 849                      
      IF ( IPRINT .GE. 1 ) WRITE(6,8853) I,MD,ID,IL,LIN,LOUT,FF(ID,
     *IL), STARTS(ID,I,1,1)                                             
      IF ( DABS( FF(ID,IL)/STARTS(ID,I,1,1) - 1 ) .GT. 10*ACCURA ) 
     * WRITE(6,843) LIN, LOUT, FF(ID,IL), STARTS(ID,I,1,1)                      
 843  FORMAT ( '***** FOR LIN, LOUT =', 2I4,  ' FF RECURSION IS POOR:', 
     *2G20.10 )                                                         
 849  CONTINUE                                                          
      GO TO 869                                                         
C                                                                       
 850  MD = MXDEL + MOD(MXDEL+I+1, 2)                                    
      DO 859 ID = 1, MD                                                 
      IL = 2*(LMAX-LMIN)-1 + I                                          
      LIN = (IL+2*LMIN+MXDEL)/2 + ID-1 - MXDEL                          
      LOUT = IL+2*LMIN-1 - LIN                                          
      IF (IPRINT .GE. 1) WRITE(6,8853) I,MD,ID,IL,LIN,LOUT,FF(ID,IL
     *), FG(ID,IL), GF(ID,IL), GG(ID,IL),  ( STARTS(ID,I,III,2), III = 1
     *, 4 )                                                             
 8853 FORMAT ( 9H CHECKING , 6I7 / ( 10X, 4G20.10 ) )                   
      IF ( DABS( FF(ID,IL)/STARTS(ID,I,1,2) - 1 ) .GT. 10*ACCURA ) 
     * WRITE(6,851) LIN, LOUT, FF(ID,IL), STARTS(ID,I,1,2)                      
 851  FORMAT ( '***** FOR LIN, LOUT =', 2I4,  ' FF RECURSION IS POOR:', 
     *2G20.10 )                                                         
      IF ( .NOT. ALLSW ) GO TO 859                                      
      IF ( DABS( FG(ID,IL)/STARTS(ID,I,2,2) - 1 ) .GT. 10*ACCURA ) 
     * WRITE(6,852) LIN, LOUT, FG(ID,IL), STARTS(ID,I,2,2)                      
 852  FORMAT ( '***** FOR LIN, LOUT =', 2I4,  ' FG RECURSION IS POOR:', 
     *2G20.10 )                                                         
      IF ( DABS( GF(ID,IL)/STARTS(ID,I,3,2) - 1 ) .GT. 10*ACCURA ) 
     * WRITE(6,853) LIN, LOUT, GF(ID,IL), STARTS(ID,I,3,2)                      
 853  FORMAT ( '***** FOR LIN, LOUT =', 2I4,  ' GF RECURSION IS POOR:', 
     *2G20.10 )                                                         
      IF ( DABS( GG(ID,IL)/STARTS(ID,I,4,2) - 1 ) .GT. 10*ACCURA ) 
     *WRITE(6,857) LIN, LOUT, GG(ID,IL), STARTS(ID,I,4,2)                      
 857  FORMAT ( '***** FOR LIN, LOUT =', 2I4,  ' GG RECURSION IS POOR:', 
     *2G20.10 )                                                         
 859  CONTINUE                                                          
 869  CONTINUE                                                          
C                                                                       
      IRET = 0                                                          
      RETURN                                                            
C                                                                       
C     ERROR DETECTED BY RCWFN                                           
C                                                                       
 900  WRITE(6,903) IRET,RVAL,LMN,LMX,ETAIN,ETAOUT,AKIN,AKOUT,RTOP
     *, DELTA, B, II, IPT                                               
 903  FORMAT ( 28H0***RCWFN FROM COULIN IRET =, I6, G15.5, 2I5, 4G15.5 /
     * 4H $$$, 3G20.10, 2I5 )                                           
      RETURN                                                            
 910  RVAL = R                                                          
      LMN = LMINMN                                                      
      LMX = LMAXMX                                                      
      B = 123456789.                                                    
      GO TO 900                                                         
      END                                                               
      FUNCTION COULNG ( L, ETA, RHO, ANORM )                            
C                                                                       
C     COMPUTE COULOMB WAVEFUNCTION FOR NEGATIVE ENERGY                  
C                                                                       
C     THE RETURNED FUNCTION IS                                          
C                                                                       
C       COULNG =  GAMMA(L+ETA+1) / GAMMA(ANORM)                         
C              * EXP(RHO) * (2*RHO)**ETA * W( -ETA, L+1/2, 2*RHO )      
C                                                                       
C     WHERE W IS THE WHITTAKER FUNCTION OF ABRAMOWITZ AND STEGUN        
C                                                                       
C     AN INTEGRAL EXPRESSION FOR W (RHYDZAK AND ZIMMERMAN XXXXXX)       
C     IS COMPUTED USING GAUSS-LAGUERRE QUADRATURE.  THIS IS A CRUDE     
C     AND SLOW TECHNIQUE BUT IT SEEMS RELIABLE FOR THE ARGUMENT RANGES  
C     OF INTEREST.                                                      
C                                                                       
C     THIS ROUTINE REQUIRES (BUT DOES NOT CHECK FOR)                    
C           ETA > -L.                                                   
C                                                                       
C     THE ROUTINE HAS BEEN CHECKED FOR:                                 
C           0 =< L =< 10,                                               
C           0 =< ETA =< 120                                             
C           20 =< RHO =< 200                                            
C     FOR WHICH IT USUALLY GIVES BETTER THAN 10 PLACES OF ACCURACY.     
C     FOR LARGE RHO AND ETA THE ACCURACY DETERIORATES ( FOR RHO =100,   
C     ETA = 120 IT HAS ONLY 6 PLACES ) BUT IF ONE OR THE OTHER          
C     OF RHO OR ETA IS NOT LARGE THEN IT HAS GOOD ACCURACY.             
C                                                                       
C     4/23/75 - FIRST VERSION - S. PIEPER                               
C     6/26/75 - ANORM ADDED;  NEW FACTORIZATION FOR SMALL RHO           
C     1/27/80 - USE BIGLOG, PASS A, B, C TO LAGUER - RPG                
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                                                                       
      DATA NPTS /28/                                                    
      DIMENSION X(28), DX(28), A(28), B(28), C(28)                      
C                                                                       
      ETA1 = DMOD( ETA, 1.D0 )                                          
      L1 = MOD( L, 10 )                                                 
      IF (ETA .LT. 0) L1 = 0                                            
      L2 = L - L1                                                       
      DL1 = L1                                                          
      ETA1 = ETA1 + DMAX1( DMIN1( 10-DL1, ETA-ETA1 ), 0.D0 )            
      IETA2 = ETA - ETA1                                                
C                                                                       
      GAM = 1                                                           
      IF ( ETA+L .NE. 0 ) GAM = DEXP( -DLGAMA(ANORM)/(ETA+L) )          
      XLIM = 0                                                          
      IF ( L2+IETA2 .LE. 1 ) GO TO 100                                  
      XLIM = DEXP( -BIGLOG/(L2+IETA2) ) / GAM                           
C                                                                       
 100  CALL LAGUER ( NPTS, X, DX, ETA1+DL1, 1.D-20, CSX, CSW, TSX, TSW,  
     *A, B, C )                                                         
C                                                                       
      COULNG = 0                                                        
      DO 159 N = 1, NPTS                                                
      IF ( X(N) .LT. XLIM ) GO TO 159                                   
      IF ( RHO .LT. 2 ) GO TO 130                                       
      COULNG = COULNG + DX(N) * (GAM*X(N))**(L2+IETA2) *  (1+X(N)/(2*RHO
     *))**(L-ETA)                                                       
      GO TO 159                                                         
 130  TEMP = 1 + X(N)/(2*RHO)                                           
      COULNG = COULNG + DX(N) * (GAM*X(N)/TEMP)**(L2+IETA2)  * TEMP**(L+
     *L2-ETA1)                                                          
 159  CONTINUE                                                          
C                                                                       
      COULNG = COULNG * GAM**(ETA1+DL1)                                 
      IF ( ETA+L .EQ. 0 ) COULNG = COULNG / DGAMMA(ANORM)               
      RETURN                                                            
      END                                                               
      SUBROUTINE COULST ( IRTN )                                        
C                                                                       
C     COULOMB INTEGRALS FOR INELASTIC DWBA & COUPLED CHANNELS           
C                                                                       
C     FIRST WE FIND THE MAXIMUM LI TO BE USED FOR THE COULOMB INTEGRALS 
C     WE USE AN ASYMPTOTIC FORM TO BE FOUND IN                          
C       ALDER, BOHR, HUUS, MOTTELSON AND WINTHER, REV. MOD. PHYS. 28,   
C       (1956) 432.                                                     
C                                                                       
C     WE SETUP INTEGRAL(R TO INF) FF, FG, GF AND GG FOR LMIN TO LMAX,   
C     AND JUST FF FOR (0 TO INF) AND LMIN TO LIMOST.                    
C     FOR THE LATTER WE ALSO EVALUATE LIMOST AND EXPAND THE             
C     COULOMB PHASE SHIFT ARRAYS.                                       
C     IN EACH CASE WE MUST STRUCTURE THE ARRAYS TO BE THE SAME          
C     AS THE I(LX,LI,LO) ARRAYS.                                        
C                                                                       
C     IN THE CASE OF COUPLED CHANNELS (BUT NOT COUPL2) WE HAVE          
C     A MORE COMPLICATED STORAGE SCHEME AND A B-FACTOR INDEX ARRAY      
C     IS DEFINED.  IN THIS CASE WE ALSO STORE ONLY FF+GG AND FG-GF.     
C                                                                       
C     IRTN IS SET TO 0 IF AN ERROR OCCURS, 1 OTHERWISE.                 
C                                                                       
C                                                                       
C     1/7/80 - SPLIT OFF FROM ANGSET - S.P.                             
C     2/7/80 - MAKE FG ARRAY REAL*4 - S.P.                              
C     2/19/80 - MOVE A LOOP TO SETBFC - S.P.                            
C     3/31/80 - SMALL FIXES - S.P.                                      
C     4/27/80 - ALLOCATIONS FOR COUPLN; PBUGSW - S.P.                   
C     9/25/80 - COMPUTE LIMOST SEPARATELY FOR EACH CHANNEL - S.P.       
C     12/16/80 - FIX BUG IN ABOVE - S.P.                                
C     6/25/81 - FIX BUG WHEN NO BFACTORS ARE NEEEDED - S.P.             
C     6/29/81 - SMALLER S-MATRIX SEQUENCE AND PADE TABLES - S.P.        
C     9/3/81 - GET AND USE MXLXBF; REMOVE COUPL2 - S.P.                 
C     10/22/81 - FIX COULSIG BUG IF SOME LX > MAX(CHN SPIN) - S.P.      
C     3/8/82 - FIX ARRAY SIZE BUGS FOR LXMAX = 1, 0 - S.P.              
C     3/15/82  TEMPORARY REAL8 VERSION                                  
C     4/10/82 - BACK TO REAL*4 VERSION; NOBFAC BUG                      
C     5/4/82 - FIX K TO INDXS FOR 1/2 INTEGER SPINS - S.P               
C     6/25/82 - ADD SMATITER DEFINITION - S.P.                          
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(100)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), ML
     *LOC(1) )                                                          
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      COMMON /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 PWAVSW, STANSW, SOSWS, PWBGSW, TCSWS, SOSWT               
      COMMON /WAVCOM/ HS(2), RSTEPS(2), NSTPSS(2), NFS(2), NGS(2), NF1S(
     *2), NG1S(2), STEPR, STEPI, IWAVR, IWAVI, NUMAIT, NUMFIT, IOFFIT, P
     *WAVSW, NBAKCM, STANSW, SOSWS(2), NUMJS(2), RIS(2), AIS(2), RSOS(2)
     *, ASOS(2), RSOIS(2), ASOIS(2), IRLVS(2), IIMVS(2), IZPS(2), IZTS(2
     *), ASYMPS(2), V0RS(2), V0IS(2), V0SORS(2), V0SOIS(2), ES(2), JSPS(
     *2), RSIS(2), ASIS(2), V0SIS(2), ISORS(2), ISOIS(2), ALPHAR, ALPHAI
     *, NFIRST, PWBGSW, LASTL(2), LASTNF(2), LSKIPS(2), ISTATS(2), POWRL
     *S(2), POWIMS(2), NSTP2S(2), XFACS(3,2), IVWORK, ICENTR(2), TCSWS(2
     *), NWAVEF, VTENS(2,6), RTENS(2,6), ATENS(2,6), ITENS(2,6), IWAVRS(
     *2), IWAVIS(2), LASTZR, SOSWT, IINDXE(2), ITOCE(2)                 
C                                                                       
      COMMON /FORMF/ IBDS(2), NPOTS(2), LBP, LBT, NBP, NBT, JBP, JBT, BN
     *DMAX(2), BNDSTP(2), NSTPBD(2), RBNDS(2), ABNDS(2), RCBNDS(2), BNDM
     *AS(2), BRATMS(2), RSOBDS(2), ASOBDS(2), VBNDS(2), VSOBDS(2), TAUBD
     *S(2), LNKADB(6,2,12)                                              
      DIMENSION R2S(4)                                                  
      EQUIVALENCE ( R2S(1), RBNDS(1) )                                  
C                                                                       
      LOGICAL ONELSW, IDENSW                                            
      COMMON /INELCM/ JBPF,JBTF,LXMIN,LXMAX,ILILOR,ILILOI,MSTOP,IA12M, 
     *NMLOLX,ONELSW,NUMLX,IRDINT,IELCUP,LILOSZ,NUMLIS,ILIS,IBETAS(4), 
     *ICL2FF,LXSTEP,IDENSW,LSKIP,JPMIN,JPMAX,JPBASE,NJP,JTMIN,JTMAX, 
     *JTBASE,NJT,IINDXS,ISMATR,ISMATI,NSMAT,NLX,NSPLI,ITOCS,NASPLI, 
     *IUNITR,LIFIT,ILIFIT,NOLFIT,IDELSR,IDELSI
      INTEGER INDXJS(4,2)                                               
      EQUIVALENCE ( INDXJS(1,1), JPMIN )                                
      COMMON /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
C                                                                       
      COMMON /NAMCOM/ ANAMES(1)                                         
      REAL*8 BNDXNM                                                     
      DATA BNDXNM / 'BFACINDX' /                                        
C                                                                       
      INTEGER GIVEAL                                                    
C                                                                       
      LOGICAL PBUGSW, PINFSW, COULSW, COUPSW                            
C                                                                       
      IRTN = 0                                                          
C                                                                       
      IPRNT = MOD( IPRINT, 10 )                                         
      PBUGSW = IPRNT .GE. 3                                             
      PINFSW = IPRNT .GE. 2                                             
C                                                                       
      COUPSW = PROBLM .EQ. 24                                           
C                                                                       
C     THESE INTEGRALS WILL BE JUST ZERO IF THE BETA(COULOMB) IS ZERO.   
C                                                                       
C     IN THIS CASE THE LARGE COULOMB LMAX IS ALSO NOT NEEDED.           
C                                                                       
      LIMOST = LMAX                                                     
      COULSW = .FALSE.                                                  
      MXLXBF = LXMAX                                                    
C                                                                       
      IF ( COUPSW ) GO TO 100                                           
      NCHNDF = 2                                                        
      LBETAR = Z(IBETAS(3)) - LXMIN/2                                   
      DO 69 LX = LXMIN, LXMAX, 2                                        
      IF ( ALLOC(LBETAR+LX/2) .EQ. 0 ) GO TO 69                         
      COULSW = .TRUE.                                                   
      GO TO 200                                                         
   69 CONTINUE                                                          
C                                                                       
C     NO COULOMB TERMS WILL BE NEEDED                                   
C                                                                       
      COULSW = .FALSE.                                                  
      NOBFAC = 1                                                        
      GO TO 300                                                         
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     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                                                                       
 100  IBINDX = GIVEAL(I)                                                
      ANAMES(IBINDX) = BNDXNM                                           
      LBINDX = FACFR4*(Z(IBINDX)-1) + 1                                 
      MBINDX = 9                                                        
C                                                                       
      LBASCP = FACFR4*(Z(IBASCP)-1) + 1                                 
      NBASCP = ILLOC(LBASCP)                                            
      MBASCP = ILLOC(LBASCP+1)                                          
      LBASCP = LBASCP + ILLOC(LBASCP+2)                                 
C                                                                       
      LBASDF = FACFR4*(Z(IBASDF)-1) + 1                                 
      NBASDF = ILLOC(LBASDF)                                            
      MBASDF = ILLOC(LBASDF+1)                                          
      LBASDF = LBASDF + ILLOC(LBASDF+2)                                 
C                                                                       
      LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      NCHNDF = ILLOC(LCHNDF)                                            
      MCHNDF = ILLOC(LCHNDF+1)                                          
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2)                                 
C                                                                       
      CALL GENBNX ( 1, NBINDX, MBINDX, ILLOC(LBINDX), NBASCP,  MBASCP, I
     *LLOC(LBASCP), MBASDF, ILLOC(LBASDF), MCHNDF,  ALLOC4(LCHNDF), NMBF
     *AC, NMFFAC, MXLXGS, MXLXBF,  COULSW, PBUGSW )                     
C                                                                       
      I = MAX0( ( NBINDX*MBINDX+1)/FACFR4, 1 )                          
      CALL CHOPIT (I)                                                   
      IF ( NBINDX .NE. 0 ) GO TO 150                                    
C                                                                       
C     B-FACTORS ARE NOT NEEDED OR ARE INHIBITED.                        
C                                                                       
      NOBFAC = 1                                                        
 150  IF ( .NOT. COULSW ) GO TO 300                                     
C                                                                       
C     COULOMB COUPLING EXISTS.  COMPUTE APPROPRIATE EXTRAPOLATION       
C     LIMIT (LIMOST)                                                    
C                                                                       
C     FIRST WE FIND THE MAXIMUM LI TO BE USED FOR THE COULOMB INTEGRALS 
C     WE USE AN ASYMPTOTIC FORM TO BE FOUND IN                          
C       ALDER, BOHR, HUUS, MOTTELSON AND WINTHER, REV. MOD. PHYS. 28,   
C       (1956) 432, FORMULA II E.83 .                                   
C     FOR CC THIS IS DONE SEPARATELY FOR EACH CHANNEL AND THE RESULT    
C     STORED IN THE CHANNEL DEFINITION ARRAY.                           
C                                                                       
  200 IF ( PINFSW ) WRITE(6,223)
  223 FORMAT ( ' CHN LX  LO-LI  MAXIMUM L NEEDED' )                     
      DLCRIT = LCRIT                                                    
      LX = LXMIN                                                        
      DO 249 NCHN = 2, NCHNDF                                           
      LI = LMAX                                                         
      IF ( .NOT. COUPSW ) GO TO 230                                     
      I = LCHNDF + (NCHN-1)*MCHNDF                                      
      IF ( ILLOC(I+14) .EQ. NOTDEF ) GO TO 249                          
      ETAS(2) = ALLOC4(I+5)                                             
      LX = ILLOC(I+14)                                                  
C                                                                       
 230  MLX = -LX                                                         
      DO 239 LDEL = MLX, LX, 2                                          
      ATERM = DABS( (ETAS(2)-ETAS(1))/ETAS(1) )                         
      BTERM = (LX+LDEL+1.D0)/2                                          
      CTERM = DLOG(DWCUT) - ATERM*DLCRIT - BTERM*DLOG(DLCRIT)           
      L = RTXLNX( ATERM, BTERM, CTERM, .1D0 ) + .5                      
      LI = MAX0( LI, L )                                                
      IF ( PINFSW ) WRITE(6,233) NCHN, LX, LDEL, L                        
  233 FORMAT ( I4, I3, I6, I13 )                                        
      IF ( PBUGSW ) WRITE(6,237) ATERM, BTERM, CTERM                      
  237 FORMAT ( X, T50, 3G15.5 )                                       
  239 CONTINUE                                                          
C                                                                       
C     LIMIT BY MAXLEX                                                   
C                                                                       
      LI = MIN0( LI, LMAX+MAXLEX )                                      
      IF ( COUPSW ) ILLOC(I+14) = LI                                    
      LIMOST = MAX0( LIMOST, LI )                                       
 249  CONTINUE                                                          
C                                                                       
  300 LOMOST = LIMOST + LXMAX                                           
C                                                                       
C     NOW GENERATE POINTERS TO THE B AND FF2 ARRAYS                     
C                                                                       
      IF ( COUPSW )  CALL GENBNX ( 2, NBINDX, MBINDX, ILLOC(LBINDX), NBA
     *SCP,  MBASCP, ILLOC(LBASCP), MBASDF, ILLOC(LBASDF), MCHNDF,  ALLOC
     *4(LCHNDF), NMBFAC, NMFFAC, MXLXGS, MXLXBF,  COULSW, PBUGSW )      
C                                                                       
C     EXPAND THE COULOMB PHASE SHIFT ARRAYS                             
C     WE ARE SLOPPY AND FIND SOME MORE THAN ARE REALLY NECESSARY        
C                                                                       
      LMXMX = LOMOST + 2*LXMAX                                          
      CALL IREDEF( LMXMX+1, ISIGS(1) )                                  
C                                                                       
      IF ( COUPSW ) GO TO 370                                           
C                                                                       
      CALL IREDEF( LMXMX+1, ISIGS(2) )                                  

      LSIGI = Z(ISIGS(1))                                               
      LSIGO = Z(ISIGS(2))                                               
      CI = ALLOC(LSIGI+LMAX)                                            
      CO = ALLOC(LSIGO+LMAX)                                            
      LMP1 = LMAX+1                                                     
      DO 329 L = LMP1, LMXMX                                            
      CI = CI + DATAN( ETAS(1)/L )                                      
      CO = CO + DATAN( ETAS(2)/L )                                      
      ALLOC(LSIGI+L) = CI                                               
      ALLOC(LSIGO+L) = CO                                               
  329 CONTINUE                                                          
C                                                                       
C     WE SETUP INTEGRAL(R TO INF) FF, FG, GF AND GG FOR LMIN TO LMAX,   
C     AND JUST FF FOR (0 TO INF) AND LMIN TO LIMOST.                    
C     FOR THE LATTER WE ALSO EVALUATE LIMOST AND EXPAND THE             
C     COULOMB PHASE SHIFT ARRAYS.                                       
C     IN EACH CASE WE MUST STRUCTURE THE ARRAYS TO BE THE SAME          
C     AS THE I(LX,LI,LO) ARRAYS.                                        
C                                                                       
C     THIS IS FOR NON-C.C. CALCULATIONS                                 
C     FIRST THE (R, INF) STUFF                                          
C                                                                       
      ICL1FF = NALLOC( NSMAT, 'FF1INTS ' )                              
      ICL1FG = NALLOC( NSMAT, 'FG1INTS ' )                              
      ICL1GF = NALLOC( NSMAT, 'GF1INTS ' )                              
      ICL1GG = NALLOC( NSMAT, 'GG1INTS ' )                              
      DO 339 I = 1, NSMAT                                               
      ALLOC(Z(ICL1FF)-1+I) = 0                                          
      ALLOC(Z(ICL1FG)-1+I) = 0                                          
      ALLOC(Z(ICL1GF)-1+I) = 0                                          
      ALLOC(Z(ICL1GG)-1+I) = 0                                          
  339 CONTINUE                                                          
      GO TO 400                                                         
C                                                                       
C     FOR COUPLED CHANNELS WE STORE IT ALL IN ONE                       
C     BIG ARRAY THAT IS NOT EVEN DEFINED IF THE                         
C     B FACTORS ARE NOT TO BE USED.                                     
C                                                                       
C     A SECOND WORK ARRAY FOR THE B-FACTORS IS SIMILARLY DEFINED        
C     BOTH POINTERS ARE SET TO 1 TO MAKE THNKS EASY IF THERE            
C     ARE TO BE NO BFACTORS.                                            
C                                                                       
 370  ISIGS(2) = NALLOC( LMXMX+1, 'COULSIGB' )                          
      ISMATS(2) = NALLOC( 2*LMXMX+2, 'SOPTICAL' )                       
      NUMJS(2) = NUMJS(1)                                               
C                                                                       
      ICL1FF = 1                                                        
      ICL1FG = 1                                                        
      IF ( NOBFAC .EQ. 1 ) GO TO 800                                    
C                                                                       
      ICL1FF = NALLOC( (2*NMBFAC*NUMLIS+1)/FACFR4, 'BFACTORS' )         
      CALL INIT4 ( ICL1FF, 0. )                                         
      ICL1FG = NALLOC( (4*NMBFAC+1)/FACFR4, 'BFACFORJ' )                
C                                                                       
C     IN C.C. CALCULATIONS,   LXMAX IS  MAX(J2) = MAX!L2-J!             
C     MXLXBF IS THE MAXIMUM LX USED IN BFACTORS                         
C     OTHERWISE IT HAS BEEN SET TO BE LXMAX                             
C                                                                       
  400 MAXDL1 = MAX0( 2, MXLXBF )                                        
      LDLDIM = MAXDL1 + 1                                               
      MAXDL1 = MAX0( MAXDL1, LXMAX )                                    
      LMNMN1 = MAX0( LMIN-MAXDL1, 0 )                                   
      IWRKST = NALLOC( 16*LDLDIM, 'COULSTRT' )                          
C                                                                       
      IF ( NOBFAC .EQ. 1 ) GO TO 500                                    
C                                                                       
      LMXMX = LMAX+LXMAX                                                
      LMXMX1 = LMAX + MAXDL1                                            
      IDIM1 = LDLDIM*(2*(LMXMX1-LMNMN1)+1)                              
      IWRKFF = NALLOC( 4*IDIM1, 'FFWORK ' )                             
      IDIM2 = MAX0( LMXMX1+MAXDL1, 4*MXCOUL ) + 1                       
      IWRKFI = NALLOC( 4*IDIM2, 'FIWORK ' )                             
      IWRKWK = NALLOC( MAX0(2*NPCOUL+4*MXCOUL, 2*(LMXMX1+MAXDL1)+1,  2*N
     *PCOUL+LMXMX1+MAXDL1)+1, 'COULWORK' )                              
C                                                                       
      LWRKFF = Z(IWRKFF)                                                
      LWRKFI = Z(IWRKFI)                                                
      LWRKWK = Z(IWRKWK)                                                
      LWRKST = Z(IWRKST)                                                
      LLIS = FACFR4*(Z(ILIS)-1)                                         
      LSIG1 = Z(ISIGS(1))                                               
      LSIG2 = Z(ISIGS(2))                                               
C                                                                       
      IF ( COUPSW ) GO TO 700                                           
C                                                                       
      LINDXS = Z(IINDXS)*FACFR4 - FACFR4                                
      LWRKFG = LWRKFF+IDIM1                                             
      LWRKGF = LWRKFG+IDIM1                                             
      LWRKGG = LWRKGF+IDIM1                                             
      LWRKFO = LWRKFI+IDIM2                                             
      LWRKGI = LWRKFO+IDIM2                                             
      LWRKGO = LWRKGI+IDIM2                                             
C                                                                       
      DO 439 LX = LXMIN, LXMAX, 2                                       
      LMNMN = MAX0( LMIN-(LX+1)/2, LX/2 )                               
      CALL COULIN ( LX+1, LX, LMNMN, LMXMX, ETAS(2), AKO,  ALLOC(LSIG2),
     *  ETAS(1), AKI, ALLOC(LSIG1), SUMMAX, .TRUE.,  ALLOC(LWRKFF), ALLO
     *C(LWRKFG), ALLOC(LWRKGF),  ALLOC(LWRKGG),  LDLDIM, ACCINE, COULML,
     * MXCOUL, NPCOUL,  ALLOC(LWRKWK), ALLOC(LWRKFI), ALLOC(LWRKFO),  AL
     *LOC(LWRKGI),ALLOC(LWRKGO),ALLOC(LWRKST),MOD(IPRINT/100,10),IRET)                                                     
      IF ( IRET .NE. 0 ) GO TO 9960                                     
      MAXDEL = MAX0(2, LX)                                              
C                                                                       
C     STORE THE INTEGRALS IN THE SAME ORDER AS THE I(LX,LI,LO)          
C     ARRAYS.                                                           
C     MULTIPLY IN THE CHARGE AND RADIUS FACTORS (BUT NOT THE BETA'S)    
C                                                                       
      K = LX+1 + NLX*(LX-INDXJS(3,IEXCIT)/2)                            
      KBASE = ILLOC(LINDXS+3*K-2)                                       
      LDELMN = ILLOC(LINDXS+3*K-1)                                      
      NDEL = ILLOC(LINDXS+3*K)                                          
      DO 439 ILI = 1, NUMLIS                                            
      LI = ILLOC(LLIS+ILI)                                              
      IDELMN = 1                                                        
      IF ( LI .LT. LX ) IDELMN = LX+1 - LI                              
      DO 439 IDEL = IDELMN, NDEL                                        
      LDEL = LDELMN-2 + 2*IDEL                                          
      LO = LI + LDEL                                                    
      ID = JISHFT( MAXDEL-LDEL, -1)                                     
      IL = LO+LI - 2*LMNMN                                              
      I1 = ID + IL*LDLDIM                                               
      I = NSPLI*(ILI-1) + KBASE-2 + IDEL                                
      ALLOC(Z(ICL1FF)+I) = -R2S(4)*ALLOC(LWRKFF+I1)                     
      ALLOC(Z(ICL1FG)+I) = -R2S(4)*ALLOC(LWRKFG+I1)                     
      ALLOC(Z(ICL1GF)+I) = -R2S(4)*ALLOC(LWRKGF+I1)                     
      ALLOC(Z(ICL1GG)+I) = -R2S(4)*ALLOC(LWRKGG+I1)                     
  439 CONTINUE                                                          
  490 CONTINUE                                                          
C                                                                       
C     NOW THE PURE COULOMB (FF) INTEGRALS OUT TO LOMOST                 
C                                                                       
  500 IDIM1 = NMLOLX*(LIMOST-LMIN+1)                                    
      ICL2FF = NALLOC( IDIM1, 'FF2INTS ' )                              
      LMXMX = LOMOST                                                    
      LMXMX1 = LMXMX + MAXDL1-LXMAX                                     
      DO 519 I = 1, IDIM1                                               
      ALLOC(Z(ICL2FF)-1+I) = 0                                          
  519 CONTINUE                                                          
C                                                                       
      IF ( .NOT. COULSW ) GO TO 990                                     
C                                                                       
      IDIM1 = LDLDIM*(2*(LMXMX1-LMNMN1)+1)                              
      IWRKFF = NALLOC( IDIM1, 'FFWORK ' )                               
      IDIM2 = MAX0( LMXMX1+MAXDL1, 4*MXCOUL ) + 1                       
      IWRKFI = NALLOC( IDIM2, 'FIWORK ' )                               
      IWRKFO = NALLOC( IDIM2, 'FOWORK ' )                               
      IWRKGI = NALLOC( IDIM2, 'GIWORK ' )                               
      IWRKGO = NALLOC( IDIM2, 'GOWORK ' )                               
      IWRKWK = NALLOC( MAX0(2*NPCOUL+4*MXCOUL,2*(LMXMX1+MAXDL1)+1,2*N
     * PCOUL+LMXMX1+MAXDL1)+1, 'COULWORK' )                              
      LINDXS = Z(IINDXS)*FACFR4 - FACFR4                                
C                                                                       
      DO 599 LX = LXMIN, LXMAX, 2                                       
      LMNMN = MAX0( LMIN-(LX+1)/2, LX/2 )                               
      CALL COULIN ( LX+1, LX, LMNMN, LMXMX, ETAS(2), AKO,  ALLOC(Z(ISIGS
     *(2))),  ETAS(1), AKI, ALLOC(Z(ISIGS(1))), 0.D0, .FALSE.,  ALLOC(Z(
     *IWRKFF)), DUMMY, DUMMY, DUMMY,  LDLDIM, ACCINE, COULML, MXCOUL, NP
     *COUL,  ALLOC(Z(IWRKWK)), ALLOC(Z(IWRKFI)), ALLOC(Z(IWRKFO)),  ALLO
     *C(Z(IWRKGI)), ALLOC(Z(IWRKGO)), ALLOC(Z(IWRKST)),  MOD(IPRINT/100,
     * 10), IRET)                                              
      IF ( IRET .NE. 0 ) GO TO 9960                                     
      MAXDEL = MAX0(2, LX)                                              
      K = LX+1 + NLX*(LX-INDXJS(3,IEXCIT)/2)                            
      KBASE = ILLOC(LINDXS+3*K-2)                                       
      LDELMN = ILLOC(LINDXS+3*K-1)                                      
      NDEL = ILLOC(LINDXS+3*K)                                          
      DO 599 LI = LMIN, LIMOST                                          
      IDELMN = 1                                                        
      IF ( LI .LT. LX ) IDELMN = LX+1 - LI                              
      DO 599 IDEL = IDELMN, NDEL                                        
      LDEL = LDELMN-2 + 2*IDEL                                          
      LO = LI + LDEL                                                    
      ID = JISHFT( MAXDEL-LDEL, -1)                                     
      IL = LO+LI - 2*LMNMN                                              
      I1 = ID + IL*LDLDIM                                               
      I = NSPLI*(LI-LMIN) + KBASE-2 + IDEL                              
      ALLOC(Z(ICL2FF)+I) = -R2S(4)*ALLOC(Z(IWRKFF)+I1)                  
  599 CONTINUE                                                          
      Z(IWRKFO) = -Z(IWRKFO)                                            
      Z(IWRKGI) = -Z(IWRKGI)                                            
      Z(IWRKGO) = -Z(IWRKGO)                                            
      Z(IWRKFF) = -Z(IWRKFF)                                            
      Z(IWRKFI) = -Z(IWRKFI)                                            
      Z(IWRKWK) = -Z(IWRKWK)                                            
      Z(IWRKST) = -Z(IWRKST)                                            
      GO TO 990                                                         
C                                                                       
C     FOR COUPLED CHANNELS WE LOOP THROUGH BINDEX AND COMPUTE           
C     EACH REQUIRED SET.                                                
C     ALSO HERE WE MUST COMPUTE ALL THE COULOMBP PHASE FACTORS          
C     EACH TIME.                                                        
C     ALL OF THIS IS DONE IN THE SUBROUTINE                             
C                                                                       
 700  LBINDX = FACFR4*(Z(IBINDX)-1) + 1                                 
      LCL1FF = FACFR4*(Z(ICL1FF)-1) + 1                                 
      LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2)                                 
C                                                                       
      CALL SETBFC ( NBINDX, MBINDX, ILLOC(LBINDX),  MCHNDF, ILLOC(LCHNDF
     *), ALLOC4(LCHNDF),  NUMLIS, ILLOC(LLIS+1), R2S, LMXMX,  ALLOC(LSIG
     *1), ALLOC(LSIG2),  SUMMAX, .TRUE., 2, NMBFAC, ALLOC4(LCL1FF),  ALL
     *OC(LWRKFF), IDIM1, LDLDIM, ALLOC(LWRKWK),  ALLOC(LWRKFI), IDIM2, A
     *LLOC(LWRKST), 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     REESTABLISH ELASTIC PHASE SHIFTS                                  
C                                                                       
 800  CALL DSGMAL ( ETAS(1), LOMOST+LXMAX, ALLOC(Z(ISIGS(1))) )         
C                                                                       
C     NOW FIND ALL THE REQUIRED F'S AND G'S                             
C                                                                       
      I = 4*NBASDF*NUMLIS/FACFR4                                        
      IFG = NALLOC ( I, 'FANDG ' )                                      
      NFS(1) = IFG                                                      
      CALL INIT4 ( IFG, 0. )                                            
      L2P1 = LMAX+LXMAX+1                                               
      IWRKFG = NALLOC ( 6*L2P1, 'F&GWORK ' )                            
      LCHNDF = FACFR4*(Z(ICHNDF)-1) + 1                                 
      LCHNDF = LCHNDF + ILLOC(LCHNDF+2)                                 
      LBASDF = FACFR4*(Z(IBASDF)-1) + 1                                 
      LBASDF = LBASDF + ILLOC(LBASDF+2)                                 
C                                                                       
      CALL SETFG ( NCHNDF, MCHNDF, ILLOC(LCHNDF),  ALLOC4(LCHNDF), NBASD
     *F, MBASDF, ILLOC(LBASDF),  NUMLIS, ALLOC(Z(ILIS)), ALLOC(Z(IFG)), 
     * MAX0(0, LMIN-LXMAX), L2P1, ALLOC(Z(IWRKFG)),  SUMMAX-NBACK*RSTEPS
     *(1), SUMMAX, IRTN )                                               
C                                                                       
      Z(IWRKFG) = -Z(IWRKFG)                                            
C                                                                       
C                                                                       
C     ALLOCATIONS FOR COUPLN                                            
C                                                                       
C     HOMOGENEOUS SOLUTION STORAGE                                      
      NWRDS=(2*(NUMPT-NPTMIN)*NBASDF+FACFR4-1)/FACFR4                   
      IHOMO=NALLOC(NWRDS,'CCHOMO ')                                     
C     PARTICULAR INTEGRAL STORAGE                                       
      NWRDS=((NUMPT-NPTMIN)*NBASDF+FACFR4-1)/FACFR4                     
      IINHR=NALLOC(NWRDS,'CCINHR ')                                     
      IINHI=NALLOC(NWRDS,'CCINHI ')                                     
C     R.H.S.(ONLY 1 FOR SEQENTIAL ITERATION)                            
      IRHSR=NALLOC(NUMPT,'CCRHSR ')                                     
      IRHSI=NALLOC(NUMPT,'CCRHSI ')                                     
      DO 929 I = 1, NUMPT                                               
      ALLOC(Z(IRHSR)+I-1) = 0                                           
      ALLOC(Z(IRHSI)+I-1) = 0                                           
 929  CONTINUE                                                          
C     SEQUENCE OF STORED S-MATRIX ELEMENTS                              
      NWRDS= 4*NBASDF                                                   
      ISMSQ=NALLOC(NWRDS,'CCSMSQ ')                                     
C     ELEMENTS OF THE PADE TABLE                                        
      NWRDS=6*((MAXITR+1)/2)*NBASDF                                     
      IPADE=NALLOC(NWRDS,'PADE ')                                       
C                                                                       
      IF ( ISAVSM .NE. 0 ) ISMTSV = NALLOC( 2*MAXITR*NBASDF,  'SMATITER'
     * )                                                                
C                                                                       
  990 IRTN = 1                                                          
      RETURN                                                            
C                                                                       
C                                                                       
 9960 WRITE(6,9963) IRET                                                  
 9963 FORMAT ( '0**** ERROR RETURN FROM COULIN:', I12 )                 
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE COUPLN(IRET)                                           
C                                                                       
C     ITERATIVE SOLUTION OF MULTI-CHANNEL COUPLED EQUATIONS             
C                                                                       
C     2/7/80 FIRST VERSION MRB                                          
C     4/17/80 - BETTER TIMING; MINOR CHANGES - S.P.                     
C     4/19/80 - RHS ARRAYS ARE REAL*8 - S.P.                            
C     4/24/80 - USE IPARM3 AS NFIRST OFFSET; PBUGSW - S.P.              
C     4/27/80 - NPTMIN IS LEAST POINT TO USE; MOVE ALLOCATIONS - S.P.   
C     6/3/80 - DIMS PASSED TO CCMTCH, DRIVE, GETBFC FOR CDC - S.P.      
C     6/11/80 - USE DIMAG INSTEAD OF IMAG - S.P.                        
C     7/28/80 - USE IODEP TO HELP CRAY - S.P.                           
C     8/1/80 - CALL SETLOG - S.P.                                       
C     8/25/80 - USE AIMAG, NOT DIMAG - S.P.                             
C     6/24/81 - REMOVE TRI, SANE USE OF NCHNDF, JT - S.P.               
C               FIX BUG STORING O'TH ORDER ELASTIC S-MATRIX - S.P.      
C     10/27/81 - JBLOCK TO STORE J; WRITEWAVE STUFF - S.P.              
C     11/19/81 - USE WAVELJ TO COUPUTE THE DIAGONAL POT - S.P.          
C     3/12/82 - ALLOW BLENDING OF NEW AND OLD SOLUTIONS - S.P.          
C     3/15/82 - ****** TEMPORARY REAL*8 VERSION *****                   
C     3/15/82 - ADD GRADUAL SCALLING OF COUPLING STRENGTH               
C     3/16/82 - ADD BLOCK ITERATION - S.P.                              
C     4/10/82 - BACK TO REAL*4 VERSION - S.P.                           
C     6/25/82 - SAVE COMPUTED S MATRICES FOR EACH ITERATION - 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) )                                                          
      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                                                             
      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    
      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 )                                
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      COMMON /KANDM/ AKI, AKO, REDMI, REDMO, RIMAX, ROMAX, ISIGS(2), RSC
     *TS(2), ASCTS(2), RCSCTS(2) ,ISMATS(2), LOMOST, LCRIT, ISCTMN, ISCT
     *CR, ETAS(2), RCSCTP(2), RCSCTT(2), LCRITS(2), RATMSS(2)           
      DIMENSION AKS(2), REDMS(2), RMAXS(2)                              
      EQUIVALENCE ( AKI, AKS(1) ), ( REDMI, REDMS(1) ), ( RIMAX, RMAXS(1
     *) )                                                               
      LOGICAL*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)                             
C                                                                       
      COMPLEX*8 CFAC                                                    
      REAL*4 CFACR, CFACI                                               
	DIMENSION DU(1)
      LOGICAL PBUGSW, CONVSW, BLOKSW                                    
      CHARACTER*8 ACCWRD(3)                                             
      DATA ACCWRD/'BLOCKREL', 'ABSOLUTE', 'RELATIVE'/                   
C                                                                       
      TRIGHT=0                                                          
      TUOPT = 0                                                         
      TINHO=0                                                           
      TWAVE=0                                                           
      TNORM = 0                                                         
      TITER = 0                                                         
      NMINHO = 0                                                        
      NMINPT = 0                                                        
      FLPINH = 0                                                        
      FLPRHS = 0                                                        
      FLPUOP = 0                                                        
      FLPNRM = 0                                                        
      IPRNT = MOD(IPRINT,10)                                            
      WRITE(6,3) REACT, ELAB, HEADER                                      
  3   FORMAT ( X, T60, 'P T O L E M Y' /  1X, 'COMPUTATION OF COUPLED 
     *INELASTIC CHANNELS S-MATRICES',  T95, 'WIN A FEW, LOOSE A FEW' /  
     *X, 45A1, 'ELAB =', F7.2, ' MEV', 5X, 65A1 / )                   
C *************** TEMPORARY FOLLOWS ******************************      
      BLEND = PAR620(15)                                                
      IF ( BLEND .EQ. UNDEF ) BLEND = 1                                 
      VSCALE = PAR620(14)                                               
      IF ( VSCALE .EQ. UNDEF ) VSCALE = 0                               
      BLOKSW = ISW3 .EQ. 1                                              
      WRITE(6,23) ACCWRD(CONVRG+1), ACCURA, BLEND, VSCALE                 
  23  FORMAT ( 1X, A8, ' ACCURACY REQUIREMENT IS', G12.3 /  ' BLENDING F
     *ACTOR IS', G15.5 /  ' COUPLING STRENGTH SCALED BY 1 - (', G14.5,  
     *')**ITERATION.' )                                                 
      IF ( .NOT. BLOKSW ) WRITE(6,27)
 27   FORMAT ( ' USING SEQUENTIAL ITERATION' / )                        
      IF ( BLOKSW ) WRITE(6,28)
 28   FORMAT ( ' USING BLOCK (BORN) ITERATION' / )                      
      NLINE = 10                                                        
      PBUGSW = IPRNT .GE. 4                                             
C                                                                       
C                                                                       
C                                                                       
C     NO SPIN ORBIT FORCE                                               
C                                                                       
      ISPUN=1                                                           
C                                                                       
C     SOME VARIABLES                                                    
C                                                                       
C     SUMMAX = ASYMPTOPIA = MATCHING POINT                              
C     NUMPT = NUMBER OF GRID POINTS FROM 0 TO SUMMAX INCLUDING THE      
C             LAST POINT.  THIS IS THE DIMENSION OF THE ONE-DIMENSIONAL 
C             ARRAYS SUCH AS WAVR, RHSR, AND THE POTENTIALS             
C     NSTEP = THE NUMBER OF STEPS = NUMPT-1                             
C     NPTMIN = THE NUMBER OF POINTS THAT ARE NEVER USED BECAUSE EVEN    
C              THE WAVEFUNC FOR LMIN-LXMIN DOESN'T GO IN THAT FAR.      
C              NPTMIN=0 MEANS ALL STEPS ARE USED.                       
C     NPTSAV = NUMPT-NPTMIN = THE NUMBER OF VALUES OF THE HOMO FUNCS    
C              AND SOLUTIONS THAT MUST BE SAVED.  THIS IS THE FIRST     
C              DIMENSION OF THE HOMO, INHR AND INHI ARRAYS.             
C     NPSTRT = NPTMIN+1 = THE FIRST POINT TO BE USED.                   
C                                                                       
C     ALLOC(LSMSQ) - S MATRICES FOR CURRENT AND PREVIOS ITERATION,      
C                    RESPECTIVELY.                                      
      NSTEP = NUMPT-1                                                   
      NPTSAV = NUMPT-NPTMIN                                             
      NPSTRT = NPTMIN+1                                                 
C                                                                       
C************** TEMPORARY ****************************                  
C                                                                       
      LBASDF=FACFR4*Z(IBASDF)-FACFR4+1                                  
      NBASDF=ILLOC(LBASDF)                                              
      NUMINH = NPTSAV*NBASDF                                            
      IF ( BLOKSW ) IBLOCK = NALLOC( (2*NUMINH+1)/FACFR4, 'BLOCKSAV' )  
      IF ( BLOKSW ) ISBLOK = NALLOC( 2*NBASDF, 'SBLOCKSA' )             
C                                                                       
      CALL SETLOG ( 2*(LOMOST+LXMAX) )                                  
C                                                                       
C     WE WILL HAVE NO MORE  ALLOC CALLS SO GET ADDRESSES                
C                                                                       
C  ******* TEMP SET REAL*8 IN NEXT THREE LINES                          
      LHOMO = FACFR4*Z(IHOMO)-FACFR4+1 - 2*NPTMIN                       
      LINHR = FACFR4*Z(IINHR)-FACFR4+1 - NPTMIN                         
      LINHI = FACFR4*Z(IINHI)-FACFR4+1 - NPTMIN                         
      IF ( BLOKSW ) LBLOCK = FACFR4*Z(IBLOCK)-FACFR4                    
      IF ( BLOKSW ) LSBLOK = Z(ISBLOK)                                  
      LRHSR=Z(IRHSR)                                                    
      LRHSI=Z(IRHSI)                                                    
      LSMSQ=Z(ISMSQ)                                                    
      LPADE=Z(IPADE)                                                    
      LLIS=FACFR4*Z(ILIS)-FACFR4                                        
      LFG=FACFR4*Z(NFS(1))-FACFR4+1                                     
      LWAVR=Z(IWAVR)                                                    
      LWAVI=Z(IWAVI)                                                    
      LWRK1 = LWAVR-1                                                   
      LWRK2 = LWAVI-1                                                   
      LVRL1=Z(IRLVS(1))                                                 
      LVRL2=Z(IRLVS(2))                                                 
      LVIM1=Z(IIMVS(1))                                                 
      LVIM2=Z(IIMVS(2))                                                 
      LNUCH=FACFR4*Z(INUCH)-FACFR4+1                                    
      LCOULH=FACFR4*Z(ICOULH)-FACFR4+1                                  
      LCENT1=Z(ICENTR(1))                                               
      LCENT2=Z(ICENTR(2))                                               
      LCL1FF=FACFR4*Z(ICL1FF)-FACFR4+1                                  
      LCL1FG=FACFR4*Z(ICL1FG)-FACFR4+1                                  
      LBINDX=FACFR4*Z(IBINDX)-FACFR4+1                                  
      LSMATS=Z(ISMATS(1))                                               
      LCHNDF=FACFR4*Z(ICHNDF)-FACFR4+1                                  
      LBASDF=FACFR4*Z(IBASDF)-FACFR4+1                                  
      LBASCP=FACFR4*Z(IBASCP)-FACFR4+1                                  
      NCHNDF=ILLOC(LCHNDF)                                              
      NBASDF=ILLOC(LBASDF)                                              
      NBASCP=ILLOC(LBASCP)                                              
      MCHNDF=ILLOC(LCHNDF+1)                                            
      MBASDF=ILLOC(LBASDF+1)                                            
      MBASCP=ILLOC(LBASCP+1)                                            
      LCHNDF=LCHNDF+ILLOC(LCHNDF+2)                                     
      LBASDF=LBASDF+ILLOC(LBASDF+2)                                     
      LBASCP=LBASCP+ILLOC(LBASCP+2)                                     
      LSMATR=Z(ISMATR)-1                                                
      LSMATI=Z(ISMATI)-1                                                
      LINDXS=FACFR4*(Z(IINDXS)-1)                                       
      LELCUP=Z(IELCUP)-2                                                
C                                                                       
      IF ( IWRTWV .EQ. 0 ) GO TO 80                                     
      THISDT = DATE(THISDT)                                             
      WRITE ( 1, 53 ) HEADER, REACT, ELAB, THISDT,  NBASDF, NUMPT, SUMMA
     *X, RSTEPS(1), AKI, REDMI                                          
 53   FORMAT ( 65A1 / 45A1, F12.3, 1X, A8 /  2I5, 2G25.15 / 2G25.15 )   
C                                                                       
C     INTRODUCE MAJOR LOOP OVER TOTAL ANGULAR MOMENTUN J                
C               /
 80   DO 999 IJ=1,NUMLIS                                                
C                                                                       
C     INITIALISE RELEVANT ARRAYS TO ZERO                                
C                                                                       
      CONVSW = MOD( IWRTWV, 10) .EQ. 2                                  
      DO 84 I=1,NUMINH                                                  
      ALLOC4(LINHR+NPTMIN+I-1)=0.                                       
      ALLOC4(LINHI+NPTMIN+I-1)=0.                                       
 84   CONTINUE                                                          
      NWRDS = 4*NBASDF                                                  
      DO 87 I=1,NWRDS                                                   
      ALLOC(LSMSQ+I-1)=0.                                               
 87   CONTINUE                                                          
C                                                                       
C                                                                       
      JT = ILLOC(LLIS+IJ)                                               
      J = 2*JT                                                          
      NELCUP=LELCUP+2*IJ                                                
      NADD = NBASDF                                                     
      IF ( IPRNT .EQ. 0 ) NADD = 1                                      
      IF ( NLINE+NADD+3 .LE. 59 ) GO TO 100                             
      NLINE = 5                                                         
C                                                                       
C     CALCULATE B FACTORS                                               
C                                                                       
 100  IF (NOBFAC.EQ.0)CALL GETBFC(IJ,J,NBACK*STEPSZ,SUMMAX,  NMBFAC, ALL
     *OC4(LCL1FF), ALLOC4(LCL1FG), MBINDX, ILLOC(LBINDX),  MCHNDF, ILLOC
     *(LCHNDF),ALLOC4(LCHNDF),MBASDF,ILLOC(LBASDF),  NBASDF,ALLOC4(LFG))
     *                                                                  
C                                                                       
C     LOOP OVER CHANNEL ARRAY INPUT                                     
C                                                                       
      DO 199 I1=1,NCHNDF                                                
      LABEL=(I1-1)*MCHNDF+LCHNDF                                        
      CKC=ALLOC4(LABEL+6)                                               
C                                                                       
C     INTRODUCE POINTERS I2,I3 FOR BASLBL ARRAY                         
C                                                                       
      I2=ILLOC(LABEL+7)                                                 
      I3=ILLOC(LABEL+8)                                                 
      I3=I3+I2-1                                                        
C                                                                       
C     LOOP OVER BASLBL ARRAY                                            
C                                                                       
      DO 194 I4=I2,I3                                                   
      LABEL1=(I4-1)*MBASDF+LBASDF                                       
      J1=ILLOC(LABEL1+1)                                                
      L1X2=ILLOC(LABEL1+2)                                              
      L1X2 = L1X2+J                                                     
      IF ( L1X2 .LT. 0 ) GO TO 194                                      
      L1 = L1X2/2                                                       
C                                                                       
C     INTRODUCE POINTERS I5,I6 TO GENERATE BASCPL ARRAY                 
C                                                                       
      I5=ILLOC(LABEL1+3)                                                
      I6=ILLOC(LABEL1+4)                                                
      I6=I6+I5-1                                                        
C                                                                       
C     LOOP  OVER BASCPL ARRAY TO CALCULATE UNKNOWN QUANTITIES           
C                                                                       
      DO 120 I7=I5,I6                                                   
      LABEL2=(I7-1)*MBASCP+LBASCP                                       
      IMULT=ILLOC(LABEL2+3)                                             
      IPT=ILLOC(LABEL2+1)                                               
      J2=ILLOC((IPT-1)*MBASDF+LBASDF+1)                                 
      L2X2=ILLOC((IPT-1)*MBASDF+LBASDF+2)                               
      L2X2=L2X2+J                                                       
      CALL AKFCR(L1X2,J1,L2X2,J2,IMULT,J,ALLOC4(LABEL2+7))              
 120  CONTINUE                                                          
C                                                                       
C     GENERATE HOMOGENEOUS WAVEFUNCTION                                 
C                                                                       
      NWP=2                                                             
C     FOR INELASTIC SCATTERING USE NWP=1                                
      IF(I2.EQ.1)NWP=1                                                  
C                                                                       
      HS(NWP)=CKC*RSTEPS(NWP)                                           
C     LABEL FOR COULOMB FUNCTIONS                                       
      LABEL2=LFG+4*(I4-1)+4*NBASDF*(IJ-1)                               
C                                                                       
      IF(NWP.EQ.1)CALL WAVELJ(L1,ISPUN,1,0,DU(1),ALLOC4(LABEL2),DU(1), A
     *LLOC(LWAVR),ALLOC(LWAVI),ALLOC(LVRL1),ALLOC(LVIM1),ALLOC(LCENT1)) 
      IF(NWP.EQ.2)CALL WAVELJ(L1,ISPUN,2,0,DU(1),ALLOC4(LABEL2),DU(1), A
     *LLOC(LWAVR),ALLOC(LWAVI),ALLOC(LVRL2),ALLOC(LVIM2),ALLOC(LCENT2)) 
C     STARTING LABEL                                                    
C                                                                       
C     STARTING VALUE FOR THIS BASIS STATE                               
C                                                                       
      NFIRST = MAX0( LASTNF(NWP) + NFIROF, NPTMIN+2 )                   
      ILLOC(LABEL1+5) = NFIRST                                          
      ISTRT = NFIRST-2                                                  
C                                                                       
C     LABEL FOR STORING HOMOGENEOUS WAVEFUNCTION                        
      II = 2*(I4-1)*NPTSAV                                              
      IF ( PBUGSW ) WRITE(6,123) J,I4,NFIRST,ISTRT,NSTEP,II,NPTSAV,
     * NPTMIN, LHOMO, LWAVR                                             
 123  FORMAT (' J, BASIS, NFIRST =', I5, '/2', 10I9 )                   
CRACDIR$ IVDEP                                                          
      DO 125 I7 = ISTRT, NSTEP                                          
      ALLOC4(LHOMO+II+2*I7) = ALLOC(LWAVR+I7)                           
      ALLOC4(LHOMO+II+2*I7+1) = ALLOC(LWAVI+I7)                         
 125  CONTINUE                                                          
      IF(I2.NE.1)GO TO 180                                              
C                                                                       
C     STORE ELASTIC WAVEFUNCTION FOR 0TH GUESS                          
C     STORE ELASTIC HOMOGENEOUS S-MATRIX                                
C                                                                       
      ALLOC(LSMSQ) = ALLOC(LSMATS+2*L1)                                 
      ALLOC(LSMSQ+2*NBASDF) = ALLOC(LSMATS+2*L1)                        
      ALLOC(LSMSQ+1) = ALLOC(LSMATS+2*L1+1)                             
      ALLOC(LSMSQ+1+2*NBASDF) = ALLOC(LSMATS+2*L1+1)                    
      II = II/2                                                         
CRACDIR$ IVDEP                                                          
      DO 179 I7 = ISTRT, NSTEP                                          
      ALLOC4(LINHR+II+I7) = ALLOC(LWAVR+I7)                             
      ALLOC4(LINHI+II+I7) = ALLOC(LWAVI+I7)                             
 179  CONTINUE                                                          
180   CONTINUE                                                          
 194  CONTINUE                                                          
 199  CONTINUE                                                          
C                                                                       
      IF ( .NOT. BLOKSW ) GO TO 300                                     
      DO 209 I = 1, NUMINH                                              
      ALLOC4(LBLOCK+I) = ALLOC4(LINHR+NPTMIN+I-1)                       
      ALLOC4(LBLOCK+NUMINH+I) = ALLOC4(LINHI+NPTMIN+I-1)                
 209  CONTINUE                                                          
      DO 219 I = 1, NBASDF                                              
      ALLOC(LSBLOK+2*I-2) = ALLOC(LSMSQ+2*I-2)                          
      ALLOC(LSBLOK+2*I-1) = ALLOC(LSMSQ+2*I-1)                          
 219  CONTINUE                                                          
C                                                                       
C     START ITERATIVE SOLUTION OF INHOMOGENEOUS EQUATIONS               
C                                                                       
 300  CONTINUE
      VFACTR = 1                                                        
      DO 899 ITR=1,MAXITR                                               
C                                                                       
      VFACTR = VFACTR*VSCALE                                            
      VMULT = 1 - VFACTR                                                
C                                                                       
C     LOOP OVER CHANNEL ARRAY INPUT                                     
C      DO ELASTIC CHANNEL LAST                                          
C                                                                       
      DO 699 I1=1,NCHNDF                                                
      ICHAN = I1+1                                                      
      IF ( I1 .EQ. NCHNDF ) ICHAN = 1                                   
      LABEL=(ICHAN-1)*MCHNDF+LCHNDF                                     
C                                                                       
      NWP = 2                                                           
      IF ( ICHAN .EQ. 1 ) NWP = 1                                       
C                                                                       
      HS(NWP) = ALLOC4(LABEL+6)*RSTEPS(NWP)                             
C     INTRODUCE POINTERS I2,I3 FOR BASLBL ARRAY                         
      I2=ILLOC(LABEL+7)                                                 
      I3=ILLOC(LABEL+8)                                                 
      I3=I3+I2-1                                                        
C                                                                       
C     LOOP OVER BASLBL ARRAY AND PICK UP RELEVANT QUANTITIES            
C                                                                       
      DO 689 I4=I2,I3                                                   
      LABEL1=(I4-1)*MBASDF+LBASDF                                       
      L1X2 = ILLOC(LABEL1+2)                                            
      L1X2 = L1X2+J                                                     
      IF ( L1X2 .LT. 0 ) GO TO 689                                      
      L1 = L1X2/2                                                       
      NFIRST=ILLOC(LABEL1+5)                                            
C     INTRODUCE POINTERS I5,I6 TO ANALYSE BASCPL ARRAY                  
      I5=ILLOC(LABEL1+3)                                                
      I6=ILLOC(LABEL1+4)                                                
      I6=I6+I5-1                                                        
C                                                                       
C     CONSTRUCT DRIVING TERM OF INHOMOGENEOUS EQUATION                  
C                                                                       
      CALL DRIVE ( ALLOC(LRHSR),ALLOC(LRHSI),I5,I6,NFIRST,ITR,  MBASCP, 
     *ILLOC(LBASCP), ALLOC4(LBASCP), ALLOC4(LNUCH),  ALLOC4(LCOULH), NUM
     *PT, NPTSAV, ALLOC4(LINHR), ALLOC4(LINHI),  FLP, VMULT )           
C                                                                       
C     IF NO RHS WAS COMPUTED, THERE IS NOTHING TO DO                    
C                                                                       
      IF ( FLP .EQ. 0 ) GO TO 689                                       
C                                                                       
      FLPRHS = FLPRHS + FLP                                             
C                                                                       
C     CONSTRUCT DIAGONAL POTENTIAL IN FORM USEFULL FOR                  
C     NUMEROV ALGORITHUM AND SOLVE INHOMOGENEOUS EQUNS.                 
C                                                                       
C     THE STORING TECHNIQUE IS TAKEN FROM WAVELJ PLUS DRIVING TERM      
C     WE COMPUTE 12*WAVEFUNCTION                                        
C     THIS IS CORRECTED FOR IN CONSTRUCTING R.H.S AND C-FACTOR          
C                                                                       
      ISTRT=(I4-1)*NPTSAV                                               
      NHOR=LHOMO+2*ISTRT                                                
      NINR=LINHR+ISTRT                                                  
      NINI=LINHI+ISTRT                                                  
      IF ( BLOKSW ) NINR = LBLOCK - NPTMIN+ISTRT+1                      
      IF ( BLOKSW ) NINI = NINR + NUMINH                                
      ISTRT=NFIRST-2                                                    
C                                                                       
C     GET FIRST TWO 12*U'S                                              
C                                                                       
      II=ISTRT+1                                                        
      DO 539 I7=ISTRT,II                                                
      ALLOC(LWRK1+I7+1) = ALLOC4(NINR+I7)                               
      ALLOC(LWRK2+I7+1) = ALLOC4(NINI+I7)                               
539   CONTINUE                                                          
C                                                                       
C     CONSTRUCT DIAGIONAL POTENTIAL AND STORE IN WORK ARRAY             
C                                                                       
      CALL WAVELJ ( L1, JP, NWP, -NFIRST, DU(1), DU(1), DU(1),  ALLOC(LW
     *RK1+1), ALLOC(LWRK2+1),  ALLOC(Z(IRLVS(NWP))), ALLOC(Z(IIMVS(NWP))
     *),  ALLOC(Z(ICENTR(NWP))) )                                       
C                                                                       
      IF ( IPRNT .GE. 9 ) WRITE(6,543) I4,ISTRT,(ALLOC(LWRK1+I7+1),AL
     *LOC(LWRK2+I7+1), I7 = ISTRT, II ),  ALLOC(LWRK1+II+4), ALLOC(LWRK2
     *+II+4),  ALLOC(LRHSR+NFIRST-1), ALLOC(LRHSI+NFIRST-1)             
 543  FORMAT ( ' ++', I3, I5, 8G15.6 )                                  
C                                                                       
C     START ACTUAL INTGRATION OF INHOMOGENEOUS EQUATION                 
C                                                                       
      FLPUOP = FLPUOP + 3*(NSTEP-NFIRST)                                
C                                                                       
      CALL WAVINH ( NFIRST, NSTEP, ALLOC(LWRK1+1), ALLOC(LWRK2+1),  ALLO
     *C(LRHSR), ALLOC(LRHSI), FLP, NSTEP+5 )                            
      FLPINH = FLPINH + FLP                                             
      NMINHO = NMINHO + 1                                               
      NMINPT = NMINPT + NSTEP - NFIRST +1                               
C                                                                       
C     CALCULATE MATCHING CONDITION                                      
C                                                                       
      CALL CCMTCH(IJ,J,I4,ALLOC(LSMSQ),CFAC,NBASDF,ALLOC(LWRK1+1),  ALLO
     *C(LWRK2+1),NPTSAV,ALLOC4(LHOMO),MBASDF,ILLOC(LBASDF),MBASCP,  ILLO
     *C(LBASCP),  ALLOC4(LBASCP),MCHNDF,ALLOC4(LCHNDF),ALLOC4(LCL1FG),  
     *MBINDX, ILLOC(LBINDX), ALLOC4(LFG), VMULT )                       
C                                                                       
      IF ( PBUGSW ) WRITE(6,593) ITR,J,I4,ALLOC(LSMSQ+2*I4-2),ALLOC(L
     *SMSQ+2*I4-1) ,CFAC                                                
593   FORMAT(' CCMTCH,ITER,J,I4=',2I5,'/2',I5,3X, 'S=',2G15.5,3X,'C=',2G
     *15.5)                                                             
C                                                                       
C     IF NECESSARY, PATCH UP FOR BLOCK BY PRESERVING THE OLD S-MATRIX   
C                                                                       
      IF ( .NOT. BLOKSW ) GO TO 610                                     
      DO 609 I = 1, 2                                                   
      TEMP = ALLOC(LSMSQ+2*I4+I-3)                                      
      ALLOC(LSMSQ+2*I4+I-3) = ALLOC(LSBLOK+2*I4+I-3)                    
      ALLOC(LSBLOK+2*I4+I-3) = TEMP                                     
 609  CONTINUE                                                          
C                                                                       
C     CALCULATE NORMALISED WAVEFUNCTION AND BLEND IT IN                 
C                                                                       
 610  CFACR=REAL(CFAC)                                                  
      CFACI=AIMAG(CFAC)                                                 
      IF ( BLEND .NE. 1 ) GO TO 640                                     
CRACDIR$ IVDEP                                                          
      DO 634 I=ISTRT, NSTEP                                             
      ALLOC4(NINR+I)=ALLOC(LWRK1+I+1) + (CFACR*ALLOC4(NHOR+2*I)  -CFACI*
     *ALLOC4(NHOR+2*I+1))                                               
      ALLOC4(NINI+I)=ALLOC(LWRK2+I+1) + (CFACR*ALLOC4(NHOR+2*I+1)  +CFAC
     *I*ALLOC4(NHOR+2*I))                                               
 634  CONTINUE                                                          
      TEMP = 8                                                          
      GO TO 650                                                         
C                                                                       
C     HERE WE ARE REALLY BLENDING                                       
C                                                                       
 640  TEMP = 1-BLEND                                                    
      DO 645 I = ISTRT, NSTEP                                           
      ALLOC4(NINR+I) = TEMP*ALLOC4(NINR+I) + BLEND*(  ALLOC(LWRK1+I+1) +
     * (CFACR*ALLOC4(NHOR+2*I)  -CFACI*ALLOC4(NHOR+2*I+1)) )            
      ALLOC4(NINI+I) = TEMP*ALLOC4(NINI+I) + BLEND*(  ALLOC(LWRK2+I+1) +
     * (CFACR*ALLOC4(NHOR+2*I+1)  +CFACI*ALLOC4(NHOR+2*I)) )            
 645  CONTINUE                                                          
      TEMP = 14                                                         
  650 CONTINUE
      FLPNRM = FLPNRM + TEMP*(NSTEP-ISTRT+1)                            
C                                                                       
      IF ( .NOT. CONVSW ) GO TO 689                                     
C                                                                       
C     WRITE OUT THE WAVEFUNCTIONS AND RHS                               
C                                                                       
      IF ( IWRTWV .GE. 10 .AND. ICHAN .NE. 1 ) GO TO 689                
      I = NFIRST-1                                                      
      WRITE ( 1, 663 ) JT, ITR, ICHAN, I4, I,  ( ALLOC4(NINR+I7), ALLOC4
     *(NINI+I7), ALLOC(LRHSR+I7),  ALLOC(LRHSI+I7), I7 = ISTRT, NSTEP ) 
 663  FORMAT ( 5I5 / ( 4G16.8 ) )                                       
C                                                                       
C     END OF LOOPS OVER ALL CHANNELS AND BASIS STATES                   
C                                                                       
689   CONTINUE                                                          
699   CONTINUE                                                          
C                                                                       
C     NOW MOVE OVER THE NEW S-MATRICES FOR BLOCK ITERATION              
C                                                                       
      NWRDS = 2*NBASDF                                                  
      IF ( .NOT. BLOKSW ) GO TO 810                                     
      DO 804 I = 1, NWRDS                                               
      ALLOC(LSMSQ+I-1) = ALLOC(LSBLOK+I-1)                              
 804  CONTINUE                                                          
C                                                                       
C     IF DESIRED, SAVE THE S-MATRICES FOR EACH ITERATION                
C                                                                       
 810  IF ( ISAVSM .EQ. 0 ) GO TO 820                                    
      LSMTSV = Z(ISMTSV) + 2*NBASDF*(ITR-1) - 1                         
      DO 814 I = 1, NWRDS                                               
      ALLOC(LSMTSV+I) = ALLOC(LSMSQ+I-1)                                
 814  CONTINUE                                                          
C                                                                       
C     TEST FOR CONVERGENCE OF S-MATRIX ELEMENTS                         
C                                                                       
 820  CALL CCONV(ALLOC(LSMSQ), ITR, ITEST, NBASDF, ALLOC(LPADE),  (MAXIT
     *R+1)/2,  ALLOC(NELCUP), ALLOC(LSMATR), ALLOC(LSMATI), ILLOC(LINDXS
     *),  ILLOC(LCHNDF), MCHNDF, ILLOC(LBASDF), MBASDF, IJ, NCHNDF,  JT,
     * NLINE )                                                          
      IF ( ITEST .NE. 1 ) GO TO 850                                     
C                                                                       
C     WE HAVE CONVERGE, MUST WE DO ONE MORE TO WRITE IT OUT?            
C                                                                       
      IF ( IWRTWV .EQ. 0 .OR. CONVSW ) GO TO 950                        
      CONVSW = .TRUE.                                                   
C                                                                       
C     FOR BLOCK, TRANSFER THE NEW SET OF SOLUTIONS NOW                  
C                                                                       
 850  IF ( .NOT. BLOKSW ) GO TO 899                                     
      DO 859 I = 1, NUMINH                                              
      ALLOC4(LINHR+NPTMIN+I-1) = ALLOC4(LBLOCK+I)                       
      ALLOC4(LINHI+NPTMIN+I-1) = ALLOC4(LBLOCK+NUMINH+I)                
 859  CONTINUE                                                          
C                                                                       
C     END OF ITERATION LOOP                                             
C                                                                       
899   CONTINUE                                                          
      ITR = MAXITR                                                      
 950  CONTINUE
 999  CONTINUE                                                          
C                                                                       
C     FREE ARRAYS                                                       
C                                                                       
      IF(MOD(IPRINT/100,10).GE.1)GO TO 2000                             
C                                                                       
      IF ( BLOKSW ) Z(IBLOCK) = -Z(IBLOCK)                              
      Z(IHOMO)=-Z(IHOMO)                                                
      Z(IINHR)=-Z(IINHR)                                                
      Z(IINHI)=-Z(IINHI)                                                
      Z(IRHSR)=-Z(IRHSR)                                                
      Z(IRHSI)=-Z(IRHSI)                                                
      Z(ISMSQ)=-Z(ISMSQ)                                                
      Z(IWAVR)=-Z(IWAVR)                                                
      Z(IWAVI)=-Z(IWAVI)                                                
      Z(IPADE)=-Z(IPADE)                                                
      Z(INUCH) = -Z(INUCH)                                              
      Z(ICOULH) = -Z(ICOULH)                                            
      Z(ICL1FF) = -Z(ICL1FF)                                            
      Z(ICL1FG) = -Z(ICL1FG)                                            
      Z(NFS(1)) = -Z(NFS(1))                                            
      DO 1699 I = 1, 2                                                  
      Z(IRLVS(I)) = -Z(IRLVS(I))                                        
      Z(IIMVS(I)) = -Z(IIMVS(I))                                        
      Z(ICENTR(I)) = -Z(ICENTR(I))                                      
 1699 CONTINUE                                                          
2000  CONTINUE                                                          
C                                                                       
      IF ( ISAVSM .NE. 0 ) CALL IREDEF ( 2*NBASDF*ITR, ISMTSV )         
      RETURN                                                            
      END                                                               
      SUBROUTINE CTRAN(IRET)                                            
C                                                                       
C     INPUT ROUTINE FOR GENERAL MULTIPLE/BETA VALUES                    
C                                                                       
C     STRUCTURE OF DATA IN ALLOCATOR IS                                 
C     PREFACE                                                           
C     LDATA +0 #BLOCKS                                                  
C           +1 BLOCK LENGTH                                             
C           +2 PREFACE LENGTH                                           
C     +3 FOR TARGET:  0 = NOT SPECIFIED; > 0 IS POINTER (RELATIVE TO    
C           LTRANS) OF FIRST ENTRY.                                     
C     +4 FOR PROJECTILE:  SAME AS +3 BUT FOR PROJECTILE.                
C     +5 NO OF TARGET SETS                                              
C     +6 NO OF PROJECTILE SETS                                          
C     +7 IS BE(UP) (-1) OR BETAC (0) BEING USED FOR TARGET              
C     +8 IS BE(UP) (-1) OR BETAC (0) BEING USED FOR PROJECTILE          
C     FOR EACH DATA SET                                                 
C     LABEL +0 MULTIPOLE                                                
C     +1 BELX/BETAC                                                     
C     +2 BETAN                                                          
C                                                                       
C     12/79 - FIRST VERSION - MRB                                       
C     1/16/80 - STORE ADDRESS IN CCBLK - S.P.                           
C     7/3/80 - FIX ORDER OF NXVALF CALLS, COMMENTS - S.P.               
C     7/7/80 - CHANGE DEFS OF +3 AND +4 - S.P.                          
C     12/10/80 - -1 FOR BE - 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 /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
      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                                                                 
      DATA NUMKEY/8/                                                    
	CHARACTER*8 KEYS(8)
      DATA KEYS/'TARGET','PROJECTI','MULTIPOL','BELX','BEUP','BE', 
     *'BETAC','BETAN'/                                                     
      DATA LENDAT /3/,LAL/9/                                            
	CHARACTER*8 AKEY
      REAL*8 NAME8                                                      
      DATA NAME8 / 'TRANSITI' /                                         
	CHARACTER*8 NAME9/'TRANSITI'/
      COMMON/NAMCOM/ANAMES(1)                                           
      INTEGER GIVEAL                                                    
C
      ICD3I=1                                                           
      IRET=0                                                            
      ICG=1                                                             
      ICH1=0                                                            
10    ICH=0                                                             
      IBN=0                                                             
      IBC=0                                                             
      IMT=0                                                             
      IF(ICG.EQ.2)GO TO 90                                              
      I=NAMLOC(NAME9)                                                   
      IF(I.NE.0)Z(I)=-Z(I)                                              
      ITRANS=GIVEAL(IWRDS)                                              
      LDATA=Z(ITRANS)                                                   
      ANAMES(ITRANS)=NAME8                                              
      LTRANS=FACFR4*(LDATA-1)+1                                         
      LABEL=LTRANS+LAL                                                  
      ILLOC(LTRANS+3)=0                                                 
      ILLOC(LTRANS+4)=0                                                 
      ILLOC(LTRANS+5)=0                                                 
      ILLOC(LTRANS+6)=0                                                 
      ILLOC(LTRANS+7) = NOTDEF                                          
      ILLOC(LTRANS+8) = NOTDEF                                          
20    CALL FITKEY(AKEY,&90,&900,&900,&900)                              
      GO TO 900                                                         
C                                                                       
C     (ENCOUNTERED LETS GO                                              
C     FIRST READ THE KEYWORD LIST                                       
C                                                                       
C     *** NOTE ***  HERE WE HAVE IPT = 1, 2 FOR TARGET, PROJECTILE,     
C     BUT IN BASCPL AND POTRHS, IT IS THE OTHER WAY AROUND (ENGLISHMEN  
C     CAN BE MOST PECULIAR).                                            
C                                                                       
90    IORDER=0                                                          
      IPT = 0                                                           
100   CALL NXWORD(AKEY,&699,&900,&900)                                  
      DO 110 I=1,NUMKEY                                                 
      IF(KEYS(I).NE.AKEY)GO TO 110                                      
      IF ( I .GE. 3 .AND. IPT .EQ. 0 ) GO TO 930                        
      GO TO (200,200,300,350,350,350,400,450 ),I                        
110   CONTINUE                                                          
      GO TO 900                                                         
200   ILLOC(LTRANS+2+I) = LABEL-LTRANS                                  
      IF(IORDER.NE.0)GO TO 930                                          
      IPT = I                                                           
      GO TO 100                                                         
300   IORDER=IORDER+1                                                   
      IMT=IORDER                                                        
      GO TO 100                                                         
C     BE                                                                
350   IORDER=IORDER+1                                                   
      IBC=IORDER                                                        
      ILLOC(LTRANS+6+IPT) = -1                                          
      GO TO 100                                                         
C     BETAC                                                             
400   IORDER=IORDER+1                                                   
      IBC=IORDER                                                        
      ILLOC(LTRANS+6+IPT) = 0                                           
      GO TO 100                                                         
C     BETAN                                                             
450   IORDER=IORDER+1                                                   
      IBN=IORDER                                                        
      GO TO 100                                                         
C                                                                       
C     END OF KEYWORDS, GO ON TO DATA                                    
C                                                                       
699   CONTINUE                                                          
      LABEL=LABEL-LENDAT                                                
C                                                                       
C     READ THE NEXT SET OF DATA                                         
C                                                                       
700   LABEL=LABEL+LENDAT                                                
      ILLOC(LABEL)=NOTDEF                                               
      ALLOC4(LABEL+1)=UNDEF                                             
      ALLOC4(LABEL+2)=UNDEF                                             
      DO 750 I=1,IORDER                                                 
      IF(I.EQ.IMT)GO TO 720                                             
      IF(I.EQ.IBC)GO TO 730                                             
      CALL NXVALF(TEMP, &910, &800, &910,&890)                          
      ALLOC4(LABEL+2)=TEMP                                              
      GO TO 750                                                         
720   CALL NXHINT(INT,&910,&800,&885)                                   
      ILLOC(LABEL)=INT                                                  
      GO TO 750                                                         
730   CALL NXVALF(TEMP, &910, &800, &910,&890)                          
      ALLOC4(LABEL+1)=TEMP                                              
750   CONTINUE                                                          
      ICH=ICH+1                                                         
      GO TO 700                                                         
C                                                                       
C     SEMI-COLON FOUND, GO TO NEXT NUCLEUS                              
C                                                                       
 800  ILLOC(LTRANS+4+IPT) = ICH                                         
      ICH1=ICH                                                          
      ICG=ICG+1                                                         
      GO TO 10                                                          
885   CALL FITKEY(AKEY,&900,&900,&890,&900)                             
      GO TO 900                                                         
 890  ILLOC(LTRANS+4+IPT) = ICH                                         
      ILLOC(LTRANS)=ICH1+ICH                                            
      ILLOC(LTRANS+1)=LENDAT                                            
      ILLOC(LTRANS+2)=LAL                                               
      IWRDS=(LABEL-LTRANS)/FACFR4+1                                     
      IL=CHOPIT(IWRDS)                                                  
      IRET=1                                                            
      RETURN                                                            
C                                                                       
900   WRITE(6,901)(KEYS(I),I=1,NUMKEY)                                  
901   FORMAT ( '0**** DATA NOT ENCLOSED IN PARENTHESIS OR KEYWORD',  ' M
     *ISSPELLED, DATA KEYWORDS ARE:' // ( 1X, 10A9 ) )                  
      RETURN                                                            
910   WRITE(6,911)I                                                     
911   FORMAT ( '0**** ERROR IN READING THE',I5,  ' NUMERICAL DATA VALUE 
     *IN A SET' )                                                       
      RETURN                                                            
930   WRITE(6,931)                                                      
931   FORMAT ( '0**** MUST USE PROJECTILE OR TARGET KEYWORD FIRST' )    
      RETURN                                                            
      END                                                               
      SUBROUTINE CUBMAP (MAPTYP, XLO, XMID, XHI, GAMMA, ARGS, WTS, NPTS)
C                                                                       
C     CUBIC-SINH MAPPING OF _-1,1_ INTO _XLO,XHI_                       
C                                                                       
C     MAPTYP CONTROLS THE TYPE OF MAP:                                  
C     0 - LINEAR MAP                                                    
C     1 - CUBIC SINH MAP                                                
C     2 - RATIONAL SINH MAP                                             
C     3 - LINEAR SINH MAP                                               
C                                                                       
C     0 MAPPED ON XMID; GAMMA SCALES SINH TRANSFORMATION SUCH           
C     THAT GAUSS POINTS ARE PILED UP MOST DENSELY AROUND XMID           
C      MHM 2/19/75                                                      
C     IF MAPTYP.NE.1 REPLACE CUBIC-SINH BY RATIONAL-SINH MAP            
C     MHM 2/21/75                                                       
C     3/4/75 - LINEAR MAP ADDED - S.P.                                  
C     3/5/75 - MAPTYP MADE AN ARGUMENT                                  
C     6/28/75 - USE GAUSSL                                              
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
CDC      ALLOCLEVEL ARGS,WTS                                            
C                                                                       
      DIMENSION ARGS(1),WTS(1)                                          
C                                                                       
C     FOLLOWING IS ARCSINH(GAMMA)                                       
C                                                                       
      IF ( GAMMA .GT. 1.D-6 ) TAU=DLOG(GAMMA+DSQRT(GAMMA**2+1.D0))      
      IF ( GAMMA .LE. 1.D-6 ) TAU = GAMMA*(1 - GAMMA**2/6)              
C                                                                       
      CALL GAUSSL ( NPTS, ARGS, WTS )                                   
      XLEN=XHI-XLO                                                      
      XADD=XLO+XHI                                                      
C                                                                       
      JGO = MAPTYP + 1                                                  
      GO TO ( 100, 200, 300, 400 ), JGO                                 
C                                                                       
C     LINEAR MAP                                                        
C                                                                       
 100  DO 159 I = 1, NPTS                                                
      ARGS(I) = XLO + (.5*XLEN)*(ARGS(I)+1)                             
      WTS(I) = (.5*XLEN) * WTS(I)                                       
 159  CONTINUE                                                          
      RETURN                                                            
C                                                                       
C     CUBIC-SINH MAPPING                                                
C                                                                       
 200  XMID=DMAX1 (XMID,XLO+XLEN/7.D0)                                   
      XMID=DMIN1 (XMID,.5*XADD)                                         
      A=.5*XADD-XMID                                                    
      B=.5*XLEN                                                         
      C=.5*XADD                                                         
      DO 259 I=1,NPTS                                                   
      TU=TAU*ARGS(I)                                                    
      XI=DSINH(TU)/GAMMA                                                
      ARGS(I)=A*(XI**2-1.D0)*(XI+1.D0)+B*XI+C                           
  259 WTS(I)=WTS(I)*(TAU/GAMMA)*DCOSH(TU)*((3.D0*XI-1.D0)*(XI+1.D0)*A+B)
      RETURN                                                            
C                                                                       
C     RATIONAL-SINH MAPPING                                             
C                                                                       
C     THIS MAP IS DEFINED FOR ALL   XLO < XMID < XHI                    
C     HOWEVER, FOR   XMID = (XLO+XHI)/2   IT REDUCES TO A LINEAR        
C     MAP, AND FOR   XMID > (XLO+XHI)/2   IT BUNCHES POINTS AT THE      
C     HIGH END.                                                         
C                                                                       
  300 A=-XMID*XLEN                                                      
      B=XLEN                                                            
      C=XMID*XADD-2.D0*XLO*XHI                                          
      D=XADD-2.D0*XMID                                                  
      DO 359 I=1,NPTS                                                   
      TU=TAU*ARGS(I)                                                    
      SH=DSINH(TU)                                                      
      DENOM=B-(D/GAMMA)*SH                                              
      ARGS(I)=(-A+(C/GAMMA)*SH)/DENOM                                   
  359 WTS(I)=WTS(I)*(TAU/GAMMA)*DCOSH(TU)*((B*C-A*D)/DENOM**2)          
      RETURN                                                            
C                                                                       
C     LINEAR SINH MAPPING                                               
C                                                                       
 400  DO 459 I = 1, NPTS                                                
      TU = TAU*ARGS(I)                                                  
      ARGS(I) = XLO + (.5*XLEN) * (DSINH(TU)/GAMMA + 1)                 
      WTS(I) = (.5*XLEN*TAU/GAMMA) * DCOSH(TU) * WTS(I)                 
 459  CONTINUE                                                          
      RETURN                                                            
C                                                                       
      END                                                               
      SUBROUTINE CUPAB ( IORDER, IPT, LXX2S, LXX2,  RMENUC, RMECOU, RNUC
     *, IZPT, RMEGN, RMEGC, IPT1 )                                      
C                                                                       
C     COMPUTES THE  <JA, JBIGA!! G(LX) !!JB, JBIGB>                     
C                                                                       
C     THESE FORMULAS ARE ALL GENERAL                                    
C     SEE NOTES EQUATIONS  47, 70, 46, 71                               
C                                                                       
C     IORDER - ORDER OF COUPLING (1 OR 2)                               
C     IPT - NUCLEUS BEING COUPLED:                                      
C        1 = PROJECTILE (1ST OR 2ND ORDER)                              
C        2 = TARGET                                                     
C     LXX2S(2) - 2*MULTIPOLES.  FOR FIRST ORDER THERE IS ONLY           
C              LXX2S(1)=LXX2.  FOR SECOND ORDER LXX2, LXX2S(1),         
C              AND LXX2S(2) OBEY TRIANGLE RULES.                        
C     LXX2 - 2*(TOTAL L-TRANSFER)                                       
C     RMENUC(2) - INPUT < J !! ALPHA(NUC) !! J >                        
C     RMECOU(2) - INPUT < J !! E(LX) !! J >                             
C     RNUC(2) - THE NUCLEAR RADII.                                      
C     IZPT(2) = THE ATOMIC NUMBERS FOR P, T                             
C     RMEGN - THE NUCLEAR MATRIX ELEMENT IS TO BE STORED HERE           
C     RMEGC - THE COULOMB MATRIX ELEMENT                                
C     IPT1 - SET AS FOLLOWS FOR INGRST:                                 
C           1 - 1ST ORDER PROJECTILE EXCITATION                         
C           2 - 1ST ORDER TARGET                                        
C           3 - 2ND ORDER PROJECTILE                                    
C           4 - 2ND ORDER TARGET                                        
C           5 - 2ND ORDER MUTUAL                                        
C                                                                       
C     1/8/81 - CUPAB MADE FROM CUPROT - S.P.                            
C     8/2/81 - MAKE SURE XC, XN ARE ALWAYS DEFINED - S.P.               
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      DIMENSION LXX2S(2), RMENUC(2), RMECOU(2), RNUC(2)                 
      DIMENSION IZPT(2)                                                 
C                                                                       
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
      COMMON/FACTRL/MAXFAC,ISPACE,TABLE(57)                             
C                                                                       
      LOGICAL TBIT                                                      
C                                                                       
      F(L1, L2, L) = DSQRT( (L1+1.D0)*(L2+1.D0)/(16*PI*(L+1.D0)) )  * CL
     *EBSH( L1, L2, 0, 0, L, 0 )                                        
C                                                                       
      LX = LXX2/2                                                       
      XN = 1                                                            
      XC = 1                                                            
C                                                                       
C     CHECK FOR ORDER OF COUPLING                                       
C                                                                       
      IPT1 = IPT                                                        
      IF(IORDER.EQ.2)GO TO 300                                          
C                                                                       
C     FIRST AND SECOND ORDER AT THE SAME VERTEX                         
C                                                                       
 200  SGNFAC = +1                                                       
      IF ( IPT .EQ. 1 ) SGNFAC = (-1)**LX                               
      RMEGN = SGNFAC*RNUC(IPT)*XN*RMENUC(IORDER)                        
      RMEGC = SGNFAC*4*PI/((LXX2+1)*3.D0*IZPT(IPT))  * XC*RMECOU(IORDER)
     *                                                                  
      RETURN                                                            
C                                                                       
C     SECOND-ORDER EXCITATION                                           
C                                                                       
 300  IPT1 = IPT+2                                                      
      IF(IPT.GT.2)GO TO 500                                             
C                                                                       
C     NON-MUTUAL SECOND-ORDER EXCITATION (PROJECTILE OR TARGET)         
C     A FEX EXTRA FACTORS ON TOP OF FIRST ORDER FOR NUCLEAR             
C     ALSO SOUBLE IF LX1 ^= LX2                                         
C                                                                       
      IF ( LXX2S(1) .NE. LXX2S(2) ) XC = 2                              
      XN = XC * RNUC(IPT)*F( LXX2S(1), LXX2S(2), LXX2 )                 
      GO TO 200                                                         
C                                                                       

C     SECOND ORDER MUTUAL EXCITATION OF TARGET AND PROJECTILE           
C                                                                       
 500  IPT1=5                                                            
C                                                                       
      SGNFAC = (-1)**(LXX2S(1)/2)                                       
      RMEGN = SGNFAC * 2*F( LXX2S(1), LXX2S(2), LXX2 )  * RNUC(1)*RNUC(2
     *)*RMENUC(1)*RMENUC(2)                                             
C                                                                       
      RMEGC = 0                                                         
      IF ( LXX2 .NE. LXX2S(1)+LXX2S(2) ) RETURN                         
      RMEGC = SGNFAC * 4*PI*RT4PI  * TABLE(LXX2+2)/(TABLE(LXX2S(1)+2)*TA
     *BLE(LXX2S(2)+2) )  / (3*(LXX2+1)*IZPT(1)*IZPT(2))  * RMECOU(1)*RME
     *COU(2)                                                            
      RETURN                                                            
      END                                                               
      SUBROUTINE CUPSPN ( IRTN, LXX2, IPT, SCHN,  LXX2S, JNUC, RMEGN, RM
     *EGC,  XN, XC )                                                    
C                                                                       
C     CALCULATES CHANNEL-SPIN COUPLING MATRIX ELEMENTS                  
C                                                                       
C     THESE ARE THE MODEL-INDEPENDANT COUPLING COEFFICENTS THAT         
C     CONVERT THE NUCLEAR SPIN BASIS (JA, MA, JBIGA, MBIGB) TO THE      
C     CHANNEL SPIN BASIS (S(ALPHA), M(ALPHA)).                          
C                                                                       
C     IRTN IS SET AS FOLLOWS:                                           
C        +1 - ALL IS O.K.                                               
C         0 - AN ERROR MESSAGE WAS PRINTED (NONE PRESENTLY)             
C     LXX2 - 2*(TOTAL L-TRANSFER)                                       
C     IPT - NUCLEUS BEING COUPLED:                                      
C        1 = PROJECTILE (1ST OR 2ND ORDER)                              
C        2 = TARGET                                                     
C        3 = BOTH PROJECTILE AND TARGET (2ND ORDER MUTUAL)              
C     SCHN(2) - 2*(TOTAL CHANNEL SPINS) ON LEFT (1) AND RIGHT (2)       
C                 THIS IS AN INTEGER ARRAY                              
C     LXX2S(2) - 2*MULTIPOLES.  FOR FIRST ORDER THERE IS ONLY           
C              LXX2S(1)=LXX2.  FOR SECOND ORDER LXX2, LXX2S(1),         
C              AND LXX2S(2) OBEY TRIANGLE RULES.                        
C     JNUC(2,2) - 2*(THE NUCLEAR SPINS).  THIS IS JNUC(IPT,I)           
C              WHERE IPT=1,2 FOR PROJECTILE, TARGET, AND                
C              I=1,2 FOR LEFT AND RIGHT SIDES.                          
C     RMEGN, RMEGC - INPUT VALUES OF THE REDUCED MATRIX ELEMENTS        
C            <JA, JBIGA!! G(LX) !!JB, JBIGB>                            
C         AS DEFINED BY EQ. 47, 70, 46, 71 FOR BOTH NUCLEAR AND         
C         COULOMB.                                                      
C     XN - THE NUCLEAR MATRIX ELEMENT IS TO BE STORED HERE              
C     XC - THE COULOMB MATRIX ELEMENT                                   
C                                                                       
C                                                                       
C     THE FOLLOWING TRIANGLE CONDITIONS ARE SATISFIED AND NEED          
C     NOT BE CHECKED IN THIS ROUTINE.                                   
C                                                                       
C     1)  ALL ORDERS:                                                   
C        S1, S2, LX     S1, S2 ARE THE CHANNEL SPINS IN SCHN.           
C        JP1, JT1, S1   JT1 IS JNUC(2,1), ETC.                          
C        JP2, JT2, S2                                                   
C     2)  FIRST ORDER:                                                  
C        JP1, JP2, LX   OR   JT1, JT2, LX  AS APPROPRIATE.              
C     3)  SECOND ORDER:                                                 
C        A) AT SAME VERTEX:                                             
C           JP1, JP2, LX  OR  JT1, JT2, LX                              
C        B) MUTUAL:                                                     
C           JP1, JP2, LX1                                               
C           JT1, JT2, LX2                                               
C                                                                       
C                                                                       
C                                                                       
C     DEC 1979 FIRST VERSION M.R.B.                                     
C     JAN 1980 PUT IN APPROPIATE FACTORS FOR FIRST ORDER B COEFF.       
C     29/1/80/ PUT IN ALL RADIUS PARAMETERS INTO X FACTORS              
C     6/3/80 - FIXES SUGGESTED BY MARK AS I LEFT ARGONNE - S.P.         
C     7/2/80 - SMALL FIXES TO FORMATS AND VAR. NAMES - S.P.             
C     7/3/80 - PRINT BELX AND Q, DEFINE BETAS BY EQUAL DEF. LENGTHS - S.
C      7/4/80 - FIX BUGS IN BELX-BETA CONVERSIONS - S.P.                
C     7/7/80 - FIX BUG IN CTRANS PTR, CHANGE LTRANS TO STRT OF ARRAY,   
C              BELX IS NOLONGER IN CTRANS ARRAY - S.P.                  
C     7/8/80 - FIX BUGS IN FINDING WHICH NUCLEUS IS 1ST ORDER COUPLED   
C              COMPINE IET AND IRET INTO IRTN - S.P.                    
C     7/10/80 - PUT IN MARK'S 2ND ORDER FIXES - S.P.                    
C     8/25/80 - COPY /RT4PI INTO 2ND ORDER MUTUAL FROM MARK - S.P.      
C     9/11/80 - FIX 2ND ORDER BUGS IN SEARCHING TRANS TABLE - S.P.      
C     9/19/80 - SOME TESTS MOVED TO BASCPL - S.P.                       
C     9/21/80 - FIX SOME BUGS IN SECOND-ORDER MUTUAL EXCITATION - S.P.  
C     9/23/80 - "HERMITICITY" (-)**LX REMOVED FROM 1ST ORDER - S.P.     
C     10/2/80 - MASSIVE SIMPLIFICATION; RENAMED CUPROT - S.P.           
C     12/11/80 - K-QUANTA ADDED.                                        
C     1/8/81 - MODEL INDEPENDANT STUFF SPLIT OFF INTO CUPSPN - S.P.     
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      DIMENSION LXX2S(2), JNUC(2,2), BETACS(2), BETANS(2),  RCOUL(2), RN
     *UC(2), KNUC(2,2), ENUC(2,2)                                       
      INTEGER SCHN(2)                                                   
C                                                                       
C     CHECK FOR MUTUAL EXCITATION                                       
C                                                                       
      IF ( IPT .EQ. 3 ) GO TO 500                                       
C                                                                       
C                                                                       
C     FIRST AND SECOND ORDER AT THE SAME VERTEX                         
C                                                                       
 200  RME = DSQRT( (SCHN(1)+1.D0)*(SCHN(2)+1) )  * SIXJ( SCHN(1), SCHN(2
     *), LXX2,  JNUC(IPT,2), JNUC(IPT,1), JNUC(3-IPT,1) )  * (-1)**((LXX
     *2+JNUC(1,IPT)+JNUC(2,IPT)+SCHN(3-IPT))/2)                         
C                                                                       
 300  XN = RME*RMEGN                                                    
      XC = RME*RMEGC                                                    
      IRTN = 1                                                          
      RETURN                                                            
C                                                                       
C     SECOND ORDER MUTUAL EXCITATION OF TARGET AND PROJECTILE           
C                                                                       
 500  MUL=LXX2S(1)+LXX2S(2)                                             
      IPT1=5                                                            
C                                                                       
      RME = DSQRT( (SCHN(1)+1)*(SCHN(2)+1.D0)*(LXX2+1.D0) )  * WIG9J( SC
     *HN(1), SCHN(2), LXX2,  JNUC(1,1), JNUC(1,2), LXX2S(1),  JNUC(2,1),
     * JNUC(2,2), LXX2S(2) )                                            
C                                                                       
      GO TO 300                                                         
C                                                                       
      END                                                               
      SUBROUTINE DATAIN(IRET)                                           
C                                                                       
C  INPUT ROUTINE FOR DATA KEYWORD.  PROCESSES   DATA ( SPECIFICATIONS ) 
C                                                                       
C  STURCTURE OF DATA IN ALLOCATOR IS  :                                 
C                                                                       
C     POINTER WORD CONTENTS                                             
C                                                                       
C     PREFACE:                                                          
C                                                                       
C     LDATA4   +0  TOTAL NUMBER OF DATA POINTS.                         
C              +1  TOTAL NUMBER OF DATA SETS ( DIFFERENT ELAB'S )       
C              +2  NUMBER OF WORDS IN PREFACE                           
C              +3  NUMBER OF WORDS IN EACH KEY                          
C              +4  NUMBER OF WORDS IN EACH HEADER                       
C                                                                       
C     FOR EACH DATA SET                                                 
C                                                                       
C     LEKEY    +0   (POINTS TO JUST BEFORE THE DATA SET)                
C              +1   0 = MB ERRORS; 1 = % ERRORS; 2 = SIGMA UNITS        
C               2   0 = SIGMA/RUTHERFORD; 1 = SIGMA IN MB;              
C                   2 = LAB SIGMA IN MB.                                
C               3   0 = NO POLARIZATION; 1 = POLARAIZATION DATA.        
C               4   0 = ANGLES ARE IN C.M.; 1 = LAB ANGLES.             
C              +5   NUMBER OF WORDS FOR EACH ANGLE                      
C     LEHED    +0   NUMBER OF DATA POINTS IN THIS SET                   
C              +1   OVERALL WEIGHT FOR THIS SET.                        
C              +2   RENORMALIZATION OF THIS SET.                        
C              +3   LAB-ANGLE SHIFT.                                    
C              +4   ELAB FOR THIS SET.                                  
C              +5   IZP FOR THIS DATA SET                               
C              +6   IZT                                                 
C              +7   AMP                                                 
C              +8   AMT                                                 
C              +9-  REACTION SPECIFICATION FOR                          
C               14   THIS DATA SET                                      
C             +20   JSP - PROJECTILE SPIN * 2                           
C             +21   JST - TARGET SPIN * 2                               
C             +22   LSKIP - 0=NOT SET; 1=NONIDENTICAL, 2=IDENTICAL PARTI
C             +23   LBASE - 0=BOSONS, 1=FERMIONS, NOMEANING IF LSKIP=1  
C             +24   RATMAS = MP/MT (KINEMATIC MASSES)                   
C             +25   MXCGP = PROJECTILE G.S. MASS EXCESS                 
C             +26   MXCGT                                               
C             +27   E*P = PROJECTILE EXCITATION ENERGY                  
C             +28   E*T                                                 
C             +29   0=ELAB, 1=ECM WAS ENTERED (0 MAY MEAN NEITHER)      
C                                                                       
C     FOR EACH ANGLE                                                    
C                                                                       
C     LADATA   +0   ANGLE IN DEGREES (C.M. OR LAB - SEE ABOVE)          
C              +1   ERROR AS DESCRIBED ABOVE.                           
C              +2   CROSS SECTIONS AS DESCRIBED ABOVE.                  
C              +3   POLARIZATION.                                       
C                                                                       
C     THE ENTIRE OBJECT IS TREATED AS REAL*4 OR INTEGER*4 AND THUS      
C     WORD MEANS 4-BYTE WORD.                                           
CDCC     ON THE CDC EACH WORD IS A 60-BIT WORD.                         
C                                                                       
C                                                                       
C   FIRST VERSION  8/20/75  D.G.                                        
C     10/11/75 - INDICATE WHEN ELAB IS NOT DEFINED                      
C     10/22/75 - CHECK FOR FUNNY OR INVALID ANGLES                      
C     10/31/75 - SIMPLIFIED NUMBER OF POINTS COUNTING                   
C     11/20/75 - LAB-ANGLE SHIFT                                        
C     7/31/76 - CDC/IBM, REAL*4, LABANGLE.                              
C     4/14/77 - LABSIGMA AND ANGLE; SIGMA MADE GENERAL; CHANNEL         
C     4/25/77 - IDENTICAL PARTICLES; LENGTHS STORED IN DATA             
C     5/4/79 - STORE RATMAS, MASS EXCESS, E* - S.P.                     
C     12/27/79 - STANDARD MORTRAN - RPG                                 
C     5/3/82 - ECM INPUT, CHECK FOR DOUBLE SPECIFICATION - 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) )                                                          
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                                                            
C                                                                       
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      INTEGER REACT4(10)                                                
      EQUIVALENCE ( REACT(1), REACT4(1) )                               
C                                                                       
      COMMON / INTRNL / UNDEF                                           
C                                                                       
      CHARACTER*8 KEYS(18), NAME8, ANAMES, AKEY                         
      DATA NUMKEY/18/                                                   
      DATA KEYS /'ELAB','ECM','ANGLE','MBERROR','PERCENTE','POLARIZA', 
     *'SIGMA', 'SIGMATOR', 'WEIGHT', 'RENORMAL',  'ANGLESHI', 
     *'LABANGLE','CMANGLE', 'CMSIGMA', 'LABSIGMA','ERROR','CHANNEL', 
     *'RENORM' /                                                           
      DATA NAME8 / 'DATA' /                                             
      COMMON/NAMCOM/ANAMES(75)                                          
C                                                                       
      LOGICAL MORESW                                                    
      INTEGER KEY(4)
      DATA KEY/4*0/
      INTEGER GIVEAL, CHOPIT                                            
C                                                                       
      DATA LENPRE /5/, LENKEY /5/, LENHED /30/                          
C                                                                       
      IRET=0                                                            
      IANGLE=0                                                          
      ISIGMA=0                                                          
      IERROR=0                                                          
      IPOL=0                                                            
      ICNT=0                                                            
      IAT=0                                                             
      NPTSE=0                                                           
      NPTS = 0                                                          
      I = NAMLOC(NAME8)                                                 
      IF ( I .NE. 0 ) Z(I) = -Z(I)                                      
      IDATA = GIVEAL(IWRDS)                                             
      ANAMES(IDATA)=NAME8                                               
      LDATA = Z(IDATA)                                                  
      LDATA4 = FACFR4*(LDATA-1) + 1                                     
      ALLOC(LDATA) = 0                                                  
      ILLOC(LDATA4+2) = LENPRE                                          
      ILLOC(LDATA4+3) = LENKEY                                          
      ILLOC(LDATA4+4) = LENHED                                          
      LEKEY = LDATA4 + LENPRE-1                                         
C                                                                       
      CALL FITKEY(AKEY,&90,&900,&900,&900)                              
      GO TO 900                                                         
C                                                                       
C  (  ENCOUNTERED  --  LETS GO                                          
90    IORDER=0                                                          
      LEHED = LEKEY + LENKEY+1                                          
      LADATA = LEHED + LENHED                                           
      ALLOC4(LEHED+1) = 1                                               
      ALLOC4(LEHED+2) = 1                                               
      ALLOC4(LEHED+3) = 0                                               
      IELAB = 0                                                         
100   CALL NXWORD(AKEY,&800,&900,&900)                                  
      ANGLAS = 0                                                        
105   DO 110 I=1,NUMKEY                                                 
      IF(KEYS(I).NE.AKEY)GO TO 110                                      
      GO TO (200, 210, 250, 300, 310, 400, 450, 470, 500, 510, 520,  260
     *, 265, 460, 465, 320, 550, 510 ), I                               
110   CONTINUE                                                          
      GO TO 900                                                         
C                                                                       
C  ELAB                                                                 
C                                                                       
 200  IELAB = 0                                                         
      GO TO 220                                                         
 210  IELAB = 1                                                         
 220  CALL NXVAL ( ELAB, &900, &900, &900 )                             
      GO TO 100                                                         
C                                                                       
C  ANGLE - MEANS C.M. ANGLE.  HOWEVER, USE OF THE COMMENTED CARD        
C       WOULD CAUSE ANGLE MEANING TO DEPEND ON THE LABANGLE/CMANGLE     
C       SWITCH THAT IS SET EXTERNAL TO  DATA ( ... )                    
C                                                                       
CCCC 250  KEY(4) = LABANG                                               
 250  KEY(4) = 0                                                        
255   IORDER=IORDER+1                                                   
      IANGLE=IORDER                                                     
      GO TO 100                                                         
C                                                                       
C     LABANGLE                                                          
C                                                                       
 260  KEY(4) = 1                                                        
      GO TO 255                                                         
C                                                                       
C     CMANGLE                                                           
C                                                                       
 265  KEY(4) = 0                                                        
      GO TO 255                                                         
C                                                                       
C  MBERROR                                                              
C                                                                       
 300  KEY(1) = 0                                                        
 305  IORDER=IORDER+1                                                   
      IERROR=IORDER                                                     
      GO TO 100                                                         
C                                                                       
C  % ERROR                                                              
C                                                                       
 310  KEY(1) = 1                                                        
      GO TO 305                                                         
C                                                                       
C     ERROR IS IN SAME UNITS AS DATA                                    
C                                                                       
 320  KEY(1) = 2                                                        
      GO TO 305                                                         
C                                                                       
C  POLORIZATION                                                         
C                                                                       
400   IORDER=IORDER+1                                                   
      IPOL=IORDER                                                       
      KEY(3) = 1                                                        
      GO TO 100                                                         
C                                                                       
C  SIGMA                                                                
C                                                                       
 450  KEY(2) = -1                                                       
 455  IORDER=IORDER+1                                                   
      ISIGMA=IORDER                                                     
      GO TO 100                                                         
C                                                                       
C     CMSIGMA                                                           
C                                                                       
 460  KEY(2) = 1                                                        
      GO TO 455                                                         
C                                                                       
C     LABSIGMA                                                          
C                                                                       
 465  KEY(2) = 2                                                        
      GO TO 455                                                         
C                                                                       
C  SIGMATOR                                                             
C                                                                       
 470  KEY(2) = 0                                                        
      GO TO 455                                                         
C                                                                       
C  WEIGHT                                                               
C                                                                       
500   CALL NXVAL(WEIGH,&900,&900,&900)                                  
      ALLOC4(LEHED+1)=WEIGH                                             
      GO TO 100                                                         
C                                                                       
C     RENORMALIZATION                                                   
C                                                                       
510   CALL NXVAL(RNORM,&900,&900,&900)                                  
      ALLOC4(LEHED+2)=RNORM                                             
      GO TO 100                                                         
C                                                                       
C     ANGLESHIFT                                                        
C                                                                       
 520  CALL NXVAL ( ASHIFT, &900, &900, &900 )                           
      ALLOC4(LEHED+3) = ASHIFT                                          
      GO TO 100                                                         
C                                                                       
C     CHANNEL < CHANNEL SPECIFICATION >                                 
C                                                                       
 550  CALL CHANEL ( IRET )                                              
      IF ( IRET ) 100, 950, 100                                         
C                                                                       
C  NUMBER ENCOUNTERED ---  NOW READ IN NUMBERS.                         
C                                                                       
800   IAT=IAT+4                                                         
      IF(IERROR.EQ.0.OR.IANGLE.EQ.0.OR.ISIGMA.EQ.0)GO TO 930            
C                                                                       
C     SIGMA KEYWORD MEANING DEPENDS ON ANGLE SPECIFICATION              
C                                                                       
      IF ( KEY(2) .EQ. -1 ) KEY(2) = KEY(4) + 1                         
C                                                                       
      NTHISE = 0                                                        
      LENDAT = 3                                                        
      IF ( IPOL .NE. 0 ) LENDAT = 4                                     
C  LENDAT= ANGLE + SIGMA + ERROR +POL                                   
 850  DO 860 I=1,LENDAT                                                 
      CALL NXVALF(TEMP,&880,&910,&910,&885)                             
      IF(I .EQ. IANGLE)GO TO 862                                        
      IF(I .EQ. ISIGMA)GO TO 864                                        
      IF(I .EQ. IERROR)GO TO 866                                        
      IF ( I .EQ. IPOL ) GO TO 868                                      
      GO TO 945                                                         
C                                                                       
C     PERFORM SOME VALIDITY CHECKS ON THE ANGLE IN AN ATTEMPT TO        
C    DETECT OUT-OF-SEQUENCE DATA                                        
C                                                                       
 862  IF ( TEMP .LT. 0 .OR. TEMP .GT. 180 ) GO TO 940                   
      IF (TEMP .LT. 1 ) WRITE(6,853) TEMP                                 
 853  FORMAT ( ' **** WARNING:  ANGLE (', G13.5,  ' DEGREES) IS UNUSUALL
     *Y SMALL.' )                                                       
      IF ( TEMP .LT. ANGLAS ) WRITE(6,854) TEMP                           
 854  FORMAT ( ' **** WARNING:  ANGLE (', F6.2,  ' DEGREES) IS LESS THAN
     * PREVIOUS ANGLE.' )                                               
      ANGLAS = TEMP                                                     
      ALLOC4(LADATA)=TEMP                                               
      NTHISE = NTHISE + 1                                               
      NPTS = NPTS + 1                                                   
      GO TO 860                                                         
864   ALLOC4(LADATA+2)=TEMP                                             
      GO TO 860                                                         
866   ALLOC4(LADATA+1)=TEMP                                             
      GO TO 860                                                         
868   ALLOC4(LADATA+3)=TEMP                                             
      GO TO 860                                                         
860   CONTINUE                                                          
      LADATA = LADATA + LENDAT                                          
      GO TO 850                                                         
C                                                                       
C  FINISHED THIS GROUP -- APPARENTLY MORE                               
C                                                                       
 880  MORESW = .TRUE.                                                   
      GO TO 890                                                         
C                                                                       
C     ) ENCOUNTERED - ALL DONE                                          
C                                                                       
 885  MORESW = .FALSE.                                                  
C                                                                       
C     FINISH THIS SET OFF                                               
C                                                                       
 890  IF ( I .NE. 1 ) GO TO 920                                         
      DO 892 I = 1, 4                                                   
 892  ILLOC(LEKEY+I) = KEY(I)                                           
      ILLOC(LEKEY+5) = LENDAT                                           
      ILLOC(LEHED) = NTHISE                                             
      ALLOC4(LEHED+4) = ELAB                                            
      ILLOC(LEHED+5) = IZP                                              
      ILLOC(LEHED+6) = IZT                                              
      ALLOC4(LEHED+7) = AMP                                             
      ALLOC4(LEHED+8) = AMT                                             
      DO 895 I = 9, 19                                                  
      ILLOC(LEHED+I) = REACT4(I-8)                                      
 895  CONTINUE                                                          
      ILLOC(LEHED+20) = JSP                                             
      ILLOC(LEHED+21) = JST                                             
C                                                                       
C     DO NOT STORE LSKIP, LBASE IF CHANNEL NOT FULLY SPECIFIED          
C                                                                       
      ILLOC(LEHED+22) = 0                                               
      ILLOC(LEHED+23) = 0                                               
      IF ( EXSPT(1) .EQ. UNDEF ) GO TO 897                              
      ILLOC(LEHED+22) = 1                                               
      ILLOC(LEHED+23) = 3                                               
      IF ( AMP .NE. AMT .OR. IZP .NE. IZT .OR. JSP .NE. JST .OR. EXSPT(1
     *) .NE. EXSPT(2) ) GO TO 897                                       
      IF ( JSP .EQ. 0 ) ILLOC(LEHED+22) = 2                             
      ILLOC(LEHED+23) = MOD(JSP,2)+1                                    
C                                                                       
 897  ALLOC4(LEHED+25) = AMXGPT(1)                                      
      ALLOC4(LEHED+26) = AMXGPT(2)                                      
      ALLOC4(LEHED+27) = EXSPT(1)                                       
      ALLOC4(LEHED+28) = EXSPT(2)                                       
      ILLOC(LEHED+29) = IELAB                                           
      NPTSE = NPTSE + 1                                                 
      LEKEY = LEKEY + LENKEY+LENHED + LENDAT*NTHISE                     
C                                                                       
      IF (MORESW) GO TO 90                                              
C                                                                       
      ILLOC(LDATA4) = NPTS                                              
      ILLOC(LDATA4+1) = NPTSE                                           
      IWRDS = (LEKEY-LDATA4)/FACFR4 + 1                                 
      IL=CHOPIT(IWRDS)                                                  
      IRET=1                                                            
      RETURN                                                            
C                                                                       
900   WRITE(6,901)(KEYS(I),I=1,NUMKEY)                                  
901   FORMAT(' DATA NOT ENCLOSED IN PARENTHESIS OR KEYWORD MISPELLED', '
     * DATA KEYWORDS ARE:' // ( 1X, 10A9 ) )                            
      RETURN                                                            
910   WRITE(6,911)                                                      
911   FORMAT(' ERROR IN READING NUMERICAL DATA VALUES')                 
      RETURN                                                            
920   WRITE(6,921)LENDAT                                                
921   FORMAT(' INPUT ERROR - NUMBER OF INPUT NUMBERS MUST BE',I5,'*N')  
      RETURN                                                            
930   WRITE(6,931)                                                      
931   FORMAT(' ORDER OF ANGLE,ERROR AND SIGMA MUST BE SPECIFIED')       
      RETURN                                                            
 940  WRITE(6,941) TEMP                                                   
 941  FORMAT ( '0**** INVALID ANGLE (', G13.5,  ' DEGREES); CHECK ORDER 
     *OF INPUT.' )                                                      
      RETURN                                                            
 945  WRITE(6,947) I, IANGLE, ISIGMA, IERROR, IPOL                        
 947  FORMAT ( '0*** A DATA-ENTERING KEYWORD HAS BEEN SPECIFIED',  ' TWI
     *CE OR AN INTERNAL ERROR OCCURRED:', 6I5 )                         
 950  RETURN                                                            
      END 
      
      SUBROUTINE DEFALT ( NUMFLT, NUMINT, NUMJ, NUMSW, RESTSW )         
C                                                                       
C     INITIALIZATION OF THE DWBA CODE                                   
C                                                                       
C     1/18/75 - SEPARATEDED FROM CONTRL - S.P.                          
C     1/18/75 - REARRANGED TO BE OVERLAYED - S. P.                      
C     2/10/75 - MOVE  NUCONLY AND JX                                    
C     2/16/75 - LOAD IEWSZOVR, PRINT DATE                               
C     2/20/75 - MOST DEFAULTS SET TO 0 - S. P.                          
C     3/5/75 - NEW GRID DEFAULTS                                        
C     4/15/75 - MAJOR REVISION FOR NEW COMMON BLOCKS                    
C     5/5/75 - STUFF FOR SETCHN                                         
C     5/18/75 - RESTSW ADDED.                                           
C     5/22/75 - VSI ADDED                                               
C     5/30/75 - FIX FOR RESET                                           
C     6/11/75 - SAVEHS/USEHS                                            
C     8/7/75  - ADD R0E,VE,ETC TO COMMON                                
C     8/28/75 - LMINMULT, LMAXMULT, SPFACP SPFACT                       
C     9/3/75 - MAXLEXTRAP ADDED; USECOULOMB IS DEFAULT                  
C     9/25/75 - CHANGE DWCUT; REMOVE VCUT                               
C     9/30/75 - LMAXMULT BECOMES LMAXADD                                
C     10/1/75 - FITTING KEYWORDS                                        
C     10/19/75 - ESQ PARAMETERS, TBEGIN                                 
C     11/6/75 - DERIVSTEP, MAXFUNCTIONS;  LMCHOL IS DEFAULT FITTER      
C     1/29/76 - FITMULTI, FITRATIO, FITMODE, NUMRANDO                   
C     2/26/76 - LMAXADD INCREASED FOR ELASTIC STUFF                     
C     6/1/76 - NVPOLY, SUMPTS ADDED                                     
C     6/17/76 - LARGE FAKE AMDMLT                                       
C     9/16/76 - SEPT. 76 VERSION; FITMUL FIX                            
C     12/26/76 - INELASTIC SCATTERING                                   
C     4/15/77 - LMINSB, ALMXAD ADDED                                    
C     5/8/77 - PRINT=10001; MAY 77 VERSION                              
C     9/24/77 - USECORE DEFAULT; SEPT 77 VERSION                        
C     10/16/77 - POWERS OF WOODS-SAXONS                                 
C     11/20/77 - SEPARATE BOUND & SCAT ASYMP; DEC 77 VERSION            
C     11/25/77 - LINKULES                                               
C     3/19/78 - MARCH, 1978 VERSION                                     
C     4/24/78 - APRIL VERSION FOR LI, LO REVERSALS - S.P.               
C     4/28/78 - BIG AND SMALL STUFF IN /CNSTNT/ - S.P.                  
C     5/23/78 - JUNE 1978 VERSION - S.P.                                
C     12/7/78 - ADD TENSOR POTENTIALS - RPG                             
C     3/21/79 - APRIL 1979 VERSION - S.P.                               
C     5/6/79 - MAY 1979 VERSION; PARITIES AND LEVEL SPEC ARRAYS - S.P.  
C     6/10/79 - CMS VERSION - S.P.                                      
C     6/8/79 - JUNE 1979 VERSION; STANDARD PREFIXES, CHARACTER TYPE,    
C        UNIVAC STUFF - RPG                                             
C     6/18/79 - PROPERLY RESTORE IECHO FOR RESET - S.P.                 
C     9/10/79 - SEPTEMBER 1979 VERSION - RPG                            
C     11/3/79 - OCTOBER 1979 VERSION; TIME AND CPU VERSION STAMP - S.P. 
C     11/15/79 - NOVEMBER 1979 VERSION; CMPUTR SUBROUTINE - S.P.        
C     12/31/79 - DECEMBER 1979 VERSION; VAX STUFF - RPG                 
C     1/14/80 - FIX CVA IUNDEF/AUNDEF DATA; CHARACTER*1 BLANK1 - RPG    
C     1/18/80 - CALL EDTDAT FOR CND; CHAACTER*8 DATE, THISDT - RPG      
C     1/25/80 - CND CHARACTER*1 THEDAT, WRITE(6,-) TO PRINT - RPG       
C     2/5/80 - INITIALIZE NBLKSZ, CVA CALL TLIMIT - RPG                 
C     2/19/80 - INITIALIZE MAPPHI, PHIMID, GAMPHI; FEB. 1980 VERSION - R
C     3/15/80 - MARCH 1980 VERSION FOR RPG MERGED BACK TO ANL - S.P.    
C     5/2/80 - APRIL 1980 VERSION - C.C. WORKING FAIRLY WELL] S.P.      
C     6/13/80 - CHAR*8 FOR CDC THEDAT, SHIFT FOR NOS - S.P.             
C     7/10/80 - CWD, CHR PREFIXES, JULY 1980 VERSION - S.P.             
C     7/17/80 - FIX CRAY NOTDEF, UNDEF VALUES - S.P.                    
C     8/25/80 - JULY 1980 VERSION, SOMEHOW LOST ON CDC - S.P.           
C     9/16/80 - SEPT. 1980 VERSION; ZERO CCBLK; L-EXTRAP DEFAULT - S.P. 
C     10/8/80 - OCTOBER 1980 VERSION FOR NEW BASCPL, ETC. - S.P.        
C     12/17/80 - DECEMBER 1980 VERSION FOR COMPLETION OF ABOVE - S.P.   
C     1/8/81 - JANUARY 1981 VERSION FOR NEW COUPLING SCHEME  - S.P.     
C     6/24/81 - JUNE 1981 VERSION FOR REWORKS OF COUPLN - S.P.          
C     8/28/81 - AUGUST 1981 VERSION FOR DEFORMED POTENS - S.P.          
C     9/17/81 - SEPT 1981 VERSION; LEBACK DEFAULT - S.P.                
C     10/12/81 - OCT 1981 VERSION FOR GIESSEN CHANGES - S.P.            
C     2/11/82 - JANUARY 1982 VERSION                                    
C     3/12/82 - MARCH 1982 VERSION                                      
C     4/10/82 - APRIL 1982 VERSION                                      
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, A
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, T
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, 
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPA
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, 
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, 
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, 
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDA
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PA
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, R
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, A
     *MXGPT(2), PHIMID, GAMPHI                                          
      DIMENSION PARAMS(20)                                              
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 
      DIMENSION AMS(5)                                                  
      EQUIVALENCE ( AMS(1), AMA )                                       
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), 
     *(ATEN(1), ATR )                                                   
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,
     * MAPPHI, NFIROF, LEBACK                                           
      COMMON /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     *ISAVSM                                                            
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), ID
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, W
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3
     *I                                                                 
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      
      REAL*8 LNKNAM(3,12)                                               
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      CHARACTER*1 REACT, HEADER                                         
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             
      COMMON /CCBLK/ ICHNDF, ICHNCP, ITRANS, IBASDF, IBASCP, ICCBLK(2), 
     *IORDX                                                             
C                                                                       
      LOGICAL RESTSW                                                    
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                                                                       
      CHARACTER*1 BLANK1                                                
      DATA BLANK1 / ' ' /                                               
C                                                                       
CIB      DATA  IUNDEF / Z F0F0F0F0 /,  AUNDEF / Z F0F0F0F0 00000000 /   
CDC      DATA  IUNDEF / 7070707070 7070707070 B /,                      
CDC     1  AUNDEF / 7070707070 7070707070 B /                           
C                                                                       
CRA      DATA  IUNDEF / 1 57070 70707070 70707070 B /                   
CRA      DATA  AUNDEF / 1 57070 70707070 70707070 B /                   
C                                                                       
CUN      DATA IUNDEF / O707070707070 /                                  
CUN      REAL*4 SUNDEF(2) / O707030707070, O707070707070 /              
CUN      EQUIVALENCE ( SUNDEF(1), AUNDEF )                              
      DATA IUNDEF / 'F0F0F0F0'X /                                       
      REAL*4 SUNDEF(2)                                                  
      DATA SUNDEF/'F0F0F0F0'X, 'F0F0F0F0'X/                             
      EQUIVALENCE ( SUNDEF(1), AUNDEF )                                 
      CHARACTER*1 THEDAT(18)                                            
      CHARACTER*8 THETIM, DATE, THISDT                                  
      DATA THETIM / '        ' /                                        
C                                                                       
C     IS THIS THE FIRST CALL TO DEFALT                                  
C                                                                       
      IF ( RESTSW ) GO TO 10                                            
C                                                                       
C                                                                       
C  INITIALIZE INPUT                                                     
C                                                                       
C     FIRST SET EVERYTHING TO UNDEFINED STATUS                          
C                                                                       
 10   NOTDEF = IUNDEF                                                   
      UNDEF = AUNDEF                                                    
C                                                                       
      DO 39 I = 1, NUMFLT                                               
 39   FLOATK(I) = UNDEF                                                  
      DO 49 I = 1, NUMINT                                               
 49   INTGER(I) = NOTDEF                                                
      DO 59 I = 1, NUMJ                                                 
 59   JBLOCK(I) = NOTDEF                                                
C                                                                       
C     SET ALL OPTIONS OFF                                               
C                                                                       
      ITSOSV = ITSO                                                     
      IECHSV = IECHO                                                    
      DO 69 I = 1, NUMSW                                                
 69   SWITCH(I) = 0                                                     
      ITSO = ITSOSV                                                     
      IECHO = IECHSV                                                    
C                                                                       
      DO 79 I = 1, 110                                                  
 79   REACT(I) = BLANK1                                                 
C                                                                       
C                                                                       
      IF ( RESTSW ) GO TO 110                                           
C                                                                       
      IECHO=1                                                           
C     INDICATE NO ALLOCATOR YET.                                        
      ICNTT = 0                                                         
C  IECHO MUST BE INITIALIZED BEFORE NEWCD IF FIRST INPUT... ISTOBEVISIBL
 110  IF(ITSO.EQ.0) WRITE(6,118)                                           
      IF(ITSO.EQ.1) WRITE(6,113)
 113  FORMAT('            P T O L E M Y')                               
 118  FORMAT( X, T50, 'P T O L E M Y' )                               
      WRITE(6,119)
 119  FORMAT(X,T10, 'THIS IS THE ARGONNE-INDIANA-STONYBROOK DIRECT 
     *REACTION PROGRAM PTOLEMY')
      WRITE(6,120)
 120  FORMAT(X,T10, 'FOR MORE INFORMATION CONTACT  S PIEPER ARGONNE, 
     *M. MACFARLANE INDIANA, M. RHOADES-BROWN STONYBROOK.' / X,T10, 
     *'(CORRECTED BY DAO T. KHOA FOR UNIX WORK-STATION, AUGUST 96).')
C                                                                       
C     GET CURRENT DATE                                                  
C                                                                       
  150 THISDT = DATE(THISDT)                                             
      CALL EDTDAT ( THEDAT, N, THISDT ) 
C      CALL TIMODA (THETIM)                                              
C                                                                       
C     **********************************************************        
C     *                                                        *        
C     *                STOP     THINK                          *        
C     *                                                        *        
C     *    IS IT TIME TO CHANGE THE DATE OF THE VERSION ??     *        
C     *                                                        *        
C     **********************************************************        
C                                                                       
CK      IF ( ITSO .EQ. 0 ) WRITE(6,153) CPUID,OPSYS,THEDAT,THETIM        
CK 153  FORMAT ( ' MARCH 1983 VERSION',  T30, 'COMPUTER: ', 2A8, 2X, 'OP. 
CK     *SYS: ', 2A8,  T100, 18A1, 2X, A8 / )                              
CWD     2  T110,  A8, 3X,  A8 / )                                       
CK      IF ( ITSO .EQ. 1 ) WRITE(6,158) THEDAT                              
CK 158  FORMAT ( ' APRIL 1982 VERSION;', 5X, 18A1 / )                     
C                                                                       
C     SETUP CONSTANTS                                                   
C                                                                       
      PI = 3.1415 92653 58979 32 0D0                                    
      RT4PI = DSQRT(4*PI)                                               
      PIINV = 1/PI                                                      
      RADIAN = 180/PI                                                   
      DEGREE = 1/RADIAN                                                 
C                                                                       
C     FOLLOWING FROM  E. R. COHEN AND B. N. TAYLOR, J. PHYS. AND CHEM.  
C     REF. DATA, 2, 663 (1973).                                         
C                                                                       
      HBARC = 197.32858 0D0                                             
      AMUMEV = 931.5016 0D0                                             
      AFINE = 137.03604 0D0                                             
C                                                                       
C     UNDERFLOW AND OVERFLOW LIMITS                                     
C                                                                       
CIB      BIGEST = 1.D+75                                                
CIB      BIGNUM = 1.D+30                                                
C                                                                       
CDC      BIGEST = 1.E+290                                               
CDC      BIGNUM = 1.E+135                                               
C                                                                       
CRA      BIGEST = 1.E+2400                                              
CRA      BIGNUM = 1.E+1200                                              
C                                                                       
CUN      BIGEST = 1.D+290                                               
CUN      BIGNUM = 1.D+135                                               
C                                                                       
      BIGEST = 1.D+36                                                   
      BIGNUM = 1.D+18                                                   
C                                                                       
      SMLEST = 1/BIGEST                                                 
      SMLNUM = 1/BIGNUM                                                 
      BIGLOG = DLOG( BIGNUM )                                           
C                                                                       
C     TO TRAP A TROLLOP TRAVELLING ON A TROLLY                          
C     (I.E. RESET POINTER TO BOUND STATE POLENTIAL.)                    
C                                                                       
      IPOT = 0                                                          
C                                                                       
C     SETUP DEFAULT VALUES                                              
C                                                                       
      DWCUT=1.D-3                                                       
      NCOSIN=256                                                        
      NBACK=4                                                           
      DELTVK=.050D0                                                     
      MAXITR=10                                                         
      IFIT=1                                                            
      IVRTEX=1                                                          
      ACCURA=1.0D-12                                                    
      BNDASY=20.0D0                                                     
      SCTASY=20.0D0                                                     
      STEP1R=1.0D0                                                      
      STEP1I=1.0D0                                                      
COS      ISIZE=-7000                                                    
COS      IF ( ITSO .EQ. 0 )  ISIZE = -5000                              
CMS      ISIZE = -10000                                                 
CNV      ISIZE = 10 000                                                 

C   VAX VIRTUAL MEMORY IS CHEAP 
      ISIZE=5000000
CK      isize=2500000

      STEPSZ=.10D0                                                      
C  DEFAULT VALUES FOR ANGLES                                            
      ANGMIN=0                                                          
      ANGMAX = 90                                                       
      ANGSTP = 1                                                        
      LSTEP = 1                                                         
      NPPHI=10                                                          
      NPSUM = 15                                                        
      NPDIF = 10                                                        
      NVPOLY = 3                                                        
      SUMPTS = 6                                                        
      SPAMP=1.0D0                                                       
      SPAMT=1.0D0                                                       
      SPFACP = 1                                                        
      SPFACT = 1                                                        
      NAITKN=4                                                          
      IPRINT = 10001                                                    
      IF ( ITSO .EQ. 1 ) IPRINT = 01                                    
      LOOKST = 250                                                      
      ICHANB = 0                                                        
      ICHANW = 0                                                        
      IDONE = 0                                                         
      ISTRIP = 0                                                        
      MAPSUM = 2                                                        
      MAPDIF = 1                                                        
      MAPPHI = 2                                                        
      GAMSUM = 1                                                        
      GAMDIF = 5                                                        
      GAMPHI = 1.D-6                                                    
      AMDMLT = 2                                                        
      PHIMID = 0.5                                                      
      NPHIAD = 4                                                        
      NUCONL = 3                                                        
      IHSAVE = 0                                                        
      ALMXMT = 1.6                                                      
      LMAXAD = 30                                                       
      ALMNMT = .6                                                       
      LMINSB = 20                                                       
      MAXLEX = 100                                                      
      LEBACK = 15                                                       
C                                                                       
      NWAVEF = 0                                                        
C     EXCITATION ENERGIES ARE 0 BY DEFAULT                              
C     PARITY = 0 MEANS UNDEFINED                                        
C                                                                       
      DO 309 I = 1, 5                                                   
      PARITS(I) = 0                                                     
 309  EXS(I) = 0                                                        
      PARITY = 0                                                        
C                                                                       
      NBLKSZ = 5632                                                     
C                                                                       
C     VAX/VMS:  THE DEFAULT CPU TIME LIMIT IS ONE HOUR.                 
C                                                                       
CVMS      CALL TLIMIT (8000.D0)                                             
      DO 319 I = 1, 4                                                   
      LSPECS(I) = NOTDEF                                                
      NODESP(I) = NOTDEF                                                
 319  CONTINUE                                                          
      DO 329 I = 1, 2                                                   
      LSPCPT(I) = NOTDEF                                                
      NODEPT(I) = NOTDEF                                                
      PARIPT(I) = 0                                                     
      EBNDS(I) = UNDEF                                                  
 329  CONTINUE                                                          
C                                                                       
C     POTENTIALS ARE 0 BY DEFAULT                                       
C                                                                       
      V = 0                                                             
      VI = 0                                                            
      VSO = 0                                                           
      VSOI = 0                                                          
      TAU = 0                                                           
      TAUI = 0                                                          
      VSI = 0                                                           
      DO 359 I = 1, 6                                                   
 359  VTEN(I) = 0                                                       
C                                                                       
C  ENERGY DEPENDENCE ZERO BY DEFAULT                                    
C                                                                       
      R0E=0                                                             
      RI0E=0                                                            
      AE=0                                                              
      AIE=0                                                             
      VE=0                                                              
      VIE=0                                                             
      R0ESQ = 0                                                         
      RI0ESQ = 0                                                        
      AESQ = 0                                                          
      AIESQ = 0                                                         
      VESQ = 0                                                          
      VIESQ = 0                                                         
C                                                                       
C     POTENTIALS ARE LINEAR WOODS SAXONS                                
C                                                                       
      POWRL = 1                                                         
      POWIM = 1                                                         
C                                                                       
C     INDICATE NO LINKULES IN USE.                                      
C                                                                       
      NUMLNK = 12                                                       
      IUNIQU = 100                                                      
      DO 409 I = 1, NUMLNK                                              
      LNKADR(3,I) = 0                                                   
 409  CONTINUE                                                          
C                                                                       
C     FITTING KEYWORDS                                                  
C                                                                       
      FITACC = 1.D-3                                                    
      FITMUL = 500                                                      
      FITRAT = 1.D-4                                                    
      MODEFT = 1                                                        
      NUMRAN = 0                                                        
      MAXFUN = 50                                                       
      IREINI = 0                                                        
      IFITER = 6                                                        
      DERIVS = 1.D-6                                                    
C                                                                       
C     INELASTIC SCATTERING                                              
C                                                                       
      ACCINE = 1.D-5                                                    
      COULML = 1                                                        
      NPCOUL = 8                                                        
      MXCOUL = 80                                                       
C                                                                       
C     COUPLED CHANNELS                                                  
C                                                                       
      IEXTYP = 1                                                        
      ICHNDF = 0                                                        
      ICHNCP = 0                                                        
      ITRANS = 0                                                        
      IBASDF = 0                                                        
      NFIROF = 1                                                        
      RETURN                                                            
      END                                                               
      SUBROUTINE DEFINE ( ANAME, ILEN, ISIZE )                          
C                                                                       
C     DEFINES AN OBJECT IN THE ALLOCATOR WITH THE NAME ANAME.           
C                                                                       
C     THE OBJECT IS LOADED WITH A LIST OF NUMBERS READ FROM THE         
C     INPUT STREAM.  THE LIST DETERMINS THE LENGTH OF THE OBJECT        
C     AND IS TERMINATED BY A NON-NUMBER.                                
C                                                                       
C     ANAME - NAME OF THE OBJECT TO BE DEFINED.                         
C     ILEN - SET TO THE LENGTH OF THE LIST OF NUMBERS READ.             
C     ISIZE - SET TO THE MAXIMUM SIZE AVAILABLE IN THE ALLOCATOR.       
C             IF  ILEN > ISIZE,  THEN ALL THE NUMBERS WERE READ         
C             BUT ONLY THE FIRST ISIZE VALUES WERE STORED INTO THE      
C             ARRAY.                                                    
C                                                                       
C     12/14/76 - FIRST VERSION - S. PIEPER                              
C     1/24/80 - CHARACTER*8 NAMES, ANAME - RPG                          
C     7/21/80 - FIX BLUNDER IN PRINT STMNT - S.P.                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
C                                                                       
      INTEGER*4 Z                                                       
      COMMON /LOCKT/ Z(1000)                                               
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            
      DIMENSION ALLOC(1)                                                
      LOGICAL*1 MLLOC(1)                                                
      REAL*4 ALLOC4(1)                                                  
      INTEGER ILLOC(1)                                                  
      INTEGER*2 ILLOC2(1)                                               
      EQUIVALENCE (FACFR4,ALLOC(1),ILLOC(1),ILLOC2(1),ALLOC4(1), ML
     *LOC(1) )                                                          
      CHARACTER*8 NAMES, ANAME                                          
      COMMON /NAMCOM/ NAMES(100)                                          
      COMMON /LENGTH/ LENG(100)                                           
C                                                                       
      CHARACTER*1 IBUF(80)                                              
      COMMON /INPBUF/ NOCH, INCH, IBUF                                  
      INTEGER GIVEAL                                                    
C                                                                       
C     GET THE OBJECT NUMBER IF IT PRESENTLY EXISTS                      
C                                                                       
      IDOLD = NAMLOC(ANAME)                                             
C                                                                       
C     GET MAXIMUM AMOUT POSSIBLE FROM ALLOCATOR TO READ IN NUMBERS      
C                                                                       
      IDATA = GIVEAL(ISIZE)                                             
      NAMES(IDATA) = ANAME                                              
      LDATA = Z(IDATA)                                                  
      ILEN = 0                                                          
C                                                                       
 50   CALL NXVAL ( X, &310, &300, &310 )                                
      ILEN = ILEN + 1                                                   
      IF ( ILEN .GT. ISIZE+1 ) GO TO 50                                 
      IF ( ILEN .LE. ISIZE ) GO TO 100                                  
      WRITE(6,73) ANAME, ILEN                                             
 73   FORMAT ( '0**** EXCEEDED ALLOCATOR WHEN DEFINING ',  A8, ' ROOM FO
     *R ONLY', I6, ' VALUES.' )                                         
      GO TO 50                                                          
C                                                                       
 100  ALLOC(LDATA-1+ILEN) = X                                           
      GO TO 50                                                          
C                                                                       
C     END OF LIST -- BACKUP FOR SEMICOLON.                              
C                                                                       
 300  INCH = INCH-1                                                     
 310  CALL CHOPIT ( MIN0(ILEN,ISIZE) )                                  
C                                                                       
C     IF OBJECT PREVIOUSLY EXISTED, ASSIGN IT THE SAME NUMBER           
C                                                                       
      IF ( IDOLD .EQ. 0 ) RETURN                                        
      LOLD = Z(IDOLD)                                                   
      Z(IDOLD) = LDATA                                                  
      Z(IDATA) = -LOLD                                                  
      X = ALLOC(LDATA-1)                                                
      ALLOC(LDATA-1) = ALLOC(LOLD-1)                                    
      ALLOC(LOLD-1) = X                                                 
      LENG(IDATA) = LENG(IDOLD)                                         
      LENG(IDOLD) = MIN0( ILEN, ISIZE )                                 
C                                                                       
      RETURN                                                            
      END                                                               
      SUBROUTINE DEFWOO ( NUMPTS, RSTRT, STEPSZ, VRAY, N1, N2,  ITYPE, V
     *, R, A, POWER, IPORT, LXMIN, LDEFMX, RBETAS,  LXS, NUMPT )        
C                                                                       
C     COMPUTES DEFORMED WOODS-SAXON TYPE POTENTIALS                     
C                                                                       
C     NUMPTS - NUMBER OF DESIRED POTENTIAL VALUES                       
C     RSTRT - FIRST R VALUE                                             
C     STEPSZ - INCREMENT IN R - LASTR = RSTRT + (NUMPTS-1)*STEPSZ       
C     VRAY - ARRAY OF NUMPTS LOCATIONS TO GET V                         
C     N1 - SET TO INDEX OF FIRST ELEMENT OF VRAY THAT IS NONTRIVIAL     
C     N2 - SET TO INDEX OF LAST NON-ZERO ELEMENT IN VRAY.               
C     ITYPE - TYPE OF POTENTIAL DESIRED:                                
C       1 - WOODS SAXON.                                                
C          -V / ( 1 + EXP((RVAL-R)/A) )**POWER                          
C     V, R, A, POWER - POTENTIAL PARAMETERS                             
C                                                                       
C     IPORT - THE PROJECTION THAT IS DESIRED:                           
C      0 - DEFORMED OPTICAL POTENTIAL                                   
C      1 - PROJECTILE EXCITATION                                        
C      2 - TARGET EXECITATION                                           
C      3 - MUTUAL                                                       
C     LXMIN - LOWER LIMIT OF LX'S TO USE IN THE DEFORMATION             
C             APPLYS TO BOTH PROJECTILE AND TARGET                      
C     LDEFMX(2) - THE UPPER LIMIT OF LX'S TO USE FOR PROJECTILE         
C             AND TARGET.  0 MEANS NO DEFORMATION.                      
C     RBETAS(2,) - RBETAS(I,LX) IS THE DEFORMATION LENGTH               
C              I=1 IS PROJECTILE, =2 IS TARGET                          
C     LXS(2) - THE DESIRED PROJECTED LAMBDA IN THE PROJ AND             
C              TARGET.                                                  
C     NUMPT - THE NUMBER OF POINTS TO USE IN THE INTEGRATION.           
C             IF ODD LX'S ARE PRESENT, TWICE THIS NUMBER ARE USED.      
C                                                                       
C     FOR IPORT = 0, THE POTENTIAL COMPUTED IS                          
C       1/2  INTEGRAL(-1,1) DX V( R(X) )                                
C       OR 1/4 THE DOUBLE INTEGRAL IF BOTH NUCLEI ARE DEFORMED          
C     FOR IPORT > 0 IT IS                                               
C       SQRT( PI*(2LXOUT+1) ) INTEGRAL(-1,1) DX V( R(X) ) P(LXOUT,0,X)  
C     WHERE                                                             
C       R(X) = R + SUM(LX) RBETAS(LX)*Y(LX,0,X)                         
C     IS THE DEFORMED POTENTIAL RADIUS.                                 
C     IF BOTH NUCLEI ARE DEFORMED THEN A DOUBLE INTEGRAL IS DONE.       
C                                                                       
C     7/27/81 - FIRST VERSION MADE FROM WOODSX - S.P.                   
C     10/16/81 - ALLOW MUTUAL DEFORMATION - S.P.                        
C                                                                       
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      DIMENSION VRAY(NUMPTS), RBETAS(2,1), LXS(2), LDEFMX(2)            
      LOGICAL ODDLSW, TBIT                                              
      DIMENSION XS(50), YS(2,50), WTS(50), PLM(20),  FACS(2,20), WT(2,50
     *)                                                                 
C                                                                       
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, A
     *FINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
C                                                                       
C     CHECK FOR ZERO POTENTIAL                                          
C                                                                       
      N1 = 0                                                            
      N2 = 0                                                            
      IF ( V .EQ. 0 ) GO TO 300                                         
C                                                                       
C                                                                       
C     WILL WE NEED TO INTEGRATE FROM -1 TO 1                            
C     ALSO FIND AT LEAST ONE NUCLEUS THAT IS DEFORMED                   
C     AND THE NUMBER OF NUCLEI THAT ARE DEFORMED                        
C                                                                       
      ODDLSW = .FALSE.                                                  
      NDIM = 0                                                          
      DO 39 I = 1, 2                                                    
      LXMAX = LDEFMX(I)                                                 
      IF ( LXMAX .EQ. 0 ) GO TO 39                                      
      NDIM = NDIM + 1                                                   
      IPT = I                                                           
      DO 29 LX = LXMIN, LXMAX                                           
      IF ( MOD(LX,2).NE.0 .AND. RBETAS(I,LX) .NE. 0 )  ODDLSW = .TRUE.  
      FACS(I,LX) = DSQRT((2*LX+1)/(4*PI)) * RBETAS(I,LX)                
 29   CONTINUE                                                          
      LX = LXS(I)                                                       
      IF ( MOD(LX,2).NE.0 .AND. .NOT. ODDLSW ) GO TO 300                
 39   CONTINUE                                                          
      NGAUSS = NUMPT                                                    
      IF ( ODDLSW ) NGAUSS = 2*NUMPT                                    
C                                                                       
C     SETUP THE TOTAL DEFORMATION AND WEIGHTS AT EACH                   
C     INTEGRATION POINT                                                 
C                                                                       
      CALL GAUSSL ( NGAUSS, XS, WTS )                                   
      VSCALE = .5**NDIM * V                                             
      IF ( IPORT .EQ. 0 ) GO TO 50                                      
      IF ( IPORT .LT. 3 ) VSCALE = SQRT( PI*(2*LXS(IPORT)+1) )  * 2*VSCA
     *LE                                                                
      IF ( IPORT .EQ. 3 ) VSCALE = PI * SQRT(  (2*LXS(1)+1)*(2*LXS(2)+1.
     *D0) ) * V                                                         
C                                                                       
 50   LXMAX = MAX0( LXS(1), LXS(2), LDEFMX(1), LDEFMX(2) )              
      DO 99 I = 1, NGAUSS                                               
      X = XS(I)                                                         
      IF ( .NOT. ODDLSW ) X = .5*(1+X)                                  
      CALL PLMSUB ( LXMAX, 0, X, PLM )                                  
      DO 89 II = 1, 2                                                   
      LXM = LDEFMX(II)                                                  
      Y = 1                                                             
      IF ( LXM .EQ. 0 ) GO TO 85                                        
      Y = 0                                                             
      DO 79 LX = LXMIN, LXM                                             
      Y = Y + FACS(II,LX)*PLM(LX+1)                                     
 79   CONTINUE                                                          
      Y = DEXP(-Y/A)                                                    
 85   YS(II,I) = Y                                                      
      WT(II,I) = WTS(I)*PLM(LXS(II)+1)                                  
 89   CONTINUE                                                          
 99   CONTINUE                                                          
C                                                                       
C                                                                       
      XSTP = STEPSZ/A                                                   
      YSTP = DEXP(XSTP)                                                 
      X = (RSTRT-STEPSZ - R)/A                                          
C                                                                       
C     BREAK THE REGION (RSTRT, REND) INTO THREE REGIONS:                
C     1) SMALL R:  EXP((RVAL-R)/A)  <  EXP(-100)                        
C     2) MODERATE R:  EXP(..)**POWER IS COMPUTABLE                      
C     3) LARGE R:  V/( EXP((RVAL-R)/A) )**POWER  <  EXP(-46) = 1.E-20   
C                                                                       
      N1 = -(100+X)/XSTP                                                
      N1 = MAX0( N1, 1 )                                                
      N1 = MIN0( N1, NUMPTS )                                           
      Y = 46 + DLOG( DABS(V) )                                          
      Y = DMIN1( Y, BIGLOG )                                            
      IF ( POWER .GT. 1 ) Y = Y/POWER                                   
      N2 = (Y-X)/XSTP                                                   
      N2 = MIN0( N2, NUMPTS )                                           
      N2 = MAX0( N2, N1 )                                               
C                                                                       
C     REGION 1 - POTENTIAL IS -V OR ZERO.                               
C                                                                       
      IF ( N1 .EQ. 1 ) GO TO 200                                        
      Y = -V                                                            
      IF ( ITYPE .GT. 1 .OR. IPORT .NE. 0 ) Y = 0                       
      DO 189 I = 1, N1                                                  
      VRAY(I) = Y                                                       
 189  CONTINUE                                                          
C                                                                       
C     REGION 2 - COMPUTE THE POTENTIAL                                  
C                                                                       
 200  X = X + N1*XSTP                                                   
      Y = DEXP(X)                                                       
C                                                                       
C     STRAIGHT W.S.                                                     
C                                                                       
 210  IF ( POWER .NE. 1 ) GO TO 250                                     
      ASSIGN 220 TO IGO                                                 
      IF ( NDIM .EQ. 2 ) ASSIGN 230 TO IGO                              
      DO 249 I = N1, N2                                                 
      VV = 0                                                            
      GO TO IGO, ( 220, 230 )                                           
 220  DO 224 II = 1, NGAUSS                                             
      VV = VV + WT(IPT,II)/(1+Y*YS(IPT,II))                             
 224  CONTINUE                                                          
      GO TO 240                                                         
 230  DO 235 II = 1, NGAUSS                                             
      DO 235 III = 1, NGAUSS                                            
      VV = VV + WT(1,II)*WT(2,III) /  ( 1 + Y*YS(1,II)*YS(2,III) )      
 235  CONTINUE                                                          
 240  VRAY(I) = -VSCALE*VV                                              
      Y = Y*YSTP                                                        
 249  CONTINUE                                                          
      GO TO 300                                                         
C                                                                       
C     POWER OF W.S.                                                     
C                                                                       
 250  ASSIGN 260 TO IGO                                                 
      IF ( NDIM .EQ. 2 ) ASSIGN 270 TO IGO                              
      DO 299 I = N1, N2                                                 
      VV = 0                                                            
      GO TO IGO, ( 260, 270 )                                           
 260  DO 264 II = 1, NGAUSS                                             
      VV = VV + WT(IPT,II)/(1+Y*YS(IPT,II))**POWER                      
 264  CONTINUE                                                          
      GO TO 280                                                         
 270  DO 274 II = 1, NGAUSS                                             
      DO 274 III = 1, NGAUSS                                            
      VV = VV + WT(1,II)*WT(2,III) /  ( 1 + Y*YS(1,II)*YS(2,III) )**POWE
     *R                                                                 
 274  CONTINUE                                                          
 280  VRAY(I) = -VSCALE*VV                                              
      Y = Y*YSTP                                                        
 299  CONTINUE                                                          
C                                                                       
C     NOW FILL OUT THE REST OF THE ARRAY WITH 0                         
C                                                                       
 300  IF ( N2 .EQ. NUMPTS ) RETURN                                      
      N2P1 = N2+1                                                       
      DO 329 I = N2P1, NUMPTS                                           
      VRAY(I) = 0                                                       
 329  CONTINUE                                                          
      RETURN                                                            
      END                                                               
