SUBROUTINE RESTRT(IRSTRT,ISAVEU, JTOTL,JSTEP,MXPAR,MSET,MHI,
     1           LABELX,ITYPEX,NLEVX,NQNX,UREDX,IPX,
     2           JLEVX,NNRGX,ENERGX,MXNRG,
     3           SIG,ISST,IECONV,MINJT,MAXJT,ISIGU,IPARTU,KSAVE,
     4           OTOL,DTOL, IXX,RXX, MRSTRT,IERST,MXP,PRNTLV)
C
C     RESTART MOLSCAT CALCULATION FROM SAVED TAPE ON UNIT(ISAVEU):
C     IRSTRT IS AN ADDITIONAL &INPUT NAMELIST PARAMETER
C     IRSTRT= 1  RESTART AFTER A COMPLETED JTOT SET
C           =-1  SAME AS 1, BUT BEGINNING AT &INPUT JTOTL
C           = 2  RESTART AFTER A COMPLETED SYMMETRY BLOCK
C           = 3  RESTART AFTER LAST GOOD JTOT,M,INRG SET
C
C     A RESTART RUN SHOULD HAVE SAME INPUT DECK AS ORIGINAL RUN
C       EXCEPT THAT IRSTRT PARAMETER MUST BE SET.
C       FOR IRSTRT=-1, JTOTL MUST BE RESET TO DESIRED RESTART VALUE
C       SOME OTHER PARMS (E.G., INTEGRATION PARMS *MAY* BE CHANGED)
C
C     RECREATES ACCUM CROSS SECTIONS (OUTPUT/PRBR) FROM SAVED S-MATRICES
C
C     JTSV(IRSTRT),MSV(IRSTRT),INSV(IRSTRT)
C       CONTAIN VALUES FOR LAST *COMPLETED* SET FOR EACH IRSTRT OPTION.
C     RETURNS JTOTL,MRSTRT,IERST -- VALUES AT WHICH TO RECOMMENCE
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION JLEVX(1)
      DIMENSION ENERGX(MXNRG)
      DIMENSION MINJT(MXNRG),MAXJT(MXNRG),ISST(MXNRG),IECONV(MXNRG)
      DIMENSION SIG(1),  IXX(1),RXX(1)
      DIMENSION JTSV(3),MSV(3),INSV(3)
      INTEGER PRNTLV
      CHARACTER*80 LABEL,LABELX
      LOGICAL CONSIS,MPLMIN,LCS,LCS3
C     BIG VALUE TO INITIALIZE JSTOP
      DATA IBIG/1000000/
C
C   DYNAMIC STORAGE COMMON BLOCK ...
C     USAGE IN RESTRT DOES *NOT* CONFORM W/ USUAL MOLSCAT PHILOSOPHY:
C       X() IS ACCESSED DIRECTLY, VIA IXX() AND RXX()
C       LIMIT CHECKED DIRECTLY AGAINST MX, I.E., CHKSTR IS NOT USED.
C       ON ENTRY IXX(1), RXX(1) ARE EQUIVALENCED TO X(IXNEXT)
      COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C
C   'BASIS' COMMON BLOCK -- NEED NLEVEL,ELEVEL,JLEVEL (V13, MAR 94)
      DIMENSION ELEVEL(600),ELVL(600),JLEVEL(1200)
      COMMON /CMBASE/ DUM(614),IDUM(1208)
      EQUIVALENCE (NLVL,IDUM(7)),(ELVL(1),DUM(11)),(JLEVEL(1),IDUM(8))
     1           ,(IDENT,IDUM(1208))
C
C   COMMON TO COMMUNICATION WITH PRBR; EXCEPT FOR MVALUE THESE HAVE
C     BEEN SET IN PRIOR CALL TO BASIN.
      COMMON /PRBASE/ ITYPE,NQN,NLEV,MVALUE,IEXX,MPLMIN
C
C     --------------------------------------------------------
      IF (IRSTRT.LT.-1) RETURN
      CALL GCLOCK(TSTART)
C
C     FIRST MXPAR LOCATIONS IN IXX USED TO STORE HIGHEST ENERGY/M
C       (PERHAPS WE SHOULD KEEP HIGHEST ENERGY IN *LAST* JTOT CYCLE)
      IXI=MXPAR
      IXR=(MXPAR+NIPR-1)/NIPR
      IF (IXNEXT+IXR-1.GT.MX) THEN
        WRITE(6,*) ' *** TERMINAL ERROR. SCRATCH STORAGE EXCEEDED.'
        STOP
      ELSE
        DO 1000 I=1,MXPAR
 1000   IXX(I)=-1
      ENDIF
C
      JSTOP=IBIG
      IF (IRSTRT.EQ.-1) THEN
        WRITE(6,*) ' *** RESTRT.  REQUEST TO RESTART AT JTOT =',JTOTL
        JSTOP=JTOTL-JSTEP
        IRSTRT=1
      ENDIF
      IT=ISAVEU
C     CHECK HEADER INFO ON TAPE FOR AGREEMENT WITH CURRENT RUN PARAMS.
      READ(IT,END=9001) LABEL,ITYPE,NLEV,NQN,URED,IP
      WRITE(6,600) IT,LABEL,LABELX
  600 FORMAT('  ***'/'  *** RESTRT.  DATA FROM UNIT ISAVEU =',I4/
     2       '  *** LABEL  ON  ISAVEU =',A80/
     3       '  *** CURRENT RUN LABEL =',A80/'  ***')
      IF (ITYPE.EQ.ITYPEX .AND. NLEVX.EQ.NLEV .AND. NQNX.EQ.NQN
     1    .AND. URED.EQ.UREDX) THEN
        WRITE(6,601) ITYPE,NLEV,NQN,URED,IP
  601  FORMAT(/'  *** CURRENT PARAMETERS AGREE WITH SAVED VALUES'/
     1         6X,'ITYPE =',I3/6X,'NLEV, NQN =',2I4/6X,'URED =',F8.4/
     2         6X,'IPROGM =',I3)
      ELSE
        WRITE(6,602) ITYPEX,ITYPE,NLEVX,NLEV,NQNX,NQN,UREDX,URED
  602   FORMAT('  *** ERROR.  CURRENT/SAVED PARAMTERS DO NOT MATCH'/
     1         14X,'ITYPE',2I6/14X,'NLEV',2I6/14X,'NQN ',2I6/
     2         14X,'URED',2F12.4/'  *** TERMINATING.')
        STOP
      ENDIF
      IF (IPX.NE.IP) WRITE(6,603) IPX
  603 FORMAT(' *** NOTE DIFFERENT CURRENT PROGRAM VERISON =',I4)
      IF (IP.LT.3) THEN
        WRITE(6,*) ' *** TERMINAL ERROR.  NO SUPPORT FOR IPROGM',IP
        STOP
      ENDIF
C
      NSQ=NLEV*NQN
      NUSED=(IXI+NSQ+NIPR-1)/NIPR
      IF (IXNEXT+NUSED-1.GT.MX) THEN
        WRITE(6,*) ' *** TERMINAL ERROR.  NOT ENOUGH STORAGE FOR JLEV'
        STOP
      ELSE
        READ(IT,END=9001) (IXX(IXI+I),I=1,NSQ)
        DO 1001 I=1,NSQ
        IF (IXX(IXI+I).EQ.(JLEVX(I))) GO TO 1001
        WRITE(6,604) (JLEVX(II),IXX(IXI+II),II=1,NSQ)
  604   FORMAT('  *** TERMINAL ERROR.  CURRENT/SAVED JLEV MISMATCH'/
     1         (8(2X,2I4)))
        STOP
 1001   CONTINUE
        WRITE(6,*) ' *** CURRENT/SAVED JLEV MATCH'
      ENDIF
C
      READ(IT,END=9001) NLEVEL,(ELEVEL(I),I=1,NLEVEL)
      IF (NLVL.NE.NLEVEL) THEN
        WRITE(6,605) NLVL,NLEVEL
  605   FORMAT('  *** TERMINAL ERROR. CURRENT/SAVED NLEVEL',2I6)
        STOP
      ENDIF
      DO 1002 I=1,NLEVEL
      IF (ELVL(I).EQ.ELEVEL(I)) GO TO 1002
      WRITE(6,606) I,ELVL(I),ELEVEL(I)
  606 FORMAT('  *** TERMINAL ERROR. CURRENT/SAVED ELEVEL(',I3,')=',
     1       2D12.4)
      STOP
 1002 CONTINUE
      WRITE(6,*) ' *** CURRENT/SAVED NLEVEL,ELEVEL MATCH.'
C
      IF (IXNEXT+IXR+MXNRG-1.GT.MX) THEN
        WRITE(6,*) ' *** TERMINAL ERROR.  NOT ENOUGH STORAGE FOR MXNRG'
        STOP
      ELSE
        READ(IT,END=9001) NNRG,(RXX(IXR+I),I=1,NNRG)
      ENDIF
      IF (NNRG.NE.NNRGX) THEN
        WRITE(6,607) NNRG,NNRGX
  607   FORMAT('  *** TERMINAL ERROR. CURRENT/SAVED NNRG',2I6)
        STOP
      ENDIF
      DO 1003 I=1,NNRG
      IF (RXX(IXR+I).EQ.ENERGX(I)) GO TO 1003
      WRITE(6,608) I,RXX(IXR+I),ENERGX(I)
  608 FORMAT('  *** TERMINAL ERROR. CURRENT/SAVED ENERGY(',I3,')=',
     1       2D12.4)
      STOP
 1003 CONTINUE
      WRITE(6,*) ' *** CURRENT/SAVED NNRG,ENERGY MATCH.'
C
C     CHECKING SPECIFIC TO SOME ITYPES ...
      LCS=ITYPE.EQ.21.OR.ITYPE.EQ.22.OR.ITYPE.EQ.25.OR.ITYPE.EQ.26
     1    .OR.ITYPE.EQ.27
      LCS3=ITYPE.EQ.23
C     MPLMIN IS AVAILABLE FROM CURRENT RUN IN /PRBASE/, BUT SAVE TAPE
C       CANNOT BE CHECKED FOR ORIGINAL VALUE.  ASSUME IT IS SAME.
C     THIS SHOULD ONLY MATTER FOR PRESSURE BROADENING W/ COUPLED STATES
      IF (LCS.OR.LCS3) THEN
        IF (MPLMIN) THEN
          WRITE(6,*) ' *** CURRENT COUPLED STATES APPROXIMATION ',
     1               'HAS IDENTICAL +/- PROJECTIONS'
        ELSE
          WRITE(6,*) ' *** CURRENT COUPLED STATES APPROX HAS ',
     1               'BOTH +/- PROJECTIONS'
        ENDIF
          WRITE(6,*) '     WILL ATTEMPT TO VERIFY CONSISTENCY WITH '
     1               ,'SAVE TAPE'
      ENDIF
C     FOR ITYPE='3' CHECK JLEVEL/JLEV ARE CONSISTENT
      IF (ITYPE-10*(ITPYE/10).EQ.3) THEN
        CONSIS=.TRUE.
        NLV=0
        IXT=(NQNX-1)*NLEVX
        DO 4002 I=1,NLEVX
        IL=JLEVX(IXT+I)
        NLV=MAX(NLV,IL)
        CONSIS=CONSIS.AND.JLEVEL(2*IL-1).EQ.JLEVX(I)
 4002   CONSIS=CONSIS.AND.JLEVEL(2*IL).EQ.JLEVX(NLEVX+I)
        IF (NLV.EQ.NLVL.AND.CONSIS) THEN
          WRITE(6,*) ' *** ITYPE=3+10*N: JLEVEL/JLEV ARE CONSISTENT'
        ELSE
          WRITE(6,*) ' *** ERROR. ITYPE=3+10*N: INCONSISTENT JLEVEL/',
     1               'JLEV.  SHOULD AFFECT ONLY PRBR CALCULATION'
        ENDIF
      ENDIF
C
C     READ THROUGH JTOT/S-MATRICES FIRST TIME, TO SEE WHAT'S THERE
      NOPMX=0
      MAXMIN=0
      JTOLD=-1
      MSOLD=-1
C
 2000 READ(IT,END=9002) JTOT,INRG,ECHK,IEXCH,WT,M
      IF (JTOT.GT.JSTOP) GO TO 9004
C
C     SEE IF M-VALUE IS CONSISTENT W/ MHI,MSET AND MXPAR
      IF (M.GT.MXPAR.OR.M.LE.0) THEN
        WRITE(6,*) ' *** TERMINAL ERROR.  ILLEGAL M-VALUE',M
        WRITE(6,*) ' *** TERMINAL ERROR.  NOTE.  MXPAR =',MXPAR
        STOP
      ELSE
        IXX(M)=MAX(IXX(M),INRG)
      ENDIF
      IF (MSET.GT.0.AND.(M.LT.MSET.OR.M.GT.MHI)) THEN
        WRITE(6,612) M,MSET,MHI
  612   FORMAT(' *** RESTRT.  WARNING.  M =',I4,
     1         ' INCONSISTENT WITH CURRENT MSET,MHI =',2I4)
      ENDIF
C     CHECK CONSISTENCY OF INRG,ECHK
      IF (ABS(ECHK-ENERGX(INRG)).GT.1.D-8)
     1WRITE(6,611)  JTOT,M,INRG,ECHK
  611 FORMAT('0 *** WARNING.  FOR JTOT,M=',I4,'.',I2,' ENERGY('
     1       ,I4,'), BAD ECHK =',D16.8)
C
      IF (JTOT.EQ.JTOLD .OR. JTOLD.EQ.-1) GO TO 2011
C     NEW JTOT.  SAVE IRSTRT=1 VALUES; CHECK JSTEP CONSISTENCY
      JTSV(1)=JTSV(3)
      MSV(1)=MSV(3)
      INSV(1)=INSV(3)
      JSTEPX=JTOT-JTOLD
      IF (JSTEP.EQ.JSTEPX) GO TO 2011
      WRITE(6,609) JSTEP,JSTEPX
  609 FORMAT(' *** RSTRT.  TERMINAL ERROR. CURRENT/SAVED JSTEP =',2I6)
      STOP
 2011 JTOLD=JTOT
C
      IF (M.EQ.MSOLD.OR.MSOLD.EQ.-1) GO TO 2021
C     NEW PARITY (SYMMETRY) BLOCK; SAVE IRSTRT=2 VALUES, AND
C       REVISE IXX(LAST-M) TO REFLECT HIGHEST INRG IN LAST SET
      IXX(MSV(3))=INSV(3)
      JTSV(2)=JTSV(3)
      MSV(2)=MSV(3)
      INSV(2)=INSV(3)
 2021 MSOLD=M
C
 2002 READ(IT,END=9003) NOPEN,(JX,LX,WVX,I=1,NOPEN)
C
      IF (IXNEXT+IXR+NOPEN*NOPEN-1.LE.MX) THEN
        CALL SREAD(IT,NOPEN,RXX(IXR+1),IEND)
        IF (IEND.GT.0) GO TO 9003
        CALL SREAD(IT,NOPEN,RXX(IXR+1),IEND)
        IF (IEND.GT.0) GO TO 9003
      ELSE
        WRITE(6,*) ' *** RESTRT.  TERMINAL ERROR. INADEQUATE SCRATCH '
     1            ,'STORAGE FOR SREAL/SIMAG. NOPEN =',NOPEN
        STOP
      ENDIF
C     COMPLETE JTOT,M,INRG SET.  UPDATE NOPMX; SAVE IRSTRT=3 VALUES
      NOPMX=MAX(NOPMX,NOPEN)
      MAXMIN=MAX(MAXMIN,M)
      JTSV(3)=JTOT
      MSV(3)=M
      INSV(3)=INRG
C
C     GO BACK FOR MORE JTOT, INRG SETS . . .
      GO TO 2000
