C
C     PROGRAM BASIS
C
C     PURPOSE
C        EXTRACT GAUSSIAN BASIS SETS FROM THE BASIS SET FILES, IN A
C        FORMAT MONSTERGAUSS CAN USE DIRECTLY (AS GENERAL BASIS INPUT).
C
C     ALL REQUIRED DATA IS REQUESTED INTERACTIVELY BY THE PROGRAM.
C
C     NOTE: THE DIRECTORY WHERE THE BASIS SET FILES ARE LOCATED IS
C           SET BY VARIABLE 'ZDIR' BELOW. IT IS CURRENTLY SET TO
C           '~mgauss/basis'.
C
C     NOTE: TO DUMP THE BASIS SET EXACTLY AS READ FROM THE BASIS SET
C           FILES, RE-COMPILE WITH THE DEBUG OPTION SET, AND ASSIGN LFC 6
C           TO THE PRINTER (IF DESIRED).
C
      PROGRAM BASIS
C
      COMMON DISTP(4,30),NSPDF(4),MPRINT,NTOTAL,
     1 NLINE(80),NCOEF(80,60)
C
      DIMENSION LINE(72),NUM(10)
      DIMENSION IALPHA(4)
C
      INTEGER DISTP
C
      CHARACTER*1 STAR,COMMA,DOT,BLANK,NUM,LINE,NLINE,SLASH,R
      CHARACTER*1 MS,ME,MP,NEG,E,NCOEF,IALPHA
      CHARACTER ZFILE*16, ZFILEOUT*60, ZLINE*72,
     1 ZDIR*40
C
      EQUIVALENCE (ZLINE,LINE(1))
C
      DATA NUM/'1','2','3','4','5','6','7','8','9','0'/,R/'R'/
      DATA STAR/'*'/,COMMA/','/,DOT/'.'/,BLANK/' '/,SLASH/'/'/
      DATA MS/'S'/,ME/'='/,MP/'P'/,NEG/'-'/,E/'E'/
      DATA IALPHA/'A','B','C','D'/
      DATA ZDIR/'//alchemy/u0/mgauss/basis/'/
C
 1010 FORMAT (A72)
 1020 FORMAT (/'UNABLE TO OPEN FILE ',A,', ISTAT =',I4)
 1030 FORMAT (/'UNABLE TO OPEN FILE ',A,A,', ISTAT =',I4)
 1040 FORMAT (/'Basis set extraction program'//
     1 /'Enter file name for basis set output: ',$)
 1060 FORMAT (/'Enter atomic number (0 to stop): ',$)
 1070 FORMAT (/'For a basis set numbered 20.3.2, the major table',
     1 ' number is 3'/'and the minor table number is 2.'/
     2 'The program will give back all minor tables for a given',
     3 ' major table number.'/
     4 'Enter major table number: ',$)
 1080 FORMAT (I10)
 1090 FORMAT (A)
 1100 FORMAT (/'THERE IS A COMMA MISSING IN THE LAST TABLE')
 1110 FORMAT (/'THE ATOM OR TABLE SPECIFIED NOT FOUND IN FILE ',A16)
 1120 FORMAT (/'UNEXPECTED BLANK LINE AT NNDX =',I4,' I =',I4)
 1130 FORMAT (/'UNEXPECTED END OF FILE FOUND IN FILE ',A16)
 1140 FORMAT (/'I/O ERROR IN FILE ',A16)
C
C     GET OUTPUT FILE NAME.
C
      WRITE (6,1040)
      READ (5,1090,END=990) ZFILEOUT
      OPEN (UNIT=2, ERR=900, FILE=ZFILEOUT,
     1 FORM='FORMATTED', IOSTAT=ISTAT, STATUS='UNKNOWN')
C
C     LOOP OVER ALL REQUESTED TABLES.
C
    1 NPOS=1
      MPRINT=0
      DO 4 K=1,4
    4 NSPDF(K)=0
      IC=1
      DO 10 K=1,80
   10 NLINE(K)=BLANK
      J=2
