C N. R. BADNELL  UoS v2.8   -   QUB v1.1                        13/03/03
C
C  PROGRAM PREBF, TO BE RUN BEFORE STGBF.
C
C  READS THE DATA FOR STGBF
C  PREBF PREMULTIPLIES THE D MATRIX BY THE EIGENVECTOR FOR THE
C  EACH BOUND LEVEL AND FOR EACH SLPI1,SLPI2 COMBINATION.
C  THE FINAL VECTOR IS WRITTEN TO A SERIAL FILE ON UNIT 4.
C  AFTER RUNNING PREBF THE D FILES CAN BE DELETED TO SAVE DISC SPACE.
C
C
C  I/O CHANNELS:
C      1      INITIAL BOUND STATE DATA (FILES B);
C      2      FINAL FREE STATE DATA (FILES F);
C      3      DIPOLE DATA FOR THE INITIAL AND FINAL SLPI COMBINATION;
C      4      FILE FOR OUTPUT VECTORS DVECTL,DVECTV AND ANGULAR
C             COEFFICIENTS COPIED FROM FILES D (FILE DVEC);
C      5      STANDARD INPUT. THE FOLLOWING DATA ARE READ:
C                  IPRINT, IBUT
C                  IS1, IL1, IP1, M11, M12    = S L PI  OR  0 2J  PI ...
C                  IS2, IL2, IP2              - SET 0 0 2 FOR J=0 EVEN
C                  IS2, IL2, IP2              - AS PI CONGR PI MODULO 2!
C                  .    .    .
C                 -1,  -1,  -1                :TERMINATING 1 INITIAL SLP
C                  IS1, IL1, IP1, M11, M12    :AND STARTING ANOTHER
C                  .    .    .
C                  .    .    .
C                 -1,  -1,  -1,  -1,  -1      :OR SIMPLY /EOF
C      6      STANDARD OUTPUT. PRINT LEVEL IS CONTROLED BY IPRINT:
C                  IPRINT=0      DEFAULT, MINIMUM PRINT LEVEL.
C                        =1      DETAILED PRINTOUT    
C
C                  IBUT=-1 FOR OLD D DATASETS (NO BUTTLE DATA)
C                  IBUT= 0 FOR NEW D DATASETS, NOT TO BE PROCESSED (DEFAULT)
C                  IBUT=+1 FOR NEW D DATASETS, TO BE PROCESSED
C
C
      PROGRAM MAIN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MNPEXT=MZMNP+MZCHF, MXTRAN=99)
C
C  SUN
      REAL*4 TARRY(2)
C
      COMMON/LIST0/KOUNT,MSLPL(MXTRAN),MSLPR(MXTRAN),LAST,LTAPE,LBUT
      COMMON/MISC/WBODE(MZPTS,-3:1),IPERT,MXE2,EMESH(MZMSH),BSTO
      COMMON/SCALE/AZ,AZP,AZ2,AZP2,K10,K20
      COMMON/CTRLBF/IPRINT,IBUT
      COMMON/SLPI2/IS2V(3),IL2V(3),IP2V(3),KUT
      COMMON/FLAG0/ALL1,ALL2,RED,MORE1,MORE2,OK,EOF,KKP,CMPLT
      COMMON /TARG/ ENAT(MZTAR),NCONAT(MZTAR),NZED,NELC,NAST
      COMMON/A1/AVECT1(MNPEXT,MZEST),E1(MZEST)
      COMMON/NRBPRT/IPERT1,IPERT2
C
      LOGICAL ALL1,ALL2,RED,MORE1,MORE2,OK,EOF,KKP, CMPLT
      CHARACTER*3 FILE1,FILE2,FILE4*4
C
      NAMELIST/PREBF/IPRINT,IBUT
C
      DATA FILE4/'DVEC'/
C
C     OPEN(5,FILE='dstgpre',FORM='FORMATTED')
      OPEN(6,FILE='routpre',FORM='FORMATTED',STATUS='UNKNOWN')
C
      WRITE(6,598)MZCHF,MZMNP,MZMSH,MZPTS,MZTAR
C
      IPRINT=0
      IBUT=0
C
      READ(5,PREBF)
C
      IF(IBUT.GT.0) WRITE(6,500)IBUT
      CALL RBF00
      CALL RD00(3,IPRINT,IBUT)
      IPERT0=IPERT
C  SET OR CLEAR FLAGS FOR PROCESSING ALL INITIAL STATES
      EOF=.FALSE.
C
      CALL RD5L1(IS1,IL1,IP1,M11,M12)
C
      ALL1=EOF
      ALL2=.TRUE.
      IF(EOF) THEN
        WRITE(6,501)
      ELSE
          CALL RD5L2
C         RETURNING NEW VALUES ALL2,EOF:
C         IF(.NOT.EOF) BACKSPACE 5
          BACKSPACE 5
        BACKSPACE 5
      ENDIF
      IF(ALL2) WRITE(6,502)
C
C  START PROCESSING SLPI CASES, SET FIRST ENTRY FLAGS
C
      OPEN(4,FILE=FILE4,FORM='UNFORMATTED',STATUS='UNKNOWN')
      WRITE(6,503)
      RED=.TRUE.
      MORE1=.TRUE.
C
C  START LOOP FOR INITIAL SLPI
    1 CALL GET1(FILE1,IS1,IL1,IP1,M11,M12)
      IF(.NOT.OK) GOTO 5
      MORE2=.TRUE.
C
C  READ E1-INDEPENDENT DATA
      CALL R1EIND(FILE1,M11,M12,M13,MNP2,NCHF)
      IF(M13.EQ.0) GO TO 5
C  START LOOP FOR INITIAL BOUND LEVELS
      MLAST=M13
      DO 3 M1=M11,M13
C
C  READ E1-DEPENDENT DATA
       CALL R1EDEP(M1,MNP2,NCHF)
C
C  WARNING IF LEVEL IS ABOVE IONIZATION LIMIT
       IF(E1(M1).LE.0.0) GO TO 3
        WRITE(6,515)
C
C  BUT FOR PRODUCTION WORK WE SKIP IT
        IF(IPRINT.NE.-1) GO TO 3
          MLAST=M1-1
          IF (MLAST .LT. M11) GO TO 5
          GO TO 31
    3  CONTINUE
C
C  END LOOP FOR INITIAL BOUND LEVELS
   31 RED=.TRUE.
      MORE2=.TRUE.
C
C  START LOOP FOR FINAL SLPI
    2 CALL GET2(FILE2,IS1,IL1,IP1,IS2,IL2,IP2)
      IF(.NOT.OK) GOTO 4
      CALL GETD(IS1,IL1,IP1,IS2,IL2,IP2,M11,MLAST,OK,
     &  MNP2D1,NCHND1,MNP2D2,NCHND2,NSPND,LRGLD1,NPTYD1,2)