C
C     END OF FILE CONDITIONS
C
 9001 WRITE(6,*) ' *** TERMINAL ERROR.  PREMATURE EOF READING ISAVEU.'
      STOP
C
C     NORMAL END OF FILE AFTER A COMPLETED SET.
C     DETERMINE IF LAST INPUT COMPLETED 1) M-SET, 2) JTOT
C       AND MODIFY JTSV,MSV,INSV ACCORDINGLY
 9002 WRITE(6,699) ISAVEU
  699 FORMAT('0 *** NOTE.   NORMAL EOF REACHED ON UNIT (',I3,')')
      IF (INSV(3).EQ.IXX(MSV(3))) THEN
        WRITE(6,*)'             LAST INPUT APPEARS TO COMPLETE AN M-SET'
        JTSV(2)=JTSV(3)
        MSV(2)=MSV(3)
        INSV(2)=INSV(3)
        IF (MSV(3).EQ.MAXMIN) THEN
          WRITE(6,*) '             IT ALSO APPEARS TO COMPLETE A JTOT'
          JTSV(1)=JTSV(3)
          MSV(1)=MSV(3)
          INSV(1)=INSV(3)
        ENDIF
      ENDIF
C     IRSTRT=-1 CASES: TRY TO ASCERTAIN COMPLETENESS THROUGH JSTOP.
      IF (JSTOP.GE.IBIG) GO TO 3000
      IF (JTOT.NE.JSTOP) THEN
        WRITE(6,*) ' *** LAST COMPLETE JTOT,M,INRG=',
     1              JTSV(3),MSV(3),INSV(3)
        WRITE(6,*) ' *** ERROR.  LAST JTOT.NE.JSTOP',JTOT,JSTOP
        STOP
      ENDIF
      IF (JTSV(1).NE.JTOT) THEN
        WRITE(6,*) ' *** POSSIBLE ERROR.'
        WRITE(6,*) '     IT IS NOT CLEAR THAT FINAL JTOT SET IS',
     1             ' COMPLETE.  ASSUME IT IS.'
        WRITE(6,*) ' *** LAST COMPLETE JTOT,M,INRG=',
     1              JTSV(3),MSV(3),INSV(3)
        JTSV(1)=JTSV(3)
        MSV(1)=MSV(3)
        INSV(1)=INSV(3)
      ENDIF
      GO TO 3000
C
C     EOF WHILE READING S-MATRICES; ALL JTSV,MSV,INSV SHOULD BE CORRECT.
 9003 WRITE(6,698) ISAVEU
  698 FORMAT('0 *** NOTE. ABNORMAL EOF REACHED ON UNIT (',I3,')'/
     1       '            INCOMPLETE (JTOT,INRG,M)-SET')
      IF (JSTOP.LT.IBIG) THEN
        WRITE(6,*) ' *** ERROR.  ISAVEU DOES NOT HAVE ALL S-MATRICES',
     1             ' PRIOR TO REQUESTED RESTART AT JTOTL =',JTOTL
        WRITE(6,*) ' *** LAST COMPLETE JTOT,M,INRG=',
     1              JTSV(3),MSV(3),INSV(3)
        STOP
      ENDIF
      GO TO 3000
C     BELOW REACHED IF JSTOP EXCEEDED BEFORE EOF
C       FORCE JTSV(IRSTRT=1) VALUES TO LAST COMPLETED SET
 9004 WRITE(6,*) ' *** ISAVEU INPUT TERMINATED BY IRSTRT=-1, JSTOP ='
     1          ,JSTOP
      JTSV(1)=JTSV(3)
      MSV(1)=MSV(3)
      INSV(1)=INSV(3)
C
 3000 WRITE(6,630) JTSV(3),MSV(3),INSV(3)
  630 FORMAT(/'  ***',6X,' LAST COMPLETED (JTOT,M,INRG)-SET ---',3I5)
      IF (IRSTRT.NE.3)
     1    WRITE(6,631) IRSTRT,JTSV(IRSTRT),MSV(IRSTRT),INSV(IRSTRT)
  631 FORMAT('  *** FOR REQUESTED IRSTRT =',I2/
     1       '  ***',6X,' LAST COMPLETED (JTOT,M,INRG)-SET ---',3I5)
      WRITE(6,632)
  632 FORMAT('  ***',6X,' THESE S-MATRICES WILL BE REREAD/REPROCESSED')
C
C     ----------------------------------------------------------------
C     READ THROUGH TAPE AGAIN, ONLY THROUGH APPROPRIATE LAST SET
C       AND PROCESS S-MATRICES THROUGH OUTPUT/PRBR
C
C     ALLOCATE STORAGE FOR NB,J,L,WV,SR,SI; AND PRBR TEMPORARIES
C     PLACE THE REAL VARIABLES FIRST
      IXWV=1
      IXSR=IXWV+NOPMX
      IXSI=IXSR+NOPMX*NOPMX
      NREAL=IXSI+NOPMX*NOPMX
C     SPACE THE INTEGER VARIABLES BY NIPR
      IXNB=NREAL*NIPR+1
      IXJ=IXNB+NOPMX
      IXL=IXJ+NOPMX
      IT1=IXL+NOPMX
      IT2=IT1+NOPMX
      IT3=IT2+NOPMX
      IT4=IT3+NOPMX
C     NINT IS THE NUMBER OF REAL SPACES TAKEN BY THE INTEGERS
      NINT=(7*NOPMX+NIPR-1)/NIPR
      NUSED=NREAL+NINT
      NAVAIL=MX-IXNEXT+1
      IF (NUSED.GT.NAVAIL) THEN
        WRITE(6,*) '  *** RESTRT.  INADEQUATE SCRATCH STORAGE',
     1             ' TO PROCESS SAVED S-MATRICES.'
        STOP
      ENDIF
C
C     SET VALUES REQUIRED FOR OUTPUT/PRBR
      DO 4001 I=1,NOPMX
 4001 IXX(IXNB-1+I)=I
      RM=1.D0
      TTIME=0.D0
      ISIGPR=0
      CONV=0.D0
      ILSU=0
C     REQUEST MINIMAL OUTPUT FROM OUTPUT/PRBR ...
      IPRINT=MIN(1,PRNTLV)
C
      REWIND ISAVEU
      READ(IT,END=9999) LABEL,ITYPE,NLEV,NQN,URED,IP
      NSQ=NLEV*NQN
      READ(IT,END=9999) (JLEVX(I),I=1,NSQ)
      READ(IT,END=9999) NLEVEL,(ELEVEL(I),I=1,NLEVEL)
      READ(IT,END=9999) NNRGX,(ENERGX(I),I=1,NNRGX)
C     READ THROUGH JTOT/S-MATRICES FIRST TIME, TO SEE WHAT'S THERE
 4000 READ(IT,END=9999) JTOT,INRG,ECHK,IEXCH,WT,M
      MXP=MAX(MXP,M)
      READ(IT,END=9999) NOPEN,(IXX(IXJ-1+I),IXX(IXL-1+I),RXX(IXWV-1+I),
     1                         I=1,NOPEN)
      CALL SREAD(IT,NOPEN,RXX(IXSR),IEND)
      IF (IEND.GT.0) GO TO 9999
      CALL SREAD(IT,NOPEN,RXX(IXSI),IEND)
      IF (IEND.GT.0) GO TO 9999
C
      CALL OUTPUT(JTOT,IXX(IXNB),IXX(IXJ),IXX(IXL),
     1   RXX(IXWV),RXX(IXSR),RXX(IXSI),AKDUM,
     2   CONV,NOPEN,M,MXPAR,WT,INRG,RM,IPRINT,TTIME,
     3   ENERGX,SIG,    JLEVX,   ISST,IECONV,MINJT,MAXJT,
     4   NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR,IRSTRT)
C
C     BELOW DUPLICATES DRIVER (SG: I DON'T THINK IT IS USED ANYMORE.)
      MOLD=-M
      IF (M.EQ.MXPAR) MOLD=0
C
C     COUPLED STATES PRBR NEEDS MVALUE; CALC FROM M (NB IEXX NOT USED)
C     BELOW TRIES TO BE CONSISTENT WITH MOLSCAT; SHOULD BE MOOT AS IT
C       ONLY AFFECTS PRBR AND ITYPE=23/IDENT.NE.0 IS NOT SUPPORTED.
      IF (LCS.OR.LCS3) THEN
        IF (LCS3.AND.IDENT.NE.0) THEN
          IF (M.LE.MXPAR/2) THEN
            IEXX=1
            MVALUE=M-1
          ELSE
            IEXX=2
            MVALUE=M-(MXPAR/2)-1
          ENDIF
        ELSE
          MVALUE=M-1
        ENDIF
C       CHECK CONSISTENCY OF MPLMIN/MVALUE,WT
        IF ( MPLMIN.AND.(.NOT.((MVALUE.EQ.0.AND.WT.EQ.1.D0).OR.
     1       (MVALUE.GT.0.AND.WT.EQ.2.D0))) .OR.
     2      .NOT.MPLMIN.AND.MVALUE.NE.1.D0 )
     3       WRITE(6,*) ' *** INCONSISTENT MVALUE/WT'
      ENDIF
      CALL PRBR(JTOT,MOLD,NOPEN,INRG,RM,
     1   IXX(IXNB),IXX(IXJ),IXX(IXL),RXX(IXWV),
     2   RXX(IXSR),RXX(IXSI),IXX(IT1),IXX(IT2),IXX(IT3),IXX(IT4),
     3   JLEVX,MXPAR,WT,IPRINT,ILSU)
C
C     UNTIL WE HIT 'FINAL' SET, GO BACK FOR MORE JTOT,M,INRG ...
      IF (JTOT.NE.JTSV(IRSTRT).OR.M.NE.MSV(IRSTRT).OR.
     1    INRG.NE.INSV(IRSTRT)) GO TO 4000
C
C     WE HAVE NOW FINISHED REPROCESSING THE 'SAVED' S-MATRICES
C
      CALL GCLOCK(TEND)
      TUSED=TEND-TSTART
      WRITE(6,634) NUSED,NAVAIL,TUSED
  634 FORMAT('  *** RESTRT.  REPROCESSING COMPLETED.  IT REQUIRED'/
     1       5X,I9,' OF THE',I12,
     2      ' CURRENTLY AVAILABLE WORDS OF STORAGE'/
     3        9X,'AND',F8.2,' CPU SECONDS.')
C
C     CHOOSE 'NEXT' JTOTL,MRSTRT,IERST AND PUT IN CALLING ARGUMENTS
      IF (IRSTRT.EQ.3) THEN
        JTOTL=JTSV(3)
        MRSTRT=MSV(3)
        IERST=INSV(3)+1
        IF (IERST.GT.NNRG.OR.IERST.GT.IXX(MRSTRT)) THEN
          IERST=1
          MRSTRT=MRSTRT+1
          IF (MRSTRT.GT.MXPAR.OR.MRSTRT.GT.MAXMIN) THEN
            MRSTRT=1
            JTOTL=JTOTL+JSTEP
          ENDIF
        ENDIF
      ELSEIF (IRSTRT.EQ.2) THEN
        JTOTL=JTSV(2)
        MRSTRT=MSV(2)+1
        IERST=1
        IF (MRSTRT.GT.MXPAR.OR.MRSTRT.GT.MAXMIN) THEN
          MRSTRT=1
          JTOTL=JTOTL+JSTEP
        ENDIF
      ELSEIF (IRSTRT.EQ.1) THEN
        MRSTRT=1
        IERST=1
        JTOTL=JTSV(1)+JSTEP
      ENDIF
      WRITE(6,635) JTOTL,MRSTRT,IERST
  635 FORMAT('  *** RESTRT.  CALCULATION WILL BE RESTARTED AT'/
     1       15X,'JTOT =',I4,',  M =',I3,',  ENERGY(',I4,')')
C
      RETURN
C
 9999 WRITE(6,*) '  *** RESTRT. ERROR: UNEXPECTED EOF REREADING ISAVEU'
      STOP
      END
      SUBROUTINE DRIVER
C***********************************************************************
C
C  ------  MOLSCAT - J.M. HUTSON AND S.GREEN - VERSION 12 - FEB 94 -----
C  ------  W/ MODIFICATIONS FOR RESTART CODE -- COMPATIBLE W/ NEW CPLING
C
C   MAIN DRIVER FOR QUANTUM MOLECULAR SCATTERING PROGRAM
C
C   REVISION HISTORY SINCE VERSION 7 OF SHELDON GREEN'S QCPE PROGRAM
C   (MAY 79):
C
C   VARIOUS NEW PROPAGATORS HAVE BEEN ADDED SINCE EARLY VERSIONS.
C   THE COMPLETE LIST IN VERSION 11 IS:
C
C     INTFLG =-1 : WKB METHOD FOR SINGLE CHANNEL, SINGLE TURNING POINT
C     INTFLG = 2 : DEVOGELAERE'S PROPAGATOR
C     INTFLG = 3 : WALKER-LIGHT R-MATRIX PROPAGATOR
C     INTFLG = 4 : HYBRID LOG-DERIVATIVE / VIVS (VIVAS) PROPAGATOR
C     INTFLG = 5 : JOHNSON'S LOG-DERIVATIVE PROPAGATOR
C     INTFLG = 6 : MANOLOPOULOS'S DIABATIC MODIFIED
C                  LOG-DERIVATIVE PROPAGATOR
C     INTFLG = 7 : MANOLOPOULOS'S QUASIADIABATIC MODIFIED
C                  LOG-DERIVATIVE PROPAGATOR
C     INTFLG = 8 : ALEXANDER-MANOLOPOLOUS MODIFIED LOG-DERIVATIVE
C                   AIRY PROPAGATOR (HIBRIDON)
 
C   VERSION 8: CHANGES MADE BY CHRIS ASHTON (1982) AND JEREMY HUTSON
C              (1982-4) AT WATERLOO AND CAMBRIDGE UNIVERSITIES.
C
C   (1) ENTIRE PROGRAM CONVERTED TO DOUBLE PRECISION
C
C   (2) GORDON ALGORITHM (INTFLG=1) REMOVED.
C
C   (3) LOOP OVER "PARITY CASES" IN DRIVER HAS BEEN MADE EXPLICIT
C       FOR CLARITY.
C
C   (4) EIGENPHASE SUM CALCULATION AND RESONANCE SEARCH OPTION
C       INCORPORATED. NEW OUTPUT CHANNEL (KSAVE) WITH OPTIONAL
C       UNFORMATTED OUTPUT ON CHANNEL ISAVEU.
C
C   (5) COLLISION TYPE ITYPE=10*N+7 HAS BEEN ADDED,
C       FOR AN ATOM HITTING A DIATOMIC VIB-ROTOR, WHERE THE
C       POTENTIAL MATRIX IS CONSTRUCTED BY DOING PROPERLY THE
C       AVERAGING OF POTENTIAL TERMS OVER (V,J) AND (V',J') DIATOM
C       INTERNAL STATES.
C
C   (6) COLLISION TYPE ITYPE=8 ADDED, FOR ELASTIC SCATTERING OF ATOMS
C       FROM CORRUGATED SURFACES. USES SUBROUTINE SURBAS TO SET UP
C       THE BASIS SET. THE LOOPS IN DRIVER OVER JTOT AND M ARE USED
C       TO LOOP OVER ANGLES THETA AND PHI RESPECTIVELY.
C
C   (7) THE STORAGE OF THE COUPLING ARRAY VL HAS BEEN REARRANGED. THE
C       METHOD OF CONSTRUCTING POTENTIAL MATRICES FROM IT HAS BEEN
C       CHANGED, AND IN PARTICULAR A NEW INDEXING ARRAY IV HAS BEEN
C       INTRODUCED.
C
C***********************************************************************
C
C  VERSION 9 (APR 86): JMH AND SG CODES UNIFIED
C
C   (9)  IOS CODE RE-INCORPORATED FROM SG'S PROGRAM.
C        IT IS ACCESSED BY SETTING ITYPE = 100 + 'ITYPE'
C
C   (10) MANOLOPOULOS'S DIABATIC AND ADIABATIC MODIFIED LOG-DERIVATIVE
C        PROPAGATORS ADDED (INTFLG=6 AND 7 RESPECTIVELY).
C
C***********************************************************************
C
C  SG VERSION 10 (AUG 91):
C
C  (10) NEW PRBR/IOSPB FOR OFF-DIAGONAL LINESHAPE CROSS SECTIONS,
C       WITH HAS IN-CORE SIMULATION OF DIRECT ACCESS FILES.
C       OUTPUT CROSS-SECTIONS NOW MULTIPLIED BY JSTEP (FOR JTOT).
C
C  (11) ALEXANDER/MANOLOPOULOS MODIFIED LOG-DERIVATIVE/AIRY PROPAGATOR
C       ADDED AS INTFLG=8. INTERFACED BY TIM PHILLIPS (NASA/GISS)
C
C  VERSION 11 (JUN 92): JMH AND SG CODES INTEGRATED AGAIN.
C
C  (12) LOOP OVER ENERGY IN DRIVER MODIFIED TO SIMPLIFY PARALLELISATION
C
C  (13) ISAVEU OUTPUT MODIFIED TO USE UNFORMATTED WRITES
C
C  (14) USAGE OF LINEAR ALGEBRA AND BLAS ROUTINES UNIFIED
C
C  AND THE FOLLOWING ENHANCEMENTS ADDED FROM JMH'S CODE:
C
C  (15) BASE9 INTERFACE ADDED
C
C  (16) POTENL ENHANCED TO EVALUATE RADIAL STRENGTH FUNCTIONS BY
C       QUADRATURE FOR ITYPE=1, 2, 5 AND 6.
C
C  (17) CODE ADDED TO CALCULATE ASYMMETRIC TOP ENERGIES AND WAVEFUNCTION
C       FROM ROTATIONAL CONSTANTS. MECHANISM FOR SELECTING ASYMMETRIC
C       TOP STATES TO BE INCLUDED GENERALISED
C
C  (18) CODE FOR ATOM-SPHERICAL TOP SCATTERING ADDED
C
C***********************************************************************
C
C  VERSION 12 (MAY 93)
C
C  (19) DYNAMIC STORAGE HANDLING COMPLETELY REORGANIZED.
C
C  (20) VECTOR/MATRIX ROUTINES RATIONALIZED TO USE LAPACK AND BLAS.
C
C  (21) IV() ARRAY USED ONLY FOR 'NON-TRIVIAL' CASES.
C
C  (22) OPTION TO WRITE VL ARRAY TO DISC TO AVOID EXCESSIVE MEMORY USE.
C
C  (23) SOME CODE FOR COUPLING VL MATRIX ELEMENTS MODIFIED TO AVOID
C       UNNECESSARY RECALCULATION OF NJ COEFFICIENTS
C
C***********************************************************************
C
C   EXTERNAL UNITS FOR MASSES ARE ATOMIC MASS UNITS (CARBON MASS/12)
C   EXTERNAL UNITS FOR ENERGIES ARE WAVENUMBERS
C   EXTERNAL UNITS FOR LENGTH RM ARE ANGSTROMS
C   ALL OTHER LENGTHS ARE IN UNITS OF RM
C
C   INTFLG CONTROLS METHOD OF SOLVING EQUATIONS.  NPOTL AND MXLAM
C   FOR SUM OVER ANGULAR DEPENDENCE OF POTENTIAL,  NQN IS NO. OF
C   QUANTUM NUMBERS NECESSARY TO DESCRIBE COLLISION PARTNERS.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     *****  PROGRAM DIMENSION LIMITATIONS  *****
C     ENERGY,TEMP,RTURNM,LINE DIMENSIONS LIMITED BY VALUES ...
      PARAMETER(MXNRG=100,MXLN=200,MXTEMP=5,MXRTM=100)
C
      INTEGER EUNITS,PRNTLV,PRINT,SHRINK
C
C   ARRAY TO HOLD TIME AND DATE
C     INTEGER CTIME(2),CDATE(4)
      CHARACTER CTIME*9,CDATE*11
C
C   TYPES FOR COMMON/LDVVCM/
      LOGICAL IALFP,IV,IVP,IVPP,NUMDER,ISHIFT,IDIAG,IPERT,ISYM
      LOGICAL LCALC,ALDONE
      LOGICAL IREAD,IWRITE
C
C     DOUBLE PRECISION LABEL(10)
      CHARACTER*80 LABEL
      CHARACTER*80 LABL
      CHARACTER*1 TITLE(80),TIT(120),TIT2(120),BL
      CHARACTER*8 PDATE
      CHARACTER*8 CWD(2)
      EQUIVALENCE (LABL,TITLE(1))
C
C   FOLLOWING ARRAYS ALL HAVE DIMENSION MXNRG. MXNRG IS THE MAXIMUM
C   ALLOWED NUMBER OF TOTAL ENERGIES PER RUN.
      DIMENSION ENERGY(MXNRG)
      DIMENSION IECONV(MXNRG),ISST(MXNRG),MINJT(MXNRG),MAXJT(MXNRG)
C
C   ARRAY TO SAVE TURNING POINTS FROM DIFFERENT PARITY CASES
C   FOR IRMSET > 0 OPTION.
      DIMENSION RTURNM(MXRTM)
C
C   VARIABLES DIMENSIONED FOR NO. OF LINES IN PRES. BROAD. CALC.
C   N.B. PRBRIN STILL MAX NO. LINES = 2*MXLN DESPITE OFF-DIAG CHANGES
      DIMENSION LINE(2*MXLN),LTYPE(MXLN)
      EQUIVALENCE (ILSU,IPRBRU), (NLPRBR,IFLS)
C
      DIMENSION TEMP(MXTEMP)
C
C     VARIABLES TO TEST PARTIAL WAVE CONVERGENCE
      DIMENSION TEST(2)
      EQUIVALENCE (TEST(1),DTOL),(TEST(2),OTOL)
C
      DIMENSION NLABV(9)
C
C   DYNAMIC STORAGE COMMON BLOCK ...
      COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1)