C
C     GET ATOM AND TABLE NUMBER.
C
      WRITE (6,1060)
      READ (5,1080,END=920) NATOM
      IF (NATOM .LE. 0) GO TO 920
      WRITE (6,1070)
      READ (5,1080,END=920) NTABL
      ZFILE = 'basis1.dat'
      IF (NATOM .GT. 2) ZFILE = 'basis2a.dat'
      IF (NATOM .GT. 6) ZFILE = 'basis2b.dat'
      IF (NATOM .GT. 10) ZFILE = 'basis3.dat'
      IF (NATOM .GT. 18) ZFILE = 'basis4a.dat'
      IF (NATOM .GT. 25) ZFILE = 'basis4b.dat'
      IF (NATOM .GT. 36) ZFILE = 'basis5.dat'
      IF (NATOM .GT. 54) ZFILE = 'basis6.dat'
      CLOSE (UNIT=1)
      LZDIR = INDEX (ZDIR, ' ')
      OPEN (UNIT=1, ERR=910, FILE=ZDIR(1:LZDIR-1)//ZFILE,
     1 FORM='FORMATTED', IOSTAT=ISTAT, STATUS='READONLY')
C
      M9=NATOM
      IF (M9 .LT. 10) GO TO 13
      M9=NATOM/10
      M8=NATOM-10*M9
      IF (M8 .EQ. 0) M8=10
C
   13 READ (1,1010,END=930,ERR=970) ZLINE
      IF (LINE(1) .NE. STAR) GO TO 13
      IF (LINE(2) .NE. NUM(M9)) GO TO 13
      IF (NATOM .LT. 10) GO TO 15
      IF (LINE(3) .NE. NUM(M8)) GO TO 13
   15 IF (NPOS .EQ. NTABL) GO TO 20
   18 READ (1,1010,END=930,ERR=970) ZLINE
      IF (LINE(1) .NE. STAR) GO TO 18
      NPOS=NPOS + 1
      GO TO 15
C
 20   NLINE(1)=NUM(M9)
      IF (NATOM .LT. 10) GO TO 22
      NLINE(2)=NUM(M8)
      J=3
 22   NLINE(J)=DOT
      J=J+1
      N8=NTABL
      IF (NTABL .LT. 10) GO TO 25
      N9=NTABL/10
      N8=NTABL - 10*N9
      IF (N8 .EQ. 0) N8=10
      NLINE(J)=NUM(N9)
      J=J + 1
 25   NLINE(J)=NUM(N8)
      NLINE(J+1)=DOT
      NLINE(J+2)=NUM(1)
      JC=J+2
      ICON=0
D     WRITE (6,1010) ZLINE
C
C     FOR THE NUMBER OF S/P/D/F CONTRACTIONS.
C
      READ (1,1010,END=960,ERR=970) ZLINE
D     WRITE (6,1010) ZLINE
      II=0
C
      DO 76 I=1,72
      IF (LINE(I) .EQ. BLANK) GO TO 76
      II=II+1
      LINE(II)=LINE(I)
 76   CONTINUE
C
      ISEQP=0
      IF (LINE(3) .EQ. NEG) ISEQP=3
      IF (LINE(4) .EQ. NEG) ISEQP=4
      IF (ISEQP .LT. 1) GO TO 73
      II=II-1
C
      DO 71 LK1=ISEQP,II
 71   LINE(LK1)=LINE(LK1+1)
C
      LINE(II+1)=BLANK
 73   I=1
      INDX=1
 77   NNUM=0
      IF (LINE(I) .EQ. NUM(10)) GO TO 79
 78   NNUM=NNUM+1
      IF (LINE(I) .NE. NUM(NNUM)) GO TO 78
 79   IF (LINE(I+1).EQ.COMMA .OR. I.EQ.II) GO TO 82
      NNUB=0
      IF (LINE(I+1) .EQ. NUM(10)) GO TO 81
 80   NNUB=NNUB+1
      IF (LINE(I+1) .NE. NUM(NNUB)) GO TO 80
 81   NNUM=NNUM*10 + NNUB
      I=I+1
 82   NSPDF(INDX)=NNUM
      I=I+2
      INDX=INDX+1
      IF (INDX .LT. 5) GO TO 77
C
C     THIS READS THE REFERENCES.
C
      J=12
      READ (1,1010,END=960,ERR=970) ZLINE
