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