C     MX,IXNEXT ARE MAX AND NEXT AVAILABLE LOCATION IN X() ARRAY
C     IVLFL FLAGS WHETHER IV() ARRAY IS USED AS POINPER W/ VL ARRAY.
C     NIPR IS NUMBER OF INTEGERS PER REAL; SHOULD BE 1 OR 2.
C       E.G. FOR IBM R*8/I*4, NIPR=2.  AN INTEGER ARRAY OF DIM. N
C       CAN BE STORED IN A REAL ARRAY OF DIMENSION (N+NIPR-1)/NIPR.
C
C     COMMON BLOCK FOR COMMUNICATING WITH COUPLED EQUATION SOLVERS
      COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RSTART,RSTOP,XEPS,
     1 DR,DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA,
     2 NOPEN,JKEEP,ISCRU,MAXSTP
C
C     EXTRA COMMON BLOCK FOR LDVIVS
      COMMON/LDVVCM/XSQMAX,ALPHA1,ALPHA2,IALPHA,IALFP,IV,IVP,IVPP,
     1 NUMDER,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE
C
C     COMMON BLOCK FOR WKB INTEGRATOR
      COMMON/WKBCOM/NGMP(3)
C
C     COMMON BLOCK TO SUBROUTINE OUTPUT FOR USE IN RESONANCE SEARCHES
      COMMON/EIGSUM/EPSM(5)
C
C     COMMON BLOCK FOR AIRPRP ARGUMENTS IN MANOLOPOLOUS/ALEXANDER
C     PROPAGATOR
      COMMON/HIBRIN/POWRX,DRAIRY,IABSDR
C
      COMMON/VLSAVE/IVLU
C
      NAMELIST /INPUT/ LABEL,RMIN,RMAX,IRMSET,IRXSET,URED,ISCRU,ISIGPR
     1  ,ITHROW,STEST,NNRG,ENERGY,DNRG,JTOTL,JTOTU,JSTEP,MSET,MHI,NCAC
     2  ,PRNTLV,INTFLG,MXSIG,STEPS,STABIL,NTEMP,NGAUSS,TEMP,EUNITS
     3  ,ISIGU,IPARTU,ILSU,IPRBRU,IFLS,NLPRBR,LINE,IFEGEN,LTYPE,MAXSTP
     4  ,TOLHI,RVIVAS,RVFAC,XSQMAX,ALPHA1,ALPHA2,IALPHA
     5  ,IALFP,IV,IVP,IVPP,NUMDER,ISHIFT,IDIAG,IPERT,ISYM
     6  ,ISAVEU,DTOL,OTOL,KSAVE,DR,DRNOW,DRMAX,RMID,VTOL,ICONV
     7  ,THETLW,THETST,PHILW,PHIST,MXPHI,SHRINK,LASTIN
     8  ,MMAX,LMAX,NGMP
     9  ,VMAX,TMAX,TOLLO,CTOL,UTEST,TOLER,TOL,MXXX,MNNN
     A  ,POWRX,DRAIRY,IABSDR,NNRGPG,IRSTRT
C
      EQUIVALENCE (MXPAR,MXPHI), (RMID,RVIVAS), (DR,DRNOW),
     1   (TOL,TOLER,TOLHI)
C
C     NGPT,LMAX, MMAX, AND NGMP(3) ARE VARIABLES ADDED FOR
C     COMPATIBILITY WITH THE IOS PROGRAMS
C     VARIABLES VMAX,...,MNNN ADDED FOR COMPATIBILITY WITH S.GREEN CODE
C     (MOSTLY GORDON INTEGRATOR).  ALSO TOL, TOLER, DRNOW
C
C     RMIN IS THE RADIUS AT WHICH THE INTEGRATION IS BEGUN
C     RMAX IS THE OUTER RADIUS TO WHICH THE INTEGRATION MUST EXTEND
C     MAXSTP IS MAX NO. OF STEPS IN RADIAL INTEGRATION (INTFLG=3 ONLY)
C
C     ARRAYS FOR NAMELIST SIMULATOR
C     CHARACTER*6 INAMES
C     DIMENSION INAMES(88),LOCN(88),INDX(88)
C
C     DATA INAMES/'LABEL','RMIN','RMAX','IRMSET','IRXSET',
C    1  'URED','ISCRU','ISIGPR',
C    1  'ITHROW','STEST','NNRG','ENERGY','DNRG',
C    2  'JTOTL','JTOTU','JSTEP','MSET','MHI','NCAC',
C    2  'PRNTLV','INTFLG','MXSIG','STEPS','STABIL',
C    3  'NTEMP','NGAUSS','TEMP','EUNITS','ISIGU','IPARTU','ILSU',
C    4  'IPRBRU','IFLS','NLPRBR','LINE','IFEGEN','LTYPE','MAXSTP',
C    4  'TOLHI','RVIVAS','RVFAC','XSQMAX','ALPHA1','ALPHA2','IALPHA',
C    5  'IALFP','IV','IVP','IVPP','NUMDER','ISHIFT','IDIAG','IPERT',
C    6  'ISYM','ISAVEU','DTOL','OTOL','KSAVE','DR','DRNOW','DRMAX',
C    7  'RMID','VTOL','ICONV','THETLW','THETST','PHILW','PHIST',
C    8  'MXPHI','SHRINK','LASTIN','MMAX','LMAX','NGMP','VMAX',
C    9  'TMAX','TOLLO','CTOL','UTEST','TOLER','TOL','MXXX','MNNN'
C    A  'PWRX','DRAIRY','IABSDR','NNRGPG','IRSTRT'/
C     DATA INDX/87*0/
C
C     DATA LABEL/10*'        '/
      DATA CWD/'       ','(8-BYTE)'/
      DATA CTIME/'         '/,CDATE/'           '/
      DATA IPROGM/12/, PDATE/'(FEB 94)'/
      DATA TITLE/80*' '/, BL/' '/
      DATA TIT/120*'='/, TIT2/120*'-'/
C
      DATA LTYPE/MXLN*-1/
C
C     NLABV ARRAY CONTAINS NUMBER OF LABELS PER SYMMETRY TERM FOR EACH
C     VALUE OF ITYPE
      DATA NLABV/1,3,3,-1,2,2,5,2,1/
C
C   THE PHYSICAL CONSTANTS USED ARE COMBINED IN THE SINGLE NUMBER BFCT.
C   BFCT IS 0.5*(HBAR**2) IN UNITS OF (ATOMIC MASS UNITS)*(WAVENUMBERS)
C   *(ANGSTROMS**2).
C   THE FOLLOWING VALUE IS FROM THE 1973 PHYSICAL CONSTANTS.
      DATA BFCT/16.857630D0/
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     CALL ROUTINE TO MASK FLOATING-POINT UNDERFLOW.
      CALL MASK
C
      MXSAVE=MX
  100 CALL GCLOCK(TFIRST)
      CALL GDATE(CDATE)
      CALL GTIME(CTIME)
      WRITE(6,110) IPROGM,PDATE,CDATE,CTIME,IPROGM
  110 FORMAT(2X,8('----MOLSCAT----')/' |',120X,'|'/' |',24X,
     1 'COUPLED CHANNEL MOLECULAR SCATTERING PROGRAM OF J. M. HUTSON ',
     2 'AND S. GREEN',23X,'|'/' |',29X,'VERSION 1 BY S. GREEN ',
     3 '(NOV 1973);  THIS IS VERSION',I3,1X,A8,29X,'|'/
     4 ' |',120X,'|'/' |',44X,'RUN ON ',A11,2X,
     5 'AT ',A9,44X,'|'/' |',120X,'|'/2X,8('----MOLSCAT----')//
     6 2X,'PUBLICATIONS RESULTING FROM THE USE OF THIS PROGRAM SHOULD ',
     7 'REFER TO'/2X,'J. M. HUTSON AND S. GREEN, MOLSCAT COMPUTER ',
     8 'CODE, VERSION',I3,' (1993)'/
     9 2X,'DISTRIBUTED BY COLLABORATIVE COMPUTATIONAL PROJECT NO. 6 ',
     A 'OF THE SCIENCE AND ENGINEERING RESEARCH COUNCIL (UK)')
C
C     INITIALIZE STORAGE PARAMETERS IN /MEMORY/
      NIPR=2
      IXNEXT=1
C     SET IVLFL TO 1 TO ENSURE STORAGE COMPATIBILITY W/ VERSION 11
      IVLFL=1
C     SET NUSED.LT.0 AND CALL CHKSTR TO RESET COUNTER FOR EACH &INPUT.
      NUSED=-1
      CALL CHKSTR(NUSED)
C
C   SET INITIAL VALUES BEFORE READ(5,INPUT) . . .
C
      IRSTRT=0
      IOSFLG=0
      NGMP(1)=8
      NGMP(2)=1
      NGMP(3)=16
      NNRG=0
      NNRGPG=1
      DNRG=0.D0
      NTEMP=0
      NGAUSS=3
      JSTEP=1
      JTOTL=-1
      JTOTU=-1
      MSET=0
      MHI=0
      MXSIG=0
      ISIGPR=0
      ITHROW=0
      DTOL=0.3D0
      OTOL=.005D0
      NCAC=4
      ISIGU = 0
      IPARTU=0
      ISAVEU=0
      KSAVE=0
      ILSU=11
      IFLS=0
      IFEGEN=0
      ICONV=0
      INTFLG=4
      RMIN=0.8D0
      RMAX=10.D0
      STEST=1.D-4
      STEPS=10.D0
      STABIL=5.D0
      ISCRU=0
      IRMSET=9
      IRXSET=1
      DR=2.D-2
      RMID=9999.D0
      RVFAC=0.D0
      DRMAX=5.D0
      VTOL=1.D-06
      MAXSTP=10000
      TOLHI=0.001D0
      XSQMAX=1.D04
      ALPHA1=1.D0
      ALPHA2=1.5D0
      IALPHA=6
      IALFP=.FALSE.
      IV=.TRUE.
      IVP=.FALSE.
      IVPP=.FALSE.
      NUMDER=.FALSE.
      ISHIFT=.FALSE.
      IDIAG=.FALSE.
      IPERT=.TRUE.
      ISYM=.TRUE.
      EUNITS=0
      PRNTLV=0
      MXPHI=1
      THETLW=0.D0
      THETST=0.D0
      PHILW=0.D0
      PHIST=0.D0
      SHRINK=1
      LASTIN=1
      PI=ACOS(-1.D0)
      POWRX=3.D0
      DRAIRY=-1.D0
      IABSDR=0