D     WRITE (6,1010) ZLINE
      NLINE(10)=LINE(3)
      NLINE(11)=LINE(4)
      IF (LINE(5) .EQ. COMMA) GO TO 84
      NLINE(12)=LINE(5)
      J=J+1
 84   IF (LINE(J-6) .NE. LINE(3)) GO TO 86
      NLINE(J)=SLASH
      JD=J+1
      NLINE(J+1)=LINE(3)
      NLINE(J+2)=LINE(J-5)
      IF (LINE(J-4) .EQ. COMMA) GO TO 85
      NLINE(J+3)=LINE(J-4)
      J=J+1
 85   L=J-3
      GO TO 87
C
 86   L=J-4
C
C     SETS CONDITION FOR CONTINUING TABLES.
C
 87   IF (LINE(L) .EQ. NUM(10)) GO TO 89
 88   ICON=ICON+1
      IF (LINE(L) .NE. NUM(ICON)) GO TO 88
C
C     THIS WRITES ANY COMMENTS.
C
 89   IF (LINE(1) .EQ. NUM(10)) GO TO 120
      READ (1,1010,END=960,ERR=970) ZLINE
      WRITE (6,1010) ZLINE
C
C     THIS FINDS THE TOTAL S/P/D/F AND THE COEFFICIENTS FOR EACH BASIS.
C
 120  NTOTAL=0
      NNDX=0
C
      DO 125 KINKY=1,80
      DO 123 KUKY=1,60
 123  NCOEF(KINKY,KUKY)=BLANK
 125  CONTINUE
C
      DO 155 NSTP=1,4
      IF (NSPDF(NSTP) .EQ. 0) GO TO 155
      READ (1,1010,END=960,ERR=970) ZLINE
D     WRITE (6,1010) ZLINE
      II=0
C
      DO 130 I=1,72
      IF (LINE(I) .EQ. BLANK) GO TO 130
      II=II+1
      LINE(II)=LINE(I)
 130  CONTINUE
C
      I=1
      INDX=1
 132  NNUM=0
      IF (LINE(I) .EQ. NUM(10)) GO TO 136
 134  NNUM=NNUM + 1
      IF (LINE(I) .NE. NUM(NNUM)) GO TO 134
 136  IF (LINE(I+1).EQ.COMMA .OR. I.EQ.II) GO TO 142
      NNUB=0
      IF (LINE(I+1) .EQ. NUM(10)) GO TO 140
 138  NNUB=NNUB + 1
      IF (LINE(I+1) .NE. NUM(NNUB)) GO TO 138
 140  NNUM=NNUM*10 + NNUB
      LINE(I+1)=IALPHA(NNUM-9)
      I=I+1
 142  DISTP(NSTP,INDX)=NNUM
      I=I+2
      INDX=INDX + 1
      IF (I .LE. II) GO TO 132
C
C     THIS IS FOR THE EXPONENTS.
C
      J=INDX-1
C
      DO 144 I=1,J
 144  NTOTAL=NTOTAL + DISTP(NSTP,I)
C
      J=1
      NDOT=0
      NNDX=NNDX+1
 863  READ (1,1010,END=960,ERR=970) ZLINE
D     WRITE (6,1010) ZLINE
      II=0
C
      DO 864 I=1,72
      IF (LINE(I) .EQ. BLANK) GO TO 864
      II=II+1
      LINE(II)=LINE(I)
 864  CONTINUE
C
      IF (II .EQ. 0) GO TO 863
      I=1
 865  IF (LINE(I) .EQ. COMMA) GO TO 868
      IF (LINE(I) .NE. DOT) GO TO 867
      NDOT=NDOT+1
      IF (NDOT .GT. 1) GO TO 940
 867  NCOEF(NNDX,J)=LINE(I)
      J=J+1
      I=I+1
      IF (I .LE. II) GO TO 865
      IF (NNDX .GE. NTOTAL) GO TO 155
      NDOT=0
      I=I+1
      J=1
      NNDX=NNDX+1
      GO TO 863
C
 868  NDOT=0
      I=I+1
      J=1
      NNDX=NNDX+1
      IF (I .LE. II) GO TO 865
      IF (NNDX .LE. NTOTAL) GO TO 863
 155  CONTINUE
      IF (ICON .NE. 0) GO TO 161
