C-*- Fortran -*-
C
C..FILE 'common_symbols.h'
C
C..FILE 'common_flow.h'
C
C..FILE 'common_systab.h'
C
PROGRAM MAIN
INCLUDE 'param.h'
C
C DELCD DEBUG
C..DELCN NORMALIZATION OF BASI
C
C the input is a segmented basis, but the files generated for
C DALTON should contain a generalized contraction scheme
C without double counting of exponents
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C C
C Generator for input to DALTON C
C C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C C
C for DALTON: DALTON.INP and MOLECULE.INP are generated C
C C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Generator for GAMESS: 12/2000
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Generator for MOLPRO: 3/2003
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C INPUT :
C
C number of atoms in molecule
C
C for each atom:
C
C ATOMIC NUMBER, NUMBER OF SHELLS, POSITION WITH RESPECT TO
C CENTER OF CELL
C
C for each shell
C
C TYPE, NUMBER OF PRIMITIVES
C
C Exponents, contraction coefficients
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C attention to the normalization of contractions!
C
C Gaussians are d_i exp( -a_i r^2 )
C
C where the d_i are dependent on angular momentum and exponent a_i
C
C we take a contraction:
C
C sum_i [ c_i * d_i exp ( -a_i r^2 )]
C
C since the d_i exp (-a_i r^2) are normalized, we have to
C
C calculate SQRT(\pi^3/2 sum_ij (c_i d_i c_j d_j)/(a_i+a_j)^l+3/2)
C
C we print as coefficients: 1 for primitive orbitals
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Input generator for Dalton 22/5/1997
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C beyond d-functions 3/7/97
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C MOLPRO, GAUSSIAN 3/2003
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C ORTHO - programs for ab-initio calculations in localized orbitals
C Copyright (C) 2008 Peter Reinhardt (Univ. Paris VI, France)
C
C This program is free software: you can redistribute it and/or modify
C it under the terms of the GNU General Public License as published by
C the Free Software Foundation, either version 3 of the License, or
C (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
C along with this program. If not, see .
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
COMMON /SYMTAB/ SYMBAT(0:92),SYMLEN(0:92)
CHARACTER*2 SYMBAT
INTEGER*2 SYMLEN
CHARACTER*1 CST(10)
DIMENSION MDEGEN(0:4)
DATA CST /'S','P','D','F','G','H','I','J','K','L'/
DATA MDEGEN /1,3,6,10,15/
C.. INCLUDE 'common_symbols.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
DIMENSION INDXX(NLMAX),ISHLX(NLMAX)
DATA SYMBAT/ 'XX','H ','HE','LI','BE','B ','C ','N ',
1'O ','F ','NE','NA','MG','AL','SI','P ','S ','CL','AR',
2'K ','CA','SC','TI','V ','CR','MN','FE','CO','NI','CU',
3'ZN','GA','GE','AS','SE','BR','KR','RB','SR','Y ','ZR',
4'NB','MO','TC','RU','RH','PD','AG','CD','IN','SN','SB',
5'TE','I ','XE','CS','BA','LA','CE','PR','ND','PM','SM',
6'EU','GD','TB','DY','HO','ER','TM','YB','LU','HF','TA',
7'W ','RE','OS','IR','PT','AU','HG','TL','PB','BI','PO',
8'AT','RN','FR','RA','AC','TH','PA','U '/
DATA SYMLEN/ 2,1,2,2,2,1,1,1,
1 1,1,2,2,2,2,2,1,1,2,2,
2 1,2,2,2,1,2,2,2,2,2,2,
3 2,2,2,2,2,2,2,2,2,1,2,
4 2,2,2,2,2,2,2,2,2,2,2,
5 2,1,2,2,2,2,2,2,2,2,2,
6 2,2,2,2,2,2,2,2,2,2,2,
7 1,2,2,2,2,2,2,2,2,2,2,
8 2,2,2,2,2,2,2,1/
C
INCLUDE 'compiler_stamp'
IUNITV=5
IUNITW=34
IUNITS=26
IUNITR=17
C
X=CPTIME(3)
CALL DATING('GEN MOL ',1)
WRITE(6,*)
WRITE(6,*) ' G E N I N P - 1 MOLECULE '
WRITE(6,*)
C
WRITE(6,*) ' + NORMALIZATION OF BASIS FUNCTIONS'
WRITE(6,*) ' + INPUT GENERATOR FOR DALTON INTEGRAL GENERATOR'
WRITE(6,*) ' + INPUT GENERATOR FOR GAMESS SCF CALCULATIONS'
WRITE(6,*) ' + INPUT GENERATOR FOR MOLPRO SCF CALCULATIONS'
WRITE(6,*) ' + INPUT GENERATOR FOR GAUSSIAN SCF CALCULATIONS'
WRITE(6,*) ' + GENERATION OF GENERALIZED CONTRACTIONS IN DALTON'
WRITE(6,*)
C
ANTOAU=.529177249D0
CALL FFCAL
C
C read file INPUT.GEN, if present
CALL RDINP
C
IF (LANGST) THEN
WRITE(6,*) ' UNITS are ANGSTROMS'
ELSE
WRITE(6,*) ' INPUT POSITIONS should be in ATOMIC UNITS'
END IF
IF (LSLATER) THEN
WRITE(6,*) ' GENERATING INPUT FOR THE SMILES CODE '
WRITE(6,*) ' of the Madrid group, using Slater orbitals'
WRITE(6,*) ' GENERATING INPUT FOR THE ORTHO-SCF-PROGRAMS'
WRITE(6,*)
WRITE(6,*) ' USING ',NGAUSS,' Gaussians for the multi-center '
$ ,'integrals '
WRITE(6,*)
LORTHO=.FALSE.
LGAMESS=.FALSE.
LMOLPRO=.FALSE.
LGAUSS =.FALSE.
LDALT =.FALSE.
END IF
IF (LORTHO) THEN
WRITE(6,*) ' GENERATING INPUT FOR THE ORTHO-SCF-PROGRAMS'
C
IF (LORTIN) THEN
WRITE(6,*) ' using own integral program INTCAL'
ELSE
IF (LDALTIN) THEN
WRITE(6,*) ' using DALTON for calculating integrals '
ELSE
WRITE(6,*) ' you should specify an integral generator'
$ ,' via the keywords ORTINT or DALTIN'
STOP
END IF
END IF
IF (LDFT) THEN
WRITE(6,*)
$ ' we will do an external DFT calculation ORTHO/MOLPRO '
END IF
END IF
C
IF (LGAMESS) WRITE(6,*) ' GENERATED INPUT IS FOR THE GAMESS SCF'
IF (LMOLPRO) WRITE(6,*) ' GENERATED INPUT IS FOR THE MOLPRO SCF'
IF (LGAUSS) WRITE(6,*) ' GENERATED INPUT IS FOR THE GAUSSIAN SCF'
IF (LDALT) WRITE(6,*) ' GENERATED INPUT IS FOR THE DALTON SCF'
IF (LEXPAND) THEN
WRITE(6,*) ' expanding the atomic basis set among ghost atoms '
END IF
WRITE(6,*)
C
WRITE(6,*) ' CHARGE OF THE MOLECULE:',ICHGE
C
WRITE(6,*)
WRITE(6,*)
WRITE(6,*)
IF (LEULER) THEN
CALL GENEUL(EUL1,EUL2,EUL3,ROTEUL)
END IF
C READING positions and basis sets for molecule
IF (LSLATER) THEN
CALL RDSLATER
ELSE
CALL RDCELL
END IF
C if we had the option expand, we write the file SYSTEM.ORTHO, reread
c it and store the information expanded
c
IF (LEXPAND) THEN
C write a file SYSTEM.ORTHO
CALL WORTHO
CALL SYSTEM('cp SYSTEM.ORTHO SYSTEM.ORTHO.TMP')
DO ILL=1,NLMAX
INDXX(ILL)=0
END DO
OPEN(UNIT=26,FILE='SYSTEM.ORTHO',FORM='FORMATTED',STATUS='OLD')
READ(26,*) NAT2
NATOM=0
IIPRIM=0
DO IAT=1,NAT2
READ(26,*) NNZ,NNSHL,PX,PY,PZ
IF (NNSHL.LE.0) STOP ' no atoms without basis functions '
C read first basis function
READ(26,*) ILL,NPPPP
NATOM=NATOM+1
NZ(NATOM)=NNZ
LMAX(NATOM)=ILL
NSH(NATOM)=1
NPRIM(NATOM)=NPPPP
IL(NATOM)=ILL
ILL=ILL+1
POS(1,NATOM)=PX
POS(2,NATOM)=PY
POS(3,NATOM)=PZ
DO I4=1,NPPPP
IIPRIM=IIPRIM+1
READ(26,*) EXX(IIPRIM),COEFF(ILL,IIPRIM)
END DO
INDXX(ILL)=INDXX(ILL)+1
NPPARL(ILL,INDXX(ILL))=NPRIM(NATOM)
NPARL(ILL,NATOM)=1
NPX(ILL,NATOM)=NPRIM(NATOM)
DO III=2,NNSHL
READ(26,*) ILL,NPPPP
NATOM=NATOM+1
NZ(NATOM)=0
NSH(NATOM)=1
NPRIM(NATOM)=NPPPP
LMAX(NATOM)=ILL
IL(NATOM)=ILL
ILL=ILL+1
POS(1,NATOM)=PX
POS(2,NATOM)=PY
POS(3,NATOM)=PZ
DO I4=1,NPPPP
IIPRIM=IIPRIM+1
READ(26,*) EXX(IIPRIM),COEFF(ILL,IIPRIM)
END DO
INDXX(ILL)=INDXX(ILL)+1
NPPARL(ILL,INDXX(ILL))=NPRIM(NATOM)
NPARL(ILL,NATOM)=1
NPX(ILL,NATOM)=NPRIM(NATOM)
END DO
END DO
CLOSE(UNIT=26,STATUS='DELETE')
C the information is reinstalled in a scattered form
END IF
C
C input is read, arrays are filled, we can proceed to the output
C
IF (LORTHO.OR.LSLATER) THEN
CALL WORTHO
IF (LEXPAND) CALL SYSTEM(' mv SYSTEM.ORTHO.TMP SYSTEM.ORTHO')
IUNITA=12
NVIRT=NBAS-NOCC
OPEN (UNIT=IUNITA,FILE='GUESS',STATUS='UNKNOWN',FORM
$ ='FORMATTED')
WRITE(IUNITA,9821)
9821 FORMAT('E')
IZERO=0
ITWO=2
WRITE(IUNITA,'(20I2)') (ITWO,I=1,NOCC),(IZERO,J=1,NVIRT)
WRITE(IUNITA,'(20I2)') (ITWO,I=1,NBAS)
CLOSE(IUNITA)
WRITE(6,*)
WRITE(6,*) ' dumped simple starting vector on file '
WRITE(6,*)
IF (.NOT.LSLATER) THEN
IF (LDALTIN) THEN
CALL DALGEN(IUNITW)
CALL TIMING('DALT')
ELSE
CALL WSORTH
CALL TIMING('WSOR')
END IF
IF (LDFT) THEN
CALL MOLPRO(IUNITW)
CALL TIMING('MOLP')
END IF
END IF
END IF
C the same for GAMESS
IF (LGAMESS) THEN
CALL GAMGEN(IUNITW)
CALL TIMING('GAMS')
END IF
IF (LMOLPRO) THEN
LDFT=.FALSE.
CALL MOLPRO(IUNITW)
CALL TIMING('MOLP')
END IF
IF (LGAUSS) THEN
CALL GAUSSN(IUNITW)
CALL TIMING('GSSN')
END IF
IF (LDALT) THEN
CALL DALGEN(IUNITW)
CALL TIMING('DALT')
END IF
WRITE(6,*)
C
WRITE(6,'(///)')
CALL DISTAB
WRITE(6,'(///)')
X=CPTIME(4)
CALL DATING('GEN MOL ',2)
END
C
SUBROUTINE RDCELL
INCLUDE 'param.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
COMMON /SYMTAB/ SYMBAT(0:92),SYMLEN(0:92)
CHARACTER*2 SYMBAT
INTEGER*2 SYMLEN
CHARACTER*1 CST(10)
DIMENSION MDEGEN(0:4)
DATA CST /'S','P','D','F','G','H','I','J','K','L'/
DATA MDEGEN /1,3,6,10,15/
C.. INCLUDE 'common_symbols.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
COMMON /CELL/ INDXX(NLMAX)
C
DIMENSION ISHLX(NLMAX)
WRITE(6,*) ' READING INFORMATION ON MOLECULE'
READ(IUNITV,*) NATOM
C
NSHL=0
NBAS=0
IPRIM=0
LLMAX=0
C
DO I=1,3
BARYZ(I)=0.D0
END DO
DO ILL=1,NLMAX
INDXX(ILL)=0
END DO
C
DO IAT=1,NATOM
LMAX(IAT)=0
DO ILL=1,NLMAX
NPX(ILL,IAT)=0
NPARL(ILL,IAT)=0
END DO
READ(IUNITV,*) NZ(IAT),NSH(IAT),(POS(J,IAT),J=1,3)
C positions in a.u.
IF (LANGST) THEN
DO J=1,3
POS(J,IAT)=POS(J,IAT)/ANTOAU
END DO
END IF
DO II=1,3
BARYZ(I)=BARYZ(I)+NZ(IAT)*POS(II,IAT)
END DO
NUMAT(NZ(IAT))=0
C positions are now all in a.u.
WRITE(6,9901) IAT,SYMBAT(NZ(IAT)),(POS(J,IAT),J=1,3),
- (POS(J,IAT)*ANTOAU,J=1,3)
DO ISH=1,NSH(IAT)
NSHL=NSHL+1
IF (NSHL.GT.NSHLMX) THEN
WRITE(6,*) ' NSHL = ',NSHL,'; THIS IS BEYOND MAXIMUM OF '
- ,NSHLMX
STOP ' TOO MANY SHELLS, INCREASE NSHLMX '
END IF
READ(IUNITV,*) ILL,NPRIM(NSHL)
IL(NSHL)=ILL
ILL=ILL+1
IF (ILL.GT.NLMAX) THEN
WRITE(6,*) ' ILL = ',ILL,'; THIS IS BEYOND MAXIMUM OF ',NLMAX
STOP ' LMAX TOO HIGH '
END IF
LLMAX=MAX(LLMAX,ILL)
LMAX(IAT)=MAX(LMAX(IAT),ILL-1)
IF (L6D) THEN
NBAS=NBAS+MDEGEN(ILL-1)
ELSE
NBAS=NBAS+ILL+ILL-1
END IF
WRITE(6,9903) CST(ILL),NPRIM(NSHL)
INDXX(ILL)=INDXX(ILL)+1
NPPARL(ILL,INDXX(ILL))=NPRIM(NSHL)
NPARL(ILL,IAT)=NPARL(ILL,IAT)+1
NPX(ILL,IAT)=NPX(ILL,IAT)+NPRIM(NSHL)
IPST=IPRIM+1
DO III=1,NPRIM(NSHL)
IPRIM=IPRIM+1
IF (IPRIM.GT.NPRIMX) STOP
$ ' TOO MANY PRIMITIVES, ADJUST NPRIMX'
READ(IUNITV,*) EXX(IPRIM),COEFF(ILL,IPRIM)
C WRITE(IUNITR,'(2F20.12)') EXX(IPRIM),COEFF(ILL,IPRIM)
END DO
CALL NORMBF(NSHL,IPST)
DO III=0,NPRIM(NSHL)-1
WRITE(6,9902) EXX(IPST+III),COEFF(ILL,IPST+III)
END DO
END DO
END DO
WRITE(6,*)
WRITE(6,*) ' CHARGE OF THE MOLECULE: ',ICHGE
NELEC=0
DO IAT=1,NATOM
NELEC=NELEC+NZ(IAT)
END DO
NELEC=NELEC-ICHGE
WRITE(6,*)
WRITE(6,*) ' TOTAL NUMBER OF ELECTRONS IN THE MOLECULE:',NELEC
WRITE(6,*)
IF (MOD(NELEC,2).EQ.1) STOP
$ ' NO OPEN SHELLS ALLOWED FOR THE MOMENT ?'
NOCC=NELEC/2
C
9901 FORMAT(/,' ATOM ',I3,' : ',A2,' AT ',3F12.6,' (A.U.)',/,
- 18X,3F12.6,' (ANGSTROM)',/)
9902 FORMAT(' EXPONENT ',F20.12,' COEFFICIENT ',F20.12)
9903 FORMAT(' ',A1,'-SHELL WITH ',I3,' PRIMITIVES: ')
WRITE(6,9933) NBAS
9933 FORMAT(//,' TOTAL NUMBER OF BASIS FUNCTIONS : ',I5,//)
WRITE(6,*) ' HIGHEST L FOUND :',LLMAX-1,' (',CST(LLMAX)
$ ,'-FUNCTIONS)'
WRITE(6,*)
IF (NBAS.GT.NBASM) WRITE(6,9934) NBAS,NBASM
9934 FORMAT (1X,79('='),//,
- ' WARNING: NBAS > NBASM (defined in param.h) ',2I6,//,
- 1X,79('='),//)
C
IF (LEULER) CALL TURN
RETURN
END
SUBROUTINE WORTHO
INCLUDE 'param.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
C
C write the file SYSTEM.ORTHO
C
C SYSTEM.ORTHO will be the system input file needed by the ORTHO
C programs
C
IUNITR=26
OPEN(UNIT=IUNITR,FILE='SYSTEM.ORTHO',FORM='FORMATTED',STATUS
$ ='UNKNOWN')
WRITE(IUNITR,*) NATOM
IIPST=1
NNSHL=0
DO IAT=1,NATOM
WRITE(IUNITR,'(I3,I6,3F20.12)') NZ(IAT),NSH(IAT),(POS(J,IAT),J=1
$ ,3)
DO ILL=0,LMAX(IAT)
IPST=IIPST
NSHL=NNSHL
DO ISHL=1,NSH(IAT)
NSHL=NSHL+1
IF (IL(NSHL).EQ.ILL) THEN
IF (LSLATER) THEN
WRITE(IUNITR,'(3I6)') ILL,NPRIM(NSHL),NREXP(NSHL)
ELSE
WRITE(IUNITR,'(2I6)') ILL,NPRIM(NSHL)
END IF
DO IPRIM=1,NPRIM(NSHL)
IIPRIM=IPRIM+IPST-1
WRITE(IUNITR,'(F24.12,F20.12)') EXX(IIPRIM)
- ,COEFF(ILL+1,IIPRIM)
END DO
END IF
IPST=IPST+NPRIM(NSHL)
END DO
END DO
IIPST=IPST
NNSHL=NSHL
END DO
CLOSE(IUNITR)
C
RETURN
END
C
SUBROUTINE RDSLATER
INCLUDE 'param.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
COMMON /SYMTAB/ SYMBAT(0:92),SYMLEN(0:92)
CHARACTER*2 SYMBAT
INTEGER*2 SYMLEN
CHARACTER*1 CST(10)
DIMENSION MDEGEN(0:4)
DATA CST /'S','P','D','F','G','H','I','J','K','L'/
DATA MDEGEN /1,3,6,10,15/
C.. INCLUDE 'common_symbols.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
COMMON /CELL/ INDXX(NLMAX)
C
DIMENSION ISHLX(NLMAX)
C reading the input for a Slater calculation and generating the
C input file for the Madrid Slater program SMILES
C
C dumping as well an execution script
C
C we assume primitive Slaters
C
WRITE(6,*) ' READING INFORMATION ON MOLECULE'
WRITE(6,*) ' --- SLATER orbitals --- '
READ(IUNITV,*) NATOM
C
NSHL=0
NBAS=0
IPRIM=0
C
DO I=1,3
BARYZ(I)=0.D0
END DO
DO IAT=1,NATOM
LMAX(IAT)=0
READ(IUNITV,*) NZ(IAT),NSH(IAT),(POS(J,IAT),J=1,3)
C positions in a.u.
IF (LANGST) THEN
DO J=1,3
POS(J,IAT)=POS(J,IAT)/ANTOAU
END DO
END IF
DO II=1,3
BARYZ(I)=BARYZ(I)+NZ(IAT)*POS(II,IAT)
END DO
C positions are now all in a.u.
WRITE(6,9901) IAT,SYMBAT(NZ(IAT)),(POS(J,IAT),J=1,3),
- (POS(J,IAT)*ANTOAU,J=1,3)
DO ISH=1,NSH(IAT)
NSHL=NSHL+1
IF (NSHL.GT.NSHLMX) STOP ' TOO MANY SHELLS, INCREASE NSHLMX '
READ(IUNITV,*) ILL,NREXP(NSHL),EXX(NSHL)
IF (ILL.GE.NREXP(NSHL)) THEN
WRITE(6,9904) NREXP(NSHL),CST(ILL+1),EXX(NSHL)
9904 FORMAT(' you asked for a ',I1,A1,' - SHELL WITH EXPONENT ',F20.12)
WRITE(6,*) ' that means L >= N, which is impossible '
WRITE(6,*) ' check your basis set '
STOP 'ERROR in input '
END IF
NPRIM(NSHL)=1
IL(NSHL)=ILL
LMAX(IAT)=MAX(LMAX(IAT),ILL)
NBAS=NBAS+1+ILL+ILL
ILL=ILL+1
WRITE(6,9903) NREXP(NSHL),CST(ILL),EXX(NSHL)
COEFF(ILL,NSHL)=0.D0
END DO
END DO
WRITE(6,*)
WRITE(6,*) ' CHARGE OF THE MOLECULE: ',ICHGE
NELEC=0
DO IAT=1,NATOM
NELEC=NELEC+NZ(IAT)
END DO
NELEC=NELEC-ICHGE
WRITE(6,*)
WRITE(6,*) ' TOTAL NUMBER OF ELECTRONS IN THE MOLECULE:',NELEC
WRITE(6,*)
IF (MOD(NELEC,2).EQ.1) STOP
$ ' NO OPEN SHELLS ALLOWED FOR THE MOMENT ?'
NOCC=NELEC/2
C
9901 FORMAT(/,' ATOM ',I3,' : ',A2,' AT ',3F12.6,' (A.U.)',/,
- 18X,3F12.6,' (ANGSTROM)',/)
9903 FORMAT(' ',I1,A1,' - SHELL WITH EXPONENT ',F20.12)
WRITE(6,9933) NBAS
9933 FORMAT(//,' TOTAL NUMBER OF BASIS FUNCTIONS : ',I5,//)
WRITE(6,*)
IF (NBAS.GT.NBASM) WRITE(6,9934) NBAS,NBASM
9934 FORMAT (1X,79('='),//,
- ' WARNING: NBAS > NBASM (defined in param.h) ',2I6,//,
- 1X,79('='),//)
C
IF (LEULER) CALL TURN
C
C we have to dump a script and the input for the SMILES code
WRITE(6,*) ' writing input for the SMILES code '
OPEN(UNIT=IUNITR,FILE='SMILES.input',FORM='FORMATTED',
- STATUS='UNKNOWN')
WRITE(IUNITR,9001)
9001 FORMAT(' &DATOS',/,' TITLE=''ORTHO'' ',/
$ ,' PROJECTNAME=''ORTHO''',/,' LGEOMFIX=T ',/,' LORTHO=T'
- ,/,' &END')
C write positions
WRITE(IUNITR,'(I5)') NATOM
DO IAT=1,NATOM
WRITE(IUNITR,'(3F20.12,2I6)') (POS(J,IAT),J=1,3),NZ(IAT),IAT
END DO
C write basis sets
IIPST=1
NNSHL=0
DO IAT=1,NATOM
DO ILL=0,LMAX(IAT)
IPST=IIPST
NSHL=NNSHL
DO ISHL=1,NSH(IAT)
NSHL=NSHL+1
IF (IL(NSHL).EQ.ILL) WRITE(IUNITR,'(3I6,F20.12,I6)') IAT
$ ,NREXP(NSHL),IL(NSHL),EXX(NSHL),NGAUSS
IPST=IPST+1
END DO
END DO
IIPST=IPST
NNSHL=NSHL
END DO
CLOSE(IUNITR)
C
WRITE(6,*) ' writing script for the SMILES code '
C
OPEN(UNIT=IUNITR,FILE='script_smiles',FORM='FORMATTED',STATUS
$ ='UNKNOWN')
WRITE(IUNITR,9902)
9902 FORMAT(':',/
$ ,' /home/reinh/bin/smiles_mol < SMILES.input '
$ ,'| tee smiles.output',/
$ ,' /home/reinh/bin/ors_mol | tee ors_smiles.output | grep ITE
$R ')
C folded 1 (fixf $Revision: 1.3 $)
CLOSE(IUNITR)
RETURN
END
C
SUBROUTINE FFCAL
INCLUDE 'param.h'
COMMON /POLYTA/ FAC(NLMAX+NLMAX),FACC(NLMAX)
C the (2l+1)!! and the (l+|m|)!
FACC(1)=1.D0
FACC(2)=1.D0
FAC(1)=1.D0
FAC(2)=1.D0
DO I=3,NLMAX
XMLT=DBLE(I-1)
FACC(I)=XMLT*FACC(I-2)
FAC(I)=XMLT*FAC(I-1)
END DO
DO I=NLMAX+1,NLMAX+NLMAX
XMLT=DBLE(I-1)
FAC(I)=XMLT*FAC(I-1)
END DO
RETURN
END
C
SUBROUTINE NORMBF(NSHLF,IPST)
INCLUDE 'param.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
COMMON /POLYTA/ FAC(NLMAX+NLMAX),FACC(NLMAX)
C the (2l+1)!! and the (l+|m|)!
C
C we normalize the functions x^l \sum_i c_i exp{-a_i * (r^2))} to unity
C this gives as factor:
C
C sqrt[(\pi^{3/2}*(2l-1)!! / 2^l) * \sum_{ij} c_i c_j / ((a_i + a_j)^(l+3/2))]
C
C in general this will be multiplied by
C
C sqrt[ (l+|m|)! / ((2-\delta_{m0})*(l-|m|)! ) ], a factor of 1 for m=0
C
C this is the prefactor for the solid harmonics
C
C
XNRM=0.D0
C 0: s, 1: p, ...
LVAL=IL(NSHLF)
NPRIMM=NPRIM(NSHLF)
EPS=1.D-9
PI=2.0D0*ACOS(0.D0)
XVAL=DBLE(LVAL)
C shift LVAL to LVAL+1
C PIF = 2**l / (2 l - 1)!!/pi**3/2
LVAL=LVAL+1
PIF=FACC(LVAL)*(PI**1.5D0)
PIF=(2.D0**XVAL)/PIF
CD WRITE(6,*) 'NORMBF',LVAL,IPST,NPRIM,EXX(IPST),FACC(LVAL)
C
IF (NPRIMM.EQ.1) THEN
C CCC=(2.D0*EXX(IPST))**(XVAL+1.5D0)
C COEFF(LVAL,IPST)=SQRT(PIF*CCC)
C COEFF(LVAL,IPST)=SQRT(PIF*(2.D0*EXX(IPST))**(XVAL+1.5D0))
C
COEFF(LVAL,IPST)=1.D0
COEFF(LVAL,IPST)=SQRT(PIF*(2.D0*EXX(IPST))**(XVAL+1.5D0))
CD WRITE(6,*) ' a) LVAL,COEFF,EXP',IPST,LVAL,COEFF(LVAL,IPST),EXX(IPST)
ELSE
CCC=0.D0
DO IP=IPST,IPST+NPRIMM-1
CIP=COEFF(LVAL,IP)
DIP=SQRT((2.D0*EXX(IP))**(XVAL+1.5D0))
DO JP=IPST,IPST+NPRIMM-1
EXXX=1.D0/(EXX(IP)+EXX(JP))
DJP=SQRT((2.D0*EXX(JP))**(XVAL+1.5D0))
CJP=COEFF(LVAL,JP)
CCC=CCC+CIP*CJP*DIP*DJP*(EXXX**(XVAL+1.5D0))
END DO
END DO
DO IP=IPST,IPST+NPRIMM-1
COEFF(LVAL,IP)=COEFF(LVAL,IP)/SQRT(CCC)
CD WRITE(6,*) ' b) LVAL,COEFF,EXP',IPST,LVAL,COEFF(LVAL,IP),EXX(IP)
DIP=SQRT((2.D0*EXX(IP))**(XVAL+1.5D0))
WRITE(6,*) ' new coefficients : ',COEFF(LVAL,IP),COEFF(LVAL,IP)
$ *DIP/PI**0.75
END DO
END IF
RETURN
END
C
SUBROUTINE DISTAB
INCLUDE 'param.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
C
C set up distance table
C
WRITE(6,*)
WRITE(6,*) ' DISTANCE TABLE (A.U.)'
WRITE(6,*) ' ------------------------- '
WRITE(6,*)
DO IPOS=1,NATOM
DO JPOS=1,IPOS
DIST(JPOS)=0.D0
DO KK=1,3
DIST(JPOS)=DIST(JPOS)+(POS(KK,IPOS)-POS(KK,JPOS))**2
END DO
END DO
WRITE(6,'(4F25.15)') (SQRT(DIST(JPOS)),JPOS=1,IPOS)
END DO
C
WRITE(6,*)
WRITE(6,*)
WRITE(6,*)
WRITE(6,*) ' DISTANCE TABLE (ANGSTROM)'
WRITE(6,*) ' ----------------------------- '
WRITE(6,*)
DO IPOS=1,NATOM
DO JPOS=1,IPOS
DIST(JPOS)=0.D0
DO KK=1,3
DIST(JPOS)=DIST(JPOS)+(POS(KK,IPOS)-POS(KK,JPOS))**2
END DO
END DO
WRITE(6,'(4F25.15)') (SQRT(DIST(JPOS))*ANTOAU,JPOS=1,IPOS)
END DO
RETURN
END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
SUBROUTINE DALGEN(IODAL)
INCLUDE 'param.h'
COMMON /SYMTAB/ SYMBAT(0:92),SYMLEN(0:92)
CHARACTER*2 SYMBAT
INTEGER*2 SYMLEN
CHARACTER*1 CST(10)
DIMENSION MDEGEN(0:4)
DATA CST /'S','P','D','F','G','H','I','J','K','L'/
DATA MDEGEN /1,3,6,10,15/
C.. INCLUDE 'common_symbols.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
DIMENSION COEFLI(NPRIMX),ISHLX(NLMAX),INDXX(NLMAX)
C
WRITE(6,*)
WRITE(6,*) ' DALTON INPUT GENERATOR '
WRITE(6,*) ' =========================== '
WRITE(6,*)
C
C sort according to angular momenta
C
WRITE(6,*) ' LLMAX ',LLMAX
DO ILL=1,LLMAX
INDXX(ILL)=0
END DO
C
WRITE(6,*) ' NATOM',NATOM
IEX=0
ISHL=0
DO IAT=1,NATOM
ISHST=ISHL+1
LM=0
DO IISHL=1,NSH(IAT)
ISHL=ISHL+1
ILL=IL(ISHL)+1
DO IPRIM=1,NPRIM(ISHL)
INDXX(ILL)=INDXX(ILL)+1
IEX=IEX+1
EXXM(ILL,INDXX(ILL))=EXX(IEX)
COEFFM(ILL,INDXX(ILL))=COEFF(ILL,IEX)
END DO
END DO
END DO
C
WRITE(6,*) ' SORTED FUNCTIONS '
C
DO I=0,92
NUMAT(I)=0
END DO
C
C LMAX: 0<->s, 1<->p ...
LLMAX=0
DO IAT=1,NATOM
LLMAX=MAX(LLMAX,LMAX(IAT)+1)
END DO
C
C the DALTON.INP
C
IF (LORTHO) THEN
OPEN (UNIT=IODAL,FILE='DALTON.INP',FORM='FORMATTED',STATUS
$ ='UNKNOWN')
WRITE(IODAL,9908)
9908 FORMAT('**DALTON INPUT',/,'.INTEGRALS',/,'**INTEGRALS',/,'.NOSUP'
$ ,/,'.DIPLEN',/,'.THETA'
- ,/,'*END OF INPUT',/,'**END OF INPUT'
$ )
ELSE
OPEN (UNIT=IODAL,FILE='DALTON.INP',FORM='FORMATTED',
- STATUS='UNKNOWN')
C NOCC is the number of occupied orbitals per monomer
WRITE(IODAL,9901) NOCC
9901 FORMAT('**DALTON INPUT',/,'.RUN WAVEFUNCTION',/,'**WAVEFUNCTION',
$ /,'.HF',/,'*HF INPUT',/,'.HF OCCUPATION',/,I5,/
$ ,'*ORBITAL INPUT',/,'.PUNCHOUT',/,'*END OF INPUT',/
$ ,'**INTEGRALS',/,'.KINENE',/,'*END OF INPUT',/
$ ,'**END OF INPUT')
END IF
CLOSE (IODAL)
C
C the MOLECULE.INP
C
OPEN (UNIT=IODAL,FILE='MOLECULE.INP',FORM='FORMATTED',
- STATUS='UNKNOWN')
IF (L6D) THEN
WRITE(IODAL,9962) NATOM
ELSE
WRITE(IODAL,9902) NATOM
END IF
9962 FORMAT('INTGRL',/,' MOLECULE INPUT GENERATED BY GENINPUT_MOL ',/,
- ' ---------------------------- ',/,'C',I4,' 0')
9902 FORMAT('INTGRL',/,' MOLECULE INPUT GENERATED BY GENINPUT_MOL ',/,
- ' ---------------------------- ',/,' ',I4,' 0')
IONE=1
ZERO=0.D0
DO ILL=1,LLMAX
ISHLX(ILL)=0
INDXX(ILL)=0
END DO
C
DO IAT=1,NATOM
NUMAT(NZ(IAT))=NUMAT(NZ(IAT))+1
ILM=LMAX(IAT)+1
WRITE(IODAL,9903) DBLE(NZ(IAT)),IONE,ILM,(IONE,I=1,ILM)
C
ILS=2
IF (SYMBAT(NZ(IAT))(2:2).EQ.' ') ILS=1
ILZ=1
IF (NUMAT(NZ(IAT)).GT.9) ILZ=2
IF (NUMAT(NZ(IAT)).GT.99) ILZ=3
IF (ILS.EQ.1) THEN
IF (ILZ.EQ.1) THEN
WRITE(IODAL,9925) SYMBAT(NZ(IAT))(1:1),NUMAT(NZ(IAT)),
- (POS(J,IAT),J=1,3)
ELSE IF (ILZ.EQ.2) THEN
WRITE(IODAL,9926) SYMBAT(NZ(IAT))(1:1),NUMAT(NZ(IAT)),
- (POS(J,IAT),J=1,3)
ELSE IF (ILZ.EQ.3) THEN
WRITE(IODAL,9927) SYMBAT(NZ(IAT))(1:1),NUMAT(NZ(IAT)),
- (POS(J,IAT),J=1,3)
ELSE
STOP 'MORE THAN 1000 ATOMS'
END IF
ELSE IF (ILS.EQ.2) THEN
IF (ILZ.EQ.1) THEN
WRITE(IODAL,9928) SYMBAT(NZ(IAT)),NUMAT(NZ(IAT)),
- (POS(J,IAT),J=1,3)
ELSE IF (ILZ.EQ.2) THEN
WRITE(IODAL,9929) SYMBAT(NZ(IAT)),NUMAT(NZ(IAT)),
- (POS(J,IAT),J=1,3)
ELSE IF (ILZ.EQ.3) THEN
STOP ' 2 LETTERS AND 3 DIGITS FOR THE NUMBER'
ELSE
STOP 'MORE THAN 1000 ATOMS'
END IF
ELSE
STOP 'NEITHER 1 OR 2 LETTERS FOR ATOM SYMBOL'
END IF
C
C the basis set, segmented basis used throughout
C
DO ILL=1,LMAX(IAT)+1
C
C
C first we store the information in the fields EXXG and COEFFG
C we reduce these fields, and then we print
C
C number of contractions
NCONTR=NPARL(ILL,IAT)
IF (NCONTR.NE.0) THEN
C number of primitives
NPXXG=NPX(ILL,IAT)
ITT=INDXX(ILL)
DO I=1,NPXXG
ITT=ITT+1
EXXG(I)=EXXM(ILL,ITT)
LTAKE(I)=.TRUE.
DO J=1,NPXXG
COEFFG(I,J)=0.D0
END DO
END DO
C
ITTG=0
DO ISHL=1,NCONTR
ISHLX(ILL)=ISHLX(ILL)+1
DO IPRIM=1,NPPARL(ILL,ISHLX(ILL))
INDXX(ILL)=INDXX(ILL)+1
ITTG=ITTG+1
COEFFG(ITTG,ISHL)=COEFFM(ILL,INDXX(ILL))
END DO
END DO
C
C the information is stored in the arrays EXXG and COEFFG
C now reduce
C we use the heavy bubble-sort
C
DO I=2,NPXXG
DO J=1,I-1
IF (EXXG(J).LT.EXXG(I)) THEN
XDUM=EXXG(I)
EXXG(I)=EXXG(J)
EXXG(J)=XDUM
DO II=1,NCONTR
XDUM=COEFFG(I,II)
COEFFG(I,II)=COEFFG(J,II)
COEFFG(J,II)=XDUM
END DO
END IF
END DO
END DO
C
C now reduce
C
NPXXGG=NPXXG
DO IRUN=1,NPXXG-1
IF (LTAKE(IRUN)) THEN
DO I=IRUN+1,NPXXG
IF (LTAKE(I).AND.ABS(EXXG(I)-EXXG(IRUN)).LE.1.D-8) THEN
DO II=1,NCONTR
IF (COEFFG(I,II).NE.0) COEFFG(IRUN,II)=COEFFG(I,II)
END DO
LTAKE(I)=.FALSE.
NPXXGG=NPXXGG-1
END IF
END DO
END IF
END DO
WRITE(IODAL,9910) NPXXGG,NCONTR
DO I=1,NPXXG
IF (LTAKE(I)) THEN
WRITE(IODAL,9911) EXXG(I),(COEFFG(I,II),II=1,MIN(3,NCONTR))
IF (NCONTR.GT.3) WRITE(IODAL,9913) (COEFFG(I,II),II=4,NCONTR)
END IF
END DO
C
ELSE
WRITE(IODAL,9910) NPX(ILL,IAT),NCONTR
END IF
C
END DO
C
END DO
C
CLOSE(IODAL)
IF (.NOT.LORTHO) THEN
C dump a simple script
OPEN(UNIT=IODAL,FILE='script_dalton',STATUS='UNKNOWN',FORM='FORMA
$TTED')
C folded 1 (fixf $Revision: 1.3 $)
WRITE(IODAL,9378)
9378 FORMAT(':',/,' dalton.x | tee dalton.output',/,'exit')
ELSE
WRITE(6,*) ' WE ARE DUMPING THE ORTHO SCRIPT TO '
OPEN(UNIT=IODAL,FILE='script_ortho',STATUS='UNKNOWN',FORM='FORMAT
$TED')
C folded 1 (fixf $Revision: 1.3 $)
WRITE(IODAL,9377)
9377 FORMAT(':',/,' dalton.x | tee dalton.output',/
$ ,' rm AOSUPINT DALTON.CM DALTON.MOL',/
$ ,' rm DALTON.ORB fort.21 fort.3',/
$ ,' extract_mol | tee extract.output',
- /,' ors_mol | tee ors_mol.output | grep ''ITER ''',/
$ ,' exit')
END IF
CLOSE(IODAL)
C
9903 FORMAT(' ',F4.0,24I5)
9925 FORMAT(A1,I1,' ',3F20.15)
9926 FORMAT(A1,I2,' ',3F20.15)
9927 FORMAT(A1,I3,3F20.15)
9928 FORMAT(A2,I1,' ',3F20.15)
9929 FORMAT(A2,I2,3F20.15)
9910 FORMAT('H',I4,I5,' 0')
9911 FORMAT(4F20.8)
9913 FORMAT(20X,3F20.8)
RETURN
END
C
SUBROUTINE RDINP
INCLUDE 'param.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
CHARACTER*4 KEYW(2),STR3
CHARACTER*9 FILE
CHARACTER*6 KEYOPT(20),STR6
CHARACTER*80 LINE
DATA KEYW /'*INP','*END'/
DATA KEYOPT /'DALTON','ORTHO ','ATOMIC','ANGSTR','CHARGE',
- 'GAMESS','6 D ','5 D ','MOLPRO','EXPAND',
- 'GAUSSI','EXTDFT','EULER ','SLATER','BOCHUM',
- 'ORTINT','DALTIN','XXXXXX','XXXXXX','XXXXXX'/
C
C DEFAULTS
FILE='INPUT.GEN'
LANGST=.FALSE.
LORTHO=.FALSE.
LGAMESS=.FALSE.
LMOLPRO=.FALSE.
L6D =.FALSE.
LGAUSS=.FALSE.
LDALT=.FALSE.
LDFT=.FALSE.
LEULER=.FALSE.
LSLATER=.FALSE.
LEXPAND=.FALSE.
LBOCHUM=.FALSE.
LORTIN =.TRUE.
LDALTIN=.FALSE.
ICHGE=0
IOINP=83
OPEN(UNIT=IOINP,FILE=FILE,ERR=2217,FORM='FORMATTED',STATUS='OLD')
C first, look for keyword 'INP'
1 CONTINUE
READ(IOINP,'(A4)',END=2,ERR=921) STR3
IF (STR3.EQ.KEYW(1)) THEN
C look for Keyoptions /'DALTON','ORTHO ','ATOMIC','ANGSTR'
11 CONTINUE
READ(IOINP,'(A6)',END=2,ERR=921) STR6
IF (STR6(1:4).EQ.KEYW(2)) RETURN
IF (STR6.EQ.KEYOPT(1)) THEN
C option DALTON
WRITE(6,*) ' READ OPTION ',KEYOPT(1)
LORTHO=.FALSE.
LDALT=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(2)) THEN
C option ORTHO
WRITE(6,*) ' READ OPTION ',KEYOPT(2)
LORTHO=.TRUE.
C no DALTON calculation, conflicting input in DALTON.INP
LDALT=.FALSE.
ELSE IF (STR6.EQ.KEYOPT(3)) THEN
C option ATOMIC
WRITE(6,*) ' READ OPTION ',KEYOPT(3)
LANGST=.FALSE.
ELSE IF (STR6.EQ.KEYOPT(4)) THEN
C option ANGSTR
WRITE(6,*) ' READ OPTION ',KEYOPT(4)
LANGST=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(5)) THEN
C option CHARGE
WRITE(6,*) ' READ OPTION ',KEYOPT(5)
READ(IOINP,*) ICHGE
C GAMESS
ELSE IF (STR6.EQ.KEYOPT(6)) THEN
WRITE(6,*) ' READ OPTION ',KEYOPT(6)
LGAMESS=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(7)) THEN
C 6 D-Functions
WRITE(6,*) ' READ OPTION ',KEYOPT(7)
L6D=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(8)) THEN
C 5 D-functions
WRITE(6,*) ' READ OPTION ',KEYOPT(8)
L6D=.FALSE.
ELSE IF (STR6.EQ.KEYOPT(9)) THEN
C MOLPRO
WRITE(6,*) ' READ OPTION ',KEYOPT(9)
LMOLPRO=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(10)) THEN
C EXPAND
WRITE(6,*) ' READ OPTION ',KEYOPT(10)
LEXPAND=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(11)) THEN
C GAUSSIAN
WRITE(6,*) ' READ OPTION ',KEYOPT(11)
LGAUSS=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(12)) THEN
C external DFT via MOLPRO
WRITE(6,*) ' READ OPTION ',KEYOPT(12)
LDFT=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(13)) THEN
C rotation of the molecule around the barycenter via three Euler angles,
C around z, x, z
WRITE(6,*) ' READ OPTION ',KEYOPT(13)
LEULER=.TRUE.
READ(IOINP,*) EUL1,EUL2,EUL3
ELSE IF (STR6.EQ.KEYOPT(14)) THEN
C Slater integrals via SMILES
LSLATER=.TRUE.
READ(IOINP,*) NGAUSS
ELSE IF (STR6.EQ.KEYOPT(15)) THEN
C interface for the Bochum programs
LBOCHUM=.TRUE.
ELSE IF (STR6.EQ.KEYOPT(16)) THEN
C integrals via our own integral program
LORTIN=.TRUE.
LDALTIN=.FALSE.
ELSE IF (STR6.EQ.KEYOPT(17)) THEN
C integrals via Dalton
LDALTIN=.TRUE.
LORTIN=.FALSE.
ELSE
WRITE(6,*) ' POSSIBLE OPTIONS IN THE BLOCK *INP ... *END ARE:'
WRITE(6,*)
WRITE(6,*) ' ',KEYOPT(1)
WRITE(6,*) ' ',KEYOPT(2)
WRITE(6,*) ' ',KEYOPT(3)
WRITE(6,*) ' ',KEYOPT(4)
WRITE(6,*) ' ',KEYOPT(5)
WRITE(6,*) ' ',KEYOPT(6)
WRITE(6,*) ' ',KEYOPT(7)
WRITE(6,*) ' ',KEYOPT(8)
WRITE(6,*) ' ',KEYOPT(9)
WRITE(6,*) ' ',KEYOPT(11)
WRITE(6,*) ' ',KEYOPT(12)
WRITE(6,*) ' ',KEYOPT(13)
WRITE(6,*) ' ',KEYOPT(14)
WRITE(6,*) ' ',KEYOPT(15)
WRITE(6,*) ' ',KEYOPT(16)
WRITE(6,*) ' ',KEYOPT(17)
WRITE(6,*)
STOP ' CHOOSE CORRECT OPTION '
END IF
GO TO 11
ELSE IF (STR3.EQ.KEYW(2)) THEN
RETURN
END IF
GO TO 1
RETURN
2 CONTINUE
WRITE(6,*)
$ ' NO BLOCK *INP ... *END FOUND ON FILE, taking default values
$ '
C folded 1 (fixf $Revision: 1.3 $)
RETURN
C
921 CONTINUE
CLOSE(IOINP)
STOP ' ERROR IN INPUT'
2217 CONTINUE
WRITE(6,*) ' NO FILE , USING THE DEFAULT VALUES'
RETURN
END
C
C
C..FILE 'morceau3.h'
C
SUBROUTINE GAMGEN(IOGAM)
INCLUDE 'param.h'
COMMON /SYMTAB/ SYMBAT(0:92),SYMLEN(0:92)
CHARACTER*2 SYMBAT
INTEGER*2 SYMLEN
CHARACTER*1 CST(10)
DIMENSION MDEGEN(0:4)
DATA CST /'S','P','D','F','G','H','I','J','K','L'/
DATA MDEGEN /1,3,6,10,15/
C.. INCLUDE 'common_symbols.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
DIMENSION COEFLI(NPRIMX),ISHLX(NLMAX),INDXX(NLMAX)
C
WRITE(6,*)
WRITE(6,*) ' GAMESS INPUT GENERATOR '
WRITE(6,*) ' =========================== '
WRITE(6,*)
WRITE(6,*)
WRITE(6,*)
C
C
C GAMESS format is
C $CONTRL SCFTYP=RHF RUNTYP=ENERGY COORD=UNIQUE
C UNITS=BOHR NOSYM=1 INTTYP=HONDO
C ITOL=30 ICUT=30 $END
C $GUESS GUESS=HUCKEL $END
C $INTGRL NOPK=1 NINTMX=2048 $END
C $MOROKM MOROKM=.FALSE. $END
C $DATA
C
9021 FORMAT(' $CONTRL SCFTYP=RHF RUNTYP=ENERGY COORD=UNIQUE',/
$ ,' UNITS=BOHR NOSYM=1 INTTYP=HONDO',/
$ ,' ITOL=30 ICUT=30 $END',/,' $GUESS GUESS=HCORE $END',/
$ ,' $SCF NCONV=9 $END',/,' $DATA')
9022 FORMAT(' $CONTRL SCFTYP=RHF RUNTYP=ENERGY COORD=UNIQUE',/
$ ,' UNITS=BOHR NOSYM=1 ISPHER=1 INTTYP=HONDO',/
$ ,' ITOL=30 ICUT=30 $END',/,' $GUESS GUESS=HCORE $END',/
$ ,' $SCF NCONV=9 $END',/,' $DATA')
9002 FORMAT('geninput_mol generated input for molecule ')
9005 FORMAT('C1')
9006 FORMAT(8X,A1,I10)
9007 FORMAT(10X,I4,2F22.12)
9008 FORMAT(' $END')
C
C the supermolecule
C
OPEN (UNIT=IOGAM,FILE='GAMESS.inp',FORM='FORMATTED',STATUS
$ ='UNKNOWN')
IF (L6D) THEN
WRITE(IOGAM,9021)
ELSE
WRITE(IOGAM,9022)
END IF
WRITE(IOGAM,9002)
WRITE(IOGAM,9005)
C
C initialize NUMAT
DO IAT=1,NATOM
NUMAT(NZ(IAT))=0
END DO
NUMAT(0)=0
C
IEX=0
ISHL=0
DO IAT=1,NATOM
IATTYP=NZ(IAT)
CHARGE=DBLE(IATTYP)
NUMAT(IATTYP)=NUMAT(IATTYP)+1
ILM=LMAX(IAT)+1
C
ILS=2
IF (SYMBAT(IATTYP)(2:2).EQ.' ') ILS=1
ILZ=1
IF (NUMAT(IATTYP).GT.9) ILZ=2
IF (NUMAT(IATTYP).GT.99) ILZ=3
IF (ILS.EQ.1) THEN
IF (ILZ.EQ.1) THEN
WRITE(IOGAM,9925) SYMBAT(IATTYP)(1:1),NUMAT(IATTYP)
$ ,CHARGE,(POS(J,IAT),J=1,3)
ELSE IF (ILZ.EQ.2) THEN
WRITE(IOGAM,9926) SYMBAT(IATTYP)(1:1),NUMAT(IATTYP)
$ ,CHARGE,(POS(J,IAT),J=1,3)
ELSE IF (ILZ.EQ.3) THEN
WRITE(IOGAM,9927) SYMBAT(IATTYP)(1:1),NUMAT(IATTYP)
$ ,CHARGE,(POS(J,IAT),J=1,3)
ELSE
STOP 'MORE THAN 1000 ATOMS'
END IF
ELSE IF (ILS.EQ.2) THEN
IF (ILZ.EQ.1) THEN
WRITE(IOGAM,9928) SYMBAT(IATTYP),NUMAT(IATTYP),CHARGE
$ ,(POS(J,IAT),J=1,3)
ELSE IF (ILZ.EQ.2) THEN
WRITE(IOGAM,9929) SYMBAT(IATTYP),NUMAT(IATTYP),CHARGE
$ ,(POS(J,IAT),J=1,3)
ELSE IF (ILZ.EQ.3) THEN
STOP ' 2 LETTERS AND 3 DIGITS FOR THE NUMBER'
ELSE
STOP 'MORE THAN 1000 ATOMS'
END IF
ELSE
STOP 'NEITHER 1 OR 2 LETTERS FOR ATOM SYMBOL'
END IF
C
C
C now we have to write the basis
C
ISHST=ISHL+1
LM=0
DO IISHL=1,NSH(IAT)
ISHL=ISHL+1
ILL=IL(ISHL)+1
WRITE(IOGAM,9006) CST(ILL),NPRIM(ISHL)
DO IPRIM=1,NPRIM(ISHL)
IEX=IEX+1
WRITE(IOGAM,9007) IPRIM,EXX(IEX),COEFF(ILL,IEX)
END DO
END DO
C
C close loop over atoms
WRITE(IOGAM,*)
C.. INCLUDE 'morceau3.h'
END DO
WRITE(IOGAM,9008)
CLOSE(IOGAM)
9925 FORMAT(A1,I1,8X,F10.4,3F17.10)
9926 FORMAT(A1,I2,7X,F10.4,3F17.10)
9927 FORMAT(A1,I3,6X,F10.4,3F17.10)
9928 FORMAT(A2,I1,7X,F10.4,3F17.10)
9929 FORMAT(A2,I2,6X,F10.4,3F17.10)
C
C and the script to run the GAMESS program
C
OPEN(UNIT=IOGAM,FILE='gamess_script',STATUS='UNKNOWN',FORM
$ ='FORMATTED')
WRITE(IOGAM,9919)
CLOSE(IOGAM)
9919 FORMAT(':',/,'GAMSCR="$TMPDIR"',/
$ ,' rm $GAMSCR/GAMESS.* ',/
$ ,' rungms GAMESS | tee gamess.output | grep FINAL',/
$ ,' cp $GAMSCR/GAMESS.PUNCH GAMESS.PUNCH',/
$ ,' cp $GAMSCR/GAMESS.DICTNRY GAMESS.DICTNRY',/
$ ,' cp $GAMSCR/GAMESS.dat GAMESS.dat',/
$ ,' rm $GAMSCR/GAMESS.*')
C
RETURN
END
C
SUBROUTINE MOLPRO(IOMOL)
INCLUDE 'param.h'
COMMON /SYMTAB/ SYMBAT(0:92),SYMLEN(0:92)
CHARACTER*2 SYMBAT
INTEGER*2 SYMLEN
CHARACTER*1 CST(10)
DIMENSION MDEGEN(0:4)
DATA CST /'S','P','D','F','G','H','I','J','K','L'/
DATA MDEGEN /1,3,6,10,15/
C.. INCLUDE 'common_symbols.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
CHARACTER*40 FSTR1,FSTR2
CHARACTER*1 CCB(10)
DATA CCB /'0','1','2','3','4','5','6','7','8','9'/
C
WRITE(6,*)
WRITE(6,*) ' MOLPRO INPUT GENERATOR '
WRITE(6,*) ' =========================== '
WRITE(6,*)
WRITE(6,*)
C
C MOLPRO format is
C basis
C s,#,exp1 ..... expn; all s-exponents
C c,first.last,c1....cn per contraction
C end
C
C follows the geometry
C
IF (LDFT) THEN
OPEN (UNIT=IOMOL,FILE='MOLDFT.inp',FORM='FORMATTED',STATUS
$ ='UNKNOWN')
WRITE(6,*) ' preparing input for the external DFT ORTHO/MOLPRO '
WRITE(6,*) ' default functional: LDA '
WRITE(6,*) ' for others please update the file MOLDFT.inp '
WRITE(6,*)
ELSE
OPEN (UNIT=IOMOL,FILE='MOLPRO.inp',FORM='FORMATTED',STATUS
$ ='UNKNOWN')
END IF
WRITE(IOMOL,9001)
9001 FORMAT ('***, MOLPRO input generated by ORTHO',/)
IF (L6D) WRITE(IOMOL,*) ' CARTESIAN'
WRITE(IOMOL,9002)
9002 FORMAT('BASIS')
C
C write basis sets
C
IEX=0
ISHL=0
IONE=1
DO IAT=1,NATOM
ISHST=ISHL+1
LM=0
DO IISHL=1,NSH(IAT)
ISHL=ISHL+1
ILL=IL(ISHL)+1
IF (NPRIM(ISHL).GT.1) THEN
I10=NPRIM(ISHL)/10
I1=NPRIM(ISHL)-I10*10
I1=I1+1
I10=I10+1
IF (NPRIM(ISHL).GE.10) THEN
c$$$ FSTR1='(A1,1H,,I2.2,'//CCB(I10)//CCB(I1)//'(1H,,E15.8),1H;)'
c$$$ FSTR2='(4HC,1.,I2,'//CCB(I10)//CCB(I1)//'(1H,,E15.8),1H;)'
FSTR1='(A1,1H,,I2.2,'//CCB(I10)//CCB(I1)//'(1H,,E19.12),1H;)'
FSTR2='(4HC,1.,I2,'//CCB(I10)//CCB(I1)//'(1H,,E19.12),1H;)'
ELSE
c$$$ FSTR1='(A1,1H,,I2.2,'//CCB(I1)//'(1H,,E15.8),1H;)'
c$$$ FSTR2='(4HC,1.,I1,'//CCB(I1)//'(1H,,E15.8),1H;)'
FSTR1='(A1,1H,,I2.2,'//CCB(I1)//'(1H,,E19.12),1H;)'
FSTR2='(4HC,1.,I1,'//CCB(I1)//'(1H,,E19.12),1H;)'
END IF
c$$$ WRITE(6,*) ' FSTR1 =|',FSTR1,'|'
c$$$ WRITE(6,*) ' FSTR2 =|',FSTR2,'|'
WRITE(IOMOL,FSTR1) CST(ILL),IAT,(EXX(IEX+J),J=1,NPRIM(ISHL))
WRITE(IOMOL,FSTR2) NPRIM(ISHL),(COEFF(ILL,IEX+J),J=1
$ ,NPRIM(ISHL))
ELSE
WRITE(IOMOL,9005) CST(ILL),IAT,EXX(IEX+1)
END IF
IEX=IEX+NPRIM(ISHL)
9005 FORMAT(A1,',',I2,',',E15.8,';')
END DO
END DO
WRITE(IOMOL,9003)
9003 FORMAT('END',//'gprint,basis',//)
C
C write geometry in XYZ format
C
IF (LDFT) THEN
WRITE(IOMOL,9960) NATOM
9960 FORMAT(/,'GEOMTYP=XYZ',//,'geometry={nosym;',/,I4,/
$ ,'generated by ORTHO')
ELSE
WRITE(IOMOL,9910) NATOM
9910 FORMAT(/,'GEOMTYP=XYZ',//,'geometry={',/,I4,/,'generated by ORTHO
$')
C folded 1 (fixf $Revision: 1.3 $)
END IF
DO IAT=1,NATOM
IF (IAT.LT.10) THEN
IF (SYMLEN(NZ(IAT)).EQ.1) THEN
WRITE(IOMOL,9911) SYMBAT(NZ(IAT)),IAT,(ANTOAU*POS(J,IAT),J=1,3)
ELSE
WRITE(IOMOL,9912) SYMBAT(NZ(IAT)),IAT,(ANTOAU*POS(J,IAT),J=1,3)
END IF
ELSE
IF (SYMLEN(NZ(IAT)).EQ.1) THEN
WRITE(IOMOL,9913) SYMBAT(NZ(IAT)),IAT,(ANTOAU*POS(J,IAT),J=1,3)
ELSE
WRITE(IOMOL,9914) SYMBAT(NZ(IAT)),IAT,(ANTOAU*POS(J,IAT),J=1,3)
END IF
END IF
END DO
c$$$ 9911 FORMAT(A1,I1,',',E15.8,',',E15.8,',',E15.8)
c$$$ 9912 FORMAT(A2,I1,',',E15.8,',',E15.8,',',E15.8)
c$$$ 9913 FORMAT(A1,I2,',',E15.8,',',E15.8,',',E15.8)
c$$$ 9914 FORMAT(A2,I2,',',E15.8,',',E15.8,',',E15.8)
9911 FORMAT(A1,I1,',',E19.12,',',E19.12,',',E19.12)
9912 FORMAT(A2,I1,',',E19.12,',',E19.12,',',E19.12)
9913 FORMAT(A1,I2,',',E19.12,',',E19.12,',',E19.12)
9914 FORMAT(A2,I2,',',E19.12,',',E19.12,',',E19.12)
C
C write number of electrons
C
IF (LDFT) THEN
WRITE(IOMOL,9956) NOCC,2*NOCC
9956 FORMAT('}',//,'matrop',/,'read,orb,orb',/,'include,VEC.TMP',/
$ ,'save,orb,2200.1,orbitals',/,'dens,densu,orb,',I2,/
$ ,'save,densu,2200.2,density',//,'dft,lda;',/
$ ,'density,2200.2;',/,'potential,2900.1',//,'matrop',/
$ ,'load,densu,den,2200.2',/,'coul,cc,densu',/,'exch,ex,densu'
$ ,/,'trace,ccoul,cc,densu',/,'trace,eexch,ex,densu',/
$ ,'load,dftp,triang,2900.1',/,'load,h01,h01',/
$ ,'add,gorch,h01,2.,cc,dftp',/,'write,gorch,gorch.mat,erase',
$ //,'table,ccoul,eexch,dftfun',/,'save,dftfun.tmp,new',//
$ ,'ks,lda;',/,'orbitals,2200.1',/,'wf,',I4,';',/,'maxit,4;',/
$ ,'---')
ELSE
WRITE(IOMOL,9915) NOCC*2
9915 FORMAT('}',//,'rhf;',/,'wf,',I4,';',//,'---')
END IF
C
CLOSE(IOMOL)
C
C and the script to run the MOLPRO program
C
OPEN(UNIT=IOMOL,FILE='molpro_script',STATUS='UNKNOWN',FORM
$ ='FORMATTED')
WRITE(IOMOL,9919)
CLOSE(IOMOL)
9919 FORMAT(':',/,' molpro < MOLPRO.inp | tee MOLPRO.output ')
C
RETURN
END
C
SUBROUTINE GAUSSN(IOGAU)
INCLUDE 'param.h'
COMMON /SYMTAB/ SYMBAT(0:92),SYMLEN(0:92)
CHARACTER*2 SYMBAT
INTEGER*2 SYMLEN
CHARACTER*1 CST(10)
DIMENSION MDEGEN(0:4)
DATA CST /'S','P','D','F','G','H','I','J','K','L'/
DATA MDEGEN /1,3,6,10,15/
C.. INCLUDE 'common_symbols.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
CHARACTER*30 FSTR1,FSTR2
CHARACTER*1 CCB(10)
DATA CCB /'0','1','2','3','4','5','6','7','8','9'/
C
WRITE(6,*)
WRITE(6,*) ' GAUSSIAN INPUT GENERATOR '
WRITE(6,*) ' =========================== '
WRITE(6,*)
WRITE(6,*)
C
C
C GAUSSIAN format is
C basis
C s,#,exp1 ..... expn; all s-exponents
C c,first.last,c1....cn per contraction
C end
C
C follows the geometry
C
OPEN (UNIT=IOGAU,FILE='Gaussian.inp',FORM='FORMATTED',STATUS
$ ='UNKNOWN')
IF (L6D) THEN
WRITE(IOGAU,9001) ICHGE
ELSE
WRITE(IOGAU,9002) ICHGE
END IF
9001 FORMAT ('$ RunGauss',/,'#P RHF/gen 6d 10f scf=tight '
$ ,'pop=full nosymm ',//,'GAUSSIAN input generated by ORTHO',//
$ ,I4,' 1')
9002 FORMAT ('$ RunGauss',/,'#P RHF/gen 5d 7f scf=tight '
- ,'pop=full nosymm ',//
$ ,'GAUSSIAN input generated by ORTHO',//,I4,' 1')
C
C write atoms and positions
C
DO IAT=1,NATOM
WRITE(IOGAU,9911) SYMBAT(NZ(IAT)),(POS(J,IAT)*ANTOAU,J=1,3)
9911 FORMAT(A2,3E17.8)
END DO
WRITE(IOGAU,*)
C
C write basis sets
C
IEX=0
ISHL=0
IONE=1
DO IAT=1,NATOM
WRITE(IOGAU,*) IAT,' 0'
ISHST=ISHL+1
LM=0
DO IISHL=1,NSH(IAT)
ISHL=ISHL+1
ILL=IL(ISHL)+1
WRITE(IOGAU,*) CST(ILL),NPRIM(ISHL),' 1.'
WRITE(IOGAU,'(2E20.12)') (EXX(IEX+J),COEFF(ILL,IEX+J),J=1
$ ,NPRIM(ISHL))
IEX=IEX+NPRIM(ISHL)
END DO
WRITE(IOGAU,*) '****'
END DO
WRITE(IOGAU,*)
C
CLOSE(IOGAU)
C
C and the script to run the GAUSSIAN program
C
OPEN(UNIT=IOGAU,FILE='gaussian_script',STATUS='UNKNOWN',FORM
$ ='FORMATTED')
WRITE(IOGAU,9919)
CLOSE(IOGAU)
9919 FORMAT(':',/,' rung98 Gaussian.inp Gaussian.out ')
C
RETURN
END
C
SUBROUTINE GENEUL(EUL1,EUL2,EUL3,ROTEUL)
INCLUDE 'param.h'
DIMENSION ROTEUL(3,3)
C generates a rotation matrix from 3 angles
C
C around z, around x, around z
C 0..360 0..180 0..360
NEUL=EUL1/360.D0
EUL1=EUL1-DBLE(NEUL*360)
NEUL=EUL2/180.D0
EUL2=EUL2-DBLE(NEUL*180)
NEUL=EUL3/360.D0
EUL3=EUL3-DBLE(NEUL*360)
WRITE(6,*)
WRITE(6,*) ' Rotation around three Euler angles'
WRITE(6,*) ' around z through angle :',EUL1,' degrees'
WRITE(6,*) ' around x through angle :',EUL2,' degrees'
WRITE(6,*) ' around z through angle :',EUL3,' degrees'
WRITE(6,*)
PI=ACOS(0.D0)*2.D0
EUL1=PI/180.D0*EUL1
EUL2=PI/180.D0*EUL2
EUL3=PI/180.D0*EUL3
S1=SIN(EUL1)
S2=SIN(EUL2)
S3=SIN(EUL3)
C1=COS(EUL1)
C2=COS(EUL2)
C3=COS(EUL3)
ROTEUL(1,1)= c1*c3 - c2*s1*s3
ROTEUL(1,2)=-c2*c3*s1 - c1*s3
ROTEUL(1,3)= s1*s2
ROTEUL(2,1)= c3*s1 + c1*c2*s3
ROTEUL(2,2)= c1*c2*c3 - s1*s3
ROTEUL(2,3)=-c1*s2
ROTEUL(3,1)= s2*s3
ROTEUL(3,2)= c3*s2
ROTEUL(3,3)= c2
RETURN
END
SUBROUTINE TURN
INCLUDE 'param.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
WRITE(6,*)
WRITE(6,*) ' applying the rotation around the Euler angles '
WRITE(6,*)
WRITE(6,9821) ((roteul(i,j),j=1,3),i=1,3)
9821 FORMAT(/,' the rotation matrix ',/,3(10X,3F10.6,/))
WRITE(6,*) ' initital positions '
DO IAT=1,NATOM
WRITE(6,'(I3,3F15.10)') IAT,(POS(J,IAT),J=1,3)
DO II=1,3
POS(II,IAT)=POS(II,IAT)-BARYZ(II)
END DO
END DO
DO IAT=1,NATOM
SUM1=0.D0
SUM2=0.D0
SUM3=0.D0
DO II=1,3
PPP=POS(II,IAT)
SUM1=SUM1+ROTEUL(1,II)*PPP
SUM2=SUM2+ROTEUL(2,II)*PPP
SUM3=SUM3+ROTEUL(3,II)*PPP
END DO
POS(1,IAT)=SUM1
POS(2,IAT)=SUM2
POS(3,IAT)=SUM3
END DO
WRITE(6,*)
WRITE(6,*) ' positions after the rotation '
DO IAT=1,NATOM
DO II=1,3
POS(II,IAT)=POS(II,IAT)+BARYZ(II)
END DO
WRITE(6,'(I3,3F15.10)') IAT,(POS(J,IAT),J=1,3)
END DO
RETURN
END
SUBROUTINE GBOCHUM
INCLUDE 'param.h'
COMMON /FLOW/ ROTEUL(3,3),EUL1,EUL2,EUL3,ICHGE,NGAUSS,LANGST
$ ,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT,LEULER,LSLATER
$ ,LEXPAND,LBOCHUM,LORTIN,LDALTIN
LOGICAL LANGST,LORTHO,L6D,LGAMESS,LMOLPRO,LGAUSS,LDALT,LDFT
- ,LEULER,LSLATER,LEXPAND,LBOCHUM,LORTIN,LDALTIN
COMMON /UNITS/ ANTOAU,IUNITV,IUNITR
C.. INCLUDE 'common_flow.h'
COMMON /SYST/ NBAS,NATOM,NSHL,NOCC,LLMAX
COMMON /BAS/ EXX(NPRIMX),COEFF(NLMAX,NPRIMX),NZ(NATMX),NSH(NATMX)
$ ,NPRIM(NSHLMX),IL(NSHLMX),NPX(NLMAX,NATMX),NREXP(NSHLMX)
COMMON /GEN/ EXXG(NPRIMX),COEFFG(NPRIMX,NPRIMX),LTAKE(NPRIMX)
COMMON /MOLCAS/EXXM(NLMAX,NPRIMX),COEFFM(NLMAX,NPRIMX),LMAX(NATMX)
$ ,NPPARL(NLMAX,NPRIMX),NPARL(NLMAX,NSHLMX),NUMAT(0:92)
LOGICAL LTAKE
COMMON /POSPOS/ POS(3,NATMX),DIST(NATMX),BARYZ(3)
C.. INCLUDE 'common_systab.h'
COMMON /SYMTAB/ SYMBAT(0:92),SYMLEN(0:92)
CHARACTER*2 SYMBAT
INTEGER*2 SYMLEN
CHARACTER*1 CST(10)
DIMENSION MDEGEN(0:4)
DATA CST /'S','P','D','F','G','H','I','J','K','L'/
DATA MDEGEN /1,3,6,10,15/
C.. INCLUDE 'common_symbols.h'
WRITE(6,*) ' not yet finished, work harder '
RETURN
RETURN
END
SUBROUTINE WSORTH
INCLUDE 'param.h'
C
C write a VERY short script for the ORTHO series of programs
C
WRITE(6,*) ' WE ARE DUMPING THE ORTHO SCRIPT TO '
OPEN(UNIT=IODAL,FILE='script_ortho',STATUS='UNKNOWN',FORM
$ ='FORMATTED')
WRITE(IODAL,9377)
9377 FORMAT(':',/,' intcal_mol | tee intcal.output',/
$ ,' ors_mol | tee ors_mol.output | grep ''ITER ''',/,' exit')
RETURN
END