C
C     READ &INPUT  DATA.
C     OPEN(5,STATUS='OLD',SHARED,READONLY)
C----------------------------------------------------------------
C     ARRAYS FOR NAMELIST SIMULATOR
C     LOCN(1)=LOC(LABEL)
C     LOCN(2)=LOC(RMIN)
C     LOCN(3)=LOC(RMAX)
C     LOCN(4)=LOC(IRMSET)
C     LOCN(5)=LOC(IRXSET)
C     LOCN(6)=LOC(URED)
C     LOCN(7)=LOC(ISCRU)
C     LOCN(8)=LOC(ISIGPR)
C     LOCN(9)=LOC(ITHROW)
C     LOCN(10)=LOC(STEST)
C     LOCN(11)=LOC(NNRG)
C     LOCN(12)=LOC(ENERGY)
C     LOCN(13)=LOC(DNRG)
C     LOCN(14)=LOC(JTOTL)
C     LOCN(15)=LOC(JTOTU)
C     LOCN(16)=LOC(JSTEP)
C     LOCN(17)=LOC(MSET)
C     LOCN(18)=LOC(MHI)
C     LOCN(19)=LOC(NCAC)
C     LOCN(20)=LOC(PRNTLV)
C     INDX(20)=4
C     LOCN(21)=LOC(INTFLG)
C     LOCN(22)=LOC(MXSIG)
C     LOCN(23)=LOC(STEPS)
C     LOCN(24)=LOC(STABIL)
C     LOCN(25)=LOC(NTEMP)
C     LOCN(26)=LOC(NGAUSS)
C     LOCN(27)=LOC(TEMP)
C     LOCN(28)=LOC(EUNITS)
C     INDX(28)=4
C     LOCN(29)=LOC(ISIGU)
C     LOCN(30)=LOC(IPARTU)
C     LOCN(31)=LOC(ILSU)
C     LOCN(32)=LOC(IPRBRU)
C     LOCN(33)=LOC(IFLS)
C     LOCN(34)=LOC(NLPRBR)
C     LOCN(35)=LOC(LINE)
C     LOCN(36)=LOC(IFEGEN)
C     LOCN(37)=LOC(LTYPE)
C     LOCN(38)=LOC(MAXSTP)
C     LOCN(39)=LOC(TOLHI)
C     LOCN(40)=LOC(RVIVAS)
C     LOCN(41)=LOC(RVFAC)
C     LOCN(42)=LOC(XSQMAX)
C     LOCN(43)=LOC(ALPHA1)
C     LOCN(44)=LOC(ALPHA2)
C     LOCN(45)=LOC(IALPHA)
C     LOCN(46)=LOC(IALFP)
C     LOCN(47)=LOC(IV)
C     LOCN(48)=LOC(IVP)
C     LOCN(49)=LOC(IVPP)
C     LOCN(50)=LOC(NUMDER)
C     LOCN(51)=LOC(ISHIFT)
C     LOCN(52)=LOC(IDIAG)
C     LOCN(53)=LOC(IPERT)
C     LOCN(54)=LOC(ISYM)
C     DO 115 I=46,54
C 115 INDX(I)=3
C     LOCN(55)=LOC(ISAVEU)
C     LOCN(56)=LOC(DTOL)
C     LOCN(57)=LOC(OTOL)
C     LOCN(58)=LOC(KSAVE)
C     LOCN(59)=LOC(DR)
C     LOCN(60)=LOC(DRNOW)
C     LOCN(61)=LOC(DRMAX)
C     LOCN(62)=LOC(RMID)
C     LOCN(63)=LOC(VTOL)
C     LOCN(64)=LOC(ICONV)
C     LOCN(65)=LOC(THETLW)
C     LOCN(66)=LOC(THETST)
C     LOCN(67)=LOC(PHILW)
C     LOCN(68)=LOC(PHIST)
C     LOCN(69)=LOC(MXPHI)
C     LOCN(70)=LOC(SHRINK)
C     INDX(70)=4
C     LOCN(71)=LOC(LASTIN)
C     LOCN(72)=LOC(MMAX)
C     LOCN(73)=LOC(LMAX)
C     LOCN(74)=LOC(NGMP)
C     LOCN(75)=LOC(VMAX)
C     LOCN(76)=LOC(TMAX)
C     LOCN(77)=LOC(TOLLO)
C     LOCN(78)=LOC(CTOL)
C     LOCN(79)=LOC(UTEST)
C     LOCN(80)=LOC(TOLER)
C     LOCN(81)=LOC(TOL)
C     LOCN(82)=LOC(MXXX)
C     LOCN(83)=LOC(MNNN)
C     LOCN(84)=LOC(POWRX)
C     LOCN(85)=LOC(DRAIRY)
C     LOCN(86)=LOC(IABSDR)
C     LOCN(87)=LOC(NNRGPG)
C     LOCN(88)=LOC(IRSTRT)
C
C     CALL NAMLIS('&INPUT',INAMES,LOCN,INDX,87,IEOF)
C     IF(IEOF.EQ.1) GOTO 1040
C--------------------------------------------------------------
      READ(5,INPUT,END=1040)
C
      WRITE(6,120)
  120 FORMAT(/'0 /INPUT/  DATA ARE  --')
      WRITE(LABL,'(A80)') LABEL
      WRITE(6,130)  LABL
  130 FORMAT('0 RUN LABEL = ',A80)
      DO 140 IST=1,80
      IF(TITLE(IST).NE.BL) GOTO 150
  140 CONTINUE
      GOTO 190
  150 DO 160 IND=1,80
      IF(TITLE(81-IND).NE.BL) GOTO 170
  160 CONTINUE
      GOTO 190
  170 IND=81-IND
      NST=(119-IND+IST)/2
      TIT(NST)=BL
      TIT2(NST)=BL
      DO 180 I=IST,IND
      NST=NST+1
      TIT(NST)=TITLE(I)
      TIT2(NST)=TITLE(I)
  180 CONTINUE
      TIT(NST+1)=BL
      TIT2(NST+1)=BL
C
  190 AMXKB=MX/128.D0
      IF (NIPR.EQ.1.OR.NIPR.EQ.2) THEN
        WRITE(6,200) MX,CWD(NIPR),AMXKB
  200   FORMAT('0 SCRATCH CORE STORAGE ALLOCATION IS',I10,A8,
     1         ' WORDS (',F8.2,' KBYTES)')
        WRITE(6,202) NIPR
  202   FORMAT(2X,I1,' INTEGER(S) CAN BE STORED IN EACH WORD.')
      ELSE
        WRITE(6,204) NIPR
  204   FORMAT(/' *** ILLEGAL NIPR =',I10)
        STOP
      ENDIF
C
      PRINT=PRNTLV
C
C   PROCESS INTFLG  -- REQUESTED PROPAGATOR -- AND ITS INPUT DATA.
C
      WRITE(6,210) INTFLG
  210 FORMAT('0 INTEGRATOR REQUESTED BY INPUT VALUE INTFLG =',I3)
  220 FORMAT('0***** ERROR - NO IMPLEMENTATION FOR THIS INTFLG'
     1       ,'  -  RUN HALTED.')
  240 FORMAT('0 COUPLED EQUATIONS SOLVED BY METHOD OF DEVOGELAERE.')
  250 FORMAT('0 INTEGRATION PARAMETERS ARE  RMIN   =',F7.2/
     1  30X,'RMAX   =',F7.2/30X,'STEST  =',D11.2/30X,'STEPS  =',
     2 F6.1,'  (PER WAVELENGTH)'/30X,'STABIL =',F6.1,'  (STEPS PER',
     3 ' STABILIZATION)')
  270 FORMAT('0 COUPLED EQUATIONS SOLVED BY WALKER-LIGHT R-MATRIX',
     1 ' PROPAGATOR ALGORITHM'/'0 PARAMETERS ARE',5X,'RMIN   =',
     2 F7.2,8X,'DR     = ',G8.2/21X,'RMAX   =',F7.2,8X,
     3 'VTOL   =',D9.2/21X,'RMID   =',F7.2,8X,'MAXSTP =',I9)
  271 FORMAT('0',' RVFAC =',F7.2,'  OVERRIDES INPUT RMID')
  300 FORMAT('0 COUPLED EQUATIONS SOLVED BY LOG DERIVATIVE METHOD ',
     1 'OF JOHNSON')
  310 FORMAT('0 INTEGRATION PARAMETERS ARE     RMIN   =',F7.2,8X,
     1  'STEPS  = ',F7.1/33X,'RMAX   =',F7.2)
  320 FORMAT('0 CHANGING TO VARIABLE INTERVAL / VARIABLE STEP METHOD',
     1   ' AT LONG RANGE'/'0 INTEGRATION PARAMETERS ARE     RVIVAS =',
     2   F7.2,8X,'DR     =',G8.2/
     3   33X,'RMAX   =',F7.2,8X,'DRMAX  =',F8.2/
     4   56X,'ALPHA1 = ',F7.2/33X,'XSQMAX =',G7.1,8X,'ALPHA2 = ',F7.2/
     5   33X,'TOLHI  =',G7.1,8X,'IALPHA =',I8/33X,'ISHIFT =',L7,8X,
     6   'IV     =',L8/33X,'IPERT  =',L7,8X,'IVP    =',L8/33X,
     7   'IALFP  =',L7,8X,'IVPP   =',L8/33X,'ISYM   =',L7,8X,
     8   'NUMDER =',L8)
  340 FORMAT('0 COUPLED EQUATIONS SOLVED BY DIABATIC ',
     1 'MODIFIED LOG DERIVATIVE METHOD OF MANOLOPOULOS')
  350 FORMAT('0 COUPLED EQUATIONS SOLVED BY QUASIADIABATIC ',
     1 'MODIFIED LOG DERIVATIVE METHOD OF MANOLOPOULOS')
  352   FORMAT(33X,'IABSDR =',I4)
  353   FORMAT(33X,'OVERRIDES STEPS PARAMETER WITH DR =',F9.3)
  354   FORMAT('0            AIRY PARAMETERS     ','RMID  =',F10.4/
     2        33X,'DRAIRY=',F10.4/33X,'TOLHI=',F13.6/
     3        33X,'POWRX =',F8.2)
  355   FORMAT('0 DRAIRY.LT.0 TAKES INITIAL AIRY STEP SIZE FROM'
     1      ,' MODIFIED LOG-DERIVATIVE VALUE.')
  356     FORMAT('0 TOLHI.GE.1  --  AIRY STEP SIZE INCREASED BY'
     1      ,' FACTOR OF TOLHI AT EACH STEP')
  357     FORMAT('0 TOLHI.LT.1  --  AIRY STEPS ADJUSTED TO MAINTAIN'
     1      ,' APPROX. ACCURACY VIA PERTURBATION THEORY AND POWRX.')
  370 FORMAT('0 EQUATIONS SOLVED BY WKB APPROXIMATION WITH GAUSS-'
     1      ,'MEHLER INTEGRATION.  SEE R. T PACK, JCP 60, 633 (1974).'/
     2      '0 NOTE THAT THIS IS IMPLEMENTED ONLY FOR ONE CHANNEL',
     3      ' CASES, E.G., IOS CALCULATIONS.'/
     4      '0 INTEGRATION PARAMETERS ARE  RMIN =',D15.4/
     5       30X,'STEST =',D14.4/30X,'NGMP =',I6,' (',I2,')',I3)
C
      IF(INTFLG.EQ.2) THEN
        WRITE(6,240)
C       STABIL=MIN(STABIL,STEPS/2.D0)
        WRITE(6,250) RMIN,RMAX,STEST,STEPS,STABIL
        GO TO 380
      ENDIF
C
      IF(INTFLG.EQ.3) THEN
        WRITE(6,270) RMIN,DR,RMAX,VTOL,RMID,MAXSTP
        IF(RVFAC.GT.0.D0 .AND. IRMSET.GT.0) WRITE(6,271) RVFAC
        GO TO 380
      ENDIF
C
      IF(INTFLG.EQ.4 .OR. INTFLG.EQ.5) THEN
        IF(IDIAG) THEN
          IV=.TRUE.
          IVP=.TRUE.
          IVPP=.TRUE.
          ISHIFT=.TRUE.
          IPERT=.TRUE.
        ENDIF
        IF(INTFLG.EQ.5) RVIVAS=RMAX
        WRITE(6,300)
        WRITE(6,310) RMIN,STEPS,RVIVAS
        IF(INTFLG.EQ.4) WRITE(6,320) RVIVAS,DR,RMAX,DRMAX,ALPHA1,XSQMAX,
     1    ALPHA2,TOLHI,IALPHA,ISHIFT,IV,IPERT,IVP,IALFP,IVPP,ISYM,NUMDER
        GO TO 380
      ENDIF
C
      IF(INTFLG.EQ.6) THEN
        WRITE(6,340)
        WRITE(6,310) RMIN,STEPS,RMAX
        GO TO 380
      ENDIF
C
      IF(INTFLG.EQ.7) THEN
        WRITE(6,350)
        WRITE(6,310) RMIN,STEPS,RMAX
        GO TO 380
      ENDIF
C
      IF(INTFLG.EQ.8) THEN
        CALL MHAACK(6)
        WRITE(6,310) RMIN,STEPS,RMAX
        WRITE(6,352) IABSDR
        IF(IABSDR.EQ.1) WRITE(6,353) DR
        WRITE(6,354) RMID,DRAIRY,TOLHI,POWRX
        IF(RVFAC.GT.0.D0.AND.IRMSET.GT.0) WRITE(6,271) RVFAC
        IF(DRAIRY.LT.0.D0) WRITE(6,355)
        IF(TOLHI.GE.1.D0) THEN
          WRITE(6,356)
        ELSE
          WRITE(6,357)
        ENDIF
        GO TO 380
      ENDIF
C
      IF(INTFLG.EQ.-1) THEN
        WRITE(6,370) RMIN,STEST,NGMP
        GO TO 380
      ENDIF
C
      WRITE(6,220)
      STOP
C
  380 JKEEP=-1
      XEPS=-1.D0
      DEEP=1.D30
      IF(IRXSET.GT.0) WRITE(6,381) IRXSET
  381 FORMAT('0 IRXSET =',I3,' OPTION. RMAX ADJUSTED AUTOMATICALLY ',
     1   'FOR EACH NEW JTOT,MVAL')
      IF(IRMSET.LE.0) GOTO 420
      WRITE(6,390) IRMSET
  390 FORMAT('0 IRMSET =',I3,' OPTION. RMIN CHOSEN AUTOMATICALLY ',
     1   'FOR EACH NEW JTOT')
C
C   XEPS IS SUCH THAT AIRY(XEPS) APPROX. EQUALS 10**(-IRMSET)
C
      XEPS=(-1.5D0*LOG(4.D0*SQRT(PI)*
     1 10.D0**(-IRMSET)))**(2.D0/3.D0)