C
C     THIS IS FOR ICON=0 WITH ALL COEFFICIENTS AT 1.0.
C
      DO 154 NSTP=1,4
      IF (NSPDF(NSTP) .EQ. 0) GO TO 154
      KML=DISTP(NSTP,1)
      NSPDF(NSTP)=KML
      IF (KML .EQ. 0) GO TO 154
      DO 153 LMP=1,KML
 153  DISTP(NSTP,LMP)=1
 154  CONTINUE
C
      DO 160 I=1,NTOTAL
      NCOEF(I,21)=NUM(1)
      NCOEF(I,22)=DOT
      NCOEF(I,23)=NUM(10)
 160  CONTINUE
C
      IF (ISEQP .EQ. 0) GO TO 172
      N1=NSPDF(1)+1
      N2=NTOTAL-NSPDF(3)-NSPDF(4)
C
      DO 158 I=N1,N2
      NCOEF(I,41)=NUM(1)
      NCOEF(I,42)=DOT
  158 NCOEF(I,43)=NUM(10)
C
      MPRINT=1
      GO TO 172
C
C     FOR THE COEFFICIENTS OF ICON.GT.0.
C
 161  MEQP=21
      NNDX=1
 162  J=MEQP
      NDOT=0
 163  READ (1,1010,END=960,ERR=970) ZLINE
D     WRITE (6,1010) ZLINE
      II=0
C
      DO 164 I=1,72
      IF (LINE(I) .EQ. BLANK) GO TO 164
      II=II+1
      LINE(II)=LINE(I)
 164  CONTINUE
C
      IF (II .EQ. 0) GO TO 950
      I=1
 165  IF (LINE(I) .EQ. COMMA) GO TO 168
      IF (LINE(I) .NE. DOT) GO TO 167
      NDOT=NDOT+1
      IF (NDOT .GT. 1) GO TO 940
 167  NCOEF(NNDX,J)=LINE(I)
      J=J+1
      I=I+1
      IF (I .LE. II) GO TO 165
      IF (NNDX .GE. NTOTAL) GO TO 171
      NDOT=0
      I=I+1
      J=MEQP
      NNDX=NNDX+1
      GO TO 163
C
 168  NDOT=0
      I=I+1
      J=MEQP
      NNDX=NNDX+1
      IF (I .LE. II) GO TO 165
      IF (NNDX .LE. NTOTAL) GO TO 163
 171  IF (ISEQP .LT. 1) GO TO 172
      MEQP=41
      MPRINT=1
      ISEQP=0
      NNDX=DISTP(1,1)+1
      GO TO 162
C
  172 IATOM=0
 220  IATOM=IATOM+1
      IF (NLINE(1) .NE. NUM(IATOM)) GO TO 220
      IF (NLINE(2) .EQ. DOT) GO TO 400
      NNUB=0
      IF (NLINE(2) .EQ. NUM(10)) GO TO 225
 222  NNUB=NNUB+1
      IF (NLINE(2) .NE. NUM(NNUB)) GO TO 222
 225  IATOM=IATOM*10+NNUB
C
C     WRITE OUT THE TABLE.
C
  400 CALL WRTBASIS
      IF (ICON .LE. IC) GO TO 1
C
C     THIS IS FOR CONTINUING TABLES.
C     ******************************
C
      IC=IC+1
      IF (IC .GT. 9) GO TO 275
      NLINE(JC)=NUM(IC)
C
 275  READ (1,1010,END=960,ERR=970) ZLINE
D     WRITE (6,1010) ZLINE
      NLINE(JD)=LINE(3)
      NLINE(JD+1)=LINE(4)
      LOV1=JD+2
C
      DO 270 LOV=LOV1,80
 270  NLINE(LOV)=BLANK
C
      IF (LINE(5) .EQ. BLANK) GO TO 280
      NLINE(JD+2)=LINE(5)
 280  IF (LINE(1) .EQ. NUM(10)) GO TO 281
      READ (1,1010,END=960,ERR=970) ZLINE
D     WRITE (6,1010) ZLINE
C
C     FOR THE NUMBER OF S/P/D/F CONTRACTIONS.
C
 281  READ (1,1010,END=960,ERR=970) ZLINE
D     WRITE (6,1010) ZLINE
      II=0