C
      IF(.NOT.OK) GOTO 4
C
C  CHECK ACCORD BETWEEN FILES B AND D - TRIVIAL HERE.
      IF(IS1.NE.NSPND.OR.IL1.NE.LRGLD1.OR.IP1.NE.NPTYD1.OR.MNP2.NE.
     1   MNP2D1) THEN
        WRITE(6,510)FILE1,IS1,IL1,IP1,MNP2
        CALL ABORTT(8)
      ENDIF
C
      WRITE(6,609)IS1,IL1,IP1,M11,MLAST,IS2,IL2,IP2
C
      WRITE(6,503)
      CLOSE(2)
C     CLOSE(3)
    4 IF(MORE2) GO TO 2
C
C  END LOOP FOR FINAL SLPI
      CLOSE(1)
    5 IF(MORE1) GOTO 1
C
C  END LOOP FOR INITIAL SLPI
      CLOSE(4)
      WRITE(6,703)
      WRITE(6,697)
C
C SUN
      DUM=DTIME(TARRY)
      TIME=TARRY(1)
      TIME=TIME/60.
      WRITE(6,999)TIME
  999 FORMAT(//' CPU TIME=',F9.3,' MIN')
C
      STOP
C
C  FORMATS
C  *******
C
  500 FORMAT(//'    RUN WITH IBUT =',I2/5X,17('*')//)
  501 FORMAT(//20X,'FROM ALL INITIAL STATES AVAILABLE')
  502 FORMAT(//20X,'TO ALL ALLOWED FINAL STATES')
  503 FORMAT(//1X,79('+')/)
  510 FORMAT(//'*** MISMATCH'/4X,'FILE ',A3,' HAS IS,IL,IP,MNP2 = ',
     *       3I3,I5//)
  515 FORMAT(//'*** HIGHER LEVELS OF THE PRESENT SERIES ARE ',
     1 'ABOVE THE IONIZATION LIMIT ***'//)
  598 FORMAT(///2(/1X,79('+'))///28X,'PROGRAM PREBF'
     * /28X,13('+')//
     * 18X,'PHOTOIONIZATION CROSS SECTION DATA'//
     *      ///10X,'COMPILED FOR DIMENSIONS -'//
     + 15X,'CHANNELS                   MZCHF =',I6/
     * 15X,'R-MATRIX POLES             MZMNP =',I6/
     + 15X,'ENERGY-MESH POINTS         MZMSH =',I6/
     + 15X,'OUTER-REGION RADIAL POINTS MZPTS =',I6/
     + 15X,'TARGET STATES              MZTAR =',I6//)
  609 FORMAT(//20X,'D VECTORS WRITTEN FOR'//
     1 10X,'(IS1,IL1,IP1) = (',3I3,' )',5X,'LEVELS',I3,'  TO',I3/
     2 10X,'(IS2,IL2,IP2) = (',3I3,' )'//)
  697 FORMAT(///20X,'END OF PREBF'/20X,12('-')//)
  703 FORMAT(///10X,'D VECTOR FILE DVEC WRITTEN')
C
      END
C
C*******************************************************************
C
      SUBROUTINE ABORTT(N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
C  HANDLE CONDITION CODE AND ABORT PROGRAM
C
      WRITE(6,97)N
      GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16) N
C
    1 PRINT 99,'CHECK DATASETS ACCESSED FOR BOUND AND FREE DATA'
      GOTO 50
    2 PRINT 99,'REQUESTED TRANSITION NOT ALLOWED: ERROR IN TOTAL SPIN'
      GOTO 50
    3 PRINT 99,'REQUESTED TRANSITION NOT ALLOWED: TOTAL L OUT OF RANGE'
      GOTO 50
    4 PRINT 99,'REQUESTED TRANSITION NOT ALLOWED: ERROR IN PARITY'
      GOTO 50
    5 PRINT 99,'INITIAL LEVEL SPECIFICATION ERROR'
      WRITE(6,98)
      GOTO 50
    6 CONTINUE
C
C  CASE DELETED
      GOTO 50
    7 PRINT 99,'BOUND LEVEL DATA NOT ON B FILE: LEVEL TOO HIGH'
      GOTO 50
    8 PRINT 99,'CHECK DATASETS ACCESSED FOR BOUND AND DIPOLE DATA'
      GOTO 50
    9 PRINT 99,'CHECK DATASETS ACCESSED FOR FREE AND DIPOLE DATA'
      GOTO 50
   10 PRINT 99,'RECOMPILE PROGRAM WITH LARGER DIMENSIONS'
      GOTO 50
   11 PRINT 99,'RE-RUN STGB AND STGF WITH THE SAME IPERT'
      GOTO 50
   12 PRINT 99,'DIRECTORY FILE B00 NOT FOUND'
      WRITE(6,96)
      GOTO 50
   13 PRINT 99,'FILE NOT FOUND'
      WRITE(6,96)
      GOTO 50
   14 PRINT 99,'RE-RUN STGF WITH LARGER QNMAX'
      GOTO 50
   15 PRINT 99,'DIRECTORY FILE F00 NOT FOUND'
      WRITE(6,96)
      GOTO 50
   16 PRINT 99,'DIRECTORY FILE D00 NOT FOUND'
      WRITE(6,96)
      GOTO 50
C
   50 CALL EXIT (0)
C
   96 FORMAT(//5X,40('*')/10X,'THE STANDARD INPUT FILES ARE'/
     1       12X,'B00    F00    D00'/
     2       12X,'B01    F01    D01'/
     3       12X,'B02    F02    D02'/
     4       12X,' .      .      . '/
     5       12X,' .      .      . '/
     6       12X,' .      .      . '/
     7       12X,'AS MANY AS NECESSARY'/5X,40('*')/)
   97 FORMAT(//' *** ABORT: CN',I3)
   98 FORMAT(//10X,60('*')/10X,'THE FOLLOWING DATA ARE READ IN FREE ',
     1  'FORMAT'/30X,'IS1, IL1, IP1, M11, M12'/10X,'FOR BOUND STATE ',
     2  'WITH IS1,IL1,IP1 AND LEVELS RANGING FROM M11 AND M12'/
     3  10X,60('*')/)
   99 FORMAT(' ',A/)
      END
C
C*********************************************************************
C
      SUBROUTINE GET1(FILE,IS1,IL1,IP1,M11,M12)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
C  GET AN INITIAL STATE SLPI FILE AND RANGE OF BOUND LEVELS
C
      COMMON/FLAG0/ALL1,ALL2,RED,MORE1,MORE2,OK,EOF,KKP,CMPLT
      COMMON/LIST1/KSLP1,MSLP1(100)
      COMMON/CTRLBF/IPRINT,IBUT
      COMMON/SLPI2/IS2V(3),IL2V(3),IP2V(3),KUT
      CHARACTER FILE*3,NUM(0:9)
      LOGICAL ALL1,ALL2,RED,MORE1,MORE2,OK,EOF,KKP,CMPLT
      DATA NUM/'0','1','2','3','4','5','6','7','8','9'/
      SAVE KASE
C
      IF(ALL1) THEN
        IF(RED) THEN
          KASE=1
          RED=.FALSE.
        ELSE
          KASE=KASE+1
        ENDIF
        IF(KASE.EQ.KSLP1) MORE1=.FALSE.
        IS1=MSLP1(KASE)/10000
        IL1=(MSLP1(KASE)-IS1*10000)/100
        IP1=MSLP1(KASE)-(IS1*100+IL1)*100
        MF=KASE
      ELSE
CW      READ(5,*) IS1,IL1
CW      PRINT *,' GET1-TEST: IS1,IL1,IP1 = ',IS1,IL1
CW      BACKSPACE 5
C
        CALL RD5L1(IS1,IL1,IP1,M11,M12)
C
        IP1 = MOD(IP1,2)
        CALL RD5L2
        IF(EOF) THEN
          MORE1=.FALSE.
        ELSE
C
          CALL RD5L1(IQ,JUNK1,JUNK2,JUNK3,JUNK4)
C
          IF(EOF.OR.JUNK1.EQ.-1) THEN
            MORE1=.FALSE.
          ELSE
            BACKSPACE 5
          ENDIF
        ENDIF
        ISLP1=(IS1*100+IL1)*100+IP1
        DO 1 K=1,KSLP1
         IF(ISLP1.NE.MSLP1(K)) GO TO 1
          MF=K
          GOTO 2
    1    CONTINUE
        WRITE(6,500)IS1,IL1,IP1
        OK=.FALSE.
        RETURN
      ENDIF
C
    2 FILE='B'//NUM(MF/10)//NUM(MF-10*(MF/10))
      IF(IPRINT.NE.0) WRITE(6,501)FILE
C
C  CMPLT IS CLEARED IF TOTAL X-SECTION SUM IS UNSAFE, WILL WARN AT END
      CMPLT = ALL2 .OR. IL1.EQ.0 .OR. KUT.EQ.3
      OK=.TRUE.
      RETURN
C
  500 FORMAT(/' *** DATA FOR ',3I3,'  NOT ON B DATASET'//)
  501 FORMAT(' OPENING FILE ',A3)
      END
C***************************************************************
C
      SUBROUTINE GET2(FILE,IS1,IL1,IP1,IS2,IL2,IP2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
C  GET A FINAL STATE SLPI FILE
C
      COMMON/SLPI2/IS2V(3),IL2V(3),IP2V(3),KUT
      COMMON/FLAG0/ALL1,ALL2,RED,MORE1,MORE2,OK,EOF,KKP,CMPLT
      COMMON/CTRLBF/IPRINT,IBUT
      COMMON/LIST2/KSLP2,MSLP2(100)
      CHARACTER FILE*3, NUM(0:9)
      LOGICAL ALL1,ALL2,RED,MORE1,MORE2,OK,EOF,KKP,CMPLT
      DATA NUM/'0','1','2','3','4','5','6','7','8','9'/
      SAVE KRRNT
C
      IF(ALL2) THEN
        IF(RED) THEN
          IL2=IL1+1
         IF(IS1.EQ.0) IL2=IL2+1
          IS2=IS1
          IP2=1-IP1
          RED=.FALSE.
        ELSE
          IL2=IL2-1
         IF(IS1.EQ.0) IL2=IL2-1
        ENDIF
        IF(IL2.EQ.0.OR.IL2.EQ.IL1-1) MORE2=.FALSE.
        IF(IL1.EQ.0) MORE2=.FALSE.
         IF(IS1.EQ.0.AND.(IL2.EQ.IL1-2.OR.IL2.EQ.1)) MORE2=.FALSE.      !NRB
      ELSE
        IF(RED) THEN
          KRRNT=1
          RED=.FALSE.
        ELSE
          KRRNT=KRRNT+1
        ENDIF
        IS2=IS2V(KRRNT)
        IL2=IL2V(KRRNT)
        IP2=IP2V(KRRNT)
        IF(IS2.NE.IS1) THEN
          WRITE(6,505)IS1,IS2
          CALL ABORTT(2)
        ENDIF
        IF(IL2.GT.IL1+2 .OR.IL2.LT.IL1-2 .OR.IL2.LT.0) THEN
          WRITE(6,506)IL1,IL2
          CALL ABORTT(3)
        ENDIF
        IF(IP2+2*(IP2/2).NE.1-IP1+2*(IP1/2)) THEN
          WRITE(6,507)IP1,IP2
          CALL ABORTT(4)
        ENDIF
        IF(KRRNT.EQ.KUT) MORE2=.FALSE.
      ENDIF
CW    PRINT *,' GET2-TEST: KRRNT,KUT,MORE2 = ',KRRNT,KUT,MORE2
C
      ISLP2=(IS2*100+IL2)*100+IP2
      DO 3 K=1,KSLP2
       IF(ISLP2.NE.MSLP2(K)) GO TO 3
        FILE='F'//NUM(K/10)//NUM(K-10*(K/10))
        IF(IPRINT.NE.0) WRITE(6,501)FILE
        OK=.TRUE.
        GO TO 4
    3  CONTINUE
C
C  DATA NOT FOUND. CLEAR CMPLT TO GIVE WARNING AT THE END
      WRITE(6,500)IS2,IL2,IP2
      OK=.FALSE.
      CMPLT=.FALSE.
    4 RETURN
C
C
  500 FORMAT(/' *** DATA FOR ',3I3,'  NOT ON F DATASET'//)
  501 FORMAT(' OPENING FILE ',A3)
  505 FORMAT(//10X,'IS1 =',I4,10X,'IS2 =',I4)
  506 FORMAT(//10X,'IL1 =',I4,10X,'IS2 =',I4)
  507 FORMAT(//10X,'IP1 =',I4,10X,'IP2 =',I4)
      END
C***********************************************************************
C
      SUBROUTINE GETD(IS1,IL1,IP1,IS2,IL2,IP2,M11,MLAST,OK,
     &  MNP2D1,NCHND1,MNP2D2,NCHND2,NSPND,LRGLD1,NPTYD1,LV)
C
C    GET DIPOLE MATRIX FROM D DATASET (UNLESS THEY ARE ON DKK FILES).
C    IS1,IL1,IP1/IS2,IL2,IP2 IS THE S,L,PI COMBINATION REQUIRED.
C    LV = 1 FOR LENGTH FORM ONLY, = 2 FOR LENGTH AND VELOCITY FORM.
C    OK IS RETURNED .FALSE. IF DIPOLE MATRIX NOT FOUND.
C
C    ADAPTED FROM
C    PROGRAM OF KTT FOR READING DIPOLE MATRIX ELEMENT DATA
C    AND KB/WE FOR REDUCED MEMORY - ERRORS CORRECTED BY NRB 10/03/99.
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      PARAMETER (MXTRAN=99)
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      PARAMETER (MXLV=2)
C
      COMMON/LIST0/KOUNT,MSLPL(MXTRAN),MSLPR(MXTRAN),LAST,LTAPE,IBUT
      COMMON/DVECT/DVECTL(MNPEXT,MZEST),DVECTV(MNPEXT,MZEST)
      COMMON/A1/AVECT1(MNPEXT,MZEST),E1(MZEST)
      COMMON/SCALE/AZ,AZP,AZ2,AZP2,K10,K20
C
      DIMENSION A(MZCHF,MZCHF,MXLV),B(MZCHF,MZCHF,MXLV),C(MZCHF)
     X         ,D(MZCHF,MNPEXT,MXLV)              !USE MZCHF NOT MZNR2 - NRB
      LOGICAL OK,DOLD,BRDV
C
      CHARACTER  DKK*3,NUM(0:9)
      DATA NUM/'0','1','2','3','4','5','6','7','8','9'/
C
      IF(LV.GT.MXLV)THEN
         WRITE(6,*)' ****INCREASE PARAMETER MXLV TO:',LV
         STOP
      ENDIF
C
      DO M1=M11,MLAST
        DO K2=1,MNPEXT
          DVECTV(K2,M1)=0.
          DVECTL(K2,M1)=0.
        ENDDO
      ENDDO
C
C
C --- FIND POSITION (LPOS) OF S,L,PI COMBINATION IN /LIST0/,
C     SET LPOS -VE FOR TRANSPOSE.
C
      MSLP1=(IS1*100+IL1)*100+IP1
      MSLP2=(IS2*100+IL2)*100+IP2
      DO K=1,KOUNT
        IF(MSLP1.EQ.MSLPL(K).AND.MSLP2.EQ.MSLPR(K)) THEN
          LPOS=K
          GO TO 10
        ENDIF
        IF(MSLP2.EQ.MSLPL(K).AND.MSLP1.EQ.MSLPR(K)) THEN
          LPOS=-K
          GO TO 10
        ENDIF
      ENDDO
      OK=.FALSE.
      RETURN
C
   10 OK=.TRUE.
      IF(LPOS.EQ.LAST) RETURN
      K1 = ABS(LPOS)
      DKK='D'//NUM(K1/10)//NUM(K1-10*(K1/10))
      OPEN(LTAPE,FILE=DKK,STATUS='OLD',FORM='UNFORMATTED',ERR=97)
      DOLD=.FALSE.
      BRDV=IS1.EQ.0.AND.LV.EQ.2    !RECUPD AND VEL. TRUE
      REWIND (LTAPE)
      GO TO 98
   97 PRINT *,' ... LOOKING FOR DATASET D:'
      DOLD=.TRUE.
      BRDV=.FALSE.
      LSKIP=K1-ABS(LAST)-1
      IF(LSKIP.LT.0) THEN
C
C  RESTART D DATASET
C
        CLOSE(LTAPE)
        OPEN(LTAPE,FILE='D',STATUS='OLD',FORM='UNFORMATTED',ERR=99)
        LSKIP=K1
      ENDIF
      IF(LSKIP.GT.0) THEN
C
C         LOOP OVER LSKIP END-OF-FILE MARKERS
C
        DO LOOP=1,LSKIP
   12     READ(LTAPE,END=20)
          GO TO 12
   20     CONTINUE
        ENDDO
      ENDIF
C
C --- READ D DATASET.  CHECK S,L,PI COMBINATION.
C
   98 NPTYD2=-99
      READ(LTAPE,END=99) NOTERM,MNP2D2,NCHND2,LRGLD2,NPTYD2,
     &  NSPND ,MNP2D1,NCHND1,LRGLD1
C
C  CHECK DIMENSIONS FOR MNP2,MZCHF
      N=MAX(NCHND1,NCHND2)
      M=MAX(MNP2D1,MNP2D2)
      IF(M.GT.MZMNP.OR.N.GT.MZCHF) THEN
        WRITE(6,600)MNP2D1,NCHND1,MNP2D2,NCHND2
        GO TO 99
      ENDIF
C
C  CHECK DIMENSION FOR "NR2".
C  IN SMALL CASES THE NO OF CHANNELS WILL BE LESS THAN THE NO OF BASIS
C  ORBITALS BUT IN LARGE CASES THE NO OF CHANNELS WILL BE LARGER. 
C  THE BUTTLE CORRECTION NEEDS MZCHF. WHICHEVER IS USED (MZCHF OR MZNR2)
C  DIMENSIONS NEED TO BE TESTED-FOR.  NRB
      IF(NOTERM.GT.MZCHF)THEN
        WRITE(6,601)NOTERM
        GO TO 99
      ENDIF
C
C  CALCULATE NPTYD1
      NPTYD1=1-NPTYD2
      M1 = (NSPND*100+LRGLD1)*100+NPTYD1
      M2 = (NSPND*100+LRGLD2)*100+NPTYD2
      IF(LPOS.GT.0) THEN
        IF(MSLP1.NE.M1.OR.MSLP2.NE.M2) GO TO 99
      ELSE
        IF(MSLP1.NE.M2.OR.MSLP2.NE.M1) GO TO 99
      ENDIF
C
C  READ DIPOLE MATRIX - TRANSPOSING IF -VE LPOS
C
      IAIN1 = (MNP2D1 - 1) / NOTERM
      IBIN1 = ( MNP2D2 - 1) / NOTERM
      MCI = 0
      DO IK = 1 , IAIN1
        MCH = MCI + 1
        MCI = MCI + NOTERM
        NCI = 0
        DO JK = 1 , IBIN1
          NCH = NCI + 1
          NCI = NCI + NOTERM
          READ(LTAPE) (((D(I,J,L),J=1,NOTERM),I=1,NOTERM),L=1,LV)
          DO M1=M11,MLAST
            K1P = 1
            IF(LPOS.GT.0) THEN
              DO K1=MCH,MCI
                K2P = 1
                AVL=AVECT1(K1,M1)*AZ
                AVV=AVECT1(K1,M1)*AZP
                DO K2=NCH,NCI
                  DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K1P,K2P,2)
                  DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K1P,K2P,1)
                  K2P=K2P+1
                ENDDO
                K1P=K1P+1            !MISSING IN KB/WE SOURCE - NRB
              ENDDO
            ELSE
              DO K1=NCH,NCI
                K2P = 1
                AVL=AVECT1(K1,M1)*AZ
                AVV=AVECT1(K1,M1)*AZP
                DO K2=MCH,MCI
                  DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K2P,K1P,2)
                  DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K2P,K1P,1)
                  K2P=K2P+1
                ENDDO
                K1P=K1P+1
              ENDDO
            ENDIF
          ENDDO
        ENDDO
        NCH = NCI + 1
        NCI = MNP2D2
        NCP=NCI-NCH+1
        READ(LTAPE) (((D(I,J,L),J=1,NCP),I=1,NOTERM),L=1,LV)
        DO M1=M11,MLAST
          K1P = 1
          IF(LPOS.GT.0) THEN
            DO K1=MCH,MCI
              K2P = 1
              AVL=AVECT1(K1,M1)*AZ
              AVV=AVECT1(K1,M1)*AZP
              DO K2=NCH,NCI
                DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K1P,K2P,2)
                DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K1P,K2P,1)
                K2P=K2P+1
              ENDDO
              K1P=K1P+1
            ENDDO
          ELSE
            DO K1=NCH,NCI
              K2P = 1
              AVL=AVECT1(K1,M1)*AZ
              AVV=AVECT1(K1,M1)*AZP
              DO K2=MCH,MCI
                DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K2P,K1P,2)
                DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K2P,K1P,1)
                K2P=K2P+1
              ENDDO
              K1P=K1P+1
            ENDDO
          ENDIF
        ENDDO
      ENDDO
      MCH = MCI + 1
      MCI = MNP2D1
      MCP=MCI-MCH+1
      NCI = 0
      DO JK = 1 , IBIN1
        NCH = NCI + 1
        NCI = NCI + NOTERM
        READ(LTAPE) (((D(I,J,L),J=1,NOTERM),I=1,MCP),L=1,LV)
        DO M1=M11,MLAST
          K1P = 1
          IF(LPOS.GT.0) THEN
            DO K1=MCH,MCI
              K2P = 1
              AVL=AVECT1(K1,M1)*AZ
              AVV=AVECT1(K1,M1)*AZP
              DO K2=NCH,NCI
                DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K1P,K2P,2)
                DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K1P,K2P,1)
                K2P=K2P+1
              ENDDO
              K1P=K1P+1
            ENDDO
          ELSE
            DO K1=NCH,NCI
              K2P = 1
              AVL=AVECT1(K1,M1)*AZ
              AVV=AVECT1(K1,M1)*AZP
              DO K2=MCH,MCI
                DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K2P,K1P,2)
                DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K2P,K1P,1)
                K2P=K2P+1
              ENDDO
              K1P=K1P+1
            ENDDO
          ENDIF
        ENDDO
      ENDDO
      NCH = NCI + 1
      NCI = MNP2D2
      NCP=NCI-NCH+1
      READ(LTAPE) (((D(I,J,L),J=1,NCP),I=1,MCP),L=1,LV)
      DO M1=M11,MLAST
        K1P = 1
        IF(LPOS.GT.0) THEN
          DO K1=MCH,MCI
            K2P = 1
            AVL=AVECT1(K1,M1)*AZ
            AVV=AVECT1(K1,M1)*AZP
            DO K2=NCH,NCI
              DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K1P,K2P,2)
              DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K1P,K2P,1)
              K2P=K2P+1
            ENDDO
            K1P=K1P+1
          ENDDO
        ELSE
          DO K1=NCH,NCI
            K2P = 1
            AVL=AVECT1(K1,M1)*AZ
            AVV=AVECT1(K1,M1)*AZP
            DO K2=MCH,MCI
              DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K2P,K1P,2)
              DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K2P,K1P,1)
              K2P=K2P+1
            ENDDO
            K1P=K1P+1
          ENDDO
        ENDIF
      ENDDO
C
C  READ BUTTLE PART
C
      IF(IBUT.EQ.-1) GOTO 1000
      NCH=1
      NCI=MNP2D2
      MCH=MNP2D1+1
      MCI=MNP2D1+NCHND1
      READ(LTAPE) (((D(I,J,L),I=1,NCHND1),J=NCH,NCI),L=1,LV)
      IF(IBUT.LE.0) GO TO 47
      DO M1=M11,MLAST
        K1P = 1
        IF(LPOS.GT.0) THEN
          DO K1=MCH,MCI
            K2P = 1
            AVL=AVECT1(K1,M1)*AZ
            AVV=AVECT1(K1,M1)*AZP
            DO K2=NCH,NCI
              DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K1P,K2P,2)
              DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K1P,K2P,1)
              K2P=K2P+1
            ENDDO
            K1P=K1P+1
          ENDDO
        ELSE
          DO K1=NCH,NCI
            K2P = 1
            AVL=AVECT1(K1,M1)*AZ
            AVV=AVECT1(K1,M1)*AZP
            DO K2=MCH,MCI
              DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K2P,K1P,2)
              DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K2P,K1P,1)
              K2P=K2P+1
            ENDDO
            K1P=K1P+1
          ENDDO
        ENDIF
      ENDDO
   47 CONTINUE
      NCH=MNP2D2+1
      NCI=MNP2D2+NCHND2
      MCH=1
      MCI=MNP2D1
      READ(LTAPE) (((D(J,I,L),J=1,NCHND2),I=MCH,MCI),L=1,LV)
      IF(IBUT.LE.0) GO TO 48
      DO M1=M11,MLAST
        K1P = 1
        IF(LPOS.GT.0) THEN
          DO K1=MCH,MCI
            K2P = 1
            AVL=AVECT1(K1,M1)*AZ
            AVV=AVECT1(K1,M1)*AZP
            DO K2=NCH,NCI
              DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K2P,K1P,2)
              DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K2P,K1P,1)
              K2P=K2P+1
            ENDDO
            K1P=K1P+1
          ENDDO
        ELSE
          DO K1=NCH,NCI
            K2P = 1
            AVL=AVECT1(K1,M1)*AZ
            AVV=AVECT1(K1,M1)*AZP
            DO K2=MCH,MCI
              DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K1P,K2P,2)
              DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K1P,K2P,1)
              K2P=K2P+1
            ENDDO
            K1P=K1P+1
          ENDDO
        ENDIF
      ENDDO
   48 CONTINUE
      MCH=MNP2D1+1
      MCI=MNP2D1+NCHND1
      READ(LTAPE) (((D(I,J,L),J=1,NCHND2),I=1,NCHND1),L=1,LV)
      IF(IBUT.LE.0) GO TO 1000
      DO M1=M11,MLAST
        K1P = 1
        IF(LPOS.GT.0) THEN
          DO K1=MCH,MCI
            K2P = 1
            AVL=AVECT1(K1,M1)*AZ
            AVV=AVECT1(K1,M1)*AZP
            DO K2=NCH,NCI
              DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K1P,K2P,2)
              DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K1P,K2P,1)
              K2P=K2P+1
            ENDDO
            K1P=K1P+1
          ENDDO
        ELSE
          DO K1=NCH,NCI
            K2P = 1
            AVL=AVECT1(K1,M1)*AZ
            AVV=AVECT1(K1,M1)*AZP
            DO K2=MCH,MCI
              DVECTV(K2,M1)=DVECTV(K2,M1)+AVV*D(K2P,K1P,2)
              DVECTL(K2,M1)=DVECTL(K2,M1)+AVL*D(K2P,K1P,1)
              K2P=K2P+1
            ENDDO
            K1P=K1P+1
          ENDDO
        ENDIF
      ENDDO