C>>SG 1/18/93 BELOW REMOVED AT SUGGESTION OF JMH
C     IF(ISCRU.EQ.0 .AND. NNRG.NE.1) SHRINK=0
      IF(INTFLG.NE.3 .OR. SHRINK.NE.1) GOTO 420
      DEEP=2.D0+XEPS**1.5D0/1.5D0
      WRITE(6,400)
  400 FORMAT(22X,'AND DEEPLY CLOSED CHANNELS ',
     1   'DROPPED IN LONG-RANGE REGION')
      IF(NNRG.NE.1 .AND. ISCRU.NE.0) WRITE(6,410)
  410 FORMAT(22X,'NOTE THAT BASIS SET CONTRACTION IS PERFORMED FOR ',
     1   'ENERGY(1),'/22X,'SO THAT SUBSEQUENT ENERGIES MUST NOT BE ',
     2   'SIGNIFICANTLY HIGHER.')
C
  420 ISAV=0
      IF(JTOTL.EQ.JTOTU .AND. MSET.GT.0) ISAV=1
      IF(ISCRU.LT.0) ISAV=-ISAV
      ISCRU=IABS(ISCRU)
C
      IF(ISCRU.EQ.0) THEN
        IF(NNRG.GT.1.OR.NTEMP.GT.0) WRITE(6,430)
  430   FORMAT('0***** WARNING - NO SCRATCH FILE SPECIFIED BY ISCRU ',
     1    'PARAMETER - FULL CALCULATION WILL BE DONE AT EACH ENERGY')
      ELSE
        IF(ISAV.EQ.-1) THEN
          WRITE(6,440) ISCRU
  440     FORMAT('0 ENERGY-INDEPENDENT MATRICES SAVED FROM A ',
     1      'PREVIOUS RUN WILL BE READ FROM UNIT',I3)
C*V12*    OPEN(ISCRU,FILE='ISCRU',FORM='UNFORMATTED',STATUS='OLD')
C*****    GISS VERSION FOLLOWS
          OPEN(ISCRU,             FORM='UNFORMATTED',STATUS='OLD')
C         OPEN(ISCRU,FORM='UNFORMATTED',STATUS='OLD',SHARED,READONLY)
        ELSE
          WRITE(6,450) ISCRU
  450     FORMAT('0 ENERGY-INDEPENDENT MATRICES WILL BE SAVED ',
     1      'TEMPORARILY ON UNIT',I3)
C*V12*    OPEN(ISCRU,FILE='ISCRU',FORM='UNFORMATTED',STATUS='UNKNOWN')
C*****    GISS VERSION FOLLOWS
          OPEN(ISCRU,             FORM='UNFORMATTED',STATUS='UNKNOWN')
        ENDIF
      ENDIF
C
      WRITE(6,470) URED
  470 FORMAT('0 REDUCED MASS FOR COLLISION =',F14.9,' A.M.U.')
      IF(JTOTL.LT.0) JTOTL=0
      IF(JTOTU.LT.JTOTL)  JTOTU=999
      WRITE(6,480)  JTOTL,JTOTU,JSTEP
  480 FORMAT('0 CONTROL DATA FOR TOTAL ANGULAR MOMENTUM IS'/
     1 7X,'JTOT FROM',I4,'  TO',I6,'  IN STEPS OF',I4)
      IF(JTOTU.GE.999)  WRITE(6,490)  NCAC,DTOL,OTOL
  490 FORMAT('0 JTOT SERIES WILL BE TERMINATED WHEN MAX CHANGE IN ',
     1  'CROSS SECTIONS IS LESS THAN TOLERANCE FOR NCAC =',I3,
     2  ' CONSECUTIVE JTOT'/25X,
     3  'DIAGONAL (DTOL) AND OFF-DIAGONAL (OTOL) TOLERANCES ARE',2F9.5)
      IF(JTOTU.GE.999.AND.NNRGPG.GT.1) WRITE(6,491) NNRGPG
  491 FORMAT('0 N.B. CONVERGENCE CHECKING IS DONE FOR ENERGY GROUPS',
     1       ' OF NNRGPG =',I4)
      IF(MSET.GT.0 .AND. MHI.LE.0) MHI=MSET
      IF(MSET.GT.0) WRITE(6,500) MSET,MHI
  500 FORMAT('0 CALCULATIONS WILL BE FOR SYMMETRY BLOCK ("PARITY ',
     1 'CASES")',I4,'  TO',I4)
C
C   PROCESS TOTAL ENERGIES
C
      CALL ECNV(EUNITS,EFACT)
      IF(NNRG.GT.0 .AND. DNRG.EQ.0.D0 .AND. ABS(EFACT-1.D0).GT.1.D-3
     1  .AND. ICONV.EQ.0) WRITE(6,510) (ENERGY(I),I=1,NNRG)
  510 FORMAT('0 INPUT ENERGY LIST IS'/(16X,7D16.6))
      IF(NTEMP.LE.0) GOTO 520
C   OVERRIDE ENERGY INPUT WITH TEMP INPUT
      NTEMP=MIN0(NTEMP,MXTEMP)
      CALL EAVG(NTEMP,TEMP,NGAUSS,ENERGY,NNRG,MXNRG)
      NPR=NNRG
      GOTO 590
  520 ISRCH=0
      NPR=NNRG
C
C  PROCESS A NEGATIVE INPUT NNRG FOR RESONANCE SEARCH OPTION
C
      IF(NNRG.GE.0 .OR. DNRG.EQ.0.D0 .OR. JTOTL.NE.JTOTU .OR.
     1 MSET.LE.0 .OR. KSAVE.LE.0) GOTO 530
      ISRCH=1
      NNRG=5*(IABS(NNRG)/5)
      MXN=5*(MXNRG/5)
      NNRG=MIN0(NNRG,MXN)
      NNRGPG=5
      NPR=5
C
  530 NNRG=MIN0(MXNRG,NNRG)
      NPR=MIN0(MXNRG,NPR)
      IF(NNRG.GT.0) GOTO 550
      WRITE(6,540)
  540 FORMAT('0***** ERROR - NO INPUT ENERGIES SPECIFIED - RUN HALTED')
      STOP
  550 IF(NNRG.LE.1 .OR. (DNRG.EQ.0.D0 .AND. ICONV.EQ.0)) GOTO 570
      DO 560 I=2,NPR
  560 ENERGY(I)=ENERGY(1)+(I-1)*DNRG
  570 DO 580 I=1,NPR
  580 ENERGY(I)=ENERGY(I)*EFACT
  590 WRITE(6,600) NNRG
  600 FORMAT('0 CONTROL DATA FOR TOTAL ENERGIES.  CALCULATIONS WILL ',
     1 'BE PERFORMED FOR',I4,' VALUES')
      DO 610 I=1,NPR
      ENEV=ENERGY(I)/8065.5410D0
  610 WRITE(6,620)  I,ENERGY(I),ENEV
  620 FORMAT(7X,'ENERGY NO.',I4,' =',F17.9,' (1/CM) =',F17.12,' E.V.')
C
      IF(ISRCH.EQ.1) WRITE(6,630)
  630 FORMAT('0 RESONANCE SEARCH OPTION. ONLY FIRST 5 ENERGIES ',
     1 'GIVEN. OTHERS WILL BE DETERMINED INTERACTIVELY.')
C
      IF(IFLS.GT.0 .AND. IFEGEN.GT.0)  WRITE(6,640)
  640 FORMAT('0 THESE ENERGY VALUES WILL BE USED AS RELATIVE (CENTER',
     1 ' OF MASS) VALUES AND LIST MAY BE MODIFIED ACCORDINGLY.')
C
      IF(NUMDER) WRITE(6,641)
  641 FORMAT('0 NUMDER=.TRUE.  POTENTIAL DERIVATIVE WILL BE COMPUTED',
     &       ' NUMERICALLY FROM POTENTIAL.')
      WRITE(6,650)  PRINT,ISIGPR,ITHROW
  650 FORMAT('0 PRINT LEVEL (PRNTLV) =',I3,'     OTHER PRINT CONTROLS',
     1 '  ISIGPR =',I2,'    ITHROW =',I2)
      WRITE(6,660)
  660 FORMAT('0',30('===='))
C
C   INITIALIZE BASIS (BASIN/IOSBIN)
C     COMBINED MOLSCAT (BASIN) AND IOS (IOSBIN) -- APR 86
C     IOSBIN GRABS STORAGE IN ATAU=JLEV=X (ITYPE=6 ONLY).  MAX AVAILABLE
C       PASSED INITIALLY IN NLEV; SET6I/IOSBIN MUST UPDATE
C       IC ACCORDINGLY.  N.B. IOS CASE ALSO USES NLEV TO PASS 'NVC'
C       FROM BASIN/IOSBIN TO IOSDRV.
C     BASIN TAKES STORAGE FOR JLEV=X, AND ALSO RESETS IC ACCORDINGLY;
C       FOR THIS CASE, NLEV INITIALIZED TO MAXIMUM AVAILABLE IN X().
      IXJLEV=IXNEXT
      NLEV=MX
C     IXNEXT REMOVED FROM ARGUMENT LIST: JMH, 10 NOV 93
      CALL BASIN(NLEV,X(IXJLEV),URED,NQN,NLABV(9),MXPAR,ITYPE,IOSFLG)
C     BASE ROUTINE INCREMENTS IXNEXT BY AMOUNT OF STORAGE IN JLEV.
      CALL CHKSTR(NUSED)
      WRITE(6,660)
C
C  INITIALIZE POTENTIAL.
C
      ILAM=IXNEXT
      MXLAM=NIPR*(MX-ILAM+1)
      CALL POTENL(-1,MXLAM,NPOTL,X(ILAM),RM,EPSIL,ITYPE)
C     THIS READS (5, POTL).  RM AND EPSIL ARE SET HERE.
C     RM IS A LENGTH PARAMETER (IN ANGSTROMS)
C     EPSIL IS AN ENERGY PARAMETER IN WAVENUMBERS.
      ITYP=MOD(ITYPE,10)
C     INCREMENT IXNEXT FOR STORAGE TAKEN FOR LAM(NLABV,MXLAM)
      IXNEXT=IXNEXT+(MXLAM*NLABV(ITYP)+NIPR-1)/NIPR
      CALL IVCHK(IVLFL,PRNTLV,ITYPE,NLABV,MXLAM,NPOTL,X(ILAM))
      WRITE(6,660)
C
C   COMPUTE SOME DIMENSIONLESS PARAMETERS
C
C     RMLMDA IS THE SQUARE OF THE RATIO OF RM TO DEBROGLIE WAVELENGTH
      RMLMDA=URED*RM*RM*EPSIL/BFCT
C     CINT IS THE FACTOR TO REDUCE THE ROTATIONAL CONSTANTS
      CINT = RMLMDA/EPSIL
C
C ***
      IF(IOSFLG.LE.0) GOTO 670
C ***
C *** THIS IS WHERE IOS CODE DIVERGES - CALL IOS CODE AND SKIP TO EXIT
C ***
      IF (IRSTRT.GT.0) THEN
        WRITE(6,*) '  *** RESTART REQUESTED WITH IOS RUN - NOT ALLOWED'
        WRITE(6,*) '  *** MODIFY INPUT DECK AND RESUBMIT'
        STOP
      ENDIF
      CALL IOSDRV(NNRG,NPR,ENERGY,JTOTL,JTOTU,JSTEP,TEST,NCAC,
     1   IFLS,LINE,LTYPE,MXLN,INTFLG,ITYPE,LMAX,MMAX,
     2   IPROGM,URED,LABL,NUMDER,
     3   X(ILAM),MXLAM,NPOTL,CINT,IRMSET,IRXSET,RVFAC,
     4   DEEP,PRINT,NLEV,ISAVEU,TFIRST,RM,EPSIL,RMIN,RMAX)
      CALL GCLOCK(TLAST)
      TOTIME=TLAST-TFIRST
      GOTO 1020
C
C  PROCESS PRESSURE-BROADENING LINE-SHAPE INPUT PARAMETERS.
C
  670 IF(IFLS.GT.0) THEN
        CALL PRBRIN(IFLS,LINE,LTYPE,MXLN,ILSU,NNRG,ENERGY,MXNRG,IFEGEN,
     1    X(IXJLEV),PRINT)
        IF(IFEGEN.GT.0) NPR=NNRG
        WRITE(6,660)
        IF(KSAVE.EQ.0) GOTO 690
        WRITE(6,680) IFLS,KSAVE
  680   FORMAT('0****** WARNING. IFLS =',I3,' AND KSAVE =',I3,' ARE ',
     1   'INCOMPATIBLE. KSAVE IS RESET TO ZERO')
        KSAVE=0
      ENDIF
C
C   INITIALIZE OUTPUT ROUTINE.
C   OUTPUT TAKES AN ADDITIONAL AMOUNT OF STORAGE
C   FOR SIG AT X(IXNEXT) AND INCREASES IXNEXT ACCORDINGLY.
C
  690 IOUT=IXNEXT
C     N.B IXNEXT WILL BE CHANGED BY OUTINT
      CALL OUTINT(LABL,ENERGY,NNRG,NLEV,NQN,X(IXJLEV),X(IOUT),IXNEXT,
     1   IECONV,URED,ITYPE,KSAVE,ISST,MINJT,MAXJT,ISIGU,IPARTU,ISAVEU,
     2   IPROGM,MXSIG,ISIGPR,IRSTRT)
      CALL CHKSTR(NUSED)
      IC1=IXNEXT
C     PROCESS RESTART REQUEST ...
      MXP=0
      CALL RESTRT(IRSTRT,ISAVEU, JTOTL,JSTEP,MXPAR,MSET,MHI,
     1     LABEL,ITYPE,NLEV,NQN,URED,IPROGM,
     2     X(IXJLEV),NNRG,ENERGY,MXNRG,
     3     X(IOUT),ISST,IECONV,MINJT,MAXJT,ISIGU,IPARTU,KSAVE,
     4     OTOL,DTOL,  X(IC1),X(IC1), MRSTRT,IERST, MXP, PRINT)
      WRITE(6,660)
C
      EFIRST=ENERGY(1)*CINT
      CALL GCLOCK(TITIME)
      TTIME=TITIME-TFIRST
      WRITE(6,700) TTIME,NUSED
  700 FORMAT('0 INITIALIZATION DONE.  TIME WAS',F7.2,' CPU SECS.',I10,
     1       ' WORDS OF STORAGE USED.')
      IF(PRINT.LT.4) WRITE(6,710) TIT
  710 FORMAT('1',120A1)
      IF(PRINT.GE.4.AND.ITHROW.EQ.0) WRITE(6,720)
  720 FORMAT('1')
C
C **************  LOOP OVER JTOT VALUES BEGINS HERE.  ******************
C
      DO 990 JTOT=JTOTL,JTOTU,JSTEP
      IF(PRINT.GE.1 .AND. PRINT.LE.4) WRITE(6,730) JTOT
  730 FORMAT('0 ANGULAR MOMENTUM JTOT  =',I4/2X,7('****'))
      THETA=THETLW+THETST*DBLE(JTOT)
C
C ***************  LOOP OVER SYMMETRY BLOCKS BEGINS HERE  **************
C
      DO 980 M=1,MXPAR
      IF(M.LE.MXRTM) GO TO 735
      WRITE(6,732) MXRTM
  732 FORMAT(/' *** ERROR.  EXCEEDED LIMIT ON RTURNM.  MXRTM =',I5)
      STOP
  735 PHI=PHILW+PHIST*DBLE(M-1)
      IF(JTOT.EQ.JTOTL) RTURNM(M)=RMIN
      IF(MSET.GT.0.AND.(M.LT.MSET.OR.M.GT.MHI)) GO TO 980
      IF (IRSTRT.GE.2.AND.JTOT.EQ.JTOTL.AND.M.LT.MRSTRT) THEN
        WRITE(6,736) M,IRSTRT
  736   FORMAT('  *** SKIPPING MVALUE =',I3,'  DUE TO IRSTRT =',I3)
        GO TO 980
      ENDIF
      IF(PRINT.LT.4)  GOTO 760
      IF(ITHROW.NE.0) WRITE(6,710) TIT
      IF(ITHROW.EQ.0) WRITE(6,740) TIT
  740 FORMAT('0',120A1)
      WRITE(6,750)  JTOT,M
  750 FORMAT('0 TOTAL ANGULAR MOMENTUM, JTOT =',I5,'    SYMMETRY',
     1 ' BLOCK =',I4)
  760 CONTINUE