C
      DO 300 I=1,72
      IF (LINE(I) .EQ. BLANK) GO TO 300
      II=II+1
      LINE(II)=LINE(I)
 300  CONTINUE
C
      I=1
      INDX=1
 302  NNUM=0
      IF (LINE(I) .EQ. NUM(10)) GO TO 306
 304  NNUM=NNUM+1
      IF (LINE(I) .NE. NUM(NNUM)) GO TO 304
 306  IF (LINE(I+1).EQ.COMMA .OR. I.EQ.II) GO TO 312
      NNUB=0
      IF (LINE(I+1) .EQ. NUM(10)) GO TO 310
 308  NNUB=NNUB+1
      IF (LINE(I+1) .NE. NUM(NNUB)) GO TO 308
 310  NNUM=NNUM*10 + NNUB
      I=I+1
 312  NSPDF(INDX)=NNUM
      I=I+2
      INDX=INDX+1
      IF (INDX .LT. 5) GO TO 302
C
C     THIS FINDS THE TOTAL S/P/D/F AND THE COEFFICIENTS FOR EACH BASIS.
C
      NNDX=0
      ITOT=0
      MEQP=21
C
      DO 325 KINKY=1,NTOTAL
      DO 323 KUKY=20,60
 323  NCOEF(KINKY,KUKY)=BLANK
 325  CONTINUE
C
      DO 355 NSTP=1,4
      IF (NSPDF(NSTP) .EQ. 0) GO TO 355
      READ (1,1010,END=960,ERR=970) ZLINE
D     WRITE (6,1010) ZLINE
      II=0
C
      DO 330 I=1,72
      IF (LINE(I) .EQ. BLANK) GO TO 330
      II=II+1
      LINE(II)=LINE(I)
 330  CONTINUE
C
      I=1
      INDX=1
 332  NNUM=0
      IF (LINE(I) .EQ. NUM(10)) GO TO 336
 334  NNUM=NNUM + 1
      IF (LINE(I) .NE. NUM(NNUM)) GO TO 334
 336  IF (LINE(I+1).EQ.COMMA .OR. I.EQ.II) GO TO 342
      NNUB=0
      IF (LINE(I+1) .EQ. NUM(10)) GO TO 340
 338  NNUB=NNUB + 1
      IF (LINE(I+1) .NE. NUM(NNUB)) GO TO 338
 340  NNUM=NNUM*10 + NNUB
      I=I+1
 342  DISTP(NSTP,INDX)=NNUM
      I=I+2
      INDX=INDX + 1
      IF (I .LE. II) GO TO 332
C
C     THIS IS FOR THE COEFFICIENTS.
C
      NSPIN=NSPDF(NSTP)
C
      DO 350 IMPX=1,NSPIN
 350  ITOT=ITOT + DISTP(NSTP,IMPX)
C
      NNDX=NNDX+1
      J=MEQP
      NDOT=0
 363  READ (1,1010,END=960,ERR=970) ZLINE
D     WRITE (6,1010) ZLINE
      II=0
C
      DO 364 I=1,72
      IF (LINE(I) .EQ. BLANK) GO TO 364
      II=II+1
      LINE(II)=LINE(I)
 364  CONTINUE
C
      IF (II .EQ. 0) GO TO 950
      I=1
 365  IF (LINE(I) .EQ. COMMA) GO TO 367
      IF (LINE(I) .EQ. BLANK) GO TO 355
      IF (LINE(I) .NE. DOT) GO TO 366
      NDOT=NDOT+1
      IF (NDOT .GT. 1) GO TO 940
 366  NCOEF(NNDX,J)=LINE(I)
      J=J+1
      I=I+1
      IF (I .LE. II) GO TO 365
      IF (NNDX .GE. ITOT) GO TO 355
      NDOT=0
      I=I+1
      J=MEQP
      NNDX=NNDX+1
      GO TO 363
C
 367  NDOT=0
      I=I+1
      J=MEQP
      NNDX=NNDX+1
      IF (I .LE. II) GO TO 365
      IF (NNDX .LE. ITOT) GO TO 363
 355  CONTINUE
C
      GO TO 172
C
C     ERROR FOUND.
C
C     UNABLE TO OPEN OUTPUT FILE.
  900 WRITE (6,1020) ZFILEOUT, ISTAT
      STOP