C
C-----READ ANGULAR COEFFICIENTS
 1000 CONTINUE
      READ(LTAPE) MAXM1,(C(M),M=1,MAXM1)
      IF(LPOS.GT.0) THEN
        READ(LTAPE) ((A(J,I,1),J=1,NCHND1),I=1,NCHND2),
     &    (((B(J,I,L),J=1,NCHND1),I=1,NCHND2),L=1,LV)
        IF(BRDV)READ(LTAPE,ERR=70,END=80)            !BP VEL. ARRAY
     &    ((A(J,I,2),J=1,NCHND1),I=1,NCHND2)
      ELSE
        READ(LTAPE) ((A(I,J,1),J=1,NCHND1),I=1,NCHND2),
     &    (((B(I,J,L),J=1,NCHND1),I=1,NCHND2),L=1,LV)
        IF(BRDV)READ(LTAPE,ERR=70,END=80)            !BP VEL. ARRAY
     &    ((A(I,J,2),J=1,NCHND1),I=1,NCHND2)
      ENDIF
      GO TO 85
   70 BACKSPACE (LTAPE)
   80 BRDV=.FALSE.
   85 IF(DOLD)READ(LTAPE,END=90)
   90 LAST=LPOS
      CLOSE(LTAPE)
C
C --- END OF DIPOLE MATRIX.  TRANSPOSE PARAMETERS IF -VE LPOS.
C
      IF(LPOS.LT.0) THEN
        I=MNP2D1
        MNP2D1=MNP2D2
        MNP2D2=I
        I=NCHND1
        NCHND1=NCHND2
        NCHND2=I
      ENDIF
      IF(IBUT.GT.0) THEN
        K10=MNP2D1+NCHND1
        K20=MNP2D2+NCHND2
      ELSE
        K10=MNP2D1
        K20=MNP2D2
      ENDIF
      LRGLD1=IL1
      NPTYD1=IP1
      NSPND=IS1
      LRGLD2=IL2
      NPTYD2=IP2
      WRITE(4)MNP2D2,NCHND2,LRGLD2,NPTYD2,NSPND,
     &  MNP2D1,NCHND1,LRGLD1,NPTYD1,K20,K10,M11,MLAST
      WRITE(4) ((DVECTL(K2,M1),K2=1,K20),M1=M11,MLAST)
      WRITE(4) ((DVECTV(K2,M1),K2=1,K20),M1=M11,MLAST)