C
C     CHOOSE BASIS FUNCTIONS
C
      CALL BASE (JTOT,X(IXJLEV),N,X,X,CINT,X,X,X,X,MXLAM,NPOTL,X(ILAM),
     1   X,WGHT,THETA,PHI,M,.TRUE.,EFIRST,NLEV,PRINT)
C
C   MOLD IS A REMNANT OF THE PREVIOUS "PARITY CASE" PROCESSING.
C   MXP IS USED IN CONVERGENCE CHECKING, MOLD IS PASSED TO PRBR
C
      MOLD=-M
      IF(M.EQ.MXPAR.AND.N.LE.0) MOLD=0
      MXP=MAX0(MXP,IABS(MOLD))
      IF(M.EQ.MXPAR) MOLD=0
C
C     SG (29 DEC 93): IK IS PASSED THROUGH TO RMTPRP AND NEVER MODIFIED.
      IK=1
C     INITIALISE RTURN FOR IRMSET > 0 OPTION
      RTURN=RTURNM(M)
C
C   N IS THE NUMBER OF BASIS FUNCTIONS
C   SKIP THIS JTOT,M IF NO CHANNELS
C
C     IF(N.LE.0)  GOTO 980  <<- SG: FIXES ISIGU BUG
      IF(N.LE.0)  GOTO 769
      NSQ = N*N
C
C     ALLOCATE STORAGE FOR COUPLED EQUATION SOLVER.
C
C     ALLOCATE STORAGE COMMON TO ALL SCATTERING. . .
C     IS0-IS9 ARE SREAL,SIMAG,K-MATRIX,VL,IV,EINT,CENT,WVEC,L,NBASIS
C       N.B. INTEGER ARRAYS OF LENGTH N ARE NOT REDUCED BY NIPR
C     IC1 IS IXNEXT AFTER ALLOCATIONS OF BASIN, POTENL, OUTINT ...
      ISJ=IC1
      IS0=ISJ+N
      IS1=IS0+NSQ
      IS2=IS1+NSQ
      IS3=IS2+NSQ
      NV=N*(N+1)/2
      IF(IVLU.EQ.0) NV=NV*NPOTL
      IS4=IS3+NV
      IS5=IS4
      IF(IVLFL.GT.0) IS5=IS4+(NV+NIPR-1)/NIPR
      IS6=IS5+N
      IS7=IS6+N
      IS8=IS7+N
      IS9=IS8+N
      IXNEXT=IS9+N
C
C   SET UP SOME STORAGE POINTERS FOR LATER USE IN CONVRG
C
      IF(ICONV.LE.0) GOTO 770
      IS10=IXNEXT
      IS11=IS10+NSQ
      IXNEXT=IS11+NSQ
  770 IC2=IXNEXT
      CALL CHKSTR(NUSED)
C     IXNEXT/IC2 REFLECT STORAGE ALWAYS NEEDED FOR THIS JTOT,PARITY.
C
C     SET UP BASIS FUNCTIONS IN ALLOCATED STORAGE
C
      CALL BASE(JTOT,X(IXJLEV),N,X(ISJ),X(IS8),CINT,X(IS5),X(IS6),
     1     X(IS3),X(IS4),MXLAM,NPOTL,X(ILAM),X(IS7),WGHT,THETA,PHI,
     2     M,.FALSE.,EFIRST,NLEV,PRINT)
C
C     CHECK THAT RMAX IS BEYOND CENTRIFUGAL BARRIER
C
      CALL FINDRX(ENERGY,X(IS5),X(IS6),NPR,N,CINT,RMAX,RSTOP,
     1   NOPMAX,IRXSET,PRINT)
      IF(INTFLG.EQ.5) RVIVAS=RSTOP
      RSTART=RMIN
C
C ******************  LOOP OVER ENERGIES BEGINS HERE  ******************
C
  769 NELOOP=(NNRG+NNRGPG-1)/NNRGPG
      JHI=0
      ICODE=0
      ALDONE=.TRUE.
      DO 966 IEL=1,NELOOP
      JLO=JHI+1
      JHI=MIN(JHI+NNRGPG,NNRG)
C
C     SEE WHETHER THIS BLOCK OF ENERGIES CAN BE SKIPPED
C
      LCALC=.FALSE.
      DO 775 J=JLO,JHI
      IF(IECONV(J)) 771,774,773
  771 IF(IECONV(J).LT.-2*MXP) GOTO 775
      WRITE(6,772) JTOT,J
  772 FORMAT('0 * * * WARNING.  JTOT =',2I5,'-TH ENERGY PREVIOUSLY ',
     1  'FAILED TO CONVERGE.')
      LCALC=.TRUE.
      GOTO 775
  773 IF(JTOTU.LT.999) GOTO 774
      IF(IECONV(J).LT.NCAC*MXP) GOTO 774
      GOTO 775
  774 LCALC=.TRUE.
  775 CONTINUE
C
      IF(.NOT.LCALC) GOTO 966
      ALDONE=.FALSE.
      DO 960 J=JLO,JHI
      IF(N.LE.0) THEN
        CALL OUTSIG(ISIGU,M,MXPAR,J,ENERGY,MINJT,MAXJT,X(IOUT))
        GOTO 960
      ENDIF
      IF (IRSTRT.EQ.3.AND.JTOT.EQ.JTOTL.AND.M.EQ.MRSTRT.AND.J.LT.IERST)
     1  GO TO 960
      ETOT=ENERGY(J)
      ERED=ETOT*CINT
      IF(ICODE.EQ.0) THEN
        EFIRST=ERED
        ICODE=1
      ENDIF
      ESHIFT=ERED-EFIRST
C
C     ICODE CONTROLS WHETHER POTENTIAL INFORMATION IS READ FROM CHANNEL
C     ICODE=1 CALCULATES INFORMATION AND STORES IT
C     ICODE=2 (SET AFTER 1ST ENERGY) READS STORED INFORMATION
C
  778 IF(PRINT.LT.4)  GOTO 790
      IF(ITHROW.NE.0) WRITE(6,710) TIT2
      IF(ITHROW.EQ.0) WRITE(6,740) TIT2
      WRITE(6,780)  JTOT,M,J,ETOT
  780 FORMAT('0 JTOT =',I5,'   SYMMETRY BLOCK =',I4,'   ENERGY(',
     1 I3,') =',F18.9,' (1/CM)')
C
C     FOR SURFACE SCATTERING AT SUBSEQUENT ENERGY,
C     GET CORRESPONDING THETA FOR PRINTING
C
  790 IF(ITYPE.EQ.8 .AND. J.NE.1)  THEN
        SINTH=SIN(THETA*PI/180.D0)
        SINTH=SINTH**2*ENERGY(1)/ETOT
        IF(SINTH.GT.1.D0) GOTO 960
        THETJ=ASIN(SQRT(SINTH))*180.D0/PI
        WRITE(6,795) J,ETOT,THETJ
  795   FORMAT('0 NOTE: K VECTORS PARALLEL TO SURFACE WERE CALCULATED ',
     1    'FOR ENERGY(1)'/'  SUBSEQUENT ENERGY(',I3,') =',F10.4,
     2    ' CORRESPONDS TO THETA =',F10.4,' DEGREES')
      ENDIF
C
C     TEMPORARY STORAGE FOR HEADER, FINDRX ...
      IT1=IXNEXT
      IT2=IT1+MXLAM
      IXNEXT=IT2+N
      CALL CHKSTR(NUSED)
C
      CALL HEADER(X(IS1),X(IS2),N,NSQ,X(IT1),X(IS3),X(IS4),X(IS5),
     1   X(IS6),X(IT2),MXLAM,NPOTL,ICODE,ISAV,EFIRST)
      IF(ICODE.NE.1 .OR. IRMSET.LE.0) GOTO 810
C     FOR IRMSET > 0 OPTION, CHOOSE APPROPRIATE RMIN
      RSTART=RMIN
      CALL FINDRM(X(IS1),N,RSTART,RTURN,IK,X(IT1),X(IS3),X(IS4),ERED,
     1 X(IS5),X(IS6),RMLMDA,X(IT2),MXLAM,NPOTL,XEPS,ITYPE,PRINT)
      IF(RVFAC.EQ.0.D0) GOTO 810
      RMID=RVFAC*RTURN
      IF(PRINT.GE.3.AND.RSTOP.GT.RMAX) WRITE(6,799) RSTOP,RMAX
  799 FORMAT(' DRIVER(11/01/89) RMID IGNORES RSTOP.GT.RMAX',2F8.2)
      IF(PRINT.GE.3) WRITE(6,800) RMID,RVFAC
  800 FORMAT('0 RMID =',F7.2,' OBTAINED FROM RVFAC =',F6.3)
C
C     RESET IXNEXT TO DELETE TEMPORARY STORAGE
  810 IXNEXT=IT1
C
C     AND SOLVE COUPLED EQUATIONS.
C     PROPAGATORS ARE CALLED FROM SUBROUTINE STORAG
      CALL STORAG(INTFLG,N,MXLAM,NV,NPOTL,
     1   ISJ,IS0,IS1,IS2,IS3,IS4,IS5,IS6,IS7,IS8,IS9,
     2   ESHIFT,NOPMAX,DEEP,IK,ICODE,PRINT,NUMDER)
C>>SG RESET ICODE AFTER CALL STORAG
      ICODE=2
C<<SG
C
      CALL GCLOCK(TJTIME)
      TTIME=(TJTIME-TITIME)
      TITIME=TJTIME
C
      IF(NOPEN.GT.0)  GOTO 910
      IF(PRINT.GE.2) WRITE(6,900) JTOT,M,J,ETOT,TTIME
  900 FORMAT('0 ****** NO OPEN CHANNELS FOR JTOT =',I5,
     1 '   M =',I4,'   ENERGY(',I3,') =',F18.9,10X,'STEP TIME =',
     2 F6.2,' SECS')
      IF(IECONV(J).GE.0)  IECONV(J)=IECONV(J)+1
      GOTO 960
  910 CONTINUE
C
C     RESET IRSTRT, IF NECESSARY, SO THAT ISAVEU WILL BE UPDATED.
      IRSTRT=0
      CALL OUTPUT(JTOT,X(IS9),X(ISJ),X(IS8),X(IS7),X(IS0),X(IS1),
     1   X(IS2),CONV,NOPEN,M,MXPAR,WGHT,J,RM,PRINT,TTIME,
     2   ENERGY,X(IOUT),X(IXJLEV),ISST,IECONV,MINJT,MAXJT,
     3   NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR,IRSTRT)
C
      IF(ICONV.GT.0) CALL CONVRG(J,X(IS0),X(IS1),X(IS10),X(IS11))
      IF(IECONV(J).LT.0 .OR. IFLS.LE.0) GOTO 940
C
C     TEMPORARY STORAGE FOR PRBR -- THESE ARE INTEGERS, COULD USE NIPR
      IT1=IXNEXT
      IT2=IT1+N
      IT3=IT2+N
      IT4=IT3+N
      IXNEXT=IT4+N
      CALL CHKSTR(NUSED)
      CALL PRBR(JTOT,MOLD,NOPEN,J,RM,
     1   X(IS9),X(ISJ),X(IS8),X(IS7),
     2   X(IS0),X(IS1),X(IT1),X(IT2),X(IT3),X(IT4),
     3   X(IXJLEV),MXPAR,WGHT,PRINT,ILSU)
C     RECOVER TEMPORARY STORAGE ...
      IXNEXT=IT1
C
  940 IF(PRINT.GE.5) WRITE(6,950) JTOT,M,J,ETOT,TTIME
  950 FORMAT('0 FINISHED JTOT =',I5,'   M =',I4,'   ENERGY(',I3,
     1 ') =',F18.9,10X,'STEP TIME =',F8.2,' SECS')
C
C>>SG 29 DEC 93: RESET OF ICODE MOVED TO RIGHT AFTER CALL STORAG
C 960 ICODE=2
  960 CONTINUE
C<<SG
C
C  RESONANCE SEARCH OPTION - GENERATE NEXT 5 ENERGIES
C
      IF(ISRCH.EQ.0) GOTO 964
      CALL NEXTE(ENERGY(JLO),EPSM,ENEW,DNRG,KSAVE)
      IF(JHI.EQ.NNRG) GOTO 964
      IF(ENEW.LE.0.D0) GOTO 1000
      JST=JHI+1
      JND=JHI+5
      WRITE(6,600) NNRG
      DO 962 JJ=JST,JND
      ENERGY(JJ)=ENEW+(JJ-JST)*DNRG
      ENEV=ENERGY(JJ)/8065.541D0
      WRITE(6,620) JJ,ENERGY(JJ),ENEV
  962 CONTINUE
  964 CONTINUE
C
  966 CONTINUE
C
C ********************  END OF LOOP OVER ENERGIES  *********************
C
      IF(ALDONE) THEN
        WRITE(6,968) DTOL,OTOL,NCAC
  968 FORMAT('0'/'0 CALCULATION TERMINATED BY CONVERGENCE OF TOTAL ',
     1  'CROSS SECTIONS.'/'0 DIAGONAL AND OFF-DIAGONAL TOLERANCES WERE',
     2  2F9.5,'   NCAC =',I3)
        GOTO 1000
      ENDIF
C
      IF(PRINT.GE.2 .AND. PRINT.LT.5)  WRITE(6,970)
  970 FORMAT('0')
C     SAVE RTURN FOR USE IN SUBSEQUENT JTOT FOR SAME M
      RTURNM(M)=RTURN
C     RESTORE ERED TO FIRST ENERGY VALUE.
      ERED = EFIRST
  980 CONTINUE
C
C ******************  END OF LOOP OVER SYMMETRY BLOCKS  ****************
C
      IF(IFLS.GT.0) CALL PRBOUT(JSTEP)
  990 CONTINUE
C
C ********************  END OF LOOP OVER JTOT VALUES  ******************
C
C   END OF RUN BOOKKEEPING
C
 1000 CALL OUTPCH(X(IOUT),ENERGY,NNRG,MINJT,MAXJT,ISIGPR,LABL,
     1  ISIGU,JSTEP)
      IF(IFLS.GT.0) WRITE(6,710) TIT
      IF(IFLS.GT.0) CALL PRBOUT(JSTEP)
      IF(IFLS.GT.0) CALL DACLOS
      CALL GCLOCK(TLAST)
      TOTIME=TLAST-TFIRST
C     MAKE SURE WE HAVE NUSED FOR KSAVE BY CALLING CHKSTR
      CALL CHKSTR(NUSED)
      IF(KSAVE.GT.0) WRITE(KSAVE,1010) TOTIME,TTIME,NUSED
 1010 FORMAT(1X/' TOTAL CPU =',F9.2,' SECS   LAST CYCLE =',
     1 F8.2,' SECS   NUSED =',I8)