C     UNABLE TO OPEN BASIS SET FILE.
  910 WRITE (6,1030) ZDIR, ZFILE, ISTAT
C     END OF INPUT - CLOSE OUTPUT FILE.
  920 ENDFILE 2
      CLOSE (UNIT=2)
      STOP
C     ATOM/TABLE NOT FOUND IN THE FILE.
  930 WRITE (6,1110) ZFILE
      GO TO 1
C     MISSING COMMA IN THE LAST TABLE.
  940 WRITE (6,1100)
      GO TO 920
C     UNEXPECTED BLANK LINE FOUND.
  950 WRITE (6,1120) NNDX, I
      GO TO 920
C     END-OF-FILE ON BASIS SET FILE.
  960 WRITE (6,1130) ZFILE
      GO TO 1
C     I/O ERROR IN BASIS SET FILE.
  970 WRITE (6,1140) ZFILE
      GO TO 1
C     STOP.
  990 STOP
      END
      SUBROUTINE WRTBASIS
C
C     WRITE THE BASIS SET IN MONSTERGAUSS FORMAT TO LFC 2.
C
      COMMON DISTP(4,30),NSPDF(4),MPRINT,NTOTAL,
     1 NLINE(80),NCOEF(80,60)
C
      INTEGER DISTP
C
      CHARACTER*1 NLINE,NCOEF,DOT
C
      DATA DOT/'.'/
C
 1040 FORMAT ('BASIS SET TABLE ',9A1,' FROM REFERENCE ',11A1)
 1110 FORMAT (4X,I2,'S  1.0')
 1120 FORMAT (40A1)
 1130 FORMAT (4X,I2,'P  1.0')
 1140 FORMAT (20A1,'0.0',17X,20A1)
 1150 FORMAT (4X,I2,'D  1.0')
 1160 FORMAT (4X,I2,'F  1.0')
 1180 FORMAT ('****')
 1200 FORMAT (4X,I2,'SP 1.0')
 1210 FORMAT (60A1)
C
C     TITLE.
C
      WRITE (2,1040) (NLINE(I),I=1,9), (NLINE(J),J=10,20)
      IF (MPRINT .EQ. 1) GO TO 460
      INDX=0
      ISTP=1
 179  IF (NSPDF(ISTP) .EQ. 0)  GO TO 210
      I=1
 180  GO TO(181,182,183,184),ISTP
 181  WRITE (2,1110) I
      GO TO 185
 182  WRITE (2,1130) I
      GO TO 185
 183  WRITE (2,1150) I
      GO TO 185
 184  WRITE (2,1160) I
 185  J=1
 186  INDX=INDX+1
C
      GO TO(191,192,191,192),ISTP
 191  WRITE (2,1120) (NCOEF(INDX,K),K=1,40)
      GO TO 198
C
 192  WRITE (2,1140) (NCOEF(INDX,K),K=1,20), (NCOEF(INDX,L),L=21,40)
C
 198  J=J+1
      IF (J .LE. DISTP(ISTP,I)) GO TO 186
      I=I+1
      IF (I .LE. NSPDF(ISTP)) GO TO 180
 210  ISTP=ISTP+1
      IF (ISTP .LT. 5) GO TO 179
      WRITE (2,1180)
      RETURN
C
C     WRITE S=P BASIS SET.
C
 460  MK=1
      INDX=0
C
C     S-TYPE.
C
  461 WRITE (2,1110) MK
      J=1
 462  INDX=INDX+1
      WRITE (2,1120) (NCOEF(INDX,K),K=1,40)
      J=J+1
      IF (J .LE. DISTP(1,MK)) GO TO 462
      MK=MK+1
      IF (MK .LE. NSPDF(1)) GO TO 461
      MK=0
      I=1
 463  I=I+1
      MK=MK+1
C
C     SP-TYPE.
C
      WRITE (2,1200) I
      J=1
 466  INDX=INDX+1
      WRITE (2,1210) (NCOEF(INDX,K),K=1,60)
      J=J+1
      IF (J .LE. DISTP(2,MK)) GO TO 466
      IF (INDX .LT. NTOTAL) GO TO 463
      WRITE (2,1180)
      RETURN
      END