C
C-----WRITE ANGULAR COEFFICIENTS
      WRITE(4) ((A(J,I,1),J=1,NCHND1),I=1,NCHND2),
     &  ((B(J,I,1)*AZ,J=1,NCHND1),I=1,NCHND2),
     &  ((B(J,I,2)*AZP,J=1,NCHND1),I=1,NCHND2)
      IF(BRDV)WRITE(4) ((A(J,I,2),J=1,NCHND1),I=1,NCHND2)
      RETURN
C
   99 WRITE(6,*)' *** FATAL ERROR IN GETD: ',IS1,IL1,IP1,IS2,IL2,IP2
     &  ,LPOS,LAST
      WRITE(6,*)NSPND,LRGLD1,NPTYD1,NSPND,LRGLD2,NPTYD2
      STOP
C
  600 FORMAT(//1X,30(1H*)//' DIMENSION FOR MNP2 OR NCHF TOO'
     &,' SMALL'//  ' MNP2D1, NCHND1 = ',I5,', ',I5/
     &  ' MNP2D2, NCHND2 = ',I5,', ',I5//1X,30(1H*)//)
  601 FORMAT(//1X,30(1H*)//' MZCHF TOO SMALL FOR BUFFER'//
     &  ' NEED AT LEAST ',I4//1X,30(1H*)//)
C
      END
C
C***********************************************************************
C
      SUBROUTINE R1EDEP(M1,MNP2,NCHF)
C
C  READ INITIAL ENERGY DEPENDENT DATA
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'PARAM'
      PARAMETER (MNPEXT=MZMNP+MZCHF)
      COMMON/MISC/WBODE(MZPTS,-3:1),IPERT,MXE2,EMESH(MZMSH),BSTO
      COMMON/A1/AVECT1(MNPEXT,MZEST),E1(MZEST)
      COMMON/NRBPRT/IPERT1,IPERT2
C
      READ(1) E1(M1)
      READ(1) (AVECT1(K1,M1),K1=1,MNP2+NCHF)
      READ(1)
      READ(1)
      READ(1)
      READ(1)
      READ(1)
      IF(IPERT1.NE.1) GO TO 9
      READ(1)
      READ(1)
      READ(1)
C
    9 RETURN
      END
C
C*******************************************************************
C
      SUBROUTINE R1EIND(FILE1,M11,M12,M13,MNP2,NCHF)
C
C  READS INITIAL ENERGY INDEPENDENT DATA
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      CHARACTER*3 FILE1
C
      COMMON/MISC/WBODE(MZPTS,-3:1),IPERT,MXE2,EMESH(MZMSH),BSTO
      COMMON/NRBPRT/IPERT1,IPERT2
C
      OPEN(1,FILE=FILE1,STATUS='OLD',FORM='UNFORMATTED',ERR=90)
      REWIND(1)
      GOTO 6
   90 WRITE(6,696) FILE1
      CALL ABORTT(13)
C
C  READ E1-INDEPENDENT DATA
    6 READ(1)IS,IL,IP
      READ(1)MNP2,NCHF
            IF(MNP2.GT.MZMNP) THEN
             WRITE(6,613)MNP2
             CALL ABORTT(10)
            ENDIF
            IF(NCHF.GT.MZCHF) THEN
             WRITE(6,614)NCHF
             CALL ABORTT(10)
            ENDIF
      READ(1)
      READ(1)
      IF(IPERT1.EQ.1)READ(1)
      READ(1)MXE1
C
      IF(M11.GT.MXE1) THEN
        WRITE(6,505)M11,MXE1
C       CALL ABORTT(7)
      ENDIF
C
C  SKIP PRECEDING LEVELS; NREC HOLDS THE NUMBER OF RECORDS FOR A LEVEL
      M13=MIN(M12,MXE1)
      IF(MZSA1.GT.1.AND.M13.GT.MZSA1)THEN
        WRITE(6,506)M13
      ENDIF
      NREC=7               !7 NOT 6 - NRB
      IF(IPERT1.EQ.1) NREC=NREC+3
      M1SKIP=(M11-1)*NREC
      DO I=1,M1SKIP
        READ(1) DUMMY
      ENDDO
C
      RETURN
C
  505 FORMAT(//'  BOUND LEVEL REQUESTED',I4,10X,
     *       'NUMBER OF LEVELS FOR THIS SLPI',I4)
  506 FORMAT(//' ****DIMENSION EXCEEDED, RESET MZSA1=1 **OR**'
     X,' TO AT LEAST',I5,' FOR MAXIMUM EFFICIENCY')
  613 FORMAT(//'    READS MNP2 = ',I4,' WHICH IS LARGER THAN ',
     1 'MAXIMUM VALUE OF MZMNP ALLOWED BY DIMENSIONS'//)
  614 FORMAT(//'    READS NCHF = ',I4,' WHICH IS LARGER THAN MAXIMUM ',
     *'VALUE OF MZCHF (LESS 1 FOR FINAL STATE) ALLOWED BY DIMENSIONS'//)
  696 FORMAT(/' *** CANNOT OPEN FILE ',A/)
      END
C
C**********************************************************************
C
C
      SUBROUTINE RBF00
C
C  READ DIRECTORY FILES ON B AND F DATASETS
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
      COMMON/LIST1/KSLP1,MSLP1(100)
      COMMON/LIST2/KSLP2,MSLP2(100)
      COMMON/MISC/WBODE(MZPTS,-3:1),IPERT,MXE2,EMESH(MZMSH),BSTO
      COMMON/CPOINT/KP0,KP1,KP2,KPM,RZERO,RONE,RTWO,H
      COMMON/SCALE/AZ,AZP,AZ2,AZP2,K10,K20
      COMMON/CTRLBF/IPRINT,IBUT
      COMMON /TARG/ ENAT(MZTAR),NCONAT(MZTAR),NZED,NELC,NAST
      COMMON/NRBPRT/IPERT1,IPERT2
C
C  INITIAL BOUND STATE DATA
      OPEN(1,FILE='B00',STATUS='OLD',FORM='UNFORMATTED',ERR=9)
      REWIND(1)
      READ(1)NZED,NELC
      READ(1)KP2
C
C  CHECK DIMENSION FOR KP2
      IF(KP2.GT.MZPTS)THEN
        WRITE(6,600)
        STOP
      ENDIF
C
      READ(1)RZERO,H
      READ(1)(WBODE(IR,0),IR=1,KP2)
      READ(1)IPERT1
      IF(IPERT1.EQ.0)WRITE(6,500)
      WRITE(6,506)NZED,NELC
      IF(IPRINT.GT.0)WRITE(6,503)RZERO,H,KP2
      IF(IPRINT.GT.0)WRITE(6,501)
      KSLP1=0
C
C  AND LIST OF SLPI CASES
    5 READ(1,END=901)IS,IL,IP
      IF(IL.GE.0)THEN
        KSLP1=KSLP1+1
        MSLP1(KSLP1)=(IS*100+IL)*100+IP
        IF(IPRINT.GT.0)WRITE(6,502)KSLP1,IS,IL,IP
        GOTO 5
      ENDIF
  901 CLOSE(1)
C
C  DATA FOR SCALING
      AZ=MAX(NZED-NELC,1)
      AZP=1./AZ
      AZ2=AZ*AZ
      AZP2=AZP*AZP
C
      RTWO=RZERO+H*(KP2-1)
      R=RZERO-H
      DO 3 K=1,KP2
      R=R+H
      AR=1./R
      AR2=AR*AR
      AR3=AR2*AR
      WBODE(K,-3)=WBODE(K,0)*AR3
      WBODE(K,-2)=WBODE(K,0)*AR2
    3 WBODE(K,1)=R*WBODE(K,0)
C
C  FINAL FREE STATE DATA
      OPEN(2,FILE='F00',STATUS='OLD',FORM='UNFORMATTED',ERR=10)
      REWIND(2)
      READ(2)NZED2,NELC2
      READ(2)NAST,(ENAT(I),I=1,NAST)
      READ(2)KP22
      READ(2)RZERO2,H2
      READ(2)WBODE2
      READ(2)IPERT2
      IF(NZED2.NE.NZED.OR.
     1   NELC2.NE.NELC.OR.
     2   ABS(RZERO2-RZERO).GT.1.E-10.OR.
     3   KP22.NE.KP2.OR.
     4   ABS(H2-H).GT.1.E-10) THEN
        WRITE(6,504)NZED,NZED2,NELC,NELC2,RZERO,RZERO2,KP2,KP22,H,H2
        CALL ABORTT(1)
      ENDIF
      IF(IPERT2.NE.IPERT1) THEN
        WRITE(6,507)IPERT1,IPERT2
        IPERT=0
      ELSE
        IPERT=IPERT1
      ENDIF
      READ(2)MXE2
C
C  CHECK DIMENSION FOR MXE
      IF(MXE2.GT.MZMSH)THEN
        WRITE(6,610)
        STOP
      ENDIF
C
      READ(2)(EMESH(I),I=1,MXE2)
      READ(2)BSTO
C
C  UN-SCALE TARGET ENERGIES TO BE WRITTEN TO ARCHIVE FILE
      DO 4 I=1,NAST
    4 ENAT(I)=AZ2*ENAT(I)
      IF(IPRINT.GT.0)WRITE(6,505)
      KSLP2=0
C
C  AND LIST OF SLPI CASES
    6 READ(2,END=902)IS,IL,IP
        KSLP2=KSLP2+1
        MSLP2(KSLP2)=(IS*100+IL)*100+IP
        IF(IPRINT.GT.0)WRITE(6,502)KSLP2,IS,IL,IP
        GOTO 6
  902 CLOSE(2)
C
      RETURN
C
    9 CALL ABORTT(12)
   10 CALL ABORTT(15)
C
  500 FORMAT(17X,'(CALCULATION WITHOUT MUTIPOLE POTENTIALS)')
  501 FORMAT(//10X,'FROM STGB DATASET'/10X,'KSLP   IS   IL   IP')
  502 FORMAT(10X,I3,4X,I2,2I5)
  503 FORMAT(/7X,'RZERO =',F9.4/7X,'H   =',F8.4/7X,'KP2 =',I5/)
  504 FORMAT(/30X,'B',20X,'F'/10X,'NZED',2I20/10X,'NELC',2I20/
     1     10X,'RZERO',2F20.4/10X,'KP2',2I20/10X,'H',2F20.4/)
  505 FORMAT(//10X,'FROM STGF DATASET'/10X,'KSLP   IS   IL   IP')
  506 FORMAT(//14X,'NUCLEAR CHARGE =',I3,
     *  ', NUMBER OF TARGET ELECTRONS =',I3/14X,52('-')//)
  507 FORMAT(//'*WARNING* ','STGB',5X,'STGF'/5X,'IPERT',I4,5X,I4/
     X10X,'PERTURBATIONS SWITCHED-OFF'//)
  600 FORMAT(///10X,'KP2 =',I6,
     *  '  IS GREATER THAN MZPTS'///)
  610 FORMAT(///10X,'MXE2 =',I6,
     *  ' IS GREATER THAN MZMSH'///)
C
      END
C**********************************************************************
C
      SUBROUTINE RD00(ITAPE,IPRINT,IBUT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
C  READ DIRECTORY FILE ON D DATASET
C  PUT S,L,PI COMBINATIONS INTO /LIST0/
C
      PARAMETER (MXTRAN=99)
      COMMON/LIST0/KOUNT,MSLPL(MXTRAN),MSLPR(MXTRAN),LAST,LTAPE,LBUT
C
      LTAPE=ITAPE
      LBUT=IBUT
      LAST=0
      KK=0
      OPEN(ITAPE,FILE='D00',STATUS='OLD',FORM='UNFORMATTED',ERR=4)
      GO TO 5
    4 PRINT *,' FILE D00 NOT FOUND, LOOKING FOR DATASET D:'
      OPEN(ITAPE,FILE='D',STATUS='OLD',FORM='UNFORMATTED',ERR=8)
    5 READ(ITAPE,END=8) KOUNT
      IF(IPRINT.GT.0)WRITE(6,500)
      DO 1 K=1,KOUNT
       READ(ITAPE,END=8) IS1,IL1,IP1,IS2,IL2,IP2
       IF(IPRINT.GT.0) WRITE(6,501)K,IS1,IL1,IP1,IS2,IL2,IP2
       IF(KOUNT.GT.MXTRAN) GO TO 1
       MSLPL(K)=(IS1*100+IL1)*100+IP1
       MSLPR(K)=(IS2*100+IL2)*100+IP2
       KK=K
    1 CONTINUE
      READ(ITAPE,END=7)
    7 IF(KOUNT.LE.MXTRAN) GO TO 9
C
    8 WRITE(6,*)' *** WARNING IN RD00 *** ONLY ',KK,
     *          ' DIPOLE MATRICES READ FROM D FILE'
      KOUNT=KK
    9 CLOSE(ITAPE)
C
      RETURN
  500 FORMAT(//10X,'FROM D DATASET'//10X,'K',8X,'IS1  IL1  IP1',
     *       6X,'IS2  IL2  IP2'/)
  501 FORMAT(2(8X,I3),2I5,6X,I3,2I5)
      END
C
C**********************************************************************
C
      SUBROUTINE RD5L1(IS1,IL1,IP1,M11,M12)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
C  READ INITIAL STATE SPECIFICATION FROM UNIT 5
C  VALID INPUT IS EITHER IS1,IL1,IP1,M11,M12 OR EOF
C
      COMMON/FLAG0/ALL1,ALL2,RED,MORE1,MORE2,OK,EOF,KKP,CMPLT
      LOGICAL ALL1,ALL2,RED,MORE1,MORE2,OK,EOF,KKP,CMPLT
      CHARACTER CARD*80
C
      READ(5,*,END=1,ERR=2)IS1,IL1,IP1,M11,M12
      IF(M11.EQ.0) GO TO 3
      IF(M12.LT.M11) M12=M11
      GO TO 4
C
    1 EOF=.TRUE.
    3 M11=1
      M12=9999
    4 RETURN
C
    2 BACKSPACE 5
      READ(5,*)CARD
      WRITE(6,*)' *** THE FOLLOWING INPUT IS ENCOUNTERED WHEN '
      WRITE(6,*)'     AN INITIAL STATE SPECIFICATION IS EXPECTED:'
      WRITE(6,'(A)')CARD
      CALL ABORTT(5)
      END
C
C*******************************************************************
C
      SUBROUTINE RD5L2
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INCLUDE 'PARAM'
C
C  READ UNIT 5 FOR SECOND SLPI LIST, OR SET ALL2 FLAG
C
      COMMON/SLPI2/IS2V(3),IL2V(3),IP2V(3),KUT
      COMMON/FLAG0/ALL1,ALL2,RED,MORE1,MORE2,OK,EOF,KKP,CMPLT
      LOGICAL ALL1,ALL2,RED,MORE1,MORE2,OK,EOF,KKP,CMPLT
C
      KUT=0
      DO 2 I=1,4
       READ(5,*,END=4) IS,IL,IP
       IF(I.GT.3) GO TO 6
       IP2V(I)=MOD(IP,2)
       IL2V(I)=IL
       IS2V(I)=IS
       IF(IL.EQ.-1) GO TO 5
       IF(ALL2) GO TO 8
CW       .TRUE. IN FLAG-SETTING FIRST CALL FROM MAIN.
    2  KUT=I
      GO TO 8
    4 EOF=.TRUE.
    5 IF(KUT.EQ.0) GO TO 9
      GO TO 8
    6 IF(IL.EQ.-1) GO TO 8
        WRITE(6,500)IS2V(3),IL2V(3),IP2V(3)
        BACKSPACE 5
    8 ALL2=.FALSE.
    9 RETURN
  500 FORMAT(/' UNIT 5 INPUT: TERMINATOR EXPECTED AFTER IS2,IL2,IP2=',
     1         3I2,' NEXT LINE SAVED'/)
      END