C
C *** IOS CALCULATION (IOSFLG.GT.0) REJOINS CODE BELOW
C     ASCERTAIN 'HIGH-WATER' MARK IN STORAGE FROM CHKSTR.
C     N.B. MX MAY HAVE BEEN REDUCED, SO USE MXSAVE FOR ALLOCATED STORAGE
 1020 CALL CHKSTR(NUSED)
      WRITE(6,1030) IPROGM,PDATE,TOTIME,NUSED,MXSAVE
 1030 FORMAT('0'/'0 ',8('----MOLSCAT----')/' |',120X,'|'/' |',13X,
     1 'COUPLED CHANNEL MOLECULAR SCATTERING PROGRAM OF J. M. HUTSON ',
     2 'AND S. GREEN, VERSION',I3,1X,A8,13X,'|'/
     3 ' |',120X,'|'/' |',15X,'THIS RUN USED',F11.2,' CPU SECS   ',
     4 'AND',I10,' OF THE ALLOCATED',I10,' WORDS OF STORAGE',12X,
     5 '|'/' |',120X,'|'/'  ',8('----MOLSCAT----')  )
      IF(LASTIN.EQ.0) GOTO 100
 1040 RETURN
      END
      SUBROUTINE OUTPUT( JTOT, NBASIS, J, L, WVEC, SREAL, SIMAG,
     1 AKMAT, CONV, NOPEN, M, MXPAR, WT, INRG, RM, PRNT, TTIME,
     2 ENERGY, SIG, JLEV, ISST, IECONV, MINJT, MAXJT,
     3 NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR,IRSTRT)
C     29 DEC 93: RESTART CAPABILITIES.  2 MAR 94, V13 (EXPERIMENTAL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVE
C
C     ENTRY OUTPUT - PROCESSES S MATRICES TO X-SECTIONS OUTPUTS THEM.
C     ENTRY OUTSIG - (10/92) SEPARATE ENTRY TO UPDATE UNIT(ISIGU)
C                    TO FIX BUG W/ NO BASIS FNS FOR PARITY M=MXPAR
C     ENTRY OUTINT - INITIALIZATION ENTRY FROM DRIVER.
C     ENTRY OUTPCH - PUNCHES FINAL CROSS SECTIONS.
C     ENTRY OUTERR - SETS ERROR FLAG, CALLED ONLY FROM DVSCAT.
C
C     MODIFICATIONS AUG. 74 - - -
C        NLEVEL IS DIFFERENT FROM NLEV. FORMER FOR ELEVEL,JLEVEL,
C        AND LATTER FOR JLEV(NLEV,NQN).
C        TSIG IS NOW FIRST NLEVEL*NLEVEL=NSTOR ELEMENTS OF SIG.
C        DEGENERACY IS IN 2ND NSTOR ELEMENTS OF SIG.
C     MODIFIED NOV 91 - - - MULTIPLIES CROSS SECTIONS BY JSTEP
C     MODIFIED JUN 92 TO GIVE UNFORMATTED ISAVEU OUTPUT W/ ONLY
C         NONREDUNDANT S(I,J).  OLDER (FORMATTED) CODE IS SAVED AS
C         COMMENTS TO PROVIDE COMPATIBILITY W/ VERSION 10 AND EARLIER.
C         N.B FORMATS 800,801,802 ALSO USED FOR IPARTU OUTPUT.
C     SREAL,SIMAG ARE WRITTEN USING A SUBROUTINE SWRITE.
C
      DIMENSION NBASIS(1),J(1),L(1),WVEC(1),SREAL(1),SIMAG(1)
      DIMENSION AKMAT(NOPEN,NOPEN)
      INTEGER ISST(2),MAXJT(2),MINJT(2),IECONV(2)
      INTEGER PRINT,PRNT
      INTEGER NLEV,JLEV(1)
      DIMENSION SIG(1),ENERGY(1)
      LOGICAL OKEY,LOUT,ACCUM,OPENED
C     INTEGER CTIME(2),CDATE(4)
      CHARACTER CTIME*9,CDATE*11
      CHARACTER*4 LABEL(20)
      CHARACTER*1 STAR,BLANK
C
C     DIMENSIONS IN CMBASE CHANGED 2 MAR 94 FOR V13 (EXPT'L)
      COMMON /CMBASE/ ROTI(10),ELVL(604),IDUM(1208)
      EQUIVALENCE (NLVL,IDUM(7))
C
C     COMMON BLOCK TO DRIVER FOR RESONANCE SEARCHES
C
      COMMON/EIGSUM/EPSM(5)
C
      DATA STAR/'*'/, BLANK/' '/
      DATA EPS/1.D-10/
      DATA IPUNCH/7/
C
      PRINT=PRNT
      IEXCH=1
      IRET=0
C
C     SET LOGICAL VARIABLES
      OKEY=CONV.GE.0.D0  .AND. IECONV(INRG).GE.0
      ACCUM=OKEY .AND. INVERR.LE.0 .AND. ITYPE.NE.8
C
C     BOOKEEPING FOR MINJT AND MAXJT
      IF (MINJT(INRG).LT.0)  MINJT(INRG)=JTOT
      IF (OKEY .AND. JTOT.GT.MAXJT(INRG) .AND. MAXJT(INRG).GE.0)
     &                    MAXJT(INRG)=JTOT
C
C     PRINT OUT OPEN-CHANNEL BASIS FUNCTIONS AND WAVEVECTORS IN 1/A.
      IF (PRINT.GE.11)  WRITE(6,601)
  601 FORMAT('0 CHANNEL NO.  TARGET LEVEL  ORBITAL L   WVEC(1/ANG.)')
C     CONVERT WVEC TO INVERSE ANGSTROMS
      DO 1000 I=1,NOPEN
      NB=NBASIS(I)
      WVEC(NB)=WVEC(NB)/RM
      IF (PRINT.GE.11) WRITE(6,602) I,J(NB),L(NB),WVEC(NB)
  602 FORMAT(3I12,E18.8)
 1000 CONTINUE
C
C
C     PROCESS S-MATRIX. ACCUMULATE X-SECTIONS IN TSIG. PRINT.
C     J(NBASIS(I)) IS LEVEL NUMBER OF ITH BASIS FN. IN ASYMPTOTIC AREA.
C  CLEAR TSIG.
      DO 1400 I=1,NSTOR
 1400 SIG(I)=0.D0
      IF (PRINT.GT.10) WRITE(6,606)
  606 FORMAT('0 ROW  COL',10X,'S**2',15X,'PHASE/2PI',12X,'RE (S)',14X,
     1      'IM (S)'  )
C
      IJ=0
      NTOP=(NQN-1)*NLEV
C     CALCULATE GLOBAL MULTIPLICATIVE FACTOR FOR X-SECTIONS.
      XJ=DBLE(2*JTOT+1)*PI
      IF (IEXCH.NE.0) XJ=XJ*WT
      DO 2000 ICOL=1,NOPEN
      LEVC=J(NBASIS(ICOL))
      LCOL=JLEV(NTOP+LEVC)
      DO 2000 IROW=1,NOPEN
      DD=WVEC(NBASIS(IROW))
      DD=DD*DD
      LEVR=J(NBASIS(IROW))
C     IJ IS INDEX OF SREAL,SIMAG(IROW,ICOL)
      IJ=IJ+1
      SMAG=( SREAL(IJ)*SREAL(IJ)+SIMAG(IJ)*SIMAG(IJ) )
      IF (PRINT.LE.10 .OR. SMAG.LE.EPS)  GO TO 2300
      PHASE=ATAN2(SIMAG(IJ),SREAL(IJ)) / PI2
      IF(ITYPE.NE.8) GO TO 2100
C     SPECIAL CASE FOR SURFACE SCATTERING: WRITE OUT ONE COLUMN ONLY,
C     LABELLED BY G VECTORS RATHER THAN CHANNEL NUMBERS
      XJ=1.D0
      IF(JLEV(LEVC).NE.0 .OR. JLEV(NLEV+LEVC).NE.0) GOTO 2400
      WRITE(6,607) JLEV(LEVR),JLEV(NLEV+LEVR),
     1   SMAG,PHASE,SREAL(IJ),SIMAG(IJ)
      GOTO 2400
C     ALL OTHER CASES
 2100 WRITE(6,607) IROW,ICOL,SMAG,PHASE,SREAL(IJ),SIMAG(IJ)
  607 FORMAT(2I5,4E20.6)
 2300 IF (IROW.NE.ICOL)  GO TO 2400
C     FOR IROW = ICOL,  CALCULATE  T = 1 - S.
      SMAG=1.D0-SREAL(IJ)
      SMAG=SMAG*SMAG + SIMAG(IJ)*SIMAG(IJ)
 2400 CONTINUE
      LROW=JLEV(NTOP+LEVR)
      IF (LROW.GT.NLEVEL .OR. LCOL.GT.NLEVEL) GO TO 2000
C     II IS INDEX OF SIG(ICOL,IROW).  N.B. JLEV(LEV,NQN) HAS POINTER
C          TO 'SERIAL' NUMBER OF 'LEVEL'.
      II=(LROW-1)*NLEVEL+LCOL
C     ACCOUNT FOR K(J,J), DEGEN. LATTER IN SIG(NSTOR+II).
      SIG(II) = SIG(II) + SMAG*XJ/(SIG(NSTOR+II)*DD)
 2000 CONTINUE
C
C     ACCUMULATE X-SECTIONS.  SET IJ TO START OF INRG-TH ENERGY IN SIG
 4100 IJ=(INRG+1)*NSTOR
      II=0
      XII=0.D0
      XIJ=0.D0
      DO 3000 JI=1,NLEVEL
      DO 3000 I=1,NLEVEL
      II=II+1
      IJ=IJ+1
      IF ( ACCUM )  SIG(IJ)=SIG(IJ)+SIG(II)
      IF (JI.EQ.I)  GO TO 3100
      XIJ=MAX(XIJ,ABS( SIG(II)))
      GO TO 3000
 3100 XII=MAX(XII,ABS( SIG(II)))
 3000 CONTINUE
C
      IF (ACCUM)  GO TO 5101
C     CODE BELOW IS REACHED IF SIGMA NOT ACCUMULATED. . .
      IF (ITYPE.EQ.8) GO TO 6500
      IF (OKEY)  GO TO 9100
      WRITE(6,9600)
 9600 FORMAT(' ****** SIGMA NOT ACCUMULATED DUE TO LACK OF CONVERGENCE',
     1 ' IN THIS OR PREVIOUS CALCULATION.')
      IF(ISAVEU.GT.0) WRITE(6,9632)
 9632 FORMAT(' ****** SCATTERING MATRIX NOT SAVED')
      MAXJT(INRG)=-IABS(MAXJT(INRG))
      IECONV(INRG)=MIN0(IECONV(INRG)-1,-1)
      GO TO 6500
C
 9100 WRITE(6,9611) INVERR
 9611 FORMAT(' ****** SIGMA NOT ACCUMULATED BECAUSE OF MATRIX ',
     1 'INVERSION ERROR',I4)
      IF(ISAVEU.GT.0) WRITE(6,9632)
      GO TO 6500
C
C     BELOW REACHED IF SIGMA ACCUMULATED.  OUTPUT, SAVE ON TAPE, DISK.
C
 5101 IF(PRINT.EQ.1) THEN
        WRITE(6,642) JTOT,M,INRG,ENERGY(INRG),XII,XIJ
      ELSEIF(PRINT.GT.1) THEN
        WRITE(6,642) JTOT,M,INRG,ENERGY(INRG),XII,XIJ,TTIME
  642   FORMAT('0 FOR JTOT =',I4,'.',I2,'  ENERGY(',I3,
     1   ') =',F12.2,', MAX CHANGE IN DIAG/OFF-DIAG SIG =',2D12.4,
     2   4X,'TIME =',F6.2)
      ENDIF
C
      IF(ISIGPR.EQ.0) GO TO 5100
      IF (PRINT.LE.3)  GO TO 5100
      WRITE(6,9601)
 9601 FORMAT('0',8('  *  '),'PARTIAL CROSS SECTIONS',8('  *  '))
      DO 5200 I=1,NLEVEL
 5200 WRITE(6,631) (SIG((II-1)*NLEVEL+I),I,II, II=1,NLEVEL)
  631 FORMAT('0',4(F15.6,' FOR SIG(',2I3,')'   )/
     1  (    ' ',4(F15.6,' FOR SIG(',2I3,')'   )))
      IF (PRINT.LE.10)  GO TO 5100
      WRITE(6,9602) MINJT(INRG),JTOT
 9602 FORMAT('0',6('  *  '),'CROSS SECTIONS ACCUMULATED FROM JTOT=',
     1  I4,' TO',I4,6('  *  '))
      ISTART=(INRG+1)*NSTOR
      DO 5299 I=1,NLEVEL
 5299 WRITE(6,631) (SIG((II-1)*NLEVEL+I+ISTART),I,II,II=1,NLEVEL)
 5100 IF (XII.LE.DTOL .AND. XIJ.LE.OTOL)  GO TO 5102
      IECONV(INRG)=MIN0(IECONV(INRG),0)
      GO TO 5103
 5102 IECONV(INRG)=IECONV(INRG)+1
 5103 IF(KSAVE.GT.0) GO TO 6320
C
C     SAVE S MATRICES ON TAPE (ISAVEU) . . .
      IF (IRSTRT.GT.0) GO TO 6500
      IF (ISAVEU.LE.0)  GO TO 6500
      WRITE(ISAVEU) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M
C     WRITE(ISAVEU,803) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M
C 803 FORMAT(2I4,E16.8,I4,E16.8,I4)
      WRITE(ISAVEU) NOPEN,
     1   (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN)
C     WRITE(ISAVEU,804) NOPEN,
C    1   (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN)
C 804 FORMAT(I4/(2I4,E16.8))
      CALL SWRITE(ISAVEU,NOPEN,SREAL)
      CALL SWRITE(ISAVEU,NOPEN,SIMAG)
C     NSQ=NOPEN*NOPEN
C     WRITE(ISAVEU,805) (SREAL(I),I=1,NSQ)
C     WRITE(ISAVEU,805) (SIMAG(I),I=1,NSQ)
C 805 FORMAT(5E16.8)
      GO TO 6500
C
 6320 IF(ISAVEU.LE.0) GO TO 6322
      WRITE(ISAVEU) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M
 6324 FORMAT(2I4,D22.15,I4,D22.15,I4)
      WRITE(ISAVEU) NOPEN,
     1   (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN)
 6326 FORMAT(I4/(2I4,D22.15))
      NPL1=NOPEN+1
      NSQ=NOPEN*NOPEN
      WRITE(ISAVEU) (SREAL(I),SIMAG(I),I=1,NSQ,NPL1)
      WRITE(ISAVEU) ((AKMAT(I,JJ),I=1,JJ),JJ=1,NOPEN)
 6328 FORMAT(4(D20.13))
 6322 ESUM=EPSUM(AKMAT,NOPEN,SREAL,SIMAG,SREAL(NOPEN+1))
      IF(ISAVEU.GT.0) WRITE(ISAVEU) ESUM
      WRITE(6,6342) ESUM
 6342 FORMAT('0 S-MATRIX EIGENPHASE SUM, EPSUM/PI =',F9.5)
      IS=INRG-5*((INRG-1)/5)
      EPSM(IS)=ESUM
C
      WRITE(KSAVE,6330) JTOT,M,NOPEN,INRG,ENERGY(INRG),ESUM
 6330 FORMAT(1X,I3,2I4,I5,F18.10,F21.15)
C
C     ENTRY TO ALLOW UPDATING OF SIG() ON UNIT ISIGU
C     IN CASE THERE ARE NO BASIS FNS FOR SYMMETRY BLOCK M=MXPAR.
      GO TO 6500
      ENTRY OUTSIG(ISIGU,M,MXPAR,INRG,ENERGY,MINJT,MAXJT,SIG)
      IRET=1
C
C     UPDATE DISK (ISIGU) RECORD IF THIS IS THE LAST PARITY CASE
 6500 IF (.NOT.LOUT .OR. M.NE.MXPAR)  GO TO 7200
      IJ=(INRG+1)*NSTOR
      I10=ISST(INRG)
      DO 7100 I=1,NLEVEL
      DO 7100 II=1,NLEVEL
      IJ=IJ+1
C     I10 IS INCREMENTED BY ASSOCIATED VARIABLE HERE.
      WRITE(ISIGU,101,REC=I10) STAR,ENERGY(INRG),
     1   MINJT(INRG),MAXJT(INRG),II,I,SIG(IJ)
      I10=I10+1
  101 FORMAT(A1,F19.6,I5,I7,10X,2I5,E20.6)
 7100 CONTINUE
      IF (PRINT.GE.1) WRITE(6,690) ISIGU,INRG,ENERGY(INRG),JTOT,M
  690 FORMAT(' OUTSIG: DA FILE (',I2,') UPDATED WITH SIGMA FOR ENERGY('
     1      ,I3,') =',F10.2,'  JTOT =',I4,'.',I2)
C
C>>SG(10/92)
C7200 CONTINUE
 7200 IF (IRET.EQ.1) RETURN
C<<SG
C
      IF(IPARTU.LE.0) GOTO 7250
      WRITE(IPARTU,7205) JTOT,M,INRG,ENERGY(INRG)
 7205 FORMAT(3I5,F20.5)
      DO 7210 I=1,NLEVEL
 7210 WRITE(IPARTU,7211) (SIG((II-1)*NLEVEL+I),II=1,NLEVEL)
 7211 FORMAT(5F14.6)
 7250 CONTINUE
C
      INVERR=0
C     RESTORE WVEC TO UNITS OF 1./RM
      DO 7259 I=1,NOPEN
 7259 WVEC(NBASIS(I))=WVEC(NBASIS(I))*RM
      RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     INITIALIZATION ENTRY.
C
      ENTRY OUTINT(LABEL,ENERGY,NNRG,NLEV,NQN,JLEV,SIG,IC,   IECONV,
     1      URED,ITYP,KSAVE,ISST,MINJT,MAXJT,ISIGU,IPARTU,ISAVEU,IPROGM,
     2      MXSIG,ISIGPR,IRSTRT)
C
      PI=ACOS(-1.D0)
      PI2=2.D0*PI
      INVERR=0
      ITYPE=ITYP
C     FIND NLEVEL AS MAX. INDEX FROM JLEV(I,NQN) . . .
      IJ=(NQN-1)*NLEV
      NLEVEL=0
      DO 6196 II=1,NLEV
      IJ=IJ+1
 6196 NLEVEL=MAX0(NLEVEL,JLEV(IJ))
      IF (NLEVEL.GT.0)  GO TO 6195
      WRITE(6,603)
  603 FORMAT('0 * * * ERROR.  NO LEVELS IN SIG. MATRICES.')
      STOP
 6195 IF (MXSIG.GT.0) NLEVEL=MIN0(MXSIG,NLEVEL)
      NSTOR=NLEVEL*NLEVEL
      IF (MXSIG.GT.0)  WRITE(6,604)  MXSIG
  604 FORMAT('0 NOTE THAT MAXIMUM LEVEL FOR WHICH CROSS SECTIONS ARE ',
     1 'ACCUMULATED MAY BE LIMITED BY MXSIG =',I4)
C
C     CALCULATE REQUIRED STORAGE AND INITIALIZE IT.  NSTOR LOCATIONS
C     FOR TSIG; NSTOR FOR DEGEN; NNRG*NSTOR FOR SIG.
      IJ=NSTOR*(NNRG+2)
      IC=IC+IJ
C     IC INCREMENTED TO REFLECT ADDITIONAL STORAGE TAKEN UP BY SIG.
C     THIS CODE RELIES ON THE FACT THAT IXNEXT IS PASSED IN ARG. IC
C       AND THAT IT IS REFERENCED BY LOCATION SO THAT THE VALUE
C       IN COMMON IS UPDATED BY THE ASSIGNMENT IC= ...
C       SO THAT THE VALUE IN /MEMORY/ ..,IXNEXT,.. IS SET FOR CHKSTR
C
C     N.B NUSED MUST BE INITIALIZED NON-NEGATIVE BEFORE CHKSTR
      NUSED=0
      CALL CHKSTR(NUSED)
C     INITIALIZE SIG TO ZERO
      II=2*NSTOR+1
      DO 6200 I=II,IJ
 6200 SIG(I)=0.D0
C     DEGENERACY INFORMATION IN SIG(NSTOR+(LROW-1)*NLEVEL+LCOL)
      II=NSTOR
      DO 6194 LROW=1,NLEVEL
      DO 6194 LCOL=1,NLEVEL
      II=II+1
 6194 CALL DEGENF(LCOL,LROW,SIG(II))
C
C     PREPARE FOR STORAGE OF SIG ON DA (ISIGU).
      MXREC=NSTOR*NNRG+2
      LOUT=.TRUE.
      IF (ISIGU.LE.0)  GO TO 6197
C*V12*OPEN(ISIGU,FILE='ISIGU',STATUS='UNKNOWN',ACCESS='DIRECT',
C*V12*   FORM='FORMATTED',RECL=80,ERR=6197)
C*****    GISS VERSION FOLLOWS
      OPEN(ISIGU,             STATUS='UNKNOWN',ACCESS='DIRECT',
     1   FORM='FORMATTED',RECL=80,ERR=6197)
      GO TO 6199
 6197 LOUT=.FALSE.
      WRITE(6,651)
  651 FORMAT('0 STATE-TO-STATE INTEGRAL CROSS-SECTIONS WILL BE ',
     1 'COMPUTED BUT NOT STORED ON DISK')
      GO TO 6198
 6199 WRITE(6,652) ISIGU
  652 FORMAT('0 STATE-TO-STATE INTEGRAL CROSS SECTIONS ',
     1  'WILL BE STORED IN A D.A. FILE ON UNIT',I3)
 6198 CONTINUE
      IF (.NOT. LOUT)  GO TO 6208
C     INITIALIZE DATA SET ON ISIGU. . .
      I10=1
      WRITE(ISIGU,100,REC=I10) LABEL
  100 FORMAT(20A4)
      I10=I10+1
      DO 6201 II=1,NNRG
      ISST(II)=I10
      DO 6201 I=1,NSTOR
      WRITE(ISIGU,199,REC=I10)
  199 FORMAT('.',79X)
 6201 I10=I10+1
      WRITE(ISIGU,102,REC=I10)
  102 FORMAT('$*',78X)
      I10=I10+1
C
C     PROCESS IRSTRT POSSIBILITIES NEXT.
 6208 IF (IRSTRT.GE.-1) THEN
        WRITE(6,*) ' *** '
        IF (IRSTRT.GT.3) THEN
          WRITE(6,*) ' *** IRSTRT REDUCED TO MAX ALLOWED VALUE = 3'
          IRSTRT=3
        ENDIF
        WRITE(6,655) ISAVEU,IRSTRT
  655   FORMAT('  *** OUTINT.  RESTART FROM UNIT(',I3,').  IRSTRT =',I4)
        WRITE(6,*) ' *** '
        IF (KSAVE.NE.0) THEN
          WRITE(6,*) ' *** INCOMPATIBLE WITH KSAVE.NE.0',KSAVE
          WRITE(6,*) ' ***   CHANGE INPUT DECK AND RESUBMIT   ***'
          STOP
        ENDIF
        IF (ISAVEU.LE.0) THEN
          WRITE(6,*) ' *** INCOMPATIBLE WITH ISAVEU.LE.0',ISAVEU
          WRITE(6,*) ' ***   CHANGE INPUT DECK AND RESUBMIT   ***'
          STOP
        ELSE
C         OPEN(ISAVEU,FILE='ISAVEU',STATUS='OLD',FORM='UNFORMATTED')
C*****    GISS VERSION FOLLOWS
          OPEN(ISAVEU,              STATUS='OLD',FORM='UNFORMATTED')
        ENDIF
C     IF WE ARE DOING A RESTART, SKIP 'NORMAL' KSAVE, ISAVEU PROCESSING.
      GO TO 6209
      ENDIF
C
      IF(KSAVE.GT.0) GO TO 6300
C
C     PREPARE TO SAVE S MATRICES ON (ISAVEU).
      IF (ISAVEU.LE.0)  GO TO 6209
      WRITE(6,660) ISAVEU,IPROGM
  660 FORMAT(/'  COMPUTED S-MATRICES WILL BE SAVED ON UNIT',I3/
     1    '  N.B. THESE ARE *** UNFORMATTED *** IN MOLSCAT VERSION',I3)
      INQUIRE(ISAVEU,OPENED=OPENED)
C*V12*IF(.NOT.OPENED) OPEN(ISAVEU,FILE='ISAVEU',STATUS='UNKNOWN',
C*V12*   FORM='UNFORMATTED')
C*****    GISS VERSION FOLLOWS
      IF(.NOT.OPENED) OPEN(ISAVEU,              STATUS='UNKNOWN',
     1   FORM='UNFORMATTED')
      WRITE(ISAVEU) LABEL,ITYPE,NLEV,NQN,URED,IPROGM
C     WRITE(ISAVEU,800) LABEL,ITYPE,NLEV,NQN,URED,IPROGM
  800 FORMAT(20A4/3I4,F8.4,I4)
      NSQ=NQN*NLEV
      WRITE(ISAVEU) (JLEV(I),I=1,NSQ)
C     WRITE(ISAVEU,801) (JLEV(I),I=1,NSQ)
  801 FORMAT(20I4)
      WRITE(ISAVEU)  NLVL,(ELVL(I),I=1,NLVL)
C     IF (IPROGM.GE.3)  WRITE(ISAVEU,802)  NLVL,(ELVL(I),I=1,NLVL)
      WRITE(ISAVEU) NNRG,(ENERGY(I),I=1,NNRG)
C     WRITE(ISAVEU,802) NNRG,(ENERGY(I),I=1,NNRG)
  802 FORMAT(I4/(5E16.8))
      GO TO 6209
C
C     'KSAVE' CASE
 6300 NSQ=NQN*NLEV
      IF(ISAVEU.LE.0) GO TO 6301
      WRITE(6,6306) ISAVEU
 6306 FORMAT('0 COMPUTED K-MATRICES WILL BE SAVED ON UNIT',I3)
      INQUIRE(ISAVEU,OPENED=OPENED)
C*V12*IF(.NOT.OPENED) OPEN(ISAVEU,FILE='ISAVEU',STATUS='UNKNOWN',
C*V12*   FORM='UNFORMATTED')
C*****    GISS VERSION FOLLOWS
      IF(.NOT.OPENED) OPEN(ISAVEU,              STATUS='UNKNOWN',
     1   FORM='UNFORMATTED')
      REWIND ISAVEU
      WRITE(ISAVEU) LABEL,ITYPE,NLEV,NQN,URED,IPROGM
      WRITE(ISAVEU) (JLEV(I),I=1,NSQ)
      WRITE(ISAVEU) NLVL,(ELVL(I),I=1,NLVL)
      WRITE(ISAVEU) NNRG,(ENERGY(I),I=1,NNRG)
 6304 FORMAT(I4/4(D20.13))
 6301 WRITE(6,6307) KSAVE
 6307 FORMAT('0 EIGENPHASE SUMMARY WILL BE WRITTEN TO UNIT',I3)
      CALL GDATE(CDATE)
      CALL GTIME(CTIME)
      INQUIRE(KSAVE,OPENED=OPENED)
C*V12*IF(.NOT.OPENED) OPEN(KSAVE,FILE='KSAVE',STATUS='UNKNOWN',
C*V12*   FORM='FORMATTED')
C*****    GISS VERSION FOLLOWS
      IF(.NOT.OPENED) OPEN(KSAVE,             STATUS='UNKNOWN',
     1   FORM='FORMATTED')
      WRITE(KSAVE,6308) (LABEL(I),I=1,19),
     1   CDATE,CTIME,NLEV,NQN,NNRG,(JLEV(I),I=1,NSQ)
 6308 FORMAT(1X,19A4/1X,A11,A9,4X,8X,'NLEV =',
     1 I3,'    NQN =',I3,'    NNRG =',I4/(1X,'JLEV  ',15I4))
      WRITE(KSAVE,6309)
 6309 FORMAT(1X/' JTOT  M  NOP   I',6X,'ENERGY(I)',7X,'EPSUM/PI')
C
 6209 IF(IPARTU.LE.0) GOTO 6321
      WRITE(6,6311) IPARTU
 6311 FORMAT('0 PARTIAL CROSS SECTIONS WILL BE WRITTEN TO UNIT',I3)
      REWIND IPARTU
      WRITE(IPARTU,800) LABEL,ITYPE,NLEV,NQN,URED,IPROGM
      NSQ=NQN*NLEV
      WRITE(IPARTU,801) (JLEV(I),I=1,NSQ)
      WRITE(IPARTU,802) NLVL,(ELVL(I),I=1,NLVL)
      WRITE(IPARTU,802) NNRG,(ENERGY(I),I=1,NNRG)
C
C     SET UP 'BOOKKEEPING' VARIABLES.
 6321 DO 6100 I=1,NNRG
      MINJT(I)=-1
      IECONV(I)=0
 6100 MAXJT(I)=0
C
      RETURN
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
      ENTRY OUTPCH(SIG,ENERGY,NNRG,MINJT,MAXJT,ISIGPR,LABEL,ISIGU,JSTEP)
C     ARGUMENT 'JSTEP' ADDED AUG 86 - SG
C     ARGUMENT 'ISIGU' ADDED JUL 92 - JMH
      IF(ISIGPR.NE.0) GO TO 9000
      WRITE(6,9603) IPUNCH
 9603 FORMAT('0 SIGMA NOT PRINTED BECAUSE ISIGPR = 0'/
     1       '  SIGMA WILL BE WRITTEN TO UNIT IPUNCH =',I4)
      GO TO 9001
 9000 WRITE(6,9678) LABEL
 9678 FORMAT('1',20A4/)
C ***
C *** AUG 86.  FORCE PUNCH FROM INTERNAL SIG MATRIX.
C ***          SET LOUT=.FALSE.
C ***
      LOUT=.FALSE.
      WRITE(6,9679)
 9679 FORMAT(/12X,'ENERGY  JTOTL  JSTEP  JTOTU',7X,
     1       'F    I',12X,'SIG(F,I)'/)
      IF (LOUT) GO TO 9500
C     OUTPUT FROM STORAGE IN SIG.
 9001 IJ=2*NSTOR
      XJSTEP=JSTEP
      IF(JSTEP.GT.1) WRITE(6,9604) JSTEP
 9604 FORMAT('0 *** N.B. CROSS SECTIONS HAVE BEEN MULTIPLIED BY JSTEP ='
     1  ,I3)
      DO 9900 K=1,NNRG
      MN=MINJT(K)
      MXJ=MAXJT(K)
      EK=ENERGY(K)
      DO 9900 I=1,NLEVEL
      DO 9900 II=1,NLEVEL
      IJ=IJ+1
      SIJ=SIG(IJ)*XJSTEP
      IF (ISIGPR.NE.0 .AND. SIJ.GE.EPS)
     1WRITE(6,103) BLANK,EK,MN,JSTEP,MXJ,II,I,SIJ
  103 FORMAT(A1,F19.6,I5,2I7, 5X,2I5,E20.6)
      IF (II.EQ.I .OR. SIJ.LE.EPS)  GO TO 9900
      WRITE(IPUNCH,9670) STAR,EK,MN,JSTEP,MXJ,II,I,SIJ
 9670 FORMAT(A1,F19.6,I5,'(',I3,')',I5,5X,2I5,E20.6)
 9900 CONTINUE
      RETURN
C     BELOW PUNCHES FROM DISK(ISIGU ) STORAGE.
 9500 CALL RDPCH(ISIGU)
      RETURN
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
      ENTRY OUTERR(INVER)
      INVERR=INVER
      RETURN
      END