|
nbo
|
|
0origin,
README,
ch3nh2.arc,
enable.for,
g90.man,
gennbo.for,
junk,
nbo.man,
nbo.src,
readme.g90,
readme.nbo
|
|
|
*****************************************************************************
N B O P R O G R A M
(SYSTEM INDEPENDENT ROUTINES)
LAST PROGRAM MODIFICATION: OCTOBER 22, 1991
!!! CRAY COMPILATION REQUIRES 64 BIT (-i64) INTEGERS !!!
(SEE, IN PARTICULAR, SR JOBOPT, SR NBOPEN, AND SR DEBYTE)
*****************************************************************************
MAIN SUBROUTINE:
SUBROUTINE NBO(CORE,NBOOPT,MEMORY)
JOB INITIALIZATION ROUTINES: (CALLED BY SR NBO)
SUBROUTINE NBOSET(NBOOPT)
SUBROUTINE JOBOPT(NBOOPT)
SUBROUTINE NBODIM(MEMORY)
NAO/NBO/NLMO FORMATION ROUTINES: (CALLED BY SR NBO)
SUBROUTINE NAODRV(DM,T,A)
SUBROUTINE NAOSIM(DM,T,A)
SUBROUTINE DMNAO(DM,T,A)
SUBROUTINE DMSIM(DM,T,A)
SUBROUTINE NBODRV(DM,T,A,MEMORY)
ROUTINES CALLED BY THE NAO DRIVERS:
SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF)
SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF)
SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR)
SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK)
SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO)
SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG)
ROUTINES CALLED BY SR NAO:
SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM)
SUBROUTINE ATDIAG(N,A,B,EVAL,C)
SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM)
SUBROUTINE NEWWTS(S,T,WT)
SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK)
SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK)
SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2,
+ LIST,IRPNAO)
SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
+ IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT)
SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO)
SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,IRPNAO)
ROUTINES CALLED BY THE NBO/NLMO DRIVERS:
SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
+ P,TA,HYB,VA,VB,TOPO)
SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
+ P,TA,HYB,VA,VB,TOPO)
SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
+ P,TA,HYB,VA,VB,TOPO,IFLG)
SUBROUTINE SRTNBO(T,BNDOCC)
SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR)
SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB)
SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN)
SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR)
SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB)
SUBROUTINE FNDMOL(IATOMS)
SUBROUTINE NBOCLA(BNDOCC,ACCTHR)
SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO)
SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR)
SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG)
SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR)
SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM)
SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,SIAB,NOCC,NAB)
SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX)
SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX)
SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC)
ROUTINES CALLED BY SR NATHYB, SR CHOOSE:
SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
FUNCTION IWPRJ(NCTR)
SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD)
SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP)
SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG)
SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI)
SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD)
SUBROUTINE FORMT(T,Q,POL)
SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
ROUTINES CALLED BY SR NLMO:
SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT,
+ NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL)
NBO ENERGETIC ANALYSIS ROUTINES:
SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE)
SUBROUTINE NBODEL(A,MEMORY,IDONE)
SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE,
+ ISPIN)
SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN)
SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK)
SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL)
NBO DIRECT ACCESS FILE (DAF) ROUTINES:
SUBROUTINE NBFILE(NEW,ERROR)
SUBROUTINE NBOPEN(NEW,ERROR)
SUBROUTINE NBWRIT(IX,NX,IDAR)
SUBROUTINE NBREAD(IX,NX,IDAR)
SUBROUTINE NBCLOS(SEQ)
SUBROUTINE NBINQR(IDAR)
SUBROUTINE FETITL(TITLE)
SUBROUTINE FEE0(EDEL,ETOT)
SUBROUTINE SVE0(EDEL)
SUBROUTINE FECOOR(ATCOOR)
SUBROUTINE FESRAW(S)
SUBROUTINE FEDRAW(DM,SCR)
SUBROUTINE FEFAO(F,IWFOCK)
SUBROUTINE FEAOMO(T,IT)
SUBROUTINE FEDXYZ(DXYZ,I)
SUBROUTINE SVNBO(T,OCC,ISCR)
SUBROUTINE FENBO(T,OCC,ISCR,NELEC)
SUBROUTINE FETNBO(T)
SUBROUTINE SVPNAO(T)
SUBROUTINE FEPNAO(T)
SUBROUTINE SVSNAO(S)
SUBROUTINE FESNAO(S)
SUBROUTINE SVTNAB(T)
SUBROUTINE FETNAB(T)
SUBROUTINE SVTLMO(T)
SUBROUTINE FETLMO(T)
SUBROUTINE SVTNHO(T)
SUBROUTINE FETNHO(T)
SUBROUTINE SVPPAO(DM)
SUBROUTINE FEPPAO(DM)
SUBROUTINE SVTNAO(T)
SUBROUTINE FETNAO(T)
SUBROUTINE SVNLMO(T)
SUBROUTINE FENLMO(T)
SUBROUTINE SVDNAO(DM)
SUBROUTINE FEDNAO(DM)
SUBROUTINE SVFNBO(F)
SUBROUTINE FEFNBO(F)
SUBROUTINE SVNEWD(DM)
SUBROUTINE FENEWD(DM)
SUBROUTINE FEINFO(ICORE,ISWEAN)
SUBROUTINE FEBAS(NSHELL,NEXP,ISCR)
FREE FORMAT INPUT ROUTINES:
SUBROUTINE STRTIN(LFNIN)
SUBROUTINE RDCRD
SUBROUTINE IFLD(INT,ERROR)
SUBROUTINE RFLD(REAL,ERROR)
SUBROUTINE HFLD(KEYWD,LENG,ENDD)
SUBROUTINE FNDFLD
FUNCTION EQUAL(IA,IB,L)
OTHER SYSTEM-INDEPENDENT I/O ROUTINES:
SUBROUTINE GENINP(NEWDAF)
SUBROUTINE NBOINP(NBOOPT,IDONE)
SUBROUTINE CORINP(IESS,ICOR)
SUBROUTINE CHSINP(IESS,ICHS)
SUBROUTINE DELINP(NBOOPT,IDONE)
SUBROUTINE RDCORE(JCORE)
SUBROUTINE WRPPNA(T,OCC,IFLG)
SUBROUTINE RDPPNA(T,OCC,IFLG)
SUBROUTINE WRTNAO(T,IFLG)
SUBROUTINE RDTNAO(DM,T,SCR,IFLG)
SUBROUTINE WRTNAB(T,IFLG)
SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG)
SUBROUTINE WRTNBO(T,BNDOCC,IFLG)
SUBROUTINE WRNLMO(T,DM,IFLG)
SUBROUTINE WRBAS(SCR,ISCR,LFN)
SUBROUTINE WRARC(SCR,ISCR,LFN)
SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG)
SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL)
SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN)
SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR)
SUBROUTINE ALTOUT(A,MR,MC,NR,NC)
SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR)
FUNCTION IOINQR(IFLG)
SUBROUTINE LBLAO
SUBROUTINE LBLNAO
SUBROUTINE LBLNBO
SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR)
GENERAL UTILITY ROUTINES:
SUBROUTINE ANGLES(X,Y,Z,THETA,PHI)
FUNCTION BDFIND(IAT,JAT)
SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR)
SUBROUTINE CONSOL(AUT,ALT,NDIM,N)
SUBROUTINE CONVIN(IJ,LEN,IK,ERROR)
SUBROUTINE CONVRT(N,NC1,NC2)
SUBROUTINE COPY(A,B,NDIM,NR,NC)
SUBROUTINE CORTBL(IAT,ICORE,IECP)
SUBROUTINE DEBYTE(I,IBYTE)
SUBROUTINE HALT(WORD)
SUBROUTINE IDIGIT(KINT,IK,ND,MAXD)
FUNCTION IHTYP(IBO,JBO)
SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR)
SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT)
SUBROUTINE MATMLT(A,B,V,NDIM,N)
SUBROUTINE MATML2(A,B,V,NDIM,N)
FUNCTION NAMEAT(IZ)
SUBROUTINE NORMLZ(A,S,M,N)
SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK)
SUBROUTINE PACK(T,NDIM,NBAS,L2)
SUBROUTINE RANK(EIG,N,NDIM,ARCRNK)
SUBROUTINE SIMTRN(A,T,V,NDIM,N)
SUBROUTINE SIMTRS(A,S,V,NDIM,N)
SUBROUTINE TRANSP(A,NDIM,N)
SUBROUTINE UNPACK(T,NDIM,NBAS,L2)
SUBROUTINE VALTBL(IAT,IVAL)
FUNCTION VECLEN(X,N,NDIM)
SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR,
+ IERR)
SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG)
SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR)
SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM)
*****************************************************************************
SUBROUTINE NBO(CORE,MEMORY,NBOOPT)
*****************************************************************************
Input:
CORE Core memory to be dynamically allocated for storage needs.
MEMORY The number of REAL*8 words available in `CORE'.
NBOOPT(10) List of NBO options as summarized below:
NBOOPT(1) = -2 Do nothing
= -1 Natural Population Analysis (NPA) only
= 0 Perform NPA/NBO/NLMO analyses
= 1 Perform NPA/NBO/NLMO analyses, don't read keywords
= 2 Perform one Fock matrix deletion, forming new DM
= 3 Evaluate and print the energy change from deletion
NBOOPT(2) = 0 SCF density
= 1 MP first order density
= 3 MP2 density
= 4 MP3 density
= 5 MP4 density
= 6 CI one-particle density
= 7 CI density
= 8 QCI/CC density
= 9 Density correct to second order
NBOOPT(3) = 1 Transform dipole moment matrices to NBO/NLMO bases
NBOOPT(4) = 1 Allow strongly resonant Lewis Structures
(Force the RESONANCE keyword)
NBOOPT(5) = 1 Spin-annihilated UHF (AUHF) wavefunction
NBOOPT(6-9) Unused
NBOOPT(10) = 0 General version of the NBO program (GENNBO)
= 1 AMPAC version
= 6 GAMESS version
= 7 HONDO version
= 8x Gaussian 8x version
------------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL NEWDAF,ERROR,SEQ
NBO COMMON BLOCKS:
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION CORE(MEMORY),NBOOPT(10)
IF NBOOPT(1).EQ.-2, THEN NO NBO ANALYSIS WAS REQUESTED:
IF(NBOOPT(1).EQ.-2) RETURN
SET DEFAULT OPTIONS:
CALL NBOSET(NBOOPT)
IF THIS IS THE GENERAL VERSION OF THE PROGRAM, READ THE $GENNBO KEYLIST:
IF(NBOOPT(10).EQ.0) THEN
CALL GENINP(NEWDAF)
ELSE
NEWDAF = .TRUE.
END IF
SEARCH THE INPUT FILE FOR THE $NBO KEYLIST:
CALL NBOINP(NBOOPT,IDONE)
IF(IDONE.EQ.1) RETURN
READ IN JOB OPTIONS FROM THE $NBO KEYLIST:
CALL JOBOPT(NBOOPT)
CHECK FILENAME AND OPEN SEQUENTIAL FILES:
CALL NBFILE(NEWDAF,ERROR)
IF(ERROR) RETURN
OPEN THE NBO DIRECT ACCESS FILE:
CALL NBOPEN(NEWDAF,ERROR)
IF(ERROR) THEN
WRITE(LFNPR,900)
RETURN
END IF
FETCH ATOMS, BASIS, AND WAVE FUNCTION INFORMATION:
CALL FEAOIN(CORE,CORE,NBOOPT)
IF(COMPLX) RETURN
WRITE THE JOB TITLE TO THE OUTPUT FILE:
CALL FETITL(CORE)
WRITE(LFNPR,910) (CORE(I),I=1,8)
SET UP DIMENSIONING INFORMATION AND DETERMINE IF ENOUGH SPACE IS AVAILABLE:
CALL NBODIM(MEMORY)
SET UP BASIC STORAGE:
CORE(NDM) : NDIM BY NDIM MATRIX TO STORE DENSITY MATRIX
CORE(NT) : NDIM BY NDIM MATRIX TO HOLD OVERLAP OR TRANSFORMATION MATRICES
CORE(NSCR): SCRATCH STORAGE, DYNAMICALLY ALLOCATED ACCORDING NEEDS
N2 = NDIM*NDIM
NDM = 1
NT = NDM + N2
NSCR = NT + N2
MEM = MEMORY - NSCR + 1
READ IN INPUT OVERLAP AND DENSITY MATRICES, AO BASIS:
ALPHA = .FALSE.
BETA = .FALSE.
ISPIN = 0
CALL FEDRAW(CORE(NDM),CORE(NSCR))
SIMULATE THE NATURAL POPULATION ANALYSIS IF THE INPUT BASIS IS ORTHOGONAL:
IF(ORTHO) THEN
CALL NAOSIM(CORE(NDM),CORE(NT),CORE(NSCR))
LOAD THE OVERLAP MATRIX INTO CORE(NT) AND PERFORM THE NATURAL POPULATION
ANALYSIS:
ELSE
CALL FESRAW(CORE(NT))
CALL NAODRV(CORE(NDM),CORE(NT),CORE(NSCR))
END IF
NOTE: CORE(NDM) NOW CONTAINS THE TOTAL DENSITY MATRIX IN THE NAO BASIS
AND CORE(NT) CONTAINS THE AO TO NAO TRANSFORMATION
PERFORM CLOSED SHELL NBO ANALYSIS:
IF(.NOT.OPEN) THEN
CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM)
ELSE
PERFORM OPEN SHELL NBO ANALYSIS:
FIRST, ANALYZE ALPHA DENSITY MATRIX:
ALPHA = .TRUE.
BETA = .FALSE.
ISPIN = 2
IF(ORTHO) THEN
CALL DMSIM(CORE(NDM),CORE(NT),CORE(NSCR))
ELSE
CALL DMNAO(CORE(NDM),CORE(NT),CORE(NSCR))
END IF
CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM)
NOW, ANALYZE BETA DENSITY MATRIX:
ALPHA = .FALSE.
BETA = .TRUE.
ISPIN = -2
IF(ORTHO) THEN
CALL DMSIM(CORE(NDM),CORE(NT),CORE(NSCR))
ELSE
CALL DMNAO(CORE(NDM),CORE(NT),CORE(NSCR))
END IF
CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM)
END IF
CLOSE THE NBO DIRECT ACCESS FILE AND OTHER EXTERNAL FILES:
SEQ = .TRUE.
CALL NBCLOS(SEQ)
RETURN
900 FORMAT(/1X,'NBO direct access file could not be opened. NBO ',
+ 'program aborted.')
910 FORMAT(/1X,'Job title: ',8A8)
END
*****************************************************************************
JOB INITIALIZATION ROUTINES: (CALLED BY SR NBO)
SUBROUTINE NBOSET(NBOOPT)
SUBROUTINE JOBOPT(NBOOPT)
SUBROUTINE NBODIM(MEMORY)
*****************************************************************************
SUBROUTINE NBOSET(NBOOPT)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION NBOOPT(10)
PARAMETER(MAXATM = 99,MAXBAS = 500)
PARAMETER(MAXFIL = 40)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBLBL/NLEW,NVAL,LBL(10,MAXBAS,4)
COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
CHARACTER*80 FILENM
DATA TENTH,HALF/0.1D0,0.5D0/
SET DEFAULT JOB OPTIONS: (MODIFICATIONS TO THESE DEFAULTS
SHOULD NOT BE MADE HERE BUT LATER IN THIS SUBROUTINE)
USE THE BOND-ORDER MATRIX, NOT THE OCCUPATION MATRIX (EXPECTATION
VALUES OF THE DENSITY OPERATOR)
IWDM = 1
IW3C = 0
IWAPOL = 0
IWHYBS = 0
IWPNAO = 0
IWTNAO = 0
IWTNAB = 0
IWTNBO = 0
USE THE FOCK MATRIX, IF THERE IS ONE:
IWFOCK = 1
SET TO THE DESIRED PRINT LEVEL + 10:
IPRINT = 12
IPSEUD = 0
IWDETL = 0
IWMULP = 0
ICHOOS = 0
KOPT = 0
JCORE = 0
IWCUBF = 0
OPEN = .FALSE.
ORTHO = .FALSE.
UHF = .FALSE.
AUHF = .FALSE.
ROHF = .FALSE.
CI = .FALSE.
MCSCF = .FALSE.
COMPLX = .FALSE.
DO 10 I = 1,60
JPRINT(I) = 0
10 CONTINUE
LFNAO = 31
LFNPNA = 32
LFNNAO = 33
LFNPNH = 34
LFNNHO = 35
LFNPNB = 36
LFNNBO = 37
LFNPNL = 38
LFNNLM = 39
LFNMO = 40
LFNDM = 41
LFNNAB = 42
LFNPPA = 43
LFNARC = 47
SET POSITIVE IN ROUTINE JOBOPT IF CHOSEN BY THE USER:
LFNDAF = -48
LFNDEF = 49
SETTING NVAL NEGATIVE INDICATES THAT THIS VARIABLE HAS NOT
BEEN DETERMINED YET:
NVAL = -1
INITIALIZE THE CHARACTER STRING USED TO CREATE FILENAMES:
FILENM(1:4) = 'FILE'
DO 50 I = 5,80
FILENM(I:I) = CHAR(32)
50 CONTINUE
THAT SOME THRESHOLDS ARE .LT.0 INDICATES THAT THESE VARIABLES HAVE NOT
BEEN SET BY THE USER:
THRSET = -1.9D0
PRJSET = -0.2D0
ACCTHR = -TENTH
CRTSET = 1.999
E2THR = -HALF
ATHR = -1.000
PTHR = -25.000
ETHR = -0.100
DTHR = -0.020
DLTHR = -1.000
CHSTHR = -0.100
SET JOB OPTIONS ACCORDING TO NBOOPT:
SKIP THE COMPUTATION OF THE NBOS?
IF(NBOOPT(1).EQ.-1) JPRINT(1) = 1
TURN OFF $CHOOSE AND $CORE KEYLISTS IF $NBO KEYLIST IS NOT TO
BE READ:
IF(NBOOPT(1).EQ.1) ICHOOS = -1
IF(NBOOPT(1).EQ.1) JCORE = -1
FORCE DIPOLE ANALYSIS?
IF(NBOOPT(3).NE.0) THEN
JPRINT(46) = 1
END IF
FORCE RESONANCE KEYWORD?
IF(NBOOPT(4).NE.0) JPRINT(14) = 1
PROGRAM VERSION:
JPRINT(2) = NBOOPT(10)
RETURN
END
******************************************************************************
SUBROUTINE JOBOPT(NBOOPT)
******************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR,END,EQUAL,NEXTWD,READ
DIMENSION NBOOPT(10),INTTMP(80)
PARAMETER(KEYLEN = 9)
PARAMETER(MAXFIL = 40)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
CHARACTER*80 FILENM
DIMENSION KEYWD(KEYLEN),K3CBND(6),KEPERT(6),KLFNPR(5),KTHRSH(6),
* KDETL(6),KMULA(5),KMULOR(6),KPRJTH(6),KNBNLM(7),
* KAOPRE(6),KNLMO(4),KNAOMO(5),KNBOMO(5),KNOBND(6),KNPA(3),
* KSKIPB(6),KRPNAO(5),KBNDID(6),KNLMMO(6),KRESON(5),KPPNAO(7),
* KAONAO(5),KNANBO(6),KAONBO(5),KAONLM(6),KFNBO(4),KFNLMO(5),
* KDMNBO(5),KDMNLM(6),KPRINT(5),KNANLM(7),KSPNAO(5),KSPNHO(5),
* KSPNBO(5),KAOINF(6),KAOPNB(6),KAOMO(4),KNAONH(6),KNHNLM(7),
* KAONHO(5),KFNHO(4),KAOPNH(6),KFNAO(4),KNHONB(6),KSPNLM(6),
* KNRT(3),KDMNHO(5),KDMNAO(5),KPLOT(4),KAOPNL(7),KDIAO(4),
* KBEND(4),KNHOMO(5),KSAO(3),KFAO(3),KDMAO(4),KBOAO(4),KDINLM(6),
* KNBOSM(6),KNBO(3),KDIPOL(6),KDINAO(5),KDINHO(5),KDINBO(5),
* KNBDAF(6),KARCHV(7),KFILE(4),KPOLAR(6),KNRTOP(6),KNRTRF(6),
* KCHSTH(6),KNRTDT(6),KNRTTH(6)
DIMENSION KALT(4),KBFGS(4),KPOWEL(6),KSAP(3)
DATA K3CBND/1H3,1HC,1HB,1HO,1HN,1HD/,KLFNPR/1HL,1HF,1HN,1HP,1HR/,
* KTHRSH/1HT,1HH,1HR,1HE,1HS,1HH/,KEPERT/1HE,1H2,1HP,1HE,1HR,1HT/,
* KPLOT/1HP,1HL,1HO,1HT/,KDETL/1HD,1HE,1HT,1HA,1HI,1HL/,
* KMULA/1HM,1HU,1HL,1HA,1HT/,KMULOR/1HM,1HU,1HL,1HO,1HR,1HB/,
* KPRJTH/1HP,1HR,1HJ,1HT,1HH,1HR/,KAOPRE/1HA,1HO,1HP,1HN,1HA,1HO/,
* KNLMO/1HN,1HL,1HM,1HO/,KNPA/1HN,1HP,1HA/,KNBO/1HN,1HB,1HO/,
* KNAOMO/1HN,1HA,1HO,1HM,1HO/,KNBOMO/1HN,1HB,1HO,1HM,1HO/,
* KNOBND/1HN,1HO,1HB,1HO,1HN,1HD/,KSKIPB/1HS,1HK,1HI,1HP,1HB,1HO/,
* KRPNAO/1HR,1HP,1HN,1HA,1HO/,KBNDID/1HB,1HN,1HD,1HI,1HD,1HX/,
* KNLMMO/1HN,1HL,1HM,1HO,1HM,1HO/,KRESON/1HR,1HE,1HS,1HO,1HN/,
* KPPNAO/1HP,1HA,1HO,1HP,1HN,1HA,1HO/,KAONAO/1HA,1HO,1HN,1HA,1HO/,
* KNANBO/1HN,1HA,1HO,1HN,1HB,1HO/,KAONBO/1HA,1HO,1HN,1HB,1HO/
DATA KAONLM/1HA,1HO,1HN,1HL,1HM,1HO/,KFNBO/1HF,1HN,1HB,1HO/,
* KFNLMO/1HF,1HN,1HL,1HM,1HO/,KPRINT/1HP,1HR,1HI,1HN,1HT/,
* KDMNBO/1HD,1HM,1HN,1HB,1HO/,KDMNLM/1HD,1HM,1HN,1HL,1HM,1HO/,
* KNANLM/1HN,1HA,1HO,1HN,1HL,1HM,1HO/,KAOMO/1HA,1HO,1HM,1HO/,
* KSPNAO/1HS,1HP,1HN,1HA,1HO/,KSPNHO/1HS,1HP,1HN,1HH,1HO/,
* KSPNBO/1HS,1HP,1HN,1HB,1HO/,KFNAO/1HF,1HN,1HA,1HO/,
* KAOINF/1HA,1HO,1HI,1HN,1HF,1HO/,KAOPNB/1HA,1HO,1HP,1HN,1HB,1HO/,
* KAONHO/1HA,1HO,1HN,1HH,1HO/,KFNHO/1HF,1HN,1HH,1HO/,
* KAOPNH/1HA,1HO,1HP,1HN,1HH,1HO/,KNRT/1HN,1HR,1HT/,
* KNBNLM/1HN,1HB,1HO,1HN,1HL,1HM,1HO/,KDIAO/1HD,1HI,1HA,1HO/,
* KDMNHO/1HD,1HM,1HN,1HH,1HO/,KDMNAO/1HD,1HM,1HN,1HA,1HO/,
* KBEND/1HB,1HE,1HN,1HD/,KNBOSM/1HN,1HB,1HO,1HS,1HU,1HM/,
* KNHOMO/1HN,1HH,1HO,1HM,1HO/,KSAO/1HS,1HA,1HO/,KFAO/1HF,1HA,1HO/
DATA KDMAO/1HD,1HM,1HA,1HO/,KBOAO/1HB,1HO,1HA,1HO/,
* KDIPOL/1HD,1HI,1HP,1HO,1HL,1HE/,KNAONH/1HN,1HA,1HO,1HN,1HH,1HO/,
* KNHNLM/1HN,1HH,1HO,1HN,1HL,1HM,1HO/,KDINAO/1HD,1HI,1HN,1HA,1HO/,
* KNHONB/1HN,1HH,1HO,1HN,1HB,1HO/,KSPNLM/1HS,1HP,1HN,1HL,1HM,1HO/,
* KAOPNL/1HA,1HO,1HP,1HN,1HL,1HM,1HO/,KDINHO/1HD,1HI,1HN,1HH,1HO/,
* KDINBO/1HD,1HI,1HN,1HB,1HO/,KDINLM/1HD,1HI,1HN,1HL,1HM,1HO/,
* KNBDAF/1HN,1HB,1HO,1HD,1HA,1HF/,
* KARCHV/1HA,1HR,1HC,1HH,1HI,1HV,1HE/,KFILE/1HF,1HI,1HL,1HE/,
* KPOLAR/1HA,1HP,1HO,1HL,1HA,1HR/,KNRTOP/1HN,1HR,1HT,1HO,1HP,1HT/,
* KNRTRF/1HN,1HR,1HT,1HR,1HE,1HF/,KCHSTH/1HC,1HH,1HS,1HT,1HH,1HR/,
* KNRTDT/1HN,1HR,1HT,1HD,1HT,1HL/,
* KNRTTH/1HN,1HR,1HT,1HT,1HH,1HR/
DATA KALT/1H$,1HE,1HN,1HD/,KBFGS/1HB,1HF,1HG,1HS/,
* KPOWEL/1HP,1HO,1HW,1HE,1HL,1HL/,KSAP/1HS,1HA,1HP/
DATA ZERO,ONE/0.0D0,1.0D0/
DATA IFULL,IVAL,ILEW/4HFULL,3HVAL,3HLEW/
DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/
DATA IA,IB,IP/1HA,1HB,1HP/
READ IN JOB OPTIONS, IN A KEYWORD DIRECTED MANNER:
NUMOPT = 0
LENNM = 0
IF(NBOOPT(1).EQ.1) GOTO 4500
BEGIN LOOP TO IDENTIFY KEYWORD "KEYWD":
NEXTWD = .TRUE.
100 LENG = KEYLEN
IF(NEXTWD) CALL HFLD(KEYWD,LENG,END)
NEXTWD = .TRUE.
IF((LENG.EQ.0).OR.END) GO TO 4500
IF(EQUAL(KEYWD,KALT,4)) GO TO 4500
NUMOPT = NUMOPT + 1
KEYWORD: 3CBOND -- SEARCH FOR THREE-CENTER BONDS
(DEFAULT IS TO SEARCH ONLY FOR ONE- AND TWO-CENTER NBOS)
IF(.NOT.EQUAL(KEYWD,K3CBND,6)) GO TO 500
IW3C = 1
GO TO 100
KEYWORD: LFNPR -- SPECIFY OUTPUT LFN
500 IF(.NOT.EQUAL(KEYWD,KLFNPR,5)) GO TO 510
CALL IFLD(LFNPR,ERROR)
IF(ERROR) CALL HALT('LFNPR')
GO TO 100
KEYWORD: THRESH -- SPECIFY FIXED OCCUPANCY THRESHOLD FOR NBO SEARCH
510 IF(.NOT.EQUAL(KEYWD,KTHRSH,6)) GO TO 540
CALL RFLD(THRSET,ERROR)
IF(ERROR) CALL HALT('THRESH')
GO TO 100
KEYWORD: DETAIL -- PRINT DETAILS OF NBO SEARCH PROCEDURE
540 IF(.NOT.EQUAL(KEYWD,KDETL,6)) GO TO 550
IWDETL = 1
GO TO 100
KEYWORD: MULAT -- PRINT MULLIKEN POPULATIONS BY ATOM
550 IF(.NOT.EQUAL(KEYWD,KMULA,5)) GO TO 560
IWMULP = 1
GO TO 100
KEYWORD: MULORB -- PRINT MULLIKEN POPULATIONS BY ORBITAL AND ATOM
560 IF(.NOT.EQUAL(KEYWD,KMULOR,6)) GO TO 580
IWMULP = 2
GO TO 100
KEYWORD: PRJTHR -- USER SETS VALUE OF PROJECTION THRESHOLD FOR NBO SEARCH
FOR REJECTING LINEARLY DEPENDENT HYBRIDS
580 IF(.NOT.EQUAL(KEYWD,KPRJTH,6)) GO TO 610
CALL RFLD(PRJSET,ERROR)
IF(ERROR) CALL HALT('PRJTHR')
GO TO 100
KEYWORD: FNBO -- PRINT NBO FOCK MATRIX
610 IF(.NOT.EQUAL(KEYWD,KFNBO,4)) GO TO 620
JPRINT(37) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(37),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(37).EQ.IVAL) JPRINT(37) = IFULL
END IF
GO TO 100
KEYWORD: AOPNAO -- OUTPUT RAW AO TO PNAO TRANSFORMATION
620 IF(.NOT.EQUAL(KEYWD,KAOPRE,6)) GO TO 640
JPRINT(44) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(44),LFNPNA,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(44).EQ.IVAL) JPRINT(44) = IFULL
IF(JPRINT(44).EQ.ILEW) JPRINT(44) = IFULL
END IF
GO TO 100
KEYWORD: NLMOMO -- COMPUTE AND PRINT NLMO TO MO TRANSF.
640 IF(.NOT.EQUAL(KEYWD,KNLMMO,6)) GO TO 650
JPRINT(13) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(13),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
END IF
GO TO 100
KEYWORD: NLMO -- COMPUTE AND PRINT NLMOS
650 IF(.NOT.EQUAL(KEYWD,KNLMO,4)) GO TO 660
IF(LENG.NE.4) GO TO 660
JPRINT(8) = 1
GO TO 100
KEYWORD: NAOMO -- COMPUTE AND PRINT NAO TO MO TRANSF.
660 IF(.NOT.EQUAL(KEYWD,KNAOMO,5)) GO TO 670
JPRINT(9) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(9),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
END IF
GO TO 100
KEYWORD: NBOMO -- COMPUTE AND PRINT NBO TO MO TRANSF.
670 IF(.NOT.EQUAL(KEYWD,KNBOMO,5)) GO TO 680
JPRINT(45) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(45),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
END IF
GO TO 100
KEYWORD: NOBOND -- COMPUTE ONLY ONE-CENTER NBOS
680 IF(.NOT.EQUAL(KEYWD,KNOBND,6)) GO TO 690
JPRINT(10) = 1
GO TO 100
KEYWORD: SKIPBO -- SKIP NBO PROCEDURE
690 IF(.NOT.EQUAL(KEYWD,KSKIPB,6)) GO TO 700
JPRINT(1) = 1
GO TO 100
KEYWORD: RPNAO -- COMPUTE REVISED PURE AO TO PNAO TRANSF.
700 IF(.NOT.EQUAL(KEYWD,KRPNAO,5)) GO TO 710
JPRINT(11) = 1
GO TO 100
KEYWORD: BNDIDX -- PRINT BOND INDICES
710 IF(.NOT.EQUAL(KEYWD,KBNDID,6)) GO TO 730
JPRINT(12) = 1
GO TO 100
KEYWORD: RESONANCE -- ALLOW STRONGLY "NON-LEWIS" NBO OCCUPANCIES
(OVERRIDES AUTOMATIC SHUTDOWN OF NBO PROCEDURE IN STRONGLY
DELOCALIZED CASES)
730 IF(.NOT.EQUAL(KEYWD,KRESON,5)) GO TO 740
JPRINT(14) = 1
GO TO 100
KEYWORD: PAOPNAO -- I/O WITH PAO TO PNAO TRANSFORMATION
740 IF(.NOT.EQUAL(KEYWD,KPPNAO,7)) GO TO 750
IWPNAO = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .TRUE.
CALL KEYPAR(KEYWD,LENG,IWPNAO,LFNPPA,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(IWPNAO.EQ.IVAL) IWPNAO = IFULL
IF(IWPNAO.EQ.ILEW) IWPNAO = IFULL
END IF
GO TO 100
KEYWORD: AONAO -- I/O WITH AO TO NAO TRANSFORMATION
750 IF(.NOT.EQUAL(KEYWD,KAONAO,5)) GO TO 760
IWTNAO = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .TRUE.
CALL KEYPAR(KEYWD,LENG,IWTNAO,LFNNAO,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(IWTNAO.EQ.IVAL) IWTNAO = IFULL
IF(IWTNAO.EQ.ILEW) IWTNAO = IFULL
END IF
GO TO 100
KEYWORD: NAONBO -- I/O WITH NAO TO NBO TRANSFORMATION
760 IF(.NOT.EQUAL(KEYWD,KNANBO,6)) GO TO 770
IWTNAB = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .TRUE.
CALL KEYPAR(KEYWD,LENG,IWTNAB,LFNNAB,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(IWTNAB.EQ.IVAL) IWTNAB = IFULL
END IF
GO TO 100
KEYWORD: AONBO -- OUTPUT AO TO NBO TRANSF. INFORMATION
770 IF(.NOT.EQUAL(KEYWD,KAONBO,5)) GO TO 780
IWTNBO = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,IWTNBO,LFNNBO,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(IWTNBO.EQ.IVAL) IWTNBO = IFULL
END IF
GO TO 100
KEYWORD: FNLMO -- PRINT NLMO FOCK MATRIX
780 IF(.NOT.EQUAL(KEYWD,KFNLMO,5)) GO TO 790
JPRINT(15) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(15),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(15).EQ.IVAL) JPRINT(15) = IFULL
END IF
GO TO 100
KEYWORD: DMNBO -- PRINT NBO DENSITY MATRIX
790 IF(.NOT.EQUAL(KEYWD,KDMNBO,5)) GO TO 800
JPRINT(16) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(16),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(16).EQ.IVAL) JPRINT(16) = IFULL
END IF
GO TO 100
KEYWORD: DMNLMO -- PRINT NLMO DENSITY MATRIX
800 IF(.NOT.EQUAL(KEYWD,KDMNLM,6)) GO TO 810
JPRINT(17) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(17),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(17).EQ.IVAL) JPRINT(17) = IFULL
END IF
GO TO 100
KEYWORD: AONLMO -- COMPUTE AND OUTPUT AO TO NLMO TRANSF.
810 IF(.NOT.EQUAL(KEYWD,KAONLM,6)) GO TO 820
JPRINT(23) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(23),LFNNLM,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(23).EQ.IVAL) JPRINT(23) = IFULL
END IF
GO TO 100
KEYWORD: PRINT -- READ IN PRINT OPTION LEVEL "IPRINT"
820 IF(.NOT.EQUAL(KEYWD,KPRINT,5)) GO TO 830
CALL IFLD(IPRINT,ERROR)
IF(ERROR) CALL HALT('PRINT')
GO TO 100
KEYWORD: NAONLMO -- PRINT NAO TO NLMO TRANSFORMATION MATRIX
830 IF(.NOT.EQUAL(KEYWD,KNANLM,7)) GO TO 840
JPRINT(18) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(18),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(18).EQ.IVAL) JPRINT(18) = IFULL
END IF
GO TO 100
KEYWORD: SPNAO -- PRINT S-PNAO OVERLAP MATRIX
840 IF(.NOT.EQUAL(KEYWD,KSPNAO,5)) GO TO 850
JPRINT(19) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(19),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(19).EQ.IVAL) JPRINT(19) = IFULL
IF(JPRINT(19).EQ.ILEW) JPRINT(19) = IFULL
END IF
GO TO 100
KEYWORD: SPNHO -- PRINT S-PNHO OVERLAP MATRIX
850 IF(.NOT.EQUAL(KEYWD,KSPNHO,5)) GO TO 860
JPRINT(20) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(20),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(20).EQ.IVAL) JPRINT(20) = IFULL
IF(JPRINT(20).EQ.ILEW) JPRINT(20) = IFULL
END IF
GO TO 100
KEYWORD: NHONLMO -- OUTPUT THE NHO TO NLMO TRANSFORMATION
860 IF(.NOT.EQUAL(KEYWD,KNHNLM,7)) GO TO 870
JPRINT(24) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(24),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(24).EQ.IVAL) JPRINT(24) = IFULL
END IF
GO TO 100
KEYWORD: SPNBO -- PRINT S-PNBO OVERLAP MATRIX
870 IF(.NOT.EQUAL(KEYWD,KSPNBO,5)) GO TO 880
JPRINT(21) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(21),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(21).EQ.IVAL) JPRINT(21) = IFULL
END IF
GO TO 100
KEYWORD: AOINFO -- WRITE BASIS SET INFO
880 IF(.NOT.EQUAL(KEYWD,KAOINF,6)) GO TO 910
JPRINT(22) = LFNAO
CALL IFLD(ITEMP,ERROR)
IF(.NOT.ERROR) JPRINT(22) = ABS(ITEMP)
GO TO 100
KEYWORD: AOPNBO -- WRITE AO TO PNBO TRANSFORMATION
910 IF(.NOT.EQUAL(KEYWD,KAOPNB,6)) GO TO 920
JPRINT(25) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(25),LFNPNB,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(25).EQ.IVAL) JPRINT(25) = IFULL
END IF
GO TO 100
KEYWORD: AOMO -- WRITE AO TO MO TRANSFORMATION
920 IF(.NOT.EQUAL(KEYWD,KAOMO,4)) GO TO 930
JPRINT(26) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(26),LFNMO,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
END IF
GO TO 100
KEYWORD: DMAO -- WRITE AO DENSITY MATRIX
930 IF(.NOT.EQUAL(KEYWD,KDMAO,4)) GO TO 940
JPRINT(27) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(27),LFNDM,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(27).EQ.IVAL) JPRINT(27) = IFULL
IF(JPRINT(27).EQ.ILEW) JPRINT(27) = IFULL
END IF
GO TO 100
KEYWORD: AONHO -- WRITE AO TO NHO TRANSFORMATION
940 IF(.NOT.EQUAL(KEYWD,KAONHO,5)) GO TO 950
JPRINT(28) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(28),LFNNHO,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(28).EQ.IVAL) JPRINT(28) = IFULL
IF(JPRINT(28).EQ.ILEW) JPRINT(28) = IFULL
END IF
GO TO 100
KEYWORD: FNHO -- PRINT NHO FOCK MATRIX
950 IF(.NOT.EQUAL(KEYWD,KFNHO,4)) GO TO 960
JPRINT(29) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(29),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(29).EQ.IVAL) JPRINT(29) = IFULL
IF(JPRINT(29).EQ.ILEW) JPRINT(29) = IFULL
END IF
GO TO 100
KEYWORD: AOPNHO -- WRITE AO TO PNHO TRANSFORMATION
960 IF(.NOT.EQUAL(KEYWD,KAOPNH,6)) GO TO 970
JPRINT(30) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(30),LFNPNH,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(30).EQ.IVAL) JPRINT(30) = IFULL
IF(JPRINT(30).EQ.ILEW) JPRINT(30) = IFULL
END IF
GO TO 100
KEYWORD: FNAO -- PRINT NAO FOCK MATRIX
970 IF(.NOT.EQUAL(KEYWD,KFNAO,4)) GO TO 990
JPRINT(31) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(31),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(31).EQ.IVAL) JPRINT(31) = IFULL
IF(JPRINT(31).EQ.ILEW) JPRINT(31) = IFULL
END IF
GO TO 100
KEYWORD: NAONHO -- OUTPUT THE NAO TO NHO TRANSFORMATION
990 IF(.NOT.EQUAL(KEYWD,KNAONH,6)) GO TO 1010
JPRINT(33) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(33),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(33).EQ.IVAL) JPRINT(33) = IFULL
IF(JPRINT(33).EQ.ILEW) JPRINT(33) = IFULL
END IF
GO TO 100
KEYWORD: DMNHO -- PRINT NHO DENSITY MATRIX
1010 IF(.NOT.EQUAL(KEYWD,KDMNHO,5)) GO TO 1020
JPRINT(34) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(34),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(34).EQ.IVAL) JPRINT(34) = IFULL
IF(JPRINT(34).EQ.ILEW) JPRINT(34) = IFULL
END IF
GO TO 100
KEYWORD: DMNAO -- PRINT NAO DENSITY MATRIX
1020 IF(.NOT.EQUAL(KEYWD,KDMNAO,5)) GO TO 1040
JPRINT(35) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(35),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(35).EQ.IVAL) JPRINT(35) = IFULL
IF(JPRINT(35).EQ.ILEW) JPRINT(35) = IFULL
END IF
GO TO 100
KEYWORD: BEND -- PRINT NHO DIRECTIONALITY AND BOND BENDING INFO
1040 IF(.NOT.EQUAL(KEYWD,KBEND,4)) GO TO 1050
JPRINT(36) = 1
CALL RFLD(TEMP,ERROR)
IF(ERROR) GO TO 100
ATHR = ABS(TEMP)
CALL RFLD(TEMP,ERROR)
IF(ERROR) GO TO 100
PTHR = ABS(TEMP)
IF(PTHR.LT.ONE) PTHR = ONE
CALL RFLD(TEMP,ERROR)
IF(ERROR) GO TO 100
ETHR = ABS(TEMP)
GO TO 100
KEYWORD: NHOMO -- COMPUTE AND PRINT NHO TO MO TRANSF.
1050 IF(.NOT.EQUAL(KEYWD,KNHOMO,5)) GO TO 1060
JPRINT(38) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(38),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
END IF
GO TO 100
KEYWORD: SAO -- PRINT AO OVERLAP MATRIX
1060 IF(.NOT.EQUAL(KEYWD,KSAO,3)) GO TO 1070
JPRINT(39) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(39),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(39).EQ.IVAL) JPRINT(39) = IFULL
IF(JPRINT(39).EQ.ILEW) JPRINT(39) = IFULL
END IF
GO TO 100
KEYWORD: FAO -- PRINT AO FOCK MATRIX
1070 IF(.NOT.EQUAL(KEYWD,KFAO,3)) GO TO 1080
JPRINT(40) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(40),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(40).EQ.IVAL) JPRINT(40) = IFULL
IF(JPRINT(40).EQ.ILEW) JPRINT(40) = IFULL
END IF
GO TO 100
KEYWORD: NHONBO -- OUTPUT NHO TO NBO TRANSFORMATION
1080 IF(.NOT.EQUAL(KEYWD,KNHONB,6)) GO TO 1090
JPRINT(41) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(41),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(41).EQ.IVAL) JPRINT(41) = IFULL
END IF
GO TO 100
KEYWORD: BOAO -- PRINT AO BOND-ORDER MATRIX
1090 IF(.NOT.EQUAL(KEYWD,KBOAO,4)) GO TO 1100
JPRINT(42) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(42),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(42).EQ.IVAL) JPRINT(42) = IFULL
IF(JPRINT(42).EQ.ILEW) JPRINT(42) = IFULL
END IF
GO TO 100
KEYWORD: E2PERT -- 2ND-ORDER PERTURBATIVE ANALYSIS OF THE NBO FOCK MATRIX
1100 IF(.NOT.EQUAL(KEYWD,KEPERT,6)) GO TO 1110
JPRINT(3) = 1
CALL RFLD(TEMP,ERROR)
IF(ERROR) GO TO 100
E2THR = ABS(TEMP)
GO TO 100
KEYWORD: PLOT -- WRITE AO BASIS, DENSITY, AND TRANSFORMS FOR PLOTTING
1110 IF(.NOT.EQUAL(KEYWD,KPLOT,4)) GO TO 1120
JPRINT(43) = 1
GO TO 100
KEYWORD: NPA -- PRINT THE NATURAL POPULATION ANALYSIS
1120 IF(.NOT.EQUAL(KEYWD,KNPA,3)) GO TO 1130
JPRINT(4) = 1
GO TO 100
KEYWORD: NBOSUM -- PRINT THE NBO SUMMARY
1130 IF(.NOT.EQUAL(KEYWD,KNBOSM,6)) GO TO 1140
JPRINT(6) = 1
GO TO 100
KEYWORD: NBO -- PRINT THE NBO ANALYSIS
1140 IF(.NOT.EQUAL(KEYWD,KNBO,3)) GO TO 1150
IF(LENG.NE.3) GO TO 1150
JPRINT(5) = 1
GO TO 100
KEYWORD: DIPOLE -- PRINT NBO/NLMO DIPOLE ANALYSIS:
1150 IF(.NOT.EQUAL(KEYWD,KDIPOL,6)) GO TO 1160
JPRINT(46) = 1
CALL RFLD(TEMP,ERROR)
IF(ERROR) GO TO 100
DTHR = ABS(TEMP)
GO TO 100
KEYWORD: NBONLMO -- PRINT NBO TO NLMO TRANSFORMATION MATRIX
1160 IF(.NOT.EQUAL(KEYWD,KNBNLM,7)) GO TO 1170
JPRINT(47) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(47),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(47).EQ.IVAL) JPRINT(47) = IFULL
END IF
GO TO 100
KEYWORD: SPNLMO -- OUTPUT THE PNLMO OVERLAP MATRIX
1170 IF(.NOT.EQUAL(KEYWD,KSPNLM,6)) GO TO 1180
JPRINT(48) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(48),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(48).EQ.IVAL) JPRINT(48) = IFULL
END IF
GO TO 100
KEYWORD: AOPNLMO -- OUTPUT THE AO-PNLMO TRANSFORMATION MATRIX
1180 IF(.NOT.EQUAL(KEYWD,KAOPNL,7)) GO TO 1190
JPRINT(49) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(49),LFNPNL,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(49).EQ.IVAL) JPRINT(49) = IFULL
END IF
GO TO 100
KEYWORD: DIAO -- OUTPUT THE AO DIPOLE INTEGRALS
1190 IF(.NOT.EQUAL(KEYWD,KDIAO,4)) GO TO 1200
JPRINT(50) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(50),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(50).EQ.IVAL) JPRINT(50) = IFULL
IF(JPRINT(50).EQ.ILEW) JPRINT(50) = IFULL
END IF
GO TO 100
KEYWORD: DINAO -- OUTPUT THE NAO DIPOLE INTEGRALS
1200 IF(.NOT.EQUAL(KEYWD,KDINAO,5)) GO TO 1210
JPRINT(51) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(51),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(51).EQ.IVAL) JPRINT(51) = IFULL
IF(JPRINT(51).EQ.ILEW) JPRINT(51) = IFULL
END IF
GO TO 100
KEYWORD: DINHO -- OUTPUT THE NHO DIPOLE INTEGRALS
1210 IF(.NOT.EQUAL(KEYWD,KDINHO,5)) GO TO 1220
JPRINT(52) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(52),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(52).EQ.IVAL) JPRINT(52) = IFULL
IF(JPRINT(52).EQ.ILEW) JPRINT(52) = IFULL
END IF
GO TO 100
KEYWORD: DINBO -- OUTPUT THE NBO DIPOLE INTEGRALS
1220 IF(.NOT.EQUAL(KEYWD,KDINBO,5)) GO TO 1230
JPRINT(53) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(53),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(53).EQ.IVAL) JPRINT(53) = IFULL
END IF
GO TO 100
KEYWORD: DINLMO -- OUTPUT THE NLMO DIPOLE INTEGRALS
1230 IF(.NOT.EQUAL(KEYWD,KDINLM,6)) GO TO 1240
JPRINT(54) = IFULL
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
READ = .FALSE.
CALL KEYPAR(KEYWD,LENG,JPRINT(54),LFNDEF,READ,ERROR)
IF(ERROR) NEXTWD = .FALSE.
IF(JPRINT(54).EQ.IVAL) JPRINT(54) = IFULL
END IF
GO TO 100
KEYWORD: NBODAF -- CHOOSE AN ALTERNATE DAF
1240 IF(.NOT.EQUAL(KEYWD,KNBDAF,6)) GO TO 1250
LFNDAF = ABS(LFNDAF)
CALL IFLD(ITEMP,ERROR)
IF(.NOT.ERROR) LFNDAF = ABS(ITEMP)
GO TO 100
KEYWORD: ARCHIVE -- WRITE THE ARCHIVE FILE
1250 IF(.NOT.EQUAL(KEYWD,KARCHV,7)) GO TO 1260
JPRINT(7) = LFNARC
CALL IFLD(ITEMP,ERROR)
IF(.NOT.ERROR) JPRINT(7) = ABS(ITEMP)
GO TO 100
KEYWORD: FILE -- SELECT ALTERNATE FILENAME
1260 IF(.NOT.EQUAL(KEYWD,KFILE,4)) GO TO 1270
LENG = 80
CALL HFLD(INTTMP,LENG,END)
IF(.NOT.END) LENNM = LENG
GO TO 100
KEYWORD: APOLAR -- ENFORCE APOLAR BONDS:
1270 IF(.NOT.EQUAL(KEYWD,KPOLAR,6)) GO TO 1290
IWAPOL = 1
GO TO 100
KEYWORD: NRTOPT -- OPTIMIZE NRT WEIGHTS:
1290 IF(.NOT.EQUAL(KEYWD,KNRTOP,6)) GO TO 1300
IF(JPRINT(14).EQ.0) JPRINT(14) = 1
IF(JPRINT(32).EQ.0) JPRINT(32) = 1
JPRINT(55) = IB
LENG = KEYLEN
CALL HFLD(KEYWD,LENG,END)
IF(.NOT.END) THEN
IF(EQUAL(KEYWD,KBFGS,4)) THEN
JPRINT(55) = IB
ELSE IF(EQUAL(KEYWD,KPOWEL,6)) THEN
JPRINT(55) = IP
ELSE IF(EQUAL(KEYWD,KSAP,3)) THEN
JPRINT(55) = 1234567
IF(LENG.GT.3) CALL CONVIN(KEYWD(4),LENG-3,JPRINT(55),ERROR)
IF(ERROR) CALL HALT('NRTOPT')
JPRINT(55) = ABS(JPRINT(55))
ELSE IF(EQUAL(KEYWD,KSAP,2)) THEN
JPRINT(55) = -1234567
IF(LENG.GT.2) CALL CONVIN(KEYWD(3),LENG-2,JPRINT(55),ERROR)
IF(ERROR) CALL HALT('NRTOPT')
JPRINT(55) = -ABS(JPRINT(55))
ELSE
NEXTWD = .FALSE.
END IF
END IF
GO TO 100
KEYWORD: NRTREF -- NUMBER OF REFERENCE STRUCTURES IN NRT ANALYSIS
1300 IF(.NOT.EQUAL(KEYWD,KNRTRF,6)) GO TO 1310
IF(JPRINT(14).EQ.0) JPRINT(14) = 1
IF(JPRINT(32).EQ.0) JPRINT(32) = 1
CALL IFLD(ITEMP,ERROR)
IF(ERROR) GO TO 100
JPRINT(56) = MAX(1,ABS(ITEMP))
GO TO 100
KEYWORD: CHSTHR -- SET THE OCCUPANCY THRESHOLD IN CHOOSE
1310 IF(.NOT.EQUAL(KEYWD,KCHSTH,6)) GO TO 1320
CHSTHR = ABS(CHSTHR)
CALL RFLD(TEMP,ERROR)
IF(ERROR) GO TO 100
CHSTHR = ABS(TEMP)
GO TO 100
KEYWORD: NRTDTL -- DETAIL NRT ANALYSIS
1320 IF(.NOT.EQUAL(KEYWD,KNRTDT,6)) GO TO 1340
IF(JPRINT(14).EQ.0) JPRINT(14) = 1
IF(JPRINT(32).EQ.0) JPRINT(32) = 1
JPRINT(57) = 1
CALL IFLD(ITEMP,ERROR)
IF(ERROR) GO TO 100
JPRINT(57) = MAX(1,ABS(ITEMP))
GO TO 100
KEYWORD: NRTTHR -- SET THRESHOLD FOR DELOCALIZATION LIST
1340 IF(.NOT.EQUAL(KEYWD,KNRTTH,6)) GO TO 1360
IF(JPRINT(14).EQ.0) JPRINT(14) = 1
IF(JPRINT(32).EQ.0) JPRINT(32) = 1
DLTHR = ABS(DLTHR)
CALL RFLD(TEMP,ERROR)
IF(ERROR) GO TO 100
DLTHR = ABS(TEMP)
GO TO 100
KEYWORD: NRT -- PERFORM NATURAL RESONANCE THEORY ANALYSIS:
(NOTE THAT WE SHOULD CHECK THIS KEYWORD AFTER WE CHECK THE OTHER
`NRT' KEYWORDS, LIKE `NRTOPT'. OTHERWISE, KEYWORD CONFLICTS CAN
OCCUR.)
1360 IF(.NOT.EQUAL(KEYWD,KNRT,3)) GO TO 1370
JPRINT(14) = 1
JPRINT(32) = 1
CALL IFLD(ITEMP,ERROR)
IF(.NOT.ERROR) JPRINT(32) = ITEMP
GO TO 100
1370 GO TO 4800
------------------------------------------------------------------------------
4500 CONTINUE
IF OPTION `FILE' WAS SELECTED, EXTRACT THE FILENAME FROM HOLLERITH
ARRAY INTTMP:
IF(LENNM.NE.0) THEN
IDIV = IB - IA
DO 4510 I = 1,LENNM
FILENM(I:I) = CHAR(MOD((INTTMP(I)-IA)/IDIV,256) + 65)
4510 CONTINUE
DO 4520 I = LENNM+1,80
FILENM(I:I) = CHAR(32)
4520 CONTINUE
END IF
------------------------------------------------------------------------------
IF THE PRINT LEVEL IS SET TO ZERO AND NO OTHER OPTIONS WERE ENTERED,
COMPLETELY SHUT OFF PROGRAM PRINTING:
IF(NUMOPT.EQ.1.AND.IPRINT.EQ.0) IPRINT = -1
CHECK FOR JOB OPTIONS THAT ARE CURRENTLY INCOMPATABLE:
IF((IWDM.EQ.0).AND.(IWMULP.NE.0)) GO TO 4900
CHECK FOR JOB OPTIONS THAT ARE STRICTLY INCOMPATIBLE:
IF(ORTHO) THEN
IWTNAO = 0
JPRINT(9) = 0
JPRINT(11) = 0
JPRINT(18) = 0
JPRINT(19) = 0
JPRINT(20) = 0
JPRINT(21) = 0
JPRINT(25) = 0
JPRINT(30) = 0
JPRINT(31) = 0
JPRINT(33) = 0
JPRINT(35) = 0
JPRINT(39) = 0
JPRINT(44) = 0
JPRINT(48) = 0
JPRINT(49) = 0
JPRINT(51) = 0
END IF
------------------------------------------------------------------------------
START PRINTING NBO OUTPUT:
IF(IPRINT.GE.0) THEN
WRITE(LFNPR,6000)
IF(NUMOPT.GT.0) WRITE(LFNPR,6010)
------------------------------------------------------------------------------
6000 FORMAT(/1X,79('*')/,13X,
* 'N A T U R A L A T O M I C O R B I T A L A N D'/,
* 10X,'N A T U R A L B O N D O R B I T A L ',
* 'A N A L Y S I S',/1X,79('*'))
6010 FORMAT(1X)
------------------------------------------------------------------------------
JOB CONTROL KEYWORDS:
IF(JPRINT(4).NE.0) WRITE(LFNPR,6020)
IF(JPRINT(5).NE.0) WRITE(LFNPR,6030)
IF(JPRINT(6).NE.0) WRITE(LFNPR,6040)
IF(JPRINT(14).NE.0) WRITE(LFNPR,6050)
IF(JPRINT(10).NE.0) WRITE(LFNPR,6060)
IF(IW3C.NE.0) WRITE(LFNPR,6070)
IF(JPRINT(1).NE.0) WRITE(LFNPR,6080)
IF(JPRINT(8).NE.0) WRITE(LFNPR,6090)
IF(JPRINT(32).NE.0) WRITE(LFNPR,6100)
IF(JPRINT(55).EQ.IB) THEN
WRITE(LFNPR,6110)
ELSE IF(JPRINT(55).EQ.IP) THEN
WRITE(LFNPR,6111)
ELSE IF(JPRINT(55).LT.0) THEN
WRITE(LFNPR,6112)
ELSE IF(JPRINT(55).GT.0) THEN
WRITE(LFNPR,6113)
END IF
IF(JPRINT(56).NE.0) WRITE(LFNPR,6120) JPRINT(56)
IF(DLTHR.GE.ZERO) WRITE(LFNPR,6160) DLTHR
IF(JPRINT(57).NE.0) WRITE(LFNPR,6170) JPRINT(57)
------------------------------------------------------------------------------
6020 FORMAT(1X,' /NPA / : Print Natural Population Analysis')
6030 FORMAT(1X,' /NBO / : Print Natural Bond Orbital Analysis')
6040 FORMAT(1X,' /NBOSUM / : Print summary of the NBO analysis')
6050 FORMAT(1X,' /RESON / : Allow strongly delocalized NBO ',
* 'set')
6060 FORMAT(1X,' /NOBOND / : No two-center NBO search')
6070 FORMAT(1X,' /3CBOND / : Search for 3-center bonds')
6080 FORMAT(1X,' /SKIPBO / : Skip NBO transformation step')
6090 FORMAT(1X,' /NLMO / : Form Natural Localized Molecular',
* ' Orbitals')
6100 FORMAT(1X,' /NRT / : Perform Natural Resonance Theory ',
* 'Analysis')
6110 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ',
* 'BFGS method')
6111 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ',
* 'POWELL method')
6112 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ',
* 'ANNEAL method')
6113 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ',
* 'ANNEAL method + penalty')
6120 FORMAT(1X,' /NRTREF / : Number of reference structures set',
* ' to',I3)
6160 FORMAT(1X,' /NRTTHR / : Set to ',F5.2)
6170 FORMAT(1X,' /NRTDTL / : Set to ',I2)
------------------------------------------------------------------------------
JOB THRESHOLD KEYWORDS:
IF(JPRINT(36).NE.0) WRITE(LFNPR,6500)
IF(ATHR.GE.ZERO.OR.PTHR.GE.ZERO.OR.ETHR.GE.ZERO)
+ WRITE(LFNPR,6510) ABS(ATHR),ABS(PTHR),ABS(ETHR)
IF(JPRINT(3).NE.0) WRITE(LFNPR,6520)
IF(E2THR.GT.ZERO) WRITE(LFNPR,6530) E2THR
IF(JPRINT(46).NE.0) WRITE(LFNPR,6540)
IF(DTHR.GE.ZERO) WRITE(LFNPR,6550) ABS(DTHR)
IF(THRSET.GT.ZERO) WRITE(LFNPR,6560) THRSET
IF(PRJSET.GT.ZERO) WRITE(LFNPR,6570) PRJSET
IF(CHSTHR.GT.ZERO) WRITE(LFNPR,6580) CHSTHR
------------------------------------------------------------------------------
6500 FORMAT(1X,' /BEND / : Print NHO directionality table')
6510 FORMAT(1X,' Print thresholds set to (',F4.1,
* ',',F5.1,',',F5.2,')')
6520 FORMAT(1X,' /E2PERT / : Analyze NBO Fock matrix')
6530 FORMAT(1X,' Print threshold set to ',F5.2)
6540 FORMAT(1X,' /DIPOLE / : Print NBO/NLMO dipole moment ',
* 'analysis')
6550 FORMAT(1X,' Print threshold set to ',F5.2)
6560 FORMAT(1X,' /THRESH / : Set to ',F5.2)
6570 FORMAT(1X,' /PRJTHR / : Set to ',F5.2)
6580 FORMAT(1X,' /CHSTHR / : Set to ',F5.2)
------------------------------------------------------------------------------
MATRIX OUTPUT KEYWORDS:
IF(JPRINT(44).EQ.IFULL) THEN
WRITE(LFNPR,7000)
ELSE IF(IOINQR(JPRINT(44)).EQ.IPRNT) THEN
WRITE(LFNPR,7002) JPRINT(44)
ELSE IF(IOINQR(JPRINT(44)).EQ.IWRIT) THEN
WRITE(LFNPR,7004) ABS(JPRINT(44))
END IF
IF(IWTNAO.EQ.IFULL) THEN
WRITE(LFNPR,7010)
ELSE IF(IOINQR(IWTNAO).EQ.IPRNT) THEN
WRITE(LFNPR,7012) IWTNAO
ELSE IF(IOINQR(IWTNAO).EQ.IWRIT) THEN
WRITE(LFNPR,7014) ABS(IWTNAO)
ELSE IF(IOINQR(IWTNAO).EQ.IREAD) THEN
WRITE(LFNPR,7016) ABS(IWTNAO/1000)
END IF
IF(JPRINT(30).EQ.IFULL) THEN
WRITE(LFNPR,7020)
ELSE IF(IOINQR(JPRINT(30)).EQ.IPRNT) THEN
WRITE(LFNPR,7022) JPRINT(30)
ELSE IF(IOINQR(JPRINT(30)).EQ.IWRIT) THEN
WRITE(LFNPR,7024) ABS(JPRINT(30))
END IF
IF(JPRINT(28).EQ.IFULL) THEN
WRITE(LFNPR,7030)
ELSE IF(IOINQR(JPRINT(28)).EQ.IPRNT) THEN
WRITE(LFNPR,7032) JPRINT(28)
ELSE IF(IOINQR(JPRINT(28)).EQ.IWRIT) THEN
WRITE(LFNPR,7034) ABS(JPRINT(28))
END IF
IF(JPRINT(25).EQ.IFULL) THEN
WRITE(LFNPR,7040)
ELSE IF(JPRINT(25).EQ.ILEW) THEN
WRITE(LFNPR,7042)
ELSE IF(IOINQR(JPRINT(25)).EQ.IPRNT) THEN
WRITE(LFNPR,7044) JPRINT(25)
ELSE IF(IOINQR(JPRINT(25)).EQ.IWRIT) THEN
WRITE(LFNPR,7046) ABS(JPRINT(25))
END IF
IF(IWTNBO.EQ.IFULL) THEN
WRITE(LFNPR,7050)
ELSE IF(IWTNBO.EQ.ILEW) THEN
WRITE(LFNPR,7052)
ELSE IF(IOINQR(IWTNBO).EQ.IPRNT) THEN
WRITE(LFNPR,7054) IWTNBO
ELSE IF(IOINQR(IWTNBO).EQ.IWRIT) THEN
WRITE(LFNPR,7056) ABS(IWTNBO)
END IF
IF(JPRINT(49).EQ.IFULL) THEN
WRITE(LFNPR,7060)
ELSE IF(JPRINT(49).EQ.ILEW) THEN
WRITE(LFNPR,7062)
ELSE IF(IOINQR(JPRINT(49)).EQ.IPRNT) THEN
WRITE(LFNPR,7064) JPRINT(49)
ELSE IF(IOINQR(JPRINT(49)).EQ.IWRIT) THEN
WRITE(LFNPR,7066) ABS(JPRINT(49))
END IF
IF(JPRINT(23).EQ.IFULL) THEN
WRITE(LFNPR,7070)
ELSE IF(JPRINT(23).EQ.ILEW) THEN
WRITE(LFNPR,7072)
ELSE IF(IOINQR(JPRINT(23)).EQ.IPRNT) THEN
WRITE(LFNPR,7074) JPRINT(23)
ELSE IF(IOINQR(JPRINT(23)).EQ.IWRIT) THEN
WRITE(LFNPR,7076) ABS(JPRINT(23))
END IF
IF(JPRINT(26).EQ.IFULL) THEN
WRITE(LFNPR,7080)
ELSE IF(JPRINT(26).EQ.IVAL) THEN
WRITE(LFNPR,7082)
ELSE IF(JPRINT(26).EQ.ILEW) THEN
WRITE(LFNPR,7084)
ELSE IF(IOINQR(JPRINT(26)).EQ.IPRNT) THEN
WRITE(LFNPR,7086) JPRINT(26)
ELSE IF(IOINQR(JPRINT(26)).EQ.IWRIT) THEN
WRITE(LFNPR,7088) ABS(JPRINT(26))
END IF
IF(IWPNAO.EQ.IFULL) THEN
WRITE(LFNPR,7090)
ELSE IF(IOINQR(IWPNAO).EQ.IPRNT) THEN
WRITE(LFNPR,7092) IWPNAO
ELSE IF(IOINQR(IWPNAO).EQ.IWRIT) THEN
WRITE(LFNPR,7094) ABS(IWPNAO)
ELSE IF(IOINQR(IWPNAO).EQ.IREAD) THEN
WRITE(LFNPR,7096) ABS(IWPNAO/1000)
END IF
IF(JPRINT(33).EQ.IFULL) THEN
WRITE(LFNPR,7100)
ELSE IF(IOINQR(JPRINT(33)).EQ.IPRNT) THEN
WRITE(LFNPR,7102) JPRINT(33)
ELSE IF(IOINQR(JPRINT(33)).EQ.IWRIT) THEN
WRITE(LFNPR,7104) ABS(JPRINT(33))
END IF
IF(IWTNAB.EQ.IFULL) THEN
WRITE(LFNPR,7110)
ELSE IF(IWTNAB.EQ.ILEW) THEN
WRITE(LFNPR,7112)
ELSE IF(IOINQR(IWTNAB).EQ.IPRNT) THEN
WRITE(LFNPR,7114) IWTNAB
ELSE IF(IOINQR(IWTNAB).EQ.IWRIT) THEN
WRITE(LFNPR,7116) ABS(IWTNAB)
ELSE IF(IOINQR(IWTNAB).EQ.IREAD) THEN
WRITE(LFNPR,7118) ABS(IWTNAB/1000)
END IF
IF(JPRINT(18).EQ.IFULL) THEN
WRITE(LFNPR,7120)
ELSE IF(JPRINT(18).EQ.ILEW) THEN
WRITE(LFNPR,7122)
ELSE IF(IOINQR(JPRINT(18)).EQ.IPRNT) THEN
WRITE(LFNPR,7124) JPRINT(18)
ELSE IF(IOINQR(JPRINT(18)).EQ.IWRIT) THEN
WRITE(LFNPR,7126) ABS(JPRINT(18))
END IF
IF(JPRINT(9).EQ.IFULL) THEN
WRITE(LFNPR,7130)
ELSE IF(JPRINT(9).EQ.IVAL) THEN
WRITE(LFNPR,7132)
ELSE IF(JPRINT(9).EQ.ILEW) THEN
WRITE(LFNPR,7134)
ELSE IF(IOINQR(JPRINT(9)).EQ.IPRNT) THEN
WRITE(LFNPR,7136) JPRINT(9)
ELSE IF(IOINQR(JPRINT(9)).EQ.IWRIT) THEN
WRITE(LFNPR,7138) ABS(JPRINT(9))
END IF
IF(JPRINT(41).EQ.IFULL) THEN
WRITE(LFNPR,7140)
ELSE IF(JPRINT(41).EQ.ILEW) THEN
WRITE(LFNPR,7142)
ELSE IF(IOINQR(JPRINT(41)).EQ.IPRNT) THEN
WRITE(LFNPR,7144) JPRINT(41)
ELSE IF(IOINQR(JPRINT(41)).EQ.IWRIT) THEN
WRITE(LFNPR,7146) ABS(JPRINT(41))
END IF
IF(JPRINT(24).EQ.IFULL) THEN
WRITE(LFNPR,7150)
ELSE IF(JPRINT(24).EQ.ILEW) THEN
WRITE(LFNPR,7152)
ELSE IF(IOINQR(JPRINT(24)).EQ.IPRNT) THEN
WRITE(LFNPR,7154) JPRINT(24)
ELSE IF(IOINQR(JPRINT(24)).EQ.IWRIT) THEN
WRITE(LFNPR,7156) ABS(JPRINT(24))
END IF
IF(JPRINT(38).EQ.IFULL) THEN
WRITE(LFNPR,7160)
ELSE IF(JPRINT(38).EQ.IVAL) THEN
WRITE(LFNPR,7162)
ELSE IF(JPRINT(38).EQ.ILEW) THEN
WRITE(LFNPR,7164)
ELSE IF(IOINQR(JPRINT(38)).EQ.IPRNT) THEN
WRITE(LFNPR,7166) JPRINT(38)
ELSE IF(IOINQR(JPRINT(38)).EQ.IWRIT) THEN
WRITE(LFNPR,7168) ABS(JPRINT(38))
END IF
IF(JPRINT(47).EQ.IFULL) THEN
WRITE(LFNPR,7170)
ELSE IF(JPRINT(47).EQ.ILEW) THEN
WRITE(LFNPR,7172)
ELSE IF(IOINQR(JPRINT(47)).EQ.IPRNT) THEN
WRITE(LFNPR,7174) JPRINT(47)
ELSE IF(IOINQR(JPRINT(47)).EQ.IWRIT) THEN
WRITE(LFNPR,7176) ABS(JPRINT(47))
END IF
IF(JPRINT(45).EQ.IFULL) THEN
WRITE(LFNPR,7180)
ELSE IF(JPRINT(45).EQ.IVAL) THEN
WRITE(LFNPR,7182)
ELSE IF(JPRINT(45).EQ.ILEW) THEN
WRITE(LFNPR,7184)
ELSE IF(IOINQR(JPRINT(45)).EQ.IPRNT) THEN
WRITE(LFNPR,7186) JPRINT(45)
ELSE IF(IOINQR(JPRINT(45)).EQ.IWRIT) THEN
WRITE(LFNPR,7188) ABS(JPRINT(45))
END IF
IF(JPRINT(13).EQ.IFULL) THEN
WRITE(LFNPR,7190)
ELSE IF(JPRINT(13).EQ.IVAL) THEN
WRITE(LFNPR,7192)
ELSE IF(JPRINT(13).EQ.ILEW) THEN
WRITE(LFNPR,7194)
ELSE IF(IOINQR(JPRINT(13)).EQ.IPRNT) THEN
WRITE(LFNPR,7196) JPRINT(13)
ELSE IF(IOINQR(JPRINT(13)).EQ.IWRIT) THEN
WRITE(LFNPR,7198) ABS(JPRINT(13))
END IF
IF(JPRINT(42).EQ.IFULL) THEN
WRITE(LFNPR,7200)
ELSE IF(IOINQR(JPRINT(42)).EQ.IPRNT) THEN
WRITE(LFNPR,7202) JPRINT(42)
ELSE IF(IOINQR(JPRINT(42)).EQ.IWRIT) THEN
WRITE(LFNPR,7204) ABS(JPRINT(42))
END IF
IF(JPRINT(27).EQ.IFULL) THEN
WRITE(LFNPR,7210)
ELSE IF(IOINQR(JPRINT(27)).EQ.IPRNT) THEN
WRITE(LFNPR,7212) JPRINT(27)
ELSE IF(IOINQR(JPRINT(27)).EQ.IWRIT) THEN
WRITE(LFNPR,7214) ABS(JPRINT(27))
END IF
IF(JPRINT(35).EQ.IFULL) THEN
WRITE(LFNPR,7220)
ELSE IF(IOINQR(JPRINT(35)).EQ.IPRNT) THEN
WRITE(LFNPR,7222) JPRINT(35)
ELSE IF(IOINQR(JPRINT(35)).EQ.IWRIT) THEN
WRITE(LFNPR,7224) ABS(JPRINT(35))
END IF
IF(JPRINT(34).EQ.IFULL) THEN
WRITE(LFNPR,7230)
ELSE IF(IOINQR(JPRINT(34)).EQ.IPRNT) THEN
WRITE(LFNPR,7232) JPRINT(34)
ELSE IF(IOINQR(JPRINT(34)).EQ.IWRIT) THEN
WRITE(LFNPR,7234) ABS(JPRINT(34))
END IF
IF(JPRINT(16).EQ.IFULL) THEN
WRITE(LFNPR,7240)
ELSE IF(JPRINT(16).EQ.ILEW) THEN
WRITE(LFNPR,7242)
ELSE IF(IOINQR(JPRINT(16)).EQ.IPRNT) THEN
WRITE(LFNPR,7244) JPRINT(16)
ELSE IF(IOINQR(JPRINT(16)).EQ.IWRIT) THEN
WRITE(LFNPR,7246) ABS(JPRINT(16))
END IF
IF(JPRINT(17).EQ.IFULL) THEN
WRITE(LFNPR,7250)
ELSE IF(JPRINT(17).EQ.ILEW) THEN
WRITE(LFNPR,7252)
ELSE IF(IOINQR(JPRINT(17)).EQ.IPRNT) THEN
WRITE(LFNPR,7254) JPRINT(17)
ELSE IF(IOINQR(JPRINT(17)).EQ.IWRIT) THEN
WRITE(LFNPR,7256) ABS(JPRINT(17))
END IF
IF(JPRINT(40).EQ.IFULL) THEN
WRITE(LFNPR,7260)
ELSE IF(IOINQR(JPRINT(40)).EQ.IPRNT) THEN
WRITE(LFNPR,7262) JPRINT(40)
ELSE IF(IOINQR(JPRINT(40)).EQ.IWRIT) THEN
WRITE(LFNPR,7264) ABS(JPRINT(40))
END IF
IF(JPRINT(31).EQ.IFULL) THEN
WRITE(LFNPR,7270)
ELSE IF(IOINQR(JPRINT(31)).EQ.IPRNT) THEN
WRITE(LFNPR,7272) JPRINT(31)
ELSE IF(IOINQR(JPRINT(31)).EQ.IWRIT) THEN
WRITE(LFNPR,7274) ABS(JPRINT(31))
END IF
IF(JPRINT(29).EQ.IFULL) THEN
WRITE(LFNPR,7280)
ELSE IF(IOINQR(JPRINT(29)).EQ.IPRNT) THEN
WRITE(LFNPR,7282) JPRINT(29)
ELSE IF(IOINQR(JPRINT(29)).EQ.IWRIT) THEN
WRITE(LFNPR,7284) ABS(JPRINT(29))
END IF
IF(JPRINT(37).EQ.IFULL) THEN
WRITE(LFNPR,7290)
ELSE IF(JPRINT(37).EQ.ILEW) THEN
WRITE(LFNPR,7292)
ELSE IF(IOINQR(JPRINT(37)).EQ.IPRNT) THEN
WRITE(LFNPR,7294) JPRINT(37)
ELSE IF(IOINQR(JPRINT(37)).EQ.IWRIT) THEN
WRITE(LFNPR,7296) ABS(JPRINT(37))
END IF
IF(JPRINT(15).EQ.IFULL) THEN
WRITE(LFNPR,7300)
ELSE IF(JPRINT(15).EQ.ILEW) THEN
WRITE(LFNPR,7302)
ELSE IF(IOINQR(JPRINT(15)).EQ.IPRNT) THEN
WRITE(LFNPR,7304) JPRINT(15)
ELSE IF(IOINQR(JPRINT(15)).EQ.IWRIT) THEN
WRITE(LFNPR,7306) ABS(JPRINT(15))
END IF
IF(JPRINT(50).EQ.IFULL) THEN
WRITE(LFNPR,7310)
ELSE IF(IOINQR(JPRINT(50)).EQ.IPRNT) THEN
WRITE(LFNPR,7312) JPRINT(50)
ELSE IF(IOINQR(JPRINT(50)).EQ.IWRIT) THEN
WRITE(LFNPR,7314) ABS(JPRINT(50))
END IF
IF(JPRINT(51).EQ.IFULL) THEN
WRITE(LFNPR,7320)
ELSE IF(IOINQR(JPRINT(51)).EQ.IPRNT) THEN
WRITE(LFNPR,7322) JPRINT(51)
ELSE IF(IOINQR(JPRINT(51)).EQ.IWRIT) THEN
WRITE(LFNPR,7324) ABS(JPRINT(51))
END IF
IF(JPRINT(52).EQ.IFULL) THEN
WRITE(LFNPR,7330)
ELSE IF(IOINQR(JPRINT(52)).EQ.IPRNT) THEN
WRITE(LFNPR,7332) JPRINT(52)
ELSE IF(IOINQR(JPRINT(52)).EQ.IWRIT) THEN
WRITE(LFNPR,7334) ABS(JPRINT(52))
END IF
IF(JPRINT(53).EQ.IFULL) THEN
WRITE(LFNPR,7340)
ELSE IF(JPRINT(53).EQ.ILEW) THEN
WRITE(LFNPR,7342)
ELSE IF(IOINQR(JPRINT(53)).EQ.IPRNT) THEN
WRITE(LFNPR,7344) JPRINT(53)
ELSE IF(IOINQR(JPRINT(53)).EQ.IWRIT) THEN
WRITE(LFNPR,7346) ABS(JPRINT(53))
END IF
IF(JPRINT(54).EQ.IFULL) THEN
WRITE(LFNPR,7350)
ELSE IF(JPRINT(54).EQ.ILEW) THEN
WRITE(LFNPR,7352)
ELSE IF(IOINQR(JPRINT(54)).EQ.IPRNT) THEN
WRITE(LFNPR,7354) JPRINT(54)
ELSE IF(IOINQR(JPRINT(54)).EQ.IWRIT) THEN
WRITE(LFNPR,7356) ABS(JPRINT(54))
END IF
IF(JPRINT(39).EQ.IFULL) THEN
WRITE(LFNPR,7360)
ELSE IF(IOINQR(JPRINT(39)).EQ.IPRNT) THEN
WRITE(LFNPR,7362) JPRINT(39)
ELSE IF(IOINQR(JPRINT(39)).EQ.IWRIT) THEN
WRITE(LFNPR,7364) ABS(JPRINT(39))
END IF
IF(JPRINT(19).EQ.IFULL) THEN
WRITE(LFNPR,7370)
ELSE IF(IOINQR(JPRINT(19)).EQ.IPRNT) THEN
WRITE(LFNPR,7372) JPRINT(19)
ELSE IF(IOINQR(JPRINT(19)).EQ.IWRIT) THEN
WRITE(LFNPR,7374) ABS(JPRINT(19))
END IF
IF(JPRINT(20).EQ.IFULL) THEN
WRITE(LFNPR,7380)
ELSE IF(IOINQR(JPRINT(20)).EQ.IPRNT) THEN
WRITE(LFNPR,7382) JPRINT(20)
ELSE IF(IOINQR(JPRINT(20)).EQ.IWRIT) THEN
WRITE(LFNPR,7384) ABS(JPRINT(20))
END IF
IF(JPRINT(21).EQ.IFULL) THEN
WRITE(LFNPR,7390)
ELSE IF(JPRINT(21).EQ.ILEW) THEN
WRITE(LFNPR,7392)
ELSE IF(IOINQR(JPRINT(21)).EQ.IPRNT) THEN
WRITE(LFNPR,7394) JPRINT(21)
ELSE IF(IOINQR(JPRINT(21)).EQ.IWRIT) THEN
WRITE(LFNPR,7396) ABS(JPRINT(21))
END IF
IF(JPRINT(48).EQ.IFULL) THEN
WRITE(LFNPR,7400)
ELSE IF(JPRINT(48).EQ.ILEW) THEN
WRITE(LFNPR,7402)
ELSE IF(IOINQR(JPRINT(48)).EQ.IPRNT) THEN
WRITE(LFNPR,7404) JPRINT(48)
ELSE IF(IOINQR(JPRINT(48)).EQ.IWRIT) THEN
WRITE(LFNPR,7406) ABS(JPRINT(48))
END IF
------------------------------------------------------------------------------
7000 FORMAT(1X,' /AOPNAO / : Print the AO to PNAO transformation')
7002 FORMAT(1X,' /AOPNAO / : Print ',I3,' columns of the AO to ',
* 'PNAO transformation')
7004 FORMAT(1X,' /AOPNAO / : Write the AO to PNAO transformation',
* ' to LFN',I3)
7010 FORMAT(1X,' /AONAO / : Print the AO to NAO transformation')
7012 FORMAT(1X,' /AONAO / : Print ',I3,' columns of the AO ',
* 'to NAO transformation')
7014 FORMAT(1X,' /AONAO / : Write the AO to NAO transformation ',
* 'to LFN',I3)
7016 FORMAT(1X,' /AONAO / : Read AO to NAO transformation from ',
* 'LFN',I3)
7020 FORMAT(1X,' /AOPNHO / : Print the AO to PNHO ',
* 'transformation')
7022 FORMAT(1X,' /AOPNHO / : Print ',I3,' columns of the AO to ',
* 'PNHO transformation')
7024 FORMAT(1X,' /AOPNHO / : Write the AO to PNHO transformation',
* ' to LFN',I3)
7030 FORMAT(1X,' /AONHO / : Print the AO to NHO transformation')
7032 FORMAT(1X,' /AONHO / : Print ',I3,' columns of the AO to ',
* 'NHO transformation')
7034 FORMAT(1X,' /AONHO / : Write the AO to NHO transformation ',
* 'to LFN',I3)
7040 FORMAT(1X,' /AOPNBO / : Print the AO to PNBO ',
* 'transformation')
7042 FORMAT(1X,' /AOPNBO / : Print the occupied PNBOs in the AO ',
* 'basis')
7044 FORMAT(1X,' /AOPNBO / : Print ',I3,' columns of the AO to ',
* 'PNBO transformation')
7046 FORMAT(1X,' /AOPNBO / : Write the AO to PNBO transformation',
* ' to LFN',I3)
7050 FORMAT(1X,' /AONBO / : Print the AO to NBO transformation')
7052 FORMAT(1X,' /AONBO / : Print the occupied NBOs in the AO ',
* 'basis')
7054 FORMAT(1X,' /AONBO / : Print ',I3,' columns of the AO ',
* 'to NBO transformation')
7056 FORMAT(1X,' /AONBO / : Write the AO to NBO transformation ',
* 'to LFN',I3)
7060 FORMAT(1X,' /AOPNLMO/ : Print the AO to PNLMO ',
* 'transformation')
7062 FORMAT(1X,' /AOPNLMO/ : Print the occupied PNLMOs in the AO',
* ' basis')
7064 FORMAT(1X,' /AOPNLMO/ : Print ',I3,' columns of the AO to ',
* 'PNLMO transformation')
7066 FORMAT(1X,' /AOPNLMO/ : Write the AO to PNLMO transformatio',
* 'n to LFN',I3)
7070 FORMAT(1X,' /AONLMO / : Print the AO to NLMO ',
* 'transformation')
7072 FORMAT(1X,' /AONLMO / : Print the occupied NLMOs in the AO ',
* 'basis')
7074 FORMAT(1X,' /AONLMO / : Print ',I3,' columns of the AO to ',
* 'NLMO transformation')
7076 FORMAT(1X,' /AONLMO / : Write the AO to NLMO transformation',
* ' to LFN',I3)
7080 FORMAT(1X,' /AOMO / : Print all MOs in the AO basis')
7082 FORMAT(1X,' /AOMO / : Print core and valence MOs in ',
* 'the AO basis')
7084 FORMAT(1X,' /AOMO / : Print the occupied MOs in the AO ',
* 'basis')
7086 FORMAT(1X,' /AOMO / : Print ',I3,' lowest energy MOs ',
* 'in the AO basis')
7088 FORMAT(1X,' /AOMO / : Write the AO to MO transformation ',
* 'to LFN',I3)
7090 FORMAT(1X,' /PAOPNAO/ : Print the PAO to PNAO ',
* 'transformation')
7092 FORMAT(1X,' /PAOPNAO/ : Print ',I3,' columns of the PAO ',
* 'to PNAO transformation')
7094 FORMAT(1X,' /PAOPNAO/ : Write the PAO to PNAO ',
* 'transformation to LFN',I3)
7096 FORMAT(1X,' /PAOPNAO/ : Read PAO to PNAO transformation ',
* 'from LFN',I3)
7100 FORMAT(1X,' /NAONHO / : Print the NAO to NHO transformation')
7102 FORMAT(1X,' /NAONHO / : Print ',I3,' columns of the NAO ',
* 'to NHO transformation')
7104 FORMAT(1X,' /NAONHO / : Write the NAO to NHO transformation',
* ' to LFN',I3)
7110 FORMAT(1X,' /NAONBO / : Print the NAO to NBO transformation')
7112 FORMAT(1X,' /NAONBO / : Print the occupied NBOs in the NAO ',
* 'basis')
7114 FORMAT(1X,' /NAONBO / : Print ',I3,' columns of the NAO ',
* 'to NBO transformation')
7116 FORMAT(1X,' /NAONBO / : Write the NAO to NBO transformation',
* ' to LFN',I3)
7118 FORMAT(1X,' /NAONBO / : Read NAO to NBO transformation from',
* ' LFN',I3)
7120 FORMAT(1X,' /NAONLMO/ : Print the NAO to NLMO ',
* 'transformation')
7122 FORMAT(1X,' /NAONLMO/ : Print the occupied NLMOs in the NAO',
* ' basis')
7124 FORMAT(1X,' /NAONLMO/ : Print ',I3,' columns of the NAO ',
* 'to NLMO transformation')
7126 FORMAT(1X,' /NAONLMO/ : Write the NAO to NLMO ',
* 'transformation to LFN',I3)
7130 FORMAT(1X,' /NAOMO / : Print all MOs in the NAO basis')
7132 FORMAT(1X,' /NAOMO / : Print core and valence MOs in ',
* 'the NAO basis')
7134 FORMAT(1X,' /NAOMO / : Print the occupied MOs in the NAO ',
* 'basis')
7136 FORMAT(1X,' /NAOMO / : Print ',I3,' lowest energy MOs ',
* 'in the NAO basis')
7138 FORMAT(1X,' /NAOMO / : Write the NAO to MO transformation ',
* 'to LFN',I3)
7140 FORMAT(1X,' /NHONBO / : Print the NHO to NBO transformation')
7142 FORMAT(1X,' /NHONBO / : Print the occupied NBOs in the NHO ',
* 'basis')
7144 FORMAT(1X,' /NHONBO / : Print ',I3,' columns of the NHO ',
* 'to NBO transformation')
7146 FORMAT(1X,' /NHONBO / : Write the NHO to NBO transformation',
* ' to LFN',I3)
7150 FORMAT(1X,' /NHONLMO/ : Print the NHO to NLMO ',
* 'transformation')
7152 FORMAT(1X,' /NHONLMO/ : Print the occupied NLMOs in the NHO',
* ' basis')
7154 FORMAT(1X,' /NHONLMO/ : Print ',I3,' columns of the NHO ',
* 'to NLMO transformation')
7156 FORMAT(1X,' /NHONLMO/ : Write the NHO to NLMO ',
* 'transformation to LFN',I3)
7160 FORMAT(1X,' /NHOMO / : Print all MOs in the NHO basis')
7162 FORMAT(1X,' /NHOMO / : Print core and valence MOs in ',
* 'the NHO basis')
7164 FORMAT(1X,' /NHOMO / : Print the occupied MOs in the NHO ',
* 'basis')
7166 FORMAT(1X,' /NHOMO / : Print ',I3,' lowest energy MOs ',
* 'in the NHO basis')
7168 FORMAT(1X,' /NHOMO / : Write the NHO to MO transformation ',
* 'to LFN',I3)
7170 FORMAT(1X,' /NBONLMO/ : Print the NBO to NLMO ',
* 'transformation')
7172 FORMAT(1X,' /NBONLMO/ : Print the occupied NLMOs in the NBO',
* ' basis')
7174 FORMAT(1X,' /NBONLMO/ : Print ',I3,' columns of the NBO ',
* 'to NLMO transformation')
7176 FORMAT(1X,' /NBONLMO/ : Write the NBO to NLMO ',
* 'transformation to LFN',I3)
7180 FORMAT(1X,' /NBOMO / : Print all MOs in the NBO basis')
7182 FORMAT(1X,' /NBOMO / : Print core and valence MOs in ',
* 'the NBO basis')
7184 FORMAT(1X,' /NBOMO / : Print the occupied MOs in the NBO ',
* 'basis')
7186 FORMAT(1X,' /NBOMO / : Print ',I3,' lowest energy MOs ',
* 'in the NBO basis')
7188 FORMAT(1X,' /NBOMO / : Write the NBO to MO transformation ',
* 'to LFN',I3)
7190 FORMAT(1X,' /NLMOMO / : Print all MOs in the NLMO basis')
7192 FORMAT(1X,' /NLMOMO / : Print core and valence MOs in ',
* 'the NLMO basis')
7194 FORMAT(1X,' /NLMOMO / : Print the occupied MOs in the NLMO ',
* 'basis')
7196 FORMAT(1X,' /NLMOMO / : Print ',I3,' lowest energy MOs ',
* 'in the NLMO basis')
7198 FORMAT(1X,' /NLMOMO / : Write the NLMO to MO transformation',
* ' to LFN',I3)
7200 FORMAT(1X,' /BOAO / : Print the AO bond-order matrix')
7202 FORMAT(1X,' /BOAO / : Print ',I3,' columns of the AO ',
* 'bond-order matrix')
7204 FORMAT(1X,' /BOAO / : Write the AO bond-order matrix to ',
* 'LFN',I3)
7210 FORMAT(1X,' /DMAO / : Print the AO density matrix')
7212 FORMAT(1X,' /DMAO / : Print ',I3,' columns of the AO ',
* 'density matrix')
7214 FORMAT(1X,' /DMAO / : Write the AO density matrix to ',
* 'LFN',I3)
7220 FORMAT(1X,' /DMNAO / : Print the NAO density matrix')
7222 FORMAT(1X,' /DMNAO / : Print ',I3,' columns of the NAO ',
* 'density matrix')
7224 FORMAT(1X,' /DMNAO / : Write the NAO density matrix to ',
* 'LFN',I3)
7230 FORMAT(1X,' /DMNHO / : Print the NHO density matrix')
7232 FORMAT(1X,' /DMNHO / : Print ',I3,' columns of the NHO ',
* 'density matrix')
7234 FORMAT(1X,' /DMNHO / : Write the NHO density matrix to ',
* 'LFN',I3)
7240 FORMAT(1X,' /DMNBO / : Print the NBO density matrix')
7242 FORMAT(1X,' /DMNBO / : Print the density matrix elements ',
* 'of the occupied NBOs')
7244 FORMAT(1X,' /DMNBO / : Print ',I3,' columns of the NBO ',
* 'density matrix')
7246 FORMAT(1X,' /DMNBO / : Write the NBO density matrix to ',
* 'LFN',I3)
7250 FORMAT(1X,' /DMNLMO / : Print the NLMO density matrix')
7252 FORMAT(1X,' /DMNLMO / : Print the density matrix elements ',
* 'of the occupied NLMOs')
7254 FORMAT(1X,' /DMNLMO / : Print ',I3,' columns of the NLMO ',
* 'density matrix')
7256 FORMAT(1X,' /DMNLMO / : Write the NLMO density matrix to ',
* 'LFN',I3)
7260 FORMAT(1X,' /FAO / : Print the AO Fock matrix')
7262 FORMAT(1X,' /FAO / : Print ',I3,' columns of the AO ',
* 'Fock matrix')
7264 FORMAT(1X,' /FAO / : Write the AO Fock matrix to ',
* 'LFN',I3)
7270 FORMAT(1X,' /FNAO / : Print the NAO Fock matrix')
7272 FORMAT(1X,' /FNAO / : Print ',I3,' columns of the NAO ',
* 'Fock matrix')
7274 FORMAT(1X,' /FNAO / : Write the NAO Fock matrix to ',
* 'LFN',I3)
7280 FORMAT(1X,' /FNHO / : Print the NHO Fock matrix')
7282 FORMAT(1X,' /FNHO / : Print ',I3,' columns of the NHO ',
* 'Fock matrix')
7284 FORMAT(1X,' /FNHO / : Write the NHO Fock matrix to ',
* 'LFN',I3)
7290 FORMAT(1X,' /FNBO / : Print the NBO Fock matrix')
7292 FORMAT(1X,' /FNBO / : Print the Fock matrix elements of ',
* 'the occupied NBOs')
7294 FORMAT(1X,' /FNBO / : Print ',I3,' columns of the NBO ',
* 'Fock matrix')
7296 FORMAT(1X,' /FNBO / : Write the NBO Fock matrix to ',
* 'LFN',I3)
7300 FORMAT(1X,' /FNLMO / : Print the NLMO Fock matrix')
7302 FORMAT(1X,' /FNLMO / : Print the Fock matrix elements of ',
* 'the occupied NLMOs')
7304 FORMAT(1X,' /FNLMO / : Print ',I3,' columns of the NLMO ',
* 'Fock matrix')
7306 FORMAT(1X,' /FNLMO / : Write the NLMO Fock matrix to ',
* 'LFN',I3)
7310 FORMAT(1X,' /DIAO / : Print the AO dipole integrals')
7312 FORMAT(1X,' /DIAO / : Print ',I3,' columns of the AO ',
* 'dipole matrices')
7314 FORMAT(1X,' /DIAO / : Write the AO dipole integrals',
* ' to LFN',I3)
7320 FORMAT(1X,' /DINAO / : Print the NAO dipole integrals')
7322 FORMAT(1X,' /DINAO / : Print ',I3,' columns of the NAO ',
* 'dipole matrices')
7324 FORMAT(1X,' /DINAO / : Write the NAO dipole integrals',
* ' to LFN',I3)
7330 FORMAT(1X,' /DINHO / : Print the NHO dipole integrals')
7332 FORMAT(1X,' /DINHO / : Print ',I3,' columns of the NHO ',
* 'dipole matrices')
7334 FORMAT(1X,' /DINHO / : Write the NHO dipole integrals',
* ' to LFN',I3)
7340 FORMAT(1X,' /DINBO / : Print the NBO dipole integrals')
7342 FORMAT(1X,' /DINBO / : Print the dipole integrals of ',
* 'occupied NBOs')
7344 FORMAT(1X,' /DINBO / : Print ',I3,' columns of the NBO ',
* 'dipole matrices')
7346 FORMAT(1X,' /DINBO / : Write the NBO dipole integrals',
* ' to LFN',I3)
7350 FORMAT(1X,' /DINLMO / : Print the NLMO dipole integrals')
7352 FORMAT(1X,' /DINLMO / : Print the dipole integrals of ',
* 'occupied NLMOs')
7354 FORMAT(1X,' /DINLMO / : Print ',I3,' columns of the NLMO ',
* 'dipole matrices')
7356 FORMAT(1X,' /DINLMO / : Write the NLMO dipole integrals',
* ' to LFN',I3)
7360 FORMAT(1X,' /SAO / : Print the AO overlap matrix')
7362 FORMAT(1X,' /SAO / : Print ',I3,' columns of the AO ',
* 'overlap matrix')
7364 FORMAT(1X,' /SAO / : Write the AO overlap matrix to ',
* 'LFN',I3)
7370 FORMAT(1X,' /SPNAO / : Print the PNAO overlap matrix')
7372 FORMAT(1X,' /SPNAO / : Print ',I3,' columns of the PNAO ',
* 'overlap matrix')
7374 FORMAT(1X,' /SPNAO / : Write the PNAO overlap matrix to ',
* 'LFN',I3)
7380 FORMAT(1X,' /SPNHO / : Print the PNHO overlap matrix')
7382 FORMAT(1X,' /SPNHO / : Print ',I3,' columns of the PNHO ',
* 'overlap matrix')
7384 FORMAT(1X,' /SPNHO / : Write the PNHO overlap matrix to ',
* 'LFN',I3)
7390 FORMAT(1X,' /SPNBO / : Print the PNBO overlap matrix')
7392 FORMAT(1X,' /SPNBO / : Print the overlap matrix elements ',
* 'of the occupied PNBOs')
7394 FORMAT(1X,' /SPNBO / : Print ',I3,' columns of the PNBO ',
* 'overlap matrix')
7396 FORMAT(1X,' /SPNBO / : Write the PNBO overlap matrix to ',
* 'LFN',I3)
7400 FORMAT(1X,' /SPNLMO / : Print the PNLMO overlap matrix')
7402 FORMAT(1X,' /SPNLMO / : Print the overlap matrix elements ',
* 'of the occupied PNLMOs')
7404 FORMAT(1X,' /SPNLMO / : Print ',I3,' columns of the PNLMO ',
* 'overlap matrix')
7406 FORMAT(1X,' /SPNLMO / : Write the PNLMO overlap matrix to ',
* 'LFN',I3)
------------------------------------------------------------------------------
OTHER OUTPUT CONTROL KEYWORDS:
IF(LFNPR.NE.6) WRITE(LFNPR,8000) LFNPR
IF(JPRINT(43).NE.0) WRITE(LFNPR,8010)
IF(IWDETL.NE.0) WRITE(LFNPR,8020)
IF(JPRINT(7).NE.0) WRITE(LFNPR,8030) JPRINT(7)
IF(JPRINT(12).NE.0) WRITE(LFNPR,8040)
IF(LFNDAF.GE.0) WRITE(LFNPR,8050) LFNDAF
IF(JPRINT(22).NE.0) WRITE(LFNPR,8060) JPRINT(22)
IF(IWMULP.EQ.1) WRITE(LFNPR,8070)
IF(IWMULP.EQ.2) WRITE(LFNPR,8080)
IF(IWAPOL.NE.0) WRITE(LFNPR,8090)
IF(JPRINT(11).NE.0) WRITE(LFNPR,8100)
IF(LENNM.NE.0) WRITE(LFNPR,8110) FILENM(1:52)
IF(IPRINT.LT.10) THEN
WRITE(LFNPR,8500) IPRINT
ELSE
IPRINT = IPRINT - 10
END IF
------------------------------------------------------------------------------
8000 FORMAT(1X,' /LFNPR / : set to',I3)
8010 FORMAT(1X,' /PLOT / : Write information for the orbital',
* ' plotter')
8020 FORMAT(1X,' /DETAIL / : Write out details of NBO search')
8030 FORMAT(1X,' /ARCHIVE/ : Write the archive file to LFN',I3)
8040 FORMAT(1X,' /BNDIDX / : Print bond indices based on ',
* 'the NAO density matrix')
8050 FORMAT(1X,' /NBODAF / : NBO direct access file written on',
* ' LFN',I3)
8060 FORMAT(1X,' /AOINFO / : Write AO information to LFN',I3)
8070 FORMAT(1X,' /MULAT / : Print Mulliken populations',
* ' by atom')
8080 FORMAT(1X,' /MULORB / : Print Mulliken populations',
* ' by orbital and atom')
8090 FORMAT(1X,' /APOLAR / : Enforce apolar NBOs')
8100 FORMAT(1X,' /RPNAO / : Revise TPNAO with TRYD and TRED')
8110 FORMAT(1X,' /FILE / : Set to ',A52)
8500 FORMAT(1X,' /PRINT / : Print level set to',I3)
------------------------------------------------------------------------------
END IF
SET PRINT LEVEL OPTIONS:
IF(IPRINT.GT.0) THEN
JPRINT(4) = 1
JPRINT(5) = 1
END IF
IF(IPRINT.GT.1) THEN
JPRINT(3) = 1
JPRINT(6) = 1
JPRINT(36) = 1
END IF
IF(IPRINT.GT.2) THEN
JPRINT(8) = 1
JPRINT(12) = 1
JPRINT(46) = 1
END IF
IF(IPRINT.GT.3) THEN
IF(JPRINT(7).EQ.0) JPRINT(7) = LFNARC
IF(JPRINT(9).EQ.0) JPRINT(9) = IFULL
IF(JPRINT(13).EQ.0) JPRINT(13) = IFULL
JPRINT(14) = 1
IF(JPRINT(15).EQ.0) JPRINT(15) = IFULL
IF(JPRINT(16).EQ.0) JPRINT(16) = IFULL
IF(JPRINT(17).EQ.0) JPRINT(17) = IFULL
IF(JPRINT(18).EQ.0) JPRINT(18) = IFULL
IF(JPRINT(19).EQ.0) JPRINT(19) = IFULL
IF(JPRINT(20).EQ.0) JPRINT(20) = IFULL
IF(JPRINT(21).EQ.0) JPRINT(21) = IFULL
IF(JPRINT(24).EQ.0) JPRINT(24) = IFULL
IF(JPRINT(29).EQ.0) JPRINT(29) = IFULL
IF(JPRINT(31).EQ.0) JPRINT(31) = IFULL
IF(JPRINT(32).EQ.0) JPRINT(32) = 1
IF(JPRINT(33).EQ.0) JPRINT(33) = IFULL
IF(JPRINT(34).EQ.0) JPRINT(34) = IFULL
IF(JPRINT(35).EQ.0) JPRINT(35) = IFULL
IF(JPRINT(37).EQ.0) JPRINT(37) = IFULL
IF(JPRINT(38).EQ.0) JPRINT(38) = IFULL
IF(JPRINT(39).EQ.0) JPRINT(39) = IFULL
IF(JPRINT(40).EQ.0) JPRINT(40) = IFULL
IF(JPRINT(41).EQ.0) JPRINT(41) = IFULL
IF(JPRINT(42).EQ.0) JPRINT(42) = IFULL
JPRINT(43) = 1
IF(JPRINT(45).EQ.0) JPRINT(45) = IFULL
IF(JPRINT(47).EQ.0) JPRINT(47) = IFULL
IF(JPRINT(48).EQ.0) JPRINT(48) = IFULL
IF(JPRINT(50).EQ.0) JPRINT(50) = IFULL
IF(JPRINT(51).EQ.0) JPRINT(51) = IFULL
IF(JPRINT(52).EQ.0) JPRINT(52) = IFULL
IF(JPRINT(53).EQ.0) JPRINT(53) = IFULL
IF(JPRINT(54).EQ.0) JPRINT(54) = IFULL
IF(JPRINT(55).EQ.0) JPRINT(55) = 1
IF(IWTNAB.EQ.0) IWTNAB = IFULL
IWDETL = 1
IF(IWDM.NE.0) IWMULP = 2
END IF
TURN ON THE NLMO ANALYSIS IF REQUIRED:
IF(JPRINT(13).NE.0) JPRINT(8) = 1
IF(JPRINT(15).NE.0) JPRINT(8) = 1
IF(JPRINT(17).NE.0) JPRINT(8) = 1
IF(JPRINT(18).NE.0) JPRINT(8) = 1
IF(JPRINT(23).NE.0) JPRINT(8) = 1
IF(JPRINT(46).NE.0) JPRINT(8) = 1
IF(JPRINT(47).NE.0) JPRINT(8) = 1
IF(JPRINT(48).NE.0) JPRINT(8) = 1
IF(JPRINT(49).NE.0) JPRINT(8) = 1
IF(JPRINT(54).NE.0) JPRINT(8) = 1
TAKE CARE OF THE PLOT OPTION:
IF(JPRINT(43).NE.0) THEN
JPRINT(8) = 1
IF(JPRINT(22).EQ.0) JPRINT(22) = LFNAO
IF(IWTNAO.EQ.0) IWTNAO = -LFNNAO
IF(JPRINT(28).EQ.0) JPRINT(28) = -LFNNHO
IF(IWTNBO.EQ.0) IWTNBO = -LFNNBO
IF(JPRINT(23).EQ.0) JPRINT(23) = -LFNNLM
IF(JPRINT(26).EQ.0) JPRINT(26) = -LFNMO
IF(JPRINT(27).EQ.0) JPRINT(27) = -LFNDM
IF(JPRINT(44).EQ.0) JPRINT(44) = -LFNPNA
IF(JPRINT(30).EQ.0) JPRINT(30) = -LFNPNH
IF(JPRINT(25).EQ.0) JPRINT(25) = -LFNPNB
IF(JPRINT(49).EQ.0) JPRINT(49) = -LFNPNL
END IF
PRINT HYBRIDS IF THE NBO OUTPUT IS REQUESTED:
IWHYBS = JPRINT(5)
RETURN
ABORT PROGRAM: UNRECOGNIZABLE KEYWORD ENCOUNTERED
4800 WRITE(LFNPR,9800) (KEYWD(I),I=1,6)
STOP
INCOMPATIBLE JOB OPTIONS HAVE BEEN REQUESTED:
4900 CONTINUE
WRITE(LFNPR,9900)
STOP
9800 FORMAT(1X,'Error: Unrecognizable keyword >>',6A1,'<<',/,1X,
* 'Program must halt.')
9900 FORMAT(1X,'The NBO program must stop because the options /MULAT/',
+ ' and /MULORB/',/1X,'currently require the AO bond order matrix',
+ ', rather than the AO density',/1X,'matrix. The program could ',
+ 'be modified to permit this.')
END
*****************************************************************************
SUBROUTINE NBODIM(MEMORY)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION NSPDFG(5,2)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBBAS/LABEL(MAXBAS,6),LVAL(MAXBAS),IMVAL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
DATA IREAD/4HREAD/
NBODIM: SET UP DIMENSIONING INFORMATION, LISTS IN COMMON/NBATOM/,
AND COMPARE STORAGE NEEDS WITH AMOUNT OF STORAGE AVAILABLE
FIND:
MXAOLM, THE MAXIMUM NUMBER OF ATOMIC ORBITALS OF THE SAME SYMMETRY
ON A SINGLE ATOM
MXAO, THE MAXIMUM NUMBER OF ATOMIC ORBITALS PER ATOM
MXBO, THE MAXIMUM NUMBER OF ATOMIC ORBITALS PER TWO-CENTER OR
THREE-CENTER BOND
DO 300 I = 1,NBAS
LM = LANG(I)
LVAL(I) = LM/100
IM = LM - LVAL(I)*100
IF(IM.GT.50) IM = IM - 50
IMVAL(I) = IM
300 CONTINUE
MXAO = 0
MXAO2 = 0
MXAO3 = 0
MXAOLM = 0
LLU = 0
DO 500 I = 1,NATOMS
N = 0
DO 400 IL = 1,5
DO 400 ITYP = 1,2
400 NSPDFG(IL,ITYP) = 0
DO 410 J = 1,NBAS
IF(LCTR(J).NE.I) GO TO 410
LM = LANG(J)
L = LM/100
IM = LM - L*100
IF IM.NE.1 (THAT IS, IF THIS IS NOT THE FIRST COMPONENT OF THE
ANG. MOM. L FUNCTIONS ON THE ATOM), DON'T COUNT IT IN NSPDFG:
IF(IM.NE.1) GO TO 410
ITYP=1 FOR CARTESIAN FUNCTION, =2 FOR TRUE SPHERICAL HARMONIC:
ITYP = 1
IF(IM.GT.50) ITYP = 2
IL = L + 1
NSPDFG(IL,ITYP) = NSPDFG(IL,ITYP)+1
410 IF(LCTR(J).EQ.I) N = N + 1
NUMBER OF S ORBITALS= NO. S ORBS INPUT + NO. CARTESIAN D AND G ORBS:
NSPDFG(1,1) = NSPDFG(1,1) + NSPDFG(1,2) + NSPDFG(3,1) +
+ NSPDFG(5,1)
NUMBER OF P ORBITALS= NO. P ORBS INPUT + NO. CARTESIAN F ORBS:
NSPDFG(2,1) = NSPDFG(2,1) + NSPDFG(2,2) + NSPDFG(4,1)
NUMBER OF D ORBITALS= NO. D ORBS INPUT + NO. CARTESIAN G ORBS:
NSPDFG(3,1) = NSPDFG(3,1) + NSPDFG(3,2) + NSPDFG(5,1)
NUMBER OF F ORBITALS:
NSPDFG(4,1) = NSPDFG(4,1) + NSPDFG(4,2)
NUMBER OF G ORBITALS:
NSPDFG(5,1) = NSPDFG(5,1) + NSPDFG(5,2)
DO 430 IL = 1,5
IF(NSPDFG(IL,1).LE.MXAOLM) GO TO 430
MXAOLM = NSPDFG(IL,1)
430 CONTINUE
NORBS(I) = N
LL(I) = LLU + 1
LU(I) = LL(I) + N - 1
LLU = LU(I)
IF(N.LE.MXAO) GO TO 460
MXAO3 = MXAO2
MXAO2 = MXAO
MXAO = N
GO TO 500
460 IF(N.LE.MXAO2) GO TO 480
MXAO3 = MXAO2
MXAO2 = N
GO TO 500
480 IF(N.LE.MXAO3) GO TO 500
MXAO3 = N
500 CONTINUE
MXBO = MXAO + MXAO2
IF(IW3C.EQ.1) MXBO = MXBO + MXAO3
COMPUTE STORAGE REQUIREMENTS AND COMPARE WITH AVAILABLE CORE SPACE:
STORAGE FOR DENSITY MATRIX (DM) AND TRANSFORMATIONS (T):
NEED0 = 2*NDIM*NDIM
COMPUTE STORAGE FOR NATURAL POPULATION ANALYSIS:
NEED1 = 0
IO = IOINQR(IWTNAO)
IF(IO.NE.IREAD.AND..NOT.ORTHO) THEN
NEED = NDIM + NDIM + NDIM*NDIM + MXAOLM*MXAOLM + NDIM
+ + MXAOLM*MXAOLM + MXAOLM*MXAOLM + NDIM + 9*MXAOLM
NEED1 = MAX(NEED1,NEED)
END IF
NEED = NATOMS*NATOMS + NATOMS + NATOMS*NATOMS + NATOMS*NATOMS +
+ NDIM*NDIM + NDIM
NEED1 = MAX(NEED1,NEED)
NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM
NEED1 = MAX(NEED1,NEED)
IF(JPRINT(9).NE.0) THEN
NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM*NDIM + NDIM*(NDIM+5)
NEED1 = MAX(NEED1,NEED)
END IF
NEED1 = NEED1 + NEED0
COMPUTE STORAGE FOR NATURAL BOND ORBITAL ANALYSIS:
NEED2 = 0
IF(JPRINT(1).EQ.0) THEN
IF(IOINQR(IWTNAB).NE.IREAD) THEN
NEED = NATOMS*NATOMS + NDIM + 3*NDIM + MXAO*NDIM + NDIM
+ + MXBO*MXBO + MXBO*MXBO + MXBO + MXBO + MXAO*MXAO
+ + MXAO*MXAO + MXAO + MXAO + MXAO + NATOMS*NATOMS
ELSE
NEED = NATOMS*NATOMS + NDIM + 3*NDIM
END IF
NEED2 = MAX(NEED2,NEED)
IF(.NOT.ORTHO) THEN
NEED = NATOMS*NATOMS + 4*NDIM*NDIM + MXAO + 3*NDIM
NEED2 = MAX(NEED2,NEED)
END IF
NEED = NATOMS*NATOMS + NDIM + MXAO + NDIM*NDIM + NDIM*NDIM
+ + NDIM + NDIM
NEED2 = MAX(NEED2,NEED)
NEED = NATOMS*NATOMS + NDIM + NDIM + NDIM + NDIM*NDIM
NEED2 = MAX(NEED2,NEED)
IF(JPRINT(36).NE.0) THEN
NEED = NATOMS*NATOMS + NDIM + 3*NATOMS + NDIM*NDIM
+ + NDIM*NDIM + NDIM
NEED2 = MAX(NEED2,NEED)
END IF
NEED = NATOMS*NATOMS + NDIM + NDIM*NDIM + NDIM*NDIM
+ + NDIM*(NDIM+5)
NEED2 = MAX(NEED2,NEED)
IF(JPRINT(6).NE.0) THEN
NEED = NATOMS*NATOMS + NDIM + NDIM*NDIM + NDIM + NATOMS
+ + NDIM
NEED2 = MAX(NEED2,NEED)
END IF
COMPUTE STORAGE FOR NATURAL LOCALIZED MOLECULAR ORBITAL ANALYSIS:
NEED3 = 0
IF(JPRINT(8).NE.0) THEN
NEED = NATOMS*NATOMS + NDIM + NDIM + NDIM*NDIM + NDIM*NDIM
NEED3 = MAX(NEED3,NEED)
NEED = NDIM + NDIM + NDIM + NATOMS*NATOMS + 2*NATOMS*NATOMS
+ + NDIM*NATOMS + NDIM*NATOMS*(NATOMS-1)/2 + NDIM*NDIM
NEED3 = MAX(NEED3,NEED)
NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM*NDIM + NDIM*(NDIM+5)
NEED3 = MAX(NEED3,NEED)
IF(JPRINT(46).NE.0) THEN
NEED = NDIM*NDIM + NDIM*NDIM + NDIM*NDIM + NDIM*NDIM
+ + NDIM*NDIM + NDIM*NDIM + NDIM + NATOMS*NATOMS
NEED3 = MAX(NEED3,NEED)
END IF
END IF
END IF
PRINT SCRATCH STORAGE REQUIREMENTS:
IF(IPRINT.GE.0) THEN
IF(JPRINT(1).EQ.0) THEN
IF(JPRINT(8).NE.0) THEN
WRITE(LFNPR,3300) NEED1,NEED2,NEED3,MEMORY
ELSE
NEED3 = 0
WRITE(LFNPR,3200) NEED1,NEED2,MEMORY
END IF
ELSE
NEED2 = 0
NEED3 = 0
WRITE(LFNPR,3100) NEED1,MEMORY
END IF
END IF
IF(NEED1.GT.MEMORY.OR.NEED2.GT.MEMORY.OR.NEED3.GT.MEMORY) GOTO 990
RETURN
990 WRITE(LFNPR,9900)
STOP
3100 FORMAT(/1X,'Storage needed:',I6,' in NPA (',I7,' available)')
3200 FORMAT(/1X,'Storage needed:',I6,' in NPA,',I6,' in NBO (',I7,
+ ' available)')
3300 FORMAT(/1X,'Storage needed:',I6,' in NPA,',I6,' in NBO,',I6,
+ ' in NLMO (',I7,' available)')
9900 FORMAT(/1X,'*** Not enough core storage is available ***'/)
END
**************************************************************************
NAO/NBO/NLMO FORMATION ROUTINES: (CALLED BY SR NBO)
SUBROUTINE NAODRV(DM,T,A)
SUBROUTINE NAOSIM(DM,T,A)
SUBROUTINE DMNAO(DM,T,A)
SUBROUTINE DMSIM(DM,T,A)
SUBROUTINE NBODRV(DM,T,A,MEMORY)
**************************************************************************
SUBROUTINE NAODRV(DM,T,A)
**************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DRIVER SUBROUTINE TO CALCULATE NATURAL ATOMIC ORBITALS (NAOS)
GIVEN 1-PARTICLE DENSITY MATRIX IN AN ARBITRARY ATOM-CENTERED
ATOMIC ORBITAL BASIS SET.
T = OVERLAP MATRIX FOR THE PRIMITIVE AO BASIS
(ON RETURN, THIS IS THE AO TO NAO TRANSFORMATION MATRIX)
DM = DENSITY MATRIX IN THE PRIMITIVE AO BASIS
(OR BOND-ORDER MATRIX, IF IWDM = 1)
THE SPIN NATURE OF DM IS INDICATED BY:
ISPIN = 0: SPINLESS (CLOSED SHELL)
ISPIN = +2: ALPHA SPIN
ISPIN = -2: SPIN
(ISPIN IS THE RECIPROCAL OF THE S(Z) QUANTUM NO.)
A = SCRATCH STORAGE FROM THE MAIN PROGRAM. THE LOCATION OF A(1)
IS IN THE COMMON BLOCK /SCM/ IN THE MAIN PROGRAM,
AFTER THE STORAGE FOR THE MATRICES 'S','DM'
('A' IS THE VECTOR WHICH IS PARTITIONED
ACCORDING TO THE STORAGE NEEDS OF EACH PROGRAM RUN)
ATOM, BASIS, OPTION, NBINFO: COMMON BLOCKS WITH DATA TRANSFERED FROM
FROM THE INPUT PROGRAMS.
-----------------------------------------------------------------------------
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(1)
CHARACTER*80 TITLE
DATA ONE/1.0D0/
DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/
FORM LABELS FOR THE RAW AO BASIS SET:
CALL LBLAO
COPY THE AO CENTERS AND LABELS FROM /NBAO/ TO /NBBAS/:
DO 5 I = 1,NBAS
LBL(I) = LCTR(I)
LORBC(I) = LANG(I)
5 CONTINUE
WRITE OUT THE AO BASIS SET INFORMATION:
IF(JPRINT(22).GT.0) THEN
CALL WRBAS(A,A,JPRINT(22))
END IF
WRITE OUT THE ARCHIVE FILE:
IF(JPRINT(7).NE.0) THEN
CALL WRARC(A,A,JPRINT(7))
END IF
OUTPUT THE AO OVERLAP MATRIX:
IO = IOINQR(JPRINT(39))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'AO overlap matrix:'
CALL AOUT(T,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(39))
END IF
OUTPUT THE AO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(26))
IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
CALL FEAOMO(A,IT)
IF(IT.NE.0) THEN
TITLE = 'MOs in the AO basis:'
CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26))
END IF
END IF
OUTPUT THE AO FOCK MATRIX:
IO = IOINQR(JPRINT(40))
IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
CALL FEFAO(A,IWFOCK)
IF(IWFOCK.NE.0) THEN
TITLE = 'AO Fock matrix:'
CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40))
END IF
END IF
OUTPUT THE AO BOND-ORDER MATRIX:
IO = IOINQR(JPRINT(42))
IF(IWDM.EQ.1.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
TITLE = 'Spinless AO bond-order matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(42))
END IF
CONVERT THE BOND-ORDER MATRIX TO THE DENSITY MATRIX:
IF(IWDM.NE.0) CALL SIMTRM(DM,T,A,NDIM,NBAS,IWMULP,IWCUBF)
OUTPUT THE AO DENSITY MATRIX:
IO = IOINQR(JPRINT(27))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'Spinless AO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27))
END IF
OUTPUT THE AO DIPOLE MATRICES:
IO = IOINQR(JPRINT(50))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
IX = 1
CALL FEDXYZ(A,IX)
IF(IX.NE.0) THEN
TITLE = 'AO x dipole integrals:'
CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
END IF
IX = 2
CALL FEDXYZ(A,IX)
IF(IX.NE.0) THEN
TITLE = 'AO y dipole integrals:'
CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
END IF
IX = 3
CALL FEDXYZ(A,IX)
IF(IX.NE.0) THEN
TITLE = 'AO z dipole integrals:'
CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
END IF
END IF
ALLOCATE SCRATCH COMMON FOR NAO ROUTINES:
A(I1) = V(NDIM) (ALSO USED FOR GUIDE(NATOMS,NATOMS))
A(I2) = RENORM(NDIM)
A(I3) = BLK(NDIM,NDIM)
A(I4) = SBLK(MXAOLM,MXAOLM)
A(I5) = EVAL(NDIM)
A(I6) = C(MXAOLM,MXAOLM)
A(I7) = EVECT(MXAOLM,MXAOLM)
A(I8) = EVAL2(NDIM)
LEAVE THIS LAST IN THE LIST SINCE THESE ARE INTEGERS:
A(I9) = LISTAO(MXAOLM,9)
NBLOCK = MXAOLM*MXAOLM
I1 = 1
I2 = I1 + NDIM
I3 = I2 + NDIM
I4 = I3 + NDIM*NDIM
I5 = I4 + NBLOCK
I6 = I5 + NDIM
I7 = I6 + NBLOCK
I8 = I7 + NBLOCK
I9 = I8 + NDIM
IEND = I9 + 9*MXAOLM
READ IN T-NAO, NAO LABELS, THE PNAO OVERLAP MATRIX, AND COMPUTE THE
NAO DENSITY MATRIX: (NOTE THAT T CONTAINS THE PNAO OVERLAP MATRIX
AFTER RDTNAO IS CALLED)
IF(IOINQR(IWTNAO).EQ.IREAD) THEN
CALL RDTNAO(DM,T,A(I1),IWTNAO)
GO TO 580
END IF
TRANSFORM ALL SETS OF CARTESIAN D,F,G ORBITALS, AND RELABEL ALL ORBITALS:
CALL DFGORB(A(I2),DM,T,ICTRAN,IWCUBF,0,LFNPR)
STORE PURE AO DENSITY MATRIX IN SCRATCH STORAGE:
CALL SVPPAO(DM)
CONSOLIDATE DENSITY MATRIX AND OVERLAP MATRIX IN DM:
CALL CONSOL(DM,T,NDIM,NBAS)
FIND NATURAL ATOMIC ORBITAL BASIS SET TRANSFORMATION T FROM DM:
(UPON RETURN, DM CONTAINS THE FULL NAO DENSITY MATRIX)
CALL NAO(T,DM,A(I1),A(I3),A(I4),A(I5),A(I6),A(I7),A(I8),A(I9),
* NBLOCK)
IF D ORBITALS WERE TRANSFORMED, TRANSFORM THE NAO TRANSFORMATION T
SO THAT T IS THE TRANSFORM FROM THE ORIGINAL AO'S TO THE NAO'S:
IF(ICTRAN.NE.0) CALL DFGORB(A(I2),DM,T,IDTRAN,IWCUBF,1,LFNPR)
SAVE TNAO FOR LATER USE:
CALL SVTNAO(T)
IF D ORBITALS WERE TRANSFORMED, TRANSFORM THE PNAO TRANSFORMATION
SO THAT IT IS THE TRANSFORM FROM THE ORIGINAL AO'S TO THE PNAO'S:
CALL FEPNAO(A(I3))
FOR CASE THAT RPNAOS ARE WRITTEN TO DISK, SET OCCUPANCY WEIGHTS TO -1
AS A SIGNAL THAT THEY SHOULD BE RECOMPUTED:
DO 260 I = 0,NBAS-1
260 A(I4+I) = -ONE
IF(ICTRAN.NE.0) CALL DFGORB(A(I2),DM,A(I3),IDTRAN,IWCUBF,1,LFNPR)
COMPUTE NON-ORTHOGONAL NAO OVERLAP MATRIX, SPNAO:
CALL FESRAW(T)
CALL SIMTRS(T,A(I3),A(I4),NDIM,NBAS)
CALL SVSNAO(T)
WRITE T-NAO, NAO LABELS, AND THE PNAO OVERLAP MATRIX:
IF(IOINQR(IWTNAO).EQ.IWRIT) CALL WRTNAO(T,IWTNAO)
DM IS NOW THE DENSITY MATRIX IN THE NAO BASIS
T IS THE NON-ORTHOGONAL PNAO OVERLAP MATRIX (!!!)
580 CONTINUE
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NATOMS
I4 = I3 + NATOMS*NATOMS
I5 = I4 + NATOMS*NATOMS
I6 = I5 + NDIM*NDIM
IEND = I6 + NDIM
CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
DO NOT DESTROY THE MATRIX AT A(I1). THIS HOLDS THE WIBERG BOND
INDEX WHICH NEEDS TO BE PASSED TO THE NBO ROUTINES.
SAVE THE NAO DENSITY MATRIX:
CALL SVDNAO(DM)
FORM THE NAO LABELS:
CALL LBLNAO
REORGANIZE THE SCRATCH VECTOR:
I1 = 1
I2 = I1 + NATOMS*NATOMS
IEND = I2 + NDIM*NDIM
OUTPUT THE AO-PNAO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(44))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEPNAO(T)
TITLE = 'PNAOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(44))
END IF
OUTPUT THE PNAO OVERLAP MATRIX:
IO = IOINQR(JPRINT(19))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FESNAO(A(I2))
TITLE = 'PNAO overlap matrix:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(19))
END IF
FETCH THE AO-NAO TRANSFORMATION FROM THE NBO DAF:
CALL FETNAO(T)
PRINT THE AO-NAO TRANSFORMATION MATRIX:
IF(IOINQR(IWTNAO).EQ.IPRNT) THEN
TITLE = 'NAOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IWTNAO)
END IF
OUTPUT THE NAO DIPOLE MATRICES:
IO = IOINQR(JPRINT(51))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
IX = 1
CALL FEDXYZ(A(I2),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NAO x dipole integrals:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51))
END IF
IX = 2
CALL FEDXYZ(A(I2),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NAO y dipole integrals:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51))
END IF
IX = 3
CALL FEDXYZ(A(I2),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NAO z dipole integrals:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51))
END IF
END IF
IF THIS IS AN OPEN SHELL WAVEFUNCTION, DON'T DO ANYTHING MORE:
IF(OPEN) RETURN
OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(9))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
I4 = I3 + NDIM*NDIM
IEND = I4 + NDIM*(NDIM+5)
CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
END IF
REORGANIZE THE SCRATCH VECTOR:
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
IEND = I3 + NDIM
OUTPUT THE NAO FOCK MATRIX:
IO = IOINQR(JPRINT(31))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEFAO(A(I2),IWFOCK)
IF(IWFOCK.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NAO Fock matrix:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31))
END IF
END IF
OUTPUT THE NAO DENSITY MATRIX:
IO = IOINQR(JPRINT(35))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'NAO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35))
END IF
RETURN
END
*****************************************************************************
SUBROUTINE NAOSIM(DM,T,A)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1)
CHARACTER*80 TITLE
DATA ZERO,ONE/0.0D0,1.0D0/
DATA IPRNT,IWRIT/4HPRNT,4HWRIT/
THIS ROUTINE SIMULATES THE ACTION OF THE NAO SUBPROGRAM:
FORM LABELS FOR THE RAW AO BASIS SET:
CALL LBLAO
COPY THE AO CENTERS AND LABELS FROM /NBAO/ TO /NBBAS/:
DO 5 I = 1,NBAS
LBL(I) = LCTR(I)
LORBC(I) = LANG(I)
5 CONTINUE
WRITE OUT THE AO BASIS SET INFORMATION:
IF(JPRINT(22).GT.0) THEN
CALL WRBAS(A,A,JPRINT(22))
END IF
WRITE OUT THE ARCHIVE FILE:
IF(JPRINT(7).NE.0) THEN
CALL WRARC(A,A,JPRINT(7))
END IF
OUTPUT THE AO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(26))
IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
CALL FEAOMO(A,IT)
IF(IT.NE.0) THEN
TITLE = 'MOs in the AO basis:'
CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26))
END IF
END IF
OUTPUT THE AO FOCK MATRIX:
IO = IOINQR(JPRINT(40))
IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
CALL FEFAO(A,IWFOCK)
IF(IWFOCK.NE.0) THEN
TITLE = 'AO Fock matrix:'
CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40))
END IF
END IF
OUTPUT THE AO DENSITY MATRIX:
IO = IOINQR(JPRINT(27))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'Spinless AO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27))
END IF
OUTPUT THE AO DIPOLE MATRICES:
IO = IOINQR(JPRINT(50))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
IX = 1
CALL FEDXYZ(A,IX)
IF(IX.NE.0) THEN
TITLE = 'AO x dipole integrals:'
CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
END IF
IX = 2
CALL FEDXYZ(A,IX)
IF(IX.NE.0) THEN
TITLE = 'AO y dipole integrals:'
CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
END IF
IX = 3
CALL FEDXYZ(A,IX)
IF(IX.NE.0) THEN
TITLE = 'AO z dipole integrals:'
CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
END IF
END IF
INITIALIZE THE AO TO NAO TRANSFORMATION MATRIX (UNIT MATRIX):
DO 20 J = 1,NBAS
DO 10 I = 1,NBAS
T(I,J) = ZERO
10 CONTINUE
T(J,J) = ONE
20 CONTINUE
SAVE TNAO FOR LATER USE:
CALL SVTNAO(T)
FILL ATOMIC ORBITAL INFORMATION LISTS:
DO 30 I = 1,NBAS
NAOCTR(I) = LCTR(I)
NAOL(I) = LANG(I)
LSTOCC(I) = 1
30 CONTINUE
PERFORM THE NATURAL POPULATION ANALYSIS: (NOTE THAT ROUTINE NAOANL
EXPECTS TO FIND THE OVERLAP MATRIX IN T, WHICH IS THE UNIT MATRIX
FOR ORTHOGONAL BASIS SETS. UPON RETURN FROM NAOANL, T IS THE AO TO
NAO TRANSFORMATION, WHICH IS STILL A UNIT MATRIX):
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NATOMS
I4 = I3 + NATOMS*NATOMS
I5 = I4 + NATOMS*NATOMS
I6 = I5 + NDIM*NDIM
IEND = I6 + NDIM
CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
DO NOT DESTROY THE MATRIX AT A(I1). THIS HOLDS THE WIBERG BOND
INDEX WHICH NEEDS TO BE PASSED TO THE NBO ROUTINES.
SAVE THE NAO DENSITY MATRIX:
CALL SVDNAO(DM)
FORM THE NAO LABELS:
CALL LBLNAO
IF THIS IS AN OPEN SHELL WAVEFUNCTION, DON'T DO ANYTHING MORE:
IF(OPEN) RETURN
OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(9))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
I4 = I3 + NDIM*NDIM
IEND = I4 + NDIM*(NDIM+5)
CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
END IF
REORGANIZE THE SCRATCH VECTOR:
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
IEND = I3 + NDIM
OUTPUT THE NAO FOCK MATRIX:
IO = IOINQR(JPRINT(31))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEFAO(A(I2),IWFOCK)
IF(IWFOCK.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NAO Fock matrix:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31))
END IF
END IF
OUTPUT THE NAO DENSITY MATRIX:
IO = IOINQR(JPRINT(35))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'NAO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35))
END IF
RETURN
END
**************************************************************************
SUBROUTINE DMNAO(DM,T,A)
**************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS)
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1)
CHARACTER*80 TITLE
DATA IPRNT,IWRIT/4HPRNT,4HWRIT/
PLACE ALPHA OR BETA OCCUPATION MATRIX IN DM AND TRANSFORM FROM THE AO
TO NAO BASIS:
IF(ALPHA) THEN
IF(JPRINT(4).NE.0) WRITE(LFNPR,2100)
ELSE
DO 70 I = 1,NBAS
NAOCTR(I) = NAOC(I)
NAOL(I) = NAOA(I)
LBL(I) = LCTR(I)
LORBC(I) = LANG(I)
70 CONTINUE
CALL FETNAO(T)
IF(JPRINT(4).NE.0) WRITE(LFNPR,2200)
END IF
OUTPUT THE AO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(26))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEAOMO(A,IT)
IF(IT.NE.0) THEN
TITLE = 'MOs in the AO basis:'
CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26))
END IF
END IF
OUTPUT THE AO FOCK MATRIX:
IO = IOINQR(JPRINT(40))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEFAO(A,IWFOCK)
IF(IWFOCK.NE.0) THEN
TITLE = 'AO Fock matrix:'
CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40))
END IF
END IF
FETCH ALPHA OR BETA DM (ACCORDING TO WHETHER ALPHA OR BETA IS TRUE):
CALL FEDRAW(DM,A)
OUTPUT THE AO BOND-ORDER MATRIX:
IO = IOINQR(JPRINT(42))
IF(IWDM.NE.0.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
TITLE = 'AO bond-order matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(42))
END IF
CONVERT THE BOND-ORDER MATRIX TO THE DENSITY MATRIX:
IF(IWDM.NE.0) THEN
I1 = 1
I2 = I1 + NDIM*NDIM
IEND = I2 + NDIM*NDIM
CALL FESRAW(A(I1))
CALL SIMTRM(DM,A(I1),A(I2),NDIM,NBAS,IWMULP,IWCUBF)
END IF
OUTPUT THE AO DENSITY MATRIX:
IO = IOINQR(JPRINT(27))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'AO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27))
END IF
TRANSFORM DM TO THE NAO BASIS:
CALL SIMTRS(DM,T,A,NDIM,NBAS)
SAVE THE NAO DENSITY MATRIX IN SCRATCH STORAGE:
CALL SVDNAO(DM)
PRINT THE NATURAL POPULATION ANALYSIS FOR THIS SPIN CASE:
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NATOMS
I4 = I3 + NATOMS*NATOMS
I5 = I4 + NATOMS*NATOMS
I6 = I5 + NDIM*NDIM
IEND = I6 + NDIM
CALL FESNAO(T)
CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
NOTE: DO NOT DESTROY THE WIBERG BOND INDEX WHICH IS STORED IN THE FIRST
NATOMS*NATOMS ELEMENTS OF THE SCRATCH VECTOR A. THIS IS MATRIX IS
REQUIRED FOR THE NBO ANALYSIS:
NOTE THAT T IS NOW T-AO-NAO:
FORM THE NAO LABELS:
CALL LBLNAO
OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(9))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
I4 = I3 + NDIM*NDIM
IEND = I4 + NDIM*(NDIM+5)
CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
END IF
REORGANIZE THE SCRATCH VECTOR:
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
IEND = I3 + NDIM
OUTPUT THE NAO FOCK MATRIX:
IO = IOINQR(JPRINT(31))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEFAO(A(I2),IWFOCK)
IF(IWFOCK.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NAO Fock matrix:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31))
END IF
END IF
OUTPUT THE NAO DENSITY MATRIX:
IO = IOINQR(JPRINT(35))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'NAO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35))
END IF
RETURN
2100 FORMAT(//1X,
* '***************************************************',/1X,
* '******* Alpha spin orbitals *******',/1X,
* '***************************************************')
2200 FORMAT(//1X,
* '***************************************************',/1X,
* '******* Beta spin orbitals *******',/1X,
* '***************************************************')
END
**************************************************************************
SUBROUTINE DMSIM(DM,T,A)
**************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS)
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1)
CHARACTER*80 TITLE
DATA IPRNT,IWRIT/4HPRNT,4HWRIT/
SIMULATE THE ALPHA/BETA NAO SUBPROGRAM:
IF(ALPHA) THEN
IF(JPRINT(4).NE.0) WRITE(LFNPR,2100)
ELSE
DO 70 I = 1,NBAS
NAOCTR(I) = NAOC(I)
NAOL(I) = NAOA(I)
LBL(I) = LCTR(I)
LORBC(I) = LANG(I)
70 CONTINUE
CALL FETNAO(T)
IF(JPRINT(4).NE.0) WRITE(LFNPR,2200)
END IF
OUTPUT THE AO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(26))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEAOMO(A,IT)
IF(IT.NE.0) THEN
TITLE = 'MOs in the AO basis:'
CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26))
END IF
END IF
OUTPUT THE AO FOCK MATRIX:
IO = IOINQR(JPRINT(40))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEFAO(A,IWFOCK)
IF(IWFOCK.NE.0) THEN
TITLE = 'AO Fock matrix:'
CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40))
END IF
END IF
FETCH ALPHA OR BETA DM (ACCORDING TO WHETHER ALPHA OR BETA IS TRUE):
CALL FEDRAW(DM,A)
OUTPUT THE AO DENSITY MATRIX:
IO = IOINQR(JPRINT(27))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'AO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27))
END IF
SAVE THE NAO DENSITY MATRIX IN SCRATCH STORAGE:
CALL SVDNAO(DM)
PRINT THE NATURAL POPULATION ANALYSIS FOR THIS SPIN CASE:
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NATOMS
I4 = I3 + NATOMS*NATOMS
I5 = I4 + NATOMS*NATOMS
I6 = I5 + NDIM*NDIM
IEND = I6 + NDIM
CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
NOTE: DO NOT DESTROY THE WIBERG BOND INDEX WHICH IS STORED IN THE FIRST
NATOMS*NATOMS ELEMENTS OF THE SCRATCH VECTOR A. THIS IS MATRIX IS
REQUIRED FOR THE NBO ANALYSIS:
FORM THE NAO LABELS:
CALL LBLNAO
OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(9))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
I4 = I3 + NDIM*NDIM
IEND = I4 + NDIM*(NDIM+5)
CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
END IF
REORGANIZE THE SCRATCH VECTOR:
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
IEND = I3 + NDIM
OUTPUT THE NAO FOCK MATRIX:
IO = IOINQR(JPRINT(31))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEFAO(A(I2),IWFOCK)
IF(IWFOCK.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NAO Fock matrix:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31))
END IF
END IF
PRINT THE NAO DENSITY MATRIX:
IO = IOINQR(JPRINT(35))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'NAO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35))
END IF
RETURN
2100 FORMAT(//1X,
* '***************************************************',/1X,
* '******* Alpha spin orbitals *******',/1X,
* '***************************************************')
2200 FORMAT(//1X,
* '***************************************************',/1X,
* '******* Beta spin orbitals *******',/1X,
* '***************************************************')
END
**************************************************************************
SUBROUTINE NBODRV(DM,T,A,MEMORY)
**************************************************************************
DRIVER SUBROUTINE TO CALCULATE NATURAL HYBRID ORBITALS (NHOS) AND
NATURAL BOND ORBITALS (NBOS) FROM THE DENSITY MATRIX IN THE NAO BASIS
T = SCRATCH STORAGE
DM = NAO DENSITY MATRIX
THE SPIN NATURE OF DM IS INDICATED BY:
ISPIN = 0: SPINLESS (CLOSED SHELL)
ISPIN = +2: ALPHA SPIN
ISPIN = -2: SPIN
(ISPIN IS THE RECIPROCAL OF THE S(Z) QUANTUM NO.)
A = SCRATCH STORAGE FROM THE MAIN PROGRAM. THE LOCATION OF A(1)
IS IN THE COMMON BLOCK /SCM/ IN THE MAIN PROGRAM,
AFTER THE STORAGE FOR THE MATRICES 'S','DM'
('A' IS THE VECTOR WHICH IS PARTITIONED
ACCORDING TO THE STORAGE NEEDS OF EACH PROGRAM RUN)
ATOM, BASIS, OPTION, NBINFO: COMMON BLOCKS WITH DATA TRANSFERED FROM
FROM THE INPUT PROGRAMS.
-----------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
CHARACTER*80 TITLE
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM),
+ NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM)
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(1)
DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/
DATA ZERO/0.0D0/
SKIP NBO TRANSFORMATION IF REQUESTED:
IF(JPRINT(1).GT.0) THEN
WRITE(LFNPR,2000)
RETURN
END IF
ORGANIZE SCRATCH STORAGE VECTOR A. WARNING: THIS IS REDEFINED
SEVERAL TIMES AFTER THE NBOS ARE FORMED
A(I0) = GUIDE(NATOMS,NATOMS)
A(I1) = BNDOCC(NDIM)
A(I2) = POL(NDIM,3)
A(I3) = Q(MXAO,NDIM)
A(I4) = V(NDIM)
A(I5) = BLK(MXBO,MXBO)
A(I6) = C(MXBO,MXBO)
A(I7) = EVAL(MXBO)
A(I8) = BORB(MXBO)
A(I9) = P(MXAO,MXAO)
A(I10) = PK(MXAO,MXAO)
A(I11) = HYB(MXAO)
A(I12) = VA(MXAO)
A(I13) = VB(MXAO)
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + NDIM
I3 = I2 + 3*NDIM
I4 = I3 + MXAO*NDIM
I5 = I4 + NDIM
I6 = I5 + MXBO*MXBO
I7 = I6 + MXBO*MXBO
I8 = I7 + MXBO
I9 = I8 + MXBO
I10 = I9 + MXAO*MXAO
I11 = I10 + MXAO*MXAO
I12 = I11 + MXAO
I13 = I12 + MXAO
I14 = I13 + MXAO
IEND = I14 + NATOMS*NATOMS
IF(JPRINT(5).NE.0.AND.ISPIN.EQ.0) WRITE(LFNPR,1400)
IF(JPRINT(5).NE.0.AND.ISPIN.EQ.2) WRITE(LFNPR,1410)
IF(JPRINT(5).NE.0.AND.ISPIN.EQ.-2) WRITE(LFNPR,1420)
READ IN T-NAB, LABEL, IBXM, TRANSFORM DM, AND FIND BNDOCC IF IWTNAB=IREAD:
IF(IOINQR(IWTNAB).EQ.IREAD) THEN
CALL RDTNAB(T,DM,A(I1),A(I2),IWTNAB)
ELSE
SEARCH INPUT FILE FOR $CORE INPUT:
IF(.NOT.BETA) THEN
CALL CORINP(JPRINT(2),JCORE)
CALL RDCORE(JCORE)
END IF
SEARCH INPUT FILE FOR $CHOOSE INPUT:
IF(.NOT.BETA) THEN
CALL CHSINP(JPRINT(2),ICHOOS)
IF(OPEN.AND.ICHOOS.EQ.1.AND.JPRINT(32).NE.0) THEN
WRITE(LFNPR,1390)
ICHOOS = 0
END IF
END IF
CALCULATE NATURAL HYBRID ORBITALS AND BOND ORBITALS:
IF(ICHOOS.NE.1) CALL NATHYB(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4),
+ A(I5),A(I6),A(I7),A(I8),A(I9),A(I10),
+ A(I11),A(I12),A(I13),A(I14))
IF(ICHOOS.EQ.1) CALL CHSDRV(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4),
+ A(I5),A(I6),A(I7),A(I8),A(I9),A(I10),
+ A(I11),A(I12),A(I13),A(I14))
IF NBO SEARCH WAS ABANDONED, DON'T TRY TO DO ANYTHING FURTHER:
IF(JPRINT(1).LT.0) RETURN
SORT THE NBOS BY ATOM:
CALL SRTNBO(T,A(I1))
FORM THE NBO DENSITY MATRIX:
CALL SIMTRS(DM,T,A(I2),NDIM,NBAS)
CHECK NHO OVERLAPS TO SEE IF BOND ORBITALS SHOULD BE RELABELLED:
IF(.NOT.ORTHO) THEN
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + NDIM
I3 = I2 + MXAO
I4 = I3 + NDIM*NDIM
I5 = I4 + NDIM*NDIM
I6 = I5 + NDIM
IEND = I6 + NDIM
CALL XCITED(DM,T,A(I2),A(I3),A(I4),A(I5),A(I6),A(I6))
END IF
END IF
T NOW CONTAINS THE NAO-NBO TRANSFORMATION MATRIX
DM NOW CONTAINS THE NBO DENSITY MATRIX
A(I0) CONTAINS THE WIBERG BOND INDEX MATRIX ! DON'T DESTROY THIS
A(I1) CONTAINS THE NBO OCCUPANCIES ! DON'T DESTROY THIS
A(I2) IS SCRATCH SPACE
SAVE THE NAO-NBO TRANSFORMATION ON THE NBO DAF:
CALL SVTNAB(T)
FORM THE NBO LABELS:
CALL LBLNBO
WRITE OUT THE ANALYSIS OF BOND ORBITALS:
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + NDIM
I3 = I2 + NDIM
I4 = I3 + NDIM
IEND = I4 + NDIM*NDIM
CALL ANLYZE(T,A(I1),A(I2),A(I3),A(I4))
WRITE OUT HYBRID DIRECTIONALITY AND BOND BENDING INFO:
IF(JPRINT(36).NE.0) THEN
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + NDIM
I3 = I2 + 3*NATOMS
I4 = I3 + NDIM*NDIM
I5 = I4 + NDIM*NDIM
IEND = I5 + NDIM
CALL HYBDIR(A(I1),A(I2),A(I3),A(I4),A(I5))
END IF
FIND MOLECULAR UNITS:
CALL FNDMOL(A(I2))
CLASSIFY ALL THE NBOS ACCORDING TO DONOR/ACCEPTOR TYPE:
CALL NBOCLA(A(I1),ACCTHR)
OUTPUT TRANSFORMATION MATRICES FOR THE PNHO AND NHO BASIS SETS,
AND THE NHO DENSITY MATRIX, NHO FOCK MATRIX, AND NHO DIPOLE MATRICES:
THE SECTION OF THE CODE MAKES USE OF T AND DM. THESE MATRICES
WILL BE RESTORED LATER: [NOTE: DO NOT DESTROY INFO ALREADY STORED
IN A(I0) AND A(I1)]
REORGANIZE THE SCRATCH VECTOR:
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + NDIM
I3 = I2 + NDIM*NDIM
I4 = I3 + NDIM*NDIM
IEND = I4 + NDIM*(NDIM+5)
OUTPUT THE AO-PNHO TRANSFORMATION AND THE PNHO OVERLAP MATRIX:
IO = IOINQR(JPRINT(20))
JO = IOINQR(JPRINT(30))
IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR.
+ (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN
CALL FEPNAO(T)
CALL FETNHO(A(I2))
CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
CALL FESRAW(A(I2))
CALL NORMLZ(T,A(I2),NDIM,NBAS)
IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN
TITLE = 'PNHOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(30))
END IF
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'PNHO overlap matrix:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(20))
END IF
ENDIF
FORM THE AO-NHO TRANSFORMATION MATRIX:
CALL FETNAO(T)
CALL FETNHO(A(I2))
CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
OUTPUT THE AO-NHO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(28))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'NHOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(28))
END IF
OUTPUT THE NAO-NHO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(33))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FETNHO(A(I2))
TITLE = 'NHOs in the NAO basis:'
CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,2,JPRINT(33))
END IF
OUTPUT THE NHO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(38))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FRMTMO(T,A(I2),A(I3),A(I4),3,JPRINT(38))
END IF
OUTPUT THE NHO DENSITY MATRIX:
IO = IOINQR(JPRINT(34))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEDRAW(DM,A(I2))
IF(IWDM.EQ.1) THEN
CALL FESRAW(A(I2))
CALL SIMTRS(DM,A(I2),A(I3),NDIM,NBAS)
END IF
CALL SIMTRS(DM,T,A(I2),NDIM,NBAS)
TITLE = 'NHO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,3,JPRINT(34))
END IF
OUTPUT THE NHO FOCK MATRIX:
IO = IOINQR(JPRINT(29))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEFAO(A(I2),IWFOCK)
IF(IWFOCK.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NHO Fock matrix:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(29))
END IF
END IF
OUTPUT THE NHO DIPOLE MATRICES:
IO = IOINQR(JPRINT(52))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
IX = 1
CALL FEDXYZ(A(I2),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NHO x dipole integrals:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52))
END IF
IX = 2
CALL FEDXYZ(A(I2),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NHO y dipole integrals:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52))
END IF
IX = 3
CALL FEDXYZ(A(I2),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NHO z dipole integrals:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52))
END IF
END IF
OUTPUT TRANSFORMATION MATRICES FOR THE PNBO AND NBO BASIS SETS,
AND THE NBO DENSITY MATRIX, NBO FOCK MATRIX, AND NBO DIPOLE MATRICES:
[NOTE: DO NOT DESTROY INFO ALREADY STORED IN A(I0) AND A(I1)]
REORGANIZE THE SCRATCH VECTOR:
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + NDIM
I3 = I2 + NDIM*NDIM
I4 = I3 + NDIM*NDIM
IEND = I4 + NDIM*(NDIM+5)
OUTPUT THE AO-PNBO TRANSFORMATION AND THE PNBO OVERLAP MATRIX:
IO = IOINQR(JPRINT(21))
JO = IOINQR(JPRINT(25))
IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR.
+ (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN
CALL FEPNAO(T)
CALL FETNAB(A(I2))
CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
CALL FESRAW(A(I2))
CALL NORMLZ(T,A(I2),NDIM,NBAS)
IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN
TITLE = 'PNBOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(25))
END IF
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'PNBO overlap matrix:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(21))
END IF
END IF
FORM THE AO-NBO TRANSFORMATION MATRIX:
CALL FETNAO(T)
CALL FETNAB(A(I2))
CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
SAVE THE AO-NBO TRANSFORMATION, NBO OCCS, AND NBO LABELS ON NBO DAF:
CALL SVNBO(T,A(I1),A(I2))
WRITE THE AO-NBO TRANSFORMATION WITH NBO LABELS AND OCCUPANCIES:
IF(IOINQR(IWTNBO).EQ.IWRIT) CALL WRTNBO(T,A(I1),IWTNBO)
PRINT THE AO-NBO TRANSFORMATION MATRIX:
IF(IOINQR(IWTNBO).EQ.IPRNT) THEN
TITLE = 'NBOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IWTNBO)
END IF
WRITE THE NAO-NBO TRANSFORMATION MATRIX:
IF(IOINQR(IWTNAB).EQ.IWRIT) THEN
CALL FETNAB(A(I2))
CALL WRTNAB(A(I2),IWTNAB)
END IF
PRINT THE NAO-NBO TRANSFORMATION TO THE OUTPUT FILE:
IF(IOINQR(IWTNAB).EQ.IPRNT) THEN
CALL FETNAB(A(I2))
TITLE = 'NBOs in the NAO basis:'
CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,2,IWTNAB)
END IF
OUTPUT THE NHO-NBO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(41))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FETNHO(A(I2))
CALL TRANSP(A(I2),NDIM,NBAS)
CALL FETNAB(A(I3))
CALL MATMLT(A(I2),A(I3),A(I4),NDIM,NBAS)
TITLE = 'NBOs in the NHO basis:'
CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,3,JPRINT(41))
END IF
OUTPUT THE NBO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(45))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FRMTMO(T,A(I2),A(I3),A(I4),4,JPRINT(45))
END IF
FORM THE NBO DENSITY MATRIX:
CALL FEDRAW(DM,A(I2))
IF(IWDM.EQ.1.AND..NOT.ORTHO) THEN
CALL FESRAW(A(I2))
CALL SIMTRS(DM,A(I2),A(I3),NDIM,NBAS)
END IF
CALL SIMTRS(DM,T,A(I2),NDIM,NBAS)
OUTPUT THE NBO DENSITY MATRIX:
IO = IOINQR(JPRINT(16))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'NBO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,4,JPRINT(16))
END IF
OUTPUT THE NBO FOCK MATRIX:
CALL FEFAO(A(I2),IWFOCK)
IF(IWFOCK.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
CALL SVFNBO(A(I2))
IO = IOINQR(JPRINT(37))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'NBO Fock matrix:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(37))
END IF
END IF
OUTPUT THE NBO DIPOLE MATRICES:
IO = IOINQR(JPRINT(53))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
IX = 1
CALL FEDXYZ(A(I2),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NBO x dipole integrals:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53))
END IF
IX = 2
CALL FEDXYZ(A(I2),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NBO y dipole integrals:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53))
END IF
IX = 3
CALL FEDXYZ(A(I2),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
TITLE = 'NBO z dipole integrals:'
CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53))
END IF
END IF
PERFORM PERTURBATIVE ANALYSIS OF THE NBO FOCK MATRIX:
IF(JPRINT(3).EQ.1.AND.IWFOCK.NE.0) CALL FNBOAN(A(I1),A(I2),A(I3))
PRINT THE NBO SUMMARY:
IF(JPRINT(6).EQ.1) THEN
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + NDIM
I3 = I2 + NDIM*NDIM
I4 = I3 + NDIM
I5 = I4 + NATOMS
IEND = I5 + NDIM
CALL NBOSUM(A(I2),A(I1),A(I3),A(I4),A(I5))
END IF
CONTINUE WITH THE CONSTRUCTION OF THE NLMOS:
IF(JPRINT(8).NE.0) THEN
STORE IN A(I0) THE VECTOR RESON(NDIM), THE SQUARES OF THE DIAGONAL
ELEMENTS OF THE NBO TO NLMO TRANSFORMATION MATRIX. IALARM SOUNDS
THE ALARM THAT THE NLMO STEP IS TO BE SKIPPED:
DM : NBO DENSITY ! TRANSFORMED TO NLMO BASIS ON RETURN
A(I0): RESON(NDIM) ! PERCENTAGES OF PARENT NBO
A(I1): LMOOCC(NDIM) ! NLMO OCCUPANCIES
A(I2): TNLMO(NDIM,NDIM) ! NBO-NLMO TRANSFORM
A(I3): TSYM ! SCRATCH
(DO NOT DESTROY THE WIBERG BOND INDEX!)
I0 = 1 + NATOMS*NATOMS
I1 = I0 + NDIM
I2 = I1 + NDIM
I3 = I2 + NDIM*NDIM
IEND = I3 + NDIM*NDIM
CALL NLMO(NBAS,DM,A(I1),A(I2),A(I3),A(I0),NOCC,IALARM)
IF(IALARM.NE.0) RETURN
SAVE THE NBO TO NLMO TRANSFORMATION MATRIX ON THE NBO DAF:
CALL SVTLMO(A(I2))
FORM THE NAO TO NLMO TRANSFORMATION IN T:
CALL FETNAB(T)
CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
SET UP STORAGE FOR LMOANL:
A(I0): RESON(NDIM)
A(I1): LMOOCC(NDIM)
A(I2): TS(NDIM)
A(I3): BORDER(NATOMS,NATOMS)
A(I4): OWBORD(NATOMS,NATOMS)
A(I5): ATLMO(NOCC,NATOMS)
A(I6): SIAB(NOCC,NAB)
(DO NOT DESTROY THE WIBERG BOND INDEX!)
NAB = NATOMS*(NATOMS-1)/2
IF(NATOMS.EQ.1) NAB = 1
I0 = 1 + NATOMS*NATOMS
I1 = I0 + NDIM
I2 = I1 + NDIM
I3 = I2 + NDIM
I4 = I3 + NATOMS*NATOMS
I5 = I4 + NATOMS*NATOMS
I6 = I5 + NOCC*NATOMS
I7 = I6 + NOCC*NAB
IEND = I7 + NDIM*NDIM
CALL COPY(DM,A(I7),NDIM,NBAS,NBAS)
CALL LMOANL(T,A(I7),A(I0),A(I1),A(I2),A(I3),A(I4),A(I5),
+ A(I6),NOCC,NAB)
OUTPUT TRANSFORMATION MATRICES FOR THE PNLMO AND NLMO BASIS SETS,
AND THE NLMO DENSITY MATRIX, NLMO FOCK MATRIX, AND NLMO DIPOLE MATRICES:
REORGANIZE THE SCRATCH VECTOR:
(DO NOT DESTROY THE WIBERG BOND INDEX!)
I0 = 1 + NATOMS*NATOMS
I1 = I0 + NDIM*NDIM
I2 = I1 + NDIM*NDIM
IEND = I2 + NDIM*(NDIM+5)
OUTPUT THE AO-PNLMO TRANSFORMATION AND THE PNLMO OVERLAP MATRIX:
IO = IOINQR(JPRINT(48))
JO = IOINQR(JPRINT(49))
IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR.
+ (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN
CALL FEPNAO(T)
CALL FETNAB(A(I0))
CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS)
CALL FETLMO(A(I0))
CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS)
CALL FESRAW(A(I0))
CALL NORMLZ(T,A(I0),NDIM,NBAS)
IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN
TITLE = 'PNLMOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(49))
END IF
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS)
TITLE = 'PNLMO overlap matrix:'
CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(48))
END IF
END IF
FORM THE AO-NLMO TRANSFORMATION MATRIX:
CALL FETNAO(T)
CALL FETNAB(A(I0))
CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS)
CALL FETLMO(A(I0))
CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS)
SAVE THE AO-NLMO TRANSFORMATION ON NBO DAF:
CALL SVNLMO(T)
WRITE OUT THE AO-NLMO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(23))
IF(IO.EQ.IWRIT) CALL WRNLMO(T,DM,JPRINT(23))
PRINT THE AO-NLMO TRANSFORMATION MATRIX:
IF(IO.EQ.IPRNT) THEN
TITLE = 'NLMOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(23))
END IF
OUTPUT THE NAO-NLMO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(18))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FETNAB(A(I0))
CALL FETLMO(A(I1))
CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS)
TITLE = 'NLMOs in the NAO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,2,JPRINT(18))
END IF
OUTPUT THE NHO-NLMO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(24))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FETNHO(A(I0))
CALL TRANSP(A(I0),NDIM,NBAS)
CALL FETNAB(A(I1))
CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS)
CALL FETLMO(A(I1))
CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS)
TITLE = 'NLMOs in the NHO basis:'
CALL AOUT(A(I0),NDIM,NBAS,NBAS,TITLE,3,JPRINT(24))
END IF
OUTPUT THE NBO-NLMO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(47))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FETLMO(A(I0))
TITLE = 'NLMOs in the NBO basis:'
CALL AOUT(A(I0),NDIM,NBAS,NBAS,TITLE,4,JPRINT(47))
END IF
OUTPUT THE NLMO-MO TRANSFORMATION MATRIX:
IO = IOINQR(JPRINT(13))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FRMTMO(T,A(I0),A(I1),A(I2),5,JPRINT(13))
END IF
OUTPUT THE NLMO DENSITY MATRIX:
IO = IOINQR(JPRINT(17))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
TITLE = 'NLMO density matrix:'
CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,5,JPRINT(17))
END IF
OUTPUT THE NLMO FOCK MATRIX:
IO = IOINQR(JPRINT(15))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
CALL FEFAO(A(I0),IWFOCK)
IF(IWFOCK.NE.0) THEN
CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS)
TITLE = 'NLMO Fock matrix:'
CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(15))
END IF
END IF
OUTPUT THE NLMO DIPOLE MATRICES:
IO = IOINQR(JPRINT(54))
IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
IX = 1
CALL FEDXYZ(A(I0),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS)
TITLE = 'NLMO x dipole integrals:'
CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54))
END IF
IX = 2
CALL FEDXYZ(A(I0),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS)
TITLE = 'NLMO y dipole integrals:'
CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54))
END IF
IX = 3
CALL FEDXYZ(A(I0),IX)
IF(IX.NE.0) THEN
CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS)
TITLE = 'NLMO z dipole integrals:'
CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54))
END IF
END IF
PERFORM THE NBO/NLMO DIPOLE MOMENT ANALYSIS:
DM : NLMO DENSITY MATRIX
T : AO-NLMO TRANSFORMATION MATRIX
A(I1): C(NDIM,NDIM)
A(I2): TNBO(NDIM,NDIM)
A(I3): DX(NDIM,NDIM)
A(I4): DY(NDIM,NDIM)
A(I5): DZ(NDIM,NDIM)
A(I6): SCR(NDIM,NDIM)
A(I7): INDEX(NDIM)
(DO NOT DESTROY THE WIBERG BOND INDEX!)
IF(JPRINT(46).NE.0) THEN
I1 = 1 + NATOMS*NATOMS
I2 = I1 + NDIM*NDIM
I3 = I2 + NDIM*NDIM
I4 = I3 + NDIM*NDIM
I5 = I4 + NDIM*NDIM
I6 = I5 + NDIM*NDIM
I7 = I6 + NDIM*NDIM
IEND = I7 + NDIM
CALL DIPANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6),A(I7))
END IF
END IF
PERFORM NATURAL RESONANCE THEORY ANALYSIS:
IF(JPRINT(32).NE.0) THEN
CAREFULLY DETERMINE THE MAXIMUM NUMBER OF RESONANCE STRUCTURES
(MAXRES) THAT THE SCRATCH VECTOR CAN ACCOMODATE. ASSUME THAT
THERE WILL BE ROUGHLY 6(=NEL) ELEMENTS REQUIRED PER ATOM TO STORE
THE TOPO MATRICES FOR EACH RESONANCE STRUCTURE: (1 FOR NUMBER OF
BONDS, 1 FOR NUMBER OF LONE PAIRS, AND 4 BONDED ATOMS -- SEE
SR TOPSTR)
NEL = 6
TOT = ZERO
DO 80 IBAS = 1,NBAS
TOT = TOT + DM(IBAS,IBAS)
80 CONTINUE
NELEC = NINT(TOT)
NLOW = NATOMS*(NATOMS-1)/2
MAXREF = MAX(JPRINT(56),1)
CAREFULLY DETERMINE THE MAXIMUM NUMBER OF RESONANCE STRUCTURES (MAXRES)
WHICH THE SCRATCH VECTOR CAN ACCOMODATE. ASSUME NDIM IS LARGER THAN
MAXRES (THIS IS NOT USUALLY THE CASE):
IC = NDIM*NDIM + 4*NDIM + MXAO*NDIM + NDIM + MXBO*MXBO +
+ MXBO*MXBO + MXBO + MXBO + MXAO*MXAO + MXAO*MXAO +
+ MXAO + MXAO + MXAO + NATOMS*NATOMS + NDIM*MAXREF +
+ NDIM*NDIM + MAXREF + MAXREF + NDIM*MAXREF + NDIM +
+ NDIM*NDIM + NDIM*NDIM + NDIM*NDIM + NATOMS*NATOMS +
+ MAXREF - MEMORY
IB = NDIM*MAXREF + 6*MAXREF + NLOW*MAXREF + 9 + NATOMS*NEL
IA = 0
MAXRES = INT(-IC / IB)
CHECK THIS ASSUMPTION:
IF(MAXRES.GT.NDIM) THEN
IC = IC - NDIM*NDIM - NDIM*NDIM
IA = 2
DET = SQRT(REAL(IB * IB - 4 * IA * IC))
MAXRES = INT((-REAL(IB) + DET) / REAL(2 * IA))
END IF
IF(MAXRES.GT.NDIM*NDIM) THEN
IC = IC - NDIM*NDIM
IB = IB + 1
IA = 2
DET = SQRT(REAL(IB * IB - 4 * IA * IC))
MAXRES = INT((-REAL(IB) + DET) / REAL(2 * IA))
END IF
LEN = NEL * NATOMS * MAXRES
PARTITION THE SCRATCH VECTOR:
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + MAXRES*MAXREF
I3 = I2 + MAXRES*MAXREF
I4 = I3 + MAXREF
MEM = MEMORY - I4 + 1
CALL NRTDRV(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4),MAXRES,MAXREF,
+ NLOW,LEN,NELEC,MEM)
END IF
RETURN
1390 FORMAT(/1X,'WARNING: The $CHOOSE keylist is incompatible with ',
+ 'the NRT analysis for open',/1X,' shell NBO analyses.',
+ ' Program execution will continue, ignoring the',/1X,' ',
+ ' $CHOOSE keylist.')
1400 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS:')
1410 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS,',
* ' alpha spin orbitals:')
1420 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS,',
* ' beta spin orbitals:')
2000 FORMAT(//1X,'NBO analysis skipped by request.')
END
*****************************************************************************
ROUTINES CALLED BY THE NAO DRIVERS:
SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF)
SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF)
SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR)
SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK)
SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO)
SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG)
*****************************************************************************
SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
SIMILARITY TRANSFORM A ==> S(TRANSPOSE)*A*S, USING SCRATCH VECTOR V.
WRITE THE DIAGONAL ELEMENTS OF A*S BY CALLING SUBROUTINE MULANA IF
IWMULP.NE.0
(THESE ARE THE MULLIKEN POPULATIONS IF S= OVERLAP MATRIX
AND A= BOND-ORDER MATRIX)
DIMENSION A(NDIM,NDIM),S(NDIM,NDIM),V(1)
CALL MATMLT(A,S,V,NDIM,N)
I1=NDIM+1
IF(IWMULP.NE.0) CALL MULANA(A,V(1),V(I1),IWMULP,IWCUBF)
CALL MATML2(S,A,V,NDIM,N)
RETURN
END
*****************************************************************************
SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PERFORM MAYER-MULLIKEN BOND ORDER ANALYSIS
PRINT OUT DIAGONAL ELEMENTS OF BS=B*S, WHERE
B= BOND-ORDER MATRIX, S= OVERLAP MATRIX, BOTH IN ORIGINAL AO BASIS
THIS CONSTITUTES A MULLIKEN POPULATION ANALYSIS.
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
DIMENSION BS(NDIM,NDIM),VMAYER(NATOMS),BMAYER(NATOMS,NATOMS),
* IANG(5),ANGL(60),LANG(60),CUBICF(7)
CHARACTER*80 TITLE
DATA IANG/'s','p','d','f','g'/
DATA LANG/ 51,151,152,153,251,252,253,254,255,
* 351,352,353,354,355,356,357,
* 451,452,453,454,455,456,457,458,459,
* 1,101,102,103,201,202,203,204,205,206,
* 301,302,303,304,305,306,307,308,309,310,
* 401,402,403,404,405,406,407,408,409,410,
* 411,412,413,414,415/
DATA ANGL/4H ,4Hx ,4Hy ,4Hz ,4Hxy ,4Hxz ,4Hyz ,
* 4Hx2y2,4Hz2 ,4H(0) ,4H(c1),4H(s1),4H(c2),4H(s2),4H(c3),
* 4H(s3),4H(0) ,4H(c1),4H(s1),4H(c2),4H(s2),4H(c3),4H(s3),
* 4H(c4),4H(s4),
* 4H ,4Hx ,4Hy ,4Hz ,4Hxx ,4Hxy ,4Hxz ,
* 4Hyy ,4Hyz ,4Hzz ,4Hxxx ,4Hxxy ,4Hxxz ,4Hxyy ,4Hxyz ,
* 4Hxzz ,4Hyyy ,4Hyyz ,4Hyzz ,4Hzzz ,4Hxxxx,4Hxxxy,4Hxxxz,
* 4Hxxyy,4Hxxyz,4Hxxzz,4Hxyyy,4Hxyyz,4Hxyzz,4Hxzzz,4Hyyyy,
* 4Hyyyz,4Hyyzz,4Hyzzz,4Hzzzz/
DATA CUBICF/4H(d1),4H(d2),4H(d3),4H(b) ,4H(e1),4H(e2),4H(e3)/
DATA ZERO/0.0D0/
IF(IWCUBF.EQ.0) GO TO 20
IF THE F FUNCTIONS ARE A CUBIC SET, INSERT THE PROPER LABELS:
DO 10 I=1,7
II=I+9
10 ANGL(II)=CUBICF(I)
20 CONTINUE
IF(IWMULP.EQ.1) WRITE(LFNPR,1000)
IF(IWMULP.EQ.2) WRITE(LFNPR,1100)
IF(IWMULP.EQ.2) WRITE(LFNPR,1200)
SUMT=ZERO
DO 100 I=1,NATOMS
VMAYER(I)=ZERO
DO 100 J=1,NATOMS
100 BMAYER(I,J)=ZERO
DO 300 IAT=1,NATOMS
IZ=IATNO(IAT)
NAM=NAMEAT(IZ)
SUMAT=ZERO
DO 200 I=1,NBAS
IF(LBL(I).NE.IAT) GO TO 200
LM=LORBC(I)
L=LM/100
IL=IANG(L+1)
DO 130 ILM=1,60
IF(LM.EQ.LANG(ILM)) GO TO 140
130 CONTINUE
STOP
140 CONTINUE
OCC=BS(I,I)
SUMAT=SUMAT+OCC
IF(IWMULP.EQ.2) WRITE(LFNPR,1300) I,NAM,IAT,IL,ANGL(ILM),OCC
DO 180 J=1,NBAS
JAT=LBL(J)
IF(JAT.EQ.IAT) GO TO 180
BMAYER(IAT,JAT)=BMAYER(IAT,JAT)+BS(I,J)*BS(J,I)
180 CONTINUE
200 CONTINUE
IF(IWMULP.EQ.1) WRITE(LFNPR,1800) NAM,IAT,SUMAT
IF(IWMULP.EQ.2) WRITE(LFNPR,1900) NAM,IAT,SUMAT
300 SUMT=SUMT+SUMAT
IF(IWMULP.NE.0) WRITE(LFNPR,1600) SUMT
TITLE = 'Mayer-Mulliken atom-atom bond order matrix:'
CALL AOUT(BMAYER,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS)
DO 310 I=1,NATOMS
DO 310 J=1,NATOMS
310 VMAYER(I)=VMAYER(I)+BMAYER(I,J)
TITLE = 'Mayer-Mulliken valencies by atom:'
CALL AOUT(VMAYER,NATOMS,NATOMS,1,TITLE,0,1)
RETURN
1000 FORMAT(//1X,'Total gross Mulliken populations by atom:',
* //4X,'Atom #',7X,'Total')
1100 FORMAT(//1X,'Input atomic orbitals, gross Mulliken populations:',
+//1X,' AO',2X,'Atom #',2X,'lang',2X,'Mulliken Population',
+4X,'Atom #',7X,'Total')
1200 FORMAT(1X,79('-'))
1300 FORMAT(1X,I3,3X,A2,I3,2X,A1,A4,F13.7)
1600 FORMAT(/1X,'Total number of electrons: ',F11.6)
1800 FORMAT(5X,A2,I3,F15.7)
1900 FORMAT(44X,A2,I3,F15.7)
END
*****************************************************************************
SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LIST(6,MAXBAS),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(6,6),B(6),M(6),
* RENORM(NDIM),
* LF(3,3),LFCUB(3,3),LFT(3,3),LFCUBT(3,3),LG(3,3),LGT(3,3)
DATA LF /301,304,306,302,307,309,303,308,310/
DATA LFCUB /306,304,301,309,302,307,303,308,310/
DATA LFT /151,356,352,152,357,353,153,354,351/
DATA LFCUBT/151,355,351,152,356,352,153,357,353/
DATA LG /402,407,409,403,408,410,405,412,414/
DATA LGT /251,455,459,252,452,456,253,453,457/
DATA ZERO,ONE,TWO,THREE,FOUR,SIX,EIGHT
* /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,6.0D0,8.0D0/
**********************************************************************
SUBROUTINE TO TRANSFORM THE OVERLAP AND DENSITY MATRICES IF D, F, G
ORBITALS ARE PRESENT, OR TRANSFORM A TRANSFORMATION MATRIX SO THAT IT
STARTS FROM THE RAW AO INSTEAD OF THE PURE AO BASIS
THIS TRANSFORMATION WILL NOT WORK IF DM IS THE BOND-ORDER MATRIX.
LIST(6,MAXBAS): THE LIST OF FUNCTIONS TO BE TRANSFORMED
LIST(1,I),LIST(2,I),LIST(3,I) ARE CORRESPONDING SETS OF
D,F, OR G FUNCTIONS. IT IS ASSUMED THAT, FOR EXAMPLE,
THE THIRD DX2 FUNCTION FOUND IN THE ANGULAR MOMENTA LIST "LORB"
CORRESPONDS TO THE THIRD DY2 AND THE THIRD DZ2 FUNCTIONS IN
THE LIST OF BASIS FUNCTIONS!
ITRAN=IDTRAN+IFTRAN+IGTRAN
IDTRAN: THE NUMBER OF SETS OF CARTESIAN D ORBITALS FOUND
IFTRAN: THE NUMBER OF SETS OF CARTESIAN F ORBITALS FOUND
IGTRAN: THE NUMBER OF SETS OF CARTESIAN G ORBITALS FOUND
A : THE TRANSFORMATION MATRIX
ITOPT : IF ZERO, TRANSFORM DM AND S (IN T) FROM RAW AO TO PURE
AO BASIS
IF ONE, PRE-MULTIPLY T BY THE AO TO PURE AO TRANSF.
--- THIS CONVERTS A TRANSF. THAT STARTS FROM PURE AOS
TO A TRANSF. THAT STARTS FROM THE RAW AOS
RENORM: RENORMALIZATION VECTOR FOR CARTESIAN TO PURE TRANSFORM.
(PRODUCED IF ITOPT=0, USED AS INPUT IF ITOPT=1)
**********************************************************************
DO 10 I=1,NBAS
10 LORB(I)=0
IDTRAN=0
N1=0
N2=0
N3=0
N4=0
N5=0
N6=0
...CONSTRUCT LIST:
DO 70 IBAS=1,NBAS
DX2:
IF(LORBC(IBAS).NE.201) GO TO 20
N1=N1+1
LIST(1,N1)=IBAS
GO TO 70
DY2:
20 IF(LORBC(IBAS).NE.204) GO TO 30
N2=N2+1
LIST(2,N2)=IBAS
GO TO 70
DZ2:
30 IF(LORBC(IBAS).NE.206) GO TO 40
N3=N3+1
LIST(3,N3)=IBAS
GO TO 70
LABEL DXY:
40 IF(LORBC(IBAS).NE.202) GO TO 50
N4=N4+1
LORB(IBAS)=251
GO TO 70
LABEL DXZ:
50 IF(LORBC(IBAS).NE.203) GO TO 60
N5 =N5+1
LORB(IBAS)=252
GO TO 70
LABEL DYZ:
60 IF(LORBC(IBAS).NE.205) GO TO 70
N6=N6+1
LORB(IBAS)=253
70 CONTINUE
IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1950
IF(N1.NE.N4.OR.N1.NE.N5.OR.N1.NE.N6) GO TO 1950
IDTRAN=N1
IF(IDTRAN.EQ.0) GO TO 160
SET UP TRANSFORM. COEFF:
S=R2=X2+Y2+Z2:
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
D(X2-Y2):
A(1,2)= ONE
A(2,2)=-ONE
A(3,2)= ZERO
D(3Z2-R2)=-X2-Y2+2Z2:
A(1,3)=-ONE
A(2,3)=-ONE
A(3,3)= TWO
IF(ITOPT.EQ.0) GO TO 110
DO 90 J=1,3
RENOR=RENORM(LIST(J,1))
DO 90 I=1,3
90 A(I,J)=A(I,J)*RENOR
CALL TRANSP(A,6,3)
110 CONTINUE
...LOOP OVER D SETS IN DLIST:
DO 150 ID=1,IDTRAN
M(1)=LIST(1,ID)
M(2)=LIST(2,ID)
M(3)=LIST(3,ID)
...TRANSFORM S AND DM:
IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1)
IF(ITOPT.NE.0) GO TO 150
CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0)
CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0)
...SET THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED:
LORB(M(1))=51
LORB(M(2))=254
LORB(M(3))=255
150 CONTINUE
**********************************************************************
160 CONTINUE
F ORBITALS
IFTRAN=0
DO 400 IFBLK=1,3
N1=0
N2=0
N3=0
IF(IWCUBF.NE.0) GO TO 190
LF1=LF(1,IFBLK)
LF2=LF(2,IFBLK)
LF3=LF(3,IFBLK)
GO TO 200
190 CONTINUE
LF1=LFCUB(1,IFBLK)
LF2=LFCUB(2,IFBLK)
LF3=LFCUB(3,IFBLK)
200 CONTINUE
...CONSTRUCT THE LIST:
DO 260 IBAS=1,NBAS
IF(LORBC(IBAS).NE.LF1) GO TO 220
N1=N1+1
LIST(1,N1)=IBAS
GO TO 260
220 IF(LORBC(IBAS).NE.LF2) GO TO 230
N2=N2+1
LIST(2,N2)=IBAS
GO TO 260
230 IF(LORBC(IBAS).NE.LF3) GO TO 260
N3=N3+1
LIST(3,N3)=IBAS
GO TO 260
260 CONTINUE
IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1960
IF(IFBLK.EQ.1) IFTRAN=N1
IF((IFBLK.NE.1).AND.(IFTRAN.NE.N1)) GO TO 1960
IF(IFTRAN.EQ.0) GO TO 500
IF(IWCUBF.EQ.0) GO TO 270
SET UP TRANSFORM. COEFF, CUBIC F ORBITALS
PX=X*R2, PY=Y*R2, PZ=Z*Z2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
FX(Z2-Y2), FY(Z2-X2), FZ(X2-Y2)
A(1,2)= ONE
A(2,2)=-ONE
A(3,2)= ZERO
FX(5Z2-3R2), FY(5Y2-3R2), FZ(5Z2-3R2)
A(1,3)=-THREE
A(2,3)=-THREE
A(3,3)= TWO
GO TO 310
270 IF(IFBLK.GT.1) GO TO 280
SET UP TRANSFORM. COEFF, FOR FIRST F BLOCK
PX=X*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
FX(X2-3Y2)
A(1,2)= ONE
A(2,2)=-THREE
A(3,2)= ZERO
FX(5Z2-R2)
A(1,3)=-ONE
A(2,3)=-ONE
A(3,3)= FOUR
GO TO 310
280 IF(IFBLK.EQ.3) GO TO 290
SET UP TRANSFORM. COEFF, FOR SECOND F BLOCK
PY=Y*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
FY(3X2-Y2)
A(1,2)= THREE
A(2,2)=-ONE
A(3,2)= ZERO
FY(5Z2-R2)
A(1,3)=-ONE
A(2,3)=-ONE
A(3,3)= FOUR
GO TO 310
290 CONTINUE
SET UP TRANSFORM. COEFF, FOR THIRD F BLOCK
PZ Z*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
FZ(X2-Y2)
A(1,2)= ONE
A(2,2)=-ONE
A(3,2)= ZERO
FZ(5Z2-3R2)
A(1,3)=-THREE
A(2,3)=-THREE
A(3,3)= TWO
310 CONTINUE
IF(ITOPT.EQ.0) GO TO 330
DO 320 J=1,3
RENOR=RENORM(LIST(J,1))
DO 320 I=1,3
320 A(I,J)=A(I,J)*RENOR
CALL TRANSP(A,6,3)
330 CONTINUE
...LOOP OVER F SETS IN LIST:
DO 390 IT=1,IFTRAN
M(1)=LIST(1,IT)
M(2)=LIST(2,IT)
M(3)=LIST(3,IT)
...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0)
IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1)
IF(ITOPT.NE.0) GO TO 340
CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0)
CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0)
...FIX THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED:
340 CONTINUE
IF(IWCUBF.NE.0) GO TO 350
LORB(M(1))=LFT(1,IFBLK)
LORB(M(2))=LFT(2,IFBLK)
LORB(M(3))=LFT(3,IFBLK)
GO TO 390
350 CONTINUE
LORB(M(1))=LFCUBT(1,IFBLK)
LORB(M(2))=LFCUBT(2,IFBLK)
LORB(M(3))=LFCUBT(3,IFBLK)
390 CONTINUE
400 CONTINUE
SEARCH FOR FXYZ AND RELABEL:
LF1=305
LF1T=355
IF(IWCUBF.NE.0) LF1T=354
N1=0
DO 420 IBAS=1,NBAS
IF(LORBC(IBAS).NE.LF1) GO TO 420
N1=N1+1
LORB(IBAS)=LF1T
420 CONTINUE
IF(IFTRAN.NE.N1) GO TO 1960
500 CONTINUE
G ORBITALS
IGTRAN=0
DO 800 IGBLK=1,3
N1=0
N2=0
N3=0
LG1=LG(1,IGBLK)
LG2=LG(2,IGBLK)
LG3=LG(3,IGBLK)
...CONSTRUCT THE LIST:
DO 560 IBAS=1,NBAS
LANG=LORBC(IBAS)
IF(LANG.NE.LG1) GO TO 520
N1=N1+1
LIST(1,N1)=IBAS
GO TO 560
520 IF(LANG.NE.LG2) GO TO 530
N2=N2+1
LIST(2,N2)=IBAS
GO TO 560
530 IF(LANG.NE.LG3) GO TO 560
N3=N3+1
LIST(3,N3)=IBAS
GO TO 560
560 CONTINUE
IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1970
IF(IGBLK.EQ.1) IGTRAN=N1
IF((IGBLK.NE.1).AND.(IGTRAN.NE.N1)) GO TO 1970
IF(IGTRAN.EQ.0) GO TO 1000
IF(IGBLK.GT.1) GO TO 580
SET UP TRANSFORM. COEFF, FOR FIRST G BLOCK
DXY=XY*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
G(2S)
A(1,2)= ONE
A(2,2)=-ONE
A(3,2)= SIX
G(4S)
A(1,3)= ONE
A(2,3)=-ONE
A(3,3)= ZERO
GO TO 610
580 IF(IGBLK.EQ.3) GO TO 590
SET UP TRANSFORM. COEFF, FOR SECOND G BLOCK
DXZ=XZ*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
G(1C)
A(1,2)=-THREE
A(2,2)=-THREE
A(3,2)= FOUR
G(3C)
A(1,3)= ONE
A(2,3)=-THREE
A(3,3)= ZERO
GO TO 610
590 CONTINUE
SET UP TRANSFORM. COEFF, FOR THIRD G BLOCK
DYZ=YZ*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
G(1S)
A(1,2)=-THREE
A(2,2)=-THREE
A(3,2)= FOUR
G(3S)
A(1,3)= THREE
A(2,3)=-ONE
A(3,3)= ZERO
610 CONTINUE
IF(ITOPT.EQ.0) GO TO 630
DO 620 J=1,3
RENOR=RENORM(LIST(J,1))
DO 620 I=1,3
620 A(I,J)=A(I,J)*RENOR
CALL TRANSP(A,6,3)
630 CONTINUE
...LOOP OVER G SETS IN LIST:
DO 690 IT=1,IGTRAN
M(1)=LIST(1,IT)
M(2)=LIST(2,IT)
M(3)=LIST(3,IT)
...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0)
IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1)
IF(ITOPT.NE.0) GO TO 660
CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0)
CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0)
...FIX THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED:
660 CONTINUE
LORB(M(1))=LGT(1,IGBLK)
LORB(M(2))=LGT(2,IGBLK)
LORB(M(3))=LGT(3,IGBLK)
690 CONTINUE
800 CONTINUE
G ORBITALS --- FOURTH (6X6) BLOCK
N1=0
N2=0
N3=0
N4=0
N5=0
N6=0
...CONSTRUCT THE LIST:
DO 870 IBAS=1,NBAS
LANG=LORBC(IBAS)
IF(LANG.NE.401) GO TO 820
N1=N1+1
LIST(1,N1)=IBAS
GO TO 870
820 IF(LANG.NE.411) GO TO 830
N2=N2+1
LIST(2,N2)=IBAS
GO TO 870
830 IF(LANG.NE.415) GO TO 840
N3=N3+1
LIST(3,N3)=IBAS
GO TO 870
840 IF(LANG.NE.404) GO TO 850
N4=N4+1
LIST(1,N4)=IBAS
GO TO 870
850 IF(LANG.NE.406) GO TO 860
N5=N5+1
LIST(2,N5)=IBAS
GO TO 870
860 IF(LANG.NE.413) GO TO 870
N6=N6+1
LIST(3,N6)=IBAS
GO TO 870
870 CONTINUE
IF(IGTRAN.NE.N1.OR.N1.NE.N2.OR.N1.NE.N3) GO TO 1970
IF(N1.NE.N4.OR.N1.NE.N5.OR.N1.NE.N6) GO TO 1970
SET UP TRANSFORM. COEFF, FOR FOURTH G BLOCK
S=(R2)2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
A(4,1)= TWO
A(5,1)= TWO
A(6,1)= TWO
D(3Z2-R2)
A(1,2)=-ONE
A(2,2)=-ONE
A(3,2)= TWO
A(4,2)=-TWO
A(5,2)= ONE
A(6,2)= ONE
D(X2-Y2)
A(1,3)= ONE
A(2,3)=-ONE
A(3,3)= ZERO
A(4,3)= ZERO
A(5,3)= ONE
A(6,3)=-ONE
G(0)
A(1,4)= THREE
A(2,4)= THREE
A(3,4)= EIGHT
A(4,4)= SIX
A(5,4)=-SIX*FOUR
A(6,4)=-SIX*FOUR
G(2C)
A(1,5)=-ONE
A(2,5)=-ONE
A(3,5)= ZERO
A(4,5)= SIX
A(5,5)=-SIX
A(6,5)= ZERO
G(4C)
A(1,6)= ONE
A(2,6)= ONE
A(3,6)= ZERO
A(4,6)=-SIX
A(5,6)= ZERO
A(6,6)= ZERO
IF(ITOPT.EQ.0) GO TO 930
DO 920 J=1,6
RENOR=RENORM(LIST(J,1))
DO 920 I=1,6
920 A(I,J)=A(I,J)*RENOR
CALL TRANSP(A,6,6)
930 CONTINUE
IF(ITOPT.NE.0) CALL TRANSP(A,6,6)
...LOOP OVER G SETS IN LIST:
DO 960 IT=1,IGTRAN
M(1)=LIST(1,IT)
M(2)=LIST(2,IT)
M(3)=LIST(3,IT)
M(4)=LIST(4,IT)
M(5)=LIST(5,IT)
M(6)=LIST(6,IT)
...TRANSFORM S AND DM:
...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0)
IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,6,-1)
IF(ITOPT.NE.0) GO TO 950
CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,6,0)
CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,6,0)
...CHANGE THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED:
950 CONTINUE
LORB(M(1))=51
LORB(M(2))=254
LORB(M(3))=255
LORB(M(4))=451
LORB(M(5))=454
LORB(M(6))=458
960 CONTINUE
RENORMALIZATION, ITOPT=0 :
1000 CONTINUE
ITRAN=IDTRAN+IFTRAN+IGTRAN
IF(ITOPT.NE.0) RETURN
IF(ITRAN.EQ.0) GO TO 1200
DO 1020 I=1,NBAS
X=T(I,I)
1020 RENORM(I)=ONE/SQRT(X)
DO 1040 I=1,NBAS
DO 1040 J=1,NBAS
RIJ=RENORM(I)*RENORM(J)
T(I,J)=T(I,J)*RIJ
1040 DM(I,J)=DM(I,J)*RIJ
RELABELLING OF NON-TRANSFORMED ORBITALS:
1200 CONTINUE
DO 1230 I=1,NBAS
IF(LORB(I).NE.0) GO TO 1230
LANG=LORBC(I)
LORB(I)=LANG
L=LANG/100
IDIF=LANG-L*100
IF(IDIF.GT.50) GO TO 1230
LORB(I)=LORB(I)+50
1230 CONTINUE
RETURN
ERROR MESSAGES:
1950 WRITE(LFNPR,1951)
1951 FORMAT(' Unequal numbers of d function components were',
+' found in the input.',/,' These cannot be properly transformed-',
+'-perhaps they were improperly labelled.')
STOP
1960 WRITE(LFNPR,1961)
1961 FORMAT(' Unequal numbers of f function components were',
+' found in the input.',/,' These cannot be properly transformed-',
+'-perhaps they were improperly labelled.')
STOP
1970 WRITE(LFNPR,1971)
1971 FORMAT(' Unequal numbers of g function components were',
+' found in the input.',/,' These cannot be properly transformed-',
+'-perhaps they were improperly labelled.')
STOP
END
*****************************************************************************
SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
********************************************************************
MAIN SUBROUTINE 'NAO' FOR NATURAL ATOMIC ORBITAL BASIS SET.
INPUT REQUIRED:
S = OVERLAP MATRIX ELEMENTS IN LOWER TRIANGLE (BELOW DIAGONAL)
= DENSITY MATRIX ELEMENTS IN UPPER TRIANGLE (INCLUDING DIAG.)
(INPUT AO'S MUST(!) BE NORMALIZED. ON RETURN, S IS THE
FULL DENSITY MATRIX. OVERLAP MATRIX ELEMENTS ARE LOST.)
LBL = LIST OF ATOMIC CENTERS; LBL(I) = N IF ORBITAL I IS ON CENTER N
LORB = LIST OF ANGULAR MOMENTUM TYPE FOR EACH ORBITAL;
LORB(I) = N IF ORBITAL I IS OF 'TYPE' N.
N = ( 51,151,152,153) = (S,PX,PY,PZ)
= (251,252,253,254,255) = (DXY,DXZ,DYZ,D(X2-Y2),D(3Z2-R2))
= (351-357 FOR THE 7 TYPES OF F ORBITALS)
= (451-459 FOR THE 9 TYPES OF G ORBITALS)
OUTPUT:
T = TRANSFORMATION MATRIX FROM INPUT AO'S TO NAO'S (ROWS ARE
LABELLED BY PRIMITIVE AO'S, COLUMNS BY NAO'S)
NAOCTR = LIST OF ATOMIC CENTERS FOR NAO'S; NAOCTR(I) = N IF NAO # I
IS ON CENTER #N.
NAOL = LIST OF ANGULAR MOMENTUM TYPE FOR EACH NAO, SAME FORMAT AS "LORB"
BEFORE RETURN:
LSTOCC = LIST OF NATURAL MINIMAL BASIS ('OCCUPIED') ORBITALS;
LSTOCC(I)=N (I=1,...,NOCC) MEANS THAT NAO #N BELONGS
TO THE NMB SET.
LSTEMT = LIST OF NATURAL RYDBERG BASIS ('EMPTY') ORBITALS;
LSTEMT(I)=N (I=1,...,NEMT) MEANS THAT NAO #N BELONGS
TO THE NRB SET.
AFTER RETURN:
LSTOCC(I) = 1 ONLY IF NAO #I BELONGS TO THE NMB SET.
********************************************************************
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),OCC(NDIM),BLK(NDIM,NDIM),
+ SBLK(MXAOLM,MXAOLM),EVAL(NBAS),EVAL2(NBAS),
+ LISTAO(MXAOLM,9),C(NBLOCK),EVECT(MXAOLM,MXAOLM)
CHARACTER*80 TITLE
DATA ZERO,ONE/0.0D0,1.0D0/
DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/
SKIP T-NAO FORMATION IF IOINQR(IWPNAO).EQ.IREAD:
IF(IOINQR(IWPNAO).EQ.IREAD) GO TO 200
ZERO TRANSFORMATION MATRIX T:
DO 10 J = 1,NBAS
LSTOCC(J) = 0
LSTEMT(J) = 0
DO 10 I = 1,NBAS
10 T(I,J) = ZERO
NF COUNTS THE ACCUMULATED ORBITALS:
NF = 0
NOCC COUNTS THE ACCUMULATED 'OCCUPIED' ORBITALS:
NEMT COUNTS THE ACCUMULATED 'EMPTY' ORBITALS:
NOCC = 0
NEMT = 0
BEGIN MAIN NAO LOOP OVER ATOMIC CENTERS:
DO 140 ICNTR = 1,NATOMS
LOOP OVER ANGULAR MOMENTUM BLOCKS (S,P,D,F,G). NL COUNTS THE NUMBER
OF ORBITALS IN EACH "M" COMPONENT OF THE "L" BLOCK:
DO 130 IL = 1,5
IF(NF.GT.NBAS) GO TO 130
L = IL - 1
M = 2*L + 1
SCAN ORBITAL LABELS TO GATHER 'LISTAO' OF ORBITALS BELONGING TO
PROPER ATOM AND ANGULAR MOMENTUM SYMMETRY:
DO 20 IM = 1,M
LANG = 100*L + IM + 50
NL = 0
DO 20 I = 1,NBAS
IF((LBL(I).NE.ICNTR).OR.(LORB(I).NE.LANG)) GO TO 20
NL = NL + 1
LISTAO(NL,IM) = I
20 CONTINUE
IF(NL.EQ.0) GO TO 140
LOAD THIS LIST OF ORBITALS INTO BLK AND SBLK (DENSITY MATRIX AND
OVERLAP ELEMENTS, RESP.), AND AVERAGE THE DENSITY MATRIX ELEMENTS
OVER THE M COMPONENTS OF L FOR THE ATOM:
CALL LOADAV(LISTAO,NL,M,S,NDIM,BLK,SBLK,MXAOLM)
SOLVE THE GENERALIZED EIGENVALUE PROBLEM:
CALL ATDIAG(NL,BLK,SBLK,EVAL,C)
ORDER THE EIGENVECTORS BY OCCUPANCY EIGENVALUE:
CALL RANK(EVAL,NL,NL,LARC)
LOOP OVER THE 2*L+1 COMPONENTS TO STORE T-NAO DATA:
DO 120 IM = 1,M
PARTITION ORBITALS INTO 'OCCUPIED' AND 'EMPTY' SETS:
CALL SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,ICNTR,L,NL,NF,NDIM)
STORE THE ORDERED EIGENVECTORS IN T:
DO 120 J = 1,NL
JR = LARC(J)
NF = NF + 1
OCC(NF) = EVAL(J)
DO 110 I = 1,NL
IAO = LISTAO(I,IM)
IJR = I + NL*(JR-1)
T(IAO,NF) = C(IJR)
110 CONTINUE
MAKE UP NAO ORBITAL LABELS:
NAOCTR(NF) = ICNTR
NAOL(NF) = L*100 + IM + 50
120 CONTINUE
130 CONTINUE
140 CONTINUE
200 CONTINUE
READ IN PRE-ORTHOGONAL T-NAO DATA:
IF(IOINQR(IWPNAO).NE.IREAD) GO TO 300
CALL RDPPNA(T,OCC)
RECOMPUTE AND SYMMETRY-AVERAGE WEIGHTS, REORGANIZE LSTOCC IF THE INPUT
PNAOS ARE RPNAOS:
IF(OCC(1).LT.ZERO) CALL NEWWTS(S,T,OCC)
NOCC = 0
NEMT = 0
LANG = 0
ILBL = 1
NLANG = 0
DO 280 I = 1,NBAS
IF(LSTOCC(I).GT.0) NOCC = NOCC + 1
IF((NAOCTR(I).NE.ILBL).OR.(NAOL(I).NE.LANG)) GO TO 240
NLANG = NLANG + 1
GO TO 250
240 IF(NLANG.GT.MXAOLM) MXAOLM = NLANG
NLANG = 1
ILBL = NAOCTR(I)
LANG = NAOL(I)
250 CONTINUE
DO 260 J = 1,NBAS
260 IF(LSTOCC(J).EQ.I) GO TO 280
NEMT = NEMT + 1
LSTEMT(NEMT) = I
280 CONTINUE
300 CONTINUE
WRITE PREORTHOGONAL T-NAO DATA TO LFNPPA:
IF(IOINQR(IWPNAO).EQ.IWRIT) CALL WRPPNA(T,OCC,IWPNAO)
SAVE T-PNAO FOR LATER USE IN COMPUTING THE NON-ORTHOGONAL OVERLAPS
BETWEEN NAOS OR NBOS:
CALL SVPNAO(T)
IF(IOINQR(IWPNAO).EQ.IPRNT) THEN
TITLE = 'PNAOs in the PAO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,-1,IWPNAO)
END IF
FINAL ORTHOGONALIZATION:
DO 450 I = 1,NBAS
DO 440 J = 1,I
440 S(J,I) = S(I,J)
450 S(I,I) = ONE
CALL WORTH(S,T,BLK,LSTOCC,NDIM,NBAS,NOCC,OCC,EVAL,BLK)
IF(NEMT.EQ.0) GO TO 700
CALL SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,BLK)
PUT P-PAO IN UPPER TRIANGLE OF S (AND DIAGONAL):
CALL FEPPAO(BLK)
DO 460 J = 1,NBAS
DO 460 I = 1,J
460 S(I,J) = BLK(I,J)
CALL NEWRYD(T,S,BLK,C,SBLK,EVECT,OCC,EVAL,EVAL2,LISTAO,
* JPRINT(11))
SELECT THE SIGNIFICANT RYDBERGS, PUT IN "LARC".
PUT THE LIST OF THE REST OF THE RYDBERGS INTO "LISTAO",
AND SET THE WEIGHTINGS OF THESE LOW OCCUPANCY ORBITALS TO ONE.
THEN, DO A WEIGHTED ORTHOG. AMONG THE SIGNIFICANT RYDBERGS,
SCHMIDT ORTHOG. THE LOW OCC. RYDS TO THESE, AND FINALLY
DO A LOWDIN ORTHOG. AMONG THE LOW OCC. RYDS.:
CALL RYDSEL(LSTEMT,NEMT,NSEL1,LARC,NSEL2,LISTAO,OCC)
IF(NSEL1.EQ.0) GO TO 690
CALL WORTH(S,T,BLK,LARC,NDIM,NBAS,NSEL1,OCC,EVAL,BLK)
IF(NSEL2.EQ.0) GO TO 700
690 CONTINUE
IF(NSEL1.NE.0)
* CALL SHMDT(T,S,NDIM,NBAS,NSEL1,LARC,NSEL2,LISTAO,BLK)
CALL WORTH(S,T,BLK,LISTAO,NDIM,NBAS,NSEL2,OCC,EVAL,BLK)
700 CONTINUE
CALL FEPPAO(S)
CALL SIMTRS(S,T,OCC,NDIM,NBAS)
CALL REDIAG(S,T,BLK,OCC,SBLK,C,LISTAO,JPRINT(11))
RETURN OCCUPIED LIST 'LSTOCC' OF 1'S OR 0'S:
DO 820 I = 1,NBAS
820 LSTOCC(I) = 1
DO 840 I = 1,NEMT
840 LSTOCC(LSTEMT(I)) = 0
RETURN
END
*****************************************************************************
SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
CHARACTER*80 TITLE
LOGICAL FIRST,CORE,ALLZER
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
Perform the Natural Population Analysis
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBLBL/NLEW,NVAL,LBLS(10,MAXBAS,4)
DIMENSION DM(NDIM,NDIM),SPNAO(NDIM,NDIM),BINDEX(NATOMS,NATOMS),
* BINDT(NATOMS),OVPOP(NATOMS,NATOMS),F(NDIM,NDIM),ENAO(NDIM),
* JPRIN(MAXBAS),ICORE(4),IVAL(4),NWARN(MAXATM),LABEC(20,2),
* OCCEC(20),BMO(NATOMS,NATOMS)
DIMENSION IANG(5),ANGL(25),LANG(25),CUBICF(7)
DATA IRYD/'Ryd'/
DATA IANG/'s','p','d','f','g'/
DATA LANG/ 51,151,152,153,251,252,253,254,255,
* 351,352,353,354,355,356,357,
* 451,452,453,454,455,456,457,458,459/
DATA ANGL/4H ,4Hx ,4Hy ,4Hz ,4Hxy ,4Hxz ,4Hyz ,
* 4Hx2y2,4Hz2 ,4H(0) ,4H(C1),4H(S1),4H(C2),4H(S2),4H(C3),
* 4H(S3),4H(0) ,4H(C1),4H(S1),4H(C2),4H(S2),4H(C3),4H(S3),
* 4H(C4),4H(S4)/
DATA CUBICF/4H(D1),4H(D2),4H(D3),4H(B) ,4H(E1),4H(E2),4H(E3)/
DATA ZERO,TENTH,TWO/0.0D0,0.1D0,2.0D0/
TEST, TEST2, ALLOW, and ALLOW2 are numbers used in determining if the
density matrix trace is close to being an integer. TEST2 (ALLOW2) must
be slightly greater than twice TEST (ALLOW):
DATA TEST,TEST2/1.0D-5,2.1D-5/
DATA ALLOW,ALLOW2/1.0D-3,2.1D-3/
DATA ICHCOR,ICHVAL,ICHRYD/'Cor','Val','Ryd'/
If the f functions are a cubic set, insert the proper labels:
IF(IWCUBF.EQ.0) GOTO 20
DO 10 I = 1,7
II = I+9
10 ANGL(II) = CUBICF(I)
20 CONTINUE
Update the NAO atom-atom valency matrix:
DO 30 J = 1,NATOMS
DO 30 I = 1,NATOMS
OVPOP(I,J) = ZERO
BMO(I,J) = ZERO
30 BINDEX(I,J) = ZERO
DO 50 I = 1,NBAS
IAT = NAOCTR(I)
DO 40 J = 1,NBAS
JAT = NAOCTR(J)
IF(JAT.NE.IAT) THEN
SIJ = SPNAO(I,J)
DMIJ = DM(I,J)
DMIJ2 = DMIJ*DMIJ
DMSIJ = DMIJ*SIJ
BINDEX(JAT,IAT) = BINDEX(JAT,IAT) + DMIJ2
BMO(JAT,IAT) = BMO(JAT,IAT) + DMIJ
OVPOP(JAT,IAT) = OVPOP(JAT,IAT) + DMSIJ
END IF
40 CONTINUE
50 CONTINUE
Determine the NAO orbital energies if a Fock matrix exists. Use
SPNAO to store TNAO:
CALL FETNAO(SPNAO)
IFOCK = IWFOCK
IF(OPEN.AND..NOT.(ALPHA.OR.BETA)) IFOCK = 0
IF(IFOCK.EQ.1) THEN
CALL FEFAO(F,IWFOCK)
IF(IWFOCK.NE.0) THEN
DO 80 I = 1,NBAS
ENRG = ZERO
DO 70 J = 1,NBAS
DO 60 K = 1,NBAS
ENRG = ENRG + SPNAO(J,I)*F(J,K)*SPNAO(K,I)
60 CONTINUE
70 CONTINUE
ENAO(I) = ENRG
80 CONTINUE
END IF
END IF
Label NAO's as either 'Cor', 'Val', or 'Ryd':
DO 200 I = 1,NBAS
LTYP(I) = IRYD
200 CONTINUE
IECP = 0
DO 300 NCTR = 1,NATOMS
CALL CORTBL(NCTR,ICORE,IECP)
CALL VALTBL(NCTR,IVAL)
Loop over s,p,d,f orbitals:
DO 290 L = 0,3
ITYP = IANG(L+1)
LNUM = 2*L + 1
IF(ICORE(L+1).LE.0) GOTO 240
Label core orbitals:
DO 230 M = 1,ICORE(L+1)
DO 220 LA = 1,LNUM
MORB = 0
OCC = -1.0
DO 210 N = 1,NBAS
LM = NAOL(N)
NORB = LM/100
IL = IANG(NORB+1)
NA = MOD(NAOL(N),50)
IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND.
+ DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND.
+ LA.EQ.NA) THEN
MORB = N
OCC = DM(N,N)
END IF
210 CONTINUE
IF(MORB.EQ.0) THEN
WRITE(LFNPR,2500) ITYP,NAMEAT(IATNO(NCTR)),NCTR,
+ (ICORE(I),I=1,4),M,LA
STOP
END IF
LTYP(MORB) = ICHCOR
220 CONTINUE
230 CONTINUE
240 CONTINUE
IF(IVAL(L+1).LE.0) GOTO 280
Label valence orbitals:
DO 270 M = 1,IVAL(L+1)
DO 260 LA = 1,LNUM
MORB = 0
OCC = -1.0
DO 250 N = 1,NBAS
LM = NAOL(N)
NORB = LM/100
IL = IANG(NORB+1)
NA = MOD(NAOL(N),50)
IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND.
+ DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND.
+ LA.EQ.NA) THEN
MORB = N
OCC = DM(N,N)
END IF
250 CONTINUE
IF(MORB.EQ.0) THEN
WRITE(LFNPR,2600) ITYP,NAMEAT(IATNO(NCTR)),NCTR,
+ (IVAL(I),I=1,4),M,LA
STOP
END IF
LTYP(MORB) = ICHVAL
260 CONTINUE
270 CONTINUE
280 CONTINUE
290 CONTINUE
300 CONTINUE
Assign `principal' quantum numbers using the NAO occupancies:
DO 390 I = 1,NBAS
IPRIN(I) = 0
390 CONTINUE
DO 450 NCTR = 1,NATOMS
IECP = 1
CALL CORTBL(NCTR,IVAL,IECP)
IECP = 0
CALL CORTBL(NCTR,ICORE,IECP)
DO 440 L = 0,4
ITYP = IANG(L+1)
MMAX = 2*L + 1
DO 430 M = 1,MMAX
IF(L.EQ.4) THEN
N = 3
ELSE
N = IVAL(L+1) - ICORE(L+1) + L
END IF
400 CONTINUE
MORB = 0
OCC = -1.0
DO 410 J = 1,NBAS
LM = NAOL(J)
NORB = LM/100
IL = IANG(NORB+1)
NA = MOD(NAOL(J),50)
IF(NAOCTR(J).EQ.NCTR.AND.IL.EQ.ITYP.AND.
+ DM(J,J).GT.OCC.AND.IPRIN(J).EQ.0.AND.
+ M.EQ.NA) THEN
MORB = J
OCC = DM(J,J)
END IF
410 CONTINUE
IF(MORB.EQ.0) GOTO 420
N = N + 1
IPRIN(MORB) = N
GOTO 400
420 CONTINUE
430 CONTINUE
440 CONTINUE
450 CONTINUE
Assign `principal' quantum numbers using the NAO Fock matrix elements:
IF(IFOCK.EQ.0) GOTO 580
DO 490 I = 1,NBAS
JPRIN(I) = 0
490 CONTINUE
DO 550 NCTR = 1,NATOMS
IECP = 1
CALL CORTBL(NCTR,IVAL,IECP)
IECP = 0
CALL CORTBL(NCTR,ICORE,IECP)
DO 540 L = 0,4
ITYP = IANG(L+1)
MMAX = 2*L + 1
DO 530 M = 1,MMAX
IF(L.EQ.4) THEN
N = 3
ELSE
N = IVAL(L+1) - ICORE(L+1) + L
END IF
500 CONTINUE
MORB = 0
ENRG = 1.0D6
DO 510 J = 1,NBAS
LM = NAOL(J)
NORB = LM/100
IL = IANG(NORB+1)
NA = MOD(NAOL(J),50)
IF(NAOCTR(J).EQ.NCTR.AND.IL.EQ.ITYP.AND.
+ ENAO(J).LT.ENRG.AND.JPRIN(J).EQ.0.AND.
+ M.EQ.NA) THEN
MORB = J
ENRG = ENAO(J)
END IF
510 CONTINUE
IF(MORB.EQ.0) GOTO 520
N = N + 1
JPRIN(MORB) = N
GOTO 500
520 CONTINUE
530 CONTINUE
540 CONTINUE
550 CONTINUE
580 CONTINUE
Count the total number of electrons:
TOT = ZERO
DO 600 INAO = 1,NBAS
TOT = TOT + DM(INAO,INAO)
600 CONTINUE
NEL = TOT + TENTH
Store NEL for use by the output routines:
NLEW = NEL
Check to see if the total number of electrons found is an integer:
IF(TOT.GE.ZERO) THEN
SUMTT = TOT + TEST
SUMTI = AINT(SUMTT)
SUMTF = SUMTT - SUMTI
IF(SUMTF.GT.TEST2) THEN
SUMTT = TOT + ALLOW
SUMTI = AINT(SUMTT)
SUMTF = SUMTT - SUMTI
IF(SUMTF.GT.ALLOW2) THEN
WRITE(LFNPR,955)
JPRINT(4) = -1
ELSE
WRITE(LFNPR,956)
END IF
END IF
ELSE
WRITE(LFNPR,955)
JPRINT(4) = -1
END IF
Write out Natural Population analysis:
IF(JPRINT(4).NE.0) THEN
IF(IFOCK.EQ.1) THEN
WRITE(LFNPR,900)
ELSE
WRITE(LFNPR,910)
END IF
JCTR = 1
DO 700 I = 1,NBAS
NCTR = NAOCTR(I)
IF(NCTR.NE.JCTR) THEN
WRITE(LFNPR,*)
JCTR = NCTR
END IF
IAT = IATNO(NCTR)
NAM = NAMEAT(IAT)
LM = NAOL(I)
L = LM/100
IL = IANG(L+1)
DO 680 ILM = 1,25
IF(LM.EQ.LANG(ILM)) GOTO 690
680 CONTINUE
690 CONTINUE
OCC = DM(I,I)
IF(OCC.LT.ZERO) OCC = ZERO
IF(IFOCK.EQ.1) THEN
WRITE(LFNPR,920) I,NAM,NCTR,IL,ANGL(ILM),LTYP(I),
+ JPRIN(I),IL,OCC,ENAO(I)
ELSE
WRITE(LFNPR,920) I,NAM,NCTR,IL,ANGL(ILM),LTYP(I),
+ IPRIN(I),IL,OCC
END IF
700 CONTINUE
Add note about effective core potentials if used:
IECP = 0
DO 710 I = 1,NATOMS
IECP = IECP + IATNO(I) - IZNUC(I)
710 CONTINUE
IF(IPSEUD.NE.0) THEN
IF(ALPHA.OR.BETA) IECP = IECP/2
WRITE(LFNPR,930) IECP
END IF
Write out warnings for low occupancy core orbitals:
CRTHRS = CRTSET
IF(ALPHA.OR.BETA) CRTHRS = CRTHRS - 1.0
DO 715 N = 1,NATOMS
NWARN(N) = 0
715 CONTINUE
DO 720 I = 1,NBAS
ICTR = NAOCTR(I)
IF(LTYP(I).EQ.ICHCOR.AND.DM(I,I).LT.CRTHRS)
+ NWARN(ICTR) = NWARN(ICTR) + 1
720 CONTINUE
FIRST = .TRUE.
DO 725 N = 1,NATOMS
NAM = NAMEAT(IATNO(N))
IF(NWARN(N).EQ.1) THEN
IF(FIRST) THEN
WRITE(LFNPR,931) CRTHRS,NAM,N
FIRST = .FALSE.
ELSE
WRITE(LFNPR,932) CRTHRS,NAM,N
END IF
ELSE IF(NWARN(N).GT.1) THEN
IF(FIRST) THEN
WRITE(LFNPR,933) NWARN(N),CRTHRS,NAM,N
FIRST = .FALSE.
ELSE
WRITE(LFNPR,934) NWARN(N),CRTHRS,NAM,N
END IF
END IF
725 CONTINUE
Write out warnings for population inversions:
IF(IFOCK.EQ.1) THEN
DO 730 N = 1,NATOMS
NWARN(N) = 0
730 CONTINUE
DO 735 I = 1,NBAS
ICTR = NAOCTR(I)
IF(IPRIN(I).NE.JPRIN(I)) NWARN(ICTR) = 1
IPRIN(I) = JPRIN(I)
735 CONTINUE
FIRST = .TRUE.
DO 738 N = 1,NATOMS
NAM = NAMEAT(IATNO(N))
IF(NWARN(N).GT.0) THEN
IF(FIRST) THEN
WRITE(LFNPR,936) NAM,N
FIRST = .FALSE.
ELSE
WRITE(LFNPR,937) NAM,N
END IF
END IF
738 CONTINUE
END IF
Summarize the Natural Population Analysis:
WRITE(LFNPR,939)
SUMAC = ZERO
SUMAV = ZERO
SUMAR = ZERO
NOMAC = 0
DO 750 I = 1,NATOMS
SUMC = ZERO
SUMV = ZERO
SUMR = ZERO
NAM = NAMEAT(IATNO(I))
DO 740 J = 1,NBAS
IF(NAOCTR(J).EQ.I) THEN
OCC = DM(J,J)
IF(OCC.LT.ZERO) OCC = ZERO
IF(LTYP(J).EQ.ICHCOR) SUMC = SUMC + OCC
IF(LTYP(J).EQ.ICHVAL) SUMV = SUMV + OCC
IF(LTYP(J).EQ.ICHRYD) SUMR = SUMR + OCC
IF(LTYP(J).EQ.ICHCOR) NOMAC = NOMAC + 2
END IF
740 CONTINUE
TOT = SUMC + SUMV + SUMR
IF(ALPHA.OR.BETA) THEN
CHG = IZNUC(I)/2.0 - TOT
ELSE
CHG = IZNUC(I) - TOT
END IF
ECP = FLOAT(IATNO(I) - IZNUC(I))
IF(ALPHA.OR.BETA) ECP = ECP/TWO
WRITE(LFNPR,940) NAM,I,CHG,SUMC+ECP,SUMV,SUMR,TOT+ECP
SUMAC = SUMAC + SUMC
SUMAV = SUMAV + SUMV
SUMAR = SUMAR + SUMR
750 CONTINUE
TOT = SUMAC + SUMAV + SUMAR
CHG = -1.0 * TOT
IF(ALPHA.OR.BETA) THEN
NOMAC = NOMAC/2
DO 760 I = 1,NATOMS
CHG = CHG + IZNUC(I)/2.0
760 CONTINUE
ELSE
DO 770 I = 1,NATOMS
CHG = CHG + IZNUC(I)
770 CONTINUE
END IF
WRITE(LFNPR,950) CHG,SUMAC+FLOAT(IECP),SUMAV,SUMAR,
+ TOT+FLOAT(IECP)
Write out NMB and NRB populations and percentage occupancies:
WRITE(LFNPR,960)
NOMA = NEL
NOMAV = NOMA - NOMAC
SUMA = SUMAC + SUMAV
IF(IPSEUD.NE.0) THEN
ECP = IECP
SUMA = SUMA + ECP
NOMA = NOMA + IECP
WRITE(LFNPR,970) ECP
END IF
IF(NOMAC.NE.0) THEN
PCENT = SUMAC/NOMAC * 100.0
WRITE(LFNPR,980) SUMAC,PCENT,NOMAC
ELSE IF(SUMAC.NE.ZERO) THEN
PCENT = ZERO
WRITE(LFNPR,980) SUMAC,PCENT,NOMAC
END IF
IF(NOMAV.NE.0) THEN
PCENT = SUMAV/NOMAV * 100.0
WRITE(LFNPR,990) SUMAV,PCENT,NOMAV
ELSE IF(SUMAV.NE.ZERO) THEN
PCENT = ZERO
WRITE(LFNPR,990) SUMAV,PCENT,NOMAV
END IF
IF(NOMA.NE.0) THEN
PCENT = SUMA/NOMA * 100.0
ELSE
PCENT = ZERO
END IF
WRITE(LFNPR,1000) SUMA,PCENT,NOMA
IF(NOMA.NE.0) THEN
PCENT = SUMAR/NOMA * 100.0
WRITE(LFNPR,1010) SUMAR,PCENT,NOMA
ELSE IF(SUMAR.NE.ZERO) THEN
PCENT = 0
WRITE(LFNPR,1010) SUMAR,PCENT,NOMA
END IF
Write out Natural Electron Configuration:
WRITE(LFNPR,1040)
DO 899 NCTR = 1,NATOMS
ICT = 0
IECP = 1
CALL CORTBL(NCTR,ICORE,IECP)
DO 870 NPL = 1,8
DO 860 N = 1,NPL
L = NPL - N
IF(L.GE.0.AND.L.LT.N) THEN
IF(N.GT.ICORE(L+1)+L) THEN
ICT = ICT + 1
LABEC(ICT,1) = N
LABEC(ICT,2) = IANG(L+1)
OCCEC(ICT) = ZERO
END IF
END IF
860 CONTINUE
870 CONTINUE
DO 890 I = 1,NBAS
ICTR = NAOCTR(I)
IF(ICTR.EQ.NCTR.AND.LTYP(I).NE.ICHCOR) THEN
NORB = NAOL(I)/100
IL = IANG(NORB+1)
DO 880 J = 1,ICT
IF(IPRIN(I).EQ.LABEC(J,1).AND.
+ IL.EQ.LABEC(J,2)) THEN
OCCEC(J) = OCCEC(J) + DM(I,I)
GOTO 890
END IF
880 CONTINUE
END IF
890 CONTINUE
IF(LABEC(1,1).NE.1) THEN
CORE = .TRUE.
ELSE
CORE = .FALSE.
END IF
THOLD = 5.0D-3
JMAX = ICT
Remove low occupancy subshells:
DO 893 JCT = 1,ICT
891 CONTINUE
IF(OCCEC(JCT).LT.THOLD) THEN
ALLZER = .TRUE.
DO 892 KCT = JCT,ICT-1
LABEC(KCT,1) = LABEC(KCT+1,1)
LABEC(KCT,2) = LABEC(KCT+1,2)
OCCEC(KCT) = OCCEC(KCT+1)
IF(OCCEC(KCT).GE.THOLD) ALLZER = .FALSE.
892 CONTINUE
OCCEC(ICT) = ZERO
IF(ALLZER) THEN
JMAX = JCT - 1
GOTO 895
END IF
GOTO 891
END IF
893 CONTINUE
895 CONTINUE
NAM = NAMEAT(IATNO(NCTR))
IF(JMAX.EQ.0) THEN
IF(.NOT.CORE) THEN
WRITE(LFNPR,1050) NAM,NCTR
ELSE
WRITE(LFNPR,1060) NAM,NCTR
END IF
ELSE
IF(.NOT.CORE) THEN
WRITE(LFNPR,1050) NAM,NCTR,((LABEC(K,J),J=1,2),OCCEC(K),
+ K=1,JMAX)
ELSE
WRITE(LFNPR,1060) NAM,NCTR,((LABEC(K,J),J=1,2),OCCEC(K),
+ K=1,JMAX)
END IF
END IF
899 CONTINUE
END IF
IF(JPRINT(4).LT.0) STOP
Write out Wiberg Bond Index Matrix if requested:
IF(JPRINT(12).NE.0) THEN
TITLE = 'Wiberg bond index matrix in the NAO basis:'
CALL AOUT(BINDEX,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS)
DO 3010 IAT = 1,NATOMS
BINDT(IAT) = ZERO
DO 3000 JAT = 1,NATOMS
IF(IAT.EQ.JAT) GOTO 3000
BINDT(IAT) = BINDT(IAT) + BINDEX(JAT,IAT)
3000 CONTINUE
3010 CONTINUE
TITLE = 'Wiberg bond index, Totals by atom:'
CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1)
Write out overlap-weighted bond populations:
TITLE = 'Atom-atom overlap-weighted NAO bond order:'
CALL AOUT(OVPOP,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS)
DO 3030 IAT = 1,NATOMS
BINDT(IAT) = ZERO
DO 3020 JAT = 1,NATOMS
IF(IAT.EQ.JAT) GOTO 3020
BINDT(IAT) = BINDT(IAT) + OVPOP(JAT,IAT)
3020 CONTINUE
3030 CONTINUE
TITLE(1:43) = 'Atom-atom overlap-weighted NAO bond order, '
TITLE(44:58) = 'Totals by atom:'
CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1)
Write out MO bond orders:
TITLE = 'MO bond order:'
CALL AOUT(BMO,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS)
DO 3050 IAT = 1,NATOMS
BINDT(IAT) = ZERO
DO 3040 JAT = 1,NATOMS
IF(IAT.EQ.JAT) GOTO 3040
BINDT(IAT) = BINDT(IAT) + BMO(JAT,IAT)
3040 CONTINUE
3050 CONTINUE
TITLE = 'MO atomic valencies:'
CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1)
END IF
Save NAO info in COMMON/NBNAO/:
DO 888 I = 1,NBAS
NAOC(I) = NAOCTR(I)
NAOA(I) = NAOL(I)
888 CONTINUE
RETURN
900 FORMAT(//,1X,
+'NATURAL POPULATIONS: Natural atomic orbital occupancies ',/,1X,
+' ',/,1X,
+' NAO Atom # lang Type(AO) Occupancy Energy ',/,1X,
+'---------------------------------------------------------')
910 FORMAT(//,1X,
+'NATURAL POPULATIONS: Natural atomic orbital occupancies ',/,1X,
+' ',/,1X,
+' NAO Atom # lang Type(AO) Occupancy ',/,1X,
+'------------------------------------------- ')
920 FORMAT(1X,I3,3X,A2,I3,2X,A1,A4,2X,A3,'(',I2,A1,')',4X,
+ F8.5,4X,F10.5)
930 FORMAT(/,1X,
+'[',I3,' electrons found in the effective core potential]')
931 FORMAT(/,1X,
+'WARNING: 1 low occupancy (<',F6.4,'e) core orbital found ',
+'on ',A2,I2)
932 FORMAT(1X,
+' 1 low occupancy (<',F6.4,'e) core orbital found ',
+'on ',A2,I2)
933 FORMAT(/,1X,
+'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals found',
+' on ',A2,I2)
934 FORMAT(1X,
+' ',I3,' low occupancy (<',F6.4,'e) core orbitals found',
+' on ',A2,I2)
936 FORMAT(/,1X,
+'WARNING: Population inversion found on atom ',A2,I2)
937 FORMAT(1X,
+' Population inversion found on atom ',A2,I2)
939 FORMAT(//,1X,
+'Summary of Natural Population Analysis: ',/,1X,
+' ',/,1X,
+' Natural Population ',/,1X,
+' Natural ',47('-'),/,1X,3X,'Atom #',5X,
+'Charge',8X,'Core',6X,'Valence',4X,'Rydberg',6X,'Total',/,1X,
+71('-'))
940 FORMAT(1X,4X,A2,I3,2X,F9.5,4X,F9.5,3X,F9.5,2X,F9.5,3X,F9.5)
950 FORMAT(1X,71('='),/,1X,' * Total *',F9.5,4X,F9.5,3X,F9.5,2X,
+ F9.5,3X,F9.5)
955 FORMAT(/1X,
+'Number of electrons is not an integer! Please check your ',
+'data.',/)
956 FORMAT(/1X,
+'WARNING: Number of electrons is not within 1.0D-5 of an',
+' integer.'/)
960 FORMAT(/,1X,
+' Natural Population ',/,1X,
+'--------------------------------------------------------')
970 FORMAT(1X,' Effective Core ',F10.5)
980 FORMAT(1X,' Core ',F10.5,' (',F8.4,
+'% of ',I3,')')
990 FORMAT(1X,' Valence ',F10.5,' (',F8.4,
+'% of ',I3,')')
1000 FORMAT(1X,' Natural Minimal Basis ',F10.5,' (',F8.4,
+'% of ',I3,')')
1010 FORMAT(1X,' Natural Rydberg Basis ',F10.5,' (',F8.4,
+'% of ',I3,')',/,1X,
+'--------------------------------------------------------')
1040 FORMAT(/1X,
+' Atom # Natural Electron Configuration',/,1X,
+ 76('-'))
1050 FORMAT(1X,4X,A2,I3,6X,6X,(13(I1,A1,'(',F5.2,')')))
1060 FORMAT(1X,4X,A2,I3,6X,'[core]',(13(I1,A1,'(',F5.2,')')))
2500 FORMAT(/1X,'Subroutine NAOANL could not find a ',A1,'-type ',
+ 'core orbital on atom ',A2,I2,'.',/,1X,'ICORE :',4I3,
+ ' M :',I3,' LA :',I3)
2600 FORMAT(/1X,'Subroutine NAOANL could not find a ',A1,'-type ',
+ 'valence orbital on atom ',A2,I2,'.',/,1X,'IVAL :',4I3,
+ ' M :',I3,' LA :',I3)
END
*****************************************************************************
SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
CHARACTER*80 TITLE
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION T(NDIM,NDIM),TMO(NDIM,NDIM),C(NDIM,NDIM),
+ SCR(NDIM*(NDIM+5))
DIMENSION BASIS(4)
DATA BASIS/' NAO',' NHO',' NBO','NLMO'/
DATA ZERO/0.0D0/
Input:
T -- transformation from AO basis to currect basis
INDEX -- current basis = 2,3,4,5 (NAO,NHO,NBO,NLMO)
IFLG -- number of columns of TMO to print
or external LFN to write to
Fetch the AO to MO transformation matrix:
CALL FEAOMO(C,IT)
IF(IT.EQ.0) RETURN
Find the MO transformation matrix:
ZERTOL = 1.0E-8
EPS = 1.0E-8
MAXIT = 10
LFN0 = 0
CALL LINEQ(T,TMO,C,SCR,NBAS,NBAS,NDIM,NDIM,ZERTOL,EPS,MAXIT,
+ LFN0,IERR)
IF(IERR.NE.0) THEN
WRITE(LFNPR,910) BASIS(INDEX-1)
IF(IERR.EQ.1) WRITE(LFNPR,920) BASIS(INDEX-1)
STOP
END IF
Make sure the largest coefficient in each column is positive:
DO 30 KCOL = 1,NBAS
TMAX = ZERO
DO 10 JROW = 1,NBAS
IF(ABS(TMO(JROW,KCOL)).GT.ABS(TMAX)) TMAX = TMO(JROW,KCOL)
10 CONTINUE
IF(TMAX.LT.ZERO) THEN
DO 20 JROW = 1,NBAS
TMO(JROW,KCOL) = -TMO(JROW,KCOL)
20 CONTINUE
END IF
30 CONTINUE
Write or print the MO transformation matrix:
IF(INDEX.EQ.2) TITLE = 'MOs in the NAO basis:'
IF(INDEX.EQ.3) TITLE = 'MOs in the NHO basis:'
IF(INDEX.EQ.4) TITLE = 'MOs in the NBO basis:'
IF(INDEX.EQ.5) TITLE = 'MOs in the NLMO basis:'
CALL AOUT(TMO,NDIM,NBAS,NBAS,TITLE,INDEX,IFLG)
RETURN
910 FORMAT(/1X,'Error calculating the ',A4,' to MO transformation')
920 FORMAT(1X,'The AO to ',A4,' transformation is not invertible')
END
****************************************************************************
ROUTINES CALLED BY SR NAO:
SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM)
SUBROUTINE ATDIAG(N,A,B,EVAL,C)
SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM)
SUBROUTINE NEWWTS(S,T,WT)
SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK)
SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK)
SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2,
+ LIST,IRPNAO)
SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
+ IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT)
SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO)
SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,IRPNAO)
*****************************************************************************
SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION S(NDIM,NDIM),LISTAO(MXAOLM,9),A(NL,NL),B(NL,NL)
DATA ONE,ZERO/1.0D0,0.0D0/
AVERAGE THE AO DENSITY MATRIX ELEMENTS OVER THE M=2*L+1 COMPONENTS
OF L FOR A PARTICULAR ATOM.
LOAD DENSITY MATRIX ELEMENTS (UPPER TRIANGLE OF S, INCL. DIAGONAL)
INTO A, OVERLAP MATRIX ELEMENTS (LOWER TRIANGLE OF S) INTO B, FOR
ORBITALS OF 'LIST'
DO 30 J=1,NL
DO 20 I=1,J
FIND AVERAGE DM ELEMENT OVER THE VALUES OF IM:
SUM=ZERO
DO 10 IM=1,M
IAO=LISTAO(I,IM)
JAO=LISTAO(J,IM)
10 SUM=SUM+S(IAO,JAO)
AVE=SUM/M
DENSITY MATRIX ELEMENTS INTO A:
A(I,J)=AVE
A(J,I)=AVE
OVERLAP MATRIX ELEMENTS INTO B:
B(I,J)=S(JAO,IAO)
20 B(J,I)=B(I,J)
30 B(J,J)=ONE
RETURN
END
*****************************************************************************
SUBROUTINE ATDIAG(N,A,B,EVAL,C)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
SOLVE GENERALIZED EIGENVALUE PROBLEM (A-EVAL*B)*C = 0.
USE JACOBI TO DIAGONALIZE B**(-1/2)*A*B**(-1/2); A AND B ARE DESTROYED.
DIMENSION A(N,N),B(N,N),EVAL(N),C(N,N)
DATA ZERO,ONE/0.0D0,1.0D0/
FIRST FORM B**(-1/2) AND STORE IT IN B:
CALL JACOBI(N,B,EVAL,C,N,N,0)
DO 10 I=1,N
10 EVAL(I)=ONE/SQRT(EVAL(I))
DO 30 I=1,N
DO 30 J=1,I
TEMP=ZERO
DO 20 K=1,N
20 TEMP=TEMP+EVAL(K)*C(I,K)*C(J,K)
B(I,J)=TEMP
30 B(J,I)=TEMP
NOW SIMILARITY TRANSFORM A WITH B:
CALL SIMTRS(A,B,EVAL,N,N)
DIAGONALIZE A:
CALL JACOBI(N,A,EVAL,C,N,N,1)
MULTIPLY B*C TO GET EIGENVECTORS FOR ORIGINAL PROBLEM, STORE IN A:
DO 50 I=1,N
DO 50 J=1,N
TEMP=ZERO
DO 40 K=1,N
40 TEMP=TEMP+B(I,K)*C(K,J)
50 A(I,J)=TEMP
MOVE FINAL EIGENVECTORS TO C:
CALL COPY(A,C,N,N,N)
RETURN
END
*****************************************************************************
SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM)
*****************************************************************************
Select the set of natural minimal basis (NMB) orbitals for a particular
atom and angular symmetry type: (up to atomic number 105)
------------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION LSTOCC(NDIM),LSTEMT(NDIM)
DIMENSION ICORE(4),IVAL(4)
If g orbitals or orbitals of even higher angular symmetry are selected,
there are none in the NMB:
IF(L.GE.4) GOTO 100
Find core and valence orbitals for this atom:
IECP = 0
CALL CORTBL(IAT,ICORE,IECP)
CALL VALTBL(IAT,IVAL)
Determine the number of shells with angular symmetry L in the NMB.
If there are a negative number of core orbitals, ignore them:
NSHELL = MAX0(ICORE(L+1),0) + IVAL(L+1)
IF(NSHELL.EQ.0) GOTO 100
Select sets of occupied and empty NAO's:
DO 10 J = 1,NSHELL
NOCC = NOCC + 1
LSTOCC(NOCC) = NF + J
10 CONTINUE
LEFT = NL - NSHELL
IF(LEFT.EQ.0) RETURN
DO 20 J = 1,LEFT
NEMT = NEMT + 1
LSTEMT(NEMT) = NF + NSHELL + J
20 CONTINUE
RETURN
No NMB `L'-type orbitals found for this atom:
100 CONTINUE
DO 110 J = 1,NL
NEMT = NEMT + 1
LSTEMT(NEMT) = NF + J
110 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE NEWWTS(S,T,WT)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),WT(NDIM)
CHARACTER*80 TITLE
DATA ZERO/0.0D0/
RECOMPUTE OCCUPANCY WEIGHTS
NOCC=0
DO 20 I=1,NBAS
SUM=ZERO
DO 10 J=1,NBAS
DO 10 K=1,NBAS
SJK=S(J,K)
IF(J.GT.K) SJK=S(K,J)
10 SUM=SUM+T(J,I)*SJK*T(K,I)
WT(I)=SUM
REFORMAT LIST LSTOCC:
IF(LSTOCC(I).EQ.0) GO TO 20
NOCC=NOCC+1
LSTOCC(NOCC)=I
20 CONTINUE
NSTART=NOCC+1
DO 40 I=NSTART,NDIM
40 LSTOCC(I)=0
SYMMETRY-AVERAGE WEIGHTS:
NL=1
IORB=0
100 IORB=IORB+NL
IF(IORB.GT.NBAS) GO TO 600
NL=1
ILBL=NAOCTR(IORB)
IL=NAOL(IORB)/100
NM=IL*2+1
IMAX=NBAS-IORB
DO 130 IADD=1,IMAX
JORB=IORB+IADD
JORBL=NAOL(JORB)/100
IF(NAOCTR(JORB).NE.ILBL.OR.JORBL.NE.IL) GO TO 140
130 NL=NL+1
140 NC=NL/NM
DO 500 I=1,NC
SUM=ZERO
DO 300 M=1,NM
INAO=IORB+(I-1)+(M-1)*NC
300 SUM=SUM+WT(INAO)
AV=SUM/NM
DO 400 M=1,NM
INAO=IORB+(I-1)+(M-1)*NC
400 WT(INAO)=AV
500 CONTINUE
GO TO 100
600 CONTINUE
TITLE = 'New symmetry-averaged occupancy weights:'
CALL AOUT(WT,NBAS,NBAS,1,TITLE,-1,1)
RETURN
END
*****************************************************************************
SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
******************************************************************
WORTH: OCCUPANCY WEIGHTED ORTHOGONALIZATION SUBROUTINE
S: FULL OVERLAP MATRIX (PURE AO BASIS)
(NOTE: UPPER TRIANGLE USED FOR SCRATCH, BUT RESTORED AGAIN)
T: PURE AO TO PRE-NAO TRANSFORMATION
LIST: LIST OF ORBITALS TO BE ORTHOGONALIZED
N: NUMBER OF ORBITALS IN LIST
OCC: LIST OF SYMMETRY AVERAGED OCCUPANCY WEIGHTINGS
NOTE: BLK AND BIGBLK SHARE THE SAME STORAGE BUT ARE
DIMENSIONED DIFFERENTLY.
******************************************************************
DIMENSION S(NDIM,NDIM),T(NDIM,NDIM),BLK(N,N)
DIMENSION OCC(NDIM),LIST(NDIM),EVAL(NDIM),BIGBLK(NDIM,NDIM)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DATA ZERO,ONE/0.0D0,1.0D0/
DATA NTIME/0/
IMPORTANT CONSTANTS:
WTTHR ALL WEIGHTING FACTORS SMALLER THAN WTTHR ARE SET
TO THE VALUE OF WTTHR.
DIAGTH THRESHOLD FOR MATRIX DIAGONALIZATION USED IN
SUBROUTINE JACOBI. IN JACOBI, THIS CONSTANT
IS CALLED "DONETH".
DANGER CRITERION FOR DECIDING THAT THE JOB SHOULD BE
ABORTED DUE TO NUMERICAL PROBLEMS CAUSED BY NEAR
LINEAR DEPENDENCIES IN THE BASIS SET. ALL
EIGENVALUES OF THE WEIGHTED OVERLAP MATRIX MUST
BE GREATER THAN DIAGTH*DANGER.
DATA WTTHR,DIAGTH,DANGER/1.0D-3,1.0D-12,1.0D3/
NTIME=NTIME+1
MULTIPLY THE WEIGHT BY A CONSTANT SO THAT THE MAXIMUM WEIGHT IS ONE,
AND SET ANY RESULTING WEIGHT THAT IS LESS THAN WTTHR TO THE VALUE OF WTTHR:
WTMAX=ZERO
DO 10 I=1,N
IP=LIST(I)
IF(OCC(IP).GT.WTMAX) WTMAX=OCC(IP)
10 CONTINUE
DO 20 I=1,N
IP=LIST(I)
EVAL(IP)=OCC(IP)/WTMAX
IF(EVAL(IP).LT.WTTHR) EVAL(IP)=WTTHR
20 CONTINUE
FORM THE WEIGHTED PRE-NAO VECTORS:
DO 30 J=1,N
JP=LIST(J)
DO 30 I=1,NBAS
30 T(I,JP)=T(I,JP)*EVAL(JP)
FORM THE WEIGHTED OVERLAP MATRIX OF THE VECTORS IN THE UPPER TRIANGLE OF S:
DO 70 I=1,N
IP=LIST(I)
DO 70 J=1,NBAS
SIJ=ZERO
DO 40 K=1,NBAS
TKI=T(K,IP)
IF(TKI.EQ.ZERO) GO TO 40
SIJ=SIJ+TKI*S(K,J)
40 CONTINUE
70 BIGBLK(J,I)=SIJ
DO 100 I=1,N
DO 100 J=1,I
JP=LIST(J)
SIJ=ZERO
DO 90 K=1,NBAS
TKJ=T(K,JP)
IF(TKJ.EQ.ZERO) GO TO 90
SIJ=SIJ+BIGBLK(K,I)*TKJ
90 CONTINUE
100 S(J,I)=SIJ
DIAGONALIZE S-TILDE (THE WEIGHTED OVERLAP MATRIX):
CALL JACOBI(N,S,EVAL,BLK,NDIM,N,0)
FORM THE INVERSE SQRT OF THE OVERLAP MATRIX OF THESE WEIGHTED VECTORS:
SMLEST=ONE
TOOSML=DIAGTH*DANGER
DO 150 I=1,N
EIGENV=EVAL(I)
IF(EIGENV.LT.TOOSML) GO TO 900
EVAL(I)=ONE/SQRT(EIGENV)
IF(EIGENV.LT.SMLEST) SMLEST=EIGENV
150 CONTINUE
DO 170 I=1,N
DO 170 J=1,I
SIJ=ZERO
DO 160 K=1,N
160 SIJ=SIJ+EVAL(K)*BLK(I,K)*BLK(J,K)
170 S(J,I)=SIJ
THE UPPER TRIANGLE OF S (INCLUDING THE DIAGONAL)
NOW CONTAINS THE -0.5 POWER OF THE WEIGHTED OVERLAP MATRIX,
AND IS THE WEIGHTED ORTHOG. TRANSFORM THAT WE WANT.
NOW, FORM THE TOTAL TRANSFORMATION:
DO 300 I=1,NBAS
DO 260 J=1,N
EVAL(J)=ZERO
DO 220 K=1,J
KP=LIST(K)
TIK=T(I,KP)
IF(TIK.EQ.ZERO) GO TO 220
EVAL(J)=EVAL(J)+TIK*S(K,J)
220 CONTINUE
JP1=J+1
DO 240 K=JP1,N
KP=LIST(K)
TIK=T(I,KP)
IF(TIK.EQ.ZERO) GO TO 240
EVAL(J)=EVAL(J)+TIK*S(J,K)
240 CONTINUE
260 CONTINUE
DO 280 J=1,N
JP=LIST(J)
280 T(I,JP)=EVAL(J)
300 CONTINUE
RESTORE FULL OVERLAP MATRIX S:
DO 400 I=1,NBAS
IM1=I-1
DO 380 J=1,IM1
380 S(J,I)=S(I,J)
400 S(I,I)=ONE
RETURN
900 WRITE(LFNPR,1000) EIGENV,TOOSML
STOP
1000 FORMAT(//1X,'An eigenvalue of the weighted PRE-NAO overlap',
+' matrix of ',F10.5,' has been',/,1X,'found, which is lower than',
+' the allowed threshold of ',F10.5,'. This is',/,1X,'probably',
+' caused by either an error in the data given to the analysis',
+' program',/,1X,'or by numerical problems caused by near linear',
+' dependencies among the basis',/,1X,'functions.')
END
*****************************************************************************
SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
SCHMIDT ORTHOGONALIZATION OF COLUMN VECTORS IN T
SCHMIDT ORTHOGONALIZE EACH EMPTY ORBITAL (SPECIFIED IN 'LSTEMT')
TO THE ORTHONORMAL OCCUPIED (LSTOCC) ORBITALS;
DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),LSTOCC(NDIM),LSTEMT(NDIM),
* SBLK(NDIM,NDIM)
DATA ZERO/0.0D0/
DO 30 I=1,NBAS
DO 30 J=1,NOCC
JP=LSTOCC(J)
SJI=ZERO
DO 10 K=1,NBAS
10 SJI=SJI+T(K,JP)*S(K,I)
30 SBLK(I,J)=SJI
SCHMIDT ORTHOGONALIZE EACH UNOCCUPIED /UI> TO EACH /VJ>:
...LOOP OVER UNOCCUPIED /UI>'S,
DO 120 I=1,NEMT
IP=LSTEMT(I)
...LOOP OVER OCCUPIED /VJ>'S,
DO 60 J=1,NOCC
JP=LSTOCC(J)
...CALCULATE SJI = ,
SJI=ZERO
DO 40 K=1,NBAS
40 SJI=SJI+SBLK(K,J)*T(K,IP)
...AND REPLACE EACH /UI> = /UI> - SJI*/VJ>.
DO 50 K=1,NBAS
50 T(K,IP)=T(K,IP)-SJI*T(K,JP)
60 CONTINUE
120 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2,
* LIST,IRPNAO)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),TPNAO(NDIM,NDIM),OCC(NDIM),
+ DMBLK(MXAOLM,MXAOLM),SBLK(MXAOLM,MXAOLM),EVAL(NBAS),
+ EVECT(MXAOLM,MXAOLM),EVAL2(NBAS),LIST(MXAOLM)
DATA ONE/1.0D0/
COMPUTE NEW RYDBERG NAOS AFTER THE SCHMIDT ORTHOGONALIZATION TO
THE MINIMAL NAO SET HAS BEEN DONE:
IF REQUESTED (IRPNAO=JPRINT(11)=1), UPDATE PNAO TRANSFORMATION WITH TRYD:
IF(IRPNAO.EQ.1) CALL FEPNAO(TPNAO)
NL=1
IORB=0
100 IORB=IORB+NL
IF(IORB.GT.NBAS) GO TO 300
NL=1
ILBL=NAOCTR(IORB)
IL=NAOL(IORB)/100
NM=IL*2+1
IMAX=NBAS-IORB
DO 130 IADD=1,IMAX
JORB=IORB+IADD
JORBL=NAOL(JORB)/100
IF(NAOCTR(JORB).NE.ILBL.OR.JORBL.NE.IL) GO TO 140
130 NL=NL+1
140 NC=NL/NM
NSKIP=0
IMAX=IORB-1+NC
DO 150 I=1,NBAS
INAO=LSTOCC(I)
IF(INAO.LT.IORB.OR.INAO.GT.IMAX) GO TO 150
NSKIP=NSKIP+1
150 CONTINUE
IF(NSKIP.EQ.NC) GO TO 100
NSTART=NSKIP+1
NRYDC=NC-NSKIP
CALL RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
* IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
END OF LOOP STARTING AT 100
GO TO 100
300 CONTINUE
RESTORE S:
DO 350 I=1,NBAS
IM1=I-1
DO 340 J=1,IM1
340 S(J,I)=S(I,J)
350 S(I,I)=ONE
SAVE UPDATED T-PNAO TRANSFORMATION:
IF(IRPNAO.EQ.1) CALL SVPNAO(TPNAO)
RETURN
END
*****************************************************************************
SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
* IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),TPNAO(NDIM,NDIM),OCC(NBAS),
* DMBLK(NRYDC,NRYDC),SBLK(NRYDC,NRYDC),EVAL(NBAS),
* EVECT(NRYDC,NRYDC),LARC(NRYDC),LIST(NRYDC),EVAL2(NBAS)
DATA ZERO/0.0D0/
DIAGONALIZE ONE RYDBERG BLOCK, UPDATE T-NAO (IN T) AND, IF IRPNAO.EQ.1,
UPDATE TPNAO:
II=0
DO 20 I=1,NRYDC
DO 20 J=1,NRYDC
DMBLK(I,J)=ZERO
SBLK(I,J)=ZERO
20 CONTINUE
DO 500 I=NSTART,NC
II=II+1
DO 300 M=1,NM
INAO=IORB+(I-1)+(M-1)*NC
DO 140 K=1,NBAS
DMSUM=ZERO
SSUM=ZERO
KM1=K-1
DO 100 L=1,KM1
TLI=T(L,INAO)
DMSUM=DMSUM+TLI*S(L,K)
100 SSUM=SSUM+TLI*S(K,L)
TKI=T(K,INAO)
DMSUM=DMSUM+TKI*S(K,K)
SSUM=SSUM+TKI
KP1=K+1
DO 120 L=KP1,NBAS
TLI=T(L,INAO)
DMSUM=DMSUM+TLI*S(K,L)
120 SSUM=SSUM+TLI*S(L,K)
EVAL(K)=DMSUM
EVAL2(K)=SSUM
140 CONTINUE
JJ=0
DO 240 J=NSTART,I
JJ=JJ+1
JNAO=IORB+(J-1)+(M-1)*NC
DMSUM=ZERO
SSUM=ZERO
DO 200 K=1,NBAS
TKJ=T(K,JNAO)
DMSUM=DMSUM+EVAL(K)*TKJ
200 SSUM=SSUM+EVAL2(K)*TKJ
DMBLK(II,JJ)=DMBLK(II,JJ)+DMSUM
SBLK(II,JJ)=SBLK(II,JJ)+SSUM
240 CONTINUE
300 CONTINUE
DO 350 JJ=1,II
DMBLK(II,JJ)=DMBLK(II,JJ)/NM
DMBLK(JJ,II)=DMBLK(II,JJ)
SBLK(II,JJ)=SBLK(II,JJ)/NM
350 SBLK(JJ,II)=SBLK(II,JJ)
500 CONTINUE
CALL ATDIAG(NRYDC,DMBLK,SBLK,EVAL,EVECT)
CALL RANK(EVAL,NRYDC,NRYDC,LARC)
DO 600 J=1,NRYDC
JC=LARC(J)
DO 600 I=1,NRYDC
600 SBLK(I,J)=EVECT(I,JC)
DO 700 M=1,NM
JJ=0
DO 680 J=NSTART,NC
JJ=JJ+1
JNAO=IORB+(J-1)+(M-1)*NC
OCC(JNAO)=EVAL(JJ)
LIST(JJ)=JNAO
680 CONTINUE
USE LIMTRN TO UPDATE T:
CALL LIMTRN(T,LIST,SBLK,DMBLK,NDIM,NBAS,NRYDC,NRYDC,1)
700 CONTINUE
IF(IRPNAO.EQ.0) RETURN
UPDATE TPNAO, BUT DO THIS IN SUCH A WAY THAT THE INTRA-ATOMIC BLOCKS
OF THE OVERLAP MATRIX IN THE REVISED PNAO MATRIX REMAIN DIAGONAL
AND THAT THE PNAOS REMAIN NORMALIZED. IN ORDER TO ACCOMPLISH THIS,
WE MUST LOWDIN-ORTHOGONALIZE THE RYDBERG TRANSFORMATION IN "SBLK":
CALL SYMORT(EVECT,SBLK,DMBLK,NRYDC,NRYDC,EVAL)
DO 800 M=1,NM
JJ=0
DO 780 J=NSTART,NC
JJ=JJ+1
LIST(JJ)=IORB+(J-1)+(M-1)*NC
780 CONTINUE
CALL LIMTRN(TPNAO,LIST,SBLK,DMBLK,NDIM,NBAS,NRYDC,NRYDC,1)
800 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION WT(NDIM),LIST1(NBAS),LIST2(NBAS),LSTEMT(NBAS)
DATA ONE,WTTHR/1.0D0,1.0D-4/
DIVIDE THE RYDBERG ORBITALS INTO 2 GROUPS:
LIST1: RYDBERGS OF SIGNIFICANT OCCUPANCY ( .GT.WTTHR )
LIST2: RYDBERGS OF VERY LOW OCCUPANCY ( .LT.WTTHR )
WTTHR IS SET TO 0.0001
SET THE WEIGHTINGS OF THE RYDBERGS IN LIST2 TO ONE SO THAT THE WEIGHTED
ORTHOGONALIZATION THAT WILL LATER BE DONE AMONG THESE ORBITALS WILL
BE IN FACT A LOWDIN ORTHOG.
NSEL1=0
NSEL2=0
DO 100 I=1,NEMT
IRYD=LSTEMT(I)
IF(WT(IRYD).LT.WTTHR) GO TO 50
NSEL1=NSEL1+1
LIST1(NSEL1)=IRYD
GO TO 100
50 CONTINUE
NSEL2=NSEL2+1
LIST2(NSEL2)=IRYD
WT(IRYD)=ONE
100 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LDEG(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),TPNAO(NDIM,NDIM),
+ C(MXAOLM,MXAOLM),EVAL(NDIM),BLK(MXAOLM,MXAOLM),IRANK(NBAS)
REDIAGONALIZE THE SYMMETRY AVERAGED DM SUBBLOCKS FOR EACH ANGULAR
SYMMETRY ON EACH ATOM:
READ IN OLD T-PNAO INTO TPNAO SO THAT IT CAN BE UPDATED (IF IRPNAO.EQ.1):
IF(IRPNAO.EQ.1) CALL FEPNAO(TPNAO)
NF = 0
IORB = 0
NL = 1
10 IORB = IORB + NL
IF(IORB.GT.NBAS) GO TO 100
NL = 1
ILBL = NAOCTR(IORB)
IL = NAOL(IORB)/100
NM = IL*2 + 1
IMAX = NBAS - IORB
DO 30 IADD = 1,IMAX
JORB = IORB + IADD
JORBL = NAOL(JORB)/100
IF((NAOCTR(JORB).NE.ILBL).OR.(JORBL.NE.IL)) GO TO 40
30 NL = NL + 1
40 NC = NL/NM
IF(NC.EQ.1) GO TO 80
CALL REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,
* IRPNAO)
GO TO 10
80 DO 90 M = 1,NM
NF = NF + 1
90 CONTINUE
GO TO 10
100 CONTINUE
IF(IRPNAO.EQ.0) RETURN
SAVE NEW T-PNAO FROM TPNAO:
CALL SVPNAO(TPNAO)
RETURN
END
*****************************************************************************
SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,
* IRPNAO)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LDEG(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
DIMENSION DM(NDIM,NDIM),BLK(NC,NC),C(NC,NC),EVAL(NDIM),
+ T(NDIM,NDIM),TPNAO(NDIM,NDIM),IRANK(NBAS)
DATA ZERO/0.0D0/
FIND THE REDIAGONALIZATION TRANSFORMATION FOR THE DM SUBBLOCK FOR
THE ANGULAR MOMENTUM "IL" ON AN ATOM, PUT IN T2:
NM = IL*2 + 1
DO 30 J = 1,NC
DO 30 I = 1,J
SUM = ZERO
DO 10 M = 1,NM
INAO = IORB + I-1 + (M-1)*NC
JNAO = IORB + J-1 + (M-1)*NC
10 SUM = SUM + DM(INAO,JNAO)
AVE = SUM/NM
BLK(I,J) = AVE
30 BLK(J,I) = AVE
CALL JACOBI(NC,BLK,EVAL,C,NC,NC,1)
CALL RANK(EVAL,NC,NC,LARC)
DO 80 J = 1,NC
JC = LARC(J)
DO 80 I = 1,NC
80 BLK(I,J) = C(I,JC)
DO 110 M = 1,NM
DO 100 J = 1,NC
NF = NF + 1
100 IRANK(J) = NF
CALL LIMTRN(T,IRANK,BLK,C,NDIM,NBAS,NC,NC,1)
CALL LIMTRN(DM,IRANK,BLK,C,NDIM,NBAS,NC,NC,0)
IF(IRPNAO.EQ.1) CALL LIMTRN(TPNAO,IRANK,BLK,C,NDIM,NBAS,NC,NC,1)
110 CONTINUE
RETURN
END
****************************************************************************
ROUTINES CALLED BY THE NBO/NLMO DRIVERS:
SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
+ P,TA,HYB,VA,VB,TOPO)
SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
+ P,TA,HYB,VA,VB,TOPO)
SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
+ P,TA,HYB,VA,VB,TOPO,IFLG)
SUBROUTINE SRTNBO(T,BNDOCC)
SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR)
SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB)
SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN)
SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR)
SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB)
SUBROUTINE FNDMOL(IATOMS)
SUBROUTINE NBOCLA(BNDOCC,ACCTHR)
SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO)
SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR)
SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG)
SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR)
SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM)
SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,SIAB,NOCC,NAB)
SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX)
SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX)
SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC)
****************************************************************************
SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
* P,TA,HYB,VA,VB,TOPO)
****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
Construct orthogonal matrix T for transformation from AO's to
Natural Hybrid Bond Orbitals using input density matrix DM.
REQUIRED INPUT INCLUDES:
DM = DENSITY MATRIX IN ORTHONORMAL ATOMIC ORBITAL BASIS;
REAL(1,NDIM;1,NDIM)
NBAS = NO. OF ORBITALS = ACTUAL DIMENSION OF DM,S,T,NAOL,DMT
NATOMS = NO. OF ATOMS (NOT INCLUDING GHOSTS) IN THE MOLECULE
IATNO = LIST OF ATOMIC NUMBERS
NAOCTR = ORBITAL LABEL LIST. NAOCTR(I)=IAT IF NAO # I IS ON ATOM IAT
INTEGER(1,NDIM). NAOS OF GIVEN ATOM GROUPED TOGETHER.
IW3C = 1 IF PROGRAM IS TO SEARCH FOR 3-CENTER BONDS,
= 0 OTHERWISE
GUIDE = WIBERG ATOM-ATOM BOND INDEX MATRIX, USED AS GUIDE FOR NBO SEARCH
OUTPUT:
T = BOND ORBITAL TRANSFORMATION MATRIX (NDIM,NDIM).
ROWS ARE LABELLED BY NAOS, COLUMNS BY NBOS.
LABEL = LIST OF BOND ORBITAL LABELS
IBXM = PERMUTATION LIST OF BOND ORBITAL LABELS (VERY IMPORTANT!)
LOGICAL DETAIL,NOBOND,FIRST
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
INTEGER UL
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM),
+ N3CTR,I3CTR(10,3)
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),V(NDIM),BORB(MXBO),
* POL(NDIM,3),BNDOCC(NDIM),NAME(3),HYBEXP(3),
* Q(MXAO,NDIM),BLK(MXBO,MXBO),EVAL(MXBO),C(MXBO,MXBO),
* P(MXAO,MXAO),TA(MXAO,MXAO),HYB(MXAO),VA(MXAO),VB(MXAO),
* GUIDE(NATOMS,NATOMS),TOPO(NATOMS*NATOMS)
DATA GTHRSH/1.5D-1/
DATA ISTAR,IBLNK/'*',' '/
DATA NAME/'LP','BD','3C'/
DATA LRY,LCR/'RY','CR'/
DATA ZERO,ZEROP,TENTH,ONE,TWO,FOUR
* /0.D0,1.D-6,0.1D0,1.0D0,2.0D0,4.0D0/
DATA TWOP/2.0001D0/
DATA PT8,PT99/0.8D0,0.99D0/
PRJINC, the amount to increase PRJTHR by if problems with linear
dependency between the hybrids arise.
DATA PRJINC/0.05D0/
NOPVAL(I) = NORBS(I) - INO(I)
DETAIL = .FALSE.
IF(IWDETL.NE.0) DETAIL = .TRUE.
NOBOND = .FALSE.
IF(JPRINT(10).NE.0) NOBOND = .TRUE.
Initial iteration loop: If no satisfactory Lewis structure (all
antibond occupancies < 0.1) for THRESH = 1.90, THRESH is decremented
up to 4 times by 0.1 in search of a better structure. If the DM is
not spinless, THRESH is set to 0.90 and is decremented as above.
PRJTHR = ABS(PRJSET)
THRESH = ABS(THRSET)
IF(ISPIN.NE.0) THRESH = THRESH - ONE
IF(NOBOND) THRESH = ONE
IF(NOBOND.AND.(ISPIN.NE.0)) THRESH = ONE/TWO
IF(ISPIN.NE.0) GTHRSH = GTHRSH/FOUR
Determine the atom ordering for the initial search for bonds:
IF(NATOMS.EQ.1) THEN
IORDER(1) = 1
GOTO 45
END IF
Find the two atoms which have the largest bond index:
GMAX = ZERO
DO 10 J = 2,NATOMS
DO 5 I = 1,J-1
IF(GUIDE(I,J).GT.GMAX) THEN
GMAX = GUIDE(I,J)
IAT = I
END IF
5 CONTINUE
10 CONTINUE
IORDER(1) = IAT
Add atoms to IORDER according to these connectivities:
ICNT = 1
INXT = ICNT
JCNT = ICNT
15 IPTR = INXT
I1ST = 1
DO 20 I = 1,NATOMS
TOPO(I) = GUIDE(I,IORDER(IPTR))
20 CONTINUE
CALL RANK(TOPO,NATOMS,NATOMS,JORDER)
JPTR = 1
25 IF(TOPO(JPTR).GT.PT8) THEN
IFLG = 1
DO 30 I = 1,ICNT
IF(IORDER(I).EQ.JORDER(JPTR)) IFLG = 0
30 CONTINUE
IF(IFLG.EQ.1) THEN
ICNT = ICNT + 1
IORDER(ICNT) = JORDER(JPTR)
IF(I1ST.EQ.1) THEN
I1ST = 0
INXT = ICNT
END IF
END IF
ELSE
GOTO 35
END IF
JPTR = JPTR + 1
GOTO 25
35 CONTINUE
IF(I1ST.EQ.1) THEN
JCNT = JCNT + 1
INXT = JCNT
IF(INXT.GT.NATOMS) GOTO 45
IF(INXT.GT.ICNT) THEN
KPTR = 0
40 KPTR = KPTR + 1
KFLG = 1
DO 41 I = 1,ICNT
IF(IORDER(I).EQ.KPTR) KFLG = 0
41 CONTINUE
IF(KFLG.EQ.0) GOTO 40
ICNT = ICNT + 1
IORDER(ICNT) = KPTR
END IF
END IF
GOTO 15
45 CONTINUE
ITER = 0
IALARM = 0
50 IF(IALARM.EQ.0) ITER = ITER + 1
Store density matrix in upper triangle of T:
DO 60 J = 1,NBAS
DO 60 I = 1,J
60 T(I,J) = DM(I,J)
Zero arrays Q, POL, IATHY, INO, and LABEL:
DO 100 I = 1,NBAS
DO 70 K = 1,2
70 LABEL(I,K) = IBLNK
DO 80 K = 3,6
80 LABEL(I,K) = 0
DO 90 K = 1,3
POL(I,K) = ZERO
90 IATHY(I,K) = 0
DO 100 K = 1,MXAO
100 Q(K,I) = ZERO
DO 110 I = 1,NATOMS
110 INO(I) = 0
Remove core orbitals from the density matrix:
IBD = 0
CALL CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
Main NHO loops
--------------
Doubly occupied (IOCC=1) or singly occupied (IOCC=2) NHO's
If ISPIN.NE.0, search is only for singly occupied nbos (IOCC=1):
OCCMX = THRESH
Main NHO loops over singles, doubles, and triples of atoms:
NA1 = NATOMS + 1
DO 310 IA1 = 1,NA1
IA = IA1 - 1
IF((IA.GT.0).AND.(NOPVAL(IORDER(IA)).LE.0)) GO TO 310
DO 300 IB1 = 1,NA1
IB = IB1 - 1
IF((IB.GT.0).AND.(NOPVAL(IORDER(IB)).LE.0)) GO TO 300
DO 290 IC1 = 2,NA1
IC = IC1 - 1
IF((IC.GT.0).AND.(NOPVAL(IORDER(IC)).LE.0)) GO TO 290
IF(IA.NE.0) GO TO 130
IF(IB.NE.0) GO TO 120
Lone pairs:
NCTR = 1
IAT1 = IORDER(IC)
IAT2 = 0
IAT3 = 0
GO TO 140
Bond pairs:
120 CONTINUE
IF(NOBOND) GO TO 290
NCTR = 2
IAT1 = IORDER(IB)
IAT2 = IORDER(IC)
IAT3 = 0
IF(IAT1.GE.IAT2) GO TO 290
IF(GUIDE(IAT1,IAT2).LT.GTHRSH) GO TO 290
GO TO 140
3-center bonds:
130 CONTINUE
IF(IW3C.NE.1) GO TO 320
NCTR = 3
IAT1 = IORDER(IA)
IAT2 = IORDER(IB)
IAT3 = IORDER(IC)
IF(IAT1.GE.IAT2) GO TO 300
IF(IAT2.GE.IAT3) GO TO 290
IF(GUIDE(IAT1,IAT2).GT.GTHRSH) GO TO 140
IF(GUIDE(IAT1,IAT3).GT.GTHRSH) GO TO 140
IF(GUIDE(IAT2,IAT3).GT.GTHRSH) GO TO 140
GO TO 290
140 CONTINUE
Deplete DM of one(two) center orbitals if search for two(three)
center orbitals is beginning:
IF(IWPRJ(NCTR).NE.0)
* CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD)
Load proper atomic blocks of DM into BLK:
CALL LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
Diagonalize BLK:
CALL JACOBI(NB,BLK,EVAL,C,MXBO,MXBO,1)
Rank eigenvectors by occupancy eigenvalue:
CALL RANK(EVAL,NB,MXBO,LARC)
IF(DETAIL) WRITE(LFNPR,1400) IAT1,IAT2,IAT3
IF(DETAIL) WRITE(LFNPR,1403) THRESH
IF(DETAIL) WRITE(LFNPR,1405) (EVAL(IRNK),IRNK=1,NB)
IACCEP = 0
DO 250 IRNK = 1,NB
IR = LARC(IRNK)
OCC = EVAL(IRNK)
DO 200 I = 1,NB
200 BORB(I) = C(I,IR)
IF(DETAIL) WRITE(LFNPR,1410) IRNK,OCC
IF(DETAIL) WRITE(LFNPR,1420) (BORB(I),I=1,NB)
Throw out orbital if occupancy is less than the threshhold "OCCMX":
IF(OCC.LT.OCCMX) GO TO 280
Check to see that bond orbital "BORB" doesn't contain previously used
hybrids:
IF(NCTR.EQ.1) GO TO 240
CALL PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,TA,HYB,VA,VB,HYBEXP)
IF(.NOT.DETAIL) GO TO 220
DO 210 IHYB = 1,NCTR
210 WRITE(LFNPR,1500) IHYB,HYBEXP(IHYB)
220 CONTINUE
DO 230 IHYB = 1,NCTR
230 IF(HYBEXP(IHYB).LT.PRJTHR) GO TO 250
240 CONTINUE
IBD = IBD + 1
IACCEP = IACCEP + 1
Decompose "BORB" into its constituent atomic hybrids and store in Q:
CALL STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
Construct bond orbital labels:
LABEL(IBD,1) = NAME(NCTR)
LABEL(IBD,2) = IBLNK
LABEL(IBD,3) = IACCEP
LABEL(IBD,4) = IAT1
LABEL(IBD,5) = IAT2
LABEL(IBD,6) = IAT3
BNDOCC(IBD) = OCC
IF(DETAIL) WRITE(LFNPR,1600) IBD,(LABEL(IBD,I),I=1,3)
250 CONTINUE
280 CONTINUE
290 CONTINUE
300 CONTINUE
310 CONTINUE
320 CONTINUE
Symmetric orthogonalization of principal hybrids:
CALL ORTHYB(Q,BLK,TA,EVAL,C,IALARM,0)
IALARM sounds the alarm that there is linear dependency between some
of the hybrids. The remedy is to increase prjthr and repeat the NBO
search. IALARM is equal to the number of the violating atom.
IF(IALARM.NE.0) THEN
OLDPRJ = PRJTHR
PRJTHR = OLDPRJ + PRJINC
IF(JPRINT(5).NE.0) WRITE(LFNPR,1800) OLDPRJ,PRJTHR
IF(PRJTHR.GE.PT99) THEN
WRITE(LFNPR,1810) IALARM
JPRINT(1) = -1
RETURN
END IF
GOTO 700
END IF
Augment open-valence atoms with non-arbitrary hybrids orthogonal to
those found previously:
DO 580 IA = 1,NATOMS
IF(NOPVAL(IA).LE.0) GO TO 580
IULA: upper limit of NAOs on atom. Find NMB, the number of natural
minimal basis functions on the atom:
LLA = LL(IA)
IULA = UL(IA)
NMB = 0
DO 470 I = LLA,IULA
IF(LSTOCC(I).EQ.1) NMB = NMB + 1
470 CONTINUE
Find the number of bond, core, and lone pair hybrids on the atom, IOCC:
Also find IOCCLP, number of lone pair orbitals already found on IA, for
use in labelling the extra lone pairs below:
IOCC = 0
IOCCLP = 0
DO 480 IB = 1,IBD
IF((LABEL(IB,4).NE.IA).AND.(LABEL(IB,5).NE.IA).AND.
* (LABEL(IB,6).NE.IA)) GO TO 480
IOCC = IOCC + 1
IF(LABEL(IB,1).EQ.NAME(1)) IOCCLP = IOCCLP + 1
480 CONTINUE
NEXLP: number of extra (low occupancy) LP orbitals on atom IAT. (This
is the number of low occupancy orbitals with valence shell character)
Set NEXLP to zero if (NMB-IOCC) is less than zero in order that the
orbitals are not miscounted!!
NEXLP = NMB - IOCC
IF(NEXLP.LT.0) NEXLP = 0
NOCC = INO(IA)
CALL FRMPRJ(P,IA,Q,NOCC,TA,VA,VB)
NORB = NORBS(IA)
NAUGM = NORB - NOCC
CALL AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
Stash and label extra lone pairs that AUGMNT put in BLK: (These ar
taken to be the highest occupied orbitals, which AUGMNT places first)
DO 510 IAUGM = 1,NEXLP
DO 500 J = 1,NORB
500 BORB(J) = BLK(J,IAUGM)
IBD = IBD + 1
CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB)
LABEL(IBD,1) = NAME(1)
LABEL(IBD,2) = IBLNK
LABEL(IBD,3) = IAUGM + IOCCLP
LABEL(IBD,4) = IA
LABEL(IBD,5) = 0
LABEL(IBD,6) = 0
510 CONTINUE
Stash and label the Rydberg orbitals that AUGMNT put in BLK:
IRYD = 0
NSTART = NEXLP + 1
DO 540 IAUGM = NSTART,NAUGM
DO 530 J = 1,NORB
530 BORB(J) = BLK(J,IAUGM)
IBD = IBD + 1
IRYD = IRYD + 1
CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB)
LABEL(IBD,1) = LRY
LABEL(IBD,2) = ISTAR
LABEL(IBD,3) = IRYD
LABEL(IBD,4) = IA
LABEL(IBD,5) = 0
LABEL(IBD,6) = 0
540 CONTINUE
580 CONTINUE
Include antibond labels:
IBO = IBD
DO 660 I = 1,IBO
Exit loop if LABEL(I,1) is 'LP', 'RY', or 'CR':
IF(LABEL(I,1).EQ.NAME(1)) GO TO 660
IF(LABEL(I,1).EQ.LRY) GO TO 660
IF(LABEL(I,1).EQ.LCR) GO TO 660
NAB = 1
IF(LABEL(I,1).EQ.NAME(3)) NAB = 2
DO 650 IAB = 1,NAB
IBD = IBD + 1
DO 640 J = 1,6
640 LABEL(IBD,J) = LABEL(I,J)
LABEL(IBD,2) = ISTAR
650 CONTINUE
660 CONTINUE
Replace density matrix DM from T:
700 CONTINUE
DO 740 J=1,NBAS
DO 740 I=1,J
DM(I,J)=T(I,J)
DM(J,I)=DM(I,J)
T(J,I)=ZERO
740 T(I,J)=ZERO
Remember the alarm!
IF(IALARM.NE.0) GO TO 50
Miscounted bond orbitals...exit for open shell:
IF(IBD.NE.NBAS) THEN
WRITE(LFNPR,1200) THRESH,IBD,NBAS
WRITE(LFNPR,1210) (I,(LABEL(I,J),J=1,6),I=1,IBD)
STOP
END IF
Find new polarization parameters for orthonormal hybrids:
CALL REPOL(DM,Q,POL,BLK,EVAL,C,IBD)
Form final T-NAB (NAO to NBO transformation) from orthonormal
hybrids:
CALL FORMT(T,Q,POL)
Find occupancies, find total number of electrons and occupied orbitals:
TOTELE = ZERO
DO 800 I = 1,NBAS
OCCI = ZERO
DO 790 J = 1,NBAS
DO 790 K = 1,NBAS
790 OCCI = OCCI + T(J,I) * DM(J,K) * T(K,I)
IF(ABS(OCCI).LT.ZEROP) OCCI = ZERO
IF(OCCI.GT.TWOP) GO TO 960
ZEROPM = -ZEROP
IF(OCCI.LT.ZEROPM) GO TO 960
BNDOCC(I) = OCCI
V(I) = OCCI
TOTELE = TOTELE + BNDOCC(I)
800 CONTINUE
NEL = TOTELE + TENTH
IF(ABS(TOTELE-NEL).GT.5E-4) GO TO 970
TOTELE = NEL
NOCC = NEL
IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2)
Make sure all but the NOCC highest occupied NBOs are starred:
CALL RANK(V,NBAS,NDIM,LARC)
DO 804 I = 1,NOCC
IR = LARC(I)
LABEL(IBXM(IR),2) = IBLNK
804 CONTINUE
DO 805 I = NOCC+1,NBAS
IR = LARC(I)
LABEL(IBXM(IR),2) = ISTAR
805 CONTINUE
Determine whether this is a good resonance structure:
CALL CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
IF(ICONT.EQ.0) THEN
JPRINT(1) = -1
RETURN
END IF
IF(ICONT.EQ.-1) GO TO 50
IF(ICONT.EQ.1) GO TO 50
Before final return, write out info about core orbitals which
were isolated in subroutine CORE:
CRTHRS = CRTSET
IF(ISPIN.NE.0) CRTHRS = CRTHRS - ONE
FIRST = .TRUE.
DO 952 IAT = 1,NATOMS
ILOW = 0
DO 951 I = 1,NBAS
IF(LABEL(IBXM(I),1).EQ.LCR.AND.LABEL(IBXM(I),4).EQ.IAT
+ .AND.BNDOCC(I).LT.CRTHRS) ILOW = ILOW + 1
951 CONTINUE
IF(ILOW.NE.0) THEN
IF(FIRST) THEN
FIRST = .FALSE.
NAM = NAMEAT(IATNO(IAT))
IF(ILOW.NE.1) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,3010) ILOW,CRTHRS,NAM,IAT
ELSE
IF(JPRINT(5).EQ.1) WRITE(LFNPR,3011) ILOW,CRTHRS,NAM,IAT
END IF
ELSE
NAM = NAMEAT(IATNO(IAT))
IF(ILOW.NE.1) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,3020) ILOW,CRTHRS,NAM,IAT
ELSE
IF(JPRINT(5).EQ.1) WRITE(LFNPR,3021) ILOW,CRTHRS,NAM,IAT
END IF
END IF
END IF
952 CONTINUE
RETURN
Problems with a bond orbital occupancy:
960 WRITE(LFNPR,1300) OCCI
JPRINT(1) = -1
RETURN
Total number of electrons is not an integer:
970 WRITE(LFNPR,1310) TOTELE
JPRINT(1) = -1
RETURN
1200 FORMAT(/,1X,'For an occupancy threshold of ',F4.2,' the search',
+ ' for NBOs found',/,1X,I3,' orbitals orbitals rather than ',I4)
1210 FORMAT(3X,'Label ',I3,':',A3,A1,I2,3I3)
1300 FORMAT(/,1X,'A bond orbital with an occupancy of ',F8.5,
+ ' electrons was found!',/,1X,'Please check you input data.')
1310 FORMAT(/,1X,'The total number of electron is not an integer:',
+ F10.5,/,1X,'Please check your input data.')
1400 FORMAT(/,1X,'Search of DM block between the following atoms:',
+ 3I4)
1403 FORMAT(6X,'Select orbitals with eigenvalue > ',F9.6)
1405 FORMAT(6X,8F9.6)
1410 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':')
1420 FORMAT(11X,8F7.4)
1500 FORMAT(11X,'Hybrid ',I1,' in eigenvector has a projection ',
+ 'expectation of ',F6.3)
1600 FORMAT(11X,'*** NBO accepted: Number',I3,'. Label:',A2,A1,
+ '(',I2,')')
1800 FORMAT(/4X,'PRJTHR will be raised from ',F6.3,' to',F6.3,
+ ' and the NBO search repeated.',/)
1810 FORMAT(//,1X,'Linearly independent hybrids for atom',I3,
+' cannot be found.',/,1X,'The NBO program must abort.')
3010 FORMAT(/,1X,
+'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals ',
+'found on ',A2,I2)
3011 FORMAT(/,1X,
+'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbital ',
+'found on ',A2,I2)
3020 FORMAT(1X,
+' ',I3,' low occupancy (<',F6.4,'e) core orbitals ',
+'found on ',A2,I2)
3021 FORMAT(1X,
+' ',I3,' low occupancy (<',F6.4,'e) core orbital ',
+'found on ',A2,I2)
END
*****************************************************************************
SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
* P,TA,HYB,VA,VB,TOPO)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL END,ERROR,EQUAL
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM),
+ N3CTR,I3CTR(10,3)
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),GUIDE(NATOMS,NATOMS),
* BNDOCC(NDIM),POL(NDIM,3),Q(MXAO,NDIM),V(NDIM),BLK(MXBO,MXBO),
* C(MXBO,MXBO),EVAL(MXBO),BORB(MXBO),P(MXAO,MXAO),TA(MXAO,MXAO),
* HYB(MXAO),VA(MXAO),VB(MXAO),TOPO(NATOMS,NATOMS)
DIMENSION KEYWD(6),KLONE(4),KBOND(4),K3CBON(6),KALPHA(5),
* KBETA(4),IVAL(4),KALT(4)
DATA KLONE/1HL,1HO,1HN,1HE/,
* KBOND/1HB,1HO,1HN,1HD/,
* K3CBON/1H3,1HC,1HB,1HO,1HN,1HD/,
* KALPHA/1HA,1HL,1HP,1HH,1HA/,
* KBETA/1HB,1HE,1HT,1HA/,
* KS/1HS/,KD/1HD/,KT/1HT/,KQ/1HQ/,
* KALT/1H$,1HE,1HN,1HD/
Search for `ALPHA' or `BETA' character string in case of alpha or
beta spin density matrices:
IF(ISPIN.EQ.2) THEN
20 LENG = 5
CALL HFLD(KEYWD,LENG,END)
IF(END.AND.LENG.EQ.0) GOTO 810
IF(.NOT.EQUAL(KEYWD,KALPHA,5)) GOTO 20
CONTINUE
ELSE IF(ISPIN.EQ.-2) THEN
30 LENG = 5
CALL HFLD(KEYWD,LENG,END)
IF(END.AND.LENG.EQ.0) GOTO 820
IF(.NOT.EQUAL(KEYWD,KBETA,4)) GOTO 30
CONTINUE
END IF
Fill diagonal elements of the TOPO matrix with nominal numbers of
lone pairs to be found on each atom:
DO 50 IAT = 1,NATOMS
NLP = 0
CALL VALTBL(IAT,IVAL)
DO 40 L = 0,3
NLP = NLP + IVAL(L+1)*(2*L + 1)
40 CONTINUE
NTOPO(IAT,IAT) = 100 + NLP
50 CONTINUE
Read in chosen lone pairs, bonds, and 3-center bonds:
NCTR = 0
N3CTR = 0
60 CONTINUE
LENG = 6
CALL HFLD(KEYWD,LENG,END)
IF(END.OR.EQUAL(KEYWD,KALT,4)) GOTO 300
NCTRO = NCTR
NCTR = 0
IF(EQUAL(KEYWD,KLONE,4)) NCTR = 1
IF(EQUAL(KEYWD,KBOND,4)) NCTR = 2
IF(EQUAL(KEYWD,K3CBON,6)) NCTR = 3
IF(NCTR.EQ.0) GO TO 1010
IF(NCTR.LT.NCTRO) GO TO 1020
GOTO (100,150,200), NCTR
Read in lone pairs:
100 CONTINUE
CALL IFLD(IAT,ERROR)
IF(ERROR) THEN
LENG = 6
CALL HFLD(KEYWD,LENG,END)
GO TO 60
END IF
CALL IFLD(NUM,ERROR)
IF(ERROR) GOTO 830
NTOPO(IAT,IAT) = NUM
GOTO 100
Read in bonds:
150 CONTINUE
LENG = 1
CALL HFLD(KEYWD,LENG,END)
IF(END) GOTO 60
NUM = 0
IF(EQUAL(KEYWD,KS,1)) NUM = 1
IF(EQUAL(KEYWD,KD,1)) NUM = 2
IF(EQUAL(KEYWD,KT,1)) NUM = 3
IF(EQUAL(KEYWD,KQ,1)) NUM = 4
IF(NUM.EQ.0) GOTO 840
CALL IFLD(IAT1,ERROR)
IF(ERROR) GOTO 840
CALL IFLD(IAT2,ERROR)
IF(ERROR) GOTO 840
IAT = MAX0(IAT1,IAT2)
JAT = MIN0(IAT1,IAT2)
NTOPO(IAT,JAT) = NUM
NTOPO(JAT,IAT) = NUM
GOTO 150
Read in 3-center bonds:
200 CONTINUE
IF(IW3C.NE.1) IW3C = 1
LENG = 1
CALL HFLD(KEYWD,LENG,END)
IF(END) GOTO 60
NUM = 0
IF(EQUAL(KEYWD,KS,1)) NUM = 1
IF(EQUAL(KEYWD,KD,1)) NUM = 2
IF(EQUAL(KEYWD,KT,1)) NUM = 3
IF(EQUAL(KEYWD,KQ,1)) NUM = 4
IF(NUM.EQ.0) GOTO 860
CALL IFLD(IAT1,ERROR)
IF(ERROR) GOTO 860
CALL IFLD(IAT2,ERROR)
IF(ERROR) GOTO 860
CALL IFLD(IAT3,ERROR)
IF(ERROR) GOTO 860
N3CTR = N3CTR + 1
IF(N3CTR.GT.10) GOTO 870
I3CTR(N3CTR,1) = IAT1
I3CTR(N3CTR,2) = IAT2
I3CTR(N3CTR,3) = IAT3
GOTO 200
Modify nominal sets of lone pairs by number of bonds and 3-center
bonds.
300 CONTINUE
DO 330 IAT = 1,NATOMS
NLP = NTOPO(IAT,IAT)
IF(NLP.LT.100) GOTO 330
NLP = MOD(NLP,100)
NBD = 0
DO 310 JAT = 1,NATOMS
IF(IAT.NE.JAT.AND.NTOPO(JAT,IAT).NE.0) THEN
NBD = NBD + NTOPO(JAT,IAT)
END IF
310 CONTINUE
DO 320 KAT = 1,3
DO 315 JAT = 1,N3CTR
IF(I3CTR(JAT,KAT).EQ.IAT) NBD = NBD + 1
315 CONTINUE
320 CONTINUE
NLP = NLP - NBD
IF(NLP.LT.0) NLP = 0
NTOPO(IAT,IAT) = NLP
330 CONTINUE
Use CHOOSE to find bond orbitals using NTOPO and I3CTR:
IFLG = 0
CALL CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,P,TA,HYB,
+ VA,VB,TOPO,IFLG)
RETURN
810 WRITE(LFNPR,1180)
JPRINT(1) = -1
RETURN
820 WRITE(LFNPR,1190)
JPRINT(1) = -1
RETURN
830 WRITE(LFNPR,1130)
JPRINT(1) = -1
RETURN
840 WRITE(LFNPR,1140)
JPRINT(1) = -1
RETURN
860 WRITE(LFNPR,1160)
JPRINT(1) = -1
RETURN
870 WRITE(LFNPR,1170)
JPRINT(1) = -1
RETURN
1010 WRITE(LFNPR,1110) (KEYWD(I),I=1,6)
JPRINT(1) = -1
RETURN
1020 WRITE(LFNPR,1120)
JPRINT(1) = -1
RETURN
1110 FORMAT(/1X,'Error in input of bond orbitals:',/,1X,
* 'Keyword for orbital type is not LONE, BOND, or 3CBOND (read `',
* 6A1,''')')
1120 FORMAT(/1X,'Error in input of bond orbitals:',/,1X,
* 'Orbital types should be in the order: LONE, BOND, 3CBOND')
1130 FORMAT(/1X,'Error in input of bond orbitals:',/,1X,
* 'Unrecognizable characters in input of lone orbitals')
1140 FORMAT(/1X,'Error in input of bond orbitals:',/,1X,
* 'Unrecognizable characters in input of two center orbitals')
1160 FORMAT(/1X,'Error in input of bond orbitals:',/,1X,
* 'Unrecognizable characters in input of three center orbitals')
1170 FORMAT(/1X,'Too many three center bonds:',
* ' Increase parameter MAX3C')
1180 FORMAT(/1X,'End of file encountered before the word ALPHA was ',
* 'found')
1190 FORMAT(/1X,'End of file encountered before the word BETA was ',
* 'found')
END
*****************************************************************************
SUBROUTINES CALLED BY NATHYB AND CHSDRV FOR FORMING NBOS
*****************************************************************************
SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
* P,TA,HYB,VA,VB,TOPO,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
Construct orthogonal matrix T for transformation from AO's to
Natural Hybrid Bond Orbitals using input density matrix DM
with the chosen bonding pattern read from LFNIN
LOGICAL DETAIL,FIRST,PRINT,LEFT
INTEGER UL
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM),
+ N3CTR,I3CTR(10,3)
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),GUIDE(NATOMS,NATOMS),
* BNDOCC(NDIM),POL(NDIM,3),Q(MXAO,NDIM),V(NDIM),BLK(MXBO,MXBO),
* C(MXBO,MXBO),EVAL(MXBO),BORB(MXBO),P(MXAO,MXAO),TA(MXAO,MXAO),
* HYB(MXAO),VA(MXAO),VB(MXAO),TOPO(NATOMS,NATOMS)
DIMENSION NAME(3),HYBEXP(3),KTOPO(MAXATM,MAXATM),KFLG(10)
DIMENSION SCR(MAXATM*(MAXATM-1)/2),IPT(MAXATM*(MAXATM-1)/2)
DATA ISTAR,IBLNK,NAME,LRY,LCR/'*',' ','LP','BD','3C','RY','CR'/
DATA ZERO,ZEROP,TENTH,PT99,ONE,TWO,TWOP
+ /0.0D0,1.0D-6,0.1D0,0.99D0,1.0D0,2.0D0,2.0001D0/
IFLG is a print flag on entering CHOOSE. If set to 0(1), CHOOSE
will(not) print some output to LFNPR. On exit, if IFLG is set to
-1, there was an error in finding the requested structure:
PRJINC, the amount to increase PRJTHR by if problems with linear
dependency between the hybrids arise.
DATA PRJINC/0.05D0/
NOPVAL(I) = NORBS(I) - INO(I)
PRINT = .FALSE.
IF(IFLG.EQ.0) PRINT = .TRUE.
IF(JPRINT(5).EQ.0) PRINT = .FALSE.
DETAIL = .FALSE.
IF(IWDETL.NE.0) DETAIL = .TRUE.
PRJTHR = ABS(PRJSET)
ITER = 0
Initialize KTOPO and KFLG arrays: (KFLG is set to 1 if the 3-center
bond has not been fund yet.)
DO 10 I = 1,NATOMS
DO 5 J = 1,I
KTOPO(I,J) = NTOPO(I,J)
KTOPO(J,I) = NTOPO(J,I)
5 CONTINUE
10 CONTINUE
DO 15 I = 1,N3CTR
KFLG(I) = 1
15 CONTINUE
Determine the atom ordering for the search for bond orbitals:
IF(NATOMS.EQ.1) THEN
IORDER(1) = 1
ELSE
II = 0
DO 20 JAT = 2,NATOMS
DO 19 IAT = 1,JAT-1
II = II + 1
SCR(II) = KTOPO(IAT,JAT) - GUIDE(IAT,JAT)
19 CONTINUE
20 CONTINUE
NN = NATOMS * (NATOMS - 1) / 2
CALL RANK(SCR,NN,NN,IPT)
Begin search for bond orbitals where the formal bond order is much
greater than the corresponding Wiberg bond index:
IPOS = 0
JPOS = 0
21 CONTINUE
JPOS = JPOS + 1
IF(JPOS.GT.NN) STOP 'Problems with atom permutation list'
IAT = IPT(JPOS)
JAT = 2
22 CONTINUE
IF(JAT.GT.IAT) GOTO 23
IAT = IAT - JAT + 1
JAT = JAT + 1
GOTO 22
23 CONTINUE
Add IAT and JAT to the atom permutation list IORDER:
MFLG = 0
DO 24 I = 1,IPOS
IF(IORDER(I).EQ.IAT) MFLG = 1
24 CONTINUE
IF(MFLG.EQ.0) THEN
IPOS = IPOS + 1
IORDER(IPOS) = IAT
END IF
MFLG = 0
DO 25 I = 1,IPOS
IF(IORDER(I).EQ.JAT) MFLG = 1
25 CONTINUE
IF(MFLG.EQ.0) THEN
IPOS = IPOS + 1
IORDER(IPOS) = JAT
END IF
IF(IPOS.LT.NATOMS) GOTO 21
END IF
Return to here if it should prove necessary to raise PRJTHR:
35 CONTINUE
ITER = ITER + 1
OCCTHR = ABS(THRSET)
IF(ISPIN.NE.0) OCCTHR = OCCTHR - ONE
OCCTHR = OCCTHR + TENTH
Store density matrix in upper triangle of T:
DO 50 J = 1,NBAS
DO 40 I = 1,J
T(I,J) = DM(I,J)
40 CONTINUE
50 CONTINUE
Zero arrays Q,POL,IATHY,INO,LABEL:
DO 100 I = 1,NBAS
DO 60 K = 1,2
LABEL(I,K) = IBLNK
60 CONTINUE
DO 70 K = 3,6
LABEL(I,K) = 0
70 CONTINUE
DO 80 K = 1,3
POL(I,K) = ZERO
IATHY(I,K) = 0
80 CONTINUE
DO 90 K = 1,MXAO
Q(K,I) = ZERO
90 CONTINUE
100 CONTINUE
DO 110 I = 1,NATOMS
INO(I) = 0
110 CONTINUE
Remove core orbitals from the density matrix:
IBD = 0
CALL CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
Return here if there are still more lone pairs or bonds to be found.
Lower the occupancy threshold for acceptance by a tenth:
115 CONTINUE
OCCTHR = OCCTHR - TENTH
LEFT = .FALSE.
******** START DIRECTED NBO SEARCH *********
Loop over numbers of centers, removing lone pairs and 2- and 3-center
bonds from the density matrix according to KTOPO and I3CTR:
NCTR = 0
120 NCTR = NCTR + 1
Deplete DM of one(two) center orbitals if search for two(three)
center orbitals is beginning:
IF(NCTR.NE.1) CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD)
ICNTR = 0
Return here for 3-c bonds and lone pairs:
130 ICNTR = ICNTR + 1
IF(NCTR.EQ.1) THEN
IF(ICNTR.GT.NATOMS) GOTO 120
NUM = KTOPO(IORDER(ICNTR),IORDER(ICNTR))
IF(NUM.LE.0) GOTO 130
IAT1 = IORDER(ICNTR)
IAT2 = 0
IAT3 = 0
GOTO 200
ELSE IF(NCTR.EQ.2) THEN
IF(ICNTR.GT.NATOMS) GOTO 120
JCNTR = ICNTR
Return here for 2-c bonds:
150 JCNTR = JCNTR + 1
IF(JCNTR.GT.NATOMS) GOTO 130
NUM = KTOPO(IORDER(JCNTR),IORDER(ICNTR))
IF(NUM.EQ.0) GOTO 150
IAT1 = MIN(IORDER(ICNTR),IORDER(JCNTR))
IAT2 = MAX(IORDER(ICNTR),IORDER(JCNTR))
IAT3 = 0
GOTO 200
ELSE IF(NCTR.EQ.3) THEN
IF(ICNTR.GT.N3CTR) GOTO 120
IF(KFLG(ICNTR).EQ.0) GOTO 130
NUM = 1
IAT1 = MIN(I3CTR(ICNTR,1),I3CTR(ICNTR,2),I3CTR(ICNTR,3))
IAT3 = MAX(I3CTR(ICNTR,1),I3CTR(ICNTR,2),I3CTR(ICNTR,3))
IAT2 = I3CTR(ICNTR,1)
IF(IAT2.EQ.IAT1.OR.IAT2.EQ.IAT3) IAT2 = I3CTR(ICNTR,2)
IF(IAT2.EQ.IAT1.OR.IAT2.EQ.IAT3) IAT2 = I3CTR(ICNTR,3)
GOTO 200
ELSE
GOTO 300
END IF
Load proper atomic blocks of DM into BLK, and diagonalize BLK:
200 CONTINUE
CALL LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
CALL JACOBI(NB,BLK,EVAL,C,MXBO,MXBO,1)
Rank eigenvectors by occupancy eigenvalue:
CALL RANK(EVAL,NB,MXBO,LARC)
IF(DETAIL) WRITE(LFNPR,1400) IAT1,IAT2,IAT3
IF(DETAIL) WRITE(LFNPR,1402) NUM,OCCTHR
IF(DETAIL) WRITE(LFNPR,1405) (EVAL(IRNK),IRNK=1,NB)
Loop over eigenvalues selecting the NUM highest occupied:
IACCEP = 0
DO 250 IRNK = 1,NB
IR = LARC(IRNK)
OCC = EVAL(IRNK)
DO 210 I = 1,NB
210 BORB(I) = C(I,IR)
IF(DETAIL) WRITE(LFNPR,1410) IRNK,OCC
IF(DETAIL) WRITE(LFNPR,1420) (BORB(I),I=1,NB)
If this is a low occupancy orbital, skip the rest of these and can come
back to them later:
IF(OCC.LT.OCCTHR) THEN
IF(NCTR.EQ.1) THEN
KTOPO(IAT1,IAT1) = NUM - IACCEP
IF(DETAIL) WRITE(LFNPR,1610) KTOPO(IAT1,IAT1)
ELSE IF(NCTR.EQ.2) THEN
KTOPO(IAT1,IAT2) = NUM - IACCEP
KTOPO(IAT2,IAT1) = KTOPO(IAT1,IAT2)
IF(DETAIL) WRITE(LFNPR,1610) KTOPO(IAT1,IAT2)
ELSE
IONE = 1
IF(DETAIL) WRITE(LFNPR,1610) IONE
END IF
IF(LEFT) THEN
IF(OCCMAX.LT.OCC) OCCMAX = OCC
ELSE
LEFT = .TRUE.
OCCMAX = OCC
END IF
GOTO 280
END IF
Check to see if bond orbital "BORB" contains previously used hybrids:
IF(NCTR.NE.1) THEN
CALL PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,TA,HYB,VA,VB,HYBEXP)
IF(DETAIL) THEN
DO 220 IHYB = 1,NCTR
WRITE(LFNPR,1500) IHYB,HYBEXP(IHYB)
220 CONTINUE
END IF
DO 230 IHYB = 1,NCTR
IF(HYBEXP(IHYB).LT.PRJTHR) GOTO 250
230 CONTINUE
END IF
IBD = IBD + 1
IACCEP = IACCEP + 1
Decompose "BORB" into its constituent atomic hybrids and store in Q:
CALL STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
Construct bond orbital labels:
IF(NCTR.EQ.1) THEN
ISHIFT = NTOPO(IAT1,IAT1) - KTOPO(IAT1,IAT1)
ELSE IF(NCTR.EQ.2) THEN
ISHIFT = NTOPO(IAT1,IAT2) - KTOPO(IAT1,IAT2)
ELSE
ISHIFT = 0
END IF
LABEL(IBD,1) = NAME(NCTR)
LABEL(IBD,2) = IBLNK
LABEL(IBD,3) = IACCEP + ISHIFT
LABEL(IBD,4) = IAT1
LABEL(IBD,5) = IAT2
LABEL(IBD,6) = IAT3
BNDOCC(IBD) = OCC
IF(DETAIL) WRITE(LFNPR,1600) IBD,(LABEL(IBD,I),I=1,3)
IF(IACCEP.EQ.NUM) THEN
IF(NCTR.EQ.1) THEN
KTOPO(IAT1,IAT1) = 0
ELSE IF(NCTR.EQ.2) THEN
KTOPO(IAT1,IAT2) = 0
KTOPO(IAT2,IAT1) = 0
ELSE
KFLG(ICNTR) = 0
END IF
GOTO 280
END IF
250 CONTINUE
IF(IACCEP.NE.NUM.AND.NCTR.EQ.2.AND.PRINT)
* WRITE(LFNPR,2000) PRJTHR,IACCEP,NUM,IAT1,IAT2
IF(IACCEP.NE.NUM.AND.NCTR.EQ.3.AND.PRINT)
* WRITE(LFNPR,2100) PRJTHR,IACCEP,NUM,IAT1,IAT2,IAT3
IFLG = -1
280 IF(NCTR.EQ.1.OR.NCTR.EQ.3) THEN
GOTO 130
ELSE
290 JCNTR=JCNTR+1
IF(JCNTR.GT.NATOMS) GOTO 130
NUM=KTOPO(IORDER(JCNTR),IORDER(ICNTR))
IF(NUM.EQ.0) GOTO 290
IAT1=IORDER(ICNTR)
IAT2=IORDER(JCNTR)
IAT3=0
GOTO 200
END IF
******** END OF LOOP FOR DIRECTED NBO SEARCH *********
300 CONTINUE
If some orbitals were left behind, go back and fetch them:
IF(LEFT) THEN
OCCTHR = OCCMAX
GOTO 115
END IF
Symmetrically orthogonalize principal hybrids:
CALL ORTHYB(Q,BLK,TA,EVAL,C,IALARM,IFLG)
IALARM sounds the alarm that there is linear dependency between some of the
hybrids. IALARM is equal to the number of the violating atom. Replenish
DM from T and repeat the NBO search:
IF(IALARM.NE.0) THEN
OLDPRJ = PRJTHR
PRJTHR = OLDPRJ + PRJINC
IF(PRINT) WRITE(LFNPR,1800) OLDPRJ,PRJTHR
IF(PRJTHR.GE.PT99) THEN
IF(PRINT) WRITE(LFNPR,1810) IALARM
IFLG = -1
JPRINT(1) = -1
RETURN
END IF
GOTO 700
END IF
Augment open-valence atoms with non-arbitrary hybrids orthogonal to those
found previously:
DO 580 IA = 1,NATOMS
IF(NOPVAL(IA).LE.0) GOTO 580
Find NMB, the number of natural minimal basis functions on this atom:
LLA = LL(IA)
IULA = UL(IA)
NMB = 0
DO 470 I = LLA,IULA
IF(LSTOCC(I).EQ.1) NMB = NMB + 1
470 CONTINUE
Find the number of bond, core, and lone pair hybrids on this atom, IOCC.
Also find IOCCLP, the number of lone pair orbitals already found
on atom IA for use in labelling the extra lone pairs below:
IOCC = 0
IOCCLP = 0
DO 480 IB = 1,IBD
IF((LABEL(IB,4).NE.IA).AND.(LABEL(IB,5).NE.IA).AND.
* (LABEL(IB,6).NE.IA)) GOTO 480
IOCC = IOCC + 1
IF(LABEL(IB,1).EQ.NAME(1)) THEN
IOCCLP = IOCCLP + 1
END IF
480 CONTINUE
NEXLP, the number of extra (low occupancy) LP orbitals on atom IAT.
(This is the number of low occupancy orbitals with valence shell character)
Set NEXLP to zero if (NMB-IOCC) is less than zero!!
NEXLP = NMB - IOCC
IF(NEXLP.LT.0) NEXLP = 0
NOCC = INO(IA)
CALL FRMPRJ(P,IA,Q,NOCC,TA,VA,VB)
NORB = NORBS(IA)
NAUGM = NORB - NOCC
CALL AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
Stash and label extra lone pairs that AUGMNT put in BLK:
(These are taken to be the highest occupied orbitals, which
AUGMNT places first)
DO 510 IAUGM = 1,NEXLP
DO 500 J = 1,NORB
500 BORB(J) = BLK(J,IAUGM)
IBD = IBD + 1
CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB)
LABEL(IBD,1) = NAME(1)
LABEL(IBD,2) = ISTAR
LABEL(IBD,3) = IAUGM+IOCCLP
LABEL(IBD,4) = IA
LABEL(IBD,5) = 0
LABEL(IBD,6) = 0
510 CONTINUE
Stash and label the Rydberg orbitals that AUGMNT put in BLK:
IRYD = 0
NSTART = NEXLP + 1
DO 540 IAUGM = NSTART,NAUGM
DO 530 J = 1,NORB
530 BORB(J) = BLK(J,IAUGM)
IBD = IBD + 1
IRYD = IRYD + 1
CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB)
LABEL(IBD,1) = LRY
LABEL(IBD,2) = ISTAR
LABEL(IBD,3) = IRYD
LABEL(IBD,4) = IA
LABEL(IBD,5) = 0
LABEL(IBD,6) = 0
540 CONTINUE
580 CONTINUE
Include antibond labels:
IBO = IBD
DO 660 I = 1,IBO
Exit loop if LABEL(I,1) is 'LP', 'RY', OR 'CR':
IF(LABEL(I,1).EQ.NAME(1)) GOTO 660
IF(LABEL(I,1).EQ.LRY) GOTO 660
IF(LABEL(I,1).EQ.LCR) GOTO 660
NAB = 1
IF(LABEL(I,1).EQ.NAME(3)) NAB = 2
DO 650 IAB = 1,NAB
IBD = IBD + 1
DO 640 J = 1,6
640 LABEL(IBD,J) = LABEL(I,J)
LABEL(IBD,2) = ISTAR
650 CONTINUE
660 CONTINUE
IF(IBD.EQ.NBAS) GOTO 670
WRITE(LFNPR,2200)
STOP
670 CONTINUE
Replace density matrix DM from T:
700 CONTINUE
DO 750 J = 1,NBAS
DO 740 I = 1,J
DM(I,J) = T(I,J)
DM(J,I) = DM(I,J)
T(J,I) = ZERO
T(I,J) = ZERO
740 CONTINUE
750 CONTINUE
If the alarm sounded, repeat directed NBO search:
IF(IALARM.NE.0) GOTO 35
Find new polarization parameters for orthonormal hybrids:
CALL REPOL(DM,Q,POL,BLK,EVAL,C,IBD)
Form final T-NAB (NAO to NBO transformation) from orthonormal hybrids:
CALL FORMT(T,Q,POL)
Find occupancies, find total number of electrons and occupied orbitals:
TOTELE = ZERO
DO 800 I = 1,NBAS
OCCI = ZERO
DO 790 J = 1,NBAS
DO 790 K = 1,NBAS
790 OCCI = OCCI + T(J,I) * DM(J,K) * T(K,I)
IF(ABS(OCCI).LT.ZEROP) OCCI = ZERO
IF(OCCI.GT.TWOP) GO TO 960
ZEROPM = -ZEROP
IF(OCCI.LT.ZEROPM) GO TO 960
BNDOCC(I) = OCCI
V(I) = OCCI
TOTELE = TOTELE + BNDOCC(I)
800 CONTINUE
NEL = TOTELE + TENTH
IF(ABS(TOTELE-NEL).GT.5E-4) GO TO 965
TOTELE = NEL
NOCC = NEL
IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2)
If the number of unstarred orbitals is not equal to the number of occupied
MOs, then simply rank the orbitals by occupancy, and ``unstarr'' the NOCC
highest occupied: (This can be dangerous! However, many of the subsequent
routines assume the only NOCC orbitals are starred, and therefore, this
mismatch must be corrected.)
NOSTR = 0
DO 801 I = 1,NBAS
IF(LABEL(IBXM(I),2).NE.ISTAR) NOSTR = NOSTR + 1
801 CONTINUE
IF(NOSTR.NE.NOCC) THEN
CALL RANK(V,NBAS,NDIM,LARC)
DO 804 I = 1,NOCC
IR = LARC(I)
LABEL(IBXM(IR),2) = IBLNK
804 CONTINUE
DO 805 I = NOCC+1,NBAS
IR = LARC(I)
LABEL(IBXM(IR),2) = ISTAR
805 CONTINUE
END IF
Determine whether this is a good resonance structure:
CALL CYCLES(ITER,ABS(THRSET),GUIDE,BNDOCC,TOPO,ICONT)
Write out info about core orbitals which were isolated in subroutine
CORE:
IF(.NOT.PRINT) GOTO 953
CRTHRS = CRTSET
IF(ISPIN.NE.0) CRTHRS = CRTHRS - ONE
FIRST = .TRUE.
DO 952 IAT = 1,NATOMS
ILOW = 0
DO 951 I = 1,NBAS
IF(LABEL(IBXM(I),1).EQ.LCR.AND.LABEL(IBXM(I),4).EQ.IAT
+ .AND.BNDOCC(I).LT.CRTHRS) ILOW = ILOW + 1
951 CONTINUE
IF(ILOW.NE.0) THEN
IF(FIRST) THEN
FIRST = .FALSE.
NAM = NAMEAT(IATNO(IAT))
IF(ILOW.NE.1) THEN
WRITE(LFNPR,3010) ILOW,CRTHRS,NAM,IAT
ELSE
WRITE(LFNPR,3011) ILOW,CRTHRS,NAM,IAT
END IF
ELSE
NAM = NAMEAT(IATNO(IAT))
IF(ILOW.NE.1) THEN
WRITE(LFNPR,3020) ILOW,CRTHRS,NAM,IAT
ELSE
WRITE(LFNPR,3021) ILOW,CRTHRS,NAM,IAT
END IF
END IF
END IF
952 CONTINUE
953 CONTINUE
RETURN
Bad orbital occupancy:
960 IF(PRINT) WRITE(LFNPR,1300) OCCI
IFLG = -1
JPRINT(1) = -1
RETURN
Total number of electrons is not an integer:
965 WRITE(LFNPR,1310) TOTELE
IFLG = -1
JPRINT(1) = -1
RETURN
1300 FORMAT(/,1X,'A bond orbital with an occupancy of ',F8.5,
+ ' electrons was found!',/,1X,'Please check you input data.')
1310 FORMAT(/,1X,'The total number of electron is not an integer:',
+ F10.5,/,1X,'Please check your input data.')
1400 FORMAT(/,1X,'Search of DM block between the following atoms:',
+ 3I4)
1402 FORMAT(6X,'Select ',I2,' orbital(s) with eigenvalue > ',F9.6)
1405 FORMAT(6X,8F9.6)
1410 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':')
1420 FORMAT(11X,8F7.4)
1500 FORMAT(11X,'Hybrid ',I1,' in eigenvector has a projection ',
+ 'expectation of ',F6.3)
1600 FORMAT(11X,'*** NBO accepted: Number',I3,'. Label:',A2,A1,
+ '(',I2,')')
1610 FORMAT(1X,'Still need to find',I2,' more orbital(s)')
1800 FORMAT(/4X,'PRJTHR will be raised from ',F6.3,' to',F6.3,
+ ' and the NBO search repeated.',/)
1810 FORMAT(//,1X,'Linearly independent hybrids for atom',I3,
+' cannot be found.',/,1X,'The NBO program must abort.')
2000 FORMAT(/,1X,'At a projection threshold of',F6.3,', only ',I1,
+ ' of the ',I1,' requested bonds',/,1X,'between atoms ',I2,
+ ' and ',I2,' can be constructed. The NBO analysis will',/,
+ 1X,'continue, augmenting the NBO set with extra lone pairs ',
+ 'on the atoms',/,1X,'as necessary.')
2100 FORMAT(/,1X,'At a projection threshold of',F6.3,', only ',I1,
+ ' of the ',I1,' requested bonds',/,1X,'between atoms ',I2,', ',
+ I2,', and ',I2,' can be constructed. The NBO analysis',/,1X,
+ 'will continue, augmenting the NBO set with extra lone pairs ',
+ 'on the',/,1X,'atoms as necessary.')
2200 FORMAT(/,1X,'Miscounted orbitals, program must abort')
3010 FORMAT(/,1X,
+'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals ',
+'found on ',A2,I2)
3011 FORMAT(/,1X,
+'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbital ',
+'found on ',A2,I2)
3020 FORMAT(1X,
+' ',I3,' low occupancy (<',F6.4,'e) core orbitals ',
+'found on ',A2,I2)
3021 FORMAT(1X,
+' ',I3,' low occupancy (<',F6.4,'e) core orbital ',
+'found on ',A2,I2)
END
*****************************************************************************
SUBROUTINE SRTNBO(T,BNDOCC)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL PERMUT
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
DIMENSION T(NDIM,NDIM),BNDOCC(NDIM)
DIMENSION NAME(3)
DATA LBD,L3C,NAME,LSTAR/'BD','3C','CR','LP','RY','*'/
Reorder the NBOs according to bond type and constituent atomic centers:
Fix atom ordering in the NBO labels:
DO 100 I = 1,NBAS
NCTR = 0
DO 10 J = 4,6
IF(LABEL(I,J).NE.0) THEN
NCTR = NCTR + 1
LARC(NCTR) = LABEL(I,J)
END IF
10 CONTINUE
DO 30 J = 1,NCTR-1
DO 20 K = 1,NCTR-J
IF(LARC(K).GT.LARC(K+1)) THEN
ITEMP = LARC(K)
LARC(K) = LARC(K+1)
LARC(K+1) = ITEMP
END IF
20 CONTINUE
30 CONTINUE
DO 40 J = 1,NCTR
LABEL(I,J+3) = LARC(J)
40 CONTINUE
DO 50 J = NCTR+1,3
LABEL(I,J+3) = 0
50 CONTINUE
100 CONTINUE
Place the 2- and 3-center bonds first in the list of NBOs: (No bonds if
the NOBOND keyword was specified)
ICNT = 0
IF(JPRINT(10).EQ.0) THEN
DO 200 I = 1,NATOMS-1
DO 190 J = I+1,NATOMS
IF(I.NE.J) THEN
K = -1
110 K = K + 1
DO 180 L = ICNT+1,NBAS
LBL1 = LABEL(IBXM(L),1)
LBL2 = LABEL(IBXM(L),2)
LBL3 = LABEL(IBXM(L),3)
LBL4 = LABEL(IBXM(L),4)
LBL5 = LABEL(IBXM(L),5)
LBL6 = LABEL(IBXM(L),6)
IF((LBL1.EQ.LBD.OR.LBL1.EQ.L3C).AND.LBL2.NE.LSTAR) THEN
IF(LBL4.EQ.I.AND.LBL5.EQ.J.AND.LBL6.EQ.K) THEN
ICNT = ICNT + 1
LABEL(IBXM(L),1) = LABEL(IBXM(ICNT),1)
LABEL(IBXM(L),2) = LABEL(IBXM(ICNT),2)
LABEL(IBXM(L),3) = LABEL(IBXM(ICNT),3)
LABEL(IBXM(L),4) = LABEL(IBXM(ICNT),4)
LABEL(IBXM(L),5) = LABEL(IBXM(ICNT),5)
LABEL(IBXM(L),6) = LABEL(IBXM(ICNT),6)
LABEL(IBXM(ICNT),1) = LBL1
LABEL(IBXM(ICNT),2) = LBL2
LABEL(IBXM(ICNT),3) = LBL3
LABEL(IBXM(ICNT),4) = LBL4
LABEL(IBXM(ICNT),5) = LBL5
LABEL(IBXM(ICNT),6) = LBL6
TEMP = BNDOCC(L)
BNDOCC(L) = BNDOCC(ICNT)
BNDOCC(ICNT) = TEMP
DO 170 M = 1,NBAS
TEMP = T(M,L)
T(M,L) = T(M,ICNT)
T(M,ICNT) = TEMP
170 CONTINUE
END IF
END IF
180 CONTINUE
IF(IW3C.NE.0.AND.K.EQ.0) K = J
IF(K.GT.0.AND.K.LT.NATOMS) GOTO 110
END IF
190 CONTINUE
200 CONTINUE
END IF
Next add any core, lone pair, and Rydberg orbitals:
DO 300 II = 1,3
DO 290 I = 1,NATOMS
DO 280 J = ICNT+1,NBAS
LBL1 = LABEL(IBXM(J),1)
LBL4 = LABEL(IBXM(J),4)
IF(LBL1.EQ.NAME(II).AND.LBL4.EQ.I) THEN
ICNT = ICNT + 1
DO 260 K = 1,6
ITEMP = LABEL(IBXM(J),K)
LABEL(IBXM(J),K) = LABEL(IBXM(ICNT),K)
LABEL(IBXM(ICNT),K) = ITEMP
260 CONTINUE
TEMP = BNDOCC(J)
BNDOCC(J) = BNDOCC(ICNT)
BNDOCC(ICNT) = TEMP
DO 270 K = 1,NBAS
TEMP = T(K,J)
T(K,J) = T(K,ICNT)
T(K,ICNT) = TEMP
270 CONTINUE
END IF
280 CONTINUE
290 CONTINUE
300 CONTINUE
Add in any antibonds:
IF(JPRINT(10).EQ.0) THEN
DO 400 I = 1,NATOMS-1
DO 390 J = I+1,NATOMS
IF(I.NE.J) THEN
K = -1
IF(IW3C.NE.0) K = J
310 K = K + 1
DO 380 L = ICNT+1,NBAS
LBL1 = LABEL(IBXM(L),1)
LBL2 = LABEL(IBXM(L),2)
LBL3 = LABEL(IBXM(L),3)
LBL4 = LABEL(IBXM(L),4)
LBL5 = LABEL(IBXM(L),5)
LBL6 = LABEL(IBXM(L),6)
IF((LBL1.EQ.LBD.OR.LBL1.EQ.L3C).AND.LBL2.EQ.LSTAR) THEN
IF(LBL4.EQ.I.AND.LBL5.EQ.J.AND.LBL6.EQ.K) THEN
ICNT = ICNT + 1
LABEL(IBXM(L),1) = LABEL(IBXM(ICNT),1)
LABEL(IBXM(L),2) = LABEL(IBXM(ICNT),2)
LABEL(IBXM(L),3) = LABEL(IBXM(ICNT),3)
LABEL(IBXM(L),4) = LABEL(IBXM(ICNT),4)
LABEL(IBXM(L),5) = LABEL(IBXM(ICNT),5)
LABEL(IBXM(L),6) = LABEL(IBXM(ICNT),6)
LABEL(IBXM(ICNT),1) = LBL1
LABEL(IBXM(ICNT),2) = LBL2
LABEL(IBXM(ICNT),3) = LBL3
LABEL(IBXM(ICNT),4) = LBL4
LABEL(IBXM(ICNT),5) = LBL5
LABEL(IBXM(ICNT),6) = LBL6
TEMP = BNDOCC(L)
BNDOCC(L) = BNDOCC(ICNT)
BNDOCC(ICNT) = TEMP
DO 370 M = 1,NBAS
TEMP = T(M,L)
T(M,L) = T(M,ICNT)
T(M,ICNT) = TEMP
370 CONTINUE
END IF
END IF
380 CONTINUE
IF(K.GT.0.AND.K.LT.NATOMS) GOTO 310
END IF
390 CONTINUE
400 CONTINUE
END IF
Lastly, make sure orbitals are ordered by serial number:
410 PERMUT = .FALSE.
DO 500 I = 1,NBAS-1
IF(LABEL(IBXM(I),1).EQ.LABEL(IBXM(I+1),1)) THEN
IF(LABEL(IBXM(I),2).EQ.LABEL(IBXM(I+1),2)) THEN
IF(LABEL(IBXM(I),4).EQ.LABEL(IBXM(I+1),4)) THEN
IF(LABEL(IBXM(I),5).EQ.LABEL(IBXM(I+1),5)) THEN
IF(LABEL(IBXM(I),6).EQ.LABEL(IBXM(I+1),6)) THEN
IF(LABEL(IBXM(I),3).GT.LABEL(IBXM(I+1),3)) THEN
PERMUT = .TRUE.
LBL3 = LABEL(IBXM(I),3)
LABEL(IBXM(I),3) = LABEL(IBXM(I+1),3)
LABEL(IBXM(I+1),3) = LBL3
TEMP = BNDOCC(I)
BNDOCC(I) = BNDOCC(I+1)
BNDOCC(I+1) = TEMP
DO 490 J = 1,NBAS
TEMP = T(J,I)
T(J,I) = T(J,I+1)
T(J,I+1) = TEMP
490 CONTINUE
END IF
END IF
END IF
END IF
END IF
END IF
500 CONTINUE
IF(PERMUT) GOTO 410
RETURN
END
*****************************************************************************
SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL FIRST
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),HYB(MXAO),THYB(NDIM,NDIM),
+ S(NDIM,NDIM),OCC(NDIM),SCR(NDIM),ISCR(NDIM)
DIMENSION PCT(5),IAT(3)
DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/
DATA ZERO,TENTH,ONE,THRESH/0.0D0,0.1D0,1.0D0,1.0D-4/
DATA LSTAR,LBLNK/'*',' '/
Form a temporary NAO to NHO transformation matrix. Check hybrid
overlap to make sure the NBO's were properly labelled as Lewis
and non-Lewis orbitals:
Count number of hybrids as they are written out:
NHYB = 0
Main loop over bond orbitals:
DO 200 NBOND = 1,NBAS
IB = IBXM(NBOND)
LBL = LABEL(IB,1)
IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR = 1
IF(LBL.EQ.LBD) NCTR = 2
IF(LBL.EQ.L3C) NCTR = 3
Loop over atomic centers of bond orbital NBOND:
DO 190 ICTR = 1,NCTR
I = LABEL(IB,ICTR+3)
KL = LL(I)
KU = LU(I)
DO 120 K = 1,MXAO
LTYP(K) = 0
120 HYB(K) = ZERO
Choose sign for polarization coefficients:
ISGN = 1
IF(LABEL(IB,2).NE.LSTAR) GO TO 130
IF(ICTR.LT.2) GO TO 130
IF(ICTR.EQ.3) IPAR3C = -IPAR3C
IF(ICTR.EQ.3.AND.IPAR3C.GT.0) GO TO 130
ISGN = -ISGN
130 CONTINUE
Extract hybrid (HYB) from transformation matrix T; LTYP(I) is the
orbital angular momentum quantum no. of A.O. # I:
KH = 0
DO 140 K = KL,KU
KH = KH + 1
HYB(KH) = T(K,NBOND)
140 LTYP(KH) = NAOA(K)/100
CALL HTYPE(HYB,LTYP,MXAO,KH,COEF,PCT,NL,ISGN)
IF(ABS(COEF).LT.THRESH) GO TO 190
Check to see if this orbital has been found before:
DO 160 IHYB = 1,NHYB
TEMP = ZERO
IH = 0
DO 150 K = KL,KU
IH = IH + 1
TEMP = TEMP + HYB(IH)*THYB(K,IHYB)
150 CONTINUE
IF(ABS(ABS(TEMP)-ONE).LT.THRESH) GO TO 190
IF(ABS(TEMP).GT.THRESH) THEN
WRITE(LFNPR,900) NHYB+1,NBOND,ICTR,TEMP,IHYB
STOP
END IF
160 CONTINUE
Add this hybrid to the temporary THYB:
NHYB = NHYB + 1
IF(NHYB.GT.NBAS) STOP 'Too many hybrids'
DO 170 K = 1,NBAS
THYB(K,NHYB) = ZERO
170 CONTINUE
IH = 0
DO 180 K = KL,KU
IH = IH + 1
THYB(K,NHYB) = HYB(IH)
180 CONTINUE
190 CONTINUE
200 CONTINUE
IF(NHYB.LT.NBAS) STOP 'Missing hybrids'
THYB now contains the temporary NAO to NHO transformation matrix.
Form the non-orthogonal PNHO overlap and NHO to NBO transformation matrices:
CALL FESNAO(S)
CALL SIMTRS(S,THYB,SCR,NDIM,NBAS)
CALL TRANSP(THYB,NDIM,NBAS)
CALL MATMLT(THYB,T,SCR,NDIM,NBAS)
Check to see that the bonds and antibonds have the correct hybrid
overlap. Fix the labels if there is a problem:
FIRST = .TRUE.
DO 300 NBOND = 1,NBAS
IB = IBXM(NBOND)
LBL1 = LABEL(IB,1)
IF(LBL1.EQ.LLP.OR.LBL1.EQ.LCR.OR.LBL1.EQ.LRY) ICTR = 1
IF(LBL1.EQ.LBD) ICTR = 2
IF(LBL1.EQ.L3C) ICTR = 3
NCTR = 0
DO 210 IHYB = 1,NHYB
IF(ABS(THYB(IHYB,NBOND)).GT.THRESH) THEN
NCTR = NCTR + 1
IF(NCTR.GT.3) THEN
WRITE(LFNPR,910) NBOND
STOP
END IF
IAT(NCTR) = IHYB
END IF
210 CONTINUE
IF(NCTR.GT.ICTR) THEN
WRITE(LFNPR,920) ICTR,NBOND,NCTR
STOP
END IF
IF(NCTR.GT.1) THEN
ISGN = 1
DO 230 JCTR = 1,NCTR-1
DO 220 KCTR = JCTR+1,NCTR
JHYB = IAT(JCTR)
KHYB = IAT(KCTR)
TEMP = S(JHYB,KHYB)*THYB(JHYB,NBOND)*THYB(KHYB,NBOND)
IF(TEMP.LT.ZERO) ISGN = -1
220 CONTINUE
230 CONTINUE
LBL2 = LABEL(IB,2)
IF(LBL2.EQ.LBLNK.AND.ISGN.EQ.-1) THEN
IF(FIRST.AND.JPRINT(5).NE.0) WRITE(LFNPR,930)
FIRST = .FALSE.
LABEL(IB,2) = LSTAR
IF(JPRINT(5).NE.0) WRITE(LFNPR,940) NBOND,LBL1,LSTAR
ELSE IF(LBL2.EQ.LSTAR.AND.ISGN.EQ.1) THEN
IF(FIRST.AND.JPRINT(5).NE.0) WRITE(LFNPR,930)
FIRST = .FALSE.
LABEL(IB,2) = LBLNK
IF(JPRINT(5).NE.0) WRITE(LFNPR,940) NBOND,LBL1,LBLNK
END IF
END IF
300 CONTINUE
Determine the number of occupied orbitals:
TOT = ZERO
DO 310 I = 1,NBAS
TOT = TOT + DM(I,I)
310 CONTINUE
NOCC = TOT + TENTH
IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2)
Count the number of unstarred orbitals:
ICNT = 0
DO 320 I = 1,NBAS
IF(LABEL(IBXM(I),2).NE.LSTAR) ICNT = ICNT + 1
320 CONTINUE
If the number of unstarred orbitals is not equal to the number of
occupied orbitals, fix the orbital labels:
IF(ICNT.NE.NOCC) THEN
DO 330 I = 1,NBAS
OCC(I) = DM(I,I)
330 CONTINUE
CALL RANK(OCC,NBAS,NDIM,ISCR)
If there are more unstarred orbitals than occupied, add stars to the
least occupied lone pairs:
IF(ICNT.GT.NOCC) THEN
IDIFF = ICNT - NOCC
DO 350 I = 1,IDIFF
IP = 0
DO 340 J = 1,NBAS
JP = IBXM(ISCR(J))
IF(LABEL(JP,1).EQ.LLP.AND.LABEL(JP,2).NE.LSTAR) IP = J
340 CONTINUE
IF(IP.EQ.0) THEN
WRITE(LFNPR,950) ICNT,NOCC
STOP
END IF
LABEL(IBXM(ISCR(IP)),2) = LSTAR
IF(JPRINT(5).NE.0) WRITE(LFNPR,940) ISCR(IP),
+ LABEL(IBXM(ISCR(IP)),1),LSTAR
350 CONTINUE
Remove stars from the highest occupied lone pairs/Rydbergs if there are
too few starred orbitals:
ELSE
IDIFF = NOCC - ICNT
DO 370 I = 1,IDIFF
IP = 0
DO 360 J = NBAS,1,-1
JP = IBXM(ISCR(J))
IF((LABEL(JP,1).EQ.LLP.OR.LABEL(JP,1).EQ.LRY)
+ .AND.LABEL(JP,2).EQ.LSTAR) IP = J
360 CONTINUE
IF(IP.EQ.0) THEN
WRITE(LFNPR,950) ICNT,NOCC
STOP
END IF
LABEL(IBXM(ISCR(IP)),2) = LBLNK
IF(JPRINT(5).NE.0) WRITE(LFNPR,940) ISCR(IP),
+ LABEL(IBXM(ISCR(IP)),1),LBLNK
370 CONTINUE
END IF
END IF
RETURN
900 FORMAT(/1X,'Hybrid ',I3,' (NBO ',I3,', Center ',I2,') has a ',
+ 'non-negligible overlap of ',F8.5,/,1X,'with hybrid ',I3,'.')
910 FORMAT(/1X,'NBO ',I3,' has hybrid contributions from more than ',
+ '3 atomic centers.')
920 FORMAT(/1X,'Error: the ',I1,'-center NBO ',I3,' has ',
+ 'contributions from ',I2,' atomic centers.')
930 FORMAT(/1X,' --- Apparent excited state configuration ',
+ '---',/1X,'The following "inverted" NBO labels reflect the ',
+ 'actual hybrid overlap:')
940 FORMAT(1X,' NBO ',I3,' has been relabelled ',A2,A1)
950 FORMAT(/1X,'Unable to label the NBOs properly: ',I3,' unstarred ',
+ 'orbitals',/1X,' ',I3,
+ ' occupied orbitals')
END
*****************************************************************************
SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
INTEGER UL
Print out details of bond-orbital transformation from matrix T.
Required input:
T = Transformation matrix from S.R. NATHYB; REAL (1,NDIM;1,NDIM)
NDIM = Declared dimensionality of array T
NBAS = No. of orbitals = actual dimension of T, NAOL
NAOL = Integer list of orbital angular momentum type
NAOL(I)/100 = l = Q.N. of atomic orbital I
IATNO = List of atomic numbers; IATNO(I) is the atomic number
of atom I as an integer
NATOMS = No. of atoms (not including ghosts) in the molecule
IWHYBS = 1 if hybrid A.O. coefficients are to be printed,
0 otherwise
LFNPR = Logical file number for printout.
NAOCTR = List of atomic centers of OAO or NAO basis orbitals
LABEL = List of bond orbital labels
IBXM = Permutation list of bond orbitals
BNDOCC = List of bond orbital occupancies
ISPIN = 0 for spinless NBOs
= 2 for alpha spin NBOs
=-2 for beta spin NBOs
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
DIMENSION T(NDIM,NDIM),HYB(MXAO),BNDOCC(NDIM),THYB(NDIM,NDIM),
* PCT(5),POW(5),LNAME(5),ISP(3),NAM(3),ICH(3,2),HYCOEF(NDIM)
DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/
DATA LNAME/'s','p','d','f','g'/
DATA ZERO,THRESH,T99,T99P/0.0D0,1.D-2,99.99D0,99.995D0/
DATA TENTH,HUNDRD,TTHOTH/0.1D0,100.0D0,0.0001D0/
DATA LHYP,LBLNK,LSTAR,L2BLNK/'-',' ','*',' '/
Count the number of electrons:
TOTELE = ZERO
DO 20 I = 1,NBAS
TOTELE = TOTELE + BNDOCC(I)
20 CONTINUE
TOTELE = TOTELE + TENTH
NEL = TOTELE
TOTELE = NEL
Count the number of core orbitals and the occupancies of the core,
valence Lewis, valence non-Lewis, and extra-valence Rydberg orbitals.
(Also count the number of electrons in the ECP, if employed)
MCR = 0
OCCCR = ZERO
OCCVL = ZERO
OCCVNL = ZERO
DO 50 I = 1,NBAS
IF(LABEL(IBXM(I),2).NE.LSTAR) THEN
IF(LABEL(IBXM(I),1).EQ.LCR) THEN
MCR = MCR + 1
OCCCR = OCCCR + BNDOCC(I)
ELSE
OCCVL = OCCVL + BNDOCC(I)
END IF
ELSE
IF(LABEL(IBXM(I),1).NE.LRY) THEN
OCCVNL = OCCVNL + BNDOCC(I)
END IF
END IF
50 CONTINUE
OCCEVR = TOTELE - OCCCR - OCCVL - OCCVNL
IF(ISPIN.EQ.0) THEN
MCR = 2 * MCR
END IF
MVL = NEL - MCR
MECP = 0
IF(IPSEUD.NE.0) THEN
DO 60 I = 1,NATOMS
MECP = MECP + IATNO(I) - IZNUC(I)
60 CONTINUE
IF(ISPIN.NE.0) MECP = MECP/2
END IF
MLEW = MCR + MVL + MECP
OCCLEW = OCCCR + OCCVL + MECP
OCCNON = OCCVNL + OCCEVR
Write summary of NBO occupancies:
IF(JPRINT(5).EQ.1.AND.NEL.NE.0) THEN
WRITE(LFNPR,2000)
IF(IPSEUD.NE.0) WRITE(LFNPR,2010) FLOAT(MECP)
IF(MCR.NE.0) THEN
PCENT = OCCCR/MCR * HUNDRD
WRITE(LFNPR,2020) OCCCR,PCENT,MCR
END IF
IF(MVL.NE.0) THEN
PCENT = OCCVL/MVL * HUNDRD
WRITE(LFNPR,2030) OCCVL,PCENT,MVL
END IF
WRITE(LFNPR,2040)
PCENT = OCCLEW/MLEW * HUNDRD
WRITE(LFNPR,2050) OCCLEW,PCENT,MLEW
WRITE(LFNPR,2060)
PCENT = OCCVNL/MLEW * HUNDRD
WRITE(LFNPR,2070) OCCVNL,PCENT,MLEW
PCENT = OCCEVR/MLEW * HUNDRD
WRITE(LFNPR,2080) OCCEVR,PCENT,MLEW
WRITE(LFNPR,2040)
PCENT = OCCNON/MLEW * HUNDRD
WRITE(LFNPR,2090) OCCNON,PCENT,MLEW
WRITE(LFNPR,2100)
END IF
Write out NBOs:
IF(JPRINT(5).EQ.1) THEN
WRITE(LFNPR,1000)
WRITE(LFNPR,1100) (LHYP,J=1,79)
END IF
Main loop over bond orbitals:
NHYB = 0
MHYB = 0
IPAR3C = 1
DO 180 NBOND = 1,NBAS
IB = IBXM(NBOND)
LBL = LABEL(IB,1)
IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR = 1
IF(LBL.EQ.LBD) NCTR = 2
IF(LBL.EQ.L3C) NCTR = 3
DO 110 I = 1,3
IA = LABEL(IB,I+3)
CALL CONVRT(IA,ICH(I,1),ICH(I,2))
NAM(I) = L2BLNK
IF(IA.GT.0) NAM(I) = NAMEAT(IATNO(IA))
ISP(I) = LHYP
IF(I.GE.NCTR) ISP(I) = LBLNK
110 CONTINUE
Loop over atomic centers of bond orbital NBOND:
DO 170 ICTR = 1,NCTR
I = LABEL(IB,ICTR+3)
NEL = NAMEAT(IATNO(I))
KL = LL(I)
KU = UL(I)
DO 120 K = 1,MXAO
LTYP(K) = 0
120 HYB(K) = ZERO
Choose sign for polarization coefficients:
ISGN = 1
IF(LABEL(IB,2).NE.LSTAR) GO TO 130
IF(ICTR.LT.2) GO TO 130
IF(ICTR.EQ.3) IPAR3C = -IPAR3C
IF(ICTR.EQ.3.AND.IPAR3C.GT.0) GO TO 130
ISGN = -ISGN
130 CONTINUE
Extract hybrid (HYB) from transformation matrix T; LTYP(I) is the
orbital angular momentum quantum no. of A.O. # I:
KH = 0
DO 140 K = KL,KU
KH = KH + 1
HYB(KH) = T(K,NBOND)
140 LTYP(KH) = NAOA(K)/100
CALL HTYPE(HYB,LTYP,MXAO,KH,COEF,PCT,NL,ISGN)
Find leading non-zero contribution to determine POW(L) for each L:
LSTD = 0
DO 160 L = 1,NL
IF(LSTD.GT.0) GO TO 150
POW(L) = ZERO
STD = PCT(L)
IF(STD.LT.THRESH) GO TO 160
LSTD = L
150 POW(L) = PCT(L)/STD
IF(POW(L).GT.T99P) POW(L) = T99
160 CONTINUE
Write out NHO for center ICTR:
COEFSQ = COEF * COEF * HUNDRD
NL1 = NL
IF(NL1.GT.3) NL1 = 3
IF(ICTR.EQ.1.AND.NCTR.EQ.1.AND.JPRINT(5).EQ.1)
+ WRITE(LFNPR,1210) NBOND,BNDOCC(NBOND),
+ (LABEL(IB,K),K=1,3),NAM(1),ICH(1,1),ICH(1,2),
+ PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1)
IF(ICTR.EQ.1.AND.NCTR.GT.1.AND.JPRINT(5).EQ.1)
+ WRITE(LFNPR,1220) NBOND,BNDOCC(NBOND),
+ (LABEL(IB,K),K=1,3),
+ (NAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3)
IF(NCTR.NE.1.AND.JPRINT(5).EQ.1) WRITE(LFNPR,1300) COEFSQ,
+ COEF,NEL,I,PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1)
IF(NL.GT.3.AND.JPRINT(5).EQ.1) WRITE(LFNPR,1310)
+ (LNAME(L),POW(L),PCT(L),L=4,NL)
IF(IWHYBS.NE.0.AND.BNDOCC(NBOND).GT.TTHOTH.AND.JPRINT(5).EQ.1)
+ WRITE(LFNPR,1500) (HYB(K),K=1,KH)
CALL FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
If this is a new hybrid, form its label:
IF(MHYB.NE.NHYB) THEN
MHYB = NHYB
CALL LBLNHO(NHYB,NBOND,ICTR,NCTR)
END IF
170 CONTINUE
180 CONTINUE
RETURN
1000 FORMAT(//,1X,' (Occupancy) Bond orbital/ Coefficients/ ',
+ 'Hybrids')
1100 FORMAT(1X,80A1)
1210 FORMAT(1X,I3,'. (',F7.5,') ',A2,A1,'(',I2,')',A2,2A1,12X,
+ ' s(',F6.2,'%)',2(A1,F5.2,'(',F6.2,'%)'))
1220 FORMAT(1X,I3,'. (',F7.5,') ',A2,A1,'(',I2,')',3(A2,3A1))
1300 FORMAT(16X,'(',F6.2,'%)',2X,
+ F7.4,'*',A2,I2,' s(',F6.2,'%)',2(A1,F5.2,'(',F6.2,'%)'))
1310 FORMAT(50X,2(A1,F5.2,'(',F6.2,'%)'))
1500 FORMAT(39X,5F8.4)
2000 FORMAT(/,1X,56('-'))
2010 FORMAT(1X,' Effective Core ',F9.5)
2020 FORMAT(1X,' Core ',F9.5,' (',F7.3,'% of ',
+ I3,')')
2030 FORMAT(1X,' Valence Lewis ',F9.5,' (',F7.3,'% of ',
+ I3,')')
2040 FORMAT(2X,18('='),7X,28('='))
2050 FORMAT(1X,' Total Lewis ',F9.5,' (',F7.3,'% of ',
+ I3,')')
2060 FORMAT(2X,53('-'))
2070 FORMAT(1X,' Valence non-Lewis ',F9.5,' (',F7.3,'% of ',
+ I3,')')
2080 FORMAT(1X,' Rydberg non-Lewis ',F9.5,' (',F7.3,'% of ',
+ I3,')')
2090 FORMAT(1X,' Total non-Lewis ',F9.5,' (',F7.3,'% of ',
+ I3,')')
2100 FORMAT(1X,56('-'))
END
*****************************************************************************
SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION HYB(MXAO),LTYP(MXAO),PCT(5)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
ANALYZE INPUT HYBRID 'HYB' FOR POLARIZATION COEFFICIENT 'COEF'
AND PERCENTAGES OF EACH ANGULAR MOMENTUM COMPONENT.
DATA ZERO,THRESH,HUNDRD/0.0D0,1.D-4,100.0D0/
NL = 0
ZERO PERCENTAGES AND POLARIZATION COEFFICIENT:
DO 10 L1 = 1,5
10 PCT(L1) = ZERO
COEF = ZERO
LOOP OVER ATOMIC CONTRIBUTIONS TO HYBRID, COMPUTING PERCENTAGES
AND POLARIZATION COEFFICIENT:
DO 20 I = 1,NH
L1 = LTYP(I) + 1
IF(L1.GT.5) GO TO 800
PCT(L1) = PCT(L1) + HYB(I)**2
20 COEF = COEF + HYB(I)**2
IF(ABS(COEF).LT.THRESH) RETURN
CALCULATE PERCENTAGE CONTRIBUTION FOR EACH ANGULAR SYMMETRY:
DO 30 L1 = 1,5
30 PCT(L1) = PCT(L1)/COEF*HUNDRD
COEF = SQRT(COEF)
SWITCH THE SIGN OF THE COEFFICIENT IF ISGN IS NEGATIVE:
IF(ISGN.LT.0) COEF = -COEF
NORMALIZE THE HYBRID:
DO 50 I = 1,NH
50 HYB(I) = HYB(I)/COEF
FIND THE MAXIMUM NUMBER OF ANGULAR MOMENTUM TYPES (NL):
DO 60 I = 1,NH
IF(ABS(HYB(I)).LT.THRESH) GO TO 60
IF(LTYP(I).LE.NL) GO TO 60
NL = LTYP(I)
60 CONTINUE
NL = NL + 1
RETURN
800 CONTINUE
WRITE(LFNPR,900) L1-1
STOP
900 FORMAT(/1X,'AO with unknown angular symmetry, l = ',I3)
END
*****************************************************************************
SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION HYB(1),THYB(NDIM,NDIM),HYCOEF(NDIM)
DATA ZERO,ONE,THRESH/0.0D0,1.0D0,1.0D-4/
FORM FULL NAO TO NHO TRANFORMATION IN THYB, ADDING ONE HYBRID WITH
EACH CALL. PUT POLARIZATION COEF IN HYCOEF FOR EACH HYBRID.
MAKE SURE THIS HYBRID ISN'T ALREADY IN THE LIST:
IF(ABS(COEF).LT.THRESH) RETURN
DO 20 IHYB = 1,NHYB
TEMP = ZERO
IH = 0
DO 10 K = KL,KU
IH = IH + 1
TEMP = TEMP + HYB(IH)*THYB(K,IHYB)
10 CONTINUE
IF(ABS(ABS(TEMP)-ONE).LT.THRESH) RETURN
IF(ABS(TEMP).GT.THRESH) THEN
WRITE(LFNPR,900) NHYB+1,TEMP,IHYB
STOP
END IF
20 CONTINUE
ADD THIS HYBRID TO THE LIST:
NHYB = NHYB + 1
IF(NHYB.GT.NBAS) STOP 'Too many hybrids'
DO 50 I = 1,NBAS
THYB(I,NHYB) = ZERO
50 CONTINUE
IH = 0
DO 70 I = KL,KU
IH = IH + 1
THYB(I,NHYB) = HYB(IH)
70 CONTINUE
HYCOEF(NHYB) = COEF
IF(NHYB.NE.NBAS) RETURN
CALL SVTNHO(THYB)
RETURN
900 FORMAT(/1X,'Hybrid ',I3,' has a ',
+ 'non-negligible overlap of ',F8.5,' with hybrid ',I3,'.')
END
*****************************************************************************
SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
DIMENSION BNDOCC(NDIM),ATCOOR(NATOMS*3),THYB(NDIM,NDIM),
+ TBND(NDIM,NDIM),SCR(NDIM)
DIMENSION ISTR(8),PHYB(3),XYZ(3,2),KHYB(3),AZI(2),POL(2),DEV(2)
DIMENSION ISKIP(2)
DATA LCR,LLP,LRY,LBD,L3C/'CR','LP','RY','BD','3C'/
DATA LHYP/'-'/
DATA ZERO,ONE,THRESH,CUTOFF/0.0D0,1.0D0,1.0D-4,1.0D-8/
Compute hybrid directionality and bond bending for selected NBO's:
Thresholds: ATHR -- Angular deviation threshold
PTHR -- Percentage p-character threshold
ETHR -- Occupancy threshold
CONV = 180.0/(4.0*ATAN(ONE))
WRITE(LFNPR,900) ABS(ATHR),ABS(PTHR),ABS(ETHR)
Get atomic centers, NAO to NHO trans., and NAO to NBO trans.:
CALL FECOOR(ATCOOR)
CALL FETNHO(THYB)
CALL FETNAB(TBND)
CALL TRANSP(TBND,NDIM,NBAS)
CALL MATMLT(TBND,THYB,SCR,NDIM,NBAS)
Loop over NBOs:
ICNT = 0
DO 100 IBAS = 1,NBAS
IB = IBXM(IBAS)
LBL1 = LABEL(IB,1)
LBL2 = LABEL(IB,2)
LBL3 = LABEL(IB,3)
IF(LBL1.EQ.LLP.OR.LBL1.EQ.LRY) NCTR = 1
IF(LBL1.EQ.LBD) NCTR = 2
Skip 3-center orbitals, core orbitals, low occupancy orbitals:
IF(LBL1.EQ.L3C) GO TO 100
IF(LBL1.EQ.LCR) GO TO 100
IF(BNDOCC(IBAS).LT.ABS(ETHR)) GO TO 100
Find the hybrids which contribute to this NBO:
ICTR = 0
DO 10 IHYB = 1,NBAS
IF(ABS(TBND(IBAS,IHYB)).GT.THRESH) THEN
ICTR = ICTR + 1
KHYB(ICTR) = IHYB
END IF
10 CONTINUE
IF(ICTR.NE.NCTR) THEN
WRITE(LFNPR,910) NCTR,IBAS,ICTR
STOP
END IF
Make sure the hybrids are on the proper nuclear centers and compute
the percentage p-character in the hybrid:
DO 30 ICTR = 1,NCTR
IHYB = KHYB(ICTR)
JCTR = LABEL(IB,ICTR+3)
CALL HYBCMP(XYZ(1,ICTR),PHYB(ICTR),IHYB,JCTR,THYB(1,IHYB))
30 CONTINUE
If these hybrids have low p-character, skip them:
ISKIP(1) = 0
ISKIP(2) = 0
IF(NCTR.EQ.1.AND.PHYB(1).LT.ABS(PTHR)) GO TO 100
IF(NCTR.EQ.2) THEN
IF(PHYB(1).LT.ABS(PTHR)) ISKIP(1) = 1
IF(PHYB(2).LT.ABS(PTHR)) ISKIP(2) = 1
IF(ISKIP(1).EQ.1.AND.ISKIP(2).EQ.1) GO TO 100
END IF
Compute the polar and azimuthal angles of each hybrid:
DO 70 ICTR = 1,NCTR
IF(ISKIP(ICTR).EQ.1) GO TO 70
CALL ANGLES(XYZ(1,ICTR),XYZ(2,ICTR),XYZ(3,ICTR),POL(ICTR),
+ AZI(ICTR))
70 CONTINUE
Compute the deviation from the line of nuclear centers for 2-center
orbitals:
IF(NCTR.EQ.2) THEN
ICTR = LABEL(IB,4)
JCTR = LABEL(IB,5)
X = ATCOOR(JCTR*3-2) - ATCOOR(ICTR*3-2)
Y = ATCOOR(JCTR*3-1) - ATCOOR(ICTR*3-1)
Z = ATCOOR(JCTR*3) - ATCOOR(ICTR*3)
IF(ABS(X).LT.CUTOFF) X = ZERO
IF(ABS(Y).LT.CUTOFF) Y = ZERO
IF(ABS(Z).LT.CUTOFF) Z = ZERO
R = SQRT(X*X + Y*Y + Z*Z)
X = X / R
Y = Y / R
Z = Z / R
CALL ANGLES(X,Y,Z,THETA,PHI)
PROJ = XYZ(1,1)*X + XYZ(2,1)*Y + XYZ(3,1)*Z
IF(ABS(PROJ-ONE).LT.CUTOFF) THEN
DEV(1) = ZERO
ELSE IF(ABS(PROJ+ONE).LT.CUTOFF) THEN
DEV(1) = 180.0
ELSE IF(PROJ.LT.ONE.AND.PROJ.GT.-ONE) THEN
DEV(1) = ACOS(PROJ) * CONV
DEV(1) = ABS(DEV(1))
ELSE
STOP 'ArcCosine out of bounds in SR HYBDIR'
END IF
PROJ = XYZ(1,2)*X + XYZ(2,2)*Y + XYZ(3,2)*Z
IF(ABS(PROJ-ONE).LT.CUTOFF) THEN
DEV(2) = 180.0
ELSE IF(ABS(PROJ+ONE).LT.CUTOFF) THEN
DEV(2) = ZERO
ELSE IF(PROJ.LT.ONE.AND.PROJ.GT.-ONE) THEN
DEV(2) = ACOS(PROJ) * CONV
DEV(2) = ABS(ABS(DEV(2)) - 180.0)
ELSE
STOP 'ArcCosine out of bounds in SR HYBDIR'
END IF
IF(DEV(1).LT.ABS(ATHR)) ISKIP(1) = 1
IF(DEV(2).LT.ABS(ATHR)) ISKIP(2) = 1
IF(ISKIP(1).EQ.1.AND.ISKIP(2).EQ.1) GO TO 100
END IF
Write out directionality info:
ICNT = ICNT + 1
ISTR(1) = LBL1
ISTR(2) = LBL2
ISTR(3) = LBL3
ISTR(4) = NAMEAT(IATNO(LABEL(IB,4)))
ISTR(5) = LABEL(IB,4)
IF(NCTR.EQ.2) THEN
ISTR(6) = LHYP
ISTR(7) = NAMEAT(IATNO(LABEL(IB,5)))
ISTR(8) = LABEL(IB,5)
IF(ISKIP(1).EQ.1) THEN
WRITE(LFNPR,940) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(2),
+ AZI(2),DEV(2)
ELSE IF(ISKIP(2).EQ.1) THEN
WRITE(LFNPR,950) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(1),
+ AZI(1),DEV(1)
ELSE
WRITE(LFNPR,960) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(1),
+ AZI(1),DEV(1),POL(2),AZI(2),DEV(2)
END IF
ELSE
WRITE(LFNPR,970) IBAS,(ISTR(I),I=1,5),POL(1),AZI(1)
END IF
100 CONTINUE
IF(ICNT.EQ.0) WRITE(LFNPR,980)
RETURN
900 FORMAT(//1X,'NHO Directionality and "Bond Bending" (deviations ',
+ 'from line of nuclear centers)',//1X,' [Thresholds for ',
+ 'printing: angular deviation > ',F4.1,' degree]',/1X,
+ ' hybrid p-character > ',F4.1,
+ '%',/1X,' orbital occupancy ',
+ '> ',F4.2,'e',//1X,' Line of Centers ',
+ ' Hybrid 1 Hybrid 2',/1X,' ',
+ '--------------- ------------------- ------------------',/1X,
+ ' NBO Theta Phi Theta Phi Dev ',
+ 'Theta Phi Dev',/1X,'=====================================',
+ '==========================================')
910 FORMAT(/1X,'Error: the ',I1,'-center NBO ',I3,' has ',
+ 'contributions from ',I2,' atomic centers.')
940 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1,
+ ' -- -- -- ',F5.1,2X,F5.1,1X,F5.1)
950 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1,
+ 3X,F5.1,2X,F5.1,1X,F5.1,' -- -- --')
960 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1,
+ 3X,F5.1,2X,F5.1,1X,F5.1,4X,F5.1,2X,F5.1,1X,F5.1)
970 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,' -- --',4X,
+ F5.1,2X,F5.1,' -- -- -- --')
980 FORMAT(1X,' None exceeding thresholds')
END
*****************************************************************************
SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION XYZ(3),HYB(1)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DATA ZERO,THRESH,CUTOFF/0.0D0,1.0D-4,1.0D-8/
Add the px,py,pz components of this hybrid vectorially and determine
its percentage p-character:
XYZ(1) = ZERO
XYZ(2) = ZERO
XYZ(3) = ZERO
PCENT = ZERO
HNORM = ZERO
Make sure this hybrid is situated on the correct atom, JCTR:
JMAX = 1
TMAX = ABS(HYB(1))
DO 10 INAO = 2,NBAS
IF(ABS(HYB(INAO)).GT.TMAX) THEN
JMAX = INAO
TMAX = ABS(HYB(INAO))
END IF
10 CONTINUE
IF(NAOC(JMAX).NE.JCTR) THEN
WRITE(LFNPR,920) IHYB,JCTR,NAOC(JMAX)
STOP
END IF
Find the sign of the largest s-component of this hybrid:
JMAX = 0
TMAX = ZERO
DO 20 INAO = 1,NBAS
L = NAOA(INAO)/100
IF(L.EQ.0.AND.ABS(HYB(INAO)).GT.TMAX) THEN
JMAX = INAO
TMAX = ABS(HYB(INAO))
END IF
20 CONTINUE
If the sign of the largest s-component is negative, change the
phase of this hybrid:
IF(JMAX.NE.0.AND.HYB(JMAX).LT.-THRESH) THEN
DO 30 INAO = 1,NBAS
HYB(INAO) = -HYB(INAO)
30 CONTINUE
ENDIF
Sum the px,py,pz components of this hybrid, determine the percent
p-character:
DO 40 INAO = 1,NBAS
IF(NAOC(INAO).EQ.JCTR) THEN
L = NAOA(INAO)/100
IF(L.EQ.1) THEN
PCENT = PCENT + HYB(INAO)*HYB(INAO)
M = MOD(NAOA(INAO),50)
XYZ(M) = XYZ(M) + HYB(INAO)
END IF
HNORM = HNORM + HYB(INAO)*HYB(INAO)
END IF
40 CONTINUE
IF(HNORM.LT.THRESH) THEN
WRITE(LFNPR,930) JCTR,IHYB
STOP
END IF
PCENT = PCENT/HNORM * 100.0
Normalize the px,py,pz vector:
HNORM = ZERO
DO 50 IX = 1,3
IF(ABS(XYZ(IX)).LT.CUTOFF) XYZ(IX) = ZERO
HNORM = HNORM + XYZ(IX)*XYZ(IX)
50 CONTINUE
HNORM = SQRT(HNORM)
IF(ABS(HNORM).LT.CUTOFF) THEN
PCENT = ZERO
ELSE
DO 60 IX = 1,3
XYZ(IX) = XYZ(IX)/HNORM
60 CONTINUE
END IF
RETURN
920 FORMAT(/1X,'Expected to find hybrid ',I3,' on nuclear center ',
+ I2,' rather than center ',I2,'.')
930 FORMAT(/1X,'The atomic orbitals on nuclear center ',I2,' do not ',
+ 'contribute to hybrid ',I3,'.')
END
*****************************************************************************
SUBROUTINE FNDMOL(IATOMS)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM),
+ NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION IATOMS(NATOMS)
LOGICAL BDFIND
FIND MOLECULAR UNITS : Modified algorithm replacing original which
had problems with determining molecular units for odd numberings of
atoms. (E. Glendening 3/12/88)
NMOLEC = 0
DO 20 I = 1,NATOMS
MOLAT(I) = 0
DO 10 J = 1,NATOMS
MOLEC(I,J) = 0
10 CONTINUE
20 CONTINUE
DO 30 I = 1,NATOMS
IATOMS(I) = I
30 CONTINUE
LATOMS = NATOMS
40 CONTINUE
NMOLEC = NMOLEC+1
MOLAT(NMOLEC) = 1
MOLEC(NMOLEC,1) = IATOMS(1)
LATOMS = LATOMS-1
IF(LATOMS.NE.0) THEN
DO 50 I = 1,LATOMS
IATOMS(I) = IATOMS(I+1)
50 CONTINUE
IAT = 1
60 CONTINUE
I = 1
70 CONTINUE
IF(BDFIND(MOLEC(NMOLEC,IAT),IATOMS(I))) THEN
MOLAT(NMOLEC) = MOLAT(NMOLEC)+1
MOLEC(NMOLEC,MOLAT(NMOLEC)) = IATOMS(I)
LATOMS = LATOMS-1
IF(I.LE.LATOMS) THEN
DO 80 J = I,LATOMS
IATOMS(J) = IATOMS(J+1)
80 CONTINUE
END IF
ELSE
I = I+1
END IF
IF(I.LE.LATOMS) GOTO 70
IAT = IAT+1
IF(IAT.LE.MOLAT(NMOLEC).AND.LATOMS.NE.0) GOTO 60
END IF
IF(LATOMS.GT.0) GOTO 40
SORT ATOMS IN MOLECULAR UNITS:
DO 110 I = 1,NMOLEC
DO 100 J = 1,MOLAT(I)-1
DO 90 K = 1,MOLAT(I)-J
IF(MOLEC(I,K).GT.MOLEC(I,K+1)) THEN
ITEMP = MOLEC(I,K)
MOLEC(I,K) = MOLEC(I,K+1)
MOLEC(I,K+1) = ITEMP
END IF
90 CONTINUE
100 CONTINUE
110 CONTINUE
ALPHA SPIN: SAVE BONDING INFO IN NMOLA,MOLATA,MOLECA:
IF(ISPIN.EQ.2) THEN
NMOLA = NMOLEC
DO 610 IMOL = 1,NMOLEC
MOLATA(IMOL) = MOLAT(IMOL)
IMOLAT = MOLAT(IMOL)
DO 600 IATMOL = 1,IMOLAT
MOLECA(IMOL,IATMOL) = MOLEC(IMOL,IATMOL)
600 CONTINUE
610 CONTINUE
BETA SPIN: MAKE SURE THAT BETA MOLECULAR UNITS ARE THE SAME AS ALPHA:
ELSE IF(ISPIN.EQ.-2) THEN
IF(NMOLA.NE.NMOLEC) GO TO 800
DO 730 IMOL = 1,NMOLEC
IMOLAT = MOLAT(IMOL)
IF(IMOLAT.NE.MOLATA(IMOL)) GO TO 800
DO 720 IATMOL = 1,IMOLAT
IF(MOLECA(IMOL,IATMOL).NE.MOLEC(IMOL,IATMOL)) GO TO 800
720 CONTINUE
730 CONTINUE
END IF
RETURN
800 WRITE(LFNPR,1800)
NMOLA = -NMOLA
RETURN
1800 FORMAT(/1X,'The molecular units found in the alpha and beta ',
+ 'manifolds are inequivalent.',/1X,'For labelling purposes, ',
+ 'the molecular units of the beta system will be used.')
END
*****************************************************************************
SUBROUTINE NBOCLA(BNDOCC,ACCTHR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),MOLLST(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM),
+ NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM)
DIMENSION BNDOCC(NBAS)
DATA LBD,L3C,LSTAR/2HBD,2H3C,1H*/
DATA THRESH,ONE,ZERO,TWO/1.50D0,1.0D0,0.0D0,2.0D0/
DATA DONTHR/1.0D-1/
CLASSIFY NBOS ACCORDING TO DONOR/ACCEPTOR TYPE:
IF(ACCTHR.LE.ZERO) THEN
ACCTHR = THRESH
IF(ISPIN.NE.0) ACCTHR = ACCTHR - ONE
END IF
IF(ISPIN.NE.0) DONTHR = DONTHR / TWO
MAKE UP LIST MOLLST OF WHICH "MOLECULE" EACH ATOM IS IN:
DO 80 IAT = 1,NATOMS
DO 60 IMOL = 1,NMOLEC
IMOLAT = MOLAT(IMOL)
DO 50 IATMOL = 1,IMOLAT
IF(MOLEC(IMOL,IATMOL).EQ.IAT) GO TO 70
50 CONTINUE
60 CONTINUE
STOP 'ROUTINE NBOCLA'
70 MOLLST(IAT) = IMOL
80 CONTINUE
MAKE UP LISTS OF NBO ORBITALS:
NBOUNI(IBAS) = MOLECULAR UNIT
NBOTYP(IBAS) = NUMBER OF CENTERS (+10 IF A LOW OCCUPANCY LONE PAIR)
(+20 IF AN ANTIBOND/RYDBERG)
DO 200 IBAS = 1,NBAS
IB = IBXM(IBAS)
IAT = LABEL(IB,4)
IMOL = MOLLST(IAT)
NBOUNI(IBAS) = IMOL
LAB = LABEL(IB,1)
NCTR = 1
IF(LAB.EQ.LBD) NCTR = 2
IF(LAB.EQ.L3C) NCTR = 3
NBOTYP(IBAS) = NCTR
IF(LABEL(IB,2).EQ.LSTAR) GO TO 180
IF(BNDOCC(IBAS).GT.ACCTHR) GO TO 200
LOW OCCUPANCY VALENCE ORBITAL
NBOTYP(IBAS) = NCTR + 10
GO TO 200
ANTIBOND/RYDBERG
180 NBOTYP(IBAS) = NCTR + 20
HIGH OCCUPANCY RY* OR BD* ORBITAL
IF(BNDOCC(IBAS).GT.DONTHR) NBOTYP(IBAS) = NCTR + 10
200 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),MOLLST(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM),
+ NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
DIMENSION BNDOCC(NBAS),F(NDIM,NDIM),MOLNBO(2,NBAS,NMOLEC)
DIMENSION INAM(3),JNAM(3),ICH(3,2),JCH(3,2),ISP(3),JSP(3)
DATA LBD/2HBD/,L3C/2H3C/,LBLNK1/1H /,LBLNK2/2H /,LHYP/1H-/
DATA HUNDTH/0.01D0/
DATA AUKCAL/627.51D0/,EVKCAL/23.060D0/
DATA ZERO,ONE,TWO,TEN/0.0D0,1.0D0,2.0D0,1.0D1/
PERFORM 2ND ORDER ANALYSIS OF THE FOCK MATRIX:
ETHR1 IS THE THRESHOLD FOR PRINTING THE INTRAMOLECULAR PERTURBATIONAL
ENERGIES (0.5 KCAL/MOL FOR CLOSED SHELL, 0.25 KCAL/MOL FOR OPEN SHELL)
SIMILARLY, ETHR2 IS THE INTERMOLECULAR THRESHOLD, (0.05 KCAL/MOL).
ETHR1 = ABS(E2THR)
IF(ISPIN.NE.0.AND.E2THR.LT.ZERO) ETHR1 = ETHR1/TWO
ETHR2 = ABS(E2THR)/TEN
IF(ISPIN.NE.0.AND.E2THR.LT.ZERO) ETHR2 = ETHR2/TWO
FETCH THE NBO FOCK MATRIX:
NTRI = NDIM * (NDIM+1)/2
CALL FEFNBO(F)
CALL UNPACK(F,NDIM,NBAS,NTRI)
ANALYZE FOCK MATRIX:
MAKE UP LIST MOLNBO(1,IBAS,IMOL) OF CORE/LP/BOND NBOS IN MOLEC. UNIT IMOL
MOLNBO(2,IBAS,IMOL) OF RYDBERG/ANTIBOND NBOS IN MOLEC. IMOL
DO 200 IMOL = 1,NMOLEC
NOCC = 0
NSTAR = 0
DO 110 IBAS = 1,NBAS
DO 100 I = 1,2
MOLNBO(I,IBAS,IMOL) = 0
100 CONTINUE
110 CONTINUE
DO 150 IBAS = 1,NBAS
IF(IMOL.NE.NBOUNI(IBAS)) GO TO 150
IF(NBOTYP(IBAS).GT.20) GO TO 130
NOCC = NOCC + 1
MOLNBO(1,NOCC,IMOL) = IBAS
IF(NBOTYP(IBAS).LT.10) GO TO 150
130 CONTINUE
NSTAR = NSTAR + 1
MOLNBO(2,NSTAR,IMOL) = IBAS
150 CONTINUE
200 CONTINUE
DETERMINE THE CONVERSION FROM INPUT ENERGY UNITS TO KCAL:
IF(MUNIT.EQ.0) THEN
CONV = AUKCAL
ELSE IF(MUNIT.EQ.1) THEN
CONV = EVKCAL
ELSE
CONV = ONE
END IF
LOOP OVER PAIRS OF UNITS:
WRITE(LFNPR,2700) ETHR1
IF(NMOLEC.GT.1) WRITE(LFNPR,2710) ETHR2
IF(MUNIT.EQ.0) THEN
WRITE(LFNPR,2720)
ELSE IF(MUNIT.EQ.1) THEN
WRITE(LFNPR,2730)
ELSE
WRITE(LFNPR,2740)
END IF
DO 400 IMOL = 1,NMOLEC
DO 400 JMOL = 1,NMOLEC
IF(IMOL.EQ.JMOL) WRITE(LFNPR,2300) IMOL
IF(IMOL.NE.JMOL) WRITE(LFNPR,2400) IMOL,JMOL
ETHRSH = ETHR1
IF(IMOL.NE.JMOL) ETHRSH = ETHR2
NELE = 0
DO 305 IOCC = 1,NBAS
IBAS = MOLNBO(1,IOCC,IMOL)
IF(IBAS.EQ.0) GO TO 305
IB = IBXM(IBAS)
LBL = LABEL(IB,1)
NCTR = 1
IF(LBL.EQ.LBD) NCTR = 2
IF(LBL.EQ.L3C) NCTR = 3
DO 250 I = 1,3
IA = LABEL(IB,I+3)
CALL CONVRT(IA,ICH(I,1),ICH(I,2))
INAM(I) = LBLNK2
IF(IA.GT.0) INAM(I) = NAMEAT(IATNO(IA))
ISP(I) = LHYP
IF(I.GE.NCTR) ISP(I) = LBLNK1
250 CONTINUE
DO 300 JSTAR = 1,NBAS
JBAS = MOLNBO(2,JSTAR,JMOL)
IF(JBAS.EQ.0) GO TO 300
IF(IBAS.EQ.JBAS) GO TO 300
DE = F(JBAS,JBAS) - F(IBAS,IBAS)
IF(DE.LT.HUNDTH) GO TO 300
ABSFIJ = ABS(F(IBAS,JBAS))
EPERT = (ABSFIJ**2)/DE
COMPUTE OCCUPANCY FACTOR TO MULTIPLY BY:
TOTOCC = BNDOCC(IBAS)+BNDOCC(JBAS)
FULLOC = TWO
IF(ISPIN.NE.0) FULLOC = ONE
OCCFAC = TOTOCC
IF(TOTOCC.GT.FULLOC) OCCFAC = TWO * FULLOC - TOTOCC
MULTIPLY EPERT BY SUM OF OCCUPANCIES OF NBOS IBAS AND JBAS:
EPERT = EPERT * OCCFAC
EKCAL = EPERT * CONV
IF(EKCAL.LT.ETHRSH) GO TO 300
NELE = NELE + 1
JB = IBXM(JBAS)
LBL = LABEL(JB,1)
NCTR = 1
IF(LBL.EQ.LBD) NCTR = 2
IF(LBL.EQ.L3C) NCTR = 3
DO 260 J = 1,3
JA = LABEL(JB,J+3)
CALL CONVRT(JA,JCH(J,1),JCH(J,2))
JNAM(J) = LBLNK2
IF(JA.GT.0) JNAM(J) = NAMEAT(IATNO(JA))
JSP(J) = LHYP
IF(J.GE.NCTR) JSP(J) = LBLNK1
260 CONTINUE
WRITE(LFNPR,2800) IBAS,(LABEL(IB,K),K=1,3),
* (INAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,2),
* INAM(3),ICH(3,1),ICH(3,2),
* JBAS,(LABEL(JB,K),K=1,3),
* (JNAM(K),JCH(K,1),JCH(K,2),JSP(K),K=1,2),
* JNAM(3),JCH(3,1),JCH(3,2),
* EKCAL,DE,ABSFIJ
300 CONTINUE
305 CONTINUE
IF(NELE.EQ.0) WRITE(LFNPR,2500)
400 CONTINUE
RETURN
2300 FORMAT(/1X,'within unit ',I2)
2400 FORMAT(/1X,'from unit ',I2,' to unit ',I2)
2500 FORMAT(1X,' None above threshold')
2700 FORMAT(//,1X,'Second Order Perturbation Theory Analysis ',
* 'of Fock Matrix in NBO Basis'//,1X,
* ' Threshold for printing: ',F5.2,' kcal/mol')
2710 FORMAT(1X,' (Intermolecular threshold:',F5.2,' kcal/mol)')
2720 FORMAT(56X,' E(2) E(j)-E(i) F(i,j)'/
* 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X,
* 'kcal/mol a.u. a.u. ',/1X,79('='))
2730 FORMAT(56X,' E(2) E(j)-E(i) F(i,j)'/
* 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X,
* 'kcal/mol e.V. e.V. ',/1X,79('='))
2740 FORMAT(56X,' E(2) E(j)-E(i) F(i,j)'/
* 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X,
* 'kcal/mol kcal kcal ',/1X,79('='))
2800 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1,
* '/',I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1,
* F8.2,F8.2,F9.3)
END
*****************************************************************************
SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL FIRST
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM),
+ NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM)
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION F(NDIM,NDIM),BNDOCC(NDIM),LIST(NDIM),LISTA(NATOMS,2),
+ SCR(1)
DIMENSION ISTR(80),ILAB(9)
DATA ZERO,EPS,TWO,TEN,HUNDRD/0.0D0,5.0D-6,2.0D0,1.0D1,1.0D2/
DATA TENTH/1.0D-1/
DATA LSTAR,LRY/'*','RY'/
Set flag to zero -- Determine strong delocalizations from perturbative
analysis of the NBO Fock matrix:
IFLG = 0
Threshold for printing delocalizations:
THR1 = ABS(E2THR)
IF(ISPIN.NE.0) THR = THR/TWO
THR2 = THR1 / TEN
Get Fock matrix if there is one:
IF(IWFOCK.NE.0) THEN
NTRI = NDIM * (NDIM+1)/2
CALL FEFNBO(F)
CALL UNPACK(F,NDIM,NBAS,NTRI)
END IF
Print summary heading, then loop over molecules:
IF(IWFOCK.NE.0) THEN
WRITE(LFNPR,900)
ELSE
WRITE(LFNPR,910)
END IF
DO 200 IMOL = 1,NMOLEC
Determine the molecular formula, the nuclear charge, and the number of
ECP electrons of this molecular unit:
NAT = 0
MECP = 0
CHARGE = ZERO
DO 20 IAT = 1,MOLAT(IMOL)
KAT = IATNO(MOLEC(IMOL,IAT))
MECP = MECP + FLOAT(KAT - IZNUC(MOLEC(IMOL,IAT)))
CHARGE = CHARGE + FLOAT(KAT)
DO 10 JAT = 1,NAT
IF(LISTA(JAT,1).EQ.KAT) THEN
LISTA(JAT,2) = LISTA(JAT,2) + 1
GO TO 20
END IF
10 CONTINUE
NAT = NAT + 1
LISTA(NAT,1) = KAT
LISTA(NAT,2) = 1
20 CONTINUE
IF(ISPIN.NE.0) MECP = MECP/2
IF(ISPIN.NE.0) CHARGE = CHARGE/TWO
CALL CHEM(NAT,NATOMS,LISTA,NL,ISTR)
WRITE(LFNPR,920) IMOL,(ISTR(I),I=1,NL)
Loop over NBO's on this molecular unit:
OCCLEW = FLOAT(MECP)
OCCNON = ZERO
OCCRYD = ZERO
DO 190 IBAS = 1,NBAS
IF(NBOUNI(IBAS).EQ.IMOL) THEN
IB = IBXM(IBAS)
ILAB(1) = LABEL(IB,1)
ILAB(2) = LABEL(IB,2)
ILAB(3) = LABEL(IB,3)
IPTR = 3
NCTR = MOD(NBOTYP(IBAS),10)
DO 30 ICTR = 1,NCTR
IPTR = IPTR + 2
ILAB(IPTR) = LABEL(IB,ICTR+3)
ILAB(IPTR-1) = NAMEAT(IATNO(ILAB(IPTR)))
30 CONTINUE
OCC = BNDOCC(IBAS)
IF(ILAB(1).EQ.LRY) THEN
OCCRYD = OCCRYD + OCC
ELSE IF(ILAB(2).EQ.LSTAR) THEN
OCCNON = OCCNON + OCC
ELSE
OCCLEW = OCCLEW + OCC
END IF
If there is a Fock matrix, find the orbital energy and principal
delocalizations:
IF(IWFOCK.NE.0) THEN
ENRG = F(IBAS,IBAS)
CALL GETDEL(IBAS,OCC,THR1,THR2,NL,LIST,SCR,F,IFLG)
FIRST = .TRUE.
IL = 0
40 CALL DLCSTR(IBAS,IL,NL,LIST,ML,ISTR)
IF(FIRST) THEN
IF(NCTR.EQ.1) THEN
WRITE(LFNPR,930) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG,
+ (ISTR(J),J=1,ML)
ELSE IF(NCTR.EQ.2) THEN
WRITE(LFNPR,940) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG,
+ (ISTR(J),J=1,ML)
ELSE
WRITE(LFNPR,950) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG,
+ (ISTR(J),J=1,ML)
END IF
FIRST = .FALSE.
ELSE
WRITE(LFNPR,960) (ISTR(J),J=1,ML)
END IF
IF(IL.LT.NL) GO TO 40
Otherwise only write out orbital labels and occupancy:
ELSE
IF(NCTR.EQ.1) THEN
WRITE(LFNPR,930) IBAS,(ILAB(I),I=1,IPTR),OCC
ELSE IF(NCTR.EQ.2) THEN
WRITE(LFNPR,940) IBAS,(ILAB(I),I=1,IPTR),OCC
ELSE
WRITE(LFNPR,950) IBAS,(ILAB(I),I=1,IPTR),OCC
END IF
END IF
END IF
190 CONTINUE
WRITE(LFNPR,970)
TOTAL = OCCLEW + OCCNON + OCCRYD
Make sure the total number of electrons is an integer if there is only
one molecular unit:
IF(NMOLEC.EQ.1) THEN
TOTAL = TOTAL + TENTH
NEL = TOTAL
TOTAL = NEL
OCCRYD = TOTAL - OCCLEW - OCCNON
END IF
Write a summary of the electron population on this molecular unit:
IF(ABS(TOTAL-FLOAT(NINT(TOTAL))).LT.1.0D-5)
+ TOTAL = FLOAT(NINT(TOTAL))
CHARGE = CHARGE - TOTAL
IF(TOTAL.GT.EPS) THEN
PLEW = OCCLEW/TOTAL*HUNDRD
PNON = OCCNON/TOTAL*HUNDRD
PRYD = OCCRYD/TOTAL*HUNDRD
ELSE
PLEW = ZERO
PNON = ZERO
PRYD = ZERO
END IF
WRITE(LFNPR,980) OCCLEW,PLEW
WRITE(LFNPR,990) OCCNON,PNON
WRITE(LFNPR,1000) OCCRYD,PRYD
WRITE(LFNPR,970)
WRITE(LFNPR,1010) IMOL,TOTAL,HUNDRD
WRITE(LFNPR,1020) IMOL,CHARGE
IF(IMOL.LT.NMOLEC) WRITE(LFNPR,*)
200 CONTINUE
RETURN
900 FORMAT(//1X,'Natural Bond Orbitals (Summary):',//53X,'Principal ',
+ 'Delocalizations',/1X,' NBO Occupancy ',
+ ' Energy (geminal,vicinal,remote)',/1X,79('='))
910 FORMAT(//1X,'Natural Bond Orbitals (Summary):',//1X,' ',
+ 'NBO Occupancy ',/1X,40('-'))
920 FORMAT(1X,'Molecular unit ',I2,' ',60A1)
930 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,10X,F9.5,F12.5,4X,28A1)
940 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,'-',A2,I2,5X,F9.5,F12.5,
+ 4X,28A1)
950 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,'-',A2,I2,'-',A2,I2,F9.5,
+ F12.5,4X,28A1)
960 FORMAT(52X,28A1)
970 FORMAT(1X,' -------------------------------')
980 FORMAT(1X,' Total Lewis',F11.5,' (',F8.4,'%)')
990 FORMAT(1X,' Valence non-Lewis',F11.5,' (',F8.4,'%)')
1000 FORMAT(1X,' Rydberg non-Lewis',F11.5,' (',F8.4,'%)')
1010 FORMAT(1X,' Total unit ',I2,F11.5,' (',F8.4,'%)')
1020 FORMAT(1X,' Charge unit ',I2,F11.5)
END
*****************************************************************************
SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
DIMENSION LIST(NDIM),DEL(NDIM),DELOC(NDIM,NDIM)
DATA ZERO,ONE,CUTOFF,TENTH/0.0D0,1.0D0,1.0D-4,0.1D0/
DATA AUKCAL,EVKCAL/627.51,23.060/
Determine the conversion factor to kcal:
IF(MUNIT.EQ.0) THEN
CONV = AUKCAL
ELSE IF(MUNIT.EQ.1) THEN
CONV = EVKCAL
ELSE
CONV = ONE
END IF
Determine the strength of each delocalization:
DO 10 JBO = 1,NBAS
LIST(JBO) = 0
DEL(JBO) = ZERO
10 CONTINUE
NL = 0
IF(OCC.LT.TENTH) RETURN
DO 20 JBO = 1,NBAS
IF(IBO.NE.JBO) THEN
IF(NBOTYP(JBO).GE.10) THEN
DEL(JBO) = DELOC(IBO,JBO)*DELOC(IBO,JBO)
IF(IFLG.EQ.0) THEN
DIV = ABS(DELOC(IBO,IBO)-DELOC(JBO,JBO))
IF(DIV.NE.ZERO) THEN
DEL(JBO) = OCC * DEL(JBO)/DIV * CONV
ELSE
DEL(JBO) = ZERO
END IF
END IF
END IF
IF(DEL(JBO).GT.THR2.AND.NBOUNI(IBO).NE.NBOUNI(JBO)) THEN
NL = NL + 1
LIST(NL) = JBO
ELSE IF(DEL(JBO).GT.THR1) THEN
NL = NL + 1
LIST(NL) = JBO
END IF
END IF
20 CONTINUE
Sort delocalizations:
DO 100 I = 1,NL
DO 90 J = 1,NL-1
KBO = LIST(J)
LBO = LIST(J+1)
IF(DEL(LBO)-DEL(KBO).GT.CUTOFF) THEN
LIST(J) = LBO
LIST(J+1) = KBO
END IF
90 CONTINUE
100 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (MAXCHR = 28, MAXD = 4)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION LIST(NDIM),ISTR(80)
INTEGER IK(MAXD)
DATA ICOMMA,ILEFT,IRIGHT/',','(',')'/
Build a character string (for the NBO summary table) which contains
the delocalization information for NBO # IBO:
ML = 0
10 IL = IL + 1
IF(IL.GT.NL) GO TO 30
CALL IDIGIT(LIST(IL),IK,ND,MAXD)
IF(ML+ND+4.GT.MAXCHR) GO TO 30
IF(ML.NE.0) THEN
ML = ML + 1
ISTR(ML) = ICOMMA
END IF
DO 20 I = 1,ND
ML = ML + 1
ISTR(ML) = IK(I)
20 CONTINUE
ML = ML + 1
ISTR(ML) = ILEFT
ML = ML + 1
ISTR(ML) = IHTYP(IBO,LIST(IL))
ML = ML + 1
ISTR(ML) = IRIGHT
GO TO 10
30 IL = IL - 1
RETURN
END
*****************************************************************************
SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
FORM NATURAL LOCALIZED MOLECULAR ORBITALS FROM DENSITY MATRIX A.
N: ACTUAL DIMENSION OF A,EVEC
NDIM: DECLARED DIMENSION OF A,EVEC
TSYM: SCRATCH
RESON: SQUARES OF DIAGONAL ELEMENTS OF NBO TO NLMO TRANSF, TIMES 100%
IALARM: ALARM THAT THE ORBITAL OCCUPANCIES ARE OUT OF ORDER AND THAT
THE LMO STEP SHOULD BE AVOIDED
THESE VALUES ARE SET:
DIFFER = 1.0D-5
DONE = 1.0D-10 (THIS IS THE PARAMETER FOR CONVERGENCE OF THE OFF-
DIAGONAL MATRIX ELEMENTS.)
EPS = 1.0D-11 (THIS PARAMETER HAS TO DO WITH THE MACHINE PRECISION
AND SHOULD BE SET TO A VALUE BETWEEN "DONE" AND THE
MACHINE PRECISION.)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ZEROJ
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION A(NDIM,NDIM),EVEC(NDIM,1),EVAL(1),TSYM(1),RESON(NDIM)
DIMENSION ROT(2,2)
DIMENSION ILIST(100),JLIST(100),IOFF(100),JOFF(100),IUNIQ(100),
+ JUNIQ(100)
IMPORTANT PARAMETERS:
DATA DIFFER,DONE,EPS/1.0D-5,1.0D-10,1.0D-11/
NOFFMX IS SET TO THE DIMENSION OF VECTORS ILIST,JLIST,IOFF,JOFF,IUNIQ,JUNIQ:
DATA DEGTHR,NOFFMX/1.0D-3,100/
DATA ZERO,ONE,TEN,HUNDRD/0.0D0,1.0D0,10.0D0,100.0D0/
WRITE(LFNPR,8390)
THR1 = ONE - DEGTHR
THR2 = ONE - DEGTHR*5
NTIME = 0
IF THERE IS ONLY ONE BASIS FUNCTION, SOLVE THIS TRIVIAL CASE AND RETURN:
IF(N.GT.1) GO TO 10
EVEC(1,1) = ONE
EVAL(1) = A(1,1)
RETURN
10 CONTINUE
DO 30 J = 1,N
DO 20 I = 1,N
20 EVEC(I,J) = ZERO
30 EVEC(J,J) = ONE
COUNT THE NUMBER OF ELECTRONS AND OCCUPIED ORBITALS:
TOTELE = ZERO
DO 50 I = 1,N
50 TOTELE = TOTELE + A(I,I)
TOTELE = TOTELE + DIFFER
NOCC = TOTELE
IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2)
NVIRST = NOCC + 1
CHECK IF OCCUPANCIES ARE IN ORDER:
IALARM = 0
VIRMAX = ZERO
DO 60 J = NVIRST,N
IF(A(J,J).LT.VIRMAX) GO TO 60
VIRMAX = A(J,J)
60 CONTINUE
OCCMIN = HUNDRD
DO 70 I = 1,NOCC
IF(A(I,I).GT.OCCMIN) GO TO 70
OCCMIN = A(I,I)
70 CONTINUE
X = OCCMIN - VIRMAX
21 OCT 1987. THE FOLLOWING FEATURE OF THE PROGRAM HAS BEEN
TURNED OFF BECAUSE SOMETIMES IT IS NOT POSSIBLE TO DIAGONALIZE
THE NBO DENSITY MATRIX WHEN ONE OF THE ``A'' NBOS IS DEGENERATE
IN OCCUPANCY WITH ONE OR MORE ``B'' NBOS:
THE "ABS(X).LT.DIFFER" PART OF THE NEXT LINE IS INCLUDED SO THAT
NLMOS CAN BE COMPUTED WHEN A NUMBER OF ORBITALS ARE NEARLY
DEGENERATE IN OCCUPANCY, AS FOR INSTANCE IN CLI6, WHERE SIX
LITHIUM LONE PAIRS ARE DEGENERATE BUT ONLY ONE OF THEM CAN
BE PLACED IN THE "OCCUPIED" SET OF NLMOS.
IF(X.GT.ZERO.OR.ABS(X).LT.DIFFER) GO TO 100
THE ABOVE STATEMENT IS REPLACED BY:
IF(X.GT.DIFFER) GO TO 100
OCCUPANCIES OUT OF ORDER:
IALARM = 1
IF(ABS(X).GT.DIFFER) GO TO 80
WRITE(LFNPR,8010)
GO TO 90
80 WRITE(LFNPR,8000)
90 CONTINUE
RETURN
START LOOP:
100 CONTINUE
NTIME = NTIME + 1
FIRST, FIND ELEMENT A(IOCC,JEMT) OF LARGEST MAGNITUDE, OFFTOP:
OFFTOP = ZERO
DO 200 JEMT = NVIRST,N
DO 200 IOCC = 1,NOCC
ABSAIJ = ABS(A(IOCC,JEMT))
IF(ABSAIJ.LT.OFFTOP) GO TO 200
OFFTOP = ABSAIJ
AII = A(IOCC,IOCC)
AJJ = A(JEMT,JEMT)
200 CONTINUE
RETURN IF CONVERGENCE HAS BEEN ACHIEVED:
IF(OFFTOP.LT.DONE) GO TO 900
FIND ALL ELEMENTS DEGENERATE WITH LARGEST ONE, OFFTOP:
(CHECK CORRESPONDING DIAGONAL ELEMENTS ALSO)
NOFF: NUMBER OF DEGENERATE ELEMENTS
IOFF(K),JOFF(K): KTH DEGENERATE ELEMENT
OFFTST = OFFTOP * THR1
AIIL = AII*THR2
AJJL = AJJ*THR2
AIIU = AII/THR2
AJJU = AJJ/THR2
ZEROJ = .FALSE.
IF(AJJ.LT.DIFFER) ZEROJ = .TRUE.
NOFF = 0
DO 250 JEMT = NVIRST,N
DO 250 IOCC = 1,NOCC
ABSAIJ = ABS(A(IOCC,JEMT))
IF(ABSAIJ.LT.OFFTST) GO TO 250
AIII = A(IOCC,IOCC)
AJJJ = A(JEMT,JEMT)
IF((AIII.LT.AIIL).OR.(AIII.GT.AIIU)) GO TO 250
SKIP TEST OF DIAG. ELEM. IF SMALL (.LT.DIFFER):
IF(ZEROJ) GO TO 240
IF((AJJJ.LT.AJJL).OR.(AJJJ.GT.AJJU)) GO TO 250
240 NOFF = NOFF + 1
IOFF(NOFF) = IOCC
JOFF(NOFF) = JEMT
250 CONTINUE
IF(NOFF.LT.NOFFMX) GO TO 260
WRITE(LFNPR,2500) NOFF,NOFFMX
2500 FORMAT(//1X,'NOFF = ',I5,' IS GREATER THAN NOFFMX =',I5,
* /5X,' MUST ABORT NLMO PROCEDURE')
IALARM = 1
RETURN
260 CONTINUE
S = AJJ - AII
ABSS = ABS(S)
IF THE ROTATION IS VERY CLOSE TO 45 DEGREES, SET SIN AND COS TO 1/(ROOT 2)
TEST=EPS*OFFTOP
IF (ABSS.GT.TEST) GO TO 330
S=.707106781D0
C=S
GO TO 340
CALCULATION OF SIN AND COS FOR ROTATION THAT IS NOT VERY CLOSE TO 45 DEGREES
330 T=OFFTOP/S
S=0.25D0/ SQRT(0.25D0+T*T)
JACOBI ROTATION ANGLE: COS=C , SIN=S
C= SQRT(0.5D0+S)
S=2.D0*T*S/C
340 CONTINUE
PRINT STATEMENTS FOR NLMO PROCEDURE DETAILS:
WRITE(LFNPR,9903) OFFTOP,S,C,NOFF
9903 FORMAT(' ****** OFFTOP,S,C,NOFF:',3F14.9,I3)
WRITE(LFNPR,9901) (IOFF(I),I=1,NOFF)
9901 FORMAT(' IOFF:',20I3)
WRITE(LFNPR,9902) (JOFF(I),I=1,NOFF)
9902 FORMAT(' JOFF:',20I3)
SIMPLE 2 BY 2 ROTATION, NO DEGENERACY PROBLEMS:
IF(NOFF.GT.1) GO TO 400
IOCC=IOFF(1)
JEMT=JOFF(1)
IF(A(IOCC,JEMT).LT.ZERO) S=-S
ROT(1,1)=C
ROT(2,2)=C
ROT(1,2)=S
ROT(2,1)=-S
IOFF(2)=JOFF(1)
CALL LIMTRN(A,IOFF,ROT,EVAL,NDIM,N,2,2,0)
ROTATION COMPLETED
DO 380 I=1,N
T=EVEC(I,IOCC)
EVEC(I,IOCC)=C*T-EVEC(I,JEMT)*S
380 EVEC(I,JEMT)=S*T+EVEC(I,JEMT)*C
GO TO 800
400 CONTINUE
NOFF.GT.1:
COMPUTE "AVERAGED" UNITARY TRANSFORMATION SO THAT SYMMETRY IS PRESERVED
CONSTRUCT UNIQUE LISTS OF ORBITALS INVOLVED:
IUNIQ(L): L-TH UNIQUE OCCUPIED ORB.
NIUNIQ: NO. OF UNIQUE OCC. ORBS
ILIST(L): LOCATION IN THE UNIQUE LIST (IUNIQ) OF THE I VALUE OF THE
L-TH OFFDIAG. ELEMENT
JUNIQ, NJUNIQ, AND JLIST ARE FOR THE EMPTY ORBITALS.
IUNIQ(1)=IOFF(1)
ILIST(1)=1
NIUNIQ=1
DO 500 MOFF=2,NOFF
I=IOFF(MOFF)
IIMAX=MOFF-1
DO 490 II=1,IIMAX
IF(IOFF(II).NE.I) GO TO 490
ILIST(MOFF)=ILIST(II)
GO TO 500
490 CONTINUE
NIUNIQ=NIUNIQ+1
ILIST(MOFF)=NIUNIQ
IUNIQ(NIUNIQ)=I
500 CONTINUE
JUNIQ(1)=JOFF(1)
JLIST(1)=NIUNIQ+1
NJUNIQ=1
DO 540 MOFF=2,NOFF
J=JOFF(MOFF)
JJMAX=MOFF-1
DO 530 JJ=1,JJMAX
IF(JOFF(JJ).NE.J) GO TO 530
JLIST(MOFF)=JLIST(JJ)
GO TO 540
530 CONTINUE
NJUNIQ=NJUNIQ+1
JLIST(MOFF)=NJUNIQ+NIUNIQ
JUNIQ(NJUNIQ)=J
540 CONTINUE
NROT=NIUNIQ+NJUNIQ
NROT2=NROT*NROT
N1=NROT2+1
N2=NROT2+N1
CONSTRUCT TSYM:
CALL SYMUNI(TSYM,A,C,S,TSYM(N1),TSYM(N2),EVAL,NROT,
* NIUNIQ,NJUNIQ,
* ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
MAKE IUNIQ INTO A COMPLETE LIST OF THE UNIQUE ORBITALS, AND TRANSFORM
THE NBO TO NLMO TRANSF. (EVEC) AND THE DM (A) BY TSYM:
II=NIUNIQ
DO 700 I=1,NJUNIQ
II=II+1
700 IUNIQ(II)=JUNIQ(I)
CALL LIMTRN(EVEC,IUNIQ,TSYM,EVAL,NDIM,N,NROT,NROT,1)
CALL LIMTRN(A,IUNIQ,TSYM,EVAL,NDIM,N,NROT,NROT,0)
SEE HOW MUCH THE ELEMENTS WERE REDUCED:
DO 750 MOFF=1,NOFF
I=IOFF(MOFF)
J=JOFF(MOFF)
WRITE(LFNPR,9920) I,J,(A(I,J))
9920 FORMAT(' I,J,AIJ:',2I3,F14.9)
750 CONTINUE
800 CONTINUE
TOTELE=ZERO
DO 810 J=1,N
TOTELE=TOTELE+A(J,J)
810 CONTINUE
TOT=NEL
FRACT=TOTELE-TOT
WRITE(LFNPR,7000) NOFF,TOTELE,FRACT
GO TO 100
FINISHED: PLACE OCCUPANCIES IN EVAL AND COUNT UP ELECTRONS:
900 CONTINUE
TOTELE = ZERO
DO 910 J = 1,N
EVAL(J) = A(J,J)
TOTELE = TOTELE + EVAL(J)
X = EVEC(J,J)
RESON(J) = X * X * HUNDRD
910 CONTINUE
TOTP = TOTELE + DIFFER
NEL = TOTP
TOT = NEL
FRACT = ABS(TOTELE-TOT)
IF(FRACT.GT.DIFFER) GO TO 990
FIND THE LARGEST OFF-DIAGONAL DENSITY MATRIX ELEMENT:
AMAX = ZERO
DO 960 J = 2,N
JM1 = J - 1
DO 950 I = 1,JM1
IF(ABS(A(I,J)).LT.AMAX) GO TO 950
AMAX = ABS(A(I,J))
950 CONTINUE
960 CONTINUE
WRITE(LFNPR,9500) AMAX
IF THIS IS A CORRELATED WAVEFUNCTION, RETURN TO THE CALLING ROUTINE:
IF(CI.OR.MCSCF.OR.AUHF) RETURN
FOR SCF WAVEFUNCTIONS, MAKE SURE THIS MATRIX ELEMENT IS SMALL:
IF(AMAX.LT.HUNDRD*HUNDRD*DONE) RETURN
WRITE(LFNPR,9550)
IALARM = 1
RETURN
NON-INTEGER NUMBER OF ELECTRONS:
990 WRITE(LFNPR,9900) DIFFER,TOTELE
WRITE(LFNPR,9600)
WRITE(LFNPR,9610) (EVAL(I),I=1,NBAS)
IALARM = 1
RETURN
8000 FORMAT(/1X,'Highest occupied NBOs are not at the beginning',
+ ' of the NBO list;',/,1X,'The NLMO program is not ',
+ 'currently set up to handle this.')
8010 FORMAT(/1X,'Degeneracy between orbitals in the (a) and (b)',
* ' sets detected;',
* /1X,'NLMO program cannot always handle this situation.')
8390 FORMAT(//1X,'NATURAL LOCALIZED MOLECULAR ORBITAL (NLMO) ',
* 'ANALYSIS:')
9500 FORMAT(/1X,'Maximum off-diagonal element of DM in NLMO basis:',
* E13.5)
9550 FORMAT(/1X,'Something went wrong in the NLMO procedure; density',
* ' matrix of SCF',/1X,'wave function has not been diagonalized')
9600 FORMAT(/1X,'Occupancies of NLMOs:')
9610 FORMAT(/1X,8F10.5)
9900 FORMAT(/1X,'Number of electrons (trace of DM, NLMO basis) is not',
* ' within ',F10.5/' of an integer:',F10.5,' - - PROGRAM ABORT')
END
*****************************************************************************
SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,
* SIAB,NOCC,NAB)
*****************************************************************************
Revision 1.2 88/03/03 11:29:56 reed
To reduce amount of output, deleted some blank lines, commented out print
of atom totals for bond orders, and the atomic contrib. to the NLMO is
only printed if it is greater than 0.01%.
IMPLICIT REAL*8 (A-H,O-Z)
INTEGER UL
LOGICAL CLOSED
PRINT OUT DETAILS OF NAO TO NLMO TRANSFORMATION IN MATRIX T.
REQUIRED INPUT:
NDIM = DECLARED DIMENSIONALITY OF ARRAY T
NBAS = NO. OF ORBITALS = ACTUAL DIMENSION OF T, NAOL
NAOL = INTEGER LIST OF ORBITAL ANG. MOMENTUM TYPE
NAOL(I)/100 = L = Q.N. OF ATOMIC ORBITAL I
IATNO = LIST OF ATOMIC NUMBERS; IATNO(I) IS THE NUCLEAR CHARGE
OF ATOM I AS AN INTEGER
NATOMS = NO. OF ATOMS (NOT INCLUDING GHOSTS) IN THE MOLECULE
IWHYBS = 1 IF HYBRID A.O. COEFFICIENTS ARE TO BE PRINTED,
0 OTHERWISE.
LFNPR = LOGICAL FILE NUMBER FOR PRINTOUT.
NAOCTR = LIST OF ATOMIC CENTERS OF OAO OR NAO BASIS ORBITALS
LABEL = LIST OF BOND ORBITAL LABELS
IBXM = PERMUTATION LIST OF BOND ORBITALS
BNDOCC = LIST OF BOND ORBITAL OCCUPANCIES
ISPIN = 0 FOR CLOSED SHELL
= 2 FOR ALPHA SPIN
=-2 FOR BETA SPIN
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP1(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),OCC(NDIM),RESON(NDIM),
* TS(NDIM),SIAB(NOCC,NAB),ATLMO(NOCC,NATOMS),
* BORDER(NATOMS,NATOMS),OWBORD(NATOMS,NATOMS),
* PCT(5),POW(5),LNAME(5),ISP(3),NAM(3),ICH(3,2)
CHARACTER*80 TITLE
DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/
DATA LNAME/'s','p','d','f','g'/
DATA ZERO,HUNDTH,T99,T99P/0.0D0,1.D-2,99.99D0,99.995D0/
DATA TWO,TENTH,HUNDRD,THR/2.0D0,0.1D0,100.0D0,1.0D-6/
DATA LHYP,LBLNK,L2BLNK/'-',' ',' '/
DATA BOTHR/2.0D-3/
CLOSED=.TRUE.
IF(ISPIN.NE.0) CLOSED=.FALSE.
IF(ISPIN.EQ.0) WRITE(LFNPR,8400)
IF(ISPIN.EQ.2) WRITE(LFNPR,8410)
IF(ISPIN.EQ.-2) WRITE(LFNPR,8420)
WRITE(LFNPR,8000)
WRITE(LFNPR,8100) (LHYP,J=1,79)
LOOP OVER OCCUPIED NLMOS:
DO 900 NLMO=1,NBAS
IF(OCC(NLMO).LT.TENTH) GO TO 900
IB=IBXM(NLMO)
LBL=LABEL(IB,1)
IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR=1
IF(LBL.EQ.LBD) NCTR=2
IF(LBL.EQ.L3C) NCTR=3
DO 110 I=1,3
IA=LABEL(IB,I+3)
CALL CONVRT(IA,ICH(I,1),ICH(I,2))
NAM(I)=L2BLNK
IF(IA.GT.0) NAM(I)=NAMEAT(IATNO(IA))
ISP(I)=LHYP
IF(I.GE.NCTR) ISP(I)=LBLNK
110 CONTINUE
LOOP OVER ATOMIC CENTERS OF BOND ORBITAL NBOND
DO 170 ICTR=1,NCTR
ISP(ICTR)=LHYP
IF(ICTR.EQ.NCTR) ISP(ICTR)=LBLNK
I=LABEL(IB,ICTR+3)
NEL=NAMEAT(IATNO(I))
170 CONTINUE
WRITE(LFNPR,8220) NLMO,OCC(NLMO),RESON(NLMO),(LABEL(IB,K),
+ K=1,3),(NAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3)
IF(OCC(NLMO).LT.TENTH.AND.LBL.EQ.LRY) GO TO 900
LOOP OVER ATOMS: (J COUNTS OVER NAOS)
DO 700 IAT=1,NATOMS
NL=0
DO 200 L=1,5
200 PCT(L)=ZERO
JLOW=LL(IAT)
JHIGH=UL(IAT)
DO 300 J=JLOW,JHIGH
L=NAOL(J)/100+1
COEF=T(J,NLMO)
PCT(L)=PCT(L)+COEF*COEF
300 CONTINUE
PRINT OUT CONTRIBUTION FROM ATOM IAT (AND SAVE IN ATLMO):
NL=L
POL=ZERO
DO 340 L=1,5
340 POL=POL+PCT(L)
IF(NLMO.LE.NOCC) ATLMO(NLMO,IAT)=POL
PCTPOL=POL*HUNDRD
PRINT ONLY CONTRIBUTIONS GREATER THAN 0.01%
IF(PCTPOL.LT.HUNDTH) GO TO 700
DO 350 L=1,5
350 PCT(L)=HUNDRD*PCT(L)/POL
FIND LEADING NON-ZERO CONTRIBUTION TO DETERMINE POW(L) FOR EACH L
LSTD=0
DO 460 L=1,NL
IF(LSTD.GT.0) GO TO 450
POW(L)=ZERO
STD=PCT(L)
IF(STD.LT.HUNDTH) GO TO 460
LSTD=L
450 POW(L)=PCT(L)/STD
IF(POW(L).GT.T99P) POW(L)=T99
460 CONTINUE
NL1=NL
NEL=NAMEAT(IATNO(IAT))
IF(NL1.GT.3) NL1=3
WRITE(LFNPR,8300)
* PCTPOL,NEL,IAT,PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1)
IF(NL.GT.3) WRITE(LFNPR,8310)
* (LNAME(L),POW(L),PCT(L),L=4,NL)
700 CONTINUE
900 CONTINUE
NOW, COMPUTE HYBRID OVERLAPS SIAB:
IF(ORTHO) GOTO 2200
CALL FESNAO(S)
DO 1500 NLMO=1,NOCC
IAB=0
NATM1=NATOMS-1
DO 1400 IAT=1,NATM1
IALOW=LL(IAT)
IAHIGH=UL(IAT)
DO 1100 L=1,NBAS
IF(L.GE.IALOW.AND.L.LE.IAHIGH) GO TO 1100
TS(L)=ZERO
DO 1050 K=IALOW,IAHIGH
1050 TS(L)=TS(L)+T(K,NLMO)*S(K,L)
1100 CONTINUE
IF(IAT.GT.2) GO TO 1130
CALL ALTOUT(TS,1,NDIM,1,NDIM)
1130 CONTINUE
JAT0=IAT+1
DO 1300 JAT=JAT0,NATOMS
IAB=IAB+1
OVP=ZERO
JALOW=LL(JAT)
JAHIGH=UL(JAT)
DO 1200 L=JALOW,JAHIGH
1200 OVP=OVP+TS(L)*T(L,NLMO)
ANORM=SQRT(ATLMO(NLMO,IAT)*ATLMO(NLMO,JAT))
IF(ANORM.LT.THR) GO TO 1250
SIAB(NLMO,IAB)=OVP/ANORM
IF(IAT.GT.2) GO TO 1300
WRITE(LFNPR,9996) JAT,IAB,JALOW,JAHIGH,OVP,ANORM,
* SIAB(NLMO,IAB)
9996 FORMAT(1X,'JAT,IAB,JALOW,JAHIGH,OVP,ANORM,SIAB:',
* /5X,4I3,3F11.6)
GO TO 1300
1250 SIAB(NLMO,IAB)=ZERO
IF(IAT.GT.2) GO TO 1300
WRITE(LFNPR,9996) JAT,IAB,JALOW,JAHIGH,OVP,ANORM,
* SIAB(NLMO,IAB)
1300 CONTINUE
1400 CONTINUE
1500 CONTINUE
NOW WE ARE READY TO COMPUTE BOND ORDERS!
IF(JPRINT(12).NE.0) THEN
IAB=0
NATM1=NATOMS-1
WRITE(LFNPR,9000)
DO 2000 IAT=1,NATM1
JAT0=IAT+1
DO 1900 JAT=JAT0,NATOMS
IAB=IAB+1
SUM=ZERO
OWSUM=ZERO
DO 1800 NLMO=1,NOCC
ALAMA2=ATLMO(NLMO,IAT)
ALAMB2=ATLMO(NLMO,JAT)
OVP=SIAB(NLMO,IAB)
BO=ALAMA2
IF(ALAMB2.LT.ALAMA2) BO=ALAMB2
WRITE(LFNPR,8999) ALAMA2,ALAMB2,BO
8999 FORMAT(1X,'ALAMA2,ALAMB2,BO:',3F14.7)
IF(CLOSED) BO=BO*TWO
OWBO=BO*OVP
IF(OVP.LT.ZERO) BO=-BO
IF(ABS(BO).GT.BOTHR)
* WRITE(LFNPR,9100) IAT,JAT,NLMO,BO,OVP
SUM=SUM+BO
OWSUM=OWSUM+OWBO
1800 CONTINUE
WRITE(LFNPR,9110) SUM,OWSUM
BORDER(IAT,JAT)=SUM
BORDER(JAT,IAT)=SUM
OWBORD(IAT,JAT)=OWSUM
OWBORD(JAT,IAT)=OWSUM
1900 CONTINUE
2000 CONTINUE
ZERO DIAGONAL ELEMENTS!
DO 2020 IAT=1,NATOMS
BORDER(IAT,IAT)=ZERO
2020 OWBORD(IAT,IAT)=ZERO
COMPUTE TOTALS BY ATOM AND PRINT RESULTS:
DO 2100 IAT=1,NATOMS
SUM=ZERO
DO 2050 JAT=1,NATOMS
SUM=SUM+BORDER(IAT,JAT)
2050 CONTINUE
TS(IAT)=SUM
2100 CONTINUE
TITLE = 'Atom-Atom Net Linear NLMO/NPA Bond Orders:'
CALL AOUT(BORDER,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS)
TITLE = 'Linear NLMO/NPA Bond Orders, Totals by Atom:'
CALL AOUT(TS,NATOMS,NATOMS,1,TITLE,0,1)
END IF
2200 CONTINUE
RETURN
8000 FORMAT(1X,'NLMO/Occupancy/Percent from Parent NBO/ Atomic ',
+ 'Hybrid Contributions')
8100 FORMAT(1X,80A1)
8220 FORMAT(1X,I3,'. (',F7.5,') ',F8.4,'% ',A2,A1,'(',I2,')',
+ 3(A2,3A1))
8300 FORMAT(26X,F7.3,'% ',A2,I2,' s(',F6.2,'%)',2(A1,F5.2,'(',
+ F6.2,'%)'))
8310 FORMAT(50X,2(A1,F5.2,'(',F6.2,'%)'))
8400 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ',
* 'in NAO Basis:')
8410 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ',
* 'in NAO Basis, Alpha Spin:')
8420 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ',
* 'in NAO Basis, Beta Spin:')
9000 FORMAT(/1X,'Individual LMO bond orders greater than 0.002',
* ' in magnitude,'/1X,
* 'with the overlap between the hybrids in the NLMO given:',//1X,
* 'Atom I / Atom J / NLMO / Bond Order / Hybrid Overlap /')
9100 FORMAT(1X,I4,I8,2X,I6,F14.7,F16.7)
END
*****************************************************************************
SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL TEST
DM -- NLMO density matrix (input)
T -- AO to NLMO transformation matrix (input)
C -- NBO to NLMO transformation matrix (retrieved from NBODAF)
TNBO -- AO to NBO transformation (retrieved from NBODAF)
DX,DY,DZ -- AO dipole matrices (retrieved from NBODAF)
SCR -- NDIM*NDIM word scratch vector
INDEX -- temporary indexing array
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBDXYZ/XDIP,YDIP,ZDIP,CHARGE(MAXATM)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORB(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),C(NDIM,NDIM),TNBO(NDIM,NDIM),
+ DX(NDIM,NDIM),DY(NDIM,NDIM),DZ(NDIM,NDIM),SCR(NDIM*NDIM),
+ INDEX(NDIM)
DIMENSION ISTR(14),COUPLE(3)
DATA TENTEN,SMALL,ZERO,TENTH,ONE,TWO/1.0D-10,1.0D-5,0.0D0,0.1D0,
+ 1.0D0,2.0D0/
DATA TOESU/4.803242E-10/
DATA IHYPH,IBLNK/1H-,1H /
DEBYE = TOESU / TENTEN
Copy the nuclear charges into CHARGE:
IF(ALPHA.OR..NOT.OPEN) THEN
DO 10 I = 1,NATOMS
CHARGE(I) = IZNUC(I)
10 CONTINUE
END IF
Determine the number of occupied orbitals and make sure that the
occupied NLMOs are at the beginning of the list:
TOT = ZERO
DO 20 I = 1,NBAS
TOT = TOT + DM(I,I)
SCR(I) = DM(I,I)
20 CONTINUE
NEL = TOT + TENTH
TOT = NEL
NOCC = NEL
IF(.NOT.OPEN) NOCC = NOCC/2 + MOD(NOCC,2)
CALL RANK(SCR,NBAS,NDIM,INDEX)
DO 30 I = 1,NOCC
IF(INDEX(I).GT.NOCC) THEN
WRITE(LFNPR,1000)
RETURN
END IF
30 CONTINUE
Determine the occupancy factor:
ETA = TWO
IF(OPEN) ETA = ONE
Compute the electronic contributions to the NBO bond dipole moments:
CALL FETLMO(C)
CALL FETNBO(TNBO)
II = 1
CALL DIPELE(DX,C,TNBO,SCR,ETA,NOCC,II)
IF(II.EQ.0) RETURN
II = 2
CALL DIPELE(DY,C,TNBO,SCR,ETA,NOCC,II)
IF(II.EQ.0) RETURN
II = 3
CALL DIPELE(DZ,C,TNBO,SCR,ETA,NOCC,II)
IF(II.EQ.0) RETURN
Add the nuclear contributions to these bond dipole moments:
CALL DIPNUC(DX,DY,DZ,SCR,ETA,NOCC)
Convert to Debye:
DO 50 I = 1,NOCC
DO 40 J = 1,NBAS
DX(J,I) = DX(J,I) * DEBYE
DY(J,I) = DY(J,I) * DEBYE
DZ(J,I) = DZ(J,I) * DEBYE
40 CONTINUE
50 CONTINUE
Print dipole analysis:
XNBO = ZERO
YNBO = ZERO
ZNBO = ZERO
XNLMO = ZERO
YNLMO = ZERO
ZNLMO = ZERO
DO 100 I = 1,NOCC
IF(I.EQ.1) THEN
IF(ALPHA) WRITE(LFNPR,1010)
IF(BETA) WRITE(LFNPR,1020)
IF(.NOT.OPEN) WRITE(LFNPR,1030)
WRITE(LFNPR,1040) ABS(DTHR)
ELSE
WRITE(LFNPR,1050)
END IF
Build the label for this NBO/NLMO:
IB = IBXM(I)
ISTR(1) = LABEL(IB,1)
ISTR(2) = LABEL(IB,2)
ISTR(3) = LABEL(IB,3)
DO 70 J = 1,3
J4 = 4 * J
IF(LABEL(IB,J+3).EQ.0) THEN
DO 60 K = J4-1,J4+2
ISTR(K) = IBLNK
60 CONTINUE
ELSE
IF(J.NE.1) ISTR(J4-1) = IHYPH
ISTR(J4) = NAMEAT(IATNO(LABEL(IB,J+3)))
CALL CONVRT(LABEL(IB,J+3),ISTR(J4+1),ISTR(J4+2))
END IF
70 CONTINUE
Compute the NLMO bond dipole (the NBO bond dipoles are on the diagonal
of DX,DY,DZ):
X = ZERO
Y = ZERO
Z = ZERO
DO 80 J = 1,NBAS
X = X + DX(J,I)
Y = Y + DY(J,I)
Z = Z + DZ(J,I)
80 CONTINUE
XNBO = XNBO + DX(I,I)
YNBO = YNBO + DY(I,I)
ZNBO = ZNBO + DZ(I,I)
XNLMO = XNLMO + X
YNLMO = YNLMO + Y
ZNLMO = ZNLMO + Z
Compute the net dipole for these orbitals:
TOT = SQRT(DX(I,I)*DX(I,I) + DY(I,I)*DY(I,I) + DZ(I,I)*DZ(I,I))
TOTNLM = SQRT(X*X + Y*Y + Z*Z)
WRITE(LFNPR,1060) I,(ISTR(J),J=1,14),X,Y,Z,TOTNLM,
+ DX(I,I),DY(I,I),DZ(I,I),TOT
Print delocalization terms which are stronger than ABS(DTHR):
ICNT = 0
DO 90 J = 1,NBAS
IF(J.NE.I) THEN
TOT = SQRT(DX(J,I)*DX(J,I) + DY(J,I)*DY(J,I)
+ + DZ(J,I)*DZ(J,I))
IF(TOT.GT.ABS(DTHR)) THEN
ICNT = ICNT + 1
INDEX(ICNT) = J
SCR(ICNT) = TOT
END IF
END IF
90 CONTINUE
DO 95 J = 1,ICNT
DO 94 K = 1,ICNT-J
IF(SCR(K+1)-SCR(K).GT.SMALL) THEN
ITEMP = INDEX(K)
INDEX(K) = INDEX(K+1)
INDEX(K+1) = ITEMP
TEMP = SCR(K)
SCR(K) = SCR(K+1)
SCR(K+1) = TEMP
END IF
94 CONTINUE
95 CONTINUE
DO 96 JJ = 1,ICNT
J = INDEX(JJ)
WRITE(LFNPR,1070) J,DX(J,I),DY(J,I),DZ(J,I),SCR(JJ)
96 CONTINUE
100 CONTINUE
Compute and print the correction for residual nuclear charges:
IF(.NOT.ALPHA) THEN
CALL FECOOR(SCR)
X = ZERO
Y = ZERO
Z = ZERO
TEST = .FALSE.
DO 110 I = 1,NATOMS
IF(ABS(CHARGE(I)).GT.SMALL) TEST = .TRUE.
X = X + SCR(3*I-2) * CHARGE(I) * DEBYE
Y = Y + SCR(3*I-1) * CHARGE(I) * DEBYE
Z = Z + SCR(3*I) * CHARGE(I) * DEBYE
110 CONTINUE
IF(TEST) THEN
TOT = SQRT(X*X + Y*Y + Z*Z)
WRITE(LFNPR,1080) X,Y,Z,TOT,X,Y,Z,TOT
XNBO = XNBO + X
YNBO = YNBO + Y
ZNBO = ZNBO + Z
XNLMO = XNLMO + X
YNLMO = YNLMO + Y
ZNLMO = ZNLMO + Z
END IF
END IF
Print net dipole moments:
TOT = SQRT(XNBO*XNBO + YNBO*YNBO + ZNBO*ZNBO)
TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO)
WRITE(LFNPR,1090) XNLMO,YNLMO,ZNLMO,TOTNLM,XNBO,YNBO,ZNBO,TOT
Compute and print the total delocalization correction:
X = XNLMO - XNBO
Y = YNLMO - YNBO
Z = ZNLMO - ZNBO
TOT = SQRT(X*X + Y*Y + Z*Z)
WRITE(LFNPR,1100) X,Y,Z,TOT
Compute and print the NLMO coupling correction:
TEST = .FALSE.
DO 130 I = 1,NBAS
IF(I.GT.NOCC.AND.ABS(DM(I,I)).GT.SMALL) TEST = .TRUE.
DO 120 J = I+1,NBAS
IF(ABS(DM(J,I)).GT.SMALL) TEST = .TRUE.
120 CONTINUE
130 CONTINUE
IF(TEST) THEN
TOT = ZERO
DO 160 K = 1,3
II = K
CALL FEDXYZ(DX,II)
CALL SIMTRS(DX,T,SCR,NDIM,NBAS)
COUPLE(K) = ZERO
DO 150 I = 1,NBAS
IF(I.LE.NOCC) THEN
COUPLE(K) = COUPLE(K) + (ETA - DM(I,I)) * DX(I,I)
ELSE
COUPLE(K) = COUPLE(K) - DM(I,I) * DX(I,I)
END IF
DO 140 J = I+1,NBAS
COUPLE(K) = COUPLE(K) - TWO * DM(J,I) * DX(J,I)
140 CONTINUE
150 CONTINUE
COUPLE(K) = COUPLE(K) * DEBYE
TOT = TOT + COUPLE(K) * COUPLE(K)
160 CONTINUE
TOT = SQRT(TOT)
WRITE(LFNPR,1110) XNLMO,YNLMO,ZNLMO,TOTNLM,XNLMO,YNLMO,ZNLMO,
+ TOTNLM,(COUPLE(K),K=1,3),TOT
XNLMO = XNLMO + COUPLE(1)
YNLMO = YNLMO + COUPLE(2)
ZNLMO = ZNLMO + COUPLE(3)
TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO)
IF(ALPHA) WRITE(LFNPR,1120) XNLMO,YNLMO,ZNLMO,TOTNLM
IF(BETA) WRITE(LFNPR,1130) XNLMO,YNLMO,ZNLMO,TOTNLM
IF(.NOT.OPEN) WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM
ELSE
IF(ALPHA) WRITE(LFNPR,1120) XNLMO,YNLMO,ZNLMO,TOTNLM,
+ XNLMO,YNLMO,ZNLMO,TOTNLM
IF(BETA) WRITE(LFNPR,1130) XNLMO,YNLMO,ZNLMO,TOTNLM,
+ XNLMO,YNLMO,ZNLMO,TOTNLM
IF(.NOT.OPEN) WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM,
+ XNLMO,YNLMO,ZNLMO,TOTNLM
END IF
Save the alpha spin dipoles:
IF(ALPHA) THEN
XDIP = XNLMO
YDIP = YNLMO
ZDIP = ZNLMO
END IF
Print out the total dipole moment for open shell species:
IF(BETA) THEN
XNLMO = XNLMO + XDIP
YNLMO = YNLMO + YDIP
ZNLMO = ZNLMO + ZDIP
TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO)
WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM
END IF
RETURN
1000 FORMAT(/1X,'The highest occupied NBOs are not at the beginning ',
+ 'of the list.',/1X,'The dipole moment analysis is currently not',
+ ' set up to handle this.')
1010 FORMAT(//1X,'Dipole moment analysis, alpha spin:')
1020 FORMAT(//1X,'Dipole moment analysis, beta spin:')
1030 FORMAT(//1X,'Dipole moment analysis:')
1040 FORMAT(/1X,'[Print threshold: Net dipole >',F5.2,' Debye]',//1X,
+ ' NLMO bond dipole ',
+ 'NBO bond dipole',/1X,' ----------',
+ '--------------- ------------------------',/1X,' ',
+ 'Orbital x y z Total x y ',
+ 'z Total',/1X,79('='))
1050 FORMAT(1X)
1060 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1,1X,4F6.2,
+ 3X,4F6.2)
1070 FORMAT(1X,44X,'deloc ',I3,':',4F6.2)
1080 FORMAT(/1X,' Residual nuclear charge ',4F6.2,' ',4F6.2)
1090 FORMAT(1X,' -----------------------',
+ '-----------------------------',/1X,' Net dipole moment',
+ ' ',4F6.2,' ',4F6.2)
1100 FORMAT(1X,'Delocalization correction ',24X,' ',4F6.2,/1X,
+ ' -----------------------------',
+ '-----------------------')
1110 FORMAT(1X,' Net dipole moment ',4F6.2,' ',4F6.2,/1X,
+ ' NLMO coupling correction ',4F6.2,/1X,' ',
+ ' -------------------------')
1120 FORMAT(1X,' Alpha spin dipole ',4F6.2,' ',4F6.2)
1130 FORMAT(1X,' Beta spin dipole ',4F6.2,' ',4F6.2)
1140 FORMAT(1X,' Total dipole moment ',4F6.2,' ',4F6.2)
END
*****************************************************************************
SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION DXYZ(NDIM,NDIM),C(NDIM,NDIM),T(NDIM,NDIM),SCR(NDIM,NDIM)
Compute the electronic contribution for the x (INDEX=1), y (=2),
and z (=3) components of the dipole:
Get the AO dipole matrix and transform to the NBO basis:
CALL FEDXYZ(DXYZ,INDEX)
IF(INDEX.EQ.0) RETURN
CALL SIMTRS(DXYZ,T,SCR,NDIM,NBAS)
Compute the electronic contribution for doubly occupied, filled NBOs:
DO 30 I = 1,NOCC
SCR(I,I) = -ETA * DXYZ(I,I)
30 CONTINUE
Compute delocalization contributions for each filled NBO:
DO 60 I = 1,NOCC
DO 50 J = 1,NBAS
IF(J.NE.I) THEN
SCR(J,I) = C(J,I) * DXYZ(I,I) - C(I,I) * DXYZ(J,I)
DO 40 K = 1,NBAS
SCR(J,I) = SCR(J,I) - C(K,I) * DXYZ(K,J)
40 CONTINUE
SCR(J,I) = ETA * C(J,I) * SCR(J,I)
END IF
50 CONTINUE
60 CONTINUE
CALL COPY(SCR,DXYZ,NDIM,NBAS,NBAS)
RETURN
END
*****************************************************************************
SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBDXYZ/XDIP,YDIP,ZDIP,CHARGE(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
DIMENSION DX(NDIM,NDIM),DY(NDIM,NDIM),DZ(NDIM,NDIM),
+ ATCOOR(3,NATOMS)
DATA ZERO/0.0D0/
Fetch the atomic coordinates:
CALL FECOOR(ATCOOR)
Calculate the nuclear contributions to the dipole moment:
DO 20 I = 1,NOCC
NCTR = MOD(NBOTYP(I),10)
X = ZERO
Y = ZERO
Z = ZERO
DO 10 J = 1,NCTR
IAT = LABEL(IBXM(I),J+3)
X = X + ATCOOR(1,IAT)
Y = Y + ATCOOR(2,IAT)
Z = Z + ATCOOR(3,IAT)
CHARGE(IAT) = CHARGE(IAT) - ETA/NCTR
10 CONTINUE
X = ETA * X / NCTR
Y = ETA * Y / NCTR
Z = ETA * Z / NCTR
DX(I,I) = DX(I,I) + X
DY(I,I) = DY(I,I) + Y
DZ(I,I) = DZ(I,I) + Z
20 CONTINUE
RETURN
END
*****************************************************************************
ROUTINES CALLED BY SR NATHYB, SR CHOOSE:
SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
FUNCTION IWPRJ(NCTR)
SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD)
SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP)
SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG)
SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI)
SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD)
SUBROUTINE FORMT(T,Q,POL)
SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
*****************************************************************************
SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
Label core, valence, and Rydberg NAO's and deplete DM of the density
of the core orbitals
LOGICAL DETAIL,FIRST
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
+ IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),BORB(MXBO),POL(NDIM,3),
* Q(MXAO,NDIM),HYB(MXAO),BNDOCC(NDIM),ICORE(4),IVAL(4),IANG(5)
DATA ZERO,ONE/0.0D0,1.0D0/
DATA IBLK,ICOR,IRYD/' ','CR','Ryd'/
DATA ICHCOR,ICHVAL/'Cor','Val'/
DATA IANG/'s','p','d','f','g'/
Label NAO's on each center:
DO 10 I = 1,NBAS
LTYP(I) = IRYD
10 CONTINUE
IECP = 0
DO 110 NCTR = 1,NATOMS
CALL CORTBL(NCTR,ICORE,IECP)
CALL VALTBL(NCTR,IVAL)
Loop over s,p,d,f orbitals:
DO 100 L = 0,3
ITYP = IANG(L+1)
LNUM = 2*L + 1
IF(ICORE(L+1).LE.0) GOTO 50
Label core orbitals:
DO 40 M = 1,ICORE(L+1)
DO 30 LA = 1,LNUM
MORB = 0
OCC = -1.0
DO 20 N = 1,NBAS
LM = NAOL(N)
NORB = LM/100
IL = IANG(NORB+1)
NA = MOD(NAOL(N),50)
IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND.
+ DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND.
+ LA.EQ.NA) THEN
MORB = N
OCC = DM(N,N)
END IF
20 CONTINUE
IF(MORB.EQ.0) THEN
WRITE(LFNPR,2500) ITYP,NAMEAT(IATNO(NCTR)),NCTR,
+ (ICORE(I),I=1,4),M,LA
STOP
END IF
LTYP(MORB) = ICHCOR
30 CONTINUE
40 CONTINUE
50 CONTINUE
IF(IVAL(L+1).LE.0) GOTO 90
Label valence orbitals:
DO 80 M = 1,IVAL(L+1)
DO 70 LA = 1,LNUM
MORB = 0
OCC = -1.0
DO 60 N = 1,NBAS
LM = NAOL(N)
NORB = LM/100
IL = IANG(NORB+1)
NA = MOD(NAOL(N),50)
IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND.
+ DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND.
+ LA.EQ.NA) THEN
MORB = N
OCC = DM(N,N)
END IF
60 CONTINUE
IF(MORB.EQ.0) THEN
WRITE(LFNPR,2600) ITYP,NAMEAT(IATNO(NCTR)),NCTR,
+ (IVAL(I),I=1,4),M,LA
STOP
END IF
LTYP(MORB) = ICHVAL
70 CONTINUE
80 CONTINUE
90 CONTINUE
100 CONTINUE
110 CONTINUE
Isolate core orbitals on all atoms, removing their density from the
density matrix:
DO 300 IAT = 1,NATOMS
NB = IUL(IAT) - ILL(IAT) + 1
IAC = 0
FIRST = .TRUE.
DO 290 N = ILL(IAT),IUL(IAT)
IF(LTYP(N).EQ.ICHCOR) THEN
IF(DETAIL.AND.FIRST) THEN
FIRST = .FALSE.
WRITE(LFNPR,1000) IAT
END IF
IAC = IAC + 1
IBD = IBD + 1
DO 280 I = 1,NB
BORB(I) = ZERO
280 CONTINUE
BORB(N-ILL(IAT)+1) = ONE
CALL STASH(BORB,IBD,IAT,0,0,POL,Q,HYB)
LABEL(IBD,1) = ICOR
LABEL(IBD,2) = IBLK
LABEL(IBD,3) = IAC
LABEL(IBD,4) = IAT
BNDOCC(IBD) = DM(N,N)
IF(DETAIL) WRITE(LFNPR,1010) IAC,BNDOCC(IBD)
IF(DETAIL) WRITE(LFNPR,1020) (BORB(I),I=1,NB)
IF(DETAIL) WRITE(LFNPR,1030) IBD,(LABEL(IBD,I),I=1,3)
END IF
290 CONTINUE
300 CONTINUE
Deplete the density matrix of CR orbitals:
CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD)
RETURN
1000 FORMAT(/,1X,'Search of DM block for core orbitals on atom:',I4)
1010 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':')
1020 FORMAT(11X,8F7.4)
1030 FORMAT(11X,'*** NBO accepted: Number',I3,'. Label:',A2,A1,
+ '(',I2,')')
2500 FORMAT(/1X,'Subroutine CORE could not find a ',A1,'-type ',
+ 'core orbital on atom ',A2,I2,'.',/,1X,'ICORE :',4I3,
+ ' M :',I3,' LA :',I3)
2600 FORMAT(/1X,'Subroutine CORE could not find a ',A1,'-type ',
+ 'valence orbital on atom ',A2,I2,'.',/,1X,'IVAL :',4I3,
+ ' M :',I3,' LA :',I3)
END
*****************************************************************************
FUNCTION IWPRJ(NCTR)
*****************************************************************************
DATA NCTR0/0/
RETURN 0 (NO PROJECTION WANTED) IF NCTR IS UNCHANGED, 1 OTHERWISE.
IWPRJ=0
IF(NCTR.EQ.NCTR0) RETURN
IWPRJ=1
NCTR0=NCTR
RETURN
END
*****************************************************************************
SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DEPLETE DENSITY MATRIX DM OF CONTRIBUTION FROM B.O.'BORB':
DM ==> DM - OCC*BORB*BORB(TRANSPOSE).
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
+ IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3),
* BORB(MXBO),BNDOCC(NDIM)
DIMENSION IAT(3)
RESTORE DM FROM T
DO 10 J=1,NBAS
DO 10 I=1,J
DM(I,J)=T(I,J)
10 DM(J,I)=DM(I,J)
MAIN LOOP OVER NBD AVAILABLE BOND ORBITALS:
DO 90 IBD=1,NBD
OCC=BNDOCC(IBD)
FIND ATOMS FOR B.O. #IBD
NCTR=0
DO 20 J=1,3
IAT(J)=LABEL(IBD,J+3)
IF(IAT(J).LE.0) GO TO 30
NCTR=NCTR+1
20 CONTINUE
RECONSTRUCT BORB FOR B.O. #IBD
30 NELM=0
DO 40 ICTR=1,NCTR
IA=IAT(ICTR)
IHYB=IATHY(IBD,ICTR)+ILL(IA)-1
P=POL(IBD,ICTR)
NH=NORBS(IA)
DO 40 IH=1,NH
NELM=NELM+1
40 BORB(NELM)=P*Q(IH,IHYB)
SUBTRACT OCC*BORB*BORB(T) FROM DM
NROW=0
DO 80 ICTR=1,NCTR
IA=IAT(ICTR)
IU=IUL(IA)
IL=ILL(IA)
DO 70 IROW=IL,IU
NROW=NROW+1
NCOL=0
DO 60 JCTR=1,NCTR
JA=IAT(JCTR)
JU=IUL(JA)
JL=ILL(JA)
DO 50 ICOL=JL,JU
NCOL=NCOL+1
50 DM(IROW,ICOL)=DM(IROW,ICOL)-OCC*BORB(NROW)*BORB(NCOL)
60 CONTINUE
70 CONTINUE
80 CONTINUE
90 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
ZERO THE MATRIX 'BLK' AND LOAD IN ATOMIC BLOCKS OF DENSITY
MATRIX 'DM' FOR THE ATOMS LISTED IN 'IAT'
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
+ IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
DIMENSION BLK(MXBO,MXBO),DM(NDIM,NDIM),IAT(3)
DATA ZERO/0.0D0/
IAT(1)=IAT1
IAT(2)=IAT2
IAT(3)=IAT3
ZERO 'BLK'
DO 10 I=1,MXBO
DO 10 J=1,MXBO
10 BLK(I,J)=ZERO
NROW=0
NCOL=0
DO 50 I=1,3
IA=IAT(I)
IF(IA.EQ.0) GO TO 50
IU=IUL(IA)
IL=ILL(IA)
DO 40 IROW=IL,IU
NROW=NROW+1
NCOL=0
DO 30 J=1,3
JA=IAT(J)
IF(JA.EQ.0) GO TO 30
JU=IUL(JA)
JL=ILL(JA)
DO 20 ICOL=JL,JU
NCOL=NCOL+1
BLK(NROW,NCOL)=DM(IROW,ICOL)
20 CONTINUE
30 CONTINUE
40 CONTINUE
50 CONTINUE
NB=NROW
RETURN
END
*****************************************************************************
SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DETERMINE HOW MUCH OF BORB IS COMPOSED OF PREVIOUSLY USED HYBRIDS.
RETURN HYBEXP(I) = EXPECTATION VALUE OF HYBRID "I" IN BORB OVER THE
PROJECTION OPERATOR P FOR THE ATOM OF THE HYBRID.
IF NO HYBRID ON ATOM I CONTRIBUTES TO BORB, HYBEXP(I) = ZERO.
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
+ IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
DIMENSION IAT(3),HYB(MXAO),BORB(MXBO),Q(MXAO,NDIM),P(MXAO,MXAO),
* PK(MXAO,MXAO),VA(MXAO),VB(MXAO),HYBEXP(3)
DATA ZERO,ONE,EPS/0.0D0,1.0D0,1.0D-5/
LOOP OVER ATOMIC HYBRIDS:
IAT(1) = IAT1
IAT(2) = IAT2
IAT(3) = IAT3
KMAX = 0
DO 50 I = 1,3
HYBEXP(I) = ZERO
IA = IAT(I)
IF(IA.EQ.0) GO TO 50
EXTRACT THE ITH ATOMIC HYBRID FROM BORB:
NU = IUL(IA)
NL = ILL(IA)
KMIN = KMAX + 1
KMAX = KMAX + NU - NL + 1
MJ = 0
DO 10 K = KMIN,KMAX
MJ = MJ + 1
HYB(MJ) = BORB(K)
10 CONTINUE
DO HYBRIDS FROM THE ITH ATOM CONTRIBUTE TO BORB?
S = ZERO
DO 20 J = 1,MJ
S = S + HYB(J)**2
20 CONTINUE
IF(S.LT.EPS) GO TO 50
DETERMINE THE PROJECTION EXPECTATION FOR THIS HYBRID:
NH = INO(IA)
IF(NH.EQ.0) THEN
HYBEXP(I) = ONE
ELSE
CALL FRMPRJ(P,IA,Q,NH,PK,VA,VB)
PAV = ZERO
DO 40 J = 1,MJ
DO 30 K = 1,MJ
PAV = PAV + HYB(K) * P(K,J) * HYB(J)
30 CONTINUE
40 CONTINUE
HYBEXP(I) = ABS(PAV) / S
END IF
50 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DECOMPOSE BOND ORBITAL 'BORB' AND STORE CONSTITUENT HYBRIDS IN Q
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
+ IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
DIMENSION POL(NDIM,3),Q(MXAO,NDIM),BORB(MXBO),IAT(3),HYB(MXAO)
DATA ZERO/0.0D0/
LOOP OVER CENTERS:
IAT(1) = IAT1
IAT(2) = IAT2
IAT(3) = IAT3
KMAX = 0
DO 40 I = 1,3
IA = IAT(I)
IF(IA.EQ.0) GO TO 40
NU = IUL(IA)
NL = ILL(IA)
EXTRACT HYBRID FROM BOND ORBITAL FOR ATOM IA:
KMIN = KMAX + 1
KMAX = KMAX + NU - NL + 1
MJ = 0
DO 10 K = KMIN,KMAX
MJ = MJ + 1
HYB(MJ) = BORB(K)
10 CONTINUE
EXTRACT POLARIZATION COEFFICIENT, STORE IN 'POL':
PSQ = ZERO
DO 20 J = 1,MJ
PSQ = PSQ + HYB(J)**2
20 CONTINUE
P = SQRT(PSQ)
POL(IBD,I) = P
ONE MORE HYBRID FOR ATOM IA:
INO(IA) = INO(IA) + 1
NCOL = ILL(IA) + INO(IA) - 1
PLACE NORMALIZED HYBRID IN APPROPRIATE BLOCK OF Q:
NH = NU - NL + 1
DO 30 NROW = 1,NH
IF(P.EQ.ZERO) THEN
Q(NROW,NCOL) = ZERO
ELSE
Q(NROW,NCOL) = HYB(NROW)/P
END IF
30 CONTINUE
IATHY(IBD,I) = INO(IA)
40 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
SYMMETRIC ORTHOGONALIZATION OF AVAILABLE HYBRIDS IN Q:
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ ILU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
DIMENSION Q(MXAO,NDIM),S(MXBO,MXBO),TA(MXAO,MXAO),
* EVAL(MXBO),C(MXBO,MXBO)
DATA ZERO,ONE/0.0D0,1.0D0/
DATA TOOSML/1.0D-4/
TOOSML: "TOO SMALL" -- THRESHOLD FOR AN S MATRIX EIGENVALUE THAT IS TOO
SMALL AND WILL CAUSE NUMERICAL PROBLEMS AND IS INDICATIVE OF NEAR-LINEAR
DEPENDENCY IN THE HYBRIDS:
IALARM = 0
DO 100 IA = 1,NATOMS
IL = LL(IA)
NH = INO(IA)
IF(NH.GT.MXAO) GO TO 800
IF(NH.LE.1) GO TO 100
LOAD IA-BLOCK OF Q INTO TA:
DO 10 J = 1,NH
DO 5 I = 1,MXAO
TA(I,J) = Q(I,IL+J-1)
5 CONTINUE
10 CONTINUE
FORM OVERLAP MATRIX S = TA(TRANSP)*TA:
DO 30 J = 1,NH
DO 25 I = J,NH
TEMP = ZERO
DO 20 K = 1,MXAO
TEMP = TEMP + TA(K,I) * TA(K,J)
20 CONTINUE
S(I,J) = TEMP
S(J,I) = TEMP
25 CONTINUE
30 CONTINUE
DIAGONALIZE OVERLAP MATRIX:
CALL JACOBI(NH,S,EVAL,C,MXBO,MXBO,0)
FORM INVERSE SQUARE ROOT OF S, STORE IN S: (AVOID NUMERICAL PROBLEMS
OF LINEAR DEPENDENCE ("TOO SMALL" EIGENVALUES) BY PRESCREENING THE
EIGENVALUES)
DO 40 I = 1,NH
IF(EVAL(I).LT.TOOSML) GO TO 810
EVAL(I) = ONE / SQRT(EVAL(I))
40 CONTINUE
DO 60 J = 1,NH
DO 55 I = J,NH
TEMP = ZERO
DO 50 K = 1,NH
TEMP = TEMP + EVAL(K) * C(I,K) * C(J,K)
50 CONTINUE
S(I,J) = TEMP
S(J,I) = TEMP
55 CONTINUE
60 CONTINUE
FORM NEW TAP=TA*S**(-1/2), STORE IN C:
DO 80 J = 1,NH
DO 75 I = 1,MXAO
TEMP = ZERO
DO 70 K = 1,NH
TEMP = TEMP + TA(I,K) * S(K,J)
70 CONTINUE
C(I,J) = TEMP
75 CONTINUE
80 CONTINUE
REPLACE ORTHOGONALIZED TA IN ARRAY Q:
DO 90 J = 1,NH
DO 85 I = 1,MXAO
Q(I,IL+J-1) = C(I,J)
85 CONTINUE
90 CONTINUE
100 CONTINUE
SYMMETRIC ORTHOGONALIZATION COMPLETE:
RETURN
SOUND THE ALARM THAT TOO MANY HYBRIDS WERE FOUND ON THIS ATOM:
800 CONTINUE
IALARM = IA
IF(IFLG.EQ.0) WRITE(LFNPR,900) MXAO,IA,NH
RETURN
SOUND THE ALARM THAT THERE ARE TOO MANY HYBRIDS OR THAT THERE IS
LINEAR DEPENDENCY IN THE HYBRIDS!!
810 CONTINUE
IALARM = IA
IF(IFLG.EQ.0) WRITE(LFNPR,910) IA,EVAL(I),TOOSML
RETURN
900 FORMAT(/4X,'Only expected to find',I3,' hybrids on atom',I3,
+ ', but found',I3,'.')
910 FORMAT(/4X,'The hybrids on atom',I3,' are linearly dependent.',
+ ' An eigenvalue (',F10.6,')',/4X,'of the hybrid overlap ',
+ 'matrix is too small (<',F7.5,').')
END
*****************************************************************************
SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
FORM PROJECTION MATRIX P TO ANNIHILATE COMPONENTS OF NK OCCUPIED
HYBRIDS FOR ATOM IA.
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
+ IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
DIMENSION P(MXAO,MXAO),VK(MXAO),PI(MXAO),Q(MXAO,NDIM),
* PK(MXAO,MXAO)
DATA ZERO,ONE/0.0D0,1.0D0/
INITIALIZE P = UNIT MATRIX:
NB = NORBS(IA)
DO 10 J = 1,NB
DO 5 I = 1,J
P(I,J) = ZERO
P(J,I) = ZERO
IF(I.EQ.J) P(I,J) = ONE
5 CONTINUE
10 CONTINUE
FORM PROJECTION MATRIX P = P1*P2*...*PK*...*PNK TO ANNIHILATE
COMPONENTS OF THE NK OCCUPIED HYBRIDS VK: PK = I - VK*VK(T).
LOOP OVER OCCUPIED HYBRIDS VK, K = 1,...,NK:
IF(NK.LE.0) RETURN
EXTRACT OCCUPIED HYBRID VK FROM ARRAY Q:
DO 90 K = 1,NK
ICOL = ILL(IA) + K - 1
DO 30 I = 1,NB
VK(I) = Q(I,ICOL)
30 CONTINUE
FORM PROJECTION MATRIX PK:
DO 40 J = 1,NB
DO 35 I = 1,J
PK(I,J) = -VK(I) * VK(J)
PK(J,I) = PK(I,J)
IF(I.EQ.J) PK(I,J) = PK(I,J) + ONE
35 CONTINUE
40 CONTINUE
ACCUMULATE TOTAL PROJECTOR P(K) = P(K-1)*PK:
DO 80 I = 1,NB
DO 60 J = 1,NB
PI(J) = ZERO
DO 50 L = 1,NB
PI(J) = PI(J) + P(I,L) * PK(L,J)
50 CONTINUE
60 CONTINUE
DO 70 J = 1,NB
P(I,J) = PI(J)
70 CONTINUE
80 CONTINUE
90 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION P(MXAO,MXAO),TA(MXAO,MXAO),DM(NDIM,NDIM),C(MXBO,MXBO),
+ EVAL(MXBO),BORB(MXBO),V(MXBO),BLK(MXBO,MXBO),LARC(NBAS)
DATA ZERO,EPS,PT99,ONE/0.0D0,1.0D-5,0.99D0,1.0D0/
FIRST, FORM SET OF "OPTIMALLY DIAGONAL" UNIT VECTORS TO SPAN RYDBERG SPACE:
NAUG = NORB - NOCC
DO 10 I = 1,NORB
LARC(I) = 0
10 CONTINUE
SELECT PROJECTED NAO UNIT VECTOR FROM PROJECTOR IN P:
DO 300 IPROJ = 1,NAUG
IMAX = 0
PRJMAX = ZERO
DO 80 IAO = 1,NORB
IF(LARC(IAO).NE.0) GO TO 80
PROJ = ABS(P(IAO,IAO))
IF(PROJ.GT.PT99) GO TO 100
IF(PROJ.LT.PRJMAX) GO TO 80
PRJMAX = PROJ
IMAX = IAO
80 CONTINUE
IAO = IMAX
PROJ = PRJMAX
100 CONTINUE
PUT VECTOR IN BORB, NORMALIZE, AND SAVE IN C:
SB = ZERO
DO 120 J = 1,NORB
B = P(IAO,J)
SB = SB + B * B
BORB(J) = B
120 CONTINUE
LARC(IAO) = IPROJ
RNORM = ONE / SQRT(SB)
DO 130 J = 1,NORB
BORB(J) = BORB(J) * RNORM
130 CONTINUE
DO 140 J = 1,NORB
C(J,IPROJ) = BORB(J)
140 CONTINUE
IF(IPROJ.EQ.NAUG) GO TO 300
ADD BORB TO THE PROJECTOR IN P:
DO 150 J = 1,NORB
DO 145 I = 1,J
TA(I,J) = -BORB(I) * BORB(J)
TA(J,I) = TA(I,J)
IF(I.EQ.J) TA(I,I) = TA(I,I) + ONE
145 CONTINUE
150 CONTINUE
DO 200 I = 1,NORB
DO 180 J = 1,NORB
V(J) = ZERO
DO 170 L = 1,NORB
V(J) = V(J) + P(I,L) * TA(L,J)
170 CONTINUE
180 CONTINUE
DO 190 J = 1,NORB
P(I,J) = V(J)
190 CONTINUE
200 CONTINUE
300 CONTINUE
PUT PROJECTED VECTORS IN TA, ORDERED ACCORDING TO THE NAO PARENT:
IAUG = 0
DO 350 IAO = 1,NORB
IF(LARC(IAO).EQ.0) GO TO 350
IAUG = IAUG + 1
ITCOL = LARC(IAO)
DO 330 J = 1,NORB
TA(J,IAUG) = C(J,ITCOL)
330 CONTINUE
350 CONTINUE
LOAD DM BLOCK FOR ATOM IA IN BLK:
CALL LOAD(DM,IA,0,0,BLK,NORB)
FORM BLOCK OF DM IN RYDBERG BASIS IN UPPER CORNER OF BLK:
DO 500 IB = 1,NORB
DO 450 J = 1,NAUG
SUM = ZERO
DO 440 K = 1,NORB
SUM = SUM + BLK(IB,K) * TA(K,J)
440 CONTINUE
V(J) = SUM
450 CONTINUE
DO 480 J = 1,NAUG
BLK(IB,J) = V(J)
480 CONTINUE
500 CONTINUE
DO 550 J = 1,NAUG
DO 520 I = 1,J
SUM = ZERO
DO 510 K = 1,NORB
SUM = SUM + TA(K,I) * BLK(K,J)
510 CONTINUE
V(I) = SUM
520 CONTINUE
DO 530 I = 1,NAUG
BLK(I,J) = V(I)
530 CONTINUE
550 CONTINUE
DO 560 J = 1,NAUG
JJ = J - 1
DO 555 I = 1,JJ
BLK(J,I) = BLK(I,J)
555 CONTINUE
560 CONTINUE
DIAGONALIZE DM:
CALL JACOBI(NAUG,BLK,EVAL,C,MXBO,MXBO,1)
ORDER EIGENVECTORS BY OCCUPANCY (WITHIN EPS), FORM FINAL RYDBERG VECTORS:
DO 570 I = 1,NAUG
LARC(I) = I
570 CONTINUE
NAUG1 = NAUG - 1
DO 620 I = 1,NAUG1
I1 = I + 1
DO 610 J = I1,NAUG
DIFF = EVAL(J) - EVAL(I)
IF(DIFF.LT.EPS) GO TO 610
TEMP = EVAL(I)
EVAL(I) = EVAL(J)
EVAL(J) = TEMP
ITEMP = LARC(I)
LARC(I) = LARC(J)
LARC(J) = ITEMP
610 CONTINUE
620 CONTINUE
DO 700 J = 1,NAUG
LJ = LARC(J)
DO 680 I = 1,NORB
SUM = ZERO
DO 670 K = 1,NAUG
SUM = SUM + TA(I,K) * C(K,LJ)
670 CONTINUE
BLK(I,J) = SUM
680 CONTINUE
700 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL PRINT,FIRST
DIAGONALIZE DENSITY MATRIX IN BASIS OF ORTHONORMAL HYBRIDS FOR
EACH BOND ORBITAL TO FIND NEW POLARIZATION COEFFICIENTS.
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
+ IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION DM(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3),
* BLK(MXBO,MXBO),EVAL(MXBO),C(MXBO,MXBO)
DATA ZERO,PT1,ONE,TWO/0.0D0,0.1D0,1.0D0,2.0D0/
DATA LSTAR/1H*/
FIRST, COUNT NUMBER OF BONDS AND 3C BONDS:
NBOND = 0
N3CB = 0
DO 20 IB = 1,NBAS
IF(LABEL(IB,2).EQ.LSTAR) GO TO 20
IF(LABEL(IB,5).EQ.0) GO TO 20
NBOND = NBOND + 1
IF(LABEL(IB,6).EQ.0) GO TO 20
N3CB = N3CB + 1
20 CONTINUE
IAB+1 IS THE NUMBER OF THE FIRST ANTIBOND IN THE NBO LIST:
IAB = NBAS - NBOND - N3CB
PRINT = JPRINT(5).EQ.1
FIRST = .TRUE.
APCOEF = ONE / SQRT(TWO)
DO 200 IB = 1,NBD
IF(LABEL(IB,2).EQ.LSTAR) GO TO 200
NCTR = 1
IF(LABEL(IB,5).GT.0) NCTR = 2
IF(LABEL(IB,6).GT.0) NCTR = 3
IF(NCTR.EQ.1) GO TO 200
IF(IWAPOL.EQ.0.OR.NCTR.EQ.3) THEN
DO 120 I = 1,NCTR
IA = LABEL(IB,I+3)
NHI = NORBS(IA)
DO 115 J = 1,I
JA = LABEL(IB,J+3)
NHJ = NORBS(JA)
DIJ = ZERO
DO 110 IR = 1,NHI
IRP = ILL(IA)+IR-1
CRI = Q(IR,ILL(IA)+IATHY(IB,I)-1)
DO 105 JS = 1,NHJ
JSP = ILL(JA) + JS - 1
CSJ = Q(JS,ILL(JA)+IATHY(IB,J)-1)
DIJ = DIJ+CRI*CSJ*DM(IRP,JSP)
105 CONTINUE
110 CONTINUE
BLK(I,J) = DIJ
BLK(J,I) = DIJ
115 CONTINUE
120 CONTINUE
DIAGONALIZE 'BLK' AND EXTRACT NEW POLARIZATION COEFFICIENTS
CALL JACOBI(NCTR,BLK,EVAL,C,MXBO,MXBO,0)
CALL RANK(EVAL,NCTR,MXBO,LARC)
MAKE SURE REPOLARIZATION IS NOT TOO DRASTIC (TAKE A LOOK AT THE BOND
ORBITAL ONLY):
S = ZERO
DO 125 I = 1,NCTR
S = S + POL(IB,I) * C(I,LARC(1))
125 CONTINUE
IF(S.LT.PT1.AND.NCTR.EQ.2) THEN
IF(FIRST.AND.PRINT) WRITE(LFNPR,*)
FIRST = .FALSE.
IF(PRINT) WRITE(LFNPR,900) IB,S
IAB = IAB + 1
POL(IAB,1) = POL(IB,2)
POL(IAB,2) = -POL(IB,1)
ELSE
STORE THE NEW POLARIZATION COEFFICIENTS IN POL:
DO 130 I = 1,NCTR
POL(IB,I) = C(I,LARC(1))
130 CONTINUE
IAB = IAB + 1
DO 150 I = 1,NCTR
POL(IAB,I) = C(I,LARC(2))
150 CONTINUE
IF(NCTR.NE.3) GO TO 200
IAB = IAB + 1
DO 160 I = 1,NCTR
POL(IAB,I) = C(I,LARC(3))
160 CONTINUE
END IF
CONSTRAIN BONDS TO BE APOLAR, IF REQUESTED (NOT SET UP TO WORK WITH
3-CENTER BONDS):
ELSE
POL(IB,1) = APCOEF
POL(IB,2) = APCOEF
IAB = IAB + 1
POL(IAB,1) = APCOEF
POL(IAB,2) = -APCOEF
END IF
200 CONTINUE
RETURN
900 FORMAT(1X,'WARNING: significant repolarization of NBO ',I3,' (S=',
+ F7.4,'); REPOL disabled.')
END
*****************************************************************************
SUBROUTINE FORMT(T,Q,POL)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
INTEGER UL
CONSTRUCTION OF FINAL TRANSFORMATION MATRIX T FROM ORTHONORMAL
HYBRIDS; ROWS OF T LABELLED BY NAOS, COLUMNS BY NBOS.
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NAOC(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),IBX(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBNAO/NAOCTR(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION T(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3)
DATA LCR,LLP,LBD,LSTAR,LRY/'CR','LP','BD','*','RY'/
DATA ZERO/0.0D0/
REORDER OCCUPIED NBOS TO PUT LONE AND CORE PAIRS LAST:
NCR = 0
NLP = 0
NBDS = 0
DO 10 NSCAN = 1,NBAS
IF(LABEL(NSCAN,2).EQ.LSTAR) GO TO 10
NBDS = NBDS + 1
IF(LABEL(NSCAN,1).EQ.LLP) NLP = NLP + 1
IF(LABEL(NSCAN,1).EQ.LCR) NCR = NCR + 1
10 CONTINUE
ICR = 0
ILP = 0
IBO = 0
IAB = 0
DO 40 IBD = 1,NBAS
IF(LABEL(IBD,2).EQ.LSTAR) GO TO 30
IF(LABEL(IBD,1).EQ.LCR) GO TO 15
IF(LABEL(IBD,1).EQ.LLP) GO TO 20
PAIR BONDS:
IBO = IBO + 1
IBX(IBD) = IBO
GO TO 40
CORE PAIRS:
15 ICR = ICR + 1
IBX(IBD) = ICR + NBDS - NCR - NLP
GO TO 40
LONE PAIRS AND CORE PAIRS:
20 ILP = ILP + 1
IBX(IBD) = ILP + NBDS - NLP
GO TO 40
ANTIBONDS:
30 IAB = IAB + 1
IBX(IBD) = NBDS + IAB
40 CONTINUE
ZERO TRANSFORMATION ARRAY:
DO 60 I = 1,NBAS
DO 50 J = 1,NBAS
T(I,J) = ZERO
50 CONTINUE
60 CONTINUE
DEPOSIT FINAL BOND ORBITALS IN MATRIX T:
NBO = 0
DO 130 IBD = 1,NBAS
KBD = IBD
IF(LABEL(IBD,2).NE.LSTAR) GO TO 100
IF(LABEL(IBD,1).EQ.LRY) GO TO 100
IF(LABEL(IBD,1).EQ.LLP) GO TO 100
ANTIBOND ORBITALS: SEARCH OCCUPIED ORB. LIST TO GET PROPER HYBRIDS.
SEARCH OCCUPIED BOND ORBS. FOR MATCH WITH ANTIBOND ATOMS:
DO 90 K = 1,NBO
DO 70 I = 4,6
IF(LABEL(K,I).NE.LABEL(IBD,I)) GO TO 90
IF((LABEL(K,3).LE.0).AND.(LABEL(K,1).EQ.LBD)) GO TO 90
70 CONTINUE
NEGATIVE IRNK = LABEL(K,3) MEANS BOND ORBITAL WAS ALREADY USED:
FOUND MATCH; SET LABEL(K,3)<0:
KBD = K
LABEL(KBD,3) = -LABEL(KBD,3)
GO TO 100
90 CONTINUE
COULDN'T FIND MATCH...EXIT:
WRITE(LFNPR,9000) IBD,(LABEL(IBD,JJ),JJ=1,6)
STOP
DEPOSIT BOND ORBITALS IN T MATRIX:
100 CONTINUE
DO 120 I = 1,3
IA = LABEL(IBD,I+3)
IF(IA.EQ.0) GO TO 120
JL = LL(IA)
JU = UL(IA)
IROW = 0
ICOL = JL + IATHY(KBD,I) - 1
DO 110 J = JL,JU
IROW = IROW + 1
JB = IBX(IBD)
110 T(J,JB) = POL(IBD,I) * Q(IROW,ICOL)
120 CONTINUE
IF(IBD.EQ.KBD) NBO = IBD
130 CONTINUE
RESTORE LABEL(I,3) > 0:
DO 140 I = 1,NBAS
IF(LABEL(I,3).LT.0) LABEL(I,3) = -LABEL(I,3)
140 CONTINUE
SET ARRAY IBXM: IBXM(IB) IS THE CURRENT LOCATION OF B.O. # IB:
DO 150 IB = 1,NBAS
I = IBX(IB)
150 IBXM(I) = IB
SET PHASE OF 1-CENTER ORBITALS SUCH THAT THE LARGEST S-TYPE NAO CONTRIBUTION
IS POSITIVE:
DO 200 IB = 1,NBAS
NCTR = 1
DO 160 IL = 5,6
IF(LABEL(IBXM(IB),IL).NE.0) NCTR = NCTR + 1
160 CONTINUE
IF(NCTR.EQ.1) THEN
JMAX = 0
TMAX = -1.0D0
DO 170 IN = 1,NBAS
IF(NAOA(IN).LT.100) THEN
IF(ABS(T(IN,IB)).GT.TMAX) THEN
JMAX = IN
TMAX = ABS(T(IN,IB))
END IF
END IF
170 CONTINUE
IF(JMAX.NE.0) THEN
IF(T(JMAX,IB).LT.-1.0D-4) THEN
DO 180 IN = 1,NBAS
T(IN,IB) = -T(IN,IB)
180 CONTINUE
END IF
END IF
END IF
200 CONTINUE
RETURN
9000 FORMAT(/,1X,'Can''t find bond/antibond match for NBO ',
+ I3,2X,A2,A1,'(',I2,')',3I4)
END
*****************************************************************************
SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
+ DTHR,DLTHR,CHSTHR
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM),
+ N3CTR,I3CTR(10,3)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION GUIDE(NATOMS,NATOMS),BNDOCC(NDIM),TOPO(NATOMS,NATOMS)
SAVE JTER,DEVMIN,RHOMIN,BEST,RHO,JBADL
DATA LCR,LBD,L3C,LLP,LSTAR/2HCR,2HBD,2H3C,2HLP,1H*/
DATA SMALL,ZERO,TENTH,ONE,ONEPT5,THREE,HUNDRD
+ /1.0D-4,0.0D0,0.1D0,1.0D0,1.5D0,3.0D0,1.0D2/
DATA DEVTHR/0.1D0/
DATA JTERMX/9/
Subroutine CYCLES controls the search for an acceptable resonance
structure:
Arguments:
ITER : iteration counter incremented by the calling routine
THRESH : occupancy threshold used in search for NBOs
GUIDE : Wiberg bond index
BNDOCC : array containing the NBO occupancies
TOPO : bond index matrix to be compared with the Wiberg indices
ICONT : control flag (see below)
ITER, GUIDE, and BNDOCC are unaltered by this routine
THRESH is modified by this routine, if the RESONANCE keyword is selected
The TOPO matrix is constructed by this routine
Control flag : (set by this routine)
ICONT = 2 : an acceptable Lewis structure has been found, continue
= 1 : an acceptable Lewis structure has been found, recompute the
NBOs for this structure
= 0 : bogus Lewis structure, terminate search for NBOs
= -1 : occupancy threshold and/or atom ordering have been
changed. Repeat the search for NBOs.
Set atom permuting counter and minimum deviation in GUIDE-TOPO:
IF(ITER.EQ.1) THEN
JTER = 0
ICONT = -1
END IF
JTER = JTER + 1
IF(JTER.EQ.1) DEVMIN = HUNDRD
The minimum occupancy threshold is 1.5e (0.5e for open shell):
THRMIN = ONEPT5
IF(ISPIN.NE.0) THRMIN = THRMIN - ONE
Determine the number of low occupancy orbitals in the Lewis structure:
IBADL = 0
IBADNL = 0
SUMLEW = ZERO
TOTELE = ZERO
DO 10 I = 1,NBAS
TOTELE = TOTELE + BNDOCC(I)
IF(LABEL(IBXM(I),2).NE.LSTAR) THEN
SUMLEW = SUMLEW + BNDOCC(I)
IF(BNDOCC(I).LT.THRESH) IBADL = IBADL + 1
ELSE
IF(BNDOCC(I).GT.ABS(ACCTHR)) IBADNL = IBADNL + 1
END IF
10 CONTINUE
NEL = TOTELE + TENTH
TOTELE = NEL
SUM = TOTELE - SUMLEW
Count the ECP electrons in the Lewis structure:
IF(IPSEUD.NE.0) THEN
MECP = 0
DO 20 IAT = 1,NATOMS
MECP = MECP + IATNO(IAT) - IZNUC(IAT)
20 CONTINUE
IF(ISPIN.NE.0) MECP = MECP/2
SUMLEW = SUMLEW + FLOAT(MECP)
END IF
Keep track of the best Lewis structure found so far:
IF(JTER.EQ.1) RHOMIN = HUNDRD
IF(ITER.EQ.1.OR.SUM.LT.RHO) THEN
BEST = THRESH
RHO = SUM
JBADL = IBADL
DO 25 I = 1,NATOMS
JORDER(I) = IORDER(I)
25 CONTINUE
END IF
Count the number of core, lone pair, and bonding orbitals in this
resonance structure:
MCR = 0
MBD = 0
M3C = 0
MLP = 0
DO 30 I = 1,NBAS
IF(LABEL(I,1).EQ.LCR.AND.LABEL(I,2).NE.LSTAR) MCR = MCR + 1
IF(LABEL(I,1).EQ.LBD.AND.LABEL(I,2).NE.LSTAR) MBD = MBD + 1
IF(LABEL(I,1).EQ.L3C.AND.LABEL(I,2).NE.LSTAR) M3C = M3C + 1
IF(LABEL(I,1).EQ.LLP.AND.LABEL(I,2).NE.LSTAR) MLP = MLP + 1
30 CONTINUE
Build the TOPO matrix from lone pairs and 2- and 3-center bonds:
DO 50 I = 1,NATOMS
DO 40 J = 1,NATOMS
TOPO(I,J) = ZERO
40 CONTINUE
50 CONTINUE
DO 60 I = 1,NBAS
IB = IBXM(I)
IF(LABEL(IB,1).NE.LCR.AND.LABEL(IB,2).NE.LSTAR) THEN
IAT1 = LABEL(IB,4)
NCTR = 1
IAT2 = LABEL(IB,5)
IF(IAT2.NE.0) NCTR = 2
IAT3 = LABEL(IB,6)
IF(IAT3.NE.0) NCTR = 3
IF(NCTR.EQ.1) THEN
TOPO(IAT1,IAT1) = TOPO(IAT1,IAT1) + ONE
ELSE IF(NCTR.EQ.2) THEN
TOPO(IAT1,IAT2) = TOPO(IAT1,IAT2) + ONE
TOPO(IAT2,IAT1) = TOPO(IAT2,IAT1) + ONE
ELSE
TOPO(IAT1,IAT2) = TOPO(IAT1,IAT2) + ONE/THREE
TOPO(IAT2,IAT1) = TOPO(IAT2,IAT1) + ONE/THREE
TOPO(IAT1,IAT3) = TOPO(IAT1,IAT3) + ONE/THREE
TOPO(IAT3,IAT1) = TOPO(IAT3,IAT1) + ONE/THREE
TOPO(IAT2,IAT3) = TOPO(IAT2,IAT3) + ONE/THREE
TOPO(IAT3,IAT2) = TOPO(IAT3,IAT2) + ONE/THREE
END IF
END IF
60 CONTINUE
Determine the largest off-diagonal element of GUIDE-TOPO:
DEV = ZERO
DO 80 J = 2,NATOMS
DO 70 I = 1,J-1
IF(GUIDE(I,J)-TOPO(I,J).GT.DEV) THEN
DEV = GUIDE(I,J) - TOPO(I,J)
IAT = I
JAT = J
END IF
70 CONTINUE
80 CONTINUE
Write info about this resonance structure:
IF(JPRINT(5).EQ.1) THEN
IF(ITER.EQ.1) WRITE(LFNPR,1000)
WRITE(LFNPR,1010) ITER,JTER,ABS(THRESH),SUMLEW,SUM,MCR,MBD,
+ M3C,MLP,IBADL,IBADNL,DEV
END IF
Decide if this structure is acceptable:
* Accept the structure if CHOOSE was employed.
* Accept the structure if there is only one atom.
* Accept the structure if there are no low occupancy Lewis orbitals
and DEV is less than DEVTHR.
* Accept the structure if the NOBOND option was selected.
Good resonance structure:
IF(IBADL.EQ.0.AND.DEV.LT.DEVTHR) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030)
ICONT = 2
RETURN
Only one atom:
ELSE IF(NATOMS.EQ.1) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1035)
ICONT = 2
RETURN
Directed NBO search:
ELSE IF(ICHOOS.EQ.1) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1040)
ICONT = 2
RETURN
NOBOND option selected:
ELSE IF(JPRINT(10).NE.0) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1050)
ICONT = 2
RETURN
END IF
Structure accepted due to the specification of the RESONANCE keyword
or the occupancy threshold. Otherwise, accept the structure only if
there are no high occupancy Lewis orbitals:
IF(ICONT.EQ.1) THEN
IF(THRSET.GE.ZERO) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1060)
ICONT = 2
ELSE IF(JPRINT(14).NE.0) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1070)
ICONT = 2
ELSE IF(IBADL.NE.0) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030)
ICONT = 2
END IF
RETURN
END IF
If DEV.EQ.DEVMIN.AND.SUM.EQ.RHOMIN or too many atoms permutations,
stop atom permutations:
IF((ABS(DEV-DEVMIN).LT.SMALL.AND.ABS(SUM-RHOMIN).LT.SMALL).OR.
+ JTER.GE.JTERMX) THEN
If the occupancy threshold was set by the user, accept the best
structure:
IF(THRSET.GE.ZERO) THEN
IF(ABS(SUM-RHO).LT.SMALL) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1060)
ICONT = 2
ELSE
DO 90 I = 1,NATOMS
IORDER(I) = JORDER(I)
90 CONTINUE
JTER = 0
ICONT = 1
END IF
If the RESONANCE keyword was specified, pick the best resonance structure
for this occupancy threshold, and possibly decrement the threshold and
continue the search:
ELSE IF(JPRINT(14).NE.0) THEN
THRESH = THRESH - TENTH
IF(THRMIN-THRESH.GT.SMALL) THEN
THRESH = THRESH + TENTH
IF(ABS(THRESH-BEST).LT.SMALL.AND.ABS(SUM-RHO).LT.SMALL) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1070)
ICONT = 2
ELSE
DO 100 I = 1,NATOMS
IORDER(I) = JORDER(I)
100 CONTINUE
THRESH = BEST
JTER = 0
ICONT = 1
END IF
ELSE
DO 110 I = 1,NATOMS
IORDER(I) = JORDER(I)
110 CONTINUE
JTER = 0
ICONT = -1
END IF
Otherwise, accept the best structure, but only if it had no Lewis
orbitals with occupancy less than the occupancy threshold:
ELSE
IF(ABS(SUM-RHO).LT.SMALL.AND.IBADL.EQ.0) THEN
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030)
ICONT = 2
ELSE IF(JBADL.EQ.0) THEN
DO 115 I = 1,NATOMS
IORDER(I) = JORDER(I)
115 CONTINUE
JTER = 0
ICONT = 1
ELSE
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
IF(JPRINT(5).EQ.1) WRITE(LFNPR,1080)
ICONT = 0
END IF
END IF
RETURN
Loop through atom ordering to find alternative resonance structures:
ELSE
IF(DEV.LT.DEVMIN) DEVMIN = DEV
IF(SUM.LT.RHOMIN) RHOMIN = SUM
IF(IAT.EQ.IORDER(1).AND.JAT.EQ.IORDER(2)) THEN
DEV1 = ZERO
DO 130 J = 2,NATOMS
DO 120 I = 1,J-1
IF(GUIDE(I,J)-TOPO(I,J).GT.DEV1) THEN
IF((I.NE.IORDER(1).AND.J.NE.IORDER(2)).AND.
+ (J.NE.IORDER(1).AND.I.NE.IORDER(2))) THEN
DEV1 = GUIDE(I,J) - TOPO(I,J)
IAT = I
JAT = J
END IF
END IF
120 CONTINUE
130 CONTINUE
END IF
JFLG = 0
DO 140 I = NATOMS,2,-1
IF(IORDER(I).EQ.JAT) JFLG = 1
IF(JFLG.EQ.1) IORDER(I) = IORDER(I-1)
140 CONTINUE
IORDER(1) = JAT
IFLG = 0
DO 150 I = NATOMS,2,-1
IF(IORDER(I).EQ.IAT) IFLG = 1
IF(IFLG.EQ.1) IORDER(I) = IORDER(I-1)
150 CONTINUE
IORDER(1) = IAT
ICONT = -1
END IF
RETURN
1000 FORMAT(/1X,' Occupancies Lewis ',
+ 'Structure Low High',/1X,' Occ. --------',
+ '----------- ----------------- occ occ',/1X,' Cycle ',
+ ' Thresh. Lewis Non-Lewis CR BD 3C LP (L) ',
+ ' (NL) Dev',/1X,77('='))
1010 FORMAT(1X,I3,'(',I1,')',3X,F5.2,F12.5,F10.5,3X,4I4,2X,I4,3X,I4,
+ 3X,F5.2)
1020 FORMAT(1X,77('-'))
1030 FORMAT(/1X,'Structure accepted: No low occupancy Lewis orbitals')
1035 FORMAT(/1X,'Structure accepted: Only a single atom')
1040 FORMAT(/1X,'Structure accepted: NBOs selected via the $CHOOSE ',
+ 'keylist')
1050 FORMAT(/1X,'Structure accepted: Search for bonds prevented ',
+ 'by NOBOND keyword')
1060 FORMAT(/1X,'Structure accepted: Occupancy threshold (THRESH) ',
+ 'set by user')
1070 FORMAT(/1X,'Structure accepted: RESONANCE keyword permits ',
+ 'strongly delocalized structure')
1080 FORMAT(/1X,'Only strongly delocalized resonance structures can',
+ ' be found.',/1X,'The default procedure is to abort the NBO ',
+ 'search. Include',/1X,'the RESONANCE keyword in the $NBO ',
+ 'keylist to override this test.')
END
*****************************************************************************
ROUTINES CALLED BY SR NLMO:
SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT,
+ NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL)
*****************************************************************************
SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT,
* NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION TSYM(NROT,NROT),A(NDIM,NDIM),BLK(NROT,NROT),
* OVLP(NROT,NROT),EVAL(NROT)
DIMENSION IOFF(NOFF),JOFF(NOFF),ILIST(NOFF),JLIST(NOFF)
DATA ZERO,ONE/0.0D0,1.0D0/
DATA EPS/1.0D-6/
DO 40 I=1,NROT
DO 30 J=1,NROT
30 TSYM(I,J)=ZERO
40 TSYM(I,I)=ONE
DO 60 MOFF=1,NOFF
IOCC=ILIST(MOFF)
JEMT=JLIST(MOFF)
DO 60 I=1,NROT
T=TSYM(I,IOCC)
U=TSYM(I,JEMT)
TSYM(I,IOCC)=COS*T-SIN*U
60 TSYM(I,JEMT)=SIN*T+COS*U
AVERAGE GROUPS OF THE ELEMENTS OF THE TRANSFORMATION MATRIX TSYM
SO THAT THE SYMMETRY INHERENT IN THE DENSITY MATRIX A IS PRESERVED,
MAKING SURE THAT THE RESULTING "AVERAGED" TRANSFORMATION IS UNITARY
JST=NIUNIQ+1
NROT=JST-1+NJUNIQ
AVE. DIAG. ELEM OF OCC ORBS
IF(NIUNIQ.EQ.1) GO TO 140
TOT=ZERO
DO 100 I=1,NIUNIQ
100 TOT=TOT+TSYM(I,I)
AVE=TOT/NIUNIQ
DO 110 I=1,NIUNIQ
110 TSYM(I,I)=AVE
AVE. DIAG. ELEM OF EMPTY ORBS
140 IF(NJUNIQ.EQ.1) GO TO 180
TOT=ZERO
DO 150 J=JST,NROT
150 TOT=TOT+TSYM(J,J)
AVE=TOT/NJUNIQ
DO 160 J=JST,NROT
160 TSYM(J,J)=AVE
ZERO OFFDIAG ELEM BETW OCC ORBS:
180 IF(NIUNIQ.EQ.1) GO TO 240
DO 220 I=2,NIUNIQ
DO 220 J=1,I
IF(I.EQ.J) GO TO 220
TSYM(I,J)=ZERO
TSYM(J,I)=ZERO
220 CONTINUE
ZERO OFFDIAG ELEM BETW EMPTY ORBS:
240 IF(NJUNIQ.EQ.1) GO TO 280
JST2=JST+1
DO 270 I=JST2,NROT
DO 270 J=JST,I
IF(I.EQ.J) GO TO 270
TSYM(I,J)=ZERO
TSYM(J,I)=ZERO
270 CONTINUE
AVE. OFFDIAG ELEM BETW OCC AND EMPTY ORBS (PIVOTED ELEMENTS ONLY):
280 CONTINUE
TOT=ZERO
DO 310 MOFF=1,NOFF
II=ILIST(MOFF)
JJ=JLIST(MOFF)
310 TOT=TOT+ABS(TSYM(II,JJ))+ABS(TSYM(JJ,II))
NOFF2=NOFF*2
AVE=TOT/NOFF2
DO 330 MOFF=1,NOFF
II=ILIST(MOFF)
JJ=JLIST(MOFF)
TSYM(II,JJ)=-AVE
330 TSYM(JJ,II)= AVE
NOW ZERO THE NON-PIVOTED ELEMENTS:
DO 450 I=1,NIUNIQ
DO 440 J=JST,NROT
DO 420 MOFF=1,NOFF
IF(I.EQ.ILIST(MOFF).AND.J.EQ.JLIST(MOFF)) GO TO 440
420 CONTINUE
TSYM(I,J)= ZERO
TSYM(J,I)= ZERO
440 CONTINUE
450 CONTINUE
RENORMALIZE VECTORS:
DO 700 J=1,NROT
TOT=ZERO
DO 650 I=1,NROT
650 TOT=TOT+TSYM(I,J)*TSYM(I,J)
RNORM=SQRT(TOT)
IF(RNORM.GT.EPS) GO TO 680
WRITE(LFNPR,2880) NROT,TOT,EPS,RNORM
2880 FORMAT('NROT,TOT,EPS,RNORM:',I3,3F14.9)
CALL ALTOUT(TSYM,NROT,NROT,NROT,NROT)
STOP
680 CONTINUE
DO 690 I=1,NROT
690 TSYM(I,J)=TSYM(I,J)/RNORM
700 CONTINUE
NOW, MAKE SURE THE SIGNS ARE CORRECT:
DO 800 MOFF=1,NOFF
I=IOFF(MOFF)
J=JOFF(MOFF)
IF(A(I,J).GT.ZERO) GO TO 800
II=ILIST(MOFF)
JJ=JLIST(MOFF)
TSYM(II,JJ)=-TSYM(II,JJ)
TSYM(JJ,II)=-TSYM(JJ,II)
800 CONTINUE
FINALLY, THE CRUCIAL STEP OF SYMMETRICALLY ORTHOGONALIZING THE VECTORS
SO THAT THE TRANSFORMATION IS UNITARY:
CALL SYMORT(OVLP,TSYM,BLK,NROT,NROT,EVAL)
RETURN
END
*****************************************************************************
SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
******************************************************************
SYMORT: SYMMETRIC ORTHOGONALIZATION SUBROUTINE
S: FULL OVERLAP MATRIX (DESTROYED!)
T: VECTORS TO BE ORTHOGED.
N: NUMBER OF VECTORS
NOTE: BLK AND BIGBLK SHARE THE SAME STORAGE BUT ARE
DIMENSIONED DIFFERENTLY.
THE SAME APPLIES FOR S AND SBLK.
******************************************************************
DIMENSION S(N,N),T(NDIM,NDIM),BLK(N,N),EVAL(N)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DATA ZERO,ONE/0.0D0,1.0D0/
IMPORTANT CONSTANTS:
DIAGTH THRESHOLD FOR MATRIX DIAGONALIZATION USED IN
SUBROUTINE JACOBI. IN JACOBI, THIS CONSTANT
IS CALLED "DONETH".
DANGER CRITERION FOR DECIDING THAT THE JOB SHOULD BE
ABORTED DUE TO NUMERICAL PROBLEMS CAUSED BY NEAR
LINEAR DEPENDENCIES IN THE BASIS SET. ALL
EIGENVALUES OF THE WEIGHTED OVERLAP MATRIX MUST
BE GREATER THAN DIAGTH*DANGER.
DATA DIAGTH,DANGER/1.0D-12,1.0D3/
FORM THE INVERSE SQRT OF THE OVERLAP MATRIX OF THE VECTORS:
DO 70 I=1,N
DO 70 J=1,N
SIJ=ZERO
DO 40 K=1,N
40 SIJ=SIJ+T(K,I)*T(K,J)
70 S(I,J)=SIJ
CALL JACOBI(N,S,EVAL,BLK,N,N,0)
SMLEST=ONE
TOOSML=DIAGTH*DANGER
DO 150 I=1,N
EIGENV=EVAL(I)
IF(EIGENV.LT.TOOSML) GO TO 900
EVAL(I)=ONE/SQRT(EIGENV)
IF(EIGENV.LT.SMLEST) SMLEST=EIGENV
150 CONTINUE
DO 170 I=1,N
DO 170 J=1,I
SIJ=ZERO
DO 160 K=1,N
160 SIJ=SIJ+EVAL(K)*BLK(I,K)*BLK(J,K)
S(I,J)=SIJ
170 S(J,I)=SIJ
S NOW CONTAINS THE -0.5 POWER OF THE OVERLAP MATRIX,
AND IS THE ORTHOG. TRANSFORM THAT WE WANT.
NOW, FORM THE TOTAL TRANSFORMATION:
DO 210 I=1,N
DO 200 J=1,N
EVAL(J)=ZERO
DO 200 K=1,N
200 EVAL(J)=EVAL(J)+T(I,K)*S(K,J)
DO 210 J=1,N
210 T(I,J)=EVAL(J)
RETURN
900 WRITE(LFNPR,910) EIGENV,TOOSML
910 FORMAT(/1X,'An eigenvalue of the overlap matrix of the ',
* 'symmetrized Jacobi transf. ',
* 'matrix of ',E13.5,' has been found.'/1X,
* 'This is lower than the allowed threshold of ',E13.5)
STOP
END
*****************************************************************************
NBO ENERGETIC ANALYSIS ROUTINES:
SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE)
SUBROUTINE NBODEL(A,MEMORY,IDONE)
SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE,
+ ISPIN)
SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN)
SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK)
SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL)
*****************************************************************************
SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE)
*****************************************************************************
NBOEAN: CONTROLLER SUBROUTINE TO DO NBO ENERGETIC ANALYSIS
BY FOCK MATRIX DELETION METHOD
A(MEMORY) IS SCRATCH STORAGE
NBOOPT(1) = 2 READ IN NEXT DELETION AND FORM NEW DM
= 3 COMPUTE ENERGY CHANGE FOR THIS DELETION
SET IDONE TO 1 IF NO DELETIONS ARE FOUND:
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR,NEW,SEQ
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION A(MEMORY),NBOOPT(10)
DATA THRNEG/-1.0D-3/
DATA ONE,AUKCAL,EVKCAL/1.0D0,627.51,23.061/
OPEN THE OLD NBO DAF:
NEW = .FALSE.
CALL NBOPEN(NEW,ERROR)
IF(ERROR) THEN
IDONE = 1
RETURN
END IF
CALL FEINFO(A,ISWEAN)
IF NBOOPT(1) = 3, COMPUTE THE ENERGY OF DELETION:
IF(NBOOPT(1).EQ.3) THEN
CALL FEE0(EDEL,ETOT)
ECHANG = EDEL - ETOT
IF(MUNIT.EQ.0) THEN
CONV = AUKCAL
ELSE IF(MUNIT.EQ.1) THEN
CONV = EVKCAL
ELSE
CONV = ONE
END IF
EKCAL = ECHANG * CONV
IF(EKCAL.LT.THRNEG) WRITE(LFNPR,2130)
IF(MUNIT.EQ.0) THEN
WRITE(LFNPR,2100) EDEL,ETOT,ECHANG,EKCAL
ELSE IF(MUNIT.EQ.1) THEN
WRITE(LFNPR,2110) EDEL,ETOT,ECHANG,EKCAL
ELSE
WRITE(LFNPR,2120) EDEL,ETOT,ECHANG,EKCAL
END IF
IDONE = 0
SEQ = .FALSE.
CALL NBCLOS(SEQ)
RETURN
END IF
PERFORM THE NBO ENERGETIC ANALYSIS:
IF ISWEAN IS SET TO 1, SEARCH FOR THE $DEL KEYLIST:
IF(ISWEAN.EQ.1) THEN
CALL DELINP(NBOOPT,IDONE)
IF(IDONE.EQ.1) GOTO 900
ELSE IF(NBOOPT(10).GT.80) THEN
CALL STRTIN(LFNIN)
END IF
ROHF, MCSCF, CI, AND AUHF WAVE FUNCTIONS ARE NOT ACCEPTABLE:
IF(ROHF.OR.MCSCF.OR.CI.OR.AUHF) THEN
IDONE = 1
GOTO 900
END IF
ISPIN = 0
IF(UHF) ISPIN = 2
ALPHA = .FALSE.
BETA = .FALSE.
IF(UHF) ALPHA = .TRUE.
CALL NBODEL(A,MEMORY,IDONE)
IF(IDONE.EQ.1) GOTO 900
IF(UHF) THEN
ISPIN = -2
ALPHA = .FALSE.
BETA = .TRUE.
CALL NBODEL(A,MEMORY,IDONE)
END IF
WRITE(LFNPR,3000)
SEQ = .FALSE.
CALL NBCLOS(SEQ)
RETURN
900 CONTINUE
SEQ = .FALSE.
CALL NBCLOS(SEQ)
RETURN
2100 FORMAT(1X,78('-'),/,3X,
+'Energy of deletion : ',F20.9,/,3X,
+' Total SCF energy : ',F20.9,/,3X,
+' -------------------',/,3X,
+' Energy change : ',F17.6,' a.u., ',F13.3,' kcal/mol'/
+1X,78('-'))
2110 FORMAT(1X,78('-'),/,3X,
+'Energy of deletion : ',F20.9,/,3X,
+' Total SCF energy : ',F20.9,/,3X,
+' -------------------',/,3X,
+' Energy change : ',F17.6,' e.V., ',F13.3,' kcal/mol'/
+1X,78('-'))
2120 FORMAT(1X,78('-'),/,3X,
+'Energy of deletion : ',F13.3,/,3X,
+' Total SCF energy : ',F13.3,/,3X,
+' -------------------',/,3X,
+' Energy change : ',F13.3,' kcal/mol, ',F13.3,' kcal/mol'/
+1X,78('-'))
2130 FORMAT(/,6X,
+'***** WARNING ***** The variational principle has been',/,5X,
+' violated and the above deletion energy is invalid!!',//,5X,
+'Probable cause: A deletion was attempted that did not ',/,5X,
+'have as high symmetry as was employed in the integral',/,5X,
+'and SCF computation. REMEDY: Redo computation without',/,5X,
+'symmetry if this non-symmetry-conserving deletion is still',/,5X,
+'desired.')
3000 FORMAT(/1X,
+'NEXT STEP: Evaluate the energy of the new density matrix',/,1X,
+' that has been constructed from the deleted NBO',/,1X,
+' Fock matrix by doing one SCF cycle.'/)
END
*****************************************************************************
SUBROUTINE NBODEL(A,MEMORY,IDONE)
*****************************************************************************
NBODEL: SUBROUTINE TO DELETE BOND ORBITAL FOCK MATRIX ELEMENTS FOR
A PARTICULAR SPIN CASE:
ISPIN = 0 CLOSED SHELL
2 ALPHA SPIN
-2 BETA SPIN
IDONE IS SET EQUAL TO 1 IF THERE ARE NO MORE DELETIONS,
0 OTHERWISE.
A(MEMORY) IS SCRATCH STORAGE
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL DONE
DIMENSION A(MEMORY),ICH(3,2),INAM(3),ISP(3)
NBO Common Blocks:
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DATA LBD/2HBD/,L3C/2H3C/,LBLNK2/2H /,LBLNK1/1H /,LHYP/1H-/
FNBO : NBO FOCK MATRIX (TRIANGULAR)
TRF : TRUNCATED FOCK MATRIX (SQUARE)
EIGVR : EIGENVECTORS OF FTRUNC
DMNEW : NEW AO DM (FROM TRUNCATION) -- TRIANGULAR
OCC : OCCUPATION VECTOR OF BOND ORBITALS
OCCNEW: OCCUPATION VECTOR OF BOND ORBITALS, AFTER DELETION
TNBO : AO TO NBO TRANSFORMATION MATRIX
SCR : SCRATCH VECTOR
SET UP STORAGE SPACE:
A(N1): OCC
A(N2): OCCNEW
A(N3): TNBO
A(N4): FNBO, EIGVR
A(N5): SCR, TRF, DMNEW
A(N6): SCR
A(N7): IDEL
NSQ = NDIM*NDIM
N1 = 1
N2 = N1 + NDIM
N3 = N2 + NDIM
N4 = N3 + NSQ
N5 = N4 + NSQ
N6 = N5 + NSQ
N7 = N6 + NDIM
NEND = N7 + NSQ
IF(NEND.GT.MEMORY) GO TO 950
CALL FENBO(A(N3),A(N1),A(N5),NELEC)
CALL FEFNBO(A(N4))
DELETE REQUESTED FOCK MATRIX ELEMENTS, FORMING TRUNCATED FOCK MATRIX
IN TRF
IDEL : LIST OF DELETED ORBITALS, ELEMENTS, OR BLOCKS
ITYPE : TYPE OF DELETION: 1 FOR ORBITALS
2 FOR INDIVIDUAL MATRIX ELEMENTS
3 FOR ZEROING INTERSECTION BETWEEN TWO SETS
OF ORBITALS
4 FOR ENTIRE MATRIX BLOCKS
NDEL : NUMBER OF ORBITALS, ELEMENTS OR BLOCKS TO BE DELETED
CALL DELETE(A(N4),A(N5),NDIM,A(N7),NSQ,ITYPE,NDEL,NTRUNC,DONE,
+ ISPIN)
IF NO MORE DELETIONS, EXIT PROGRAM
IF(DONE) GO TO 900
DIAGONALIZE TRUNCATED FOCK MATRIX IN TRF
CALL JACOBI(NTRUNC,A(N5),A(N2),A(N4),NDIM,NDIM,0)
CONSTRUCT NEW DENSITY MATRIX IN DM FROM EIGENVECTORS OF TRF,
IN NBO BASIS:
A(N2): EIGENVALUES OF TRF (ENTERING)
A(N2): NEW NBO ORBITAL OCCUPANCIES (EXITING)
NMOOCC=NELEC
IF(ISPIN.EQ.0) NMOOCC=NELEC/2
CALL NEWDM(A(N5),A(N4),A(N2),NDIM,A(N7),NSQ,NDEL,ITYPE,NMOOCC,
+ ISPIN)
TAKE TRANSPOSE OF T SO THAT IT CAN TRANSFORM THE DENSITY MATRIX
FROM THE NBO BASIS TO THE UNSYMMETRIZED AO BASIS:
CALL TRANSP(A(N3),NDIM,NDIM)
CALL SIMLTR(NDIM,NDIM,A(N5),A(N3),A(N4),A(N6),1)
CALL SVNEWD(A(N5))
WRITE(LFNPR,2200)
WRITE(LFNPR,2700)
DO 500 IBAS=1,NDIM
IB=IBXM(IBAS)
LBL=LABEL(IB,1)
NCTR=1
IF(LBL.EQ.LBD) NCTR=2
IF(LBL.EQ.L3C) NCTR=3
DO 350 I=1,3
IAT=LABEL(IB,I+3)
CALL CONVRT(IAT,ICH(I,1),ICH(I,2))
INAM(I)=LBLNK2
IF(IAT.GT.0) INAM(I)=NAMEAT(IATNO(IAT))
ISP(I)=LHYP
IF(I.GE.NCTR) ISP(I)=LBLNK1
350 CONTINUE
I=N1-1+IBAS
II=N2-1+IBAS
OCCCHG=A(II)-A(I)
WRITE(LFNPR,2800) IBAS,(LABEL(IB,K),K=1,3),
* (INAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3),
* A(I),A(II),OCCCHG
500 CONTINUE
IDONE=0
RETURN
900 CONTINUE
IDONE=1
RETURN
950 CONTINUE
WRITE(LFNPR,9500) NEND,MEMORY
IDONE=1
RETURN
2200 FORMAT(/1X,'Occupations of bond orbitals:')
2700 FORMAT(/7X,'Orbital',19X,'No deletions This deletion Change',
+ /,1X,78('-'))
2800 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',3(A2,3A1),
* 9X,F7.5,8X,F7.5,3X,F8.5)
9500 FORMAT(/1X,'Insufficient memory in subroutine NBODEL:',
* /5X,'Memory needed: ',I10,' Memory available: ',I10,
* /1X,'Deletions halted!')
END
*****************************************************************************
SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE,
+ ISPIN)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR,DONE,EQUAL
LOGICAL DONOR,ACCPTR,LIST1,LIST2
DIMENSION KEYWD(6),F(1),TRF(NDIM,NDIM),IDEL(LEN)
DIMENSION LORB(3),LELE(3),LBLO(3),LDEL(3),LZERO(4),LSAME(4),
* LEND(3),LDESTR(6),LDELOC(5),LNOSTR(6),LATOM(4),
* LNOGEM(5),LNOVIC(5),LALT(4)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DATA ZERO/0.0D0/,ISTAR/1H*/
DATA LDEL/1HD,1HE,1HL/,LZERO/1HZ,1HE,1HR,1HO/,LEND/1HE,1HN,1HD/
DATA LALPHA,LBETA/1HA,1HB/,LSAME/1HS,1HA,1HM,1HE/
DATA LORB,LELE,LBLO/1HO,1HR,1HB,1HE,1HL,1HE,1HB,1HL,1HO/
DATA LDESTR/1HD,1HE,1HS,1HT,1HA,1HR/
DATA LNOSTR/1HN,1HO,1HS,1HT,1HA,1HR/
DATA LDELOC/1HD,1HE,1HL,1HO,1HC/,LATOM/1HA,1HT,1HO,1HM/
DATA LNOVIC/1HN,1HO,1HV,1HI,1HC/,LNOGEM/1HN,1HO,1HG,1HE,1HM/
DATA LALT/1H$,1HE,1HN,1HD/
DATA LG,LV/'g','v'/
THIS SUBROUTINE IS CALLED AT THE START OF EACH DELETION AND READS
IN FROM LFNIN THE INSTRUCTIONS FOR THIS DELETION
NTRUNC= DIMENSION OF FOCK MATRIX AFTER DELETIONS:
NTRUNC=NDIM
WRITE(LFNPR,8700)
COUNT UP NUMBER OF MOLECULAR UNITS, NCHEMU:
NCHEMU=0
DO 1 I=1,NDIM
NUNIT=NBOUNI(I)
IF(NUNIT.GT.NCHEMU) NCHEMU=NUNIT
1 CONTINUE
IF(ISPIN.EQ.0) GO TO 10
IF OPEN SHELL, LOOK FOR FIRST LETTER OF "ALPHA" OR "BETA" KEYWORD:
LENG=3
CALL HFLD(KEYWD,LENG,DONE)
IF(EQUAL(KEYWD,LEND,3)) DONE=.TRUE.
IF(EQUAL(KEYWD,LALT,3)) DONE=.TRUE.
IF(DONE) RETURN
IF((ISPIN.EQ.2).AND.(KEYWD(1).NE.LALPHA)) GO TO 9300
IF((ISPIN.EQ.-2).AND.(KEYWD(1).NE.LBETA)) GO TO 9400
IF(ISPIN.EQ.2) WRITE(LFNPR,8100)
IF(ISPIN.EQ.-2) WRITE(LFNPR,8200)
SEARCH FOR FIRST 3 LETTERS OF "DELETE", "ZERO", "SAME", "DESTAR",
"NOSTAR", "NOGEM", "NOVIC", OR AN END MARK '**':
10 CONTINUE
LENG=3
CALL HFLD(KEYWD,LENG,DONE)
IF(EQUAL(KEYWD,LEND,3)) DONE=.TRUE.
IF(EQUAL(KEYWD,LALT,3)) DONE=.TRUE.
IF(DONE) RETURN
IF BETA DELETIONS ARE THE SAME AS THE ALPHA DELETIONS ALREADY READ IN,
SKIP TO 100:
IF((ISPIN.EQ.-2).AND.EQUAL(KEYWD,LSAME,3)) GO TO 100
IF(EQUAL(KEYWD,LZERO,3)) GO TO 600
IF(EQUAL(KEYWD,LNOVIC,3)) GO TO 3000
IF(EQUAL(KEYWD,LNOGEM,3)) GO TO 3010
IF(EQUAL(KEYWD,LDESTR,3)) GO TO 5000
IF(EQUAL(KEYWD,LNOSTR,3)) GO TO 5500
IF(.NOT.EQUAL(KEYWD,LDEL,3)) GO TO 9000
READ IN NUMBER OF ITEMS TO DELETE, NDEL:
CALL IFLD(NDEL,ERROR)
IF(ERROR) GO TO 9100
READ IN TYPE OF DELETION AND DETERMINE IF IT IS ORBITAL, ELEMENT, OR BLOCK:
(ITYPE STORES THE DELETION TYPE)
CALL HFLD(KEYWD,LENG,DONE)
IF(LENG.LT.3) GO TO 9200
IF(.NOT.EQUAL(KEYWD,LORB,3)) GO TO 20
ITYPE=1
GO TO 80
20 IF(.NOT.EQUAL(KEYWD,LELE,3)) GO TO 30
ITYPE=2
GO TO 80
30 IF(.NOT.EQUAL(KEYWD,LBLO,3)) GO TO 9200
ITYPE=4
80 CONTINUE
NREAD=NUMBER OF NUMBERS THAT MUST BE READ
NREAD=NDEL*ITYPE
READ IN ORBITALS,ELEMENTS, OR BLOCKS:
DO 90 I=1,NREAD
CALL IFLD(IDEL(I),ERROR)
IF(ERROR) GO TO 9500
90 CONTINUE
100 CONTINUE
IF(ITYPE.NE.1) GO TO 200
DELETE NDEL ORBITALS, ADJUSTING NTRUNC ACCORDINGLY:
NTRUNC=NDIM-NDEL
ORDER THE ORBITAL NUMBERS:
CALL ORDER(ISCR1,IDEL,NDEL,NDIM,ISCR2)
WRITE(LFNPR,8610) (IDEL(I),I=1,NDEL)
FILL TRF WITH TRUNCATED FOCK MATRIX, DELETING REQUESTED ORBITALS:
IFF=0
IOUT=1
II=0
DO 140 I=1,NDIM
IF(IOUT.GT.NDEL) GO TO 110
IF(I.NE.IDEL(IOUT)) GO TO 110
IFF=IFF+I
IOUT=IOUT+1
GO TO 140
110 CONTINUE
II=II+1
JOUT=1
JJ=0
DO 130 J=1,I
IF(JOUT.GT.NDEL) GO TO 120
IF(J.NE.IDEL(JOUT)) GO TO 120
IFF=IFF+1
JOUT=JOUT+1
GO TO 130
120 CONTINUE
JJ=JJ+1
IFF=IFF+1
TRF(II,JJ)=F(IFF)
TRF(JJ,II)=F(IFF)
130 CONTINUE
140 CONTINUE
RETURN
200 CONTINUE
ELEMENT OR BLOCK DELETIONS: START BY FILLING TRF WITH FULL NBO FOCK MATRIX:
II=0
DO 210 I=1,NDIM
DO 210 J=1,I
II=II+1
TRF(I,J)=F(II)
TRF(J,I)=F(II)
210 CONTINUE
IF(ITYPE.NE.2) GO TO 300
ZERO REQUESTED MATRIX ELEMENTS:
NDEL2=NDEL*2
WRITE(LFNPR,8620) (IDEL(I),I=1,NDEL2)
DO 240 I=1,NDEL
I2=2*I
ID=IDEL(I2-1)
JD=IDEL(I2)
TRF(ID,JD)=ZERO
TRF(JD,ID)=ZERO
240 CONTINUE
RETURN
300 CONTINUE
IF(ITYPE.NE.4) STOP
ZERO REQUESTED MATRIX BLOCKS:
DO 400 ID=1,NDEL
IDST=(ID-1)*4
J1=IDEL(IDST+1)
J2=IDEL(IDST+2)
I1=IDEL(IDST+3)
I2=IDEL(IDST+4)
IF(J1.LE.J2) GO TO 320
IDEL(IDST+2)=J1
IDEL(IDST+1)=J2
J1=IDEL(IDST+1)
J2=IDEL(IDST+2)
320 IF(I1.LE.I2) GO TO 330
IDEL(IDST+4)=I1
IDEL(IDST+3)=I2
I1=IDEL(IDST+3)
I2=IDEL(IDST+4)
330 DO 380 I=I1,I2
DO 380 J=J1,J2
SKIP DIAGONAL ELEMENTS:
IF(I.EQ.J) GO TO 380
TRF(I,J)=ZERO
TRF(J,I)=ZERO
380 CONTINUE
400 CONTINUE
NDEL4=NDEL*4
WRITE(LFNPR,8640) (IDEL(I),I=1,NDEL4)
RETURN
DELETE INTERSECTION IN FOCK MATRIX BETWEEN PAIRS OF SETS OF ORBITALS:
600 ITYPE=3
START BY FILLING TRF WITH FULL NBO FOCK MATRIX:
II=0
DO 610 I=1,NDIM
DO 610 J=1,I
II=II+1
TRF(I,J)=F(II)
TRF(J,I)=F(II)
610 CONTINUE
READ IN NUMBER OF PAIRS OF SETS OF ORBITALS, NDEL:
CALL IFLD(NDEL,ERROR)
IF(ERROR) GO TO 9500
LENG=5
CHECK THE NEXT WORD TO SEE IF IT IS "DELOCALIZATION" INSTEAD OF "BLOCK":
(IF SO, THE BLOCK WILL BE SPECIFIED BY MOLECULAR UNITS INSTEAD OF BY BLOCKS)
CALL HFLD(KEYWD,LENG,DONE)
IF(EQUAL(KEYWD,LDELOC,5)) GO TO 1000
CHECK THE WORD TO SEE IF IT IS "ATOM" INSTEAD OF "BLOCK":
(IF SO, THE BLOCK WILL BE SPECIFIED BY ORBITALS ON GROUPS OF ATOMS)
IF(EQUAL(KEYWD,LATOM,4)) GO TO 1200
NSTART=0
DO 800 K=1,NDEL
READ IN THE NUMBER OF ORBITALS IN EACH SET OF THE PAIR, NSET1 AND NSET2:
(SKIP THE 'BY' BETWEEN NSET1 AND NSET2)
CALL IFLD(NSET1,ERROR)
IF(ERROR) GO TO 9500
CALL HFLD(KEYWD,LENG,DONE)
CALL IFLD(NSET2,ERROR)
IF(ERROR) GO TO 9500
NSTART=NSTART+2
IDEL(NSTART-1)=NSET1
IDEL(NSTART)=NSET2
READ IN THE ORBITALS OF BOTH SETS
NTOT=NSET1+NSET2
DO 620 I=1,NTOT
CALL IFLD(IDEL(NSTART+I),ERROR)
IF(ERROR) GO TO 9500
620 CONTINUE
NOW, ZERO ALL INTERSECTING ELEMENTS BETWEEN THE TWO SETS:
NSTRT2=NSTART+NSET1
DO 700 I=1,NSET1
ID=IDEL(NSTART+I)
DO 700 J=1,NSET2
JD=IDEL(NSTRT2+J)
IF(ID.EQ.JD) GO TO 700
TRF(ID,JD)=ZERO
TRF(JD,ID)=ZERO
700 CONTINUE
NSTART=NSTART+NTOT
800 CONTINUE
GO TO 4000
ZEROING OF DELOCALIZATION WITHIN OR BETWEEN MOLECULAR UNITS.
USE THE NBO MOLECULAR UNIT (NBOUNI) AND NBO TYPE (NBOTYP) LISTS.
1000 CONTINUE
NSTART=0
DO 1100 K=1,NDEL
SKIP THE NEXT WORD ("FROM"):
CALL HFLD(KEYWD,LENG,DONE)
READ IN THE NUMBER OF THE FIRST MOLECULAR UNIT, IUNIT1:
CALL IFLD(IUNIT1,ERROR)
IF(ERROR) GO TO 9500
SKIP THE "TO" AND READ IN IUNIT2:
CALL HFLD(KEYWD,LENG,DONE)
CALL IFLD(IUNIT2,ERROR)
IF(ERROR) GO TO 9500
WRITE(LFNPR,8300) IUNIT1,IUNIT2
NSTART=NSTART+2
FIND ALL OF THE NONSTAR (CORE/"LONE PAIR"/BOND) NBOS ON UNIT IUNIT1:
NSET1=0
DO 1020 IBAS=1,NDIM
IF(NBOUNI(IBAS).NE.IUNIT1) GO TO 1020
IF(NBOTYP(IBAS).GT.20) GO TO 1020
NSET1=NSET1+1
IDEL(NSTART+NSET1)=IBAS
1020 CONTINUE
IDEL(NSTART-1)=NSET1
FIND ALL OF THE STAR (RYDBERG/ANTIBOND) NBOS ON UNIT IUNIT2:
NSET2=0
NSTRT2=NSTART+NSET1
DO 1040 IBAS=1,NDIM
IF(NBOUNI(IBAS).NE.IUNIT2) GO TO 1040
IF(NBOTYP(IBAS).LT.10) GO TO 1040
NSET2=NSET2+1
IDEL(NSTRT2+NSET2)=IBAS
1040 CONTINUE
IDEL(NSTART)=NSET2
NTOT=NSET1+NSET2
NOW, ZERO ALL INTERSECTING ELEMENTS BETWEEN THE TWO SETS:
DO 1060 I=1,NSET1
ID=IDEL(NSTART+I)
DO 1060 J=1,NSET2
JD=IDEL(NSTRT2+J)
IF(ID.EQ.JD) GO TO 1060
TRF(ID,JD)=ZERO
TRF(JD,ID)=ZERO
1060 CONTINUE
NSTART=NSTART+NTOT
1100 CONTINUE
GO TO 4000
ZEROING OF DELOCALIZATION BETWEEN GROUPS OF ATOMS
USE THE NBO TYPE (NBOTYP) AND NBO LABEL (LABEL) LISTS.
1200 CONTINUE
MSTART=0
NSTART=0
SKIP THE 'BLOCKS' BEFORE NSET1:
CALL HFLD(KEYWD,LENG,DONE)
DO 1400 K=1,NDEL
READ IN THE NUMBER OF ATOMS IN EACH SET OF THE PAIR, NSET1 AND NSET2:
(SKIP THE 'BY' BETWEEN NSET1 AND NSET2)
CALL IFLD(MSET1,ERROR)
IF(ERROR) GO TO 9500
CALL HFLD(KEYWD,LENG,DONE)
CALL IFLD(MSET2,ERROR)
IF(ERROR) GO TO 9500
MSTART=MSTART+2
ISCR1(MSTART-1)=MSET1
ISCR1(MSTART)=MSET2
READ IN THE ATOMS OF BOTH SETS:
MTOT=MSET1+MSET2
DO 1220 I=1,MTOT
CALL IFLD(ISCR1(MSTART+I),ERROR)
IF(ERROR) GO TO 9500
1220 CONTINUE
MSTRT2=MSTART+MSET1
WRITE(LFNPR,8350)
WRITE(LFNPR,8631) (ISCR1(MSTART+I),I=1,MSET1)
WRITE(LFNPR,8360)
WRITE(LFNPR,8631) (ISCR1(MSTRT2+I),I=1,MSET2)
WRITE(LFNPR,8370)
CONSTRUCT THE LIST OF THE TWO SETS OF ORBITALS FROM THE ATOM LISTS,
PLACING THE ORBITAL LIST IN IDEL IN THE STANDARD MANNER FOR ITYPE=3:
NSTART=NSTART+2
NSET1=0
NSET2=0
DO 1300 JBAS=1,NDIM
DONOR=.FALSE.
ACCPTR=.FALSE.
IF(NBOTYP(JBAS).LT.20) DONOR=.TRUE.
IF(NBOTYP(JBAS).GE.10) ACCPTR=.TRUE.
LIST1=.FALSE.
LIST2=.FALSE.
REMEMBER TO CONSULT IBXM BEFORE GETTING INFO FROM LABEL!
JB=IBXM(JBAS)
DO 1240 J=4,6
JAT=LABEL(JB,J)
IF(JAT.EQ.0) GO TO 1240
DO 1230 I=1,MSET1
IAT=ISCR1(MSTART+I)
IF(IAT.NE.JAT) GO TO 1230
GO TO 1240
1230 CONTINUE
GO TO 1250
1240 CONTINUE
LIST1=.TRUE.
1250 CONTINUE
DO 1270 J=4,6
JAT=LABEL(JB,J)
IF(JAT.EQ.0) GO TO 1270
DO 1260 I=1,MSET2
IAT=ISCR1(MSTRT2+I)
IF(IAT.NE.JAT) GO TO 1260
GO TO 1270
1260 CONTINUE
GO TO 1280
1270 CONTINUE
LIST2=.TRUE.
1280 CONTINUE
IF(LIST1.AND.LIST2) GO TO 1300
IF(.NOT.LIST1.AND..NOT.LIST2) GO TO 1300
IF(LIST1.AND..NOT.DONOR) GO TO 1300
IF(LIST2.AND..NOT.ACCPTR) GO TO 1300
IF(LIST2) GO TO 1290
LIST1.AND.DONOR=.TRUE. CASE:
NSET1=NSET1+1
IDEL(NSTART+NSET1)=JBAS
GO TO 1300
LIST2.AND.ACCPTR=.TRUE. CASE:
1290 CONTINUE
NSET2=NSET2+1
ISCR2(NSET2)=JBAS
1300 CONTINUE
IDEL(NSTART-1)=NSET1
IDEL(NSTART)=NSET2
NTOT=NSET1+NSET2
PLACE ORBITAL SET 2 IN IDEL:
NSTRT2=NSTART+NSET1
DO 1320 I=1,NSET2
1320 IDEL(NSTRT2+I)=ISCR2(I)
NOW, ZERO ALL INTERSECTING ELEMENTS BETWEEN THE TWO SETS OF ORBITALS:
DO 1340 I=1,NSET1
ID=IDEL(NSTART+I)
DO 1340 J=1,NSET2
JD=IDEL(NSTRT2+J)
TRF(ID,JD)=ZERO
1340 TRF(JD,ID)=ZERO
MSTART=MSTART+NTOT
NSTART=NSTART+NTOT
1400 CONTINUE
GO TO 4000
DELETE ALL VICINAL OR GEMINAL DELOCALIZATIONS:
3000 IVIC=1
WRITE(LFNPR,8550)
GOTO 3020
3010 IVIC=0
WRITE(LFNPR,8560)
3020 CONTINUE
ITYPE=3
START BY FILLING TRF WITH FULL NBO FOCK MATRIX:
II=0
DO 3025 I=1,NDIM
DO 3025 J=1,I
II=II+1
TRF(I,J)=F(II)
TRF(J,I)=F(II)
3025 CONTINUE
FIND THE TOTAL NUMBER OF BLOCKS OF THE FOCK MATRIX TO DELETE:
NDEL=0
NSTART=0
DO 3070 IBAS=1,NDIM
IB=IBXM(IBAS)
IF(LABEL(IB,2).NE.ISTAR) THEN
NACC=0
DO 3060 JBAS=1,NDIM
JB=IBXM(JBAS)
IF(LABEL(JB,2).EQ.ISTAR) THEN
ITMP = IHTYP(IBAS,JBAS)
VICINAL DELOCALIZATION:
IF(IVIC.EQ.1.AND.ITMP.EQ.LV) THEN
NACC=NACC+1
IDEL(NSTART+NACC+3)=JBAS
GEMINAL DELOCALIZATION:
ELSE IF(IVIC.EQ.0.AND.ITMP.EQ.LG) THEN
NACC=NACC+1
IDEL(NSTART+NACC+3)=JBAS
END IF
END IF
3060 CONTINUE
IF(NACC.GT.0) THEN
NDEL=NDEL+1
IDEL(NSTART+1)=1
IDEL(NSTART+2)=NACC
IDEL(NSTART+3)=IBAS
DO 3065 JB=1,NACC
JBAS=IDEL(NSTART+JB+3)
IF(JBAS.NE.IBAS) THEN
TRF(IBAS,JBAS)=ZERO
TRF(JBAS,IBAS)=ZERO
END IF
3065 CONTINUE
NSTART=NSTART+NACC+3
IF(NSTART.GT.LEN) STOP 'INCREASE DIMENSION OF ARRAY IDEL'
END IF
END IF
3070 CONTINUE
GOTO 4000
WRITE OUT INFORMATION FROM DELETION, FOR ITYPE=3:
4000 CONTINUE
INDX=0
DO 4050 K=1,NDEL
NSET1=IDEL(INDX+1)
NSET2=IDEL(INDX+2)
INDX=INDX+2
NL=INDX+1
NU=INDX+NSET1
WRITE(LFNPR,8630)
WRITE(LFNPR,8631) (IDEL(I),I=NL,NU)
WRITE(LFNPR,8632)
NL=INDX+NSET1+1
NU=INDX+NSET1+NSET2
WRITE(LFNPR,8631) (IDEL(I),I=NL,NU)
INDX=NU
4050 CONTINUE
RETURN
DELETE ALL THE "STAR" NBOS ON ONE OR MORE MOLECULES:
(SET ITYPE=1 FOR ORBITAL DELETIONS)
5000 CONTINUE
ITYPE=1
READ IN THE NUMBER OF MOLECULAR UNITS TO "DESTAR":
CALL IFLD(NUNITS,ERROR)
IF(ERROR) GO TO 9500
SKIP THE KEYWORD "UNITS":
LENG=3
CALL HFLD(KEYWD,LENG,DONE)
READ IN THE NUMBERS OF THE UNITS TO DESTAR, FINDING THE STAR ORBITALS
FROM THE LISTS NBOUNI AND NBOTYP:
NDEL=0
DO 5100 I=1,NUNITS
CALL IFLD(IUNIT,ERROR)
IF(ERROR) GO TO 9500
WRITE(LFNPR,8400) IUNIT
DO 5050 IBAS=1,NDIM
IF(NBOUNI(IBAS).NE.IUNIT) GO TO 5050
IF(LABEL(IBAS,2).NE.ISTAR) GO TO 5050
NDEL=NDEL+1
IDEL(NDEL)=IBAS
5050 CONTINUE
5100 CONTINUE
GO AND DO THE DELETIONS OF THE NDEL ORBITALS THAT ARE NOW IN IDEL:
GO TO 100
DELETE ALL STAR NBOS:
5500 CONTINUE
ITYPE=1
NDEL=0
WRITE(LFNPR,8500)
DO 5600 IBAS=1,NDIM
IF(LABEL(IBAS,2).NE.ISTAR) GO TO 5600
NDEL=NDEL+1
IDEL(NDEL)=IBAS
5600 CONTINUE
GO AND DO THE DELETIONS OF THE NDEL ORBITALS THAT ARE NOW IN IDEL:
GO TO 100
8100 FORMAT(1X,' ----------- Alpha spin NBO deletions ----------- '/)
8200 FORMAT(1X,' ----------- Beta spin NBO deletions ----------- '/)
8300 FORMAT(1X,'Zero delocalization from unit ',I2,' to unit ',I2)
8350 FORMAT(1X,'Zero delocalization from NBOs localized on atoms:')
8360 FORMAT(1X,'to NBOs localized on atoms:')
8370 FORMAT(1X,' (NBOs in common to the two groups of atoms ',
* 'left out)')
8400 FORMAT(1X,'DESTAR unit ',I2,': Delete all Rydberg/antibond',
* ' NBOs from this unit')
8500 FORMAT(1X,'NOSTAR: Delete all Rydberg/antibond NBOs')
8550 FORMAT(1X,'NOVIC: Delete all vicinal delocalizations')
8560 FORMAT(1X,'NOGEM: Delete all geminal delocalizations')
8610 FORMAT(1X,'Deletion of the following orbitals ',
* 'from the NBO Fock matrix:',(/1X,20I4))
8620 FORMAT(1X,'Deletion of the following NBO Fock matrix ',
* 'elements:',/(7(2X,'(',I3,',',I3,')')))
8630 FORMAT(1X,'Deletion of the NBO Fock matrix elements ',
* 'between orbitals:')
8631 FORMAT(1X,20I4)
8632 FORMAT(1X,'and orbitals:')
8640 FORMAT(1X,'Deletion of the following NBO Fock matrix ',
* 'blocks:',/(2(2X,'(',I3,'-',I3,'/',I3,'-',I3,')')))
8700 FORMAT(/)
ERROR MESSAGES:
9000 WRITE(LFNPR,9010) (KEYWD(I),I=1,3)
9010 FORMAT(1X,'First character string does not have the',
* ' first three letters of DELETE or ZERO:',/1X,3A1)
STOP
9100 WRITE(LFNPR,9110)
9110 FORMAT(1X,'Non-integer was input for number of items to delete.')
STOP
9200 WRITE(LFNPR,9210) (KEYWD(I),I=1,3)
9210 FORMAT(1X,'No match with first three letters of the keywords ',
* 'for deletion type'/' (ORBITAL,ELEMENT,BLOCK) found:',
* 3A1)
STOP
9300 WRITE(LFNPR,9310)
9310 FORMAT(1X,'Keyword ALPHA (or A) not found to start alpha NBO',
* ' deletion input.')
STOP
9400 WRITE(LFNPR,9410)
9410 FORMAT(1X,'Keyword BETA (or B) not found to start beta NBO',
* ' deletion input.')
9500 WRITE(LFNPR,9510)
9510 FORMAT(' There is an error in the input of deletions.')
STOP
END
*****************************************************************************
SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ IATNO(MAXBAS),IBXM(MAXBAS),NRANK(2*MAXBAS),LOCC(2*MAXBAS)
DIMENSION DM(1),U(NDIM,NDIM),EIG(NDIM),IDEL(LEN)
DATA ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/
ONETWO: ONE IF OPEN SHELL (ISPIN.NE.0), TWO IF CLOSED SHELL (DOUBLY OCC MOS)
ONETWO=TWO
IF(ISPIN.NE.0) ONETWO=ONE
NTRUNC: DIMENSION OF TRUNCATED FOCK MATRIX
NTRUNC=NDIM
IF(ITYPE.EQ.1) NTRUNC=NDIM-NDEL
RANK THE EIGENVALUES 'EIG' FROM THE TRUNCATED FOCK MATRIX FROM LOWEST
TO HIGHEST IN 'NRANK':
CALL RNKEIG(NRANK,EIG,NTRUNC,NDIM,LOCC)
PUT IN 'LOCC' THE LOCATIONS OF THE 'NMOOCC' LOWEST EIGENVALUES:
(THESE CORRESPOND TO THE DOUBLY OCCUPIED MOS)
NOCC=0
DO 20 I=1,NTRUNC
IF(NRANK(I).GT.NMOOCC) GO TO 20
NOCC=NOCC+1
LOCC(NOCC)=I
20 CONTINUE
NDELOR: NUMBER OF DELETED ORBITALS
NDELOR=NDIM-NTRUNC
CONSTRUCT THE NEW NBO DENSITY MATRIX:
LOOP OVER ROWS:
II=0
IJ=0
IOUT=1
DO 105 I=1,NDIM
IF(IOUT.GT.NDELOR) GO TO 40
IF(I.NE.IDEL(IOUT)) GO TO 40
ZERO ROWS OF THE NEW NBO DENSITY MATRIX THAT WERE ZEROED
IN THE TRUNCATION, ALSO ZEROING THE ORBITAL OCCPANCY, EIG(I):
IOUT=IOUT+1
EIG(I)=ZERO
DO 30 J=1,I
IJ=IJ+1
30 DM(IJ)=ZERO
GO TO 105
40 CONTINUE
II=II+1
LOOP OVER COLUMNS:
JOUT=1
JJ=0
DO 100 J=1,I
IF(JOUT.GT.NDELOR) GO TO 50
IF(J.NE.IDEL(JOUT)) GO TO 50
ZERO COLUMNS OF THE NEW NBO DENSITY MATRIX THAT WERE ZEROED
IN THE TRUNCATION OF THE NBO FOCK MATRIX:
JOUT=JOUT+1
IJ=IJ+1
DM(IJ)=ZERO
GO TO 100
50 CONTINUE
FIND DM(IJ) FROM THE EIGENVECTORS OF THE TRUNCATED NBO FOCK MATRIX IN 'U',
SUMMING OVER THE OCCUPIED MOS, AND MULTIPLYING BY TWO FOR DOUBLE OCCUPANCY:
JJ=JJ+1
SUM=ZERO
DO 80 K=1,NMOOCC
80 SUM=SUM+U(II,LOCC(K))*U(JJ,LOCC(K))
IJ=IJ+1
DM(IJ)=SUM*ONETWO
IF(I.EQ.J) EIG(I)=SUM*ONETWO
100 CONTINUE
105 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
RANK EIGENVALUES IN 'EIG', LOWEST VALUES FIRST, IN 'RANK':
INTEGER RANK,ARCRNK
DIMENSION RANK(NDIM),EIG(NDIM),ARCRNK(NDIM)
DO 10 I=1,N
10 ARCRNK(I)=I
DO 40 I=1,N
IF(I.EQ.N) GO TO 30
I1=I+1
DO 20 J=I1,N
IF(EIG(J).GE.EIG(I)) GO TO 20
TEMP=EIG(I)
EIG(I)=EIG(J)
EIG(J)=TEMP
ITEMP=ARCRNK(I)
ARCRNK(I)=ARCRNK(J)
ARCRNK(J)=ITEMP
20 CONTINUE
30 RANK(ARCRNK(I))=I
40 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION F(1),U(NDIM,1),S(1),R(1)
TAKE U(TRANSPOSE)*F*U:
F MATRIX TO BE TRANSFORMED (PACKED UPPER TRIANGULAR)
U IS THE TRANSFORMATION MATRIX
R IS THE MATRIX IN WHICH THE RESULT WILL BE RETURNED
S IS A SCRATCH MATRIX OF DIMENSION N
KNTROL....=0 RESULT RETURNED ONLY IN R
=1 RESULT COPIED INTO F
IN=0
DO 50 I=1,N
JN=0
DO 20 J=1,N
SUM=0.
KN=0
DO 10 K=1,N
JK=JN+K
IF(J.LT.K) JK=KN+J
SUM=SUM+F(JK)*U(K,I)
10 KN=KN+K
S(J)=SUM
20 JN=JN+J
DO 40 J=1,I
SUM=0.
DO 30 K=1,N
30 SUM=SUM+S(K)*U(K,J)
IJ=IN+J
40 R(IJ)=SUM
50 IN=IN+I
IF(KNTROL.EQ.0) RETURN
NT=N*(N+1)/2
DO 60 I=1,NT
60 F(I)=R(I)
RETURN
END
*****************************************************************************
NBO DIRECT ACCESS FILE (DAF) ROUTINES:
SUBROUTINE NBFILE(NEW,ERROR)
SUBROUTINE NBOPEN(NEW,ERROR)
SUBROUTINE NBWRIT(IX,NX,IDAR)
SUBROUTINE NBREAD(IX,NX,IDAR)
SUBROUTINE NBCLOS(SEQ)
SUBROUTINE NBINQR(IDAR)
SUBROUTINE FETITL(TITLE)
SUBROUTINE FEE0(EDEL,ETOT)
SUBROUTINE SVE0(EDEL)
SUBROUTINE FECOOR(ATCOOR)
SUBROUTINE FESRAW(S)
SUBROUTINE FEDRAW(DM,SCR)
SUBROUTINE FEFAO(F,IWFOCK)
SUBROUTINE FEAOMO(T,IT)
SUBROUTINE FEDXYZ(DXYZ,I)
SUBROUTINE SVNBO(T,OCC,ISCR)
SUBROUTINE FENBO(T,OCC,ISCR,NELEC)
SUBROUTINE FETNBO(T)
SUBROUTINE SVPNAO(T)
SUBROUTINE FEPNAO(T)
SUBROUTINE SVSNAO(S)
SUBROUTINE FESNAO(S)
SUBROUTINE SVTNAB(T)
SUBROUTINE FETNAB(T)
SUBROUTINE SVTLMO(T)
SUBROUTINE FETLMO(T)
SUBROUTINE SVTNHO(T)
SUBROUTINE FETNHO(T)
SUBROUTINE SVPPAO(DM)
SUBROUTINE FEPPAO(DM)
SUBROUTINE SVTNAO(T)
SUBROUTINE FETNAO(T)
SUBROUTINE SVNLMO(T)
SUBROUTINE FENLMO(T)
SUBROUTINE SVDNAO(DM)
SUBROUTINE FEDNAO(DM)
SUBROUTINE SVFNBO(F)
SUBROUTINE FEFNBO(F)
SUBROUTINE SVNEWD(DM)
SUBROUTINE FENEWD(DM)
SUBROUTINE FEINFO(ICORE,ISWEAN)
SUBROUTINE FEBAS(NSHELL,NEXP,ISCR)
*****************************************************************************
SUBROUTINE NBFILE(NEW,ERROR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL NEW,ERROR,NEED,THERE
CHARACTER*80 TEMP
PARAMETER (MAXFIL = 40)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
CHARACTER*80 FILENM
DATA IWRIT,IREAD/4HWRIT,4HREAD/
Create a list IFILE of external LFNs. First find the files that
will be written:
ERROR = .FALSE.
NFILE = 0
DO 10 I = 1,999
NEED = .FALSE.
IF(IWPNAO.EQ.-I) NEED = .TRUE.
IF(IWTNAO.EQ.-I) NEED = .TRUE.
IF(IWTNAB.EQ.-I) NEED = .TRUE.
IF(IWTNBO.EQ.-I) NEED = .TRUE.
IF(JPRINT(7).EQ. I) NEED = .TRUE.
IF(JPRINT(9).EQ.-I) NEED = .TRUE.
IF(JPRINT(13).EQ.-I) NEED = .TRUE.
IF(JPRINT(15).EQ.-I) NEED = .TRUE.
IF(JPRINT(16).EQ.-I) NEED = .TRUE.
IF(JPRINT(17).EQ.-I) NEED = .TRUE.
IF(JPRINT(18).EQ.-I) NEED = .TRUE.
IF(JPRINT(19).EQ.-I) NEED = .TRUE.
IF(JPRINT(20).EQ.-I) NEED = .TRUE.
IF(JPRINT(21).EQ.-I) NEED = .TRUE.
IF(JPRINT(22).EQ. I) NEED = .TRUE.
IF(JPRINT(23).EQ.-I) NEED = .TRUE.
IF(JPRINT(24).EQ.-I) NEED = .TRUE.
IF(JPRINT(25).EQ.-I) NEED = .TRUE.
IF(JPRINT(26).EQ.-I) NEED = .TRUE.
IF(JPRINT(27).EQ.-I) NEED = .TRUE.
IF(JPRINT(28).EQ.-I) NEED = .TRUE.
IF(JPRINT(29).EQ.-I) NEED = .TRUE.
IF(JPRINT(30).EQ.-I) NEED = .TRUE.
IF(JPRINT(31).EQ.-I) NEED = .TRUE.
IF(JPRINT(33).EQ.-I) NEED = .TRUE.
IF(JPRINT(34).EQ.-I) NEED = .TRUE.
IF(JPRINT(35).EQ.-I) NEED = .TRUE.
IF(JPRINT(37).EQ.-I) NEED = .TRUE.
IF(JPRINT(38).EQ.-I) NEED = .TRUE.
IF(JPRINT(39).EQ.-I) NEED = .TRUE.
IF(JPRINT(40).EQ.-I) NEED = .TRUE.
IF(JPRINT(41).EQ.-I) NEED = .TRUE.
IF(JPRINT(42).EQ.-I) NEED = .TRUE.
IF(JPRINT(44).EQ.-I) NEED = .TRUE.
IF(JPRINT(45).EQ.-I) NEED = .TRUE.
IF(JPRINT(47).EQ.-I) NEED = .TRUE.
IF(JPRINT(48).EQ.-I) NEED = .TRUE.
IF(JPRINT(49).EQ.-I) NEED = .TRUE.
IF(JPRINT(50).EQ.-I) NEED = .TRUE.
IF(JPRINT(51).EQ.-I) NEED = .TRUE.
IF(JPRINT(52).EQ.-I) NEED = .TRUE.
IF(JPRINT(53).EQ.-I) NEED = .TRUE.
IF(JPRINT(54).EQ.-I) NEED = .TRUE.
IF(NEED) THEN
NFILE = NFILE + 1
IF(NFILE.GT.MAXFIL) THEN
WRITE(LFNPR,890) MAXFIL
ERROR = .TRUE.
RETURN
END IF
IFILE(NFILE) = I
END IF
10 CONTINUE
Add files that may be read:
MFILE = NFILE
IF(IOINQR(IWPNAO).EQ.IREAD) THEN
MFILE = MFILE + 1
IF(MFILE.GT.MAXFIL) THEN
WRITE(LFNPR,890) MAXFIL
ERROR = .TRUE.
RETURN
END IF
IFILE(MFILE) = IWPNAO/1000
END IF
IF(IOINQR(IWTNAO).EQ.IREAD) THEN
MFILE = MFILE + 1
IF(MFILE.GT.MAXFIL) THEN
WRITE(LFNPR,890) MAXFIL
ERROR = .TRUE.
RETURN
END IF
IFILE(MFILE) = IWTNAO/1000
END IF
IF(IOINQR(IWTNAB).EQ.IREAD) THEN
MFILE = MFILE + 1
IF(MFILE.GT.MAXFIL) THEN
WRITE(LFNPR,890) MAXFIL
ERROR = .TRUE.
RETURN
END IF
IFILE(MFILE) = IWTNAB/1000
END IF
Make sure that no files are both written and read:
DO 30 I = NFILE+1,MFILE
DO 20 J = 1,NFILE
IF(ABS(IFILE(I)).EQ.IFILE(J)) THEN
WRITE(LFNPR,900) IFILE(J)
ERROR = .TRUE.
RETURN
END IF
20 CONTINUE
30 CONTINUE
NFILE = MFILE
Also check that the NBO DAF has its own LFN:
DO 40 I = 1,NFILE
IF(ABS(IFILE(I)).EQ.ABS(LFNDAF)) THEN
WRITE(LFNPR,900) IFILE(I)
ERROR = .TRUE.
RETURN
END IF
40 CONTINUE
Select an alternate filename if this one is not acceptable:
TEMP = FILENM
DO 50 I = 1,80
IF(TEMP(I:I).EQ.CHAR(32)) THEN
LENGTH = I - 1
GO TO 60
END IF
50 CONTINUE
LENGTH = 76
60 CONTINUE
IO = IOINQR(IWPNAO)
JO = IOINQR(IWTNAO)
KO = IOINQR(IWTNAB)
IF(NEW.AND.IO.NE.IREAD.AND.JO.NE.IREAD.AND.KO.NE.IREAD) THEN
DO 100 I = 0,999
LEN = LENGTH
IF(I.NE.0) THEN
II = I
65 LEN = LEN + 1
TEMP(LEN:LEN) = CHAR(MOD(II,10) + 48)
II = II / 10
IF(II.NE.0) GOTO 65
IF(LEN.EQ.LENGTH+2) THEN
TEMP(LEN+1:LEN+1) = TEMP(LEN:LEN)
TEMP(LEN:LEN) = TEMP(LEN-1:LEN-1)
TEMP(LEN-1:LEN-1) = TEMP(LEN+1:LEN+1)
ELSE IF(LEN.EQ.LENGTH+3) THEN
TEMP(LEN+1:LEN+1) = TEMP(LEN:LEN)
TEMP(LEN:LEN) = TEMP(LEN-2:LEN-2)
TEMP(LEN-2:LEN-2) = TEMP(LEN+1:LEN+1)
END IF
END IF
TEMP(LEN+1:LEN+1) = '.'
First check the DAF:
K = ABS(LFNDAF)
IF(ABS(LFNDAF).LT.100) K = K * 10
TEMP(LEN+2:LEN+2) = CHAR(K/100 + 48)
TEMP(LEN+3:LEN+3) = CHAR(MOD(K/10,10) + 48)
IF(ABS(LFNDAF).LT.100) THEN
TEMP(LEN+4:LEN+4) = CHAR(32)
ELSE
TEMP(LEN+4:LEN+4) = CHAR(MOD(K,10) + 48)
END IF
INQUIRE(FILE=TEMP,EXIST=THERE)
IF(THERE) GO TO 100
Now check the rest:
DO 70 J = 1,NFILE
K = ABS(IFILE(J))
IF(ABS(IFILE(J)).LT.100) K = K * 10
TEMP(LEN+2:LEN+2) = CHAR(K/100 + 48)
TEMP(LEN+3:LEN+3) = CHAR(MOD(K/10,10) + 48)
IF(ABS(IFILE(J)).LT.100) THEN
TEMP(LEN+4:LEN+4) = CHAR(32)
ELSE
TEMP(LEN+4:LEN+4) = CHAR(MOD(K,10) + 48)
END IF
INQUIRE(FILE=TEMP, EXIST=THERE)
IF(THERE) GO TO 100
70 CONTINUE
GO TO 200
100 CONTINUE
WRITE(LFNPR,910)
ERROR = .TRUE.
RETURN
This is a good one!! If the filename has changed, write a warning:
200 CONTINUE
IF(FILENM(1:LEN).NE.TEMP(1:LEN)) THEN
FILENM(1:LEN) = TEMP(1:LEN)
DO 210 I = LEN+1,80
FILENM(I:I) = CHAR(32)
210 CONTINUE
WRITE(LFNPR,920) FILENM(1:52)
END IF
LENGTH = LEN
END IF
Open external files:
TEMP = FILENM
TEMP(LENGTH+1:LENGTH+1) = '.'
DO 300 I = 1,NFILE
K = ABS(IFILE(I))
IF(ABS(IFILE(I)).LT.100) K = K * 10
TEMP(LENGTH+2:LENGTH+2) = CHAR(K/100 + 48)
TEMP(LENGTH+3:LENGTH+3) = CHAR(MOD(K/10,10) + 48)
IF(ABS(IFILE(I)).LT.100) THEN
TEMP(LENGTH+4:LENGTH+4) = CHAR(32)
ELSE
TEMP(LENGTH+4:LENGTH+4) = CHAR(MOD(K,10) + 48)
END IF
IF(IFILE(I).GT.0) THEN
OPEN(UNIT=IFILE(I), FILE=TEMP, STATUS='NEW')
ELSE
OPEN(UNIT=ABS(IFILE(I)), FILE=TEMP, STATUS='OLD')
END IF
300 CONTINUE
RETURN
890 FORMAT(/1X,'I/O is limited to ',I2,' files. Program abort.')
900 FORMAT(/1X,'Illegal request for input and output with LFN',I3)
910 FORMAT(/1X,'The search for an acceptable filename has failed.')
920 FORMAT(/1X,'Filename: Changed to ',A52)
END
*****************************************************************************
SUBROUTINE NBOPEN(NEW,ERROR)
*****************************************************************************
The following records of the NBO direct access file (DAF) are used:
1 --- NBODAF common block
2 --- Job title
3 --- NATOMS,NDIM,NBAS,MUNIT,wavefunction flags,ISWEAN
4 --- IATNO,IZNUC,LCTR,LANG
5 --- AO basis set information
8 --- Deletion energy, total energy
9 --- Atomic coordinates
10 --- AO overlap matrix
11 --- PNAO overlap matrix
20 --- AO density matrix (alpha)
21 --- AO density matrix (beta)
22 --- Pure AO density matrix
23 --- NAO density matrix (alpha)
24 --- NAO density matrix (beta)
25 --- AO density matrix with NBO deletions (alpha)
26 --- AO density matrix with NBO deletions (beta)
27 --- NBO occupancies (alpha)
28 --- NBO occupancies (beta)
30 --- AO Fock matrix (alpha)
31 --- AO Fock matrix (beta)
32 --- NAO Fock matrix (alpha)
33 --- NAO Fock matrix (beta)
34 --- NBO Fock matrix (alpha)
35 --- NBO Fock matrix (beta)
40 --- AO to MO transformation matrix (alpha)
41 --- AO to MO transformation matrix (beta)
42 --- AO to PNAO transformation matrix
43 --- AO to NAO transformation matrix
44 --- AO to NBO transformation matrix (alpha)
45 --- AO to NBO transformation matrix (beta)
46 --- AO to NLMO transformation matrix
47 --- NAO to NHO transformation matrix
48 --- NAO to NBO transformation matrix
49 --- NBO to NLMO transformation matrix
50 --- X dipole integrals
51 --- Y dipole integrals
52 --- Z dipole integrals
60 --- NBO labels (alpha)
61 --- NBO labels (beta)
-----------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL NEW,ERROR
CHARACTER*80 TEMP
Note that ISINGL is no longer a parameter (6/7/90):
PARAMETER (LENGTH = 256)
PARAMETER (NBDAR = 100)
PARAMETER (MAXFIL = 40)
COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
CHARACTER*80 FILENM
DIMENSION IX(NBDAR+2),IXSNBO(LENGTH/2)
EQUIVALENCE (IXSNBO(1),IXDNBO(1))
EQUIVALENCE (IX(1),INBO)
SAVE ISW,LENREC
DATA IBLNK/1H /
DATA ISW/0/
INBO : Fortran file number
IONBO : Indexing array mapping the logical records of the
NBO DAF onto the physical records of the disk file
NAV : Number of physical records currently on the DAF
NBDAR : Maximum number of logical records on the DAF
INBO = ABS(LFNDAF)
Are we working on a 32 (ISINGL=2) or 64 (ISINGL=1) bit machine?
IF(ISW.EQ.0) THEN
DO 10 I = 1,4
IBLNK = IBLNK / 256
10 CONTINUE
IF(IBLNK.EQ.0) THEN
ISINGL = 2
ELSE
ISINGL = 1
END IF
Determine an appropriate record length for the NBO DAF:
LREC = LENGTH / 4
LENREC = 0
DO 30 I = 1,6
LREC = LREC * 2
OPEN(UNIT=INBO, FILE='nb$temp.dat', STATUS='NEW',
+ ACCESS='DIRECT', RECL=LREC, FORM='UNFORMATTED',
+ ERR=40)
WRITE(INBO,REC=1,ERR=20) IXDNBO
If I.EQ.1 at this point, ERR did not work properly in the preceding
statement (this appears to be the case for the XL FORTRAN compiler
running on an IBM RISC station/6000):
IF(I.EQ.1) LREC = LENGTH * 8 / ISINGL
IF(ISINGL.EQ.1) LENREC = LREC / 2
IF(ISINGL.EQ.2) LENREC = LREC
20 CLOSE(UNIT=INBO, STATUS='DELETE')
IF(LENREC.NE.0) GO TO 50
30 CONTINUE
Problems...
40 CONTINUE
WRITE(LFNPR,900)
ERROR = .TRUE.
RETURN
50 CONTINUE
ISW = 1
END IF
Open the NBO direct access file (DAF) -- typically assigned to LFN48:
TEMP = FILENM
DO 60 I = 1,80
IF(TEMP(I:I).EQ.CHAR(32)) THEN
LEN = I - 1
GO TO 70
END IF
60 CONTINUE
LEN = 76
70 CONTINUE
K = INBO
IF(INBO.LT.100) K = K * 10
TEMP(LEN+1:LEN+1) = '.'
TEMP(LEN+2:LEN+2) = CHAR(K/100 + 48)
TEMP(LEN+3:LEN+3) = CHAR(MOD(K/10,10) + 48)
IF(INBO.LT.100) THEN
TEMP(LEN+4:LEN+4) = CHAR(32)
ELSE
TEMP(LEN+4:LEN+4) = CHAR(MOD(K,10) + 48)
END IF
If this is a new NBO DAF, write COMMON/NBODAF/ on the first record:
IF(NEW) THEN
OPEN(UNIT=INBO, FILE=TEMP, STATUS='NEW', ACCESS='DIRECT',
+ RECL=LENREC, FORM='UNFORMATTED', ERR=110)
NAV = 1
NBNAV = 1
DO 80 I = 1,NBDAR
IONBO(I) = 0
80 CONTINUE
NF = 1
NX = (NBDAR + 2) / ISINGL
CALL NBWRIT(IX,NX,NF)
Otherwise, open the old file and read in COMMON/NBODAF/ from the
first record:
ELSE
OPEN(UNIT=INBO, FILE=TEMP, STATUS='OLD', ACCESS='DIRECT',
+ RECL=LENREC, FORM='UNFORMATTED', ERR=110)
NBNAV = 1
MAXIX = LENGTH * ISINGL/2
LDAR = NBDAR + 2
MAX = 0
90 MIN = MAX + 1
MAX = MAX + MAXIX
IF(MAX.GT.LDAR) MAX = LDAR
IF(ISINGL.EQ.1) READ(INBO,REC=NBNAV) IXSNBO
IF(ISINGL.EQ.2) READ(INBO,REC=NBNAV) IXDNBO
DO 100 I = MIN,MAX
IX(I) = IXDNBO(I-MIN+1)
100 CONTINUE
NBNAV = NBNAV + 1
IF(MAX.LT.LDAR) GO TO 90
INBO = ABS(LFNDAF)
END IF
ERROR = .FALSE.
RETURN
Error encountered while opening this file:
110 ERROR = .TRUE.
RETURN
900 FORMAT(/1X,'Routine NBOPEN could not determine an appropriate ',
+ 'record length.')
END
*****************************************************************************
SUBROUTINE NBWRIT(IX,NX,IDAR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (LENGTH = 256)
PARAMETER (NBDAR = 100)
COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
DIMENSION IX(1),IXSNBO(LENGTH/2)
EQUIVALENCE (IXSNBO(1),IXDNBO(1))
MAXIX = LENGTH * ISINGL / 2
LDAR = NX * ISINGL
IF(IONBO(IDAR).NE.0) GO TO 100
If this is the first write to the NBO DAF:
IONBO(IDAR) = NAV
NBNAV = NAV
MAX = 0
10 MIN = MAX + 1
MAX = MAX + MAXIX
IF(MAX.GT.LDAR) MAX = LDAR
DO 20 I = MIN,MAX
20 IXDNBO(I-MIN+1) = IX(I)
IF(ISINGL.EQ.1) WRITE(INBO,REC=NBNAV) IXSNBO
IF(ISINGL.EQ.2) WRITE(INBO,REC=NBNAV) IXDNBO
NBNAV = NBNAV + 1
IF(MAX.LT.LDAR) GO TO 10
NAV = NBNAV
RETURN
Or if this is a rewrite:
100 CONTINUE
NBNAV = IONBO(IDAR)
MAX = 0
110 MIN = MAX + 1
MAX = MAX + MAXIX
IF(MAX.GT.LDAR) MAX = LDAR
DO 120 I = MIN,MAX
120 IXDNBO(I-MIN+1) = IX(I)
IF(ISINGL.EQ.1) WRITE(INBO,REC=NBNAV) IXSNBO
IF(ISINGL.EQ.2) WRITE(INBO,REC=NBNAV) IXDNBO
NBNAV = NBNAV + 1
IF(MAX.LT.LDAR) GO TO 110
RETURN
END
*****************************************************************************
SUBROUTINE NBREAD(IX,NX,IDAR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (LENGTH = 256)
PARAMETER (NBDAR = 100)
COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
DIMENSION IX(1),IXSNBO(LENGTH/2)
EQUIVALENCE (IXSNBO(1),IXDNBO(1))
NBNAV = IONBO(IDAR)
MAXIX = LENGTH * ISINGL / 2
LDAR = NX * ISINGL
MAX = 0
10 MIN = MAX + 1
MAX = MAX + MAXIX
IF(MAX.GT.LDAR) MAX = LDAR
IF(ISINGL.EQ.1) READ(INBO,REC=NBNAV) IXSNBO
IF(ISINGL.EQ.2) READ(INBO,REC=NBNAV) IXDNBO
DO 20 I = MIN,MAX
20 IX(I) = IXDNBO(I-MIN+1)
NBNAV = NBNAV + 1
IF(MAX.LT.LDAR) GO TO 10
RETURN
END
*****************************************************************************
SUBROUTINE NBCLOS(SEQ)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL SEQ
PARAMETER (LENGTH = 256)
PARAMETER (NBDAR = 100)
PARAMETER (MAXFIL = 40)
COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
CHARACTER*80 FILENM
DIMENSION IX(NBDAR+2)
EQUIVALENCE (IX(1),INBO)
First close the NBO direct access file, remembering to write
COMMON/NBODAF/ to the first logical record:
NF = 1
NX = (NBDAR + 2) / ISINGL
CALL NBWRIT(IX,NX,NF)
CLOSE(UNIT=INBO, STATUS='KEEP')
Then close the remainder of the files used by the NBO program:
DO 10 I = 1,NFILE
CLOSE(UNIT=ABS(IFILE(I)), STATUS='KEEP')
10 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE NBINQR(IDAR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (NBDAR = 100)
COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
IF(IDAR.LT.1.OR.IDAR.GT.NBDAR) THEN
WRITE(LFNPR,900) IDAR,NBDAR
STOP
END IF
IF(IONBO(IDAR).EQ.0) IDAR = 0
RETURN
900 FORMAT(/1X,'NBO DAF record out of range: IDAR = ',I4,
+ ' NBDAR = ',I4)
END
*****************************************************************************
SUBROUTINE FETITL(TITLE)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION TITLE(10)
FETITL: FETCHES THE JOB TITLE FROM THE NBODAF:
NFILE = 2
CALL NBREAD(TITLE,10,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FEE0(EDEL,ETOT)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION X(2)
FEE0: FETCHES THE DELETION AND TOTAL SCF ENERGY
NFILE = 8
CALL NBREAD(X,2,NFILE)
EDEL = X(1)
ETOT = X(2)
RETURN
END
*****************************************************************************
SUBROUTINE SVE0(EDEL)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION X(2)
SVE0: SAVES THE DELETION ENERGY
NFILE = 8
CALL NBREAD(X,2,NFILE)
X(1) = EDEL
CALL NBWRIT(X,2,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FECOOR(ATCOOR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION ATCOOR(3*NATOMS)
FECOOR: FETCH THE ATOMIC CARTESIAN COORDINATES IN ANGSTROMS.
NFILE = 9
CALL NBREAD(ATCOOR,3*NATOMS,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FEBAS(NSHELL,NEXP,ISCR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION ISCR(1)
FEBAS: FETCHES THE BASIS SET INFO
NFILE = 5
CALL NBINQR(NFILE)
IF(NFILE.GT.0) THEN
CALL NBREAD(ISCR,2,NFILE)
II = 0
II = II + 1
NSHELL = ISCR(II)
II = II + 1
NEXP = ISCR(II)
LEN = 2 + 3*NSHELL + 5*NEXP
CALL NBREAD(ISCR,LEN,NFILE)
ELSE
NSHELL = 0
END IF
RETURN
END
*****************************************************************************
SUBROUTINE FESRAW(S)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION S(NDIM,NDIM)
FESRAW: FETCHES THE OVERLAP MATRIX (RAW AO. BASIS)
INTO S(NDIM,NDIM) A FULL SQUARE MATRIX.
NFILE = 10
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(S,L2,NFILE)
CALL UNPACK(S,NDIM,NBAS,L2)
RETURN
END
*****************************************************************************
SUBROUTINE FEDRAW(DM,SCR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION DM(1),SCR(1)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DATA NFILEA,NFILEB/20,21/
FEDRAW: FETCHES THE DENSITY MATRIX (RAW A.O. BASIS) IN DM(NDIM,NDIM)
IF ALPHA =.TRUE. FETCH ALPHA MATRIX
IF BETA =.TRUE FETCH BETA MATRIX.
IF OPEN .AND. .NOT.(ALPHA .OR. BETA) =.TRUE FETCH THE TOTAL D.M.
L2 = NDIM*(NDIM+1)/2
NFILE = NFILEA
IF(BETA) NFILE = NFILEB
CALL NBREAD(DM,L2,NFILE)
IF(.NOT.OPEN) GOTO 300
IF(ALPHA.OR.BETA) GOTO 300
CALL NBREAD(SCR,L2,NFILEB)
FORM THE TOTAL DENSITY MATRIX:
DO 100 I = 1,L2
DM(I) = DM(I) + SCR(I)
100 CONTINUE
300 CALL UNPACK(DM,NDIM,NBAS,L2)
RETURN
END
*****************************************************************************
SUBROUTINE FEFAO(F,IWFOCK)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION F(1)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DATA NFILEA,NFILEB/30,31/
FEFAO: FETCHES THE AO FOCK MATRIX
IF ALPHA .EQ. .TRUE. WE WANT THE ALPHA FOCK MATRIX
IF BETA .EQ. .TRUE. WE WANT THE BETA FOCK MATRIX.
IF THE REQUESTED MATRIX DOES NOT EXIST THEN IWFOCK = 0
L2 = NDIM*(NDIM+1)/2
NFILE = NFILEA
IF(BETA) NFILE = NFILEB
CALL NBINQR(NFILE)
IF(NFILE.GT.0) THEN
CALL NBREAD(F,L2,NFILE)
CALL UNPACK(F,NDIM,NBAS,L2)
ELSE
IWFOCK = 0
END IF
RETURN
END
*****************************************************************************
SUBROUTINE FEAOMO(T,IT)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DATA NFILEA,NFILEB/40,41/
FEAOMO: FETCH THE AO TO MO TRANSFORMATION MATRIX:
(IT = 1, AO TO MO TRANSFORM IS ON NBO DAF)
(IT = 0, AO TO MO TRANSFORM IS NOT ON NBO DAF)
NFILE = NFILEA
IF (BETA) NFILE = NFILEB
CALL NBINQR(NFILE)
IF(NFILE.GT.0) THEN
IT = 1
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
ELSE
IT = 0
END IF
RETURN
END
*****************************************************************************
SUBROUTINE FEDXYZ(DXYZ,I)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION DXYZ(1)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DATA NFILEX,NFILEY,NFILEZ/50,51,52/
FEDXYZ: FETCH THE AO DIPOLE MOMENT MATRICES (IN ANGSTROMS)
I=1: X I=2: Y I=3: Z
IF(I.EQ.1) NFILE = NFILEX
IF(I.EQ.2) NFILE = NFILEY
IF(I.EQ.3) NFILE = NFILEZ
CALL NBINQR(NFILE)
IF(NFILE.GT.0) THEN
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(DXYZ,L2,NFILE)
CALL UNPACK(DXYZ,NDIM,NBAS,L2)
ELSE
I = 0
END IF
RETURN
END
*****************************************************************************
SUBROUTINE SVNBO(T,OCC,ISCR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORB(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
DIMENSION T(NDIM,NDIM),OCC(NDIM),ISCR(1)
SVNBO: SAVES NBO INFORMATION (TRANSFORMATION, OCCUPANCIES, LABELS, ETC.)
IF ALPHA .EQ. .TRUE. SAVE THE ALPHA INFORMATION
IF BETA .EQ. .TRUE. SAVE THE BETA INFORMATION.
SAVE THE AO TO NBO TRANSFORMATION MATRIX:
L1 = NDIM
L3 = NDIM*NDIM
L4 = 10*NDIM
NFILE = 44
IF (BETA) NFILE = 45
CALL NBWRIT(T,L3,NFILE)
SAVE NBO ORBITAL OCCUPANCIES:
NFILE = 27
IF (BETA) NFILE = 28
CALL NBWRIT(OCC,L1,NFILE)
SAVE THE LISTS OF NBO INFORMATION FOR LATER USE IN THE DELETIONS.
PACK THE INFORMATION INTO ISCR(10*NDIM):
II = 0
DO 40 K = 1,6
DO 30 I = 1,NBAS
II = II + 1
ISCR(II) = LABEL(I,K)
30 CONTINUE
40 CONTINUE
DO 50 I = 1,NBAS
II = II + 1
ISCR(II) = IBXM(I)
50 CONTINUE
DO 60 I = 1,NATOMS
II = II + 1
ISCR(II) = IATNO(I)
60 CONTINUE
DO 70 I = 1,NBAS
II = II + 1
ISCR(II) = NBOUNI(I)
70 CONTINUE
DO 80 I = 1,NBAS
II = II + 1
ISCR(II) = NBOTYP(I)
80 CONTINUE
NFILE = 60
IF (BETA) NFILE = 61
CALL NBWRIT(ISCR,L4,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FENBO(T,OCC,ISCR,NELEC)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS)
DIMENSION T(NDIM,NDIM),OCC(NDIM),ISCR(1)
DATA ZERO,TENTH /0.0D0,1.0D-1/
FENBO: FETCHES NBO INFORMATION (TRANSFORMATION, OCCUPANCIES, LABELS, ETC.)
IF ALPHA .EQ. .TRUE. FETCH THE ALPHA INFORMATION
IF BETA .EQ. .TRUE. FETCH THE BETA INFORMATION.
FETCH THE AO TO NBO TRANSFORMATION MATRIX:
L1 = NDIM
L3 = NDIM*NDIM
L4 = NDIM*10
NFILE = 44
IF (BETA) NFILE = 45
CALL NBREAD(T,L3,NFILE)
FETCH NBO ORBITAL OCCUPANCIES:
NFILE = 27
IF (BETA) NFILE = 28
CALL NBREAD(OCC,L1,NFILE)
COUNT UP THE TOTAL NUMBER OF ELECTRONS AS AN INTEGER NELEC:
ELE = ZERO
DO 10 I = 1,NBAS
ELE = ELE + OCC(I)
10 CONTINUE
ELE = ELE + TENTH
NELEC = ELE
FETCH THE VARIOUS LISTS OF NBO INFORMATION FOR USE IN THE DELETIONS.
UNPACK THE INFORMATION INTO LABEL(MAXBAS,6),IBXM(MAXBAS),IATNO(MAXBAS),
NBOUNI(MAXBAS) AND NBOTYP(MAXBAS) FROM ISCR(10*NDIM):
NFILE = 60
IF (BETA) NFILE = 61
CALL NBREAD(ISCR,L4,NFILE)
II = 0
DO 40 K = 1,6
DO 30 I = 1,NBAS
II = II + 1
LABEL(I,K) = ISCR(II)
30 CONTINUE
40 CONTINUE
DO 50 I = 1,NBAS
II = II + 1
IBXM(I) = ISCR(II)
50 CONTINUE
DO 60 I = 1,NATOMS
II = II + 1
IATNO(I) = ISCR(II)
60 CONTINUE
DO 70 I = 1,NBAS
II = II + 1
NBOUNI(I) = ISCR(II)
70 CONTINUE
DO 80 I = 1,NBAS
II = II + 1
NBOTYP(I) = ISCR(II)
80 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE FETNBO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
FETNBO: FETCH THE AO TO NBO TRANSFORMATION MATRIX
L3 = NDIM*NDIM
NFILE = 44
IF (BETA) NFILE = 45
CALL NBREAD(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE SVPNAO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
SVPNAO: SAVES THE AO TO PNAO TRANSFORMATION MATRIX.
NFILE = 42
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FEPNAO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
FEPNAO: FETCHES THE AO TO PNAO TRANSFORMATION MATRIX.
NFILE = 42
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE SVSNAO(S)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION S(NDIM,NDIM)
SVSNAO: SAVE THE OVERLAP MATRIX IN THE PNAO OR RPNAO BASIS SET.
NFILE = 11
L2 = NDIM*(NDIM+1)/2
CALL PACK(S,NDIM,NBAS,L2)
CALL NBWRIT(S,L2,NFILE)
CALL UNPACK(S,NDIM,NBAS,L2)
RETURN
END
*****************************************************************************
SUBROUTINE FESNAO(S)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION S(NDIM,NDIM)
FESNAO: FETCH THE OVERLAP MATRIX IN THE PNAO OR RPNAO BASIS SET.
NFILE = 11
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(S,L2,NFILE)
CALL UNPACK(S,NDIM,NBAS,L2)
RETURN
END
*****************************************************************************
SUBROUTINE SVTNAB(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
SVTNAB: SAVE THE NAO TO NBO TRANSFORMATION MATRIX.
NFILE = 48
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FETNAB(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
FETNAB: FETCH THE NAO TO NBO TRANSFORMATION MATRIX
NFILE = 48
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE SVTLMO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
SVTLMO: SAVE THE NBO TO NLMO TRANSFORMATION MATRIX.
NFILE = 49
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FETLMO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
FETLMO: FETCH THE NBO TO NLMO TRANSFORMATION MATRIX
NFILE = 49
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE SVTNHO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
SVTNHO: TEMPORARILY SAVE THE NAO TO NHO TRANSFORMATION
NFILE = 47
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FETNHO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
FETNHO: FETCH THE NAO TO NHO TRANSFORMATION
NFILE = 47
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE SVPPAO(DM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION DM(NDIM,NDIM)
SVPPAO: TEMPORARILY SAVES THE PURE AO (PAO) DENSITY MATRIX.
(THIS IS NOT THE RAW AO BASIS, BUT THE BASIS AFTER THE
TRANSFORMATION FROM CARTESIAN TO PURE D,F,G FUNCTIONS).
NFILE = 22
L2 = NDIM*(NDIM+1)/2
CALL PACK(DM,NDIM,NBAS,L2)
CALL NBWRIT(DM,L2,NFILE)
CALL UNPACK(DM,NDIM,NBAS,L2)
RETURN
END
*****************************************************************************
SUBROUTINE FEPPAO(DM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION DM(NDIM,NDIM)
FEPPAO: FETCHES THE PURE AO (PAO) DENSITY MATRIX.
(THIS IS NOT THE RAW AO BASIS, BUT THE BASIS AFTER THE
TRANSFORMATION FROM CARTESIAN TO PURE D,F,G FUNCTIONS).
NFILE = 22
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(DM,L2,NFILE)
CALL UNPACK(DM,NDIM,NBAS,L2)
RETURN
END
*****************************************************************************
SUBROUTINE SVTNAO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
SVTNAO: SAVE THE AO TO NAO TRANSFORMATION MATRIX.
IF(.NOT.ORTHO) THEN
NFILE = 43
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
END IF
RETURN
END
*****************************************************************************
SUBROUTINE FETNAO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
DATA ZERO,ONE/0.0D0,1.0D0/
FETNAO: FETCHES THE AO TO NAO TRANSFORMATION MATRIX.
IF(ORTHO) THEN
DO 20 J = 1,NDIM
DO 10 I = 1,NDIM
T(I,J) = ZERO
10 CONTINUE
T(J,J) = ONE
20 CONTINUE
ELSE
NFILE = 43
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
END IF
RETURN
END
*****************************************************************************
SUBROUTINE SVNLMO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
SVNLMO: SAVE THE AO TO NLMO TRANSFORMATION MATRIX
NFILE = 46
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FENLMO(T)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
FENLMO: FETCH THE AO TO NLMO TRANSFORMATION MATRIX
NFILE = 46
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE SVDNAO(DM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION DM(NDIM,NDIM)
SVDNAO: SAVE THE NAO DENSITY MATRIX
IF(.NOT.ORTHO) THEN
NFILE = 23
IF(BETA) NFILE = 24
L2 = NDIM*(NDIM+1)/2
CALL PACK(DM,NDIM,NBAS,L2)
CALL NBWRIT(DM,L2,NFILE)
CALL UNPACK(DM,NDIM,NBAS,L2)
END IF
RETURN
END
*****************************************************************************
SUBROUTINE FEDNAO(DM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION DM(NDIM,NDIM)
FEDNAO: FETCHES THE NAO DENSITY MATRIX (AO DM FOR ORTHOGONAL BASIS SETS)
IF(ORTHO) THEN
CALL FEDRAW(DM,DM)
ELSE
NFILE = 23
IF(BETA) NFILE = 24
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(DM,L2,NFILE)
CALL UNPACK(DM,NDIM,NBAS,L2)
END IF
RETURN
END
*****************************************************************************
SUBROUTINE SVFNBO(F)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION F(NDIM,NDIM)
SVFNBO: SAVES THE NBO FOCK MATRIX
NFILE = 34
IF (BETA) NFILE = 35
L2 = NDIM*(NDIM+1)/2
CALL PACK(F,NDIM,NBAS,L2)
CALL NBWRIT(F,L2,NFILE)
CALL UNPACK(F,NDIM,NBAS,L2)
RETURN
END
*****************************************************************************
SUBROUTINE FEFNBO(F)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION F(1)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
FEFNBO: FETCHES THE NBO FOCK MATRIX, LEAVING IT IN TRIANGULAR FORM!!
IF ALPHA.EQ.TRUE. WE WANT THE ALPHA FOCK MATRIX
IF BETA.EQ.TRUE. WE WANT THE BETA FOCK MATRIX.
NFILE = 34
IF (BETA) NFILE = 35
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(F,L2,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE SVNEWD(DM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION DM(1)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
SVNEWD: SAVE THE NEW DENSITY MATRIX (RAW AO BASIS) FROM NBO DELETION
NFILE = 25
IF (BETA) NFILE = 26
L2 = NDIM*(NDIM+1)/2
CALL NBWRIT(DM,L2,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FENEWD(DM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION DM(1)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
FENEWD: FETCH THE NEW DENSITY MATRIX (RAW AO BASIS)
NFILE = 25
IF (BETA) NFILE = 26
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(DM,L2,NFILE)
RETURN
END
*****************************************************************************
SUBROUTINE FEINFO(ICORE,ISWEAN)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION ICORE(12)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBBAS/LABEL(MAXBAS,6),LVAL(MAXBAS),IMVAL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
Restore wavefunction information from the NBO DAF:
Restore NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:
NFILE = 3
CALL NBREAD(ICORE,12,NFILE)
NATOMS = ICORE(1)
NDIM = ICORE(2)
NBAS = ICORE(3)
MUNIT = ICORE(4)
ROHF = .FALSE.
IF(ICORE(5).EQ.1) ROHF = .TRUE.
UHF = .FALSE.
IF(ICORE(6).EQ.1) UHF = .TRUE.
CI = .FALSE.
IF(ICORE(7).EQ.1) CI = .TRUE.
OPEN = .FALSE.
IF(ICORE(8).EQ.1) OPEN = .TRUE.
MCSCF = .FALSE.
IF(ICORE(9).EQ.1) MCSCF = .TRUE.
AUHF = .FALSE.
IF(ICORE(10).EQ.1) AUHF = .TRUE.
ORTHO = .FALSE.
IF(ICORE(11).EQ.1) ORTHO = .TRUE.
ISWEAN = ICORE(12)
IF ISWEAN IS 1, SET ICORE(12) TO 0 AND WRITE TO NBO DAF. NOTE, ISWEAN IS
SET TO 1 BY THE FEAOIN DRIVER ROUTINE. THIS TELLS THE ENERGETIC ANALYSIS
ROUTINES TO SEARCH FOR THE $DEL KEYLIST. ISWEAN IS RESET TO 0 HERE SO
THAT MULTIPLE DELETIONS CAN BE READ FROM A SINGLE $DEL KEYLIST:
IF(ISWEAN.EQ.1) THEN
ICORE(12) = 0
CALL NBWRIT(ICORE,12,NFILE)
END IF
RETURN
END
*****************************************************************************
FREE FORMAT INPUT ROUTINES:
SUBROUTINE STRTIN(LFNIN)
SUBROUTINE RDCRD
SUBROUTINE IFLD(INT,ERROR)
SUBROUTINE RFLD(REAL,ERROR)
SUBROUTINE HFLD(KEYWD,LENG,ENDD)
SUBROUTINE FNDFLD
FUNCTION EQUAL(IA,IB,L)
*****************************************************************************
USER INSTRUCTIONS:
1. THE CHARACTER STRING "END" IS THE FIELD TERMINATING MARK:
2. COMMAS AND EQUAL SIGNS ARE TREATED AS EQUIVALENT TO BLANKS.
COMMAS, EQUAL SIGNS, AND BLANKS DELIMIT INPUT ITEMS.
3. ALL CHARACTERS TO THE RIGHT OF AN EXCLAMATION MARK ! ARE TREATED AS
COMMENTS, AND THE NEXT CARD IS READ IN WHEN THESE ARE ENCOUNTERED.
4. UPPER AND LOWER CASE CHARACTERS CAN BE READ BY THESE ROUTINES.
HOWEVER, LOWER CASE CHARACTERS ARE CONVERTED TO UPPER CASE
WHEN ENCOUNTERED.
5. TO READ IN DATA FOR THE FIRST TIME FROM LFN "LFNIN" (PERHAPS
AFTER USING THESE SUBROUTINES TO READ IN DATA FROM ANOTHER LFN),
OR TO CONTINUE READING IN DATA FROM LFNIN AFTER ENCOUNTERING
A FIELD TERMINATING MARK, CALL STRTIN(LFNIN) (START INPUT)
6. TO FETCH THE NEXT NON-BLANK STRING OF CHARACTERS FROM LFN LFNIN,
CALL HFLD(KEYWD,LENGTH,END),
WHERE KEYWD IS A VECTOR OF DIMENSION "LENGTH" OR LONGER,
LENGTH IS THE MAXIMUM NUMBER OF CHARACTERS TO FETCH,
END MUST BE A DECLARED LOGICAL VARIABLE.
UPON RETURN,
END=.TRUE. IF A FIELD TERMINATING MARK WAS FOUND TO BE THE NEXT
NON-BLANK CHARACTER STRING. OTHERWISE, END=.FALSE.
END=.TRUE. AND LENGTH=0 MEANS THE END-OF-FILE WAS FOUND.
LENGTH IS CHANGED TO THE ACTUAL NUMBER OF CHARACTERS IN STRING
IF THIS IS LESS THAN THE VALUE OF LENGTH SET BY THE CALLING
PROGRAM.
KEYWD(1) THROUGH KEYWD(LENGTH) CONTAIN THE CHARACTER STRING,
ONE CHARACTER PER ELEMENT OF KEYWD.
7. TO FETCH THE INTEGER VALUE OF THE NEXT CHARACTER STRING,
CALL IFLD(INT,ERROR),
WHERE INT IS THE VARIABLE TO BE READ,
ERROR MUST BE A DECLARED LOGICAL VARIABLE.
UPON RETURN,
IF ERROR=.FALSE., AN INTEGER WAS FOUND AND PLACED IN "INT".
IF ERROR=.TRUE. AND INT.GT.0, A FIELD TERMINATING MARK WAS
FOUND AS THE NEXT CHARACTER STRING.
IF ERROR=.TRUE. AND INT.LT.0, THE NEXT CHARACTER STRING FOUND
WAS NEITHER AN INTEGER NOR A FIELD TERMINATING MARK.
8. TO FETCH THE REAL VALUE OF THE NEXT CHARACTER STRING,
(AN EXPONENT IS ALLOWED, WITH OR WITHOUT AN "E" OR "F".
IF NO LETTER IS PRESENT TO SIGNIFY THE EXPONENT FIELD,
A + OR - SIGN MUST START THE EXPONENT. IF NO MANTISSA IS
PRESENT, THE EXPONENT FIELD MUST START WITH A LETTER, AND
THE MANTISSA IS SET TO ONE.)
CALL RFLD(REAL,ERROR),
WHERE REAL IS THE VARIABLE TO BE READ,
ERROR MUST BE A DECLARED LOGICAL VARIABLE.
UPON RETURN,
IF ERROR=.FALSE., A REAL NUMBER WAS FOUND AND PLACED IN "REAL".
IF ERROR=.TRUE. AND REAL.GT.1, A FIELD TERMINATING MARK WAS
FOUND AS THE NEXT CHARACTER STRING.
IF ERROR=.TRUE. AND REAL.LT.-1, THE NEXT CHARACTER STRING FOUND
WAS NEITHER A REAL NUMBER NOR A FIELD TERMINATING MARK.
9. TO COMPARE THE CORRESPONDING FIRST L ELEMENTS OF EACH OF TWO VECTORS
IA(L) AND IB(L) TO SEE IF THE VECTORS ARE EQUIVALENT,
USE THE FUNCTION EQUAL(IA,IB,L).
EQUAL MUST BE DECLARED LOGICAL IN THE CALLING PROGRAM,
AND THE FUNCTION VALUE (.TRUE. OR .FALSE.) WILL TELL IF THE
VECTORS IA AND IB ARE EQUAL UP TO ELEMENT L.
NOTE: THIS FUNCTION IS USEFUL FOR DETERMINING IF A CHARACTER STRING
READ BY A CALL TO HFLD MATCHES A CERTAIN KEYWORD WHICH IS STORED
IN A VECTOR, ONE CHARACTER PER ELEMENT.
*****************************************************************************
SUBROUTINE STRTIN(LFNIN)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
INITIALIZE INPUT FROM LFN LFNIN:
LFN = LFNIN
END = .FALSE.
NEXT = .TRUE.
CALL RDCRD
RETURN
END
*****************************************************************************
SUBROUTINE RDCRD
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
SUBROUTINE NAME CHANGED FROM RDCARD, DUE TO CONFLICT WITH GAMESS:
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
DATA IA,ICHARA,ICHARZ/1HA,1Ha,1Hz/
DATA IBLNK,IQ,II/1H ,1H`,1HI/
READ IN THE NEXT CARD AT LFN:
READ(LFN,1000,END=800,ERR=800) ICD
CHANGE ALL LOWER CASE CHARACTERS TO UPPER CASE:
DO 10 I = 1,80
IF(ICD(I).GE.ICHARA.AND.ICD(I).LE.ICHARZ) THEN
ICD(I) = ICD(I) - ICHARA + IA
END IF
10 CONTINUE
TREAT TABS AS SPACES:
ITAB = IBLNK + II - IQ
DO 20 I = 1,80
IF(ICD(I).EQ.ITAB) ICD(I) = IBLNK
20 CONTINUE
RESET COLUMN POINTER, IPT:
IPT = 1
RETURN
END OF FILE ENCOUNTERED
800 CONTINUE
END = .TRUE.
RETURN
1000 FORMAT(80A1)
END
*****************************************************************************
SUBROUTINE IFLD(INT,ERROR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
DATA ZERO,ONE,SMALL/0.0D0,1.0D0,1.0D-3/
SEARCH LFN FOR THE NEXT STRING OF NON-BLANK CHARACTERS, SEE IF THEY
FORM AN INTEGER (IF NOT, ERROR=.TRUE.) AND, IF SO, PLACE ITS NUMERICAL
VALUE IN "INT":
INT = 0
CALL RFLD(REAL,ERROR)
IF DECIMAL POINT OR AN EXPONENT.LT.0, ERROR = .TRUE.:
IF(EXP) GO TO 100
IF(POINT) GO TO 100
IF(NEXP.LT.0) GO TO 100
IF(LENGTH.EQ.0) GO TO 100
SIGN = ONE
IF(REAL.LT.ZERO) SIGN = -ONE
REAL = REAL + SMALL * SIGN
INT = REAL
RETURN
100 ERROR = .TRUE.
NEXT = .FALSE.
RETURN
END
*****************************************************************************
SUBROUTINE RFLD(REAL,ERROR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR,EXPSGN,MANTIS
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
DIMENSION NCHAR(15)
DATA NCHAR/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H.,1H+,1H-,
+ 1HD,1HE/
DATA ZERO,ONE,TEN/0.0D0,1.0D0,10.0D0/
SEARCH LFN FOR THE NEXT STRING OF NON-BLANK CHARACTERS, SEE IF THEY FORM
A REAL NUMBER (EXPONENT IS OPTIONAL) (IF NOT, ERROR=.TRUE.) AND, IF SO,
PLACE ITS NUMERICAL VALUE IN "REAL":
REAL = ZERO
SIGN = ONE
NDEC = 0
ISEXP = 1
NEXP = 0
EXPSGN = .FALSE.
EXP = .FALSE.
POINT = .FALSE.
ERROR = .FALSE.
MANTIS = .FALSE.
END = .FALSE.
FIND THE NEXT STRING OF NON-BLANK CHARACTERS, "LOOK", OF LENGTH "LENGTH":
IF(NEXT) CALL FNDFLD
IF(END) GO TO 300
IF(LENGTH.EQ.0) GO TO 300
FIND THE NUMERICAL VALUE OF THE CHARACTERS IN "LOOK":
DO 200 J = 1,LENGTH
LK = LOOK(J)
DO 20 I = 1,15
IF(LK.EQ.NCHAR(I)) GO TO 40
20 CONTINUE
GO TO 300
40 K = I - 11
IF(K) 60,80,100
THIS CHARACTER IS A NUMBER:
60 CONTINUE
IF(EXP) GO TO 70
ADD DIGIT TO MANTISSA:
MANTIS = .TRUE.
REAL = REAL * TEN + FLOAT(I - 1)
IF WE ARE TO THE RIGHT OF A DECIMAL POINT, INCREMENT THE DECIMAL COUNTER:
IF(POINT) NDEC = NDEC + 1
GO TO 200
ADD DIGIT TO EXPONENT:
70 NEXP = NEXP * 10 + (I - 1)
GO TO 200
DECIMAL POINT:
80 IF(POINT) GO TO 300
POINT = .TRUE.
GO TO 200
EXPONENT (+,-,D,E):
100 CONTINUE
GO TO (110,130,150,150), K
PLUS SIGN: IF NOT FIRST CHARACTER, COUNT AS PART OF EXPONENT:
110 IF(J.EQ.1) GO TO 200
IF(EXPSGN) GO TO 200
EXPSGN = .TRUE.
EXP = .TRUE.
GO TO 200
MINUS SIGN: IF NOT FIRST CHARACTER, COUNT AS PART OF EXPONENT:
130 IF(J.NE.1) GO TO 140
SIGN = -ONE
GO TO 200
140 ISEXP = -1
IF(EXPSGN) GO TO 200
EXPSGN = .TRUE.
EXP = .TRUE.
GO TO 200
D OR E: START OF EXPONENT:
150 IF(EXP) GO TO 300
EXP = .TRUE.
200 CONTINUE
SET FINAL VALUE OF REAL (IF NO MANTISSA, BUT EXPONENT PRESENT,
SET MANTISSA TO ONE):
IF(EXP.AND..NOT.MANTIS) REAL = ONE
REAL = REAL * SIGN * (TEN**(-NDEC+ISEXP*NEXP))
NEXT = .TRUE.
RETURN
NO REAL NUMBER FOUND, OR FIELD TERMINATING MARK:
300 CONTINUE
ERROR = .TRUE.
REAL = -TEN
IF(END) REAL = TEN
RETURN
END
*****************************************************************************
SUBROUTINE HFLD(KEYWD,LENG,ENDD)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ENDD,EQUAL
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
DIMENSION KEYWD(LENG),KEND(3)
DATA NBLA/1H /
DATA KEND/1HE,1HN,1HD/
SEARCH LFN AND FIND NEXT NON-BLANK STRING OF CHARACTERS AND PLACE
IN THE VECTOR "KEYWD". LENG, FROM THE CALLING PROGRAM, IS MAXIMUM
LENGTH OF STRING TO PUT IN THE VECTOR KEYWD. IF "LENGTH" IS LESS
THAN "LENG", LENG IS SET TO LENGTH UPON RETURN:
IF(NEXT) CALL FNDFLD
ENDD = END
LENG1 = LENG
LENG = MIN0(LENGTH,LENG)
PLACE LENG CHARACTERS INTO KEYWD:
DO 10 I = 1,LENG
KEYWD(I) = LOOK(I)
10 CONTINUE
FILL THE REST OF KEYWD WITH BLANKS:
DO 20 I = LENG+1,LENG1
KEYWD(I) = NBLA
20 CONTINUE
NEXT = .TRUE.
CHECK FOR END OF INPUT:
IF(EQUAL(LOOK,KEND,3)) ENDD = .TRUE.
RETURN
END
*****************************************************************************
SUBROUTINE FNDFLD
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
DATA NBLA/1H /,NCOM/1H,/,NEXC/1H!/,NEQ/1H=/
FIND NEXT NON-BLANK STRING OF CHARACTERS IN LFN. READ IN ANOTHER LINE
OF LFN UNTIL NON-BLANK CHARACTERS ARE FOUND AND PLACE THEM IN "LOOK",
OF LENGTH "LENGTH":
IF(END) GO TO 35
IF(IPT.GE.80) CALL RDCRD
IF(END) GO TO 35
LOOK FOR START OF FIELD. SKIP TO NEXT CARD IF "!" IS ENCOUNTERED
(COMMENT FIELD):
10 CONTINUE
DO 20 NCOL = IPT,80
ICARD = ICD(NCOL)
IF(ICARD.EQ.NEXC) GO TO 30
IF(ICARD.NE.NBLA.AND.ICARD.NE.NCOM.AND.ICARD.NE.NEQ) GO TO 40
20 CONTINUE
NOTHING ADDITIONAL FOUND ON THIS CARD, CONTINUE WITH THE NEXT CARD:
30 CALL RDCRD
IF(.NOT.END) GO TO 10
END OF FILE FOUND:
35 LENGTH = 0
RETURN
LOOK FOR THE END OF THIS FIELD, COUNTING CHARACTERS AS WE GO AND
STORING THESE CHARACTER IN LOOK:
40 M = 0
DO 80 MCOL = NCOL,80
ICHAR = ICD(MCOL)
IF(ICHAR.EQ.NBLA.OR.ICHAR.EQ.NCOM.OR.ICHAR.EQ.NEQ) GO TO 100
M = M + 1
LOOK(M) = ICHAR
80 CONTINUE
SET LENGTH TO THE LENGTH OF THE NEW STRING IN LOOK AND RESET IPT TO
THE NEXT SPACE AFTER THIS STRING:
100 LENGTH = M
IPT = MCOL
NEXT = .FALSE.
RETURN
END
*****************************************************************************
FUNCTION EQUAL(IA,IB,L)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL EQUAL
DIMENSION IA(L),IB(L)
TEST IF THE FIRST L ELEMENTS OF VECTORS IA AND IB ARE EQUAL:
EQUAL = .FALSE.
DO 10 I = 1,L
IF(IA(I).NE.IB(I)) GO TO 20
10 CONTINUE
EQUAL = .TRUE.
20 RETURN
END
*****************************************************************************
OTHER SYSTEM-INDEPENDENT I/O ROUTINES:
SUBROUTINE GENINP(NEWDAF)
SUBROUTINE NBOINP(NBOOPT,IDONE)
SUBROUTINE CORINP(IESS,ICOR)
SUBROUTINE CHSINP(IESS,ICHS)
SUBROUTINE DELINP(NBOOPT,IDONE)
SUBROUTINE RDCORE(JCORE)
SUBROUTINE WRPPNA(T,OCC,IFLG)
SUBROUTINE RDPPNA(T,OCC,IFLG)
SUBROUTINE WRTNAO(T,IFLG)
SUBROUTINE RDTNAO(DM,T,SCR,IFLG)
SUBROUTINE WRTNAB(T,IFLG)
SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG)
SUBROUTINE WRTNBO(T,BNDOCC,IFLG)
SUBROUTINE WRNLMO(T,DM,IFLG)
SUBROUTINE WRBAS(SCR,ISCR,LFN)
SUBROUTINE WRARC(SCR,ISCR,LFN)
SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG)
SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL)
SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN)
SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR)
SUBROUTINE ALTOUT(A,MR,MC,NR,NC)
SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR)
FUNCTION IOINQR(IFLG)
SUBROUTINE LBLAO
SUBROUTINE LBLNAO
SUBROUTINE LBLNBO
SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR)
*****************************************************************************
SUBROUTINE GENINP(NEWDAF)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL NEWDAF,END,ERROR,EQUAL
DIMENSION KEYWD(6),KGEN(4),KEND(4),KREUSE(5),KNBAS(4),KNATOM(6),
+ KUPPER(5),KOPEN(4),KORTHO(5),KBOHR(4),KBODM(4),KEV(2),
+ KCUBF(6)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBGEN/REUSE,UPPER,BOHR,DENOP
LOGICAL REUSE,UPPER,BOHR,DENOP
DATA KGEN/1H$,1HG,1HE,1HN/,KEND/1H$,1HE,1HN,1HD/,
+ KREUSE/1HR,1HE,1HU,1HS,1HE/,KNBAS/1HN,1HB,1HA,1HS/,
+ KNATOM/1HN,1HA,1HT,1HO,1HM,1HS/,KUPPER/1HU,1HP,1HP,1HE,1HR/,
+ KOPEN/1HO,1HP,1HE,1HN/,KORTHO/1HO,1HR,1HT,1HH,1HO/,
+ KBOHR/1HB,1HO,1HH,1HR/,KBODM/1HB,1HO,1HD,1HM/,
+ KEV/1HE,1HV/KCUBF/1HC,1HU,1HB,1HI,1HC,1HF/
Initialize variables:
NBAS = 0
NATOMS = 0
MUNIT = 0
REUSE = .FALSE.
UPPER = .FALSE.
BOHR = .FALSE.
DENOP = .TRUE.
Search LFNIN for $GEN:
REWIND(LFNIN)
10 CALL STRTIN(LFNIN)
LEN = 6
CALL HFLD(KEYWD,LEN,END)
IF(LEN.EQ.0.AND.END) STOP 'No $GEN keylist in the input file'
IF(.NOT.EQUAL(KEYWD,KGEN,4)) GOTO 10
$GEN has been found, now read keywords:
20 LEN = 6
CALL HFLD(KEYWD,LEN,END)
IF(EQUAL(KEYWD,KEND,4)) GOTO 700
Keyword REUSE -- reuse data already stored on the NBO DAF:
IF(EQUAL(KEYWD,KREUSE,5)) THEN
REUSE = .TRUE.
GOTO 20
END IF
Keyword NBAS -- Specify the number of basis functions:
IF(EQUAL(KEYWD,KNBAS,4)) THEN
CALL IFLD(NBAS,ERROR)
IF(ERROR) STOP 'Error reading in number of basis functions NBAS'
GOTO 20
END IF
Keyword NATOMS -- Specify the number of atoms:
IF(EQUAL(KEYWD,KNATOM,4)) THEN
CALL IFLD(NATOMS,ERROR)
IF(ERROR) STOP 'Error reading in number of atoms NATOMS'
GOTO 20
END IF
Keyword UPPER -- Read only upper triangular portions of matrices:
IF(EQUAL(KEYWD,KUPPER,5)) THEN
UPPER = .TRUE.
GOTO 20
END IF
Keyword OPEN -- Open shell species (alpha and beta matrices read):
IF(EQUAL(KEYWD,KOPEN,4)) THEN
OPEN = .TRUE.
GOTO 20
END IF
Keyword ORTHO -- Orthogonal basis set (Skip NAO analysis):
IF(EQUAL(KEYWD,KORTHO,5)) THEN
ORTHO = .TRUE.
GOTO 20
END IF
Keyword BOHR -- Atomic coordinates, dipole integrals in bohr:
IF(EQUAL(KEYWD,KBOHR,4)) THEN
BOHR = .TRUE.
GOTO 20
END IF
Keyword BODM -- Input bond order matrix:
IF(EQUAL(KEYWD,KBODM,4)) THEN
DENOP = .FALSE.
GOTO 20
END IF
Keyword EV -- Expectation values of the Fock operator are in eV:
IF(EQUAL(KEYWD,KEV,2)) THEN
MUNIT = 1
GOTO 20
END IF
Keyword CUBICF -- Use set of cubic f functions:
IF(EQUAL(KEYWD,KCUBF,6)) THEN
IWCUBF = 1
GOTO 20
END IF
Unknown keyword -- halt program:
WRITE(LFNPR,900) KEYWD
STOP
End of $GEN input encountered, make sure GENNBO has all info needed:
700 CONTINUE
IF(REUSE) THEN
NEWDAF = .FALSE.
RETURN
ELSE
NEWDAF = .TRUE.
ENDIF
NDIM = NBAS
IF(NBAS.LE.0) STOP 'NBAS must be specified in $GEN keylist'
IF(NBAS.GT.MAXBAS) STOP 'Increase parameter MAXBAS'
IF(NATOMS.LE.0) STOP 'NATOMS must be specified in $GEN keylist'
IF(NATOMS.GT.MAXATM) STOP 'Increase parameter MAXATM'
RETURN
900 FORMAT(1X,'Unrecognized keyword >',6A1,'<')
END
*****************************************************************************
SUBROUTINE NBOINP(NBOOPT,IDONE)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL END,EQUAL
DIMENSION NBOOPT(10)
DIMENSION KEYWD(6),KNBO(4)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DATA KNBO/1H$,1HN,1HB,1HO/
If NBOOPT(1) = 1, don't search for keywords, just continue with
default options:
IF(NBOOPT(1).EQ.1) THEN
IDONE = 0
RETURN
END IF
If this is the GAMESS, HONDO, or general version of the NBO program,
rewind the input file before searching for $NBO:
IREP = 1
IF(NBOOPT(10).EQ.0) IREP = 0
IF(NBOOPT(10).EQ.6) IREP = 0
IF(NBOOPT(10).EQ.7) IREP = 0
IF(IREP.EQ.0) REWIND(LFNIN)
Search input file for $NBO:
10 CALL STRTIN(LFNIN)
LEN = 6
CALL HFLD(KEYWD,LEN,END)
IF(EQUAL(KEYWD,KNBO,4)) GOTO 50
IF(LEN.EQ.0.AND.END) GOTO 60
GOTO 10
$NBO found -- continue with the NBO analysis:
50 CONTINUE
IDONE = 0
RETURN
End of file encountered -- Stop NBO analysis, except for the general
version of the program (set NBOOPT(1) so keywords are not read):
60 CONTINUE
IF(IREP.EQ.1) THEN
REWIND(LFNIN)
IREP = IREP + 1
GOTO 10
ELSE IF(NBOOPT(10).EQ.0) THEN
NBOOPT(1) = 1
IDONE = 0
ELSE
IDONE = 1
END IF
RETURN
END
*****************************************************************************
SUBROUTINE CORINP(IESS,ICOR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL END,EQUAL
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION KEYWD(6),KCOR(4),KCHS(4),KDEL(4),KNBO(4),KNRT(4)
DATA KCOR/1H$,1HC,1HO,1HR/,KCHS/1H$,1HC,1HH,1HO/,
+ KDEL/1H$,1HD,1HE,1HL/,KNBO/1H$,1HN,1HB,1HO/,
+ KNRT/1H$,1HN,1HR,1HT/
If ICOR is set to -1, do not read in the $CORE keylist:
IF(ICOR.EQ.-1) RETURN
If this is the GAMESS, HONDO, or general version of the NBO program,
rewind the input file before searching for $CORE:
IREP = 1
IF(IESS.EQ.0) IREP = 0
IF(IESS.EQ.6) IREP = 0
IF(IESS.EQ.7) IREP = 0
IF(IREP.EQ.0) REWIND(LFNIN)
Search input file for $CORE:
10 CALL STRTIN(LFNIN)
LEN = 6
CALL HFLD(KEYWD,LEN,END)
IF(EQUAL(KEYWD,KCOR,4)) GOTO 50
IF(EQUAL(KEYWD,KNBO,4)) GOTO 60
IF(EQUAL(KEYWD,KCHS,4)) GOTO 60
IF(EQUAL(KEYWD,KDEL,4)) GOTO 60
IF(EQUAL(KEYWD,KNRT,4)) GOTO 60
IF(LEN.EQ.0.AND.END) GOTO 70
GOTO 10
$CORE found:
50 CONTINUE
ICOR = 1
RETURN
$NBO, $CHOOSE, $DEL -- discontinue the search for $CORE (GAUSSIAN, AMPAC)
or $NRT continue searching for $CORE (GENNBO, GAMESS, HONDO)
60 CONTINUE
IF(IREP.EQ.0) GOTO 10
BACKSPACE(LFNIN)
ICOR = 0
RETURN
End of file encountered:
70 CONTINUE
ICOR = 0
RETURN
END
*****************************************************************************
SUBROUTINE CHSINP(IESS,ICHS)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL END,EQUAL
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION KEYWD(6),KCHS(4),KDEL(4),KNBO(4),KNRT(4)
DATA KCHS/1H$,1HC,1HH,1HO/,KDEL/1H$,1HD,1HE,1HL/,
+ KNBO/1H$,1HN,1HB,1HO/,KNRT/1H$,1HN,1HR,1HT/
If ICHS is set to -1, do not search for the $CHOOSE keylist:
IF(ICHS.EQ.-1) RETURN
If this is the GAMESS, HONDO, or general version of the NBO program,
rewind the input file before searching for $CHOOSE:
IREP = 1
IF(IESS.EQ.0) IREP = 0
IF(IESS.EQ.6) IREP = 0
IF(IESS.EQ.7) IREP = 0
IF(IREP.EQ.0) REWIND(LFNIN)
Search input file for $CHOOSE:
10 CALL STRTIN(LFNIN)
LEN = 6
CALL HFLD(KEYWD,LEN,END)
IF(EQUAL(KEYWD,KCHS,4)) GOTO 50
IF(EQUAL(KEYWD,KNBO,4)) GOTO 60
IF(EQUAL(KEYWD,KDEL,4)) GOTO 60
IF(EQUAL(KEYWD,KNRT,4)) GOTO 60
IF(LEN.EQ.0.AND.END) GOTO 70
GOTO 10
$CHOOSE found:
50 CONTINUE
ICHS = 1
RETURN
$NBO, $DEL found -- discontinue the search for $CHOOSE (GAUSSIAN, AMPAC)
or $NRT continue searching for $CHOOSE (GENNBO, GAMESS, HONDO)
60 CONTINUE
IF(IREP.EQ.0) GOTO 10
BACKSPACE(LFNIN)
ICHS = 0
RETURN
End of file encountered:
70 CONTINUE
ICHS = 0
RETURN
END
*****************************************************************************
SUBROUTINE DELINP(NBOOPT,IDONE)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL END,EQUAL
DIMENSION NBOOPT(10)
DIMENSION KEYWD(6),KDEL(4),KNBO(4)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DATA KDEL/1H$,1HD,1HE,1HL/,KNBO/1H$,1HN,1HB,1HO/
If this is the GAMESS, HONDO, or general version of the NBO program,
rewind the input file before searching for $DEL:
IREP = 1
IF(NBOOPT(10).EQ.0) IREP = 0
IF(NBOOPT(10).EQ.6) IREP = 0
IF(NBOOPT(10).EQ.7) IREP = 0
IF(IREP.EQ.0) REWIND(LFNIN)
Search input file for $DEL:
10 CALL STRTIN(LFNIN)
LEN = 6
CALL HFLD(KEYWD,LEN,END)
IF(EQUAL(KEYWD,KDEL,4)) GOTO 50
IF(EQUAL(KEYWD,KNBO,4)) GOTO 60
IF(LEN.EQ.0.AND.END) GOTO 70
GOTO 10
$DEL found -- continue with the NBO energetic analysis:
50 CONTINUE
IDONE = 0
RETURN
$NBO found -- discontinue the search for $DEL (GAUSSIAN, AMPAC)
continue searching for $DEL (GENNBO, GAMESS, HONDO)
60 CONTINUE
IF(IREP.EQ.0) GOTO 10
BACKSPACE(LFNIN)
IDONE = 1
RETURN
End of file encountered -- Stop NBO energetic analysis
70 CONTINUE
IF(IREP.EQ.1) THEN
REWIND(LFNIN)
IREP = IREP + 1
GOTO 10
ELSE
IDONE = 1
END IF
RETURN
END
*****************************************************************************
SUBROUTINE RDCORE(JCORE)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
Initialize the atomic core array:
DO 10 I = 1,NATOMS
IATCR(I) = -1
10 CONTINUE
Read in modifications to the nominal core table:
IF(JCORE.EQ.1) THEN
WRITE(LFNPR,900)
30 CALL IFLD(II,ERROR)
IF(ERROR) GOTO 40
IF(II.LT.1.OR.II.GT.NATOMS) GOTO 810
CALL IFLD(JJ,ERROR)
IF(ERROR) GOTO 820
IF(JJ.LT.0) GOTO 830
IATCR(II) = JJ
GOTO 30
END IF
40 CONTINUE
RETURN
810 WRITE(LFNPR,910) II
STOP
820 WRITE(LFNPR,920) II
STOP
830 WRITE(LFNPR,930) JJ,II
STOP
900 FORMAT(/1X,'Modified core list read from the $CORE keylist')
910 FORMAT(/1X,'ATOM ',I4,' not found on this molecule')
920 FORMAT(/1X,'No core orbitals selected for atom ',I4)
930 FORMAT(/1X,I4,' core orbitals on atom ',I4,' does not make sense')
END
*****************************************************************************
SUBROUTINE WRPPNA(T,OCC,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
DIMENSION T(NDIM,NDIM),OCC(NDIM)
CHARACTER*80 TITLE
Write the PNAO information to the external file ABS(IFLG):
NOTE: This is the pure-AO to PNAO transformation, not the raw AO
to PNAO transform.
TITLE = 'PNAOs in the PAO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,-1,IFLG)
Write the NAO orbital labels to the external file:
LFN = ABS(IFLG)
WRITE(LFN,900) (NAOCTR(J),J=1,NBAS)
WRITE(LFN,900) (NAOL(J),J=1,NBAS)
WRITE(LFN,900) (LSTOCC(J),J=1,NBAS)
Write the PNAO orbital occupancies:
WRITE(LFN,910) (OCC(J),J=1,NBAS)
RETURN
900 FORMAT(1X,20I4)
910 FORMAT(1X,5F15.9)
END
*****************************************************************************
SUBROUTINE RDPPNA(T,OCC,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION T(NDIM,NDIM),OCC(NDIM)
DIMENSION JOB(20)
LOGICAL ERROR
Read the PNAO information from the external file ABS(IFLG/1000)
NOTE: This is the pure-AO to PNAO transformation, not the raw AO
to PNAO transform.
LFN = ABS(IFLG/1000)
WRITE(LFNPR,900)
IF(ISPIN.GE.0) REWIND(LFN)
CALL AREAD(T,NDIM,NBAS,NBAS,JOB,LFN,ERROR)
IF(ERROR) GOTO 800
IF(ISPIN.GE.0) WRITE(LFNPR,910) JOB
IF(ISPIN.LT.0) WRITE(LFNPR,920)
Read in orbital labels from LFN:
READ(LFN,1000,END=810) (NAOCTR(J),J=1,NBAS)
READ(LFN,1000,END=810) (NAOL(J),J=1,NBAS)
READ(LFN,1000,END=810) (LSTOCC(J),J=1,NBAS)
Read orbital occupancies:
READ(LFN,1010,END=820) (OCC(J),J=1,NBAS)
RETURN
800 WRITE(LFNPR,950) LFN
STOP
810 WRITE(LFNPR,960) LFN
STOP
820 WRITE(LFNPR,970) LFN
STOP
900 FORMAT(/1X,'PNAO basis set from a previous calculation used:')
910 FORMAT(1X,20A4)
920 FORMAT(/1X,'See alpha NBO output for title of the transformation')
950 FORMAT(/1X,'Error reading PAO to PNAO transformation from LFN',I3)
960 FORMAT(/1X,'Error reading PNAO orbital labels from LFN',I3)
970 FORMAT(/1X,'Error reading PNAO orbital occupancies from LFN',I3)
1000 FORMAT(1X,20I4)
1010 FORMAT(1X,5F15.9)
END
*****************************************************************************
SUBROUTINE WRTNAO(T,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
CHARACTER*80 TITLE
NOTE: T is the PNAO overlap matrix on return to the calling routine
Fetch the AO to NAO transformation from the NBO DAF, and write
it to the external file ABS(IFLG):
CALL FETNAO(T)
TITLE = 'NAOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG)
Write the NAO orbital labels to the external file:
LFN = ABS(IFLG)
WRITE(LFN,900) (NAOCTR(J),J=1,NBAS)
WRITE(LFN,900) (NAOL(J),J=1,NBAS)
WRITE(LFN,900) (LSTOCC(J),J=1,NBAS)
Fetch the PNAO overlap matrix from the NBO DAF, and store only the
upper triangular portion on the external file:
CALL FESNAO(T)
TITLE = 'PNAO overlap matrix:'
CALL AOUT(T,NDIM,-NBAS,NBAS,TITLE,2,IFLG)
RETURN
900 FORMAT(1X,20I4)
END
*****************************************************************************
SUBROUTINE RDTNAO(DM,T,SCR,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),SCR(NDIM)
DIMENSION JOB(20)
LOGICAL ERROR
NOTE: T is the PNAO overlap matrix on return to the calling routine
DM is the NAO density matrix on return
Read in AO to NAO transformation from the external file ABS(IFLG/1000),
and store it on the NBO DAF:
LFN = ABS(IFLG/1000)
WRITE(LFNPR,900)
REWIND(LFN)
CALL AREAD(T,NDIM,NBAS,NBAS,JOB,LFN,ERROR)
IF(ERROR) GOTO 800
WRITE(LFNPR,910) JOB
CALL SVTNAO(T)
Transform the AO density matrix, presently in DM, to the NAO basis:
CALL SIMTRS(DM,T,SCR,NDIM,NBAS)
Read in orbital labels from LFN:
READ(LFN,1000,END=810) (NAOCTR(J),J=1,NBAS)
READ(LFN,1000,END=810) (NAOL(J),J=1,NBAS)
READ(LFN,1000,END=810) (LSTOCC(J),J=1,NBAS)
Read the PNAO overlap from LFN, and save this matrix on the NBO DAF:
CALL AREAD(T,NDIM,-NBAS,NBAS,JOB,LFN,ERROR)
IF(ERROR) GOTO 820
CALL SVSNAO(T)
RETURN
800 WRITE(LFNPR,950) LFN
STOP
810 WRITE(LFNPR,960) LFN
STOP
820 WRITE(LFNPR,970) LFN
STOP
900 FORMAT(/1X,'NAO basis set from a previous calculation used:')
910 FORMAT(1X,20A4)
950 FORMAT(/1X,'Error reading AO to NAO transformation from LFN',I3)
960 FORMAT(/1X,'Error reading NAO orbital labels from LFN',I3)
970 FORMAT(/1X,'Error reading PNAO overlap matrix from LFN',I3)
1000 FORMAT(1X,20I4)
END
*****************************************************************************
SUBROUTINE WRTNAB(T,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
DIMENSION T(NDIM,NDIM)
CHARACTER*80 TITLE
Write the NAO to NBO transformation and NBO info to external file
ABS(IFLG):
TITLE = 'NBOs in the NAO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,2,IFLG)
Write the NBO labels:
LFN = ABS(IFLG)
DO 10 I = 1,NBAS
WRITE(LFN,900) (LABEL(I,J),J=1,6),IBXM(I)
10 CONTINUE
RETURN
900 FORMAT(1X,A2,A1,4I3,3X,I3)
END
*****************************************************************************
SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),BNDOCC(NDIM),SCR(NDIM)
DIMENSION JOB(20)
LOGICAL ERROR
Read the NAO to NBO transformation matrix from the external file
ABS(IFLG/1000). Also read the NBO labels, the NBO occupancies,
and transform the input NAO density matrix to the NBO basis:
LFN = ABS(IFLG/1000)
WRITE(LFNPR,900)
IF(ISPIN.GE.0) REWIND(LFN)
CALL AREAD(T,NDIM,NBAS,NBAS,JOB,LFN,ERROR)
IF(ERROR) GOTO 800
IF(ISPIN.GE.0) WRITE(LFNPR,910) JOB
IF(ISPIN.LT.0) WRITE(LFNPR,920)
Read the NBO labels:
DO 10 I = 1,NBAS
READ(LFN,1000,END=810) (LABEL(I,J),J=1,6),IBXM(I)
10 CONTINUE
Transform the NAO density matrix, DM, to the NBO basis, and store the
NBO occupancies in BNDOCC:
CALL SIMTRS(DM,T,SCR,NDIM,NBAS)
DO 20 I = 1,NBAS
BNDOCC(I) = DM(I,I)
20 CONTINUE
RETURN
800 WRITE(LFNPR,950) LFN
STOP
810 WRITE(LFNPR,960) LFN
STOP
900 FORMAT(/1X,'NAO to NBO transformation from a previous ',
+ 'calculation will be used:')
910 FORMAT(1X,20A4)
920 FORMAT(/1X,'See alpha NBO output for title of the transformation')
950 FORMAT(/1X,'Error reading NAO to NBO transformation from LFN',I3)
960 FORMAT(/1X,'Error reading NBO orbital labels from LFN',I3)
1000 FORMAT(1X,A2,A1,4I3,3X,I3)
END
*****************************************************************************
SUBROUTINE WRTNBO(T,BNDOCC,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION T(NDIM,NDIM),BNDOCC(1)
CHARACTER*80 TITLE
Write the AO to NBO transformation matrix and NBO info to the external
file ABS(IFLG):
TITLE = 'NBOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG)
Write out the NBO occupancies:
LFN = ABS(IFLG)
WRITE(LFN,900) (BNDOCC(J),J=1,NBAS)
Write out NBOUNI, NBOTYP, LABEL, IBXM, and IATNO:
WRITE(LFN,910) (NBOUNI(J),J=1,NBAS)
WRITE(LFN,910) (NBOTYP(J),J=1,NBAS)
WRITE(LFN,920) (LABEL(J,1),J=1,NBAS)
WRITE(LFN,920) (LABEL(J,2),J=1,NBAS)
WRITE(LFN,910) (LABEL(J,3),J=1,NBAS)
WRITE(LFN,910) (LABEL(J,4),J=1,NBAS)
WRITE(LFN,910) (LABEL(J,5),J=1,NBAS)
WRITE(LFN,910) (LABEL(J,6),J=1,NBAS)
WRITE(LFN,910) (IBXM(J),J=1,NBAS)
WRITE(LFN,910) (IATNO(J),J=1,NATOMS)
RETURN
900 FORMAT(1X,5F15.9)
910 FORMAT(1X,20I3)
920 FORMAT(1X,20A3)
END
*****************************************************************************
SUBROUTINE WRNLMO(T,DM,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM)
CHARACTER*80 TITLE
Write the AO to NLMO transformation matrix and NLMO info to the external
file ABS(IFLG):
TITLE = 'NLMOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG)
Write out the NLMO occupancies:
LFN = ABS(IFLG)
WRITE(LFN,900) (DM(J,J),J=1,NBAS)
Write out NBOUNI, NBOTYP, LABEL, IBXM, and IATNO:
WRITE(LFN,910) (NBOUNI(J),J=1,NBAS)
WRITE(LFN,910) (NBOTYP(J),J=1,NBAS)
WRITE(LFN,920) (LABEL(J,1),J=1,NBAS)
WRITE(LFN,920) (LABEL(J,2),J=1,NBAS)
WRITE(LFN,910) (LABEL(J,3),J=1,NBAS)
WRITE(LFN,910) (LABEL(J,4),J=1,NBAS)
WRITE(LFN,910) (LABEL(J,5),J=1,NBAS)
WRITE(LFN,910) (LABEL(J,6),J=1,NBAS)
WRITE(LFN,910) (IBXM(J),J=1,NBAS)
WRITE(LFN,910) (IATNO(J),J=1,NATOMS)
RETURN
900 FORMAT(1X,5F15.9)
910 FORMAT(1X,20I3)
920 FORMAT(1X,20A3)
END
*****************************************************************************
SUBROUTINE WRBAS(SCR,ISCR,LFN)
*****************************************************************************
Save the AO basis set information on an external file:
-----------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION SCR(1),ISCR(1)
Fetch the number of shells NSHELL, the number of exponents NEXP,
the NCOMP, NPRIM, and NPTR arrays, and the orbital exponents and
coefficients from the NBO DAF:
CALL FEBAS(NSHELL,NEXP,ISCR)
If NSHELL is zero, then no basis set info has been stored in the
DAF:
IF(NSHELL.EQ.0) THEN
WRITE(LFNPR,900)
RETURN
END IF
Partition the scratch arrays: (Note that SCR and ISCR occupy the same
space in memory)
ISCR: (integer)
NSHELL NEXP NCOMP NPRIM NPTR
+------+------+-------+-------+-------+-----------------------------------
I1 I2 I3
SCR: (real)
ATCOOR
EXP CS CP CD CF TITLE
---------------------------------------+-----+----+----+----+----+--------
I4 I5 I6 I7 I8 I9
ISCR(I1) : NCOMP(1..NSHELL)
ISCR(I2) : NPRIM(1..NSHELL)
ISCR(I3) : NPTR(1..NSHELL)
SCR(I4) : EXP(1..NEXP)
SCR(I5) : CS(1..NEXP)
SCR(I6) : CP(1..NEXP)
SCR(I7) : CD(1..NEXP)
SCR(I8) : CF(1..NEXP)
SCR(I9) : TITLE(10) or ATCOOR(3*NATOMS)
I1 = 3
I2 = I1 + NSHELL
I3 = I2 + NSHELL
I4 = I3 + NSHELL
I5 = I4 + NEXP
I6 = I5 + NEXP
I7 = I6 + NEXP
I8 = I7 + NEXP
I9 = I8 + NEXP
IEND = I9 + MAX0(3*NATOMS,10)
Fetch job title and write it to the AOINFO external file:
CALL FETITL(SCR(I9))
Begin writing to the AOINFO external file:
WRITE(LFN,910) (SCR(I9+I),I=0,9)
WRITE(LFN,920) NATOMS,NSHELL,NEXP
Fetch the atomic coordinates:
CALL FECOOR(SCR(I9))
Write atomic numbers and coordinates to external file:
J = 0
DO 10 I = 1,NATOMS
WRITE(LFN,930) IATNO(I),(SCR(I9+J+K),K=0,2)
J = J + 3
10 CONTINUE
WRITE(LFN,940)
Write out information about each shell in the basis set:
NCTR(I) -- atomic center of the Ith shell
NCOMP(I) -- number of components in the Ith shell
NPTR(I) -- pointer for the Ith shell into the primitive parameters
of EXP, CS, CP, CD, and CF
NPRIM(I) -- number of primitive functions in the Ith shell
LABEL(1..NCOMP(I)) -- symmetry labels for the orbitals of this shell
J1 = 1
J2 = I1
J3 = I3
J4 = I2
DO 20 I = 1,NSHELL
NCOMP = ISCR(J2)
NPRIM = ISCR(J3)
NPTR = ISCR(J4)
WRITE(LFN,950) LCTR(J1),NCOMP,NPRIM,NPTR
WRITE(LFN,950) ((LANG(J1+J)),J=0,NCOMP-1)
J1 = J1 + NCOMP
J2 = J2 + 1
J3 = J3 + 1
J4 = J4 + 1
20 CONTINUE
WRITE(LFN,940)
Write out the primitive parameters:
WRITE(LFN,960) (SCR(I4+I),I=0,NEXP-1)
WRITE(LFN,970)
WRITE(LFN,960) (SCR(I5+I),I=0,NEXP-1)
WRITE(LFN,970)
WRITE(LFN,960) (SCR(I6+I),I=0,NEXP-1)
WRITE(LFN,970)
WRITE(LFN,960) (SCR(I7+I),I=0,NEXP-1)
WRITE(LFN,970)
WRITE(LFN,960) (SCR(I8+I),I=0,NEXP-1)
RETURN
900 FORMAT(/1X,'No basis set information is stored on the NBO direct',
+ ' access file.',/1X,'Thus, no `AOINFO'' file can be written.')
910 FORMAT(1X,9A8,A7,/1X,'Basis set information needed for plotting ',
+ 'orbitals',/1X,75('-'))
920 FORMAT(1X,3I6,/1X,75('-'))
930 FORMAT(1X,I4,3(2X,F12.9))
940 FORMAT(1X,75('-'))
950 FORMAT(1X,10I6)
960 FORMAT(2X,4E18.9)
970 FORMAT(1X)
END
*****************************************************************************
SUBROUTINE WRARC(SCR,ISCR,LFN)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (MAXD = 4)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
DIMENSION SCR(1),ISCR(1),IK(MAXD)
DIMENSION KGEN(7),KNAT(6),KBAS(4),KOPEN(4),KORTHO(5),KUPPER(5),
+ KBODM(4),KEV(2),KCUBF(6),KEND(4),KCAL(4)
DATA KGEN/1H$,1HG,1HE,1HN,1HN,1HB,1HO/,KBAS/1HN,1HB,1HA,1HS/,
+ KNAT/1HN,1HA,1HT,1HO,1HM,1HS/,KOPEN/1HO,1HP,1HE,1HN/,
+ KORTHO/1HO,1HR,1HT,1HH,1HO/,KUPPER/1HU,1HP,1HP,1HE,1HR/,
+ KBODM/1HB,1HO,1HD,1HM/,KEV/1HE,1HV/,KEND/1H$,1HE,1HN,1HD/,
+ KCUBF/1HC,1HU,1HB,1HI,1HC,1HF/,KCAL/1HK,1HC,1HA,1HL/
DATA KBLNK,KEQ/1H ,1H=/
DATA ABLNKS,ACENTR,ALABEL/8H ,8HCENTER =,8H LABEL =/
DATA ANSHLL,ANEXP ,ANCOMP/8HNSHELL =,8H NEXP =,8H NCOMP =/
DATA ANPRIM,ANPTR ,AEXP /8H NPRIM =,8H NPTR =,8H EXP =/
DATA ACS,ACP,ACD,ACF/8H CS =,8H CP =,8H CD =,8H CF =/
DATA ZERO/0.0D0/
Write the ARCHIVE file to LFN:
This routine has been written assuming NBAS = NDIM. Skip if
this condition is not satisfied:
IF(NBAS.NE.NDIM) THEN
WRITE(LFNPR,890)
RETURN
END IF
Form the $GENNBO keylist in ISCR:
NC = 0
DO 10 I = 1,7
NC = NC + 1
ISCR(NC) = KGEN(I)
10 CONTINUE
NC = NC + 1
ISCR(NC) = KBLNK
NC = NC + 1
ISCR(NC) = KBLNK
Add the number of atoms and basis functions:
DO 20 I = 1,6
NC = NC + 1
ISCR(NC) = KNAT(I)
20 CONTINUE
NC = NC + 1
ISCR(NC) = KEQ
CALL IDIGIT(NATOMS,IK,ND,MAXD)
DO 30 I = 1,ND
NC = NC + 1
ISCR(NC) = IK(I)
30 CONTINUE
NC = NC + 1
ISCR(NC) = KBLNK
NC = NC + 1
ISCR(NC) = KBLNK
DO 40 I = 1,4
NC = NC + 1
ISCR(NC) = KBAS(I)
40 CONTINUE
NC = NC + 1
ISCR(NC) = KEQ
CALL IDIGIT(NBAS,IK,ND,MAXD)
DO 50 I = 1,ND
NC = NC + 1
ISCR(NC) = IK(I)
50 CONTINUE
NC = NC + 1
ISCR(NC) = KBLNK
NC = NC + 1
ISCR(NC) = KBLNK
If OPEN shell, add the OPEN keyword:
IF(OPEN) THEN
DO 60 I = 1,4
NC = NC + 1
ISCR(NC) = KOPEN(I)
60 CONTINUE
NC = NC + 1
ISCR(NC) = KBLNK
NC = NC + 1
ISCR(NC) = KBLNK
END IF
If the AO basis is orthogonal, add the ORTHO keyword:
IF(ORTHO) THEN
DO 70 I = 1,5
NC = NC + 1
ISCR(NC) = KORTHO(I)
70 CONTINUE
NC = NC + 1
ISCR(NC) = KBLNK
NC = NC + 1
ISCR(NC) = KBLNK
END IF
Only UPPER triangular portions of symmetric matrices will be given:
DO 80 I = 1,5
NC = NC + 1
ISCR(NC) = KUPPER(I)
80 CONTINUE
NC = NC + 1
ISCR(NC) = KBLNK
NC = NC + 1
ISCR(NC) = KBLNK
Enter the bond-order matrix, BODM, if possible:
IF(IWDM.EQ.1) THEN
DO 90 I = 1,4
NC = NC + 1
ISCR(NC) = KBODM(I)
90 CONTINUE
NC = NC + 1
ISCR(NC) = KBLNK
NC = NC + 1
ISCR(NC) = KBLNK
END IF
Add EV if the energy units are in electron volts:
IF(MUNIT.EQ.1) THEN
NC = NC + 1
ISCR(NC) = KEV(1)
NC = NC + 1
ISCR(NC) = KEV(2)
NC = NC + 1
ISCR(NC) = KBLNK
NC = NC + 1
ISCR(NC) = KBLNK
END IF
Add KCAL if the energy units are in kcal/mol:
IF(MUNIT.EQ.1) THEN
NC = NC + 1
ISCR(NC) = KCAL(1)
NC = NC + 1
ISCR(NC) = KCAL(2)
NC = NC + 1
ISCR(NC) = KCAL(3)
NC = NC + 1
ISCR(NC) = KCAL(4)
NC = NC + 1
ISCR(NC) = KBLNK
NC = NC + 1
ISCR(NC) = KBLNK
END IF
Add CUBICF if these types of orbitals are being used:
IF(IWCUBF.NE.0) THEN
DO 100 I = 1,6
NC = NC + 1
ISCR(NC) = KCUBF(I)
100 CONTINUE
NC = NC + 1
ISCR(NC) = KBLNK
NC = NC + 1
ISCR(NC) = KBLNK
END IF
Add $END:
DO 110 I = 1,4
NC = NC + 1
ISCR(NC) = KEND(I)
110 CONTINUE
Write the $GENNBO keylist to the archive file:
WRITE(LFN,900) (ISCR(I),I=1,NC)
Write the $NBO keylist to the archive file:
WRITE(LFN,910)
Write the $COORD data list to the archive file:
WRITE(LFN,920)
CALL FETITL(SCR)
WRITE(LFN,930) (SCR(I),I=1,10)
CALL FECOOR(SCR)
J = 1
DO 120 I = 1,NATOMS
WRITE(LFN,940) IATNO(I),IZNUC(I),SCR(J),SCR(J+1),SCR(J+2)
J = J + 3
120 CONTINUE
WRITE(LFN,950)
Write the $BASIS datalist to the archive file (info from /NBAO/):
WRITE(LFN,960)
NINT = 17
STR = ACENTR
DO 130 I = 1,(NBAS-1)/NINT+1
NL = (I - 1) * NINT + 1
NU = MIN0(NL+NINT-1,NBAS)
WRITE(LFN,970) STR,(LCTR(J),J=NL,NU)
STR = ABLNKS
130 CONTINUE
STR = ALABEL
DO 140 I = 1,(NBAS-1)/NINT+1
NL = (I - 1) * NINT + 1
NU = MIN0(NL+NINT-1,NBAS)
WRITE(LFN,970) STR,(LANG(J),J=NL,NU)
STR = ABLNKS
140 CONTINUE
WRITE(LFN,950)
Write the $CONTRACT datalist to the archive file:
Fetch the basis set info from the NBO DAF:
CALL FEBAS(NSHELL,NEXP,ISCR)
Partition the scratch vector:
ISCR(I1) : NCOMP(1..NSHELL)
ISCR(I2) : NPRIM(1..NSHELL)
ISCR(I3) : NPTR(1..NSHELL)
SCR(I4) : EXP(1..NEXP)
SCR(I5) : CS(1..NEXP)
SCR(I6) : CP(1..NEXP)
SCR(I7) : CD(1..NEXP)
SCR(I8) : CF(1..NEXP)
I1 = 3
I2 = I1 + NSHELL
I3 = I2 + NSHELL
I4 = I3 + NSHELL
I5 = I4 + NEXP
I6 = I5 + NEXP
I7 = I6 + NEXP
I8 = I7 + NEXP
IEND = I8 + NEXP
If NSHELL is zero, then no basis set info was ever stored on
the DAF:
IF(NSHELL.GT.0) THEN
Write out numbers of shells and orbital exponents:
WRITE(LFN,980)
WRITE(LFN,970) ANSHLL,NSHELL
WRITE(LFN,970) ANEXP,NEXP
Write out the number of components in each shell:
NINT = 17
STR = ANCOMP
DO 150 I = 1,(NSHELL-1)/NINT+1
NL = (I - 1) * NINT + 1
NU = MIN0(NL+NINT-1,NSHELL)
WRITE(LFN,970) STR,(ISCR(J),J=I1+NL-1,I1+NU-1)
STR = ABLNKS
150 CONTINUE
Write out the number of primitives in each shell:
STR = ANPRIM
DO 160 I = 1,(NSHELL-1)/NINT+1
NL = (I - 1) * NINT + 1
NU = MIN0(NL+NINT-1,NSHELL)
WRITE(LFN,970) STR,(ISCR(J),J=I2+NL-1,I2+NU-1)
STR = ABLNKS
160 CONTINUE
Write out pointer array which maps orbital exponents and coefficients
onto each shell:
STR = ANPTR
DO 170 I = 1,(NSHELL-1)/NINT+1
NL = (I - 1) * NINT + 1
NU = MIN0(NL+NINT-1,NSHELL)
WRITE(LFN,970) STR,(ISCR(J),J=I3+NL-1,I3+NU-1)
STR = ABLNKS
170 CONTINUE
Write out orbital exponents:
NREAL = 4
STR = AEXP
DO 180 I = 1,(NEXP-1)/NREAL+1
NL = (I - 1) * NREAL + 1
NU = MIN0(NL+NREAL-1,NEXP)
WRITE(LFN,990) STR,(SCR(J),J=I4+NL-1,I4+NU-1)
STR = ABLNKS
180 CONTINUE
Write out the orbital coefficients for each angular symmetry type
unless there are no basis functions of that type:
DO 210 I = 1,4
IF(I.EQ.1) THEN
STR = ACS
II = I5
ELSE IF(I.EQ.2) THEN
STR = ACP
II = I6
ELSE IF(I.EQ.3) THEN
STR = ACD
II = I7
ELSE IF(I.EQ.4) THEN
STR = ACF
II = I8
END IF
IFLG = 0
DO 190 J = II,II+NEXP-1
IF(SCR(J).NE.ZERO) IFLG = 1
190 CONTINUE
IF(IFLG.EQ.1) THEN
DO 200 J = 1,(NEXP-1)/NREAL+1
NL = (J - 1) * NREAL + 1
NU = MIN0(NL+NREAL-1,NEXP)
WRITE(LFN,990) STR,(SCR(K),K=II+NL-1,II+NU-1)
STR = ABLNKS
200 CONTINUE
END IF
210 CONTINUE
WRITE(LFN,950)
END IF
Write the $OVERLAP datalist unless the AO basis is orthogonal:
L2 = NDIM * (NDIM + 1) / 2
IF(.NOT.ORTHO) THEN
WRITE(LFN,1000)
CALL FESRAW(SCR)
L2 = NDIM * (NDIM + 1) / 2
CALL PACK(SCR,NDIM,NBAS,L2)
WRITE(LFN,1010) (SCR(I),I=1,L2)
WRITE(LFN,950)
END IF
Write the $DENSITY datalist:
WRITE(LFN,1020)
IF(OPEN) THEN
ALPHA = .TRUE.
BETA = .FALSE.
CALL FEDRAW(SCR,SCR)
CALL PACK(SCR,NDIM,NBAS,L2)
WRITE(LFN,1010) (SCR(I),I=1,L2)
ALPHA = .FALSE.
BETA = .TRUE.
CALL FEDRAW(SCR,SCR)
CALL PACK(SCR,NDIM,NBAS,L2)
WRITE(LFN,1010) (SCR(I),I=1,L2)
ELSE
ALPHA = .FALSE.
BETA = .FALSE.
CALL FEDRAW(SCR,SCR)
CALL PACK(SCR,NDIM,NBAS,L2)
WRITE(LFN,1010) (SCR(I),I=1,L2)
END IF
WRITE(LFN,950)
Write the $FOCK datalist:
IF(OPEN) THEN
ALPHA = .TRUE.
BETA = .FALSE.
IWFOCK = 1
CALL FEFAO(SCR,IWFOCK)
IF(IWFOCK.NE.0) THEN
WRITE(LFN,1030)
CALL PACK(SCR,NDIM,NBAS,L2)
WRITE(LFN,1010) (SCR(I),I=1,L2)
ALPHA = .FALSE.
BETA = .TRUE.
CALL FEFAO(SCR,IWFOCK)
CALL PACK(SCR,NDIM,NBAS,L2)
WRITE(LFN,1010) (SCR(I),I=1,L2)
WRITE(LFN,950)
END IF
ELSE
ALPHA = .FALSE.
BETA = .FALSE.
IWFOCK = 1
CALL FEFAO(SCR,IWFOCK)
IF(IWFOCK.NE.0) THEN
WRITE(LFN,1030)
CALL PACK(SCR,NDIM,NBAS,L2)
WRITE(LFN,1010) (SCR(I),I=1,L2)
WRITE(LFN,950)
END IF
END IF
Write the $LCAOMO datalist:
IF(OPEN) THEN
ALPHA = .TRUE.
BETA = .FALSE.
CALL FEAOMO(SCR,IAOMO)
IF(IAOMO.EQ.1) THEN
WRITE(LFN,1040)
WRITE(LFN,1010) (SCR(I),I=1,NDIM*NDIM)
ALPHA = .FALSE.
BETA = .TRUE.
CALL FEAOMO(SCR,IAOMO)
WRITE(LFN,1010) (SCR(I),I=1,NDIM*NDIM)
WRITE(LFN,950)
END IF
ELSE
ALPHA = .FALSE.
BETA = .FALSE.
CALL FEAOMO(SCR,IAOMO)
IF(IAOMO.EQ.1) THEN
WRITE(LFN,1040)
WRITE(LFN,1010) (SCR(I),I=1,NDIM*NDIM)
WRITE(LFN,950)
END IF
END IF
Write the $DIPOLE datalist:
IDIP = 1
CALL FEDXYZ(SCR,IDIP)
IF(IDIP.NE.0) THEN
WRITE(LFN,1050)
CALL PACK(SCR,NDIM,NBAS,L2)
WRITE(LFN,1010) (SCR(I),I=1,L2)
IDIP = 2
CALL FEDXYZ(SCR,IDIP)
CALL PACK(SCR,NDIM,NBAS,L2)
WRITE(LFN,1010) (SCR(I),I=1,L2)
IDIP = 3
CALL FEDXYZ(SCR,IDIP)
CALL PACK(SCR,NDIM,NBAS,L2)
WRITE(LFN,1010) (SCR(I),I=1,L2)
WRITE(LFN,950)
END IF
Reset logicals ALPHA and BETA:
ALPHA = ISPIN.EQ.2
BETA = ISPIN.EQ.-2
RETURN
890 FORMAT(/1X,'The routine which writes the ARCHIVE file assumes ',
+ 'NBAS = NDIM. Since',/1X,'this condition is not satisfied, ',
+ 'the ARCHIVE file will not be written.')
900 FORMAT(1X,78A1)
910 FORMAT(1X,'$NBO $END')
920 FORMAT(1X,'$COORD')
930 FORMAT(1X,9A8,A6)
940 FORMAT(1X,2I5,3F15.6)
950 FORMAT(1X,'$END')
960 FORMAT(1X,'$BASIS')
970 FORMAT(1X,1X,A8,1X,17(I3,1X))
980 FORMAT(1X,'$CONTRACT')
990 FORMAT(1X,1X,A8,1X,4(E15.7,1X))
1000 FORMAT(1X,'$OVERLAP')
1010 FORMAT(1X,1X,5E15.7)
1020 FORMAT(1X,'$DENSITY')
1030 FORMAT(1X,'$FOCK')
1040 FORMAT(1X,'$LCAOMO')
1050 FORMAT(1X,'$DIPOLE')
END
*****************************************************************************
SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(MR,1)
CHARACTER*80 TITLE
DIMENSION ISHELL(4)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBLBL/NLEW,NVAL,LBL(10,MAXBAS,4)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/
Either write A to an external file, or print it in the output file:
Input: A -- matrix to be printed or written out
MR -- row dimension of matrix A in calling routine
NR -- ABS(NR) is the actual number of rows to be output
[if NR is negative, IFLG is negative (write), and
ABS(NR).EQ.NC (square matrix), only the upper
triangular portion is written out]
NC -- actual number of columns in matrix A
[used to determine if A is square, and as an upper
limit on IFLG]
TITLE -- CHARACTER*80 variable containing a matrix title
INDEX -- Index selecting appropriate output labels
0 : Atom labels
1 : AO labels
2 : NAO labels
3 : NHO labels
4 : NBO labels
5 : NLMO labels
IFLG -- print/write flag
negative : write to LFN ABS(IFLG)
positive : print IFLG columns of A
'FULL' : print the full matrix
'VAL' : print N columns of A, where N is the
number of core + valence orbitals and
is determined by this routine
'LEW' : print N columns of A, where N is the
number of occupied orbitals and is
determined by this routine
JFLG = IFLG
IF(JFLG.EQ.0) RETURN
If JFLG is FULL, then output the total number of columns:
IF(JFLG.EQ.KFULL) JFLG = ABS(NC)
If JFLG = VAL, output only the valence orbitals, determined from the
core and valence tables:
IF(JFLG.EQ.KVAL) THEN
IF(NVAL.LT.0) THEN
IECP = 0
JFLG = 0
DO 30 IAT = 1,NATOMS
CALL CORTBL(IAT,ISHELL,IECP)
DO 10 I = 1,4
MULT = 2 * (I-1) + 1
JFLG = JFLG + ISHELL(I)*MULT
10 CONTINUE
CALL VALTBL(IAT,ISHELL)
DO 20 I = 1,4
MULT = 2 * (I-1) + 1
JFLG = JFLG + ISHELL(I)*MULT
20 CONTINUE
30 CONTINUE
ELSE
JFLG = NVAL
END IF
END IF
If JFLG is LEW, only output the occupied orbitals:
IF(JFLG.EQ.KLEW) JFLG = NLEW
If JFLG is positive, print the matrix A in the output file:
IF(JFLG.GT.0) CALL APRINT(A,MR,NR,NC,TITLE,INDEX,JFLG)
If JFLG is negative but greater than -1000, write matrix A to the external
file ABS(JFLG):
IF(JFLG.LT.0.AND.JFLG.GT.-1000) CALL AWRITE(A,MR,NR,NC,TITLE,JFLG)
RETURN
END
*****************************************************************************
SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(MR,1)
CHARACTER*80 TITLE
DIMENSION BASIS(5)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBLBL/NLEW,NVAL,LBL(10,MAXBAS,4)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DATA BASIS/4H AO ,4H NAO,4H NHO,4H NBO,4HNLMO/
DATA ATOM,DASHES/4HAtom,8H--------/
DATA TENTH/0.1D0/
Determine the number of columns of matrix A to print in the output file:
NCOL = MCOL
IF(NCOL.GT.ABS(NC)) NCOL = ABS(NC)
NN = ABS(NR)
ILABEL = INDEX
IF(ILABEL.EQ.5) ILABEL = 4
TMAX = ABS(A(1,1))
DO 20 J = 1,NCOL
DO 10 I = 1,NN
IF(ABS(A(I,J)).GT.TMAX) TMAX = ABS(A(I,J))
10 CONTINUE
20 CONTINUE
IF(TMAX.LT.TENTH) THEN
ND = 1
ELSE
ND = INT(LOG10(TMAX)) + 1
END IF
Print the matrix title:
WRITE(LFNPR,1000) TITLE(1:78)
Print the matrix A: (basis function labels)
IF(ILABEL.GE.1.AND.ILABEL.LE.4) THEN
MAXCOL = MIN(10-ND,8)
IF(MAXCOL.LT.6) THEN
CALL ALTOUT(A,MR,NCOL,NN,NCOL)
ELSE
NCL = 1
NCU = MAXCOL
NLOOPS = (NCOL - 1) / MAXCOL + 1
DO 60 L = 1,NLOOPS
IF(NCU.GT.NCOL) NCU = NCOL
IF(MAXCOL.EQ.8) THEN
WRITE(LFNPR,900) BASIS(INDEX),(J,J=NCL,NCU)
WRITE(LFNPR,910) (DASHES,J=NCL,NCU)
DO 30 I = 1,NN
WRITE(LFNPR,920) I,(LBL(J,I,ILABEL),J=1,10),
+ (A(I,K),K=NCL,NCU)
30 CONTINUE
ELSE IF(MAXCOL.EQ.7) THEN
WRITE(LFNPR,901) BASIS(INDEX),(J,J=NCL,NCU)
WRITE(LFNPR,911) (DASHES,J=NCL,NCU)
DO 40 I = 1,NN
WRITE(LFNPR,921) I,(LBL(J,I,ILABEL),J=1,10),
+ (A(I,K),K=NCL,NCU)
40 CONTINUE
ELSE
WRITE(LFNPR,902) BASIS(INDEX),(J,J=NCL,NCU)
WRITE(LFNPR,912) (DASHES,DASHES,J=NCL,NCU)
DO 50 I = 1,NN
WRITE(LFNPR,922) I,(LBL(J,I,ILABEL),J=1,10),
+ (A(I,K),K=NCL,NCU)
50 CONTINUE
END IF
NCL = NCU + 1
NCU = NCU + MAXCOL
60 CONTINUE
END IF
Print the matrix A: (atom labels)
ELSE IF(ILABEL.EQ.0) THEN
MAXCOL = MIN(10-ND,9)
IF(MAXCOL.LT.7) THEN
CALL ALTOUT(A,MR,NCOL,N,NCOL)
ELSE
NCL = 1
NCU = MAXCOL
NLOOPS = (NCOL - 1) / MAXCOL + 1
DO 160 L = 1,NLOOPS
IF(NCU.GT.NCOL) NCU = NCOL
IF(MAXCOL.EQ.9) THEN
WRITE(LFNPR,1900) ATOM,(J,J=NCL,NCU)
WRITE(LFNPR,1910) (DASHES,J=NCL,NCU)
DO 130 I = 1,NN
WRITE(LFNPR,1920) I,NAMEAT(IATNO(I)),
+ (A(I,K),K=NCL,NCU)
130 CONTINUE
ELSE IF(MAXCOL.EQ.8) THEN
WRITE(LFNPR,1901) ATOM,(J,J=NCL,NCU)
WRITE(LFNPR,1911) (DASHES,J=NCL,NCU)
DO 140 I = 1,NN
WRITE(LFNPR,1921) I,NAMEAT(IATNO(I)),
+ (A(I,K),K=NCL,NCU)
140 CONTINUE
ELSE
WRITE(LFNPR,1902) ATOM,(J,J=NCL,NCU)
WRITE(LFNPR,1912) (DASHES,J=NCL,NCU)
DO 150 I = 1,NN
WRITE(LFNPR,1922) I,NAMEAT(IATNO(I)),
+ (A(I,K),K=NCL,NCU)
150 CONTINUE
END IF
NCL = NCU + 1
NCU = NCU + MAXCOL
160 CONTINUE
END IF
Print the matrix A: (no labels)
ELSE
CALL ALTOUT(A,MR,NCOL,NN,NCOL)
END IF
RETURN
900 FORMAT(/9X,A4,3X,8(3X,I3,2X))
901 FORMAT(/9X,A4,3X,7(4X,I3,2X))
902 FORMAT(/9X,A4,3X,6(4X,I3,3X))
910 FORMAT(6X,'----------',8(1X,A7))
911 FORMAT(6X,'----------',7(1X,A8))
912 FORMAT(6X,'----------',6(1X,A8,A1))
920 FORMAT(1X,I3,'. ',10A1,8F8.4)
921 FORMAT(1X,I3,'. ',10A1,7F9.4)
922 FORMAT(1X,I3,'. ',10A1,6F10.4)
1000 FORMAT(//1X,A78)
1900 FORMAT(/5X,A4,9(2X,I3,3X))
1901 FORMAT(/5X,A4,8(3X,I3,3X))
1902 FORMAT(/5X,A4,7(3X,I3,4X))
1910 FORMAT(5X,'----',1X,9(A6,2X))
1911 FORMAT(5X,'----',1X,8(A7,2X))
1912 FORMAT(5X,'----',1X,7(A8,2X))
1920 FORMAT(1X,I3,'. ',A2,9F8.4)
1921 FORMAT(1X,I3,'. ',A2,8F9.4)
1922 FORMAT(1X,I3,'. ',A2,7F10.4)
END
*****************************************************************************
SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(MR,1)
CHARACTER*80 TITLE
DIMENSION XJOB(10)
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
Write the matrix A to the external file ABS(LFN). Include job title,
matrix title, and specify the spin in needed:
LFNOUT = ABS(LFN)
IF(LFNOUT.EQ.LFNPR) WRITE(LFNOUT,890)
IF(ALPHA.OR..NOT.OPEN.OR.LFNOUT.EQ.LFNPR) THEN
CALL FETITL(XJOB)
WRITE(LFNOUT,900) XJOB
WRITE(LFNOUT,910) TITLE(1:79)
END IF
IF(ALPHA) WRITE(LFNOUT,920)
IF(BETA) WRITE(LFNOUT,930)
If this is a square matrix and NR is negative, only write the upper
triangular portion. Otherwise, write out the full matrix:
IF(ABS(NR).EQ.ABS(NC).AND.NR.LT.0) THEN
WRITE(LFNOUT,1000) ((A(I,J),I=1,J),J=1,ABS(NR))
ELSE
DO 10 J = 1,ABS(NC)
WRITE(LFNOUT,1000) (A(I,J),I=1,ABS(NR))
10 CONTINUE
END IF
RETURN
890 FORMAT(/1X)
900 FORMAT(1X,9A8,A7)
910 FORMAT(1X,A79,/1X,79('-'))
920 FORMAT(1X,'ALPHA SPIN')
930 FORMAT(1X,'BETA SPIN')
1000 FORMAT(1X,5F15.9)
END
*****************************************************************************
SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(MR,1),JOB(20)
DIMENSION ITEMP(20)
LOGICAL ERROR
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DATA IDASH,IALFA,IBETA/4H----,4HALPH,4HBETA/
Read the matrix A to the external file LFN:
Input: MR -- row dimension of matrix A in calling routine
NR -- ABS(NR) is the actual number of rows to be read
[if NR is negative and ABS(NR).EQ.NC (square matrix),
only the upper triangular portion is stored in the
input file. This routine will read the upper triangular
portion and unpack it.]
NC -- actual number of columns in matrix A
[used to determine if A is square]
LFN -- input file
Output: JOB -- INTEGER array containing the job title
[closed shell or alpha spin only]
ERROR -- set to .true. if the end-of-file was encountered while
reading
IF(ALPHA.OR..NOT.OPEN) READ(LFN,1000,END=800) JOB
IF(.NOT.OPEN) ISTR = IDASH
IF(ALPHA) ISTR = IALFA
IF(BETA) ISTR = IBETA
10 READ(LFN,1000,END=800) ITEMP
IF(ITEMP(1).NE.ISTR) GOTO 10
If this is a square matrix and NR is negative, only read the upper
triangular portion. Otherwise, read the full matrix:
IF(ABS(NR).EQ.ABS(NC).AND.NR.LT.0) THEN
READ(LFN,900,END=800) ((A(I,J),I=1,J),J=1,ABS(NR))
DO 30 J = 1,ABS(NR)-1
DO 20 I = J+1,ABS(NR)
A(I,J) = A(J,I)
20 CONTINUE
30 CONTINUE
ELSE
DO 40 J = 1,ABS(NC)
READ(LFN,900,END=800) (A(I,J),I=1,ABS(NR))
40 CONTINUE
END IF
ERROR = .FALSE.
RETURN
800 ERROR = .TRUE.
RETURN
900 FORMAT(1X,5F15.9)
1000 FORMAT(1X,20A4)
END
*****************************************************************************
SUBROUTINE ALTOUT(A,MR,MC,NR,NC)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DIMENSION A(MR,MC)
FOR 80 COLUMN OUTPUT:
LIST ELEMENTS OF ARRAY A (MATRIX OR VECTOR).
MR,MC DECLARED ROW AND COLUMN DIMENSIONALITY,
NR,NC ACTUAL ROW AND COLUMN DIMENSIONALITY,
NCL=1
NCU=6
NLOOPS=NC/6+1
DO 20 L=1,NLOOPS
IF(NCU.GT.NC) NCU=NC
WRITE(LFNPR,1100) (J,J=NCL,NCU)
DO 10 I=1,NR
10 WRITE(LFNPR,1200) I,(A(I,J),J=NCL,NCU)
IF(NCU.GE.NC) RETURN
NCL=NCU+1
20 NCU=NCU+6
RETURN
1100 FORMAT(/11X,10(I3,9X))
1200 FORMAT(1X,I3,10F12.5)
END
*****************************************************************************
SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
INTEGER STRING(LEN)
LOGICAL READ,ERROR
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DATA IW,IR,IP,IC,IV,IL/1HW,1HR,1HP,1HC,1HV,1HL/
DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/
Interpret the KEYword PARameter STRING, storing the result in IFLG.
(The default IFLG should be passed to this routine through IFLG)
The following STRINGs are acceptable:
STRING = Wnnn means write to the external file nnn (IFLG = -nnn)
(if nnn is omitted, IFLG = -LFN)
STRING = Rnnn means read from the external file nnn (IFLG = -nnn*1000)
(if nnn is omitted, IFLG = -LFN)
(READ must be true to allow reading)
STRING = PnnnC means print nnn columns to the output file (IFLG = nnn)
(if nnn is omitted, print full matrix, IFLG = 'FULL')
(the C is optional, it means columns)
STRING = PVAL means print val columns to output file (IFLG = 'VAL')
(val is the number of core + valence orbitals)
(only the V is necessary)
STRING = PLEW means print lew columns to output file (IFLG = 'LEW'
(lew is the number of occupied orbitals)
(only the L is necessary)
STRING = other IFLG is left untouched
ERROR = .FALSE.
Process STRING = W..:
IF(STRING(1).EQ.IW) THEN
IF(LEN.EQ.1) THEN
IFLG = -LFN
RETURN
END IF
IF(LEN.GT.1) THEN
CALL CONVIN(STRING(2),LEN-1,IFLG,ERROR)
IF(ERROR) RETURN
IF(IFLG.GT.1000) THEN
WRITE(LFNPR,900)
WRITE(LFNPR,910) IFLG
STOP
END IF
IFLG = -IFLG
END IF
Process STRING = R..:
ELSE IF(STRING(1).EQ.IR) THEN
IF(.NOT.READ) THEN
ERROR = .TRUE.
RETURN
END IF
IF(LEN.EQ.1) THEN
IFLG = -LFN * 1000
RETURN
END IF
IF(LEN.GT.1) THEN
CALL CONVIN(STRING(2),LEN-1,IFLG,ERROR)
IF(ERROR) RETURN
IF(IFLG.GT.1000) THEN
WRITE(LFNPR,900)
WRITE(LFNPR,920) IFLG
STOP
END IF
IFLG = -IFLG * 1000
END IF
Process STRING = P..:
ELSE IF(STRING(1).EQ.IP) THEN
IF(STRING(2).EQ.IV) THEN
IFLG = KVAL
RETURN
END IF
IF(STRING(2).EQ.IL) THEN
IFLG = KLEW
RETURN
END IF
IF(LEN.EQ.1) THEN
IFLG = KFULL
RETURN
END IF
IF(LEN.GT.1) THEN
IF(STRING(LEN).NE.IC) THEN
CALL CONVIN(STRING(2),LEN-1,IFLG,ERROR)
ELSE
CALL CONVIN(STRING(2),LEN-2,IFLG,ERROR)
END IF
END IF
ELSE
ERROR = .TRUE.
END IF
RETURN
900 FORMAT(/1X,'The NBO program will only communicate with external ',
+ 'files 0 thru 999.')
910 FORMAT(1X,'You''re attempting to write to file ',I6,'.')
920 FORMAT(1X,'You''re attempting to read from file ',I6,'.')
END
*****************************************************************************
FUNCTION IOINQR(IFLG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/
DATA KBLNK,KPRNT,KWRIT,KREAD/4H ,4HPRNT,4HWRIT,4HREAD/
Interpret IFLG, determining whether the corresponding matrix should be
printed, written out, or read:
IF(IFLG.EQ.KFULL) THEN
IOINQR = KPRNT
ELSE IF(IFLG.EQ.KVAL) THEN
IOINQR = KPRNT
ELSE IF(IFLG.EQ.KLEW) THEN
IOINQR = KPRNT
ELSE IF(IFLG.GT.0) THEN
IOINQR = KPRNT
ELSE IF(IFLG.LT.0.AND.IFLG.GT.-1000) THEN
IOINQR = KWRIT
ELSE IF(IFLG.LT.0) THEN
IOINQR = KREAD
ELSE
IOINQR = KBLNK
END IF
RETURN
END
*****************************************************************************
SUBROUTINE LBLAO
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXD = 2)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS),
+ NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS)
DIMENSION ISTR(MAXD),IANG(5),IXYZ(3),IBYTE(4),NUM(10)
DATA IBLNK/' '/
DATA IANG/'s','p','d','f','g'/
DATA IXYZ/'x','y','z'/
DATA ILEFT,IRIGHT/'(',')'/
DATA NUM/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DO 20 IAO = 1,NBAS
DO 10 I = 1,10
IAOLBL(I,IAO) = IBLNK
10 CONTINUE
LBL = NAMEAT(IATNO(LCTR(IAO)))
CALL DEBYTE(LBL,IBYTE)
IAOLBL(1,IAO) = IBYTE(1)
IAOLBL(2,IAO) = IBYTE(2)
CALL IDIGIT(LCTR(IAO),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
IAOLBL(4,IAO) = ISTR(1)
ELSE
IAOLBL(3,IAO) = ISTR(1)
IAOLBL(4,IAO) = ISTR(2)
END IF
IAOLBL(6,IAO) = ILEFT
L = LANG(IAO)/100
IAOLBL(7,IAO) = IANG(L+1)
IF(L.EQ.0) THEN
IAOLBL(8,IAO) = IRIGHT
ELSE IF(L.EQ.1) THEN
M = MOD(LANG(IAO),10)
IAOLBL(8,IAO) = IXYZ(M)
IAOLBL(9,IAO) = IRIGHT
ELSE IF(L.EQ.2.OR.L.EQ.3) THEN
IAOLBL(8,IAO) = NUM(MOD(LANG(IAO),10)+1)
IAOLBL(9,IAO) = IRIGHT
END IF
20 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE LBLNAO
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXD = 2)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS),
+ IPRIN(MAXBAS)
COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS),
+ NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS)
DIMENSION ISTR(MAXD),IANG(5),IXYZ(3),IBYTE(4),NUM(10)
DATA IBLNK/' '/
DATA IANG/'s','p','d','f','g'/
DATA IXYZ/'x','y','z'/
DATA ILEFT,IRIGHT/'(',')'/
DATA NUM/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DO 20 INAO = 1,NBAS
DO 10 I = 1,10
NAOLBL(I,INAO) = IBLNK
10 CONTINUE
LBL = NAMEAT(IATNO(NAOCTR(INAO)))
CALL DEBYTE(LBL,IBYTE)
NAOLBL(1,INAO) = IBYTE(1)
NAOLBL(2,INAO) = IBYTE(2)
CALL IDIGIT(NAOCTR(INAO),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NAOLBL(4,INAO) = ISTR(1)
ELSE
NAOLBL(3,INAO) = ISTR(1)
NAOLBL(4,INAO) = ISTR(2)
END IF
NAOLBL(5,INAO) = ILEFT
CALL IDIGIT(IPRIN(INAO),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NAOLBL(7,INAO) = ISTR(1)
ELSE
NAOLBL(6,INAO) = ISTR(1)
NAOLBL(7,INAO) = ISTR(2)
END IF
L = NAOL(INAO)/100
NAOLBL(8,INAO) = IANG(L+1)
IF(L.EQ.1) THEN
M = MOD(NAOL(INAO),10)
NAOLBL(9,INAO) = IXYZ(M)
ELSE IF(L.EQ.2.OR.L.EQ.3) THEN
NAOLBL(9,INAO) = NUM(MOD(NAOL(INAO),10)+1)
END IF
NAOLBL(10,INAO) = IRIGHT
20 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE LBLNBO
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXD = 2)
INTEGER ISTR(MAXD),IBYTE(4)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL1(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS),
+ NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS)
DATA IBLNK,IC,IL,IP,IR,IY,ISTAR,IHYP/' ','c','l','p','r','y','*',
+ '-'/
DATA ICR,ILP/'CR','LP'/
DATA ILEFT,IRIGHT/'(',')'/
DO 20 INBO = 1,NBAS
DO 10 I = 1,10
NBOLBL(I,INBO) = IBLNK
10 CONTINUE
IB = IBXM(INBO)
NCTR = 1
IF(LABEL(IB,5).NE.0) NCTR = 2
IF(LABEL(IB,6).NE.0) NCTR = 3
One-center labels:
IF(NCTR.EQ.1) THEN
LBL = NAMEAT(IATNO(LABEL(IB,4)))
CALL DEBYTE(LBL,IBYTE)
NBOLBL(1,INBO) = IBYTE(1)
NBOLBL(2,INBO) = IBYTE(2)
CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NBOLBL(4,INBO) = ISTR(1)
ELSE
NBOLBL(3,INBO) = ISTR(1)
NBOLBL(4,INBO) = ISTR(2)
END IF
NBOLBL(5,INBO) = ILEFT
IF(LABEL(IB,1).EQ.ICR) THEN
NBOLBL(6,INBO) = IC
NBOLBL(7,INBO) = IR
NBOLBL(8,INBO) = IRIGHT
ELSE IF(LABEL(IB,1).EQ.ILP) THEN
NBOLBL(6,INBO) = IL
NBOLBL(7,INBO) = IP
IF(LABEL(IB,2).EQ.ISTAR) THEN
NBOLBL(8,INBO) = ISTAR
NBOLBL(9,INBO) = IRIGHT
ELSE
NBOLBL(8,INBO) = IRIGHT
END IF
ELSE
NBOLBL(6,INBO) = IR
NBOLBL(7,INBO) = IY
NBOLBL(8,INBO) = ISTAR
NBOLBL(9,INBO) = IRIGHT
END IF
Two-center labels:
ELSE IF(NCTR.EQ.2) THEN
LBL = NAMEAT(IATNO(LABEL(IB,4)))
CALL DEBYTE(LBL,IBYTE)
NBOLBL(1,INBO) = IBYTE(1)
NBOLBL(2,INBO) = IBYTE(2)
CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NBOLBL(4,INBO) = ISTR(1)
ELSE
NBOLBL(3,INBO) = ISTR(1)
NBOLBL(4,INBO) = ISTR(2)
END IF
NBOLBL(5,INBO) = IHYP
LBL = NAMEAT(IATNO(LABEL(IB,5)))
CALL DEBYTE(LBL,IBYTE)
NBOLBL(6,INBO) = IBYTE(1)
NBOLBL(7,INBO) = IBYTE(2)
CALL IDIGIT(LABEL(IB,5),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NBOLBL(9,INBO) = ISTR(1)
ELSE
NBOLBL(8,INBO) = ISTR(1)
NBOLBL(9,INBO) = ISTR(2)
END IF
NBOLBL(10,INBO) = LABEL(IB,2)
Three-center labels:
ELSE
CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NBOLBL(2,INBO) = ISTR(1)
ELSE
NBOLBL(1,INBO) = ISTR(1)
NBOLBL(2,INBO) = ISTR(2)
END IF
NBOLBL(3,INBO) = IHYP
CALL IDIGIT(LABEL(IB,5),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NBOLBL(5,INBO) = ISTR(1)
ELSE
NBOLBL(4,INBO) = ISTR(1)
NBOLBL(5,INBO) = ISTR(2)
END IF
NBOLBL(6,INBO) = IHYP
CALL IDIGIT(LABEL(IB,6),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NBOLBL(8,INBO) = ISTR(1)
ELSE
NBOLBL(7,INBO) = ISTR(1)
NBOLBL(8,INBO) = ISTR(2)
END IF
NBOLBL(9,INBO) = LABEL(IB,2)
END IF
20 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXD = 2)
INTEGER ISTR(MAXD),IBYTE(4)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL1(MAXBAS),
+ LORBC(MAXBAS),LORB(MAXBAS)
COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS),
+ NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS)
DATA IBLNK,IC,IL,IP,IR,IY,I3,ISTAR,IHYP/' ','c','l','p','r','y',
+ '3','*','-'/
DATA ICR,ILP/'CR','LP'/
DATA ILEFT,IRIGHT/'(',')'/
DO 10 I = 1,10
NHOLBL(I,INHO) = IBLNK
10 CONTINUE
IB = IBXM(INBO)
One-center labels:
IF(NCTR.EQ.1) THEN
LBL = NAMEAT(IATNO(LABEL(IB,4)))
CALL DEBYTE(LBL,IBYTE)
NHOLBL(1,INHO) = IBYTE(1)
NHOLBL(2,INHO) = IBYTE(2)
CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NHOLBL(4,INHO) = ISTR(1)
ELSE
NHOLBL(3,INHO) = ISTR(1)
NHOLBL(4,INHO) = ISTR(2)
END IF
NHOLBL(5,INHO) = ILEFT
IF(LABEL(IB,1).EQ.ICR) THEN
NHOLBL(6,INHO) = IC
NHOLBL(7,INHO) = IR
NHOLBL(8,INHO) = IRIGHT
ELSE IF(LABEL(IB,1).EQ.ILP) THEN
NHOLBL(6,INHO) = IL
NHOLBL(7,INHO) = IP
IF(LABEL(IB,2).EQ.ISTAR) THEN
NHOLBL(8,INHO) = ISTAR
NHOLBL(9,INHO) = IRIGHT
ELSE
NHOLBL(8,INHO) = IRIGHT
END IF
ELSE
NHOLBL(6,INHO) = IR
NHOLBL(7,INHO) = IY
NHOLBL(8,INHO) = ISTAR
NHOLBL(9,INHO) = IRIGHT
END IF
Two-center and three-center labels:
ELSE
LBL = NAMEAT(IATNO(LABEL(IB,3+ICTR)))
CALL DEBYTE(LBL,IBYTE)
NHOLBL(1,INHO) = IBYTE(1)
NHOLBL(2,INHO) = IBYTE(2)
CALL IDIGIT(LABEL(IB,3+ICTR),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NHOLBL(4,INHO) = ISTR(1)
ELSE
NHOLBL(3,INHO) = ISTR(1)
NHOLBL(4,INHO) = ISTR(2)
END IF
NHOLBL(5,INHO) = ILEFT
IF(NCTR.EQ.2) THEN
LBL = NAMEAT(IATNO(LABEL(IB,6-ICTR)))
CALL DEBYTE(LBL,IBYTE)
NHOLBL(6,INHO) = IBYTE(1)
NHOLBL(7,INHO) = IBYTE(2)
CALL IDIGIT(LABEL(IB,6-ICTR),ISTR,ND,MAXD)
IF(ND.EQ.1) THEN
NHOLBL(9,INHO) = ISTR(1)
ELSE
NHOLBL(8,INHO) = ISTR(1)
NHOLBL(9,INHO) = ISTR(2)
END IF
NHOLBL(10,INHO) = IRIGHT
ELSE
NHOLBL(6,INHO) = I3
NHOLBL(7,INHO) = IHYP
NHOLBL(8,INHO) = IC
NHOLBL(9,INHO) = IRIGHT
END IF
END IF
RETURN
END
*****************************************************************************
GENERAL UTILITY ROUTINES:
SUBROUTINE ANGLES(X,Y,Z,THETA,PHI)
FUNCTION BDFIND(IAT,JAT)
SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR)
SUBROUTINE CONSOL(AUT,ALT,NDIM,N)
SUBROUTINE CONVIN(IJ,LEN,IK,ERROR)
SUBROUTINE CONVRT(N,NC1,NC2)
SUBROUTINE COPY(A,B,NDIM,NR,NC)
SUBROUTINE CORTBL(IAT,ICORE,IECP)
SUBROUTINE DEBYTE(I,IBYTE)
SUBROUTINE HALT(WORD)
SUBROUTINE IDIGIT(KINT,IK,ND,MAXD)
FUNCTION IHTYP(IBO,JBO)
SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR)
SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT)
SUBROUTINE MATMLT(A,B,V,NDIM,N)
SUBROUTINE MATML2(A,B,V,NDIM,N)
FUNCTION NAMEAT(IZ)
SUBROUTINE NORMLZ(A,S,M,N)
SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK)
SUBROUTINE PACK(T,NDIM,NBAS,L2)
SUBROUTINE RANK(EIG,N,NDIM,ARCRNK)
SUBROUTINE SIMTRN(A,T,V,NDIM,N)
SUBROUTINE SIMTRS(A,S,V,NDIM,N)
SUBROUTINE TRANSP(A,NDIM,N)
SUBROUTINE UNPACK(T,NDIM,NBAS,L2)
SUBROUTINE VALTBL(IAT,IVAL)
FUNCTION VECLEN(X,N,NDIM)
SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR,
+ IERR)
SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG)
SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR)
SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM)
*****************************************************************************
SUBROUTINE ANGLES(X,Y,Z,THETA,PHI)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DATA ZERO,CUTOFF,ONE/0.0D0,1.0D-8,1.0D0/
CONV = 180.0/(4.0*ATAN(ONE))
IF(X.EQ.ZERO.AND.Y.EQ.ZERO) THEN
IF(Z.GE.ZERO) THEN
THETA = ZERO
ELSE
THETA = 180.0
END IF
PHI = ZERO
ELSE
IF(ABS(Z-ONE).LT.CUTOFF) THEN
THETA = ZERO
ELSE IF(ABS(Z+ONE).LT.CUTOFF) THEN
THETA = 180.0
ELSE IF(Z.LT.ONE.AND.Z.GT.-ONE) THEN
THETA = ACOS(Z) * CONV
IF(THETA.GT.180.0) THETA = 360.0 - THETA
ELSE
STOP 'ArcCosine out of bounds in SR ANGLES'
END IF
PHI = ATAN2(Y,X) * CONV
IF(PHI.LT.ZERO) PHI = PHI + 360.0
IF(ABS(PHI-360.0).LT.0.05) PHI = ZERO
IF(ABS(THETA).LT.0.05) PHI = ZERO
IF(ABS(THETA-180.0).LT.0.05) PHI = ZERO
END IF
RETURN
END
*****************************************************************************
FUNCTION BDFIND(IAT,JAT)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL BDFIND,IFOUND,JFOUND
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DATA LSTAR/1H*/
SET BDFIND=.TRUE. IF THERE IS AT LEAST ONE BOND BETWEEN ATOMS IAT AND JAT
DO 100 IBAS = 1,NBAS
IB = IBXM(IBAS)
IF(LABEL(IB,2).EQ.LSTAR) GO TO 100
IF(LABEL(IB,3).NE.1) GO TO 100
IFOUND = .FALSE.
JFOUND = .FALSE.
DO 50 K = 4,6
IF(LABEL(IB,K).EQ.IAT) IFOUND = .TRUE.
IF(LABEL(IB,K).EQ.JAT) JFOUND = .TRUE.
50 CONTINUE
IF(IFOUND.AND.JFOUND) GO TO 200
100 CONTINUE
BDFIND = .FALSE.
RETURN
200 BDFIND = .TRUE.
RETURN
END
*****************************************************************************
SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION LISTA(NATOMS,2),ISTR(80)
PARAMETER (MAXD = 4)
DIMENSION INUM(MAXD),IBYTE(4)
DATA IC,IH,IBLNK,ILEFT,IRIGHT/'C','H',' ','(',')'/
Build the chemical formula from the list of atoms in LISTA:
Get chemical symbols:
DO 10 IAT = 1,NAT
LISTA(IAT,1) = NAMEAT(LISTA(IAT,1))
10 CONTINUE
Alphabetize these symbols:
DO 30 IAT = 1,NAT-1
DO 20 JAT = 1,NAT-IAT
IF(LISTA(JAT,1).GT.LISTA(JAT+1,1)) THEN
ITEMP = LISTA(JAT,1)
LISTA(JAT,1) = LISTA(JAT+1,1)
LISTA(JAT+1,1) = ITEMP
ITEMP = LISTA(JAT,2)
LISTA(JAT,2) = LISTA(JAT+1,2)
LISTA(JAT+1,2) = ITEMP
END IF
20 CONTINUE
30 CONTINUE
Build chemical formula in ISTR:
First carbon...
NL = 1
ISTR(NL) = ILEFT
DO 50 IAT = 1,NAT
CALL DEBYTE(LISTA(IAT,1),IBYTE)
IF(IBYTE(1).EQ.IBLNK.AND.IBYTE(2).EQ.IC) THEN
NL = NL + 1
ISTR(NL) = IC
IF(LISTA(IAT,2).NE.1) THEN
CALL IDIGIT(LISTA(IAT,2),INUM,ND,MAXD)
DO 40 IL = 1,ND
NL = NL + 1
ISTR(NL) = INUM(IL)
40 CONTINUE
END IF
LISTA(IAT,2) = 0
END IF
50 CONTINUE
then hydrogen...
DO 70 IAT = 1,NAT
CALL DEBYTE(LISTA(IAT,1),IBYTE)
IF(IBYTE(1).EQ.IBLNK.AND.IBYTE(2).EQ.IH) THEN
NL = NL + 1
ISTR(NL) = IH
IF(LISTA(IAT,2).NE.1) THEN
CALL IDIGIT(LISTA(IAT,2),INUM,ND,MAXD)
DO 60 IL = 1,ND
NL = NL + 1
ISTR(NL) = INUM(IL)
60 CONTINUE
END IF
LISTA(IAT,2) = 0
END IF
70 CONTINUE
and now the rest...
DO 90 IAT = 1,NAT
IF(LISTA(IAT,2).NE.0) THEN
CALL DEBYTE(LISTA(IAT,1),IBYTE)
IF(IBYTE(1).NE.IBLNK) THEN
NL = NL + 1
ISTR(NL) = IBYTE(1)
END IF
IF(IBYTE(2).NE.IBLNK) THEN
NL = NL + 1
ISTR(NL) = IBYTE(2)
END IF
IF(LISTA(IAT,2).NE.1) THEN
CALL IDIGIT(LISTA(IAT,2),INUM,ND,MAXD)
DO 80 IL = 1,ND
NL = NL + 1
ISTR(NL) = INUM(IL)
80 CONTINUE
END IF
LISTA(IAT,2) = 0
END IF
90 CONTINUE
NL = NL + 1
ISTR(NL) = IRIGHT
RETURN
END
*****************************************************************************
SUBROUTINE CONSOL(AUT,ALT,NDIM,N)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
CONSOLIDATE AUT, ALT TO A SINGLE MATRIX, WITH AUT AS UPPER TRIANGLE
(INCLUDING DIAGONAL) AND ALT AS LOWER TRIANGLE. STORE RESULT IN AUT.
DIMENSION AUT(NDIM,NDIM),ALT(NDIM,NDIM)
NM1=N-1
DO 10 J=1,NM1
JP1=J+1
DO 10 I=JP1,N
10 AUT(I,J)=ALT(I,J)
RETURN
END
*****************************************************************************
SUBROUTINE CONVIN(IJ,LEN,IK,ERROR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION IJ(1)
DIMENSION INT(10)
LOGICAL ERROR
DATA INT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
Convert the array IJ(LEN) into an integer IK:
ERROR = .FALSE.
IF(LEN.LE.0) THEN
ERROR = .TRUE.
RETURN
END IF
Make sure all elements of IJ are integers:
IL = 0
MULT = 1
DO 30 I = LEN,1,-1
DO 10 J = 1,10
JJ = J - 1
IF(IJ(I).EQ.INT(J)) GOTO 20
10 CONTINUE
ERROR = .TRUE.
RETURN
20 IL = IL + JJ * MULT
MULT = MULT * 10
30 CONTINUE
IK = IL
RETURN
END
*****************************************************************************
SUBROUTINE CONVRT(N,NC1,NC2)
*****************************************************************************
CONVERT 2-DIGIT INTEGER 'N' TO TWO LITERAL CHARACTERS 'NC1','NC2'.
DIMENSION INT(10)
DATA ISP,INT/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0/
NC1=ISP
NC2=ISP
IF(N.LE.0) RETURN
IF(N.GE.10) GO TO 10
NC2=INT(N)
RETURN
10 N1=N/10
IF(N1.GT.9) STOP 'ROUTINE CONVRT'
NC1=INT(N1)
N2=N-N1*10
IF(N2.EQ.0) N2=10
NC2=INT(N2)
RETURN
END
*****************************************************************************
SUBROUTINE COPY(A,B,NDIM,NR,NC)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(NDIM,1),B(NDIM,1)
COPY A TO B:
DO 20 J = 1,NC
DO 10 I = 1,NR
B(I,J) = A(I,J)
10 CONTINUE
20 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE CORTBL(IAT,ICORE,IECP)
*****************************************************************************
CORE TABLE:
Determine the number of subshells of core orbitals of each angular
symmetry for atom number IAT. ICORE is an integer array LMAX+1
long which returns the number of subshells to the calling subroutine:
the number of `s' subshells in ICORE(1), the number of `p' subshells
in ICORE(2), etc...
If the CORE option has been used, the core orbitals stored in the array
IATCR are used rather than the core orbitals of the nominal core table.
If IECP = 0 return the number of subshells, excluding subshells of
an effective core potential.
IF IECP = 1 return the number of subshells, including subshells of
an effective core potential.
Note: It is possible for a negative number of core orbitals be found
if effective core potentials are employed. This happens when the
number of core electrons in the effective core potential is either
greater than the nominal number of core electrons or is greater than the
number of core electrons requested when using the CORE option.
------------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (LMAX = 3)
INTEGER CORE(57),ICORE(4),ITEMP(4),IORD(16),JORD(20),KORD(20)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
DATA IORD/1,1,3,1,3,5,1,3,5,1,3,7,5,1,3,7/
DATA JORD/1,1,3,1,3,1,5,3,1,5,3,1,7,5,3,1,7,5,3,1/
DATA KORD/1,2,1,3,2,4,1,3,5,2,4,6,1,3,5,7,2,4,6,8/
DATA CORE/2,0,8,1,1,8,2,2,1,12,2,3,2,6,3,3,2,1,12,3,4,3,1,6,3,4,3,
+ 2,16,3,5,4,2,10,4,5,4,2,1,6,4,5,4,3,1,16,4,6,5,3,1,10,4,6,5,3,2/
Initialize arrays. If there is no nuclear charge at this center,
return to calling routine:
DO 10 L = 0,LMAX
ICORE(L+1) = 0
ITEMP(L+1) = 0
10 CONTINUE
IF(IATNO(IAT).LE.0) RETURN
If the CORE option has not been used for this atom, use the nominal
set of core orbitals:
IF(JCORE.NE.1.OR.IATCR(IAT).LT.0) THEN
JAT = IATNO(IAT)
II = 0
20 II = II + 1
JAT = JAT - CORE(II)
II = II + 1
IF(JAT.LE.0) THEN
DO 30 L = 1,CORE(II)
ICORE(L) = CORE(II+L)
30 CONTINUE
ELSE
II = II + CORE(II)
END IF
IF(JAT.GT.0) GOTO 20
ELSE
If the CORE option has been used, determine the number of core
orbitals on this atom:
II = IATCR(IAT)
IF(II.GT.0) THEN
ICT = 0
40 ICT = ICT + 1
L = IORD(ICT)/2
ICORE(L+1) = ICORE(L+1) + 1
II = II - IORD(ICT)
IF(II.GT.0) GOTO 40
END IF
END IF
If effective core potentials were used and IECP = 0, remove
the core orbitals of the ECP:
IF(IPSEUD.NE.0.AND.IECP.EQ.0) THEN
II = IATNO(IAT)
ICT = 0
50 ICT = ICT + 1
II = II - 2 * JORD(ICT)
IF(II.GT.0) GOTO 50
II = IZNUC(IAT) - II
IF(II.LE.0) STOP 'Zero or negative IZNUC entry?'
ICT = ICT + 1
60 ICT = ICT - 1
IF(ICT.LE.0) STOP 'Error in SR CORTBL'
II = II - 2 * JORD(ICT)
IF(II.GE.0) THEN
L = JORD(ICT)/2
IF(ICORE(L+1).GE.KORD(ICT)) ITEMP(L+1) = ITEMP(L+1) + 1
ELSE
II = II + 2 * JORD(ICT)
END IF
IF(II.NE.0) GOTO 60
DO 70 L = 0,LMAX
ICORE(L+1) = ITEMP(L+1)
70 CONTINUE
END IF
RETURN
END
*****************************************************************************
SUBROUTINE DEBYTE(I,IBYTE)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION IBYTE(4),KB(4)
SAVE KB,KPAD,KSW
DATA KSW/0/
DATA KTMP/4HABCD/
Extract four Hollerith characters from I, store in IBTYE:
If this is the first time that this routine is called, determine
in which bytes of an integer word the Hollerith characters reside:
IF(KSW.EQ.0) THEN
KSW = 1
DO 10 K = 1,4
KB(K) = 0
10 CONTINUE
KBYTE = 0
20 KBYTE = KBYTE + 1
IF(KBYTE.GT.8) STOP 'Routine DEBYTE is limited to INTEGER*8'
KTEST = MOD(KTMP,256)
IF(KTEST.EQ.65) KB(1) = KBYTE
IF(KTEST.EQ.66) KB(2) = KBYTE
IF(KTEST.EQ.67) KB(3) = KBYTE
IF(KTEST.EQ.68) KB(4) = KBYTE
KTMP = KTMP/256
IF(KTMP.NE.0) GOTO 20
DO 30 K = 1,4
IF(KB(K).EQ.0) STOP 'Error in routine DEBYTE'
30 CONTINUE
Determine the bit padding:
KPAD = 0
KMLT = 1
DO 40 K = 1,KBYTE
IF(K.NE.KB(1)) KPAD = KPAD + 32 * KMLT
IF(K.NE.KBYTE) KMLT = KMLT * 256
40 CONTINUE
DO 60 K = 1,4
KMAX = KB(K) - 1
KB(K) = 1
DO 50 L = 1,KMAX
KB(K) = KB(K) * 256
50 CONTINUE
60 CONTINUE
END IF
Extract four Hollerith characters from I:
DO 100 K = 1,4
IBYTE(K) = MOD(I/KB(K),256)*KB(1) + KPAD
100 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE HALT(WORD)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
DATA BLANK/1H /
IF(WORD.EQ.BLANK) RETURN
WRITE(LFNPR,1000) WORD
STOP
1000 FORMAT(' Non-integer encountered when trying to read variable ',
+ '/',A6,'/')
END
*****************************************************************************
SUBROUTINE IDIGIT(KINT,IK,ND,MAXD)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION IK(MAXD),INT(10)
DATA IBLNK,INT/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0/
CONVERTS THE INTEGER KINT INTO THE FIRST ND ELEMENTS OF HOLLERITH ARRAY
IK(MAXD):
JINT = KINT
ND = MAXD
DO 10 ID = MAXD,1,-1
II = MOD(JINT,10)
IF(II.EQ.0) II = 10
IK(ID) = INT(II)
IF(II.NE.10) ND = ID
JINT = JINT/10
10 CONTINUE
ND = MAXD - ND + 1
SHIFT INTEGER REP IN IK SO THAT THE NUMBER OCCUPIES THE FIRST ND
ELEMENTS:
DO 20 ID = 1,ND
IK(ID) = IK(ID+MAXD-ND)
20 CONTINUE
DO 30 ID = ND+1,MAXD
IK(ID) = IBLNK
30 CONTINUE
RETURN
END
*****************************************************************************
FUNCTION IHTYP(IBO,JBO)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL BDFIND
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
DATA IV,IG,IR/'v','g','r'/
Determine whether the IBO->JBO delocalization is vicinal (IHTYP='v'),
geminal (IHTYP='g'), or remote (IHTYP='r'):
IHTYP = IR
IF(NBOUNI(IBO).EQ.NBOUNI(JBO)) THEN
ICTR = MOD(NBOTYP(IBO),10)
IB = IBXM(IBO)
JCTR = MOD(NBOTYP(JBO),10)
JB = IBXM(JBO)
DO 20 I = 1,ICTR
IAT = LABEL(IB,I+3)
DO 10 J = 1,JCTR
JAT = LABEL(JB,J+3)
IF(IAT.EQ.JAT) THEN
IHTYP = IG
RETURN
ELSE IF(BDFIND(IAT,JAT)) THEN
IHTYP = IV
END IF
10 CONTINUE
20 CONTINUE
END IF
RETURN
END
*****************************************************************************
SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIAGONALIZE REAL SYMMETRIC MATRIX A BY JACOBI ROTATIONS:
N: ACTUAL DIMENSION OF A,EIVR
NDIM: DECLARED DIMENSION OF A,EIVR
ICONTR: CONTROL OPTION
******** MODIFIED VERSION, MARCH 1986 *************
ICONTR = 0: REDUCE ALL OFF-DIAGONAL ELEMENTS TO "DONE" OR SMALLER
-- THIS SETS FULMIX=.TRUE.
ICONTR = 1: DO THE SAME AS FOR ICONTR=0 EXCEPT DO NOT MIX ORBITALS THAT
ARE DEGENERATE TO WITHIN "DIFFER" IF THE OFFDIAGONAL ELEMENT CONNECTING
THEM IS LESS THAN "DIFFER".
-- THIS SETS FULMIX=.FALSE.
FOR THE PURPOSES OF THE NAO AND NBO PROGRAMS, THESE VALUES ARE SET:
DIFFER = 1.0D-5
THRESHOLD FOR CONSIDERING TWO VECTORS NONDEGENERATE IF
ICONTR=1
DONE = 1.0D-13
THIS IS THE PARAMETER FOR CONVERGENCE OF THE OFF-DIAGONAL
MATRIX ELEMENTS. (ABSOLUTE) --- Reduced from 1.0D-10
on 8/31/88. A more converged Fock matrix was required
for the NBO deletions with symmetry to work properly
(EDG) ---
EPS = 0.5D-13
THIS PARAMETER HAS TO DO WITH THE MACHINE PRECISION AND SHOULD
BE SET TO A VALUE BETWEEN "DONE" AND THE MACHINE PRECISION.
--- Reduced from 1.0D-11. 8/31/88 (EDG) ---
LOGICAL FULMIX
DIMENSION A(NDIM,1),EIVR(NVDIM,1),EIVU(1)
IMPORTANT PARAMETERS:
DATA DIFFER,DONE,EPS,PT99/1.0D-5,1.0D-13,0.5D-13,0.99D0/
DATA ZERO,ONE,FIVE/0.0D0,1.0D0,5.0D0/
FULMIX=.TRUE.
IF(ICONTR.EQ.1) FULMIX=.FALSE.
IF(N.GT.1) GO TO 10
EIVR(1,1)=ONE
EIVU(1)=A(1,1)
RETURN
10 CONTINUE
DO 30 J=1,N
DO 20 I=1,N
20 EIVR(I,J)=ZERO
30 EIVR(J,J)=ONE
FIND THE ABSOLUTELY LARGEST ELEMENT OF A
FIRST CHECK THE OFF-DIAGONAL ELEMENTS:
ATOP=ZERO
DO 50 J=2,N
JM1=J-1
DO 50 I=1,JM1
IF(ATOP.GT.ABS(A(I,J))) GO TO 50
ATOP= ABS(A(I,J))
50 CONTINUE
OFFTOP=ATOP
NOW CHECK THE DIAGONAL ELEMENTS:
DO 60 J=1,N
IF(ATOP.GT.ABS(A(J,J))) GO TO 60
ATOP= ABS(A(J,J))
60 CONTINUE
IF MATRIX IS ALREADY EFFECTIVELY DIAGONAL,
PUT DIAGONAL ELEMENTS IN EIVU AND RETURN
IF(ATOP.LT.DONE) GO TO 260
IF(OFFTOP.LT.DONE) GO TO 260
CALCULATE THE STOPPING CRITERION -- DSTOP
AVGF= FLOAT(N*(N-1)/2)
D=0.0D0
DO 80 JJ=2,N
DO 80 II=2,JJ
S=A(II-1,JJ)/ATOP
80 D=S*S+D
DSTOP=(1.D-7)*D
CALCULATE THE THRESHOLD, THRSH
THRSH= SQRT(D/AVGF)*ATOP
TO MAKE THRSH DIFFERENT THAN ANY MATRIX ELEMENT OF A, MULTIPLY BY 0.99
THRSH=THRSH*PT99
IF(THRSH.LT.DONE) THRSH=DONE
START A SWEEP
90 IFLAG=0
DO 250 JCOL=2,N
JCOL1=JCOL-1
DO 250 IROW=1,JCOL1
AIJ=A(IROW,JCOL)
COMPARE THE OFF-DIAGONAL ELEMENT WITH THRSH
ABSAIJ=ABS(AIJ)
IF (ABSAIJ.LT.THRSH) GO TO 250
AII=A(IROW,IROW)
AJJ=A(JCOL,JCOL)
S=AJJ-AII
ABSS=ABS(S)
DON'T ROTATE THE VECTORS IROW AND JCOL IF IROW AND JCOL WOULD STILL
BE DEGENERATE WITHIN "DIFFER":
IF(FULMIX) GO TO 100
IF((ABSS.LT.DIFFER).AND.(ABSAIJ.LT.DIFFER)) GO TO 250
100 CONTINUE
CHECK TO SEE IF THE CHOSEN ROTATION IS LESS THAN THE ROUNDING ERROR
IF SO , THEN DO NOT ROTATE.
TEST=EPS*ABSS
IF (ABSAIJ.LT.TEST) GO TO 250
IFLAG=1
IF THE ROTATION IS VERY CLOSE TO 45 DEGREES, SET SIN AND COS
TO 1/(ROOT 2).
TEST=EPS*ABSAIJ
IF (ABSS.GT.TEST) GO TO 130
S=.707106781D0
C=S
GO TO 140
CALCULATION OF SIN AND COS FOR ROTATION THAT IS NOT VERY CLOSE
TO 45 DEGREES
130 T=AIJ/S
S=0.25D0/ SQRT(0.25D0+T*T)
COS=C , SIN=S
C= SQRT(0.5D0+S)
S=2.D0*T*S/C
CALCULATION OF THE NEW ELEMENTS OF MATRIX A
140 DO 150 I=1,IROW
T=A(I,IROW)
U=A(I,JCOL)
A(I,IROW)=C*T-S*U
150 A(I,JCOL)=S*T+C*U
I2=IROW+2
IF (I2.GT.JCOL) GO TO 180
DO 170 I=I2,JCOL
T=A(I-1,JCOL)
U=A(IROW,I-1)
A(I-1,JCOL)=S*U+C*T
170 A(IROW,I-1)=C*U-S*T
180 A(JCOL,JCOL)=S*AIJ+C*AJJ
A(IROW,IROW)=C*A(IROW,IROW)-S*(C*AIJ-S*AJJ)
DO 190 J=JCOL,N
T=A(IROW,J)
U=A(JCOL,J)
A(IROW,J)=C*T-S*U
190 A(JCOL,J)=S*T+C*U
ROTATION COMPLETED
DO 210 I=1,N
T=EIVR(I,IROW)
EIVR(I,IROW)=C*T-EIVR(I,JCOL)*S
210 EIVR(I,JCOL)=S*T+EIVR(I,JCOL)*C
CALCULATE THE NEW NORM D AND COMPARE WITH DSTOP
S=AIJ/ATOP
D=D-S*S
IF (D.GT.DSTOP) GO TO 240
RECALCULATE DSTOP AND THRSH TO DISCARD ROUNDING ERRORS
D=ZERO
DO 230 JJ=2,N
DO 230 II=2,JJ
S=A(II-1,JJ)/ATOP
230 D=S*S+D
DSTOP=(1.D-7)*D
240 CONTINUE
OLDTHR=THRSH
THRSH= SQRT(D/AVGF)*ATOP*PT99
IF(THRSH.LT.DONE) THRSH=DONE*PT99
IF(THRSH.GT.OLDTHR) THRSH=OLDTHR
250 CONTINUE
IF(THRSH.LT.DONE) GO TO 260
IF(IFLAG.EQ.1) GO TO 90
THRSH=THRSH/FIVE
GO TO 90
PLACE EIGENVALUES IN EIVU
260 CONTINUE
DO 270 J=1,N
EIVU(J)=A(J,J)
270 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(NDIM,NDIM),M(NCDIM),A(NCDIM,NCDIM),B(NCDIM)
...DO A LIMITED TRANSFORMATION OF T, INCLUDING ONLY THE "NC" ROWS AND
COLUMNS SPECIFIED IN THE VECTOR "M":
IOPT= 1 : TAKE T=T*A
IOPT= 0 : TAKE T=A(TRANSPOSE)*T*A
IOPT=-1 : TAKE T=A(TRANSPOSE)*T
IF(IOPT.EQ.1) GO TO 100
FIRST, TAKE T=A(TRANSPOSE)*T, WHERE T=S,DM
DO 30 J=1,NBAS
DO 10 K=1,NC
10 B(K)=T(M(K),J)
DO 30 I=1,NC
SUM=0.0D0
DO 20 K=1,NC
20 SUM=SUM+A(K,I)*B(K)
30 T(M(I),J)=SUM
IF(IOPT.EQ.-1) RETURN
NOW, TAKE T=T*A
100 CONTINUE
DO 160 I=1,NBAS
DO 140 K=1,NC
140 B(K)=T(I,M(K))
DO 160 J=1,NC
SUM=0.0D0
DO 150 K=1,NC
150 SUM=SUM+B(K)*A(K,J)
160 T(I,M(J))=SUM
RETURN
END
*****************************************************************************
SUBROUTINE MATMLT(A,B,V,NDIM,N)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(1),B(1),V(NDIM)
DATA ZERO/0.0D0/
MULTIPLY A*B (USING SCRATCH VECTOR V), STORE RESULT IN A:
NDIF=NDIM-N
DO 30 I=1,N
KJ=0
IKK=I-NDIM
DO 20 J=1,N
IK=IKK
TEMP=ZERO
DO 10 K=1,N
IK=IK+NDIM
KJ=KJ+1
10 TEMP=TEMP+A(IK)*B(KJ)
KJ=KJ+NDIF
20 V(J)=TEMP
IJ=I-NDIM
DO 30 J=1,N
IJ=IJ+NDIM
30 A(IJ)=V(J)
RETURN
END
*****************************************************************************
SUBROUTINE MATML2(A,B,V,NDIM,N)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(1),B(1),V(NDIM)
DATA ZERO/0.0D0/
B=A(TRANSPOSE)*B
MULTIPLY A(TRANSPOSE)*B (USING SCRATCH VECTOR V), STORE RESULT IN B:
ASSUME A*B IS A SYMMETRIC MATRIX, SO ALMOST HALF THE WORK IS SAVED.
THIS CAN BE THE SECOND STEP IN A SIMILARITY TRANSFORMATION OF B BY A.
IJ=0
IJJ=-NDIM
KJJ=-NDIM
DO 50 J=1,N
KII=-NDIM
KJJ=KJJ+NDIM
DO 20 I=1,J
KII=KII+NDIM
KI=KII
KJ=KJJ
TEMP=ZERO
DO 10 K=1,N
KI=KI+1
KJ=KJ+1
10 TEMP=TEMP+A(KI)*B(KJ)
20 V(I)=TEMP
IJJ=IJJ+NDIM
IJ=IJJ
JI=J-NDIM
JM1=J-1
DO 30 I=1,JM1
IJ=IJ+1
JI=JI+NDIM
VV=V(I)
B(IJ)=VV
30 B(JI)=VV
IJ=IJ+1
50 B(IJ)=V(J)
RETURN
END
*****************************************************************************
FUNCTION NAMEAT(IZ)
*****************************************************************************
RETURN ATOMIC SYMBOL FOR NUCLEAR CHARGE IZ (.LE. 103):
DIMENSION NAME(103)
DATA IGHOST/'gh'/IBLANK/' '/
DATA NAME/' H','He','Li','Be',' B',' C',' N',' O',' F','Ne',
+ 'Na','Mg','Al','Si',' P',' S','Cl','Ar',' K','Ca','Sc','Ti',
+ ' V','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As',
+ 'Se','Br','Kr','Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru',
+ 'Rh','Pd','Ag','Cd','In','Sn','Sb','Te',' I','Xe','Cs',
+ 'Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy',
+ 'Ho','Er','Tm','Yb','Lu','Hf','Ta',' W','Re','Os','Ir',
+ 'Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn','Fr','Ra',
+ 'Ac','Th','Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es',
+ 'Fm','Md','No','Lr'/
IF(IZ.LT.0.OR.IZ.GT.103) NAMEAT = IBLANK
IF(IZ.GT.0) NAMEAT = NAME(IZ)
IF(IZ.EQ.0) NAMEAT = IGHOST
RETURN
END
*****************************************************************************
SUBROUTINE NORMLZ(A,S,M,N)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(M,M),S(M,M)
DATA ZERO,ONE /0.0D0,1.0D0/
NORMALIZE COLUMNS OF A
DO 40 I = 1,N
TEMP = ZERO
DO 20 J = 1,N
DO 10 K = 1,N
TEMP = TEMP + A(J,I)*A(K,I)*S(J,K)
10 CONTINUE
20 CONTINUE
FACTOR = ONE/SQRT(TEMP)
DO 30 J = 1,N
A(J,I) = FACTOR * A(J,I)
30 CONTINUE
40 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
RANK POSITIVE ELEMENTS OF INTEGER 'LIST', LOWEST VALUES FIRST.
INTEGER RANK,ARCRNK,TEMP
DIMENSION RANK(NDIM),LIST(NDIM),ARCRNK(NDIM)
DO 10 I=1,N
10 ARCRNK(I)=I
DO 40 I=1,N
IF(I.EQ.N)GO TO 30
I1=I+1
DO 20 J=I1,N
IF(LIST(J).GE.LIST(I))GO TO 20
TEMP=LIST(I)
LIST(I)=LIST(J)
LIST(J)=TEMP
TEMP=ARCRNK(I)
ARCRNK(I)=ARCRNK(J)
ARCRNK(J)=TEMP
20 CONTINUE
30 RANK(ARCRNK(I))=I
IF(LIST(I).LE.0) GO TO 50
40 CONTINUE
RETURN
50 DO 60 K=I,N
RANK(ARCRNK(K))=0
60 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE PACK(T,NDIM,NBAS,L2)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
DATA ZERO/0.0D0/
PACK: PACKS A SYMMETRIC MATRIX T INTO AN UPPER TRIANGULAR MATRIX.
T SHOULD BE DIMENSIONED (NDIM,NDIM) IN THE CALLING ROUTINE:
IF(NBAS.GT.NDIM) STOP 'NBAS IS GREATER THAN NDIM'
II = 0
DO 200 J = 1,NBAS
JPTR = (J-1) * NDIM
DO 100 I = 1,J
IPTR = JPTR + I
II = II + 1
T(II) = T(IPTR)
100 CONTINUE
200 CONTINUE
IF(II.NE.L2) STOP 'ERROR IN ROUTINE PACK'
DO 300 I = II+1,NDIM*NDIM
T(I) = ZERO
300 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE RANK(EIG,N,NDIM,ARCRNK)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
ORDER NUMBERS IN 'EIG', HIGHEST VALUES FIRST,
AND CONSTRUCT 'ARCRNK':
ARCRNK(I) IS THE OLD LOCATION OF THE I-TH HIGHEST VALUE IN EIG
NOTE: UPON RETURN, EIG(I) IS THE I-TH HIGHEST VALUE IN EIG
IMPORTANT: NUMBERS IN EIG ARE NOT SWITCHED UNLESS THEY DIFFER
BY MORE THAN "DIFFER": 5.0D-8
INTEGER ARCRNK
DIMENSION ARCRNK(NDIM),EIG(NDIM)
DATA DIFFER/5.0D-8/
DO 10 I=1,N
10 ARCRNK(I)=I
DO 40 I=1,N
IF(I.EQ.N)GO TO 40
I1=I+1
DO 20 J=I1,N
IF((EIG(J)-EIG(I)).LT.DIFFER) GO TO 20
TEMP=EIG(I)
EIG(I)=EIG(J)
EIG(J)=TEMP
ITEMP=ARCRNK(I)
ARCRNK(I)=ARCRNK(J)
ARCRNK(J)=ITEMP
20 CONTINUE
40 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE SIMTRN(A,T,V,NDIM,N)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
SIMILARITY TRANSFORM A ==> T(TRANSPOSE)*A*T, USING SCRATCH VECTOR V.
DIMENSION A(NDIM,NDIM),T(NDIM,NDIM),V(NDIM)
CALL MATMLT(A,T,V,NDIM,N)
CALL TRANSP(A,NDIM,N)
CALL MATMLT(A,T,V,NDIM,N)
CALL TRANSP(A,NDIM,N)
RETURN
END
*****************************************************************************
SUBROUTINE SIMTRS(A,S,V,NDIM,N)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
SIMILARITY TRANSFORM A ==> S(TRANSPOSE)*A*S, USING SCRATCH VECTOR V.
FAST VERSION --- ASSUMES RESULT IS A SYMMETRIC MATRIX
DIMENSION A(NDIM,NDIM),S(NDIM,NDIM),V(NDIM)
CALL MATMLT(A,S,V,NDIM,N)
CALL MATML2(S,A,V,NDIM,N)
RETURN
END
*****************************************************************************
SUBROUTINE TRANSP(A,NDIM,N)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(NDIM,NDIM)
TRANSPOSE MATRIX A, STORE RESULT IN A.
DO 10 I=1,N
DO 10 J=1,I
TEMP=A(I,J)
A(I,J)=A(J,I)
10 A(J,I)=TEMP
RETURN
END
*****************************************************************************
SUBROUTINE UNPACK(T,NDIM,NBAS,L2)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
UNPACK: UNPACKS AN UPPER TRIANGULAR MATRIX (VECTOR L2 LONG) INTO A
SYMMETRIC MATRIX T(NBAS,NBAS). NOTE: T SHOULD BE DIMENSIONED
(NDIM,NDIM) IN THE CALLING ROUTINE.
FIRST SPREAD OUT THE L2 NUMBERS INTO THE UPPER PART OF THE WHOLE ARRAY.
J = 0
K = 1
IPTR = (NDIM + 1)*(NBAS - K) + 1
DO 200 I = L2,1,-1
T(IPTR-J) = T(I)
IF(J.LT.NBAS-K) THEN
J = J + 1
ELSE
J = 0
K = K + 1
IPTR = (NDIM + 1)*(NBAS - K) + 1
END IF
200 CONTINUE
NOW FILL IN THE HOLES IN THE OUTPUT ARRAY.
DO 400 J = 1,NBAS-1
ICOL = (J-1)*NDIM
DO 300 I = J+1,NBAS
IPTR = ICOL + I
JPTR = (I-1)*NDIM + J
T(IPTR) = T(JPTR)
300 CONTINUE
400 CONTINUE
RETURN
END
*****************************************************************************
SUBROUTINE VALTBL(IAT,IVAL)
*****************************************************************************
VALENCE TABLE:
Determine the number of sets of valence orbitals of each angular
symmetry for atom number IAT. IVAL is an integer array LMAX+1
long which returns the number of sets to the calling subroutine:
the number of `s' subshells in IVAL(1), the number of `p' subshells
in IVAL(2), etc...
------------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (LMAX = 3)
DIMENSION IVAL(4),ICORE(4),IORD(20)
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
+ JCORE,JPRINT(60)
DATA IORD/1,1,3,1,3,1,5,3,1,5,3,1,7,5,3,1,7,5,3,1/
DO 10 L = 0,LMAX
IVAL(L+1) = 0
10 CONTINUE
Count the number of filled or partially filled subshells:
II = IATNO(IAT)
IF(II.GT.0) THEN
ICT = 0
20 ICT = ICT + 1
L = IORD(ICT)/2
IVAL(L+1) = IVAL(L+1) + 1
II = II - 2*IORD(ICT)
IF(II.GT.0) GOTO 20
END IF
Remove the core subshells. Note: if there are more core orbitals
in the effective core potential than in the nominal core table or
from the CORE option, remove these extra core orbitals from the
set of valence orbitals:
IECP = 1
CALL CORTBL(IAT,ICORE,IECP)
DO 50 L = 0,LMAX
IVAL(L+1) = IVAL(L+1) - ICORE(L+1)
50 CONTINUE
IECP = 0
CALL CORTBL(IAT,ICORE,IECP)
DO 60 L = 0,LMAX
IF(ICORE(L+1).LT.0) THEN
IVAL(L+1) = IVAL(L+1) + ICORE(L+1)
END IF
60 CONTINUE
RETURN
END
*****************************************************************************
FUNCTION VECLEN(X,N,NDIM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION X(NDIM)
DATA ZERO/0.0D0/
SUM = ZERO
DO 10 I = 1,N
SUM = SUM + X(I)*X(I)
10 CONTINUE
VECLEN = SQRT(SUM)
RETURN
END
*****************************************************************************
SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR,
+ IERR)
*****************************************************************************
Solve the system of linear equations A * X = B for matrix X
~ ~ ~ ~
Input
-------
* Coefficient matrix A of dimension (N,N) with actual
dimension (NDIM,NDIM).
* Matrix B of dimension (N,M) with actual dimension
(NDIM,MDIM)
* Working space SCR dimensioned (NDIM,NDIM+5).
* Zero tolerance ZERTOL.
* Threshold on Euclidean norm (vector length) of the
error vector relative to the norm of a column of X.
* Maximum number of iterations MAXIT allowed during
iterative improvement.
* Logical file number LFNPR for printing during iterative
improvement. Set to zero to no printing is desired.
Output
--------
* Solution X of dimension (N,M) with actual dimension
(NDIM,MDIM).
* Euclidean norm of the final error vector, EPS.
* Number of iterations taken during interative improvement,
MAXIT.
* Error flag : IERR = -1 Iterative improvement did not
converge
IERR = 0 No errors encountered
IERR = 1 A matrix is not invertible
------------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(NDIM,NDIM),X(NDIM,MDIM),B(NDIM,MDIM),
+ SCR(NDIM*(NDIM+5))
DATA ZERO/0.0/
IF(N.LT.1) STOP 'Dimension N is not positive'
Partition scratch space:
I1 = 1
I2 = I1 + NDIM*NDIM
I3 = I2 + NDIM
I4 = I3 + NDIM
I5 = I4 + NDIM
I6 = I5 + NDIM
Perform Gauss elimination with scaled partial pivoting:
CALL FACTOR(A,SCR(I1),SCR(I2),SCR(I6),N,NDIM,ZERTOL,IFLAG)
IF(IFLAG.EQ.0) THEN
IERR = 1
RETURN
ELSE
IERR = 0
END IF
Loop over columns of X and B:
EPSMAX = ZERO
ITSMAX = 0
DO 30 KCOL = 1,M
DO 10 JROW = 1,N
SCR(I4+JROW-1) = X(JROW,KCOL)
SCR(I5+JROW-1) = B(JROW,KCOL)
10 CONTINUE
ITS = MAXIT
DEL = EPS
Use back-substitution and iterative improvement to determine
the solution X:
CALL FNDSOL(A,SCR(I4),SCR(I5),SCR(I1),SCR(I2),SCR(I3),SCR(I6),
+ N,NDIM,DEL,ITS,LFNPR,IERR)
IF(IERR.NE.0) RETURN
Copy solution into X:
DO 20 JROW = 1,N
X(JROW,KCOL) = SCR(I4+JROW-1)
20 CONTINUE
IF(DEL.GT.EPSMAX) EPSMAX = DEL
IF(ITS.GT.ITSMAX) ITSMAX = ITS
30 CONTINUE
EPS = EPSMAX
MAXIT = ITSMAX
RETURN
END
*****************************************************************************
SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(NDIM,NDIM),W(NDIM,NDIM),D(NDIM),IPIVOT(NDIM)
DATA ZERO,ONE/0.0D0,1.0D0/
Initial IFLAG. If IFLAG is 1, then an even number of interchanges
has been carried out. If equal to -1, then an odd number of inter-
changes have taken place. If IFLAG is set to zero on return to the
calling routine, then the matrix is not invertible:
IFLAG = 1
Copy coefficient matrix A to W:
CALL COPY(A,W,NDIM,N,N)
Initialize D and IPIVOT:
DO 20 I = 1,N
IPIVOT(I) = I
ROWMAX = ZERO
DO 10 J = 1,N
IF(ABS(W(I,J)).GT.ROWMAX) ROWMAX = ABS(W(I,J))
10 CONTINUE
IF(ROWMAX.LE.ZERTOL) THEN
IFLAG = 0
ROWMAX = ONE
END IF
D(I) = ROWMAX
20 CONTINUE
IF(N.EQ.1) RETURN
Loop over rows, factorizing matrix W:
DO 100 K = 1,N-1
Determine the pivot row ISTAR:
COLMAX = ABS(W(K,K))/D(K)
ISTAR = K
DO 30 I = K+1,N
TEMP = ABS(W(I,K))/D(K)
IF(TEMP.GT.COLMAX) THEN
COLMAX = TEMP
ISTAR = I
END IF
30 CONTINUE
IF(COLMAX.EQ.ZERO) THEN
IFLAG = 0
ELSE
IF(ISTAR.GT.K) THEN
IFLAG = -IFLAG
ITEMP = IPIVOT(ISTAR)
IPIVOT(ISTAR) = IPIVOT(K)
IPIVOT(K) = ITEMP
TEMP = D(ISTAR)
D(ISTAR) = D(K)
D(K) = TEMP
DO 40 J = 1,N
TEMP = W(ISTAR,J)
W(ISTAR,J) = W(K,J)
W(K,J) = TEMP
40 CONTINUE
END IF
Eliminate X(K) from rows K+1,...,N:
DO 60 I = K+1,N
W(I,K) = W(I,K)/W(K,K)
DO 50 J = K+1,N
W(I,J) = W(I,J) - W(I,K)*W(K,J)
50 CONTINUE
60 CONTINUE
END IF
100 CONTINUE
IF(ABS(W(N,N)).LE.ZERTOL) IFLAG = 0
RETURN
END
*****************************************************************************
SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(NDIM,NDIM),X(NDIM),B(NDIM),W(NDIM,NDIM),R(NDIM),
+ E(NDIM),IPIVOT(NDIM)
DATA ZERO/0.0D0/
Find initial guess for X by back substitution:
CALL COPY(B,E,NDIM,N,1)
CALL SUBST(X,W,E,IPIVOT,N,NDIM)
IF(MAXIT.EQ.0) RETURN
Iterate until the vector length of the error vector relative to
X is less than EPS:
RELLEN = ZERO
ITER = 0
10 IF(RELLEN.GT.EPS) THEN
ITER = ITER + 1
DO 30 I = 1,N
R(I) = B(I)
DO 20 J = 1,N
R(I) = R(I) - A(I,J)*X(J)
20 CONTINUE
30 CONTINUE
CALL SUBST(E,W,R,IPIVOT,N,NDIM)
ELEN = VECLEN(E,N,NDIM)
XLEN = VECLEN(X,N,NDIM)
RELLEN = ELEN/XLEN
DO 40 I = 1,N
X(I) = X(I) + E(I)
40 CONTINUE
Print out iterative improvement info:
IF(LFNPR.GT.0) THEN
WRITE(LFNPR,900) ITER,RELLEN
END IF
If too many iterations have taken place, halt furthur iterations:
IF(ITER.EQ.MAXIT) THEN
IF(RELLEN.GT.EPS) IERR = -1
IF(LFNPR.GT.0) THEN
IF(IERR.LT.0) THEN
WRITE(LFNPR,910)
ELSE
WRITE(LFNPR,920)
END IF
END IF
EPS = RELLEN
RETURN
END IF
Error vector is converged:
ELSE
IF(LFNPR.GT.0) WRITE(LFNPR,920)
EPS = RELLEN
MAXIT = ITER
RETURN
END IF
GOTO 10
900 FORMAT(1X,'Iter = ',I3,' relative length = ',F10.7)
910 FORMAT(1X,'No convergence within the specified number of ',
+ 'iterations')
920 FORMAT(1X,'The error vector is converged')
END
*****************************************************************************
SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM)
*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION X(NDIM),W(NDIM,NDIM),B(NDIM),IPIVOT(NDIM)
DATA ZERO/0.0D0/
IF(N.EQ.1) THEN
X(1) = B(1)/W(1,1)
RETURN
END IF
Use multipliers stored in W and back substitution to find X:
IP = IPIVOT(1)
X(1) = B(IP)
DO 20 I = 2,N
SUM = ZERO
DO 10 J = 1,I-1
SUM = W(I,J)*X(J) + SUM
10 CONTINUE
IP = IPIVOT(I)
X(I) = B(IP) - SUM
20 CONTINUE
X(N) = X(N)/W(N,N)
DO 40 I = N-1,1,-1
SUM = ZERO
DO 30 J = I+1,N
SUM = W(I,J)*X(J) + SUM
30 CONTINUE
X(I) = (X(I) - SUM)/W(I,I)
40 CONTINUE
RETURN
END
*****************************************************************************
E N D O F N B O P R O G R A M
*****************************************************************************
***********************************************************************GENDRV
GENDRV
GENDRV
G E N N B O GENDRV
GENDRV
GENDRV
GENERAL VERSION OF NBO PROGRAM GENDRV
GENDRV
GENDRV
DRIVER ROUTINES: GENDRV
GENDRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GENDRV
SUBROUTINE CRDINP(TITLE,ATCOOR,BOHR) GENDRV
SUBROUTINE BASINP GENDRV
SUBROUTINE CONINP(CORE,ICORE) GENDRV
SUBROUTINE SINP(CORE,UPPER) GENDRV
SUBROUTINE DMINP(CORE,UPPER) GENDRV
SUBROUTINE FINP(CORE,UPPER,END) GENDRV
SUBROUTINE TINP(CORE) GENDRV
SUBROUTINE DIPINP(CORE,UPPER,BOHR) GENDRV
GENDRV
***********************************************************************GENDRV
PROGRAM GENNBO GENDRV
***********************************************************************GENDRV
IMPLICIT REAL*8 (A-H,O-Z) GENDRV
GENDRV
PARAMETER(MEMORY = 1000000) GENDRV
DIMENSION CORE(MEMORY),NBOOPT(10) GENDRV
GENDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
+ LFNDAF,LFNDEF GENDRV
GENDRV
LFNIN = 5 GENDRV
LFNPR = 6 GENDRV
GENDRV
Set NBO options. GENDRV
GENDRV
NBOOPT(1) = 0 GENDRV
NBOOPT(2) = 0 GENDRV
NBOOPT(3) = 0 GENDRV
NBOOPT(4) = 0 GENDRV
NBOOPT(5) = 0 GENDRV
NBOOPT(6) = 0 GENDRV
NBOOPT(7) = 0 GENDRV
NBOOPT(8) = 0 GENDRV
NBOOPT(9) = 0 GENDRV
NBOOPT(10) = 0 GENDRV
GENDRV
Perform the NPA/NBO/NLMO analyses. GENDRV
GENDRV
CALL NBO(CORE,MEMORY,NBOOPT) GENDRV
GENDRV
CALL EXIT GENDRV
END GENDRV
***********************************************************************GENDRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GENDRV
***********************************************************************GENDRV
IMPLICIT REAL*8 (A-H,O-Z) GENDRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) GENDRV
LOGICAL END GENDRV
GENDRV
PARAMETER(MAXATM = 99,MAXBAS = 500) GENDRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, GENDRV
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, GENDRV
+ JCORE,JPRINT(60) GENDRV
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) GENDRV
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), GENDRV
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) GENDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
+ LFNDAF,LFNDEF GENDRV
COMMON/NBGEN/REUSE,UPPER,BOHR,DENOP GENDRV
LOGICAL REUSE,UPPER,BOHR,DENOP GENDRV
GENDRV
IF(REUSE) THEN GENDRV
GENDRV
Restore wavefunction information from the NBO DAF: GENDRV
GENDRV
Restore NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: GENDRV
GENDRV
NFILE = 3 GENDRV
CALL NBREAD(ICORE,12,NFILE) GENDRV
II = 0 GENDRV
II = II + 1 GENDRV
NATOMS = ICORE(II) GENDRV
II = II + 1 GENDRV
NDIM = ICORE(II) GENDRV
II = II + 1 GENDRV
NBAS = ICORE(II) GENDRV
II = II + 1 GENDRV
MUNIT = ICORE(II) GENDRV
II = II + 1 GENDRV
ROHF = .FALSE. GENDRV
IF(ICORE(II).EQ.1) ROHF = .TRUE. GENDRV
II = II + 1 GENDRV
UHF = .FALSE. GENDRV
IF(ICORE(II).EQ.1) UHF = .TRUE. GENDRV
II = II + 1 GENDRV
CI = .FALSE. GENDRV
IF(ICORE(II).EQ.1) CI = .TRUE. GENDRV
II = II + 1 GENDRV
OPEN = .FALSE. GENDRV
IF(ICORE(II).EQ.1) OPEN = .TRUE. GENDRV
II = II + 1 GENDRV
MCSCF = .FALSE. GENDRV
IF(ICORE(II).EQ.1) MCSCF = .TRUE. GENDRV
II = II + 1 GENDRV
AUHF = .FALSE. GENDRV
IF(ICORE(II).EQ.1) AUHF = .TRUE. GENDRV
II = II + 1 GENDRV
ORTHO = .FALSE. GENDRV
IF(ICORE(II).EQ.1) ORTHO = .TRUE. GENDRV
II = II + 1 GENDRV
ISWEAN = ICORE(II) GENDRV
GENDRV
No Fock matrix from ROHF, MCSCF, or CI wave functions: GENDRV
GENDRV
IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 GENDRV
GENDRV
Restore IATNO, IZNUC, LCTR, LANG: GENDRV
GENDRV
NFILE = 4 GENDRV
CALL NBREAD(ICORE,2*NATOMS+2*NBAS,NFILE) GENDRV
II = 0 GENDRV
DO 70 I = 1,NATOMS GENDRV
II = II + 1 GENDRV
IATNO(I) = ICORE(II) GENDRV
70 CONTINUE GENDRV
DO 80 I = 1,NATOMS GENDRV
II = II + 1 GENDRV
IZNUC(I) = ICORE(II) GENDRV
IF(IZNUC(I).NE.IATNO(I)) IPSEUD = 1 GENDRV
80 CONTINUE GENDRV
DO 90 I = 1,NBAS GENDRV
II = II + 1 GENDRV
LCTR(I) = ICORE(II) GENDRV
90 CONTINUE GENDRV
DO 95 I = 1,NBAS GENDRV
II = II + 1 GENDRV
LANG(I) = ICORE(II) GENDRV
95 CONTINUE GENDRV
ELSE GENDRV
GENDRV
Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: GENDRV
GENDRV
II = 0 GENDRV
II = II + 1 GENDRV
ICORE(II) = NATOMS GENDRV
II = II + 1 GENDRV
ICORE(II) = NDIM GENDRV
II = II + 1 GENDRV
ICORE(II) = NBAS GENDRV
II = II + 1 GENDRV
ICORE(II) = MUNIT GENDRV
II = II + 1 GENDRV
ICORE(II) = 0 GENDRV
IF(ROHF) ICORE(II) = 1 GENDRV
II = II + 1 GENDRV
ICORE(II) = 0 GENDRV
IF(UHF) ICORE(II) = 1 GENDRV
II = II + 1 GENDRV
ICORE(II) = 0 GENDRV
IF(CI) ICORE(II) = 1 GENDRV
II = II + 1 GENDRV
ICORE(II) = 0 GENDRV
IF(OPEN) ICORE(II) = 1 GENDRV
II = II + 1 GENDRV
ICORE(II) = 0 GENDRV
IF(MCSCF) ICORE(II) = 1 GENDRV
II = II + 1 GENDRV
ICORE(II) = 0 GENDRV
IF(AUHF) ICORE(II) = 1 GENDRV
II = II + 1 GENDRV
ICORE(II) = 0 GENDRV
IF(ORTHO) ICORE(II) = 1 GENDRV
II = II + 1 GENDRV
ICORE(II) = 1 GENDRV
NFILE = 3 GENDRV
CALL NBWRIT(ICORE,12,NFILE) GENDRV
GENDRV
Read wavefunction info, density matrix, etc. from LFNIN: GENDRV
GENDRV
Read in job title, atoms, nuclear charges, and coords: GENDRV
GENDRV
CALL CRDINP(CORE,CORE,BOHR) GENDRV
GENDRV
Read in the AO basis set: GENDRV
GENDRV
CALL CONINP(CORE,CORE) GENDRV
GENDRV
Read basis function labels and centers: GENDRV
GENDRV
CALL BASINP GENDRV
GENDRV
Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: GENDRV
GENDRV
II = 0 GENDRV
DO 170 I = 1,NATOMS GENDRV
II = II + 1 GENDRV
ICORE(II) = IATNO(I) GENDRV
170 CONTINUE GENDRV
DO 180 I = 1,NATOMS GENDRV
II = II + 1 GENDRV
ICORE(II) = IZNUC(I) GENDRV
180 CONTINUE GENDRV
DO 190 I = 1,NBAS GENDRV
II = II + 1 GENDRV
ICORE(II) = LCTR(I) GENDRV
190 CONTINUE GENDRV
DO 200 I = 1,NBAS GENDRV
II = II + 1 GENDRV
ICORE(II) = LANG(I) GENDRV
200 CONTINUE GENDRV
NFILE = 4 GENDRV
CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) GENDRV
GENDRV
Read the overlap matrix from LFNIN and store on the NBO DAF: GENDRV
GENDRV
IF(.NOT.ORTHO) CALL SINP(CORE,UPPER) GENDRV
GENDRV
Read the density matrix from LFNIN and store on the NBO DAF: GENDRV
GENDRV
CALL DMINP(CORE,UPPER) GENDRV
IF(DENOP) IWDM = 0 GENDRV
GENDRV
Read the Fock matrix from LFNIN and store on the NBO DAF: GENDRV
GENDRV
CALL FINP(CORE,UPPER,END) GENDRV
IF(END) THEN GENDRV
IWFOCK = 0 GENDRV
IF(OPEN) ROHF = .TRUE. GENDRV
ELSE GENDRV
IWFOCK = 1 GENDRV
IF(OPEN) UHF = .TRUE. GENDRV
END IF GENDRV
GENDRV
Read the AO to MO transformation matrix from LFNIN and store on the GENDRV
NBO DAF: GENDRV
GENDRV
CALL TINP(CORE) GENDRV
GENDRV
Read the dipole integrals from LFNIN and store on the NBO DAF: GENDRV
GENDRV
CALL DIPINP(CORE,UPPER,BOHR) GENDRV
END IF GENDRV
RETURN GENDRV
END GENDRV
***********************************************************************GENDRV
SUBROUTINE CRDINP(TITLE,ATCOOR,BOHR) GENDRV
***********************************************************************GENDRV
IMPLICIT REAL*8 (A-H,O-Z) GENDRV
DIMENSION KEYWD(6),KCOORD(6) GENDRV
LOGICAL ERROR,END,BOHR,EQUAL GENDRV
GENDRV
PARAMETER(MAXATM = 99,MAXBAS = 500) GENDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, GENDRV
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, GENDRV
+ JCORE,JPRINT(60) GENDRV
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), GENDRV
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) GENDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
+ LFNDAF,LFNDEF GENDRV
GENDRV
DIMENSION TITLE(10),ATCOOR(3*NATOMS) GENDRV
GENDRV
DATA KCOORD/1H$,1HC,1HO,1HO,1HR,1HD/ GENDRV
DATA TOANG/0.529177249/ GENDRV
GENDRV
Search LFNIN for $COORD datalist: GENDRV
GENDRV
REWIND(LFNIN) GENDRV
10 CALL STRTIN(LFNIN) GENDRV
LEN = 6 GENDRV
CALL HFLD(KEYWD,LEN,END) GENDRV
IF(LEN.EQ.0.AND.END) STOP 'No $COORD datalist in the input file' GENDRV
IF(.NOT.EQUAL(KEYWD,KCOORD,6)) GOTO 10 GENDRV
GENDRV
Read job title and store on NBO DAF: GENDRV
GENDRV
READ(LFNIN,1000) (TITLE(I),I=1,10) GENDRV
NFILE = 2 GENDRV
CALL NBWRIT(TITLE,10,NFILE) GENDRV
GENDRV
Loop over atoms, reading atomic number, nuclear charge, and coords: GENDRV
GENDRV
II = 0 GENDRV
CALL STRTIN(LFNIN) GENDRV
DO 100 IAT = 1,NATOMS GENDRV
CALL IFLD(IATNO(IAT),ERROR) GENDRV
IF(ERROR) STOP 'Error reading atomic number' GENDRV
CALL IFLD(IZNUC(IAT),ERROR) GENDRV
IF(ERROR) STOP 'Error reading nuclear charge' GENDRV
IF(IATNO(IAT).NE.IZNUC(IAT)) IPSEUD = 1 GENDRV
II = II + 1 GENDRV
CALL RFLD(ATCOOR(II),ERROR) GENDRV
IF(ERROR) STOP 'Error reading x coordinate' GENDRV
II = II + 1 GENDRV
CALL RFLD(ATCOOR(II),ERROR) GENDRV
IF(ERROR) STOP 'Error reading y coordinate' GENDRV
II = II + 1 GENDRV
CALL RFLD(ATCOOR(II),ERROR) GENDRV
IF(ERROR) STOP 'Error reading z coordinate' GENDRV
100 CONTINUE GENDRV
GENDRV
Convert atomic coords to angstroms if entered in bohr: GENDRV
GENDRV
IF(BOHR) THEN GENDRV
DO 200 I = 1,3*NATOMS GENDRV
ATCOOR(I) = ATCOOR(I) * TOANG GENDRV
200 CONTINUE GENDRV
END IF GENDRV
GENDRV
Store the atomic coordinates on the NBO DAF: GENDRV
GENDRV
NFILE = 9 GENDRV
CALL NBWRIT(ATCOOR,3*NATOMS,NFILE) GENDRV
RETURN GENDRV
GENDRV
1000 FORMAT(10A8) GENDRV
END GENDRV
***********************************************************************GENDRV
SUBROUTINE BASINP GENDRV
***********************************************************************GENDRV
IMPLICIT REAL*8 (A-H,O-Z) GENDRV
DIMENSION KEYWD(6),KBASIS(6),KCTR(6),KLABEL(5),KEND(4) GENDRV
LOGICAL ERROR,END,EQUAL GENDRV
GENDRV
PARAMETER(MAXATM = 99,MAXBAS = 500) GENDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) GENDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
+ LFNDAF,LFNDEF GENDRV
GENDRV
DATA KBASIS/1H$,1HB,1HA,1HS,1HI,1HS/,KLABEL/1HL,1HA,1HB,1HE,1HL/, GENDRV
+ KCTR/1HC,1HE,1HN,1HT,1HE,1HR/,KEND/1H$,1HE,1HN,1HD/ GENDRV
GENDRV
Search LFNIN for $BASIS datalist: GENDRV
GENDRV
REWIND(LFNIN) GENDRV
10 CALL STRTIN(LFNIN) GENDRV
LEN = 6 GENDRV
CALL HFLD(KEYWD,LEN,END) GENDRV
IF(LEN.EQ.0.AND.END) STOP 'No $BASIS datalist in the input file' GENDRV
IF(.NOT.EQUAL(KEYWD,KBASIS,6)) GOTO 10 GENDRV
GENDRV
Read in BOTH LCTR and LANG arrays: GENDRV
GENDRV
MCTR = 0 GENDRV
MANG = 0 GENDRV
20 LEN = 6 GENDRV
CALL HFLD(KEYWD,LEN,END) GENDRV
IF(END) STOP 'End encountered while reading $BASIS datalist' GENDRV
IF(EQUAL(KEYWD,KEND,4)) GOTO 100 GENDRV
GENDRV
Keyword CENTER -- basis function centers: GENDRV
GENDRV
IF(EQUAL(KEYWD,KCTR,6)) THEN GENDRV
DO 30 I = 1,NBAS GENDRV
CALL IFLD(LCTR(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading orbital centers in $BASIS' GENDRV
30 CONTINUE GENDRV
MCTR = 1 GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
Keyword LABEL -- basis orbital symmetries: GENDRV
GENDRV
IF(EQUAL(KEYWD,KLABEL,5)) THEN GENDRV
DO 40 I = 1,NBAS GENDRV
CALL IFLD(LANG(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading orbital labels in $BASIS' GENDRV
40 CONTINUE GENDRV
MANG = 1 GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
Unknown keyword -- halt program: GENDRV
GENDRV
WRITE(LFNPR,900) KEYWD GENDRV
STOP GENDRV
GENDRV
Make sure that both the orbital centers and symmetries are read: GENDRV
GENDRV
100 CONTINUE GENDRV
IF(MCTR.EQ.0) STOP 'Missing orbital centers in $BASIS datalist' GENDRV
IF(MANG.EQ.0) STOP 'Missing orbital labels in $BASIS datalist' GENDRV
RETURN GENDRV
GENDRV
900 FORMAT(1X,'Unrecognized keyword >',6A1,'<') GENDRV
END GENDRV
***********************************************************************GENDRV
SUBROUTINE CONINP(CORE,ICORE) GENDRV
***********************************************************************GENDRV
IMPLICIT REAL*8 (A-H,O-Z) GENDRV
LOGICAL ERROR,END,EQUAL GENDRV
GENDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
+ LFNDAF,LFNDEF GENDRV
GENDRV
DIMENSION CORE(1),ICORE(1) GENDRV
DIMENSION KEYWD(6),KCONTR(6),KNSHLL(6),KNEXP(4),KNCOMP(5), GENDRV
+ KNPRIM(5),KNPTR(4),KEXP(3),KCS(2),KCP(2),KCD(2),KCF(2),KEND(4) GENDRV
GENDRV
DATA KCONTR/1H$,1HC,1HO,1HN,1HT,1HR/,KNEXP/1HN,1HE,1HX,1HP/, GENDRV
+ KNSHLL/1HN,1HS,1HH,1HE,1HL,1HL/,KNCOMP/1HN,1HC,1HO,1HM,1HP/, GENDRV
+ KNPRIM/1HN,1HP,1HR,1HI,1HM/,KEXP/1HE,1HX,1HP/,KCS/1HC,1HS/, GENDRV
+ KCP/1HC,1HP/,KCD/1HC,1HD/,KCF/1HC,1HF/,KEND/1H$,1HE,1HN,1HD/,GENDRV
+ KNPTR/1HN,1HP,1HT,1HR/ GENDRV
DATA ZERO/0.0D0/ GENDRV
GENDRV
Search LFNIN for the $CONTRACT datalist: GENDRV
GENDRV
REWIND(LFNIN) GENDRV
10 CALL STRTIN(LFNIN) GENDRV
LEN = 6 GENDRV
CALL HFLD(KEYWD,LEN,END) GENDRV
IF(LEN.EQ.0.AND.END) RETURN GENDRV
IF(.NOT.EQUAL(KEYWD,KCONTR,6)) GOTO 10 GENDRV
GENDRV
MSHELL = 0 GENDRV
MEXP = 0 GENDRV
MCOMP = 0 GENDRV
MPRIM = 0 GENDRV
MPTR = 0 GENDRV
MEXP = 0 GENDRV
20 LEN = 6 GENDRV
CALL HFLD(KEYWD,LEN,END) GENDRV
IF(END) STOP 'End encountered while reading $CONTRACT datalist' GENDRV
GENDRV
Keyword NSHELL -- number of shells of basis functions: GENDRV
GENDRV
IF(EQUAL(KEYWD,KNSHLL,6)) THEN GENDRV
CALL IFLD(NSHELL,ERROR) GENDRV
IF(ERROR) STOP 'Error reading number of shells in $CONTRACT' GENDRV
MSHELL = 1 GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
Keyword NEXP -- number of orbital exponents in basis: GENDRV
GENDRV
IF(EQUAL(KEYWD,KNEXP,4)) THEN GENDRV
CALL IFLD(NEXP,ERROR) GENDRV
IF(ERROR) STOP 'Error reading number of exponents in $CONTRACT' GENDRV
MEXP = 1 GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
If NSHELL and NEXP are not specified before the remainder of the GENDRV
datalist, abort: GENDRV
GENDRV
IF(MSHELL.EQ.0.OR.MEXP.EQ.0) THEN GENDRV
WRITE(LFNPR,900) GENDRV
STOP GENDRV
END IF GENDRV
GENDRV
If NSHELL and NEXP have been specified, partition the scratch vector:GENDRV
GENDRV
ICORE(I1) : NCOMP(1..NSHELL) GENDRV
ICORE(I2) : NPRIM(1..NSHELL) GENDRV
ICORE(I3) : NPTR(1..NSHELL) GENDRV
CORE(I4) : EXP(1..NEXP) GENDRV
CORE(I5) : CS(1..NEXP) GENDRV
CORE(I6) : CP(1..NEXP) GENDRV
CORE(I7) : CD(1..NEXP) GENDRV
CORE(I8) : CF(1..NEXP) GENDRV
GENDRV
IF(MSHELL.EQ.1.AND.MEXP.EQ.1) THEN GENDRV
I1 = 3 GENDRV
I2 = I1 + NSHELL GENDRV
I3 = I2 + NSHELL GENDRV
I4 = I3 + NSHELL GENDRV
I5 = I4 + NEXP GENDRV
I6 = I5 + NEXP GENDRV
I7 = I6 + NEXP GENDRV
I8 = I7 + NEXP GENDRV
IEND = I8 + NEXP GENDRV
DO 30 I = 1,IEND-1 GENDRV
CORE(I) = ZERO GENDRV
30 CONTINUE GENDRV
II = 0 GENDRV
II = II + 1 GENDRV
ICORE(II) = NSHELL GENDRV
II = II + 1 GENDRV
ICORE(II) = NEXP GENDRV
MSHELL = 2 GENDRV
MEXP = 2 GENDRV
END IF GENDRV
GENDRV
Keyword NCOMP -- number of components in each shell: GENDRV
GENDRV
IF(EQUAL(KEYWD,KNCOMP,5)) THEN GENDRV
DO 40 I = I1,I1+NSHELL-1 GENDRV
CALL IFLD(ICORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading components in $CONTRACT' GENDRV
40 CONTINUE GENDRV
MCOMP = 1 GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
Keyword NPRIM -- number of primitives in each shell: GENDRV
GENDRV
IF(EQUAL(KEYWD,KNPRIM,5)) THEN GENDRV
DO 50 I = I2,I2+NSHELL-1 GENDRV
CALL IFLD(ICORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading primitives in $CONTRACT' GENDRV
50 CONTINUE GENDRV
MPRIM = 1 GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
Keyword NPTR -- pointer array into exponents and coefficients: GENDRV
GENDRV
IF(EQUAL(KEYWD,KNPTR,4)) THEN GENDRV
DO 60 I = I3,I3+NSHELL-1 GENDRV
CALL IFLD(ICORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading pointers in $CONTRACT' GENDRV
60 CONTINUE GENDRV
MPTR = 1 GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
Keyword EXP -- orbital exponents: GENDRV
GENDRV
IF(EQUAL(KEYWD,KEXP,3)) THEN GENDRV
DO 70 I = I4,I4+NEXP-1 GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading exponents in $CONTRACT' GENDRV
70 CONTINUE GENDRV
MEXP = 1 GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
Keyword CS -- s orbital coefficients: GENDRV
GENDRV
IF(EQUAL(KEYWD,KCS,2)) THEN GENDRV
DO 80 I = I5,I5+NEXP-1 GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading s coefficients in $CONTRACT' GENDRV
80 CONTINUE GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
Keyword CP -- p orbital coefficients: GENDRV
GENDRV
IF(EQUAL(KEYWD,KCP,2)) THEN GENDRV
DO 90 I = I6,I6+NEXP-1 GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading p coefficients in $CONTRACT' GENDRV
90 CONTINUE GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
Keyword CD -- d orbital coefficients: GENDRV
GENDRV
IF(EQUAL(KEYWD,KCD,2)) THEN GENDRV
DO 100 I = I7,I7+NEXP-1 GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading d coefficients in $CONTRACT' GENDRV
100 CONTINUE GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
Keyword CF -- f orbital coefficients: GENDRV
GENDRV
IF(EQUAL(KEYWD,KCF,2)) THEN GENDRV
DO 110 I = I8,I8+NEXP-1 GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading f coefficients in $CONTRACT' GENDRV
110 CONTINUE GENDRV
GOTO 20 GENDRV
END IF GENDRV
GENDRV
$END -- $CONTRACT datalist complete: GENDRV
GENDRV
IF(EQUAL(KEYWD,KEND,4)) THEN GENDRV
IF(MCOMP.EQ.0) STOP 'Missing NCOMP array in $CONTRACT' GENDRV
IF(MPRIM.EQ.0) STOP 'Missing NPRIM array in $CONTRACT' GENDRV
IF(MPTR.EQ.0) STOP 'Missing NPTR array in $CONTRACT' GENDRV
IF(MEXP.EQ.0) STOP 'Missing EXP array in $CONTRACT' GENDRV
GENDRV
Write info obtained in the datalist on the NBO DAF: GENDRV
GENDRV
LEN = IEND - 1 GENDRV
NFILE = 5 GENDRV
CALL NBWRIT(CORE,LEN,NFILE) GENDRV
RETURN GENDRV
END IF GENDRV
GENDRV
Unknown keyword -- halt program: GENDRV
GENDRV
WRITE(LFNPR,910) KEYWD GENDRV
STOP GENDRV
GENDRV
900 FORMAT(/1X,'NSHELL and NEXP should appear at the beginning of ', GENDRV
+ 'the $CONTRACT datalist') GENDRV
910 FORMAT(1X,'Unrecognized keyword >',6A1,'<') GENDRV
END GENDRV
***********************************************************************GENDRV
SUBROUTINE SINP(CORE,UPPER) GENDRV
***********************************************************************GENDRV
IMPLICIT REAL*8 (A-H,O-Z) GENDRV
DIMENSION CORE(1) GENDRV
DIMENSION KEYWD(6),KOVER(5) GENDRV
LOGICAL UPPER,ERROR,END,EQUAL GENDRV
GENDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
+ LFNDAF,LFNDEF GENDRV
GENDRV
DATA KOVER/1H$,1HO,1HV,1HE,1HR/ GENDRV
GENDRV
Search LFNIN for $OVERLAP datalist: GENDRV
GENDRV
REWIND(LFNIN) GENDRV
10 CALL STRTIN(LFNIN) GENDRV
LEN = 6 GENDRV
CALL HFLD(KEYWD,LEN,END) GENDRV
IF(LEN.EQ.0.AND.END) STOP 'No $OVERLAP found in the input file' GENDRV
IF(.NOT.EQUAL(KEYWD,KOVER,5)) GOTO 10 GENDRV
GENDRV
Number of elements to read in: GENDRV
GENDRV
NEL = NDIM*NDIM GENDRV
IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV
GENDRV
Read in the AO overlap matrix: GENDRV
GENDRV
DO 20 I = 1,NEL GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading AO overlap matrix' GENDRV
20 CONTINUE GENDRV
NEL = NDIM*(NDIM+1)/2 GENDRV
IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV
GENDRV
Store the overlap matrix on the NBO DAF: GENDRV
GENDRV
NFILE = 10 GENDRV
CALL NBWRIT(CORE,NEL,NFILE) GENDRV
RETURN GENDRV
END GENDRV
***********************************************************************GENDRV
SUBROUTINE DMINP(CORE,UPPER) GENDRV
***********************************************************************GENDRV
IMPLICIT REAL*8 (A-H,O-Z) GENDRV
DIMENSION CORE(1) GENDRV
DIMENSION KEYWD(6),KDENS(5) GENDRV
LOGICAL UPPER,ERROR,END,EQUAL GENDRV
GENDRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
+ LFNDAF,LFNDEF GENDRV
GENDRV
DATA KDENS/1H$,1HD,1HE,1HN,1HS/ GENDRV
GENDRV
Search LFNIN for $DENSITY datalist: GENDRV
GENDRV
REWIND(LFNIN) GENDRV
10 CALL STRTIN(LFNIN) GENDRV
LEN = 6 GENDRV
CALL HFLD(KEYWD,LEN,END) GENDRV
IF(LEN.EQ.0.AND.END) STOP 'No $DENSITY found in the input file' GENDRV
IF(.NOT.EQUAL(KEYWD,KDENS,5)) GOTO 10 GENDRV
GENDRV
Number of elements to read in: GENDRV
GENDRV
NEL = NDIM*NDIM GENDRV
IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV
GENDRV
Read in the AO density matrix: GENDRV
GENDRV
DO 20 I = 1,NEL GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading AO density matrix' GENDRV
20 CONTINUE GENDRV
NEL = NDIM*(NDIM+1)/2 GENDRV
IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV
GENDRV
Store the density matrix on the NBO DAF: GENDRV
GENDRV
NFILE = 20 GENDRV
CALL NBWRIT(CORE,NEL,NFILE) GENDRV
GENDRV
Read in and store the beta density matrix if this is open shell: GENDRV
GENDRV
IF(OPEN) THEN GENDRV
NEL = NDIM*NDIM GENDRV
IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV
DO 30 I = 1,NEL GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading beta AO density matrix' GENDRV
30 CONTINUE GENDRV
NEL = NDIM*(NDIM+1)/2 GENDRV
IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV
NFILE = 21 GENDRV
CALL NBWRIT(CORE,NEL,NFILE) GENDRV
END IF GENDRV
RETURN GENDRV
END GENDRV
***********************************************************************GENDRV
SUBROUTINE FINP(CORE,UPPER,END) GENDRV
***********************************************************************GENDRV
IMPLICIT REAL*8 (A-H,O-Z) GENDRV
DIMENSION CORE(1) GENDRV
DIMENSION KEYWD(6),KFOCK(5) GENDRV
LOGICAL UPPER,ERROR,END,EQUAL GENDRV
GENDRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
+ LFNDAF,LFNDEF GENDRV
GENDRV
DATA KFOCK/1H$,1HF,1HO,1HC,1HK/ GENDRV
GENDRV
Search LFNIN for $FOCK datalist: GENDRV
GENDRV
REWIND(LFNIN) GENDRV
10 CALL STRTIN(LFNIN) GENDRV
LEN = 6 GENDRV
CALL HFLD(KEYWD,LEN,END) GENDRV
IF(LEN.EQ.0.AND.END) RETURN GENDRV
IF(.NOT.EQUAL(KEYWD,KFOCK,5)) GOTO 10 GENDRV
GENDRV
Number of elements to read in: GENDRV
GENDRV
NEL = NDIM*NDIM GENDRV
IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV
GENDRV
Read in the AO Fock matrix: GENDRV
GENDRV
DO 20 I = 1,NEL GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading AO Fock matrix' GENDRV
20 CONTINUE GENDRV
NEL = NDIM*(NDIM+1)/2 GENDRV
IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV
GENDRV
Store the Fock matrix on the NBO DAF: GENDRV
GENDRV
NFILE = 30 GENDRV
CALL NBWRIT(CORE,NEL,NFILE) GENDRV
GENDRV
Read in and store the beta Fock matrix if this is open shell: GENDRV
GENDRV
IF(OPEN) THEN GENDRV
NEL = NDIM*NDIM GENDRV
IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV
DO 30 I = 1,NEL GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading beta AO Fock matrix' GENDRV
30 CONTINUE GENDRV
NEL = NDIM*(NDIM+1)/2 GENDRV
IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV
NFILE = 31 GENDRV
CALL NBWRIT(CORE,NEL,NFILE) GENDRV
END IF GENDRV
END = .FALSE. GENDRV
RETURN GENDRV
END GENDRV
***********************************************************************GENDRV
SUBROUTINE TINP(CORE) GENDRV
***********************************************************************GENDRV
IMPLICIT REAL*8 (A-H,O-Z) GENDRV
DIMENSION CORE(1) GENDRV
DIMENSION KEYWD(6),KAOMO(7) GENDRV
LOGICAL ERROR,END,EQUAL GENDRV
GENDRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
+ LFNDAF,LFNDEF GENDRV
GENDRV
DATA KAOMO/1H$,1HL,1HC,1HA,1HO,1HM,1HO/ GENDRV
GENDRV
Search LFNIN for $LCAOMO datalist: GENDRV
GENDRV
REWIND(LFNIN) GENDRV
10 CALL STRTIN(LFNIN) GENDRV
LEN = 6 GENDRV
CALL HFLD(KEYWD,LEN,END) GENDRV
IF(LEN.EQ.0.AND.END) RETURN GENDRV
IF(.NOT.EQUAL(KEYWD,KAOMO,6)) GOTO 10 GENDRV
GENDRV
Read in the AO to MO transformation matrix: GENDRV
GENDRV
NEL = NDIM*NDIM GENDRV
DO 20 I = 1,NEL GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading AO to MO transformation matrix' GENDRV
20 CONTINUE GENDRV
GENDRV
Store the transformation matrix on the NBO DAF: GENDRV
GENDRV
NFILE = 40 GENDRV
CALL NBWRIT(CORE,NEL,NFILE) GENDRV
GENDRV
Read in and store the beta transformation matrix if this is an open GENDRV
shell wavevfunction: GENDRV
GENDRV
IF(OPEN) THEN GENDRV
DO 30 I = 1,NEL GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading beta AO to MO trans. matrix' GENDRV
30 CONTINUE GENDRV
NFILE = 41 GENDRV
CALL NBWRIT(CORE,NEL,NFILE) GENDRV
END IF GENDRV
RETURN GENDRV
END GENDRV
***********************************************************************GENDRV
SUBROUTINE DIPINP(CORE,UPPER,BOHR) GENDRV
***********************************************************************GENDRV
IMPLICIT REAL*8 (A-H,O-Z) GENDRV
DIMENSION CORE(1) GENDRV
DIMENSION KEYWD(6),KDIPOL(6) GENDRV
LOGICAL UPPER,ERROR,END,EQUAL,BOHR GENDRV
GENDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
+ LFNDAF,LFNDEF GENDRV
GENDRV
DATA KDIPOL/1H$,1HD,1HI,1HP,1HO,1HL/ GENDRV
DATA TOANG/0.529177249/ GENDRV
GENDRV
Search LFNIN for $DIPOLE datalist: GENDRV
GENDRV
REWIND(LFNIN) GENDRV
10 CALL STRTIN(LFNIN) GENDRV
LEN = 6 GENDRV
CALL HFLD(KEYWD,LEN,END) GENDRV
IF(LEN.EQ.0.AND.END) RETURN GENDRV
IF(.NOT.EQUAL(KEYWD,KDIPOL,6)) GOTO 10 GENDRV
GENDRV
Number of elements to read in: GENDRV
GENDRV
NEL = NDIM*NDIM GENDRV
IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV
GENDRV
Read in the x dipole integral matrix: GENDRV
GENDRV
DO 20 I = 1,NEL GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading x dipole integral matrix' GENDRV
20 CONTINUE GENDRV
IF(.NOT.UPPER) THEN GENDRV
NEL = NDIM*(NDIM+1)/2 GENDRV
CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV
END IF GENDRV
GENDRV
Convert to angstroms, if necessary: GENDRV
GENDRV
IF(BOHR) THEN GENDRV
DO 30 I = 1,NEL GENDRV
CORE(I) = CORE(I) * TOANG GENDRV
30 CONTINUE GENDRV
END IF GENDRV
GENDRV
Store the dipole integral matrix on the NBO DAF: GENDRV
GENDRV
NFILE = 50 GENDRV
CALL NBWRIT(CORE,NEL,NFILE) GENDRV
GENDRV
Read in the y dipole integral matrix: GENDRV
GENDRV
DO 40 I = 1,NEL GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading y dipole integral matrix' GENDRV
40 CONTINUE GENDRV
IF(.NOT.UPPER) THEN GENDRV
NEL = NDIM*(NDIM+1)/2 GENDRV
CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV
END IF GENDRV
GENDRV
Convert to angstroms, if necessary: GENDRV
GENDRV
IF(BOHR) THEN GENDRV
DO 50 I = 1,NEL GENDRV
CORE(I) = CORE(I) * TOANG GENDRV
50 CONTINUE GENDRV
END IF GENDRV
GENDRV
NFILE = 51 GENDRV
CALL NBWRIT(CORE,NEL,NFILE) GENDRV
GENDRV
Read in the z dipole integral matrix: GENDRV
GENDRV
DO 60 I = 1,NEL GENDRV
CALL RFLD(CORE(I),ERROR) GENDRV
IF(ERROR) STOP 'Error reading z dipole integral matrix' GENDRV
60 CONTINUE GENDRV
IF(.NOT.UPPER) THEN GENDRV
NEL = NDIM*(NDIM+1)/2 GENDRV
CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV
END IF GENDRV
GENDRV
Convert to angstroms, if necessary: GENDRV
GENDRV
IF(BOHR) THEN GENDRV
DO 70 I = 1,NEL GENDRV
CORE(I) = CORE(I) * TOANG GENDRV
70 CONTINUE GENDRV
END IF GENDRV
GENDRV
NFILE = 52 GENDRV
CALL NBWRIT(CORE,NEL,NFILE) GENDRV
GENDRV
RETURN GENDRV
END GENDRV
***********************************************************************GENDRV
GENDRV
E N D O F G E N N B O R O U T I N E S GENDRV
GENDRV
***********************************************************************GENDRV
***********************************************************************G90DRV
G90DRV
G90DRV
G 9 0 N B O G90DRV
G90DRV
G90DRV
GAUSSIAN 90 VERSION OF NBO PROGRAM G90DRV
G90DRV
G90DRV
DRIVER ROUTINES: G90DRV
G90DRV
SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G90DRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G90DRV
SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G90DRV
G90DRV
***********************************************************************G90DRV
SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G90DRV
***********************************************************************G90DRV
IMPLICIT REAL*8 (A-H,O-Z) G90DRV
G90DRV
PARAMETER (MAXFIL = 40) G90DRV
G90DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G90DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G90DRV
+ LFNDAF,LFNDEF G90DRV
COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) G90DRV
CHARACTER*80 FILENM G90DRV
G90DRV
DIMENSION CORE(MEMORY),IOP(50) G90DRV
DIMENSION NBOOPT(10) G90DRV
G90DRV
DATA TENTH/0.1D0/ G90DRV
G90DRV
LFNIN = 5 G90DRV
LFNPR = 6 G90DRV
G90DRV
Set NBO options. G90DRV
G90DRV
DO 10 I = 1,9 G90DRV
NBOOPT(I) = IOP(I+39) G90DRV
10 CONTINUE G90DRV
NBOOPT(10) = 90 G90DRV
G90DRV
--- G90 patch --- G90DRV
G90DRV
IF(NBOOPT(1).EQ.0) THEN G90DRV
NBOOPT(1) = 1 G90DRV
ELSE IF(NBOOPT(1).EQ.1) THEN G90DRV
NBOOPT(1) = 0 G90DRV
END IF G90DRV
G90DRV
--- NBO analysis --- G90DRV
G90DRV
ICONTR = 0 G90DRV
IF(ABS(NBOOPT(1)).LT.2) THEN G90DRV
CALL CHARPN(4HNBO ) G90DRV
CALL NBO(CORE,MEMORY,NBOOPT) G90DRV
G90DRV
Store the name of the NBO direct access file on the RWFiles G90DRV
G90DRV
DO 20 I = 1,80 G90DRV
CORE(I) = ICHAR(FILENM(I:I)) G90DRV
20 CONTINUE G90DRV
CORE(81) = LFNDAF G90DRV
CALL TWRITE(636,CORE,81,1,81,1,0) G90DRV
G90DRV
--- NBO energetic analysis --- G90DRV
G90DRV
ELSE IF(NBOOPT(1).EQ.2) THEN G90DRV
G90DRV
Retrieve the name of the NBO direct access file from the RWFiles G90DRV
G90DRV
CALL TREAD(636,CORE,81,1,81,1,0) G90DRV
DO 30 I = 1,80 G90DRV
FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G90DRV
30 CONTINUE G90DRV
LFNDAF = INT(ABS(CORE(81)) + TENTH) G90DRV
CALL CHARPN(4HDELE) G90DRV
CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G90DRV
IF(IDONE.NE.0) ICONTR = 1 G90DRV
IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT) G90DRV
G90DRV
ELSE IF(NBOOPT(1).EQ.3) THEN G90DRV
CALL TREAD(636,CORE,81,1,81,1,0) G90DRV
DO 40 I = 1,80 G90DRV
FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G90DRV
40 CONTINUE G90DRV
LFNDAF = INT(ABS(CORE(81)) + TENTH) G90DRV
CALL CHARPN(4HEDEL) G90DRV
CALL DELSCF(CORE,CORE,NBOOPT) G90DRV
CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G90DRV
END IF G90DRV
G90DRV
RETURN G90DRV
END G90DRV
***********************************************************************G90DRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G90DRV
***********************************************************************G90DRV
IMPLICIT REAL*8 (A-H,O-Z) G90DRV
LOGICAL GOTDEN G90DRV
-----------------------------------------------------------------------G90DRV
G90DRV
Routine FEAOIN accesses the following records of the RWFs: G90DRV
G90DRV
501 --- Total energy G90DRV
502 --- Job title G90DRV
506 --- Basis set information G90DRV
512 --- Effective core potential information G90DRV
514 --- AO overlap matrix G90DRV
518 --- AO dipole integrals G90DRV
524 --- MO coefficients (alpha) G90DRV
526 --- MO coefficients (beta) G90DRV
536 --- AO Fock matrix (alpha) G90DRV
538 --- AO Fock matrix (beta) G90DRV
603 --- AO density matrix G90DRV
G90DRV
----------------------------------------------------------------------G90DRV
G90DRV
NBO Common blocks G90DRV
G90DRV
PARAMETER(MAXATM = 99,MAXBAS = 500) G90DRV
G90DRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G90DRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G90DRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G90DRV
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, G90DRV
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, G90DRV
+ JCORE,JPRINT(60) G90DRV
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) G90DRV
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G90DRV
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) G90DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G90DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G90DRV
+ LFNDAF,LFNDEF G90DRV
G90DRV
GAUSSIAN 90 Common blocks G90DRV
G90DRV
COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(401), G90DRV
* ATMCHG(400),C(1200) G90DRV
COMMON/LP2/NLP(1600),CLP(1600),ZLP(1600),KFIRST(400,5), G90DRV
* KLAST(400,5),LMAX(400),LPSKIP(400),NFroz(400) G90DRV
COMMON/B/EXX(6000),C1(6000),C2(6000),C3(6000),X(2000),Y(2000), G90DRV
* Z(2000),JAN(2000),SHELLA(2000),SHELLN(2000),SHELLT(2000), G90DRV
* SHELLC(2000),AOS(2000),AON(2000),NSHELL,MAXTYP G90DRV
INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON G90DRV
DIMENSION C4(2000),SHLADF(2000) G90DRV
EQUIVALENCE(C4(1),C3(2001)),(SHLADF(1),C3(4001)) G90DRV
G90DRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) G90DRV
DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G90DRV
G90DRV
Obtain the following information: G90DRV
G90DRV
ROHF =.TRUE. If RHF open shell wavefunction G90DRV
=.FALSE. otherwise G90DRV
G90DRV
UHF =.TRUE. If UHF wavefunction G90DRV
=.FALSE. otherwise G90DRV
G90DRV
AUHF =.TRUE. If spin-annihilated UHF wavefunction G90DRV
=.FALSE. otherwise G90DRV
G90DRV
CI =.TRUE. If CI wavefunction G90DRV
=.FALSE. otherwise G90DRV
G90DRV
OPEN =.TRUE. If open shell wavefunction G90DRV
=.FALSE. otherwise G90DRV
G90DRV
COMPLX =.TRUE. If complex wavefunction G90DRV
=.FALSE. otherwise G90DRV
(Note: The program is not capable of handling this.) G90DRV
G90DRV
NATOMS Number of atomic centers G90DRV
G90DRV
NDIM Dimension of matrices (overlap and density) G90DRV
G90DRV
NBAS Number of basis functions (.le.NDIM) G90DRV
G90DRV
IPSEUD Set to one if pseudopotentials are used. G90DRV
G90DRV
IWCUBF This pertains only basis sets with F functions. G90DRV
G90DRV
If cartesian F functions are input, set IWCUBF to: G90DRV
0, if these are to be transformed to the G90DRV
standard set of pure F functions G90DRV
1, if these are to be transformed to the G90DRV
cubic set of pure F functions G90DRV
G90DRV
If pure F functions are input, set to IWCUBF to: G90DRV
0, if these are standard F functions G90DRV
1, if these are cubic F functions G90DRV
G90DRV
IATNO(I),I=1,NATOMS G90DRV
List of atomic numbers G90DRV
G90DRV
LCTR(I),I=1,NBAS G90DRV
List of atomic centers of the basis functions G90DRV
(LCTR(3)=2 if basis function 3 is on atom 2) G90DRV
G90DRV
LANG(I),I=1,NBAS G90DRV
List of angular symmetry information for the AO basis G90DRV
G90DRV
DATA LISTS/ 1/ G90DRV
DATA LISTP/ 101, 102, 103/ G90DRV
DATA LISTD/ 255, 252, 253, 254, 251, 0, G90DRV
+ 201, 204, 206, 202, 203, 205/ G90DRV
DATA LISTF/ 351, 352, 353, 354, 355, 356, 357, 0, 0, 0, G90DRV
+ 301, 307, 310, 304, 302, 303, 306, 309, 308, 305/ G90DRV
DATA ZERO/0.0D0/ G90DRV
DATA TOANG/0.529177249/ G90DRV
G90DRV
Store job title on NBODAF: G90DRV
G90DRV
LEN = INTOWP(4000+100) G90DRV
CALL TREAD(502,ICORE,LEN,1,LEN,1,0) G90DRV
NFILE = 2 G90DRV
CALL NBWRIT(ICORE(4001),10,NFILE) G90DRV
G90DRV
Get the number of atoms from NAT and store the atomic numbers in G90DRV
IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G90DRV
nuclear charges may not be equivalent if effective core potentials G90DRV
(ECP) are used.) G90DRV
G90DRV
LEN = 0 G90DRV
IEXIST = ITQRY(512) G90DRV
IF(IEXIST.GT.0) THEN G90DRV
LEN = 8 * 400 + 17 * INTOWP(400) G90DRV
CALL TREAD(512,NLP,LEN,1,LEN,1,0) G90DRV
END IF G90DRV
NATOMS = NATOM G90DRV
DO 20 I = 1,NATOMS G90DRV
IATNO(I) = IAN(I) G90DRV
IF(IEXIST.GT.0) THEN G90DRV
IZNUC(I) = IATNO(I) - NFROZ(I) G90DRV
IF(NFROZ(I).NE.0) IPSEUD = 1 G90DRV
ELSE G90DRV
IZNUC(I) = IATNO(I) G90DRV
END IF G90DRV
20 CONTINUE G90DRV
G90DRV
Restore the basis set to COMMON/B/: G90DRV
G90DRV
LEN = 30000 + INTOWP(14002) G90DRV
CALL TREAD(506,EXX,LEN,1,LEN,1,0) G90DRV
G90DRV
The Gaussian programs do not use cubic f basis functions. G90DRV
Determine which set of d and f functions are being used, G90DRV
Cartesian or pure): G90DRV
G90DRV
IWCUBF = 0 G90DRV
CALL ILSW(2,2,I5D6D) G90DRV
CALL ILSW(2,16,I7F10F) G90DRV
G90DRV
Construct the AO information lists: LCTR and LANG G90DRV
G90DRV
IBAS = 0 G90DRV
DO 90 ISHELL = 1,2000 G90DRV
IF(IBAS.EQ.NBASIS) GOTO 100 G90DRV
NCTR = JAN(ISHELL) G90DRV
MAXL = SHELLT(ISHELL) G90DRV
ICNSTR = SHELLC(ISHELL) G90DRV
G90DRV
Is an s orbital in the shell? G90DRV
G90DRV
KS = 0 G90DRV
IF(MAXL.EQ.0) KS = 1 G90DRV
IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G90DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G90DRV
IF(KS.EQ.0) GOTO 30 G90DRV
G90DRV
s orbital: G90DRV
G90DRV
IBAS = IBAS + 1 G90DRV
LCTR(IBAS) = NCTR G90DRV
LANG(IBAS) = LISTS G90DRV
G90DRV
Is a set of p orbitals in the shell? G90DRV
G90DRV
30 CONTINUE G90DRV
KP = 0 G90DRV
IF(MAXL.EQ.0) GOTO 90 G90DRV
IF(MAXL.EQ.1) KP = 1 G90DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G90DRV
IF(KP.EQ.0) GOTO 50 G90DRV
G90DRV
p orbitals: G90DRV
G90DRV
DO 40 I = 1,3 G90DRV
IBAS = IBAS + 1 G90DRV
LCTR(IBAS) = NCTR G90DRV
LANG(IBAS) = LISTP(I) G90DRV
40 CONTINUE G90DRV
G90DRV
d orbitals: G90DRV
G90DRV
50 IF(MAXL.NE.2) GOTO 70 G90DRV
IMAX = I5D6D + 5 G90DRV
KD = I5D6D + 1 G90DRV
DO 60 I = 1,IMAX G90DRV
IBAS = IBAS + 1 G90DRV
LCTR(IBAS) = NCTR G90DRV
LANG(IBAS) = LISTD(I,KD) G90DRV
60 CONTINUE G90DRV
GO TO 90 G90DRV
G90DRV
f orbitals: G90DRV
G90DRV
70 IF(MAXL.NE.3) GOTO 90 G90DRV
IMAX = 7 G90DRV
IF(I7F10F.EQ.1) IMAX = 10 G90DRV
KF = I7F10F + 1 G90DRV
DO 80 I = 1,IMAX G90DRV
IBAS = IBAS + 1 G90DRV
LCTR(IBAS) = NCTR G90DRV
LANG(IBAS) = LISTF(I,KF) G90DRV
80 CONTINUE G90DRV
90 CONTINUE G90DRV
100 CONTINUE G90DRV
NDIM = NBASIS G90DRV
NBAS = NBASIS G90DRV
G90DRV
Determine the type of wave function the density matrix is from: G90DRV
G90DRV
IF(MULTIP.GT.1) OPEN = .TRUE. G90DRV
IF(NBOOPT(2).NE.0) THEN G90DRV
CI = .TRUE. G90DRV
ELSE G90DRV
CALL ILSW(2,1,ISCF) G90DRV
CALL ILSW(2,22,IROHF) G90DRV
IF(ISCF.EQ.1) UHF = .TRUE. G90DRV
IF(UHF) OPEN = .TRUE. G90DRV
IF(IROHF.EQ.1) ROHF = .TRUE. G90DRV
IF(IROHF.EQ.2) ROHF = .TRUE. G90DRV
IF(IROHF.EQ.3) MCSCF = .TRUE. G90DRV
IF(ISCF.GT.1) COMPLX = .TRUE. G90DRV
IF(COMPLX) GOTO 900 G90DRV
END IF G90DRV
IF(NBOOPT(5).EQ.1) AUHF = .TRUE. G90DRV
ORTHO = .FALSE. G90DRV
G90DRV
No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G90DRV
G90DRV
IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G90DRV
G90DRV
Expectation values of the Fock operator are in atomic units: G90DRV
G90DRV
MUNIT = 0 G90DRV
G90DRV
Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G90DRV
G90DRV
ICORE(1) = NATOMS G90DRV
ICORE(2) = NDIM G90DRV
ICORE(3) = NBAS G90DRV
ICORE(4) = MUNIT G90DRV
ICORE(5) = 0 G90DRV
IF(ROHF) ICORE(5) = 1 G90DRV
ICORE(6) = 0 G90DRV
IF(UHF) ICORE(6) = 1 G90DRV
ICORE(7) = 0 G90DRV
IF(CI) ICORE(7) = 1 G90DRV
ICORE(8) = 0 G90DRV
IF(OPEN) ICORE(8) = 1 G90DRV
ICORE(9) = 0 G90DRV
IF(MCSCF) ICORE(9) = 1 G90DRV
ICORE(10) = 0 G90DRV
IF(AUHF) ICORE(10) = 1 G90DRV
ICORE(11) = 0 G90DRV
IF(ORTHO) ICORE(11) = 1 G90DRV
ICORE(12) = 1 G90DRV
NFILE = 3 G90DRV
CALL NBWRIT(ICORE,12,NFILE) G90DRV
G90DRV
Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G90DRV
G90DRV
II = 0 G90DRV
DO 120 I = 1,NATOMS G90DRV
II = II + 1 G90DRV
ICORE(II) = IATNO(I) G90DRV
120 CONTINUE G90DRV
DO 130 I = 1,NATOMS G90DRV
II = II + 1 G90DRV
ICORE(II) = IZNUC(I) G90DRV
130 CONTINUE G90DRV
DO 140 I = 1,NBAS G90DRV
II = II + 1 G90DRV
ICORE(II) = LCTR(I) G90DRV
140 CONTINUE G90DRV
DO 150 I = 1,NBAS G90DRV
II = II + 1 G90DRV
ICORE(II) = LANG(I) G90DRV
150 CONTINUE G90DRV
NFILE = 4 G90DRV
CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) G90DRV
G90DRV
Fetch the total energy from the RWF and store it on the NBODAF: G90DRV
G90DRV
CALL TREAD(501,CORE,32,1,32,1,0) G90DRV
CORE(1) = CORE(32) G90DRV
CORE(2) = CORE(32) G90DRV
NFILE = 8 G90DRV
CALL NBWRIT(CORE,2,NFILE) G90DRV
G90DRV
Store the atomic coordinates on the NBO DAF: (Note that these G90DRV
coordinates are used in the calculation of dipole moments.) G90DRV
G90DRV
DO 160 I = 1,3*NATOMS G90DRV
CORE(I) = C(I) * TOANG G90DRV
160 CONTINUE G90DRV
NFILE = 9 G90DRV
CALL NBWRIT(CORE,3*NATOMS,NFILE) G90DRV
G90DRV
Store the overlap matrix on the NBODAF: G90DRV
G90DRV
L2 = NDIM*(NDIM+1)/2 G90DRV
CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1) G90DRV
CALL PACK(CORE,NDIM,NBAS,L2) G90DRV
NFILE = 10 G90DRV
CALL NBWRIT(CORE,L2,NFILE) G90DRV
G90DRV
Store the density matrices on the NBODAF: G90DRV
G90DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.0) WRITE(LFNPR,1000) G90DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.1) WRITE(LFNPR,1010) G90DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.2) WRITE(LFNPR,1020) G90DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.3) WRITE(LFNPR,1030) G90DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.4) WRITE(LFNPR,1040) G90DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.5) WRITE(LFNPR,1050) G90DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.6) WRITE(LFNPR,1060) G90DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.7) WRITE(LFNPR,1070) G90DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.8) WRITE(LFNPR,1080) G90DRV
G90DRV
L2 = NDIM*(NDIM+1)/2 G90DRV
LEN = L2 G90DRV
IF(OPEN) LEN = 2 * LEN G90DRV
CALL DENGET(LFNPR,603,NBOOPT(2),LEN,GOTDEN,CORE) G90DRV
IF(.NOT.GOTDEN) STOP 'Missing density matrix' G90DRV
NFILE = 20 G90DRV
CALL NBWRIT(CORE,L2,NFILE) G90DRV
G90DRV
IF(OPEN) THEN G90DRV
NFILE = 21 G90DRV
CALL NBWRIT(CORE(L2+1),L2,NFILE) G90DRV
END IF G90DRV
G90DRV
Store the Fock matrices on the NBODAF: G90DRV
G90DRV
IF(IWFOCK.NE.0) THEN G90DRV
IEXIST = ITQRY(536) G90DRV
IF(IEXIST.GT.0) THEN G90DRV
L2 = NDIM*(NDIM+1)/2 G90DRV
CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1) G90DRV
CALL PACK(CORE,NDIM,NBAS,L2) G90DRV
NFILE = 30 G90DRV
CALL NBWRIT(CORE,L2,NFILE) G90DRV
END IF G90DRV
G90DRV
IF(OPEN) THEN G90DRV
IEXIST = ITQRY(538) G90DRV
IF(IEXIST.GT.0) THEN G90DRV
L2 = NDIM*(NDIM+1)/2 G90DRV
CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1) G90DRV
CALL PACK(CORE,NDIM,NBAS,L2) G90DRV
NFILE = 31 G90DRV
CALL NBWRIT(CORE,L2,NFILE) G90DRV
END IF G90DRV
END IF G90DRV
END IF G90DRV
G90DRV
Store the AO to MO transformation matrices on the NBODAF: G90DRV
G90DRV
IEXIST = ITQRY(524) G90DRV
IF(IEXIST.GT.0) THEN G90DRV
L3 = NDIM*NDIM G90DRV
CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0) G90DRV
NFILE = 40 G90DRV
CALL NBWRIT(CORE,L3,NFILE) G90DRV
END IF G90DRV
G90DRV
IF(OPEN) THEN G90DRV
IEXIST = ITQRY(526) G90DRV
IF(IEXIST.GT.0) THEN G90DRV
L3 = NDIM*NDIM G90DRV
CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0) G90DRV
NFILE = 41 G90DRV
CALL NBWRIT(CORE,L3,NFILE) G90DRV
END IF G90DRV
END IF G90DRV
G90DRV
Store the x,y,z dipole integrals on the NBODAF: G90DRV
G90DRV
IEXIST = ITQRY(518) G90DRV
IF(IEXIST.GT.0) THEN G90DRV
L2 = NDIM*(NDIM+1)/2 G90DRV
LEN = 3 * L2 G90DRV
CALL TREAD(518,CORE,LEN,1,LEN,1,0) G90DRV
DO 170 I = 1,LEN G90DRV
CORE(I) = CORE(I) * TOANG G90DRV
170 CONTINUE G90DRV
NFILE = 50 G90DRV
CALL NBWRIT(CORE,L2,NFILE) G90DRV
NFILE = 51 G90DRV
CALL NBWRIT(CORE(L2+1),L2,NFILE) G90DRV
NFILE = 52 G90DRV
CALL NBWRIT(CORE(2*L2+1),L2,NFILE) G90DRV
END IF G90DRV
G90DRV
Store the AO basis set info on the NBO DAF: (Note that two integers G90DRV
and three integer arrays are stored first. Also remember that ICORE G90DRV
and CORE occupy the same memory.) G90DRV
G90DRV
NEXP = 0 G90DRV
DO 180 I = 1,6000 G90DRV
IF(EXX(I).EQ.ZERO) GOTO 180 G90DRV
NEXP = I G90DRV
180 CONTINUE G90DRV
DO 190 I = 1,2+3*NSHELL+5*NEXP G90DRV
CORE(I) = ZERO G90DRV
190 CONTINUE G90DRV
ICORE(1) = NSHELL G90DRV
ICORE(2) = NEXP G90DRV
G90DRV
Determine if Cartesian or pure D and F functions are used: G90DRV
G90DRV
CALL ILSW(2,2,I5D6D) G90DRV
CALL ILSW(2,16,I7F10F) G90DRV
G90DRV
NCOMP(I) -- the number of components in the Ith shell: G90DRV
G90DRV
II = 2 G90DRV
DO 420 I = 1,NSHELL G90DRV
II = II + 1 G90DRV
ICORE(II) = 0 G90DRV
MAXL = SHELLT(I) G90DRV
ICNSTR = SHELLC(I) G90DRV
G90DRV
Determine if an S orbital is in the shell: G90DRV
G90DRV
KS = 0 G90DRV
IF(MAXL.EQ.0) KS = 1 G90DRV
IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G90DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G90DRV
IF(KS.EQ.0) GO TO 310 G90DRV
G90DRV
S orbital: G90DRV
G90DRV
ICORE(II) = ICORE(II) + 1 G90DRV
G90DRV
Determine if a set of P orbitals is in the shell: G90DRV
G90DRV
310 CONTINUE G90DRV
KP = 0 G90DRV
IF(MAXL.EQ.0) GO TO 400 G90DRV
IF(MAXL.EQ.1) KP = 1 G90DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G90DRV
IF(KP.EQ.0) GO TO 340 G90DRV
G90DRV
P orbital: G90DRV
G90DRV
ICORE(II) = ICORE(II) + 3 G90DRV
G90DRV
If MAXL is less than 2 then there are no D or F orbitals: G90DRV
If MAXL is greater than 2 then there must be F orbitals: G90DRV
G90DRV
340 IF(MAXL.LT.2) GO TO 400 G90DRV
IF(MAXL.GT.2) GO TO 370 G90DRV
G90DRV
D orbital: G90DRV
G90DRV
IMAX = I5D6D + 5 G90DRV
ICORE(II) = ICORE(II) + IMAX G90DRV
G90DRV
If MAXL is less than 3 then there are no F orbitals: G90DRV
G90DRV
370 IF(MAXL.LT.3) GO TO 400 G90DRV
G90DRV
F orbital: G90DRV
G90DRV
IMAX=7 G90DRV
IF(I7F10F.EQ.1) IMAX=10 G90DRV
ICORE(II) = ICORE(II) + IMAX G90DRV
G90DRV
Skip here when no more orbitals are found: G90DRV
G90DRV
400 CONTINUE G90DRV
420 CONTINUE G90DRV
G90DRV
NPRIM(I) -- the number of gaussian primitives in the Ith shell: G90DRV
G90DRV
DO 480 I = 1,NSHELL G90DRV
II = II + 1 G90DRV
ICORE(II) = SHELLN(I) G90DRV
480 CONTINUE G90DRV
G90DRV
NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G90DRV
EXP, CS, CP, etc.: G90DRV
G90DRV
DO 490 I = 1,NSHELL G90DRV
II = II + 1 G90DRV
ICORE(II) = SHELLA(I) G90DRV
490 CONTINUE G90DRV
G90DRV
EXP(I) -- orbital exponents indexed by NPTR: G90DRV
G90DRV
DO 500 I = 1,NEXP G90DRV
II = II + 1 G90DRV
CORE(II) = EXX(I) G90DRV
500 CONTINUE G90DRV
G90DRV
CS,CP -- orbital coefficients: G90DRV
G90DRV
DO 510 I = 1,NEXP G90DRV
II = II + 1 G90DRV
CORE(II) = C1(I) G90DRV
510 CONTINUE G90DRV
DO 520 I = 1,NEXP G90DRV
II = II + 1 G90DRV
CORE(II) = C2(I) G90DRV
520 CONTINUE G90DRV
G90DRV
Zero CD and CF arrays: G90DRV
G90DRV
IHOLD = II G90DRV
DO 550 I = 1,2*NEXP G90DRV
II = II + 1 G90DRV
CORE(II) = ZERO G90DRV
550 CONTINUE G90DRV
G90DRV
Build CD and CF from C3 and C4: G90DRV
G90DRV
DO 570 I = 1,NSHELL G90DRV
IPTR = SHLADF(I) G90DRV
IF(IPTR.GT.0) THEN G90DRV
DO 560 J = 1,SHELLN(I) G90DRV
LPTR = J + SHELLA(I) + IHOLD - 1 G90DRV
MPTR = J + IPTR - 1 G90DRV
CORE(LPTR) = C3(MPTR) G90DRV
CORE(LPTR+NEXP) = C4(MPTR) G90DRV
560 CONTINUE G90DRV
END IF G90DRV
570 CONTINUE G90DRV
NFILE = 5 G90DRV
CALL NBWRIT(CORE,II,NFILE) G90DRV
RETURN G90DRV
G90DRV
900 WRITE(LFNPR,990) G90DRV
RETURN G90DRV
G90DRV
990 FORMAT(/1X,'The NBO program is not set up to handle complex ', G90DRV
+ 'wave functions') G90DRV
1000 FORMAT(/1X,'Analyzing the SCF density') G90DRV
1010 FORMAT(/1X,'Analyzing the MP first order density') G90DRV
1020 FORMAT(/1X,'Analyzing the MP2 density') G90DRV
1030 FORMAT(/1X,'Analyzing the MP3 density') G90DRV
1040 FORMAT(/1X,'Analyzing the MP4 density') G90DRV
1050 FORMAT(/1X,'Analyzing the CI one-particle density') G90DRV
1060 FORMAT(/1X,'Analyzing the CI density') G90DRV
1070 FORMAT(/1X,'Analyzing the QCI/CC density') G90DRV
1080 FORMAT(/1X,'Analyzing the density correct to second order') G90DRV
END G90DRV
***********************************************************************G90DRV
SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G90DRV
***********************************************************************G90DRV
IMPLICIT REAL*8 (A-H,O-Z) G90DRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) G90DRV
LOGICAL NEW,ERROR,SEQ G90DRV
G90DRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G90DRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G90DRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G90DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G90DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G90DRV
+ LFNDAF,LFNDEF G90DRV
G90DRV
If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G90DRV
DAF to the RWFs. G90DRV
G90DRV
IF(NBOOPT(1).EQ.2) THEN G90DRV
NEW = .FALSE. G90DRV
CALL NBOPEN(NEW,ERROR) G90DRV
IF(ERROR) THEN G90DRV
WRITE(LFNPR,900) G90DRV
STOP G90DRV
END IF G90DRV
L2 = NDIM * (NDIM + 1)/2 G90DRV
IF(OPEN) THEN G90DRV
ALPHA = .TRUE. G90DRV
BETA = .FALSE. G90DRV
CALL FENEWD(CORE) G90DRV
CALL TWRITE(528,CORE,L2,1,L2,1,0) G90DRV
ALPHA = .FALSE. G90DRV
BETA = .TRUE. G90DRV
CALL FENEWD(CORE) G90DRV
CALL TWRITE(530,CORE,L2,1,L2,1,0) G90DRV
ELSE G90DRV
ALPHA = .FALSE. G90DRV
BETA = .FALSE. G90DRV
CALL FENEWD(CORE) G90DRV
CALL TWRITE(528,CORE,L2,1,L2,1,0) G90DRV
END IF G90DRV
SEQ = .FALSE. G90DRV
CALL NBCLOS(SEQ) G90DRV
END IF G90DRV
G90DRV
If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G90DRV
G90DRV
IF(NBOOPT(1).EQ.3) THEN G90DRV
NEW = .FALSE. G90DRV
CALL NBOPEN(NEW,ERROR) G90DRV
IF(ERROR) THEN G90DRV
WRITE(LFNPR,900) G90DRV
STOP G90DRV
END IF G90DRV
CALL TREAD(501,CORE,32,1,32,1,0) G90DRV
CALL SVE0(CORE(32)) G90DRV
SEQ = .FALSE. G90DRV
CALL NBCLOS(SEQ) G90DRV
END IF G90DRV
RETURN G90DRV
G90DRV
900 FORMAT(/1X,'Error opening the NBO direct access file in ', G90DRV
+ 'subroutine DELSCF.') G90DRV
END G90DRV
***********************************************************************G90DRV
G90DRV
E N D O F G 9 0 N B O R O U T I N E S G90DRV
G90DRV
***********************************************************************G90DRV
***********************************************************************G88DRV
G88DRV
G88DRV
G 8 8 N B O G88DRV
G88DRV
G88DRV
GAUSSIAN 88 VERSION OF NBO PROGRAM G88DRV
G88DRV
G88DRV
DRIVER ROUTINES: G88DRV
G88DRV
SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G88DRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G88DRV
SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G88DRV
G88DRV
***********************************************************************G88DRV
SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G88DRV
***********************************************************************G88DRV
IMPLICIT REAL*8 (A-H,O-Z) G88DRV
G88DRV
PARAMETER (MAXFIL = 40) G88DRV
G88DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G88DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G88DRV
+ LFNDAF,LFNDEF G88DRV
COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) G88DRV
CHARACTER*80 FILENM G88DRV
G88DRV
DIMENSION CORE(1),IOP(50) G88DRV
DIMENSION NBOOPT(10) G88DRV
G88DRV
LFNIN = 5 G88DRV
LFNPR = 6 G88DRV
G88DRV
DATA TENTH/0.1D0/ G88DRV
G88DRV
Set NBO options. G88DRV
G88DRV
DO 10 I = 1,9 G88DRV
NBOOPT(I) = IOP(I+39) G88DRV
10 CONTINUE G88DRV
NBOOPT(10) = 88 G88DRV
G88DRV
--- NBO analysis --- G88DRV
G88DRV
ICONTR = 0 G88DRV
IF(ABS(NBOOPT(1)).LT.2) THEN G88DRV
CALL CHARPN(4HNBO ) G88DRV
CALL NBO(CORE,MEMORY,NBOOPT) G88DRV
G88DRV
Store the name of the NBO direct access file on the RWFiles G88DRV
G88DRV
DO 20 I = 1,80 G88DRV
CORE(I) = ICHAR(FILENM(I:I)) G88DRV
20 CONTINUE G88DRV
CORE(81) = LFNDAF G88DRV
CALL TWRITE(636,CORE,81,1,81,1,0) G88DRV
G88DRV
--- NBO energetic analysis --- G88DRV
G88DRV
ELSE IF(NBOOPT(1).EQ.2) THEN G88DRV
G88DRV
Retrieve the name of the NBO direct access file from the RWFiles G88DRV
G88DRV
CALL TREAD(636,CORE,81,1,81,1,0) G88DRV
DO 30 I = 1,80 G88DRV
FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G88DRV
30 CONTINUE G88DRV
LFNDAF = INT(ABS(CORE(81)) + TENTH) G88DRV
CALL CHARPN(4HDELE) G88DRV
CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G88DRV
IF(IDONE.NE.0) ICONTR = 1 G88DRV
IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT) G88DRV
G88DRV
ELSE IF(NBOOPT(1).EQ.3) THEN G88DRV
CALL TREAD(636,CORE,81,1,81,1,0) G88DRV
DO 40 I = 1,80 G88DRV
FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G88DRV
40 CONTINUE G88DRV
LFNDAF = INT(ABS(CORE(81)) + TENTH) G88DRV
CALL CHARPN(4HEDEL) G88DRV
CALL DELSCF(CORE,CORE,NBOOPT) G88DRV
CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G88DRV
END IF G88DRV
G88DRV
RETURN G88DRV
END G88DRV
***********************************************************************G88DRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G88DRV
***********************************************************************G88DRV
IMPLICIT REAL*8 (A-H,O-Z) G88DRV
LOGICAL GOTDEN G88DRV
-----------------------------------------------------------------------G88DRV
G88DRV
Routine FEAOIN accesses the following records of the RWFs: G88DRV
G88DRV
501 --- Total energy G88DRV
502 --- Job title G88DRV
506 --- Basis set information G88DRV
512 --- Effective core potential information G88DRV
514 --- AO overlap matrix G88DRV
518 --- AO dipole integrals G88DRV
524 --- MO coefficients (alpha) G88DRV
526 --- MO coefficients (beta) G88DRV
536 --- AO Fock matrix (alpha) G88DRV
538 --- AO Fock matrix (beta) G88DRV
603 --- AO density matrix G88DRV
G88DRV
----------------------------------------------------------------------G88DRV
G88DRV
NBO Common blocks G88DRV
G88DRV
PARAMETER(MAXATM = 99,MAXBAS = 500) G88DRV
G88DRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G88DRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G88DRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G88DRV
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, G88DRV
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, G88DRV
+ JCORE,JPRINT(60) G88DRV
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) G88DRV
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G88DRV
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) G88DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G88DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G88DRV
+ LFNDAF,LFNDEF G88DRV
G88DRV
GAUSSIAN 88 Common blocks G88DRV
G88DRV
COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(401), G88DRV
* ATMCHG(400),C(1200) G88DRV
COMMON/LP2/NLP(1600),CLP(1600),ZLP(1600),KFIRST(400,5), G88DRV
* KLAST(400,5),LMAX(400),LPSKIP(400),NFroz(400) G88DRV
COMMON/B/EXX(6000),C1(6000),C2(6000),C3(6000),X(2000),Y(2000), G88DRV
* Z(2000),JAN(2000),SHELLA(2000),SHELLN(2000),SHELLT(2000), G88DRV
* SHELLC(2000),AOS(2000),AON(2000),NSHELL,MAXTYP G88DRV
INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON G88DRV
DIMENSION C4(2000),SHLADF(2000) G88DRV
EQUIVALENCE(C4(1),C3(2001)),(SHLADF(1),C3(4001)) G88DRV
G88DRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) G88DRV
DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G88DRV
G88DRV
Obtain the following information: G88DRV
G88DRV
ROHF =.TRUE. If RHF open shell wavefunction G88DRV
=.FALSE. otherwise G88DRV
G88DRV
UHF =.TRUE. If UHF wavefunction G88DRV
=.FALSE. otherwise G88DRV
G88DRV
AUHF =.TRUE. If spin-annihilated UHF wavefunction G88DRV
=.FALSE. otherwise G88DRV
G88DRV
CI =.TRUE. If CI wavefunction G88DRV
=.FALSE. otherwise G88DRV
G88DRV
OPEN =.TRUE. If open shell wavefunction G88DRV
=.FALSE. otherwise G88DRV
G88DRV
COMPLX =.TRUE. If complex wavefunction G88DRV
=.FALSE. otherwise G88DRV
(Note: The program is not capable of handling this.) G88DRV
G88DRV
NATOMS Number of atomic centers G88DRV
G88DRV
NDIM Dimension of matrices (overlap and density) G88DRV
G88DRV
NBAS Number of basis functions (.le.NDIM) G88DRV
G88DRV
IPSEUD Set to one if pseudopotentials are used. G88DRV
G88DRV
IWCUBF This pertains only basis sets with F functions. G88DRV
G88DRV
If cartesian F functions are input, set IWCUBF to: G88DRV
0, if these are to be transformed to the G88DRV
standard set of pure F functions G88DRV
1, if these are to be transformed to the G88DRV
cubic set of pure F functions G88DRV
G88DRV
If pure F functions are input, set to IWCUBF to: G88DRV
0, if these are standard F functions G88DRV
1, if these are cubic F functions G88DRV
G88DRV
IATNO(I),I=1,NATOMS G88DRV
List of atomic numbers G88DRV
G88DRV
LCTR(I),I=1,NBAS G88DRV
List of atomic centers of the basis functions G88DRV
(LCTR(3)=2 if basis function 3 is on atom 2) G88DRV
G88DRV
LANG(I),I=1,NBAS G88DRV
List of angular symmetry information for the AO basis G88DRV
G88DRV
DATA LISTS/ 1/ G88DRV
DATA LISTP/ 101, 102, 103/ G88DRV
DATA LISTD/ 255, 252, 253, 254, 251, 0, G88DRV
+ 201, 204, 206, 202, 203, 205/ G88DRV
DATA LISTF/ 351, 352, 353, 354, 355, 356, 357, 0, 0, 0, G88DRV
+ 301, 307, 310, 304, 302, 303, 306, 309, 308, 305/ G88DRV
DATA ZERO/0.0D0/ G88DRV
DATA TOANG/0.529177249/ G88DRV
G88DRV
Store job title on NBODAF: G88DRV
G88DRV
LEN = INTOWP(4000+100) G88DRV
CALL TREAD(502,ICORE,LEN,1,LEN,1,0) G88DRV
NFILE = 2 G88DRV
CALL NBWRIT(ICORE(4001),10,NFILE) G88DRV
G88DRV
Get the number of atoms from NAT and store the atomic numbers in G88DRV
IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G88DRV
nuclear charges may not be equivalent if effective core potentials G88DRV
(ECP) are used.) G88DRV
G88DRV
LEN = 0 G88DRV
IEXIST = ITQRY(512) G88DRV
IF(IEXIST.GT.0) THEN G88DRV
LEN = 8 * 400 + 17 * INTOWP(400) G88DRV
CALL TREAD(512,NLP,LEN,1,LEN,1,0) G88DRV
END IF G88DRV
NATOMS = NATOM G88DRV
DO 20 I = 1,NATOMS G88DRV
IATNO(I) = IAN(I) G88DRV
IF(IEXIST.GT.0) THEN G88DRV
IZNUC(I) = IATNO(I) - NFROZ(I) G88DRV
IF(NFROZ(I).NE.0) IPSEUD = 1 G88DRV
ELSE G88DRV
IZNUC(I) = IATNO(I) G88DRV
END IF G88DRV
20 CONTINUE G88DRV
G88DRV
Restore the basis set to COMMON/B/: G88DRV
G88DRV
LEN = 30000 + INTOWP(14002) G88DRV
CALL TREAD(506,EXX,LEN,1,LEN,1,0) G88DRV
G88DRV
The Gaussian programs do not use cubic f basis functions. G88DRV
Determine which set of d and f functions are being used, G88DRV
Cartesian or pure): G88DRV
G88DRV
IWCUBF = 0 G88DRV
CALL ILSW(2,2,I5D6D) G88DRV
CALL ILSW(2,16,I7F10F) G88DRV
G88DRV
Construct the AO information lists: LCTR and LANG G88DRV
G88DRV
IBAS = 0 G88DRV
DO 90 ISHELL = 1,2000 G88DRV
IF(IBAS.EQ.NBASIS) GOTO 100 G88DRV
NCTR = JAN(ISHELL) G88DRV
MAXL = SHELLT(ISHELL) G88DRV
ICNSTR = SHELLC(ISHELL) G88DRV
G88DRV
Is an s orbital in the shell? G88DRV
G88DRV
KS = 0 G88DRV
IF(MAXL.EQ.0) KS = 1 G88DRV
IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G88DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G88DRV
IF(KS.EQ.0) GOTO 30 G88DRV
G88DRV
s orbital: G88DRV
G88DRV
IBAS = IBAS + 1 G88DRV
LCTR(IBAS) = NCTR G88DRV
LANG(IBAS) = LISTS G88DRV
G88DRV
Is a set of p orbitals in the shell? G88DRV
G88DRV
30 CONTINUE G88DRV
KP = 0 G88DRV
IF(MAXL.EQ.0) GOTO 90 G88DRV
IF(MAXL.EQ.1) KP = 1 G88DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G88DRV
IF(KP.EQ.0) GOTO 50 G88DRV
G88DRV
p orbitals: G88DRV
G88DRV
DO 40 I = 1,3 G88DRV
IBAS = IBAS + 1 G88DRV
LCTR(IBAS) = NCTR G88DRV
LANG(IBAS) = LISTP(I) G88DRV
40 CONTINUE G88DRV
G88DRV
d orbitals: G88DRV
G88DRV
50 IF(MAXL.NE.2) GOTO 70 G88DRV
IMAX = I5D6D + 5 G88DRV
KD = I5D6D + 1 G88DRV
DO 60 I = 1,IMAX G88DRV
IBAS = IBAS + 1 G88DRV
LCTR(IBAS) = NCTR G88DRV
LANG(IBAS) = LISTD(I,KD) G88DRV
60 CONTINUE G88DRV
GO TO 90 G88DRV
G88DRV
f orbitals: G88DRV
G88DRV
70 IF(MAXL.NE.3) GOTO 90 G88DRV
IMAX = 7 G88DRV
IF(I7F10F.EQ.1) IMAX = 10 G88DRV
KF = I7F10F + 1 G88DRV
DO 80 I = 1,IMAX G88DRV
IBAS = IBAS + 1 G88DRV
LCTR(IBAS) = NCTR G88DRV
LANG(IBAS) = LISTF(I,KF) G88DRV
80 CONTINUE G88DRV
90 CONTINUE G88DRV
100 CONTINUE G88DRV
NDIM = NBASIS G88DRV
NBAS = NBASIS G88DRV
G88DRV
Determine the type of wave function the density matrix is from: G88DRV
G88DRV
IF(MULTIP.GT.1) OPEN = .TRUE. G88DRV
IF(NBOOPT(2).NE.0) THEN G88DRV
CI = .TRUE. G88DRV
ELSE G88DRV
CALL ILSW(2,1,ISCF) G88DRV
CALL ILSW(2,22,IROHF) G88DRV
IF(ISCF.EQ.1) UHF = .TRUE. G88DRV
IF(UHF) OPEN = .TRUE. G88DRV
IF(IROHF.EQ.1) ROHF = .TRUE. G88DRV
IF(IROHF.EQ.2) ROHF = .TRUE. G88DRV
IF(IROHF.EQ.3) MCSCF = .TRUE. G88DRV
IF(ISCF.GT.1) COMPLX = .TRUE. G88DRV
IF(COMPLX) GOTO 900 G88DRV
END IF G88DRV
IF(NBOOPT(5).EQ.1) AUHF = .TRUE. G88DRV
ORTHO = .FALSE. G88DRV
G88DRV
No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G88DRV
G88DRV
IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G88DRV
G88DRV
Expectation values of the Fock operator are in atomic units: G88DRV
G88DRV
MUNIT = 0 G88DRV
G88DRV
Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G88DRV
G88DRV
ICORE(1) = NATOMS G88DRV
ICORE(2) = NDIM G88DRV
ICORE(3) = NBAS G88DRV
ICORE(4) = MUNIT G88DRV
ICORE(5) = 0 G88DRV
IF(ROHF) ICORE(5) = 1 G88DRV
ICORE(6) = 0 G88DRV
IF(UHF) ICORE(6) = 1 G88DRV
ICORE(7) = 0 G88DRV
IF(CI) ICORE(7) = 1 G88DRV
ICORE(8) = 0 G88DRV
IF(OPEN) ICORE(8) = 1 G88DRV
ICORE(9) = 0 G88DRV
IF(MCSCF) ICORE(9) = 1 G88DRV
ICORE(10) = 0 G88DRV
IF(AUHF) ICORE(10) = 1 G88DRV
ICORE(11) = 0 G88DRV
IF(ORTHO) ICORE(11) = 1 G88DRV
ICORE(12) = 1 G88DRV
NFILE = 3 G88DRV
CALL NBWRIT(ICORE,12,NFILE) G88DRV
G88DRV
Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G88DRV
G88DRV
II = 0 G88DRV
DO 120 I = 1,NATOMS G88DRV
II = II + 1 G88DRV
ICORE(II) = IATNO(I) G88DRV
120 CONTINUE G88DRV
DO 130 I = 1,NATOMS G88DRV
II = II + 1 G88DRV
ICORE(II) = IZNUC(I) G88DRV
130 CONTINUE G88DRV
DO 140 I = 1,NBAS G88DRV
II = II + 1 G88DRV
ICORE(II) = LCTR(I) G88DRV
140 CONTINUE G88DRV
DO 150 I = 1,NBAS G88DRV
II = II + 1 G88DRV
ICORE(II) = LANG(I) G88DRV
150 CONTINUE G88DRV
NFILE = 4 G88DRV
CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) G88DRV
G88DRV
Fetch the total energy from the RWF and store it on the NBODAF: G88DRV
G88DRV
CALL TREAD(501,CORE,32,1,32,1,0) G88DRV
CORE(1) = CORE(32) G88DRV
CORE(2) = CORE(32) G88DRV
NFILE = 8 G88DRV
CALL NBWRIT(CORE,2,NFILE) G88DRV
G88DRV
Store the atomic coordinates on the NBO DAF: (Note that these G88DRV
coordinates are used in the calculation of dipole moments.) G88DRV
G88DRV
DO 160 I = 1,3*NATOMS G88DRV
CORE(I) = C(I) * TOANG G88DRV
160 CONTINUE G88DRV
NFILE = 9 G88DRV
CALL NBWRIT(CORE,3*NATOMS,NFILE) G88DRV
G88DRV
Store the overlap matrix on the NBODAF: G88DRV
G88DRV
L2 = NDIM*(NDIM+1)/2 G88DRV
CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1) G88DRV
CALL PACK(CORE,NDIM,NBAS,L2) G88DRV
NFILE = 10 G88DRV
CALL NBWRIT(CORE,L2,NFILE) G88DRV
G88DRV
Store the density matrices on the NBODAF: G88DRV
G88DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.0) WRITE(LFNPR,1000) G88DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.1) WRITE(LFNPR,1010) G88DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.2) WRITE(LFNPR,1020) G88DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.3) WRITE(LFNPR,1030) G88DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.4) WRITE(LFNPR,1040) G88DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.5) WRITE(LFNPR,1050) G88DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.6) WRITE(LFNPR,1060) G88DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.7) WRITE(LFNPR,1070) G88DRV
IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.8) WRITE(LFNPR,1080) G88DRV
G88DRV
L2 = NDIM*(NDIM+1)/2 G88DRV
LEN = L2 G88DRV
IF(OPEN) LEN = 2 * LEN G88DRV
CALL DENGET(LFNPR,603,NBOOPT(2),LEN,GOTDEN,CORE) G88DRV
IF(.NOT.GOTDEN) STOP 'Missing density matrix' G88DRV
NFILE = 20 G88DRV
CALL NBWRIT(CORE,L2,NFILE) G88DRV
G88DRV
IF(OPEN) THEN G88DRV
NFILE = 21 G88DRV
CALL NBWRIT(CORE(L2+1),L2,NFILE) G88DRV
END IF G88DRV
G88DRV
Store the Fock matrices on the NBODAF: G88DRV
G88DRV
IF(IWFOCK.NE.0) THEN G88DRV
IEXIST = ITQRY(536) G88DRV
IF(IEXIST.GT.0) THEN G88DRV
L2 = NDIM*(NDIM+1)/2 G88DRV
CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1) G88DRV
CALL PACK(CORE,NDIM,NBAS,L2) G88DRV
NFILE = 30 G88DRV
CALL NBWRIT(CORE,L2,NFILE) G88DRV
END IF G88DRV
G88DRV
IF(OPEN) THEN G88DRV
IEXIST = ITQRY(538) G88DRV
IF(IEXIST.GT.0) THEN G88DRV
L2 = NDIM*(NDIM+1)/2 G88DRV
CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1) G88DRV
CALL PACK(CORE,NDIM,NBAS,L2) G88DRV
NFILE = 31 G88DRV
CALL NBWRIT(CORE,L2,NFILE) G88DRV
END IF G88DRV
END IF G88DRV
END IF G88DRV
G88DRV
Store the AO to MO transformation matrices on the NBODAF: G88DRV
G88DRV
IEXIST = ITQRY(524) G88DRV
IF(IEXIST.GT.0) THEN G88DRV
L3 = NDIM*NDIM G88DRV
CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0) G88DRV
NFILE = 40 G88DRV
CALL NBWRIT(CORE,L3,NFILE) G88DRV
END IF G88DRV
G88DRV
IF(OPEN) THEN G88DRV
IEXIST = ITQRY(526) G88DRV
IF(IEXIST.GT.0) THEN G88DRV
L3 = NDIM*NDIM G88DRV
CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0) G88DRV
NFILE = 41 G88DRV
CALL NBWRIT(CORE,L3,NFILE) G88DRV
END IF G88DRV
END IF G88DRV
G88DRV
Store the x,y,z dipole integrals on the NBODAF: G88DRV
G88DRV
IEXIST = ITQRY(518) G88DRV
IF(IEXIST.GT.0) THEN G88DRV
L2 = NDIM*(NDIM+1)/2 G88DRV
LEN = 3 * L2 G88DRV
CALL TREAD(518,CORE,LEN,1,LEN,1,0) G88DRV
DO 170 I = 1,LEN G88DRV
CORE(I) = CORE(I) * TOANG G88DRV
170 CONTINUE G88DRV
NFILE = 50 G88DRV
CALL NBWRIT(CORE,L2,NFILE) G88DRV
NFILE = 51 G88DRV
CALL NBWRIT(CORE(L2+1),L2,NFILE) G88DRV
NFILE = 52 G88DRV
CALL NBWRIT(CORE(2*L2+1),L2,NFILE) G88DRV
END IF G88DRV
G88DRV
Store the AO basis set info on the NBO DAF: (Note that two integers G88DRV
and three integer arrays are stored first. Also remember that ICORE G88DRV
and CORE occupy the same memory.) G88DRV
G88DRV
NEXP = 0 G88DRV
DO 180 I = 1,6000 G88DRV
IF(EXX(I).EQ.ZERO) GOTO 180 G88DRV
NEXP = I G88DRV
180 CONTINUE G88DRV
DO 190 I = 1,2+3*NSHELL+5*NEXP G88DRV
CORE(I) = ZERO G88DRV
190 CONTINUE G88DRV
ICORE(1) = NSHELL G88DRV
ICORE(2) = NEXP G88DRV
G88DRV
Determine if Cartesian or pure D and F functions are used: G88DRV
G88DRV
CALL ILSW(2,2,I5D6D) G88DRV
CALL ILSW(2,16,I7F10F) G88DRV
G88DRV
NCOMP(I) -- the number of components in the Ith shell: G88DRV
G88DRV
II = 2 G88DRV
DO 420 I = 1,NSHELL G88DRV
II = II + 1 G88DRV
ICORE(II) = 0 G88DRV
MAXL = SHELLT(I) G88DRV
ICNSTR = SHELLC(I) G88DRV
G88DRV
Determine if an S orbital is in the shell: G88DRV
G88DRV
KS = 0 G88DRV
IF(MAXL.EQ.0) KS = 1 G88DRV
IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G88DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G88DRV
IF(KS.EQ.0) GO TO 310 G88DRV
G88DRV
S orbital: G88DRV
G88DRV
ICORE(II) = ICORE(II) + 1 G88DRV
G88DRV
Determine if a set of P orbitals is in the shell: G88DRV
G88DRV
310 CONTINUE G88DRV
KP = 0 G88DRV
IF(MAXL.EQ.0) GO TO 400 G88DRV
IF(MAXL.EQ.1) KP = 1 G88DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G88DRV
IF(KP.EQ.0) GO TO 340 G88DRV
G88DRV
P orbital: G88DRV
G88DRV
ICORE(II) = ICORE(II) + 3 G88DRV
G88DRV
If MAXL is less than 2 then there are no D or F orbitals: G88DRV
If MAXL is greater than 2 then there must be F orbitals: G88DRV
G88DRV
340 IF(MAXL.LT.2) GO TO 400 G88DRV
IF(MAXL.GT.2) GO TO 370 G88DRV
G88DRV
D orbital: G88DRV
G88DRV
IMAX = I5D6D + 5 G88DRV
ICORE(II) = ICORE(II) + IMAX G88DRV
G88DRV
If MAXL is less than 3 then there are no F orbitals: G88DRV
G88DRV
370 IF(MAXL.LT.3) GO TO 400 G88DRV
G88DRV
F orbital: G88DRV
G88DRV
IMAX=7 G88DRV
IF(I7F10F.EQ.1) IMAX=10 G88DRV
ICORE(II) = ICORE(II) + IMAX G88DRV
G88DRV
Skip here when no more orbitals are found: G88DRV
G88DRV
400 CONTINUE G88DRV
420 CONTINUE G88DRV
G88DRV
NPRIM(I) -- the number of gaussian primitives in the Ith shell: G88DRV
G88DRV
DO 480 I = 1,NSHELL G88DRV
II = II + 1 G88DRV
ICORE(II) = SHELLN(I) G88DRV
480 CONTINUE G88DRV
G88DRV
NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G88DRV
EXP, CS, CP, etc.: G88DRV
G88DRV
DO 490 I = 1,NSHELL G88DRV
II = II + 1 G88DRV
ICORE(II) = SHELLA(I) G88DRV
490 CONTINUE G88DRV
G88DRV
EXP(I) -- orbital exponents indexed by NPTR: G88DRV
G88DRV
DO 500 I = 1,NEXP G88DRV
II = II + 1 G88DRV
CORE(II) = EXX(I) G88DRV
500 CONTINUE G88DRV
G88DRV
CS,CP -- orbital coefficients: G88DRV
G88DRV
DO 510 I = 1,NEXP G88DRV
II = II + 1 G88DRV
CORE(II) = C1(I) G88DRV
510 CONTINUE G88DRV
DO 520 I = 1,NEXP G88DRV
II = II + 1 G88DRV
CORE(II) = C2(I) G88DRV
520 CONTINUE G88DRV
G88DRV
Zero CD and CF arrays: G88DRV
G88DRV
IHOLD = II G88DRV
DO 550 I = 1,2*NEXP G88DRV
II = II + 1 G88DRV
CORE(II) = ZERO G88DRV
550 CONTINUE G88DRV
G88DRV
Build CD and CF from C3 and C4: G88DRV
G88DRV
DO 570 I = 1,NSHELL G88DRV
IPTR = SHLADF(I) G88DRV
IF(IPTR.GT.0) THEN G88DRV
DO 560 J = 1,SHELLN(I) G88DRV
LPTR = J + SHELLA(I) + IHOLD - 1 G88DRV
MPTR = J + IPTR - 1 G88DRV
CORE(LPTR) = C3(MPTR) G88DRV
CORE(LPTR+NEXP) = C4(MPTR) G88DRV
560 CONTINUE G88DRV
END IF G88DRV
570 CONTINUE G88DRV
NFILE = 5 G88DRV
CALL NBWRIT(CORE,II,NFILE) G88DRV
RETURN G88DRV
G88DRV
900 WRITE(LFNPR,990) G88DRV
RETURN G88DRV
G88DRV
990 FORMAT(/1X,'The NBO program is not set up to handle complex ', G88DRV
+ 'wave functions') G88DRV
1000 FORMAT(/1X,'Analyzing the SCF density') G88DRV
1010 FORMAT(/1X,'Analyzing the MP first order density') G88DRV
1020 FORMAT(/1X,'Analyzing the MP2 density') G88DRV
1030 FORMAT(/1X,'Analyzing the MP3 density') G88DRV
1040 FORMAT(/1X,'Analyzing the MP4 density') G88DRV
1050 FORMAT(/1X,'Analyzing the CI one-particle density') G88DRV
1060 FORMAT(/1X,'Analyzing the CI density') G88DRV
1070 FORMAT(/1X,'Analyzing the QCI/CC density') G88DRV
1080 FORMAT(/1X,'Analyzing the density correct to second order') G88DRV
END G88DRV
***********************************************************************G88DRV
SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G88DRV
***********************************************************************G88DRV
IMPLICIT REAL*8 (A-H,O-Z) G88DRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) G88DRV
LOGICAL NEW,ERROR,SEQ G88DRV
G88DRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G88DRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G88DRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G88DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G88DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G88DRV
+ LFNDAF,LFNDEF G88DRV
G88DRV
If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G88DRV
DAF to the RWFs. G88DRV
G88DRV
IF(NBOOPT(1).EQ.2) THEN G88DRV
NEW = .FALSE. G88DRV
CALL NBOPEN(NEW,ERROR) G88DRV
IF(ERROR) THEN G88DRV
WRITE(LFNPR,900) G88DRV
STOP G88DRV
END IF G88DRV
L2 = NDIM * (NDIM + 1)/2 G88DRV
IF(OPEN) THEN G88DRV
ALPHA = .TRUE. G88DRV
BETA = .FALSE. G88DRV
CALL FENEWD(CORE) G88DRV
CALL TWRITE(528,CORE,L2,1,L2,1,0) G88DRV
ALPHA = .FALSE. G88DRV
BETA = .TRUE. G88DRV
CALL FENEWD(CORE) G88DRV
CALL TWRITE(530,CORE,L2,1,L2,1,0) G88DRV
ELSE G88DRV
ALPHA = .FALSE. G88DRV
BETA = .FALSE. G88DRV
CALL FENEWD(CORE) G88DRV
CALL TWRITE(528,CORE,L2,1,L2,1,0) G88DRV
END IF G88DRV
SEQ = .FALSE. G88DRV
CALL NBCLOS(SEQ) G88DRV
END IF G88DRV
G88DRV
If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G88DRV
G88DRV
IF(NBOOPT(1).EQ.3) THEN G88DRV
NEW = .FALSE. G88DRV
CALL NBOPEN(NEW,ERROR) G88DRV
IF(ERROR) THEN G88DRV
WRITE(LFNPR,900) G88DRV
STOP G88DRV
END IF G88DRV
CALL TREAD(501,CORE,32,1,32,1,0) G88DRV
CALL SVE0(CORE(32)) G88DRV
SEQ = .FALSE. G88DRV
CALL NBCLOS(SEQ) G88DRV
END IF G88DRV
RETURN G88DRV
G88DRV
900 FORMAT(/1X,'Error opening the NBO direct access file in ', G88DRV
+ 'subroutine DELSCF.') G88DRV
END G88DRV
***********************************************************************G88DRV
G88DRV
E N D O F G 8 8 N B O R O U T I N E S G88DRV
G88DRV
***********************************************************************G88DRV
***********************************************************************G86DRV
G86DRV
G86DRV
G 8 6 N B O G86DRV
G86DRV
G86DRV
GAUSSIAN 86 VERSION OF NBO PROGRAM G86DRV
G86DRV
G86DRV
DRIVER ROUTINES: G86DRV
G86DRV
SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G86DRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G86DRV
SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G86DRV
G86DRV
***********************************************************************G86DRV
SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G86DRV
***********************************************************************G86DRV
IMPLICIT REAL*8 (A-H,O-Z) G86DRV
G86DRV
PARAMETER (MAXFIL = 40) G86DRV
G86DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G86DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G86DRV
+ LFNDAF,LFNDEF G86DRV
COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) G86DRV
CHARACTER*80 FILENM G86DRV
G86DRV
DIMENSION CORE(1),IOP(50) G86DRV
DIMENSION NBOOPT(10) G86DRV
G86DRV
LFNIN = 5 G86DRV
LFNPR = 6 G86DRV
G86DRV
DATA TENTH/0.1D0/ G86DRV
G86DRV
Set NBO options. G86DRV
G86DRV
DO 10 I = 1,9 G86DRV
NBOOPT(I) = IOP(I+39) G86DRV
10 CONTINUE G86DRV
NBOOPT(10) = 86 G86DRV
G86DRV
--- NBO analysis --- G86DRV
G86DRV
ICONTR = 0 G86DRV
IF(ABS(NBOOPT(1)).LT.2) THEN G86DRV
CALL CHARPN(4HNBO ) G86DRV
CALL NBO(CORE,MEMORY,NBOOPT) G86DRV
G86DRV
Store the name of the NBO direct access file on the RWFiles G86DRV
G86DRV
DO 20 I = 1,80 G86DRV
CORE(I) = ICHAR(FILENM(I:I)) G86DRV
20 CONTINUE G86DRV
CORE(81) = LFNDAF G86DRV
CALL TWRITE(636,CORE,81,1,81,1,0) G86DRV
G86DRV
--- NBO energetic analysis --- G86DRV
G86DRV
ELSE IF(NBOOPT(1).EQ.2) THEN G86DRV
G86DRV
Retrieve the name of the NBO direct access file from the RWFiles G86DRV
G86DRV
CALL TREAD(636,CORE,81,1,81,1,0) G86DRV
DO 30 I = 1,80 G86DRV
FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G86DRV
30 CONTINUE G86DRV
LFNDAF = INT(ABS(CORE(81)) + TENTH) G86DRV
CALL CHARPN(4HDELE) G86DRV
CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G86DRV
IF(IDONE.NE.0) ICONTR = 1 G86DRV
IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT) G86DRV
G86DRV
ELSE IF(NBOOPT(1).EQ.3) THEN G86DRV
CALL TREAD(636,CORE,81,1,81,1,0) G86DRV
DO 40 I = 1,80 G86DRV
FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G86DRV
40 CONTINUE G86DRV
LFNDAF = INT(ABS(CORE(81)) + TENTH) G86DRV
CALL CHARPN(4HEDEL) G86DRV
CALL DELSCF(CORE,CORE,NBOOPT) G86DRV
CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G86DRV
END IF G86DRV
G86DRV
RETURN G86DRV
END G86DRV
***********************************************************************G86DRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G86DRV
***********************************************************************G86DRV
IMPLICIT REAL*8 (A-H,O-Z) G86DRV
-----------------------------------------------------------------------G86DRV
G86DRV
Routine FEAOIN accesses the following records of the RWFs: G86DRV
G86DRV
203 --- CI density matrix (alpha) G86DRV
204 --- CI density matrix (beta) G86DRV
501 --- Total energy G86DRV
502 --- Job title G86DRV
506 --- Basis set information G86DRV
512 --- Effective core potential information G86DRV
514 --- AO overlap matrix G86DRV
518 --- AO dipole integrals G86DRV
524 --- MO coefficients (alpha) G86DRV
526 --- MO coefficients (beta) G86DRV
528 --- SCF density matrix (alpha) G86DRV
530 --- SCF density matrix (beta) G86DRV
536 --- AO Fock matrix (alpha) G86DRV
538 --- AO Fock matrix (beta) G86DRV
G86DRV
----------------------------------------------------------------------G86DRV
G86DRV
NBO Common blocks G86DRV
G86DRV
PARAMETER(MAXATM = 99,MAXBAS = 500) G86DRV
G86DRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G86DRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G86DRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G86DRV
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, G86DRV
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, G86DRV
+ JCORE,JPRINT(60) G86DRV
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) G86DRV
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G86DRV
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) G86DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G86DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G86DRV
+ LFNDAF,LFNDEF G86DRV
G86DRV
GAUSSIAN 86 Common blocks G86DRV
G86DRV
COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(401), G86DRV
* ATMCHG(400),C(1200) G86DRV
COMMON/LP2/NLP(1600),CLP(1600),ZLP(1600),KFIRST(400,5), G86DRV
* KLAST(400,5),LMAX(400),LPSKIP(400),NFroz(400) G86DRV
COMMON/B/EXX(1200),C1(1200),C2(1200),C3(1200),X(400),Y(400), G86DRV
* Z(400),JAN(400),SHELLA(400),SHELLN(400),SHELLT(400), G86DRV
* SHELLC(400),AOS(400),AON(400),NSHELL,MAXTYP G86DRV
INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON G86DRV
DIMENSION C4(400),SHLADF(400) G86DRV
EQUIVALENCE(C4(1),C3(401)),(SHLADF(1),C3(801)) G86DRV
G86DRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) G86DRV
DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G86DRV
G86DRV
Obtain the following information: G86DRV
G86DRV
ROHF =.TRUE. If RHF open shell wavefunction G86DRV
=.FALSE. otherwise G86DRV
G86DRV
UHF =.TRUE. If UHF wavefunction G86DRV
=.FALSE. otherwise G86DRV
G86DRV
AUHF =.TRUE. If spin-annihilated UHF wavefunction G86DRV
=.FALSE. otherwise G86DRV
G86DRV
CI =.TRUE. If CI wavefunction G86DRV
=.FALSE. otherwise G86DRV
G86DRV
OPEN =.TRUE. If open shell wavefunction G86DRV
=.FALSE. otherwise G86DRV
G86DRV
COMPLX =.TRUE. If complex wavefunction G86DRV
=.FALSE. otherwise G86DRV
(Note: The program is not capable of handling this.) G86DRV
G86DRV
NATOMS Number of atomic centers G86DRV
G86DRV
NDIM Dimension of matrices (overlap and density) G86DRV
G86DRV
NBAS Number of basis functions (.le.NDIM) G86DRV
G86DRV
IPSEUD Set to one if pseudopotentials are used. G86DRV
G86DRV
IWCUBF This pertains only basis sets with F functions. G86DRV
G86DRV
If cartesian F functions are input, set IWCUBF to: G86DRV
0, if these are to be transformed to the G86DRV
standard set of pure F functions G86DRV
1, if these are to be transformed to the G86DRV
cubic set of pure F functions G86DRV
G86DRV
If pure F functions are input, set to IWCUBF to: G86DRV
0, if these are standard F functions G86DRV
1, if these are cubic F functions G86DRV
G86DRV
IATNO(I),I=1,NATOMS G86DRV
List of atomic numbers G86DRV
G86DRV
LCTR(I),I=1,NBAS G86DRV
List of atomic centers of the basis functions G86DRV
(LCTR(3)=2 if basis function 3 is on atom 2) G86DRV
G86DRV
LANG(I),I=1,NBAS G86DRV
List of angular symmetry information for the AO basis G86DRV
G86DRV
DATA LISTS/ 1/ G86DRV
DATA LISTP/ 101, 102, 103/ G86DRV
DATA LISTD/ 255, 252, 253, 254, 251, 0, G86DRV
+ 201, 204, 206, 202, 203, 205/ G86DRV
DATA LISTF/ 351, 352, 353, 354, 355, 356, 357, 0, 0, 0, G86DRV
+ 301, 307, 310, 304, 302, 303, 306, 309, 308, 305/ G86DRV
DATA ZERO/0.0D0/ G86DRV
DATA TOANG/0.529177249/ G86DRV
G86DRV
Store job title on NBODAF: G86DRV
G86DRV
LEN = INTOWP(400+100) G86DRV
CALL TREAD(502,ICORE,LEN,1,LEN,1,0) G86DRV
NFILE = 2 G86DRV
CALL NBWRIT(ICORE(401),10,NFILE) G86DRV
G86DRV
Get the number of atoms from NAT and store the atomic numbers in G86DRV
IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G86DRV
nuclear charges may not be equivalent if effective core potentials G86DRV
(ECP) are used.) G86DRV
G86DRV
LEN = 0 G86DRV
IEXIST = ITQRY(512) G86DRV
IF(IEXIST.GT.0) THEN G86DRV
LEN = 8 * 400 + 17 * INTOWP(400) G86DRV
CALL TREAD(512,NLP,LEN,1,LEN,1,0) G86DRV
END IF G86DRV
NATOMS = NATOM G86DRV
DO 20 I = 1,NATOMS G86DRV
IATNO(I) = IAN(I) G86DRV
IF(IEXIST.GT.0) THEN G86DRV
IZNUC(I) = IATNO(I) - NFROZ(I) G86DRV
IF(NFROZ(I).NE.0) IPSEUD = 1 G86DRV
ELSE G86DRV
IZNUC(I) = IATNO(I) G86DRV
END IF G86DRV
20 CONTINUE G86DRV
G86DRV
Restore the basis set to COMMON/B/: G86DRV
G86DRV
LEN = 6000 + INTOWP(2802) G86DRV
CALL TREAD(506,EXX,LEN,1,LEN,1,0) G86DRV
G86DRV
The Gaussian programs do not use cubic f basis functions. G86DRV
Determine which set of d and f functions are being used, G86DRV
Cartesian or pure): G86DRV
G86DRV
IWCUBF = 0 G86DRV
CALL ILSW(2,2,I5D6D) G86DRV
CALL ILSW(2,16,I7F10F) G86DRV
G86DRV
Construct the AO information lists: LCTR and LANG G86DRV
G86DRV
IBAS = 0 G86DRV
DO 90 ISHELL = 1,400 G86DRV
IF(IBAS.EQ.NBASIS) GOTO 100 G86DRV
NCTR = JAN(ISHELL) G86DRV
MAXL = SHELLT(ISHELL) G86DRV
ICNSTR = SHELLC(ISHELL) G86DRV
G86DRV
Is an s orbital in the shell? G86DRV
G86DRV
KS = 0 G86DRV
IF(MAXL.EQ.0) KS = 1 G86DRV
IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G86DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G86DRV
IF(KS.EQ.0) GOTO 30 G86DRV
G86DRV
s orbital: G86DRV
G86DRV
IBAS = IBAS + 1 G86DRV
LCTR(IBAS) = NCTR G86DRV
LANG(IBAS) = LISTS G86DRV
G86DRV
Is a set of p orbitals in the shell? G86DRV
G86DRV
30 CONTINUE G86DRV
KP = 0 G86DRV
IF(MAXL.EQ.0) GOTO 90 G86DRV
IF(MAXL.EQ.1) KP = 1 G86DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G86DRV
IF(KP.EQ.0) GOTO 50 G86DRV
G86DRV
p orbitals: G86DRV
G86DRV
DO 40 I = 1,3 G86DRV
IBAS = IBAS + 1 G86DRV
LCTR(IBAS) = NCTR G86DRV
LANG(IBAS) = LISTP(I) G86DRV
40 CONTINUE G86DRV
G86DRV
d orbitals: G86DRV
G86DRV
50 IF(MAXL.NE.2) GOTO 70 G86DRV
IMAX = I5D6D + 5 G86DRV
KD = I5D6D + 1 G86DRV
DO 60 I = 1,IMAX G86DRV
IBAS = IBAS + 1 G86DRV
LCTR(IBAS) = NCTR G86DRV
LANG(IBAS) = LISTD(I,KD) G86DRV
60 CONTINUE G86DRV
GO TO 90 G86DRV
G86DRV
f orbitals: G86DRV
G86DRV
70 IF(MAXL.NE.3) GOTO 90 G86DRV
IMAX = 7 G86DRV
IF(I7F10F.EQ.1) IMAX = 10 G86DRV
KF = I7F10F + 1 G86DRV
DO 80 I = 1,IMAX G86DRV
IBAS = IBAS + 1 G86DRV
LCTR(IBAS) = NCTR G86DRV
LANG(IBAS) = LISTF(I,KF) G86DRV
80 CONTINUE G86DRV
90 CONTINUE G86DRV
100 CONTINUE G86DRV
NDIM = NBASIS G86DRV
NBAS = NBASIS G86DRV
G86DRV
Determine the type of wave function the density matrix is from: G86DRV
G86DRV
IF(MULTIP.GT.1) OPEN = .TRUE. G86DRV
IF(NBOOPT(2).NE.0) THEN G86DRV
CI = .TRUE. G86DRV
ELSE G86DRV
CALL ILSW(2,1,ISCF) G86DRV
CALL ILSW(2,22,IROHF) G86DRV
IF(ISCF.EQ.1) UHF = .TRUE. G86DRV
IF(UHF) OPEN = .TRUE. G86DRV
IF(IROHF.EQ.1) ROHF = .TRUE. G86DRV
IF(IROHF.EQ.2) ROHF = .TRUE. G86DRV
IF(IROHF.EQ.3) MCSCF = .TRUE. G86DRV
IF(ISCF.GT.1) COMPLX = .TRUE. G86DRV
IF(COMPLX) GOTO 900 G86DRV
END IF G86DRV
IF(NBOOPT(5).EQ.1) AUHF = .TRUE. G86DRV
ORTHO = .FALSE. G86DRV
G86DRV
No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G86DRV
G86DRV
IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G86DRV
G86DRV
Expectation values of the Fock operator are in atomic units: G86DRV
G86DRV
MUNIT = 0 G86DRV
G86DRV
Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G86DRV
G86DRV
ICORE(1) = NATOMS G86DRV
ICORE(2) = NDIM G86DRV
ICORE(3) = NBAS G86DRV
ICORE(4) = MUNIT G86DRV
ICORE(5) = 0 G86DRV
IF(ROHF) ICORE(5) = 1 G86DRV
ICORE(6) = 0 G86DRV
IF(UHF) ICORE(6) = 1 G86DRV
ICORE(7) = 0 G86DRV
IF(CI) ICORE(7) = 1 G86DRV
ICORE(8) = 0 G86DRV
IF(OPEN) ICORE(8) = 1 G86DRV
ICORE(9) = 0 G86DRV
IF(MCSCF) ICORE(9) = 1 G86DRV
ICORE(10) = 0 G86DRV
IF(AUHF) ICORE(10) = 1 G86DRV
ICORE(11) = 0 G86DRV
IF(ORTHO) ICORE(11) = 1 G86DRV
ICORE(12) = 1 G86DRV
NFILE = 3 G86DRV
CALL NBWRIT(ICORE,12,NFILE) G86DRV
G86DRV
Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G86DRV
G86DRV
II = 0 G86DRV
DO 120 I = 1,NATOMS G86DRV
II = II + 1 G86DRV
ICORE(II) = IATNO(I) G86DRV
120 CONTINUE G86DRV
DO 130 I = 1,NATOMS G86DRV
II = II + 1 G86DRV
ICORE(II) = IZNUC(I) G86DRV
130 CONTINUE G86DRV
DO 140 I = 1,NBAS G86DRV
II = II + 1 G86DRV
ICORE(II) = LCTR(I) G86DRV
140 CONTINUE G86DRV
DO 150 I = 1,NBAS G86DRV
II = II + 1 G86DRV
ICORE(II) = LANG(I) G86DRV
150 CONTINUE G86DRV
NFILE = 4 G86DRV
CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) G86DRV
G86DRV
Fetch the total energy from the RWF and store it on the NBODAF: G86DRV
G86DRV
CALL TREAD(501,CORE,32,1,32,1,0) G86DRV
CORE(1) = CORE(32) G86DRV
CORE(2) = CORE(32) G86DRV
NFILE = 8 G86DRV
CALL NBWRIT(CORE,2,NFILE) G86DRV
G86DRV
Store the atomic coordinates on the NBO DAF: (Note that these G86DRV
coordinates are used in the calculation of dipole moments.) G86DRV
G86DRV
DO 160 I = 1,3*NATOMS G86DRV
CORE(I) = C(I) * TOANG G86DRV
160 CONTINUE G86DRV
NFILE = 9 G86DRV
CALL NBWRIT(CORE,3*NATOMS,NFILE) G86DRV
G86DRV
Store the overlap matrix on the NBODAF: G86DRV
G86DRV
L2 = NDIM*(NDIM+1)/2 G86DRV
CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV
CALL PACK(CORE,NDIM,NBAS,L2) G86DRV
NFILE = 10 G86DRV
CALL NBWRIT(CORE,L2,NFILE) G86DRV
G86DRV
Store the density matrices on the NBODAF: G86DRV
G86DRV
L2 = NDIM*(NDIM+1)/2 G86DRV
IF(CI) THEN G86DRV
CALL TREAD(203,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV
CALL PACK(CORE,NDIM,NBAS,L2) G86DRV
NFILE = 20 G86DRV
CALL NBWRIT(CORE,L2,NFILE) G86DRV
IF(OPEN) THEN G86DRV
CALL TREAD(204,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV
CALL PACK(CORE,NDIM,NBAS,L2) G86DRV
NFILE = 21 G86DRV
CALL NBWRIT(CORE,L2,NFILE) G86DRV
END IF G86DRV
ELSE G86DRV
CALL TREAD(528,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV
CALL PACK(CORE,NDIM,NBAS,L2) G86DRV
NFILE = 20 G86DRV
CALL NBWRIT(CORE,L2,NFILE) G86DRV
IF(OPEN) THEN G86DRV
CALL TREAD(530,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV
CALL PACK(CORE,NDIM,NBAS,L2) G86DRV
NFILE = 21 G86DRV
CALL NBWRIT(CORE,L2,NFILE) G86DRV
END IF G86DRV
END IF G86DRV
G86DRV
Store the Fock matrices on the NBODAF: G86DRV
G86DRV
IF(IWFOCK.NE.0) THEN G86DRV
IEXIST = ITQRY(536) G86DRV
IF(IEXIST.GT.0) THEN G86DRV
L2 = NDIM*(NDIM+1)/2 G86DRV
CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV
CALL PACK(CORE,NDIM,NBAS,L2) G86DRV
NFILE = 30 G86DRV
CALL NBWRIT(CORE,L2,NFILE) G86DRV
END IF G86DRV
G86DRV
IF(OPEN) THEN G86DRV
IEXIST = ITQRY(538) G86DRV
IF(IEXIST.GT.0) THEN G86DRV
L2 = NDIM*(NDIM+1)/2 G86DRV
CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV
CALL PACK(CORE,NDIM,NBAS,L2) G86DRV
NFILE = 31 G86DRV
CALL NBWRIT(CORE,L2,NFILE) G86DRV
END IF G86DRV
END IF G86DRV
END IF G86DRV
G86DRV
Store the AO to MO transformation matrices on the NBODAF: G86DRV
G86DRV
IEXIST = ITQRY(524) G86DRV
IF(IEXIST.GT.0) THEN G86DRV
L3 = NDIM*NDIM G86DRV
CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0) G86DRV
NFILE = 40 G86DRV
CALL NBWRIT(CORE,L3,NFILE) G86DRV
END IF G86DRV
G86DRV
IF(OPEN) THEN G86DRV
IEXIST = ITQRY(526) G86DRV
IF(IEXIST.GT.0) THEN G86DRV
L3 = NDIM*NDIM G86DRV
CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0) G86DRV
NFILE = 41 G86DRV
CALL NBWRIT(CORE,L3,NFILE) G86DRV
END IF G86DRV
END IF G86DRV
G86DRV
Store the x,y,z dipole integrals on the NBODAF: G86DRV
G86DRV
IEXIST = ITQRY(518) G86DRV
IF(IEXIST.GT.0) THEN G86DRV
L2 = NDIM*(NDIM+1)/2 G86DRV
LEN = 3 * L2 G86DRV
CALL TREAD(518,CORE,LEN,1,LEN,1,0) G86DRV
DO 170 I = 1,LEN G86DRV
CORE(I) = CORE(I) * TOANG G86DRV
170 CONTINUE G86DRV
NFILE = 50 G86DRV
CALL NBWRIT(CORE,L2,NFILE) G86DRV
NFILE = 51 G86DRV
CALL NBWRIT(CORE(L2+1),L2,NFILE) G86DRV
NFILE = 52 G86DRV
CALL NBWRIT(CORE(2*L2+1),L2,NFILE) G86DRV
END IF G86DRV
G86DRV
Store the AO basis set info on the NBO DAF: (Note that two integers G86DRV
and three integer arrays are stored first. Also remember that ICORE G86DRV
and CORE occupy the same memory.) G86DRV
G86DRV
NEXP = 0 G86DRV
DO 180 I = 1,1200 G86DRV
IF(EXX(I).EQ.ZERO) GOTO 180 G86DRV
NEXP = I G86DRV
180 CONTINUE G86DRV
DO 190 I = 1,2+3*NSHELL+5*NEXP G86DRV
CORE(I) = ZERO G86DRV
190 CONTINUE G86DRV
ICORE(1) = NSHELL G86DRV
ICORE(2) = NEXP G86DRV
G86DRV
Determine if Cartesian or pure D and F functions are used: G86DRV
G86DRV
CALL ILSW(2,2,I5D6D) G86DRV
CALL ILSW(2,16,I7F10F) G86DRV
G86DRV
NCOMP(I) -- the number of components in the Ith shell: G86DRV
G86DRV
II = 2 G86DRV
DO 420 I = 1,NSHELL G86DRV
II = II + 1 G86DRV
ICORE(II) = 0 G86DRV
MAXL = SHELLT(I) G86DRV
ICNSTR = SHELLC(I) G86DRV
G86DRV
Determine if an S orbital is in the shell: G86DRV
G86DRV
KS = 0 G86DRV
IF(MAXL.EQ.0) KS = 1 G86DRV
IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G86DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G86DRV
IF(KS.EQ.0) GO TO 310 G86DRV
G86DRV
S orbital: G86DRV
G86DRV
ICORE(II) = ICORE(II) + 1 G86DRV
G86DRV
Determine if a set of P orbitals is in the shell: G86DRV
G86DRV
310 CONTINUE G86DRV
KP = 0 G86DRV
IF(MAXL.EQ.0) GO TO 400 G86DRV
IF(MAXL.EQ.1) KP = 1 G86DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G86DRV
IF(KP.EQ.0) GO TO 340 G86DRV
G86DRV
P orbital: G86DRV
G86DRV
ICORE(II) = ICORE(II) + 3 G86DRV
G86DRV
If MAXL is less than 2 then there are no D or F orbitals: G86DRV
If MAXL is greater than 2 then there must be F orbitals: G86DRV
G86DRV
340 IF(MAXL.LT.2) GO TO 400 G86DRV
IF(MAXL.GT.2) GO TO 370 G86DRV
G86DRV
D orbital: G86DRV
G86DRV
IMAX = I5D6D + 5 G86DRV
ICORE(II) = ICORE(II) + IMAX G86DRV
G86DRV
If MAXL is less than 3 then there are no F orbitals: G86DRV
G86DRV
370 IF(MAXL.LT.3) GO TO 400 G86DRV
G86DRV
F orbital: G86DRV
G86DRV
IMAX=7 G86DRV
IF(I7F10F.EQ.1) IMAX=10 G86DRV
ICORE(II) = ICORE(II) + IMAX G86DRV
G86DRV
Skip here when no more orbitals are found: G86DRV
G86DRV
400 CONTINUE G86DRV
420 CONTINUE G86DRV
G86DRV
NPRIM(I) -- the number of gaussian primitives in the Ith shell: G86DRV
G86DRV
DO 480 I = 1,NSHELL G86DRV
II = II + 1 G86DRV
ICORE(II) = SHELLN(I) G86DRV
480 CONTINUE G86DRV
G86DRV
NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G86DRV
EXP, CS, CP, etc.: G86DRV
G86DRV
DO 490 I = 1,NSHELL G86DRV
II = II + 1 G86DRV
ICORE(II) = SHELLA(I) G86DRV
490 CONTINUE G86DRV
G86DRV
EXP(I) -- orbital exponents indexed by NPTR: G86DRV
G86DRV
DO 500 I = 1,NEXP G86DRV
II = II + 1 G86DRV
CORE(II) = EXX(I) G86DRV
500 CONTINUE G86DRV
G86DRV
CS,CP -- orbital coefficients: G86DRV
G86DRV
DO 510 I = 1,NEXP G86DRV
II = II + 1 G86DRV
CORE(II) = C1(I) G86DRV
510 CONTINUE G86DRV
DO 520 I = 1,NEXP G86DRV
II = II + 1 G86DRV
CORE(II) = C2(I) G86DRV
520 CONTINUE G86DRV
G86DRV
Zero CD and CF arrays: G86DRV
G86DRV
IHOLD = II G86DRV
DO 550 I = 1,2*NEXP G86DRV
II = II + 1 G86DRV
CORE(II) = ZERO G86DRV
550 CONTINUE G86DRV
G86DRV
Build CD and CF from C3 and C4: G86DRV
G86DRV
DO 570 I = 1,NSHELL G86DRV
IPTR = SHLADF(I) G86DRV
IF(IPTR.GT.0) THEN G86DRV
DO 560 J = 1,SHELLN(I) G86DRV
LPTR = J + SHELLA(I) + IHOLD - 1 G86DRV
MPTR = J + IPTR - 1 G86DRV
CORE(LPTR) = C3(MPTR) G86DRV
CORE(LPTR+NEXP) = C4(MPTR) G86DRV
560 CONTINUE G86DRV
END IF G86DRV
570 CONTINUE G86DRV
NFILE = 5 G86DRV
CALL NBWRIT(CORE,II,NFILE) G86DRV
RETURN G86DRV
G86DRV
900 WRITE(LFNPR,1000) G86DRV
RETURN G86DRV
G86DRV
1000 FORMAT(/1X,'The NBO program is not set up to handle complex ', G86DRV
+ 'wave functions') G86DRV
END G86DRV
***********************************************************************G86DRV
SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G86DRV
***********************************************************************G86DRV
IMPLICIT REAL*8 (A-H,O-Z) G86DRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) G86DRV
LOGICAL NEW,ERROR,SEQ G86DRV
G86DRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G86DRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G86DRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G86DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G86DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G86DRV
+ LFNDAF,LFNDEF G86DRV
G86DRV
If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G86DRV
DAF to the RWFs. G86DRV
G86DRV
IF(NBOOPT(1).EQ.2) THEN G86DRV
NEW = .FALSE. G86DRV
CALL NBOPEN(NEW,ERROR) G86DRV
IF(ERROR) THEN G86DRV
WRITE(LFNPR,900) G86DRV
STOP G86DRV
END IF G86DRV
L2 = NDIM * (NDIM + 1)/2 G86DRV
IF(OPEN) THEN G86DRV
ALPHA = .TRUE. G86DRV
BETA = .FALSE. G86DRV
CALL FENEWD(CORE) G86DRV
CALL TWRITE(528,CORE,L2,1,L2,1,0) G86DRV
ALPHA = .FALSE. G86DRV
BETA = .TRUE. G86DRV
CALL FENEWD(CORE) G86DRV
CALL TWRITE(530,CORE,L2,1,L2,1,0) G86DRV
ELSE G86DRV
ALPHA = .FALSE. G86DRV
BETA = .FALSE. G86DRV
CALL FENEWD(CORE) G86DRV
CALL TWRITE(528,CORE,L2,1,L2,1,0) G86DRV
END IF G86DRV
SEQ = .FALSE. G86DRV
CALL NBCLOS(SEQ) G86DRV
END IF G86DRV
G86DRV
If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G86DRV
G86DRV
IF(NBOOPT(1).EQ.3) THEN G86DRV
NEW = .FALSE. G86DRV
CALL NBOPEN(NEW,ERROR) G86DRV
IF(ERROR) THEN G86DRV
WRITE(LFNPR,900) G86DRV
STOP G86DRV
END IF G86DRV
CALL TREAD(501,CORE,32,1,32,1,0) G86DRV
CALL SVE0(CORE(32)) G86DRV
SEQ = .FALSE. G86DRV
CALL NBCLOS(SEQ) G86DRV
END IF G86DRV
RETURN G86DRV
G86DRV
900 FORMAT(/1X,'Error opening the NBO direct access file in ', G86DRV
+ 'subroutine DELSCF.') G86DRV
END G86DRV
***********************************************************************G86DRV
G86DRV
E N D O F G 8 6 N B O R O U T I N E S G86DRV
G86DRV
***********************************************************************G86DRV
***********************************************************************G82DRV
G82DRV
G82DRV
G 8 2 N B O G82DRV
G82DRV
G82DRV
GAUSSIAN 82 VERSION OF NBO PROGRAM G82DRV
G82DRV
G82DRV
DRIVER ROUTINES: G82DRV
G82DRV
SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G82DRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G82DRV
SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G82DRV
G82DRV
***********************************************************************G82DRV
SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G82DRV
***********************************************************************G82DRV
IMPLICIT REAL*8 (A-H,O-Z) G82DRV
G82DRV
PARAMETER (MAXFIL = 40) G82DRV
G82DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G82DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G82DRV
+ LFNDAF,LFNDEF G82DRV
COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) G82DRV
CHARACTER*80 FILENM G82DRV
G82DRV
DIMENSION CORE(1),IOP(50) G82DRV
DIMENSION NBOOPT(10) G82DRV
G82DRV
LFNIN = 5 G82DRV
LFNPR = 6 G82DRV
G82DRV
DATA TENTH/0.1D0/ G82DRV
G82DRV
Set NBO options. G82DRV
G82DRV
DO 10 I = 1,9 G82DRV
NBOOPT(I) = IOP(I+39) G82DRV
10 CONTINUE G82DRV
NBOOPT(10) = 82 G82DRV
G82DRV
--- NBO analysis --- G82DRV
G82DRV
ICONTR = 0 G82DRV
IF(ABS(NBOOPT(1)).LT.2) THEN G82DRV
CALL CHARPN(4HNBO ) G82DRV
CALL NBO(CORE,MEMORY,NBOOPT) G82DRV
G82DRV
Store the name of the NBO direct access file on the RWFiles G82DRV
G82DRV
DO 20 I = 1,80 G82DRV
CORE(I) = ICHAR(FILENM(I:I)) G82DRV
20 CONTINUE G82DRV
CORE(81) = LFNDAF G82DRV
CALL TWRITE(636,CORE,81,1,81,1,0) G82DRV
G82DRV
--- NBO energetic analysis --- G82DRV
G82DRV
ELSE IF(NBOOPT(1).EQ.2) THEN G82DRV
G82DRV
Retrieve the name of the NBO direct access file from the RWFiles G82DRV
G82DRV
CALL TREAD(636,CORE,81,1,81,1,0) G82DRV
DO 30 I = 1,80 G82DRV
FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G82DRV
30 CONTINUE G82DRV
LFNDAF = INT(ABS(CORE(81)) + TENTH) G82DRV
CALL CHARPN(4HDELE) G82DRV
CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G82DRV
IF(IDONE.NE.0) ICONTR = 1 G82DRV
IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT) G82DRV
G82DRV
ELSE IF(NBOOPT(1).EQ.3) THEN G82DRV
CALL TREAD(636,CORE,81,1,81,1,0) G82DRV
DO 40 I = 1,80 G82DRV
FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G82DRV
40 CONTINUE G82DRV
LFNDAF = INT(ABS(CORE(81)) + TENTH) G82DRV
CALL CHARPN(4HEDEL) G82DRV
CALL DELSCF(CORE,CORE,NBOOPT) G82DRV
CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G82DRV
END IF G82DRV
G82DRV
RETURN G82DRV
END G82DRV
***********************************************************************G82DRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G82DRV
***********************************************************************G82DRV
IMPLICIT REAL*8 (A-H,O-Z) G82DRV
-----------------------------------------------------------------------G82DRV
G82DRV
Routine FEAOIN accesses the following records of the RWFs: G82DRV
G82DRV
203 --- CI density matrix (alpha) G82DRV
204 --- CI density matrix (beta) G82DRV
501 --- Total energy G82DRV
502 --- Job title G82DRV
506 --- Basis set information G82DRV
512 --- Effective core potential information G82DRV
514 --- AO overlap matrix G82DRV
518 --- x dipole integrals G82DRV
519 --- y dipole integrals G82DRV
520 --- z dipole integrals G82DRV
524 --- MO coefficients (alpha) G82DRV
526 --- MO coefficients (beta) G82DRV
528 --- SCF density matrix (alpha) G82DRV
530 --- SCF density matrix (beta) G82DRV
536 --- AO Fock matrix (alpha) G82DRV
538 --- AO Fock matrix (beta) G82DRV
G82DRV
----------------------------------------------------------------------G82DRV
G82DRV
NBO Common blocks G82DRV
G82DRV
PARAMETER(MAXATM = 99,MAXBAS = 500) G82DRV
G82DRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G82DRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G82DRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G82DRV
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, G82DRV
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, G82DRV
+ JCORE,JPRINT(60) G82DRV
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) G82DRV
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G82DRV
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) G82DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G82DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G82DRV
+ LFNDAF,LFNDEF G82DRV
G82DRV
GAUSSIAN 82 Common blocks G82DRV
G82DRV
COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(101), G82DRV
* ATMCHG(100),C(300) G82DRV
COMMON/LP2/NLP(400),CLP(400),ZLP(400),KFIRST(100,5), G82DRV
* KLAST(100,5),LMAX(100),LPSKIP(100),NFroz(100) G82DRV
COMMON/B/EXX(240),C1(240),C2(240),C3(240),X(80),Y(80), G82DRV
* Z(80),JAN(80),SHELLA(80),SHELLN(80),SHELLT(80), G82DRV
* SHELLC(80),AOS(80),AON(80),NSHELL,MAXTYP G82DRV
INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON G82DRV
DIMENSION C4(80),SHLADF(80) G82DRV
EQUIVALENCE(C4(1),C3(81)),(SHLADF(1),C3(161)) G82DRV
G82DRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) G82DRV
DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G82DRV
G82DRV
Obtain the following information: G82DRV
G82DRV
ROHF =.TRUE. If RHF open shell wavefunction G82DRV
=.FALSE. otherwise G82DRV
G82DRV
UHF =.TRUE. If UHF wavefunction G82DRV
=.FALSE. otherwise G82DRV
G82DRV
AUHF =.TRUE. If spin-annihilated UHF wavefunction G82DRV
=.FALSE. otherwise G82DRV
G82DRV
CI =.TRUE. If CI wavefunction G82DRV
=.FALSE. otherwise G82DRV
G82DRV
OPEN =.TRUE. If open shell wavefunction G82DRV
=.FALSE. otherwise G82DRV
G82DRV
COMPLX =.TRUE. If complex wavefunction G82DRV
=.FALSE. otherwise G82DRV
(Note: The program is not capable of handling this.) G82DRV
G82DRV
NATOMS Number of atomic centers G82DRV
G82DRV
NDIM Dimension of matrices (overlap and density) G82DRV
G82DRV
NBAS Number of basis functions (.le.NDIM) G82DRV
G82DRV
IPSEUD Set to one if pseudopotentials are used. G82DRV
G82DRV
IWCUBF This pertains only basis sets with F functions. G82DRV
G82DRV
If cartesian F functions are input, set IWCUBF to: G82DRV
0, if these are to be transformed to the G82DRV
standard set of pure F functions G82DRV
1, if these are to be transformed to the G82DRV
cubic set of pure F functions G82DRV
G82DRV
If pure F functions are input, set to IWCUBF to: G82DRV
0, if these are standard F functions G82DRV
1, if these are cubic F functions G82DRV
G82DRV
IATNO(I),I=1,NATOMS G82DRV
List of atomic numbers G82DRV
G82DRV
LCTR(I),I=1,NBAS G82DRV
List of atomic centers of the basis functions G82DRV
(LCTR(3)=2 if basis function 3 is on atom 2) G82DRV
G82DRV
LANG(I),I=1,NBAS G82DRV
List of angular symmetry information for the AO basis G82DRV
G82DRV
DATA LISTS/ 1/ G82DRV
DATA LISTP/ 101, 102, 103/ G82DRV
DATA LISTD/ 255, 252, 253, 254, 251, 0, G82DRV
+ 201, 204, 206, 202, 203, 205/ G82DRV
DATA LISTF/ 351, 352, 353, 354, 355, 356, 357, 0, 0, 0, G82DRV
+ 301, 307, 310, 304, 302, 303, 306, 309, 308, 305/ G82DRV
DATA ZERO/0.0D0/ G82DRV
DATA TOANG/0.529177249/ G82DRV
G82DRV
Store job title on NBODAF: G82DRV
G82DRV
LEN = INTOWP(500) G82DRV
CALL TREAD(502,ICORE,LEN,1,LEN,1,0) G82DRV
NFILE = 2 G82DRV
CALL NBWRIT(ICORE(401),10,NFILE) G82DRV
G82DRV
Get the number of atoms from NAT and store the atomic numbers in G82DRV
IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G82DRV
nuclear charges may not be equivalent if effective core potentials G82DRV
(ECP) are used.) G82DRV
G82DRV
LEN = 0 G82DRV
IEXIST = ITQRY(512) G82DRV
IF(IEXIST.GT.0) THEN G82DRV
LEN = 2 * 400 + 17 * INTOWP(100) G82DRV
CALL TREAD(512,NLP,LEN,1,LEN,1,0) G82DRV
END IF G82DRV
NATOMS = NATOM G82DRV
DO 20 I = 1,NATOMS G82DRV
IATNO(I) = IAN(I) G82DRV
IF(IEXIST.GT.0) THEN G82DRV
IZNUC(I) = IATNO(I) - NFROZ(I) G82DRV
IF(NFROZ(I).NE.0) IPSEUD = 1 G82DRV
ELSE G82DRV
IZNUC(I) = IATNO(I) G82DRV
END IF G82DRV
20 CONTINUE G82DRV
G82DRV
Restore the basis set to COMMON/B/: G82DRV
G82DRV
LEN = 1200 + INTOWP(562) G82DRV
CALL TREAD(506,EXX,LEN,1,LEN,1,0) G82DRV
G82DRV
The Gaussian programs do not use cubic f basis functions. G82DRV
Determine which set of d and f functions are being used, G82DRV
Cartesian or pure): G82DRV
G82DRV
IWCUBF = 0 G82DRV
CALL ILSW(2,2,I5D6D) G82DRV
CALL ILSW(2,16,I7F10F) G82DRV
G82DRV
Construct the AO information lists: LCTR and LANG G82DRV
G82DRV
IBAS = 0 G82DRV
DO 90 ISHELL = 1,80 G82DRV
IF(IBAS.EQ.NBASIS) GOTO 100 G82DRV
NCTR = JAN(ISHELL) G82DRV
MAXL = SHELLT(ISHELL) G82DRV
ICNSTR = SHELLC(ISHELL) G82DRV
G82DRV
Is an s orbital in the shell? G82DRV
G82DRV
KS = 0 G82DRV
IF(MAXL.EQ.0) KS = 1 G82DRV
IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G82DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G82DRV
IF(KS.EQ.0) GOTO 30 G82DRV
G82DRV
s orbital: G82DRV
G82DRV
IBAS = IBAS + 1 G82DRV
LCTR(IBAS) = NCTR G82DRV
LANG(IBAS) = LISTS G82DRV
G82DRV
Is a set of p orbitals in the shell? G82DRV
G82DRV
30 CONTINUE G82DRV
KP = 0 G82DRV
IF(MAXL.EQ.0) GOTO 90 G82DRV
IF(MAXL.EQ.1) KP = 1 G82DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G82DRV
IF(KP.EQ.0) GOTO 50 G82DRV
G82DRV
p orbitals: G82DRV
G82DRV
DO 40 I = 1,3 G82DRV
IBAS = IBAS + 1 G82DRV
LCTR(IBAS) = NCTR G82DRV
LANG(IBAS) = LISTP(I) G82DRV
40 CONTINUE G82DRV
G82DRV
d orbitals: G82DRV
G82DRV
50 IF(MAXL.NE.2) GOTO 70 G82DRV
IMAX = I5D6D + 5 G82DRV
KD = I5D6D + 1 G82DRV
DO 60 I = 1,IMAX G82DRV
IBAS = IBAS + 1 G82DRV
LCTR(IBAS) = NCTR G82DRV
LANG(IBAS) = LISTD(I,KD) G82DRV
60 CONTINUE G82DRV
GO TO 90 G82DRV
G82DRV
f orbitals: G82DRV
G82DRV
70 IF(MAXL.NE.3) GOTO 90 G82DRV
IMAX = 7 G82DRV
IF(I7F10F.EQ.1) IMAX = 10 G82DRV
KF = I7F10F + 1 G82DRV
DO 80 I = 1,IMAX G82DRV
IBAS = IBAS + 1 G82DRV
LCTR(IBAS) = NCTR G82DRV
LANG(IBAS) = LISTF(I,KF) G82DRV
80 CONTINUE G82DRV
90 CONTINUE G82DRV
100 CONTINUE G82DRV
NDIM = NBASIS G82DRV
NBAS = NBASIS G82DRV
G82DRV
Determine the type of wave function the density matrix is from: G82DRV
G82DRV
IF(MULTIP.GT.1) OPEN = .TRUE. G82DRV
IF(NBOOPT(2).NE.0) THEN G82DRV
CI = .TRUE. G82DRV
ELSE G82DRV
CALL ILSW(2,1,ISCF) G82DRV
CALL ILSW(2,22,IROHF) G82DRV
IF(ISCF.EQ.1) UHF = .TRUE. G82DRV
IF(UHF) OPEN = .TRUE. G82DRV
IF(IROHF.EQ.1) ROHF = .TRUE. G82DRV
IF(IROHF.EQ.2) ROHF = .TRUE. G82DRV
IF(IROHF.EQ.3) MCSCF = .TRUE. G82DRV
IF(ISCF.GT.1) COMPLX = .TRUE. G82DRV
IF(COMPLX) GOTO 900 G82DRV
END IF G82DRV
IF(NBOOPT(5).EQ.1) AUHF = .TRUE. G82DRV
ORTHO = .FALSE. G82DRV
G82DRV
No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G82DRV
G82DRV
IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G82DRV
G82DRV
Expectation values of the Fock operator are in atomic units: G82DRV
G82DRV
MUNIT = 0 G82DRV
G82DRV
Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G82DRV
G82DRV
ICORE(1) = NATOMS G82DRV
ICORE(2) = NDIM G82DRV
ICORE(3) = NBAS G82DRV
ICORE(4) = MUNIT G82DRV
ICORE(5) = 0 G82DRV
IF(ROHF) ICORE(5) = 1 G82DRV
ICORE(6) = 0 G82DRV
IF(UHF) ICORE(6) = 1 G82DRV
ICORE(7) = 0 G82DRV
IF(CI) ICORE(7) = 1 G82DRV
ICORE(8) = 0 G82DRV
IF(OPEN) ICORE(8) = 1 G82DRV
ICORE(9) = 0 G82DRV
IF(MCSCF) ICORE(9) = 1 G82DRV
ICORE(10) = 0 G82DRV
IF(AUHF) ICORE(10) = 1 G82DRV
ICORE(11) = 0 G82DRV
IF(ORTHO) ICORE(11) = 1 G82DRV
ICORE(12) = 1 G82DRV
NFILE = 3 G82DRV
CALL NBWRIT(ICORE,12,NFILE) G82DRV
G82DRV
Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G82DRV
G82DRV
II = 0 G82DRV
DO 120 I = 1,NATOMS G82DRV
II = II + 1 G82DRV
ICORE(II) = IATNO(I) G82DRV
120 CONTINUE G82DRV
DO 130 I = 1,NATOMS G82DRV
II = II + 1 G82DRV
ICORE(II) = IZNUC(I) G82DRV
130 CONTINUE G82DRV
DO 140 I = 1,NBAS G82DRV
II = II + 1 G82DRV
ICORE(II) = LCTR(I) G82DRV
140 CONTINUE G82DRV
DO 150 I = 1,NBAS G82DRV
II = II + 1 G82DRV
ICORE(II) = LANG(I) G82DRV
150 CONTINUE G82DRV
NFILE = 4 G82DRV
CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) G82DRV
G82DRV
Fetch the total energy from the RWF and store it on the NBODAF: G82DRV
G82DRV
CALL TREAD(501,CORE,32,1,32,1,0) G82DRV
CORE(1) = CORE(32) G82DRV
CORE(2) = CORE(32) G82DRV
NFILE = 8 G82DRV
CALL NBWRIT(CORE,2,NFILE) G82DRV
G82DRV
Store the atomic coordinates on the NBO DAF: (Note that these G82DRV
coordinates are used in the calculation of dipole moments.) G82DRV
G82DRV
DO 160 I = 1,3*NATOMS G82DRV
CORE(I) = C(I) * TOANG G82DRV
160 CONTINUE G82DRV
NFILE = 9 G82DRV
CALL NBWRIT(CORE,3*NATOMS,NFILE) G82DRV
G82DRV
Store the overlap matrix on the NBODAF: G82DRV
G82DRV
L2 = NDIM*(NDIM+1)/2 G82DRV
CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV
CALL PACK(CORE,NDIM,NBAS,L2) G82DRV
NFILE = 10 G82DRV
CALL NBWRIT(CORE,L2,NFILE) G82DRV
G82DRV
Store the density matrices on the NBODAF: G82DRV
G82DRV
L2 = NDIM*(NDIM+1)/2 G82DRV
IF(CI) THEN G82DRV
CALL TREAD(203,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV
CALL PACK(CORE,NDIM,NBAS,L2) G82DRV
NFILE = 20 G82DRV
CALL NBWRIT(CORE,L2,NFILE) G82DRV
IF(OPEN) THEN G82DRV
CALL TREAD(204,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV
CALL PACK(CORE,NDIM,NBAS,L2) G82DRV
NFILE = 21 G82DRV
CALL NBWRIT(CORE,L2,NFILE) G82DRV
END IF G82DRV
ELSE G82DRV
CALL TREAD(528,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV
CALL PACK(CORE,NDIM,NBAS,L2) G82DRV
NFILE = 20 G82DRV
CALL NBWRIT(CORE,L2,NFILE) G82DRV
IF(OPEN) THEN G82DRV
CALL TREAD(530,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV
CALL PACK(CORE,NDIM,NBAS,L2) G82DRV
NFILE = 21 G82DRV
CALL NBWRIT(CORE,L2,NFILE) G82DRV
END IF G82DRV
END IF G82DRV
G82DRV
Store the Fock matrices on the NBODAF: G82DRV
G82DRV
IF(IWFOCK.NE.0) THEN G82DRV
IEXIST = ITQRY(536) G82DRV
IF(IEXIST.GT.0) THEN G82DRV
L2 = NDIM*(NDIM+1)/2 G82DRV
CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV
CALL PACK(CORE,NDIM,NBAS,L2) G82DRV
NFILE = 30 G82DRV
CALL NBWRIT(CORE,L2,NFILE) G82DRV
END IF G82DRV
G82DRV
IF(OPEN) THEN G82DRV
IEXIST = ITQRY(538) G82DRV
IF(IEXIST.GT.0) THEN G82DRV
L2 = NDIM*(NDIM+1)/2 G82DRV
CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV
CALL PACK(CORE,NDIM,NBAS,L2) G82DRV
NFILE = 31 G82DRV
CALL NBWRIT(CORE,L2,NFILE) G82DRV
END IF G82DRV
END IF G82DRV
END IF G82DRV
G82DRV
Store the AO to MO transformation matrices on the NBODAF: G82DRV
G82DRV
IEXIST = ITQRY(524) G82DRV
IF(IEXIST.GT.0) THEN G82DRV
L3 = NDIM*NDIM G82DRV
CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0) G82DRV
NFILE = 40 G82DRV
CALL NBWRIT(CORE,L3,NFILE) G82DRV
END IF G82DRV
G82DRV
IF(OPEN) THEN G82DRV
IEXIST = ITQRY(526) G82DRV
IF(IEXIST.GT.0) THEN G82DRV
L3 = NDIM*NDIM G82DRV
CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0) G82DRV
NFILE = 41 G82DRV
CALL NBWRIT(CORE,L3,NFILE) G82DRV
END IF G82DRV
END IF G82DRV
G82DRV
Store the x,y,z dipole integrals on the NBODAF: G82DRV
G82DRV
IEXIST = ITQRY(518) G82DRV
IEXIST = MIN(IEXIST,ITQRY(519)) G82DRV
IEXIST = MIN(IEXIST,ITQRY(520)) G82DRV
IF(IEXIST.GT.0) THEN G82DRV
L2 = NDIM*(NDIM+1)/2 G82DRV
CALL TREAD(518,CORE(1),L2,1,L2,1,0) G82DRV
CALL TREAD(519,CORE(L2+1),L2,1,L2,1,0) G82DRV
CALL TREAD(520,CORE(2*L2+1),L2,1,L2,1,0) G82DRV
DO 170 I = 1,3*L2 G82DRV
CORE(I) = CORE(I) * TOANG G82DRV
170 CONTINUE G82DRV
NFILE = 50 G82DRV
CALL NBWRIT(CORE,L2,NFILE) G82DRV
NFILE = 51 G82DRV
CALL NBWRIT(CORE(L2+1),L2,NFILE) G82DRV
NFILE = 52 G82DRV
CALL NBWRIT(CORE(2*L2+1),L2,NFILE) G82DRV
END IF G82DRV
G82DRV
Store the AO basis set info on the NBO DAF: (Note that two integers G82DRV
and three integer arrays are stored first. Also remember that ICORE G82DRV
and CORE occupy the same memory.) G82DRV
G82DRV
NEXP = 0 G82DRV
DO 180 I = 1,240 G82DRV
IF(EXX(I).EQ.ZERO) GOTO 180 G82DRV
NEXP = I G82DRV
180 CONTINUE G82DRV
DO 190 I = 1,2+3*NSHELL+5*NEXP G82DRV
CORE(I) = ZERO G82DRV
190 CONTINUE G82DRV
ICORE(1) = NSHELL G82DRV
ICORE(2) = NEXP G82DRV
G82DRV
Determine if Cartesian or pure D and F functions are used: G82DRV
G82DRV
CALL ILSW(2,2,I5D6D) G82DRV
CALL ILSW(2,16,I7F10F) G82DRV
G82DRV
NCOMP(I) -- the number of components in the Ith shell: G82DRV
G82DRV
II = 2 G82DRV
DO 420 I = 1,NSHELL G82DRV
II = II + 1 G82DRV
ICORE(II) = 0 G82DRV
MAXL = SHELLT(I) G82DRV
ICNSTR = SHELLC(I) G82DRV
G82DRV
Determine if an S orbital is in the shell: G82DRV
G82DRV
KS = 0 G82DRV
IF(MAXL.EQ.0) KS = 1 G82DRV
IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G82DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G82DRV
IF(KS.EQ.0) GO TO 310 G82DRV
G82DRV
S orbital: G82DRV
G82DRV
ICORE(II) = ICORE(II) + 1 G82DRV
G82DRV
Determine if a set of P orbitals is in the shell: G82DRV
G82DRV
310 CONTINUE G82DRV
KP = 0 G82DRV
IF(MAXL.EQ.0) GO TO 400 G82DRV
IF(MAXL.EQ.1) KP = 1 G82DRV
IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G82DRV
IF(KP.EQ.0) GO TO 340 G82DRV
G82DRV
P orbital: G82DRV
G82DRV
ICORE(II) = ICORE(II) + 3 G82DRV
G82DRV
If MAXL is less than 2 then there are no D or F orbitals: G82DRV
If MAXL is greater than 2 then there must be F orbitals: G82DRV
G82DRV
340 IF(MAXL.LT.2) GO TO 400 G82DRV
IF(MAXL.GT.2) GO TO 370 G82DRV
G82DRV
D orbital: G82DRV
G82DRV
IMAX = I5D6D + 5 G82DRV
ICORE(II) = ICORE(II) + IMAX G82DRV
G82DRV
If MAXL is less than 3 then there are no F orbitals: G82DRV
G82DRV
370 IF(MAXL.LT.3) GO TO 400 G82DRV
G82DRV
F orbital: G82DRV
G82DRV
IMAX=7 G82DRV
IF(I7F10F.EQ.1) IMAX=10 G82DRV
ICORE(II) = ICORE(II) + IMAX G82DRV
G82DRV
Skip here when no more orbitals are found: G82DRV
G82DRV
400 CONTINUE G82DRV
420 CONTINUE G82DRV
G82DRV
NPRIM(I) -- the number of gaussian primitives in the Ith shell: G82DRV
G82DRV
DO 480 I = 1,NSHELL G82DRV
II = II + 1 G82DRV
ICORE(II) = SHELLN(I) G82DRV
480 CONTINUE G82DRV
G82DRV
NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G82DRV
EXP, CS, CP, etc.: G82DRV
G82DRV
DO 490 I = 1,NSHELL G82DRV
II = II + 1 G82DRV
ICORE(II) = SHELLA(I) G82DRV
490 CONTINUE G82DRV
G82DRV
EXP(I) -- orbital exponents indexed by NPTR: G82DRV
G82DRV
DO 500 I = 1,NEXP G82DRV
II = II + 1 G82DRV
CORE(II) = EXX(I) G82DRV
500 CONTINUE G82DRV
G82DRV
CS,CP -- orbital coefficients: G82DRV
G82DRV
DO 510 I = 1,NEXP G82DRV
II = II + 1 G82DRV
CORE(II) = C1(I) G82DRV
510 CONTINUE G82DRV
DO 520 I = 1,NEXP G82DRV
II = II + 1 G82DRV
CORE(II) = C2(I) G82DRV
520 CONTINUE G82DRV
G82DRV
Zero CD and CF arrays: G82DRV
G82DRV
IHOLD = II G82DRV
DO 550 I = 1,2*NEXP G82DRV
II = II + 1 G82DRV
CORE(II) = ZERO G82DRV
550 CONTINUE G82DRV
G82DRV
Build CD and CF from C3 and C4: G82DRV
G82DRV
DO 570 I = 1,NSHELL G82DRV
IPTR = SHLADF(I) G82DRV
IF(IPTR.GT.0) THEN G82DRV
DO 560 J = 1,SHELLN(I) G82DRV
LPTR = J + SHELLA(I) + IHOLD - 1 G82DRV
MPTR = J + IPTR - 1 G82DRV
CORE(LPTR) = C3(MPTR) G82DRV
CORE(LPTR+NEXP) = C4(MPTR) G82DRV
560 CONTINUE G82DRV
END IF G82DRV
570 CONTINUE G82DRV
NFILE = 5 G82DRV
CALL NBWRIT(CORE,II,NFILE) G82DRV
RETURN G82DRV
G82DRV
900 WRITE(LFNPR,1000) G82DRV
RETURN G82DRV
G82DRV
1000 FORMAT(/1X,'The NBO program is not set up to handle complex ', G82DRV
+ 'wave functions') G82DRV
END G82DRV
***********************************************************************G82DRV
SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G82DRV
***********************************************************************G82DRV
IMPLICIT REAL*8 (A-H,O-Z) G82DRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) G82DRV
LOGICAL NEW,ERROR,SEQ G82DRV
G82DRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G82DRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G82DRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G82DRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G82DRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G82DRV
+ LFNDAF,LFNDEF G82DRV
G82DRV
If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G82DRV
DAF to the RWFs. G82DRV
G82DRV
IF(NBOOPT(1).EQ.2) THEN G82DRV
NEW = .FALSE. G82DRV
CALL NBOPEN(NEW,ERROR) G82DRV
IF(ERROR) THEN G82DRV
WRITE(LFNPR,900) G82DRV
STOP G82DRV
END IF G82DRV
L2 = NDIM * (NDIM + 1)/2 G82DRV
IF(OPEN) THEN G82DRV
ALPHA = .TRUE. G82DRV
BETA = .FALSE. G82DRV
CALL FENEWD(CORE) G82DRV
CALL TWRITE(528,CORE,L2,1,L2,1,0) G82DRV
ALPHA = .FALSE. G82DRV
BETA = .TRUE. G82DRV
CALL FENEWD(CORE) G82DRV
CALL TWRITE(530,CORE,L2,1,L2,1,0) G82DRV
ELSE G82DRV
ALPHA = .FALSE. G82DRV
BETA = .FALSE. G82DRV
CALL FENEWD(CORE) G82DRV
CALL TWRITE(528,CORE,L2,1,L2,1,0) G82DRV
END IF G82DRV
SEQ = .FALSE. G82DRV
CALL NBCLOS(SEQ) G82DRV
END IF G82DRV
G82DRV
If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G82DRV
G82DRV
IF(NBOOPT(1).EQ.3) THEN G82DRV
NEW = .FALSE. G82DRV
CALL NBOPEN(NEW,ERROR) G82DRV
IF(ERROR) THEN G82DRV
WRITE(LFNPR,900) G82DRV
STOP G82DRV
END IF G82DRV
CALL TREAD(501,CORE,32,1,32,1,0) G82DRV
CALL SVE0(CORE(32)) G82DRV
SEQ = .FALSE. G82DRV
CALL NBCLOS(SEQ) G82DRV
END IF G82DRV
RETURN G82DRV
G82DRV
900 FORMAT(/1X,'Error opening the NBO direct access file in ', G82DRV
+ 'subroutine DELSCF.') G82DRV
END G82DRV
***********************************************************************G82DRV
G82DRV
E N D O F G 8 2 N B O R O U T I N E S G82DRV
G82DRV
***********************************************************************G82DRV
***********************************************************************GMSDRV
GMSDRV
GMSDRV
G M S N B O GMSDRV
GMSDRV
GMSDRV
GAMESS VERSION OF NBO PROGRAM GMSDRV
GMSDRV
GMSDRV
DRIVER ROUTINES: GMSDRV
GMSDRV
SUBROUTINE RUNNBO GMSDRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GMSDRV
SUBROUTINE DELSCF(A,IA) GMSDRV
GMSDRV
***********************************************************************GMSDRV
SUBROUTINE RUNNBO GMSDRV
***********************************************************************GMSDRV
IMPLICIT REAL*8 (A-H,O-Z) GMSDRV
DIMENSION NBOOPT(10) GMSDRV
GMSDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GMSDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GMSDRV
+ LFNDAF,LFNDEF GMSDRV
GMSDRV
GAMESS Common Block: GMSDRV
GMSDRV
COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(99) GMSDRV
COMMON /FMCOM/ CORE(1) GMSDRV
GMSDRV
LFNIN = IR GMSDRV
LFNPR = IW GMSDRV
GMSDRV
Determine the amount of available memory for the NBO analysis. GMSDRV
GMSDRV
CALL VALFM(ICUR) GMSDRV
CALL GOTFM(MEMORY) GMSDRV
GMSDRV
Set NBO options. GMSDRV
GMSDRV
NBOOPT(1) = 0 GMSDRV
NBOOPT(2) = 0 GMSDRV
NBOOPT(3) = 0 GMSDRV
NBOOPT(4) = 0 GMSDRV
NBOOPT(5) = 0 GMSDRV
NBOOPT(6) = 0 GMSDRV
NBOOPT(7) = 0 GMSDRV
NBOOPT(8) = 0 GMSDRV
NBOOPT(9) = 0 GMSDRV
NBOOPT(10) = 6 GMSDRV
GMSDRV
Perform the NPA/NBO/NLMO analyses. GMSDRV
GMSDRV
CALL NBO(CORE(ICUR+1),MEMORY,NBOOPT) GMSDRV
GMSDRV
Perform the energetic analysis. GMSDRV
GMSDRV
10 NBOOPT(1) = 2 GMSDRV
CALL NBOEAN(CORE(ICUR+1),MEMORY,NBOOPT,IDONE) GMSDRV
IF(IDONE.NE.0) GOTO 20 GMSDRV
CALL DELSCF(CORE(ICUR+1),CORE(ICUR+1)) GMSDRV
NBOOPT(1) = 3 GMSDRV
CALL NBOEAN(CORE(ICUR+1),MEMORY,NBOOPT,IDONE) GMSDRV
GOTO 10 GMSDRV
GMSDRV
20 RETURN GMSDRV
END GMSDRV
***********************************************************************GMSDRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GMSDRV
***********************************************************************GMSDRV
IMPLICIT REAL*8 (A-H,O-Z) GMSDRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) GMSDRV
GMSDRV
----------------------------------------------------------------------GMSDRV
GMSDRV
This routine fetchs basis set information from the GAMESS common GMSDRV
blocks and stores it in the NBO common blocks and direct access file GMSDRV
(DAF) for use by the NBO analysis. GMSDRV
GMSDRV
----------------------------------------------------------------------GMSDRV
GMSDRV
Routine FEAOIN accesses the following records of the dictionary file:GMSDRV
GMSDRV
2 --- Total energy GMSDRV
12 --- AO overlap matrix GMSDRV
14 --- AO Fock matrix (alpha) GMSDRV
15 --- AO to MO transformation matrix (alpha) GMSDRV
16 --- AO density matrix (bond order matrix) (alpha) GMSDRV
18 --- AO Fock matrix (beta) GMSDRV
19 --- AO to MO transformation matrix (beta) GMSDRV
20 --- AO density matrix (bond order matrix) (beta) GMSDRV
23 --- X dipole integrals GMSDRV
24 --- Y dipole integrals GMSDRV
25 --- Z dipole integrals GMSDRV
GMSDRV
----------------------------------------------------------------------GMSDRV
GMSDRV
NBO Common blocks GMSDRV
GMSDRV
GMSDRV
PARAMETER(MAXATM = 99,MAXBAS = 500) GMSDRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GMSDRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GMSDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GMSDRV
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, GMSDRV
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, GMSDRV
+ JCORE,JPRINT(60) GMSDRV
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) GMSDRV
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), GMSDRV
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) GMSDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GMSDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GMSDRV
+ LFNDAF,LFNDEF GMSDRV
GMSDRV
DIMENSION LABELS(20),WFNS(6) GMSDRV
LOGICAL WSTATE(6,6) GMSDRV
GMSDRV
GAMESS Common blocks GMSDRV
GMSDRV
PARAMETER (MXGTOT=5000, MXSH=1000, MXATM=50) GMSDRV
COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(2047) GMSDRV
COMMON /XYZPRP/ X(3),PAD(35) GMSDRV
COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(99) GMSDRV
COMMON /INFOA / NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(MXATM),C(3,MXATM) GMSDRV
COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT), GMSDRV
* CF(MXGTOT),CG(MXGTOT), GMSDRV
* KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH), GMSDRV
* KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL GMSDRV
COMMON /SCFOPT/ SCFTYP,BLKTYP,MAXIT,MCONV,NCONV,NPUNCH GMSDRV
COMMON /ECP2 / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6), GMSDRV
* KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM), GMSDRV
* IZCORE(MXATM) GMSDRV
GMSDRV
Obtain the following information: GMSDRV
GMSDRV
ROHF =.TRUE. If RHF open shell wavefunction GMSDRV
=.FALSE. otherwise GMSDRV
GMSDRV
UHF =.TRUE. If UHF wavefunction GMSDRV
=.FALSE. otherwise GMSDRV
GMSDRV
AUHF =.TRUE. If spin-annihilated UHF wavefunction GMSDRV
=.FALSE. otherwise GMSDRV
GMSDRV
CI =.TRUE. If CI wavefunction GMSDRV
=.FALSE. otherwise GMSDRV
GMSDRV
OPEN =.TRUE. If open shell wavefunction GMSDRV
=.FALSE. otherwise GMSDRV
GMSDRV
COMPLX =.TRUE. If complex wavefunction GMSDRV
=.FALSE. otherwise GMSDRV
(Note: The program is not capable of handling this.) GMSDRV
GMSDRV
NATOMS Number of atomic centers GMSDRV
GMSDRV
NDIM Dimension of matrices (overlap and density) GMSDRV
GMSDRV
NBAS Number of basis functions (.le.NDIM) GMSDRV
GMSDRV
IPSEUD Set to one if pseudopotentials are used. GMSDRV
GMSDRV
IWCUBF This pertains only basis sets with F functions. GMSDRV
GMSDRV
If cartesian F functions are input, set IWCUBF to: GMSDRV
0, if these are to be transformed to the GMSDRV
standard set of pure F functions GMSDRV
1, if these are to be transformed to the GMSDRV
cubic set of pure F functions GMSDRV
GMSDRV
If pure F functions are input, set to IWCUBF to: GMSDRV
0, if these are standard F functions GMSDRV
1, if these are cubic F functions GMSDRV
GMSDRV
IATNO(I),I=1,NATOMS GMSDRV
List of atomic numbers GMSDRV
GMSDRV
LCTR(I),I=1,NBAS GMSDRV
List of atomic centers of the basis functions GMSDRV
(LCTR(3)=2 if basis function 3 is on atom 2) GMSDRV
GMSDRV
LANG(I),I=1,NBAS GMSDRV
List of angular symmetry information for the basis GMSDRV
functions GMSDRV
GMSDRV
LABELS array contains NBO labels for the atomic orbitals GMSDRV
GMSDRV
DATA LABELS / GMSDRV
GMSDRV
s GMSDRV
--- GMSDRV
+ 1, GMSDRV
GMSDRV
px py pz GMSDRV
--- --- --- GMSDRV
+ 101, 102, 103, GMSDRV
GMSDRV
dxx dyy dzz dxy dxz dyz GMSDRV
--- --- --- --- --- --- GMSDRV
+ 201, 204, 206, 202, 203, 205, GMSDRV
GMSDRV
fxxx fyyy fzzz fxxy fxxz fxyy fxyz fxzz fyyz fyzz GMSDRV
---- ---- ---- ---- ---- ---- ---- ---- ---- ---- GMSDRV
+ 301, 307, 310, 302, 303, 304, 305, 306, 308, 309 / GMSDRV
GMSDRV
GMSDRV
WSTATE array contains the values which should be set in the NBO GMSDRV
common block /NBFLAG/ depending on wavefunction. GMSDRV
GMSDRV
DATA WSTATE / GMSDRV
logical variable in common NBFLAG GMSDRV
ROHF UHF CI OPEN MCSCF AUHF GMSDRV
------- ------- ------ ------ ------ ------ GMSDRV
Wavefunction GMSDRV
RHF GMSDRV
+ .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., GMSDRV
UHF GMSDRV
+ .FALSE., .TRUE. , .FALSE., .TRUE. , .FALSE., .FALSE., GMSDRV
ROHF GMSDRV
+ .TRUE. , .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., GMSDRV
GVB GMSDRV
+ .TRUE., .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., GMSDRV
MCSCF GMSDRV
+ .FALSE., .FALSE., .FALSE., .FALSE., .TRUE. , .FALSE., GMSDRV
CI GMSDRV
+ .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., .FALSE./ GMSDRV
GMSDRV
GMSDRV
Wavefunction types: GMSDRV
GMSDRV
DATA WFNS /8HRHF , GMSDRV
+ 8HUHF , GMSDRV
+ 8HROHF , GMSDRV
+ 8HGVB , GMSDRV
+ 8HMCSCF , GMSDRV
+ 8HCI / GMSDRV
GMSDRV
DATA ZERO/0.0D0/ GMSDRV
DATA TOANG/0.529177249/ GMSDRV
GMSDRV
Store job title on NBODAF: GMSDRV
GMSDRV
DO 5 I = 1,10 GMSDRV
CORE(I) = TITLE(I) GMSDRV
5 CONTINUE GMSDRV
NFILE = 2 GMSDRV
CALL NBWRIT(CORE,10,NFILE) GMSDRV
GMSDRV
Get the number of atoms from NAT and store the atomic numbers in GMSDRV
IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and GMSDRV
nuclear charges may not be equivalent if effective core potentials GMSDRV
(ECP) are used.) GMSDRV
GMSDRV
NATOMS = NAT GMSDRV
DO 10 I = 1,NAT GMSDRV
IATNO(I) = ZAN(I) + IZCORE(I) GMSDRV
IZNUC(I) = ZAN(I) GMSDRV
IF(IZCORE(I).NE.0) IPSEUD = 1 GMSDRV
10 CONTINUE GMSDRV
GMSDRV
KATOM array contains which atom the shell is on, KMIN and KMAX GMSDRV
determine the components in the shell by pointing to a range in the GMSDRV
LABELS array: GMSDRV
GMSDRV
II = 0 GMSDRV
DO 30 I = 1,NSHELL GMSDRV
IATOM = KATOM(I) GMSDRV
MIN = KMIN(I) GMSDRV
MAX = KMAX(I) GMSDRV
DO 20 J = MIN,MAX GMSDRV
II = II + 1 GMSDRV
LCTR(II) = IATOM GMSDRV
LANG(II) = LABELS(J) GMSDRV
20 CONTINUE GMSDRV
30 CONTINUE GMSDRV
GMSDRV
NBAS = II GMSDRV
NDIM = NBAS GMSDRV
GMSDRV
Inititialize various NBO options depending upon the wavefunction GMSDRV
type and basis set type. GMSDRV
GMSDRV
First, turn off the complex orbitals, indicate that the pure set GMSDRV
of F functions is desired when transforming from the cartesian set. GMSDRV
GMSDRV
COMPLX = .FALSE. GMSDRV
IWCUBF = 0 GMSDRV
ORTHO = .FALSE. GMSDRV
GMSDRV
Next set up the wavefunction flags. GMSDRV
GMSDRV
DO 50 I = 1,6 GMSDRV
ISTATE = I GMSDRV
IF (SCFTYP.EQ.WFNS(I)) GOTO 60 GMSDRV
50 CONTINUE GMSDRV
STOP 'Unknown WFNTYP' GMSDRV
GMSDRV
60 ROHF = WSTATE(1,ISTATE) GMSDRV
UHF = WSTATE(2,ISTATE) GMSDRV
CI = WSTATE(3,ISTATE) GMSDRV
OPEN = WSTATE(4,ISTATE) GMSDRV
MCSCF = WSTATE(5,ISTATE) GMSDRV
AUHF = WSTATE(6,ISTATE) GMSDRV
GMSDRV
No Fock matrices for ROHF, MCSCF, or CI wavefunctions: GMSDRV
GMSDRV
IF (ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 GMSDRV
GMSDRV
Expectation values of the Fock operator are in atomic units: GMSDRV
GMSDRV
MUNIT = 0 GMSDRV
GMSDRV
Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: GMSDRV
GMSDRV
ICORE(1) = NATOMS GMSDRV
ICORE(2) = NDIM GMSDRV
ICORE(3) = NBAS GMSDRV
ICORE(4) = MUNIT GMSDRV
ICORE(5) = 0 GMSDRV
IF(ROHF) ICORE(5) = 1 GMSDRV
ICORE(6) = 0 GMSDRV
IF(UHF) ICORE(6) = 1 GMSDRV
ICORE(7) = 0 GMSDRV
IF(CI) ICORE(7) = 1 GMSDRV
ICORE(8) = 0 GMSDRV
IF(OPEN) ICORE(8) = 1 GMSDRV
ICORE(9) = 0 GMSDRV
IF(MCSCF) ICORE(9) = 1 GMSDRV
ICORE(10) = 0 GMSDRV
IF(AUHF) ICORE(10) = 1 GMSDRV
ICORE(11) = 0 GMSDRV
IF(ORTHO) ICORE(11) = 1 GMSDRV
ICORE(12) = 1 GMSDRV
NFILE = 3 GMSDRV
CALL NBWRIT(ICORE,12,NFILE) GMSDRV
GMSDRV
Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: GMSDRV
GMSDRV
II = 0 GMSDRV
DO 70 I = 1,NATOMS GMSDRV
II = II + 1 GMSDRV
ICORE(II) = IATNO(I) GMSDRV
70 CONTINUE GMSDRV
DO 80 I = 1,NATOMS GMSDRV
II = II + 1 GMSDRV
ICORE(II) = IZNUC(I) GMSDRV
80 CONTINUE GMSDRV
DO 90 I = 1,NBAS GMSDRV
II = II + 1 GMSDRV
ICORE(II) = LCTR(I) GMSDRV
90 CONTINUE GMSDRV
DO 95 I = 1,NBAS GMSDRV
II = II + 1 GMSDRV
ICORE(II) = LANG(I) GMSDRV
95 CONTINUE GMSDRV
NFILE = 4 GMSDRV
CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) GMSDRV
GMSDRV
Fetch the total energy from the dictionary file and store it on the GMSDRV
NBO DAF: GMSDRV
GMSDRV
NFILE = 2 GMSDRV
CALL DAREAD(IDAF,IODA,CORE,3,NFILE,NAV) GMSDRV
CORE(1) = CORE(3) GMSDRV
CORE(2) = CORE(3) GMSDRV
NFILE = 8 GMSDRV
CALL NBWRIT(CORE,2,NFILE) GMSDRV
GMSDRV
Store the atomic coordinates on the NBO DAF: (Note that these GMSDRV
coordinates are used in the calculation of dipole moments. GAMESS GMSDRV
requires the Cartesian origin to be at the center of mass!!) GMSDRV
GMSDRV
I = 0 GMSDRV
DO 110 IAT = 1,NATOMS GMSDRV
DO 100 K = 1,3 GMSDRV
I = I + 1 GMSDRV
CORE(I) = (C(K,IAT) - X(K)) * TOANG GMSDRV
100 CONTINUE GMSDRV
110 CONTINUE GMSDRV
NFILE = 9 GMSDRV
CALL NBWRIT(CORE,3*NATOMS,NFILE) GMSDRV
GMSDRV
Store the overlap matrix on the NBODAF: GMSDRV
GMSDRV
NFILE = 12 GMSDRV
L2 = NDIM*(NDIM+1)/2 GMSDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV
NFILE = 10 GMSDRV
CALL NBWRIT(CORE,L2,NFILE) GMSDRV
GMSDRV
Store the density matrices on the NBODAF: GMSDRV
GMSDRV
NFILE = 16 GMSDRV
L2 = NDIM*(NDIM+1)/2 GMSDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV
NFILE = 20 GMSDRV
CALL NBWRIT(CORE,L2,NFILE) GMSDRV
GMSDRV
IF(OPEN) THEN GMSDRV
NFILE = 20 GMSDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV
NFILE = 21 GMSDRV
CALL NBWRIT(CORE,L2,NFILE) GMSDRV
END IF GMSDRV
GMSDRV
Store the Fock matrices on the NBODAF: GMSDRV
GMSDRV
IF(IWFOCK.NE.0) THEN GMSDRV
NFILE = 14 GMSDRV
L2 = NDIM*(NDIM+1)/2 GMSDRV
IF(IODA(NFILE).GT.0) THEN GMSDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV
NFILE = 30 GMSDRV
CALL NBWRIT(CORE,L2,NFILE) GMSDRV
END IF GMSDRV
GMSDRV
IF(OPEN) THEN GMSDRV
NFILE = 18 GMSDRV
IF(IODA(NFILE).GT.0) THEN GMSDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV
NFILE = 31 GMSDRV
CALL NBWRIT(CORE,L2,NFILE) GMSDRV
END IF GMSDRV
END IF GMSDRV
END IF GMSDRV
GMSDRV
Store the AO to MO transformation matrices on the NBODAF: GMSDRV
GMSDRV
IF(IODA(15).NE.0) THEN GMSDRV
NFILE = 15 GMSDRV
L3 = NDIM*NDIM GMSDRV
CALL DAREAD(IDAF,IODA,CORE,L3,NFILE,NAV) GMSDRV
NFILE = 40 GMSDRV
CALL NBWRIT(CORE,L3,NFILE) GMSDRV
IF(OPEN) THEN GMSDRV
NFILE = 19 GMSDRV
CALL DAREAD(IDAF,IODA,CORE,L3,NFILE,NAV) GMSDRV
NFILE = 41 GMSDRV
CALL NBWRIT(CORE,L3,NFILE) GMSDRV
END IF GMSDRV
END IF GMSDRV
GMSDRV
Store the x,y,z dipole integrals on the NBODAF: GMSDRV
GMSDRV
IF(IODA(23).NE.0.AND.IODA(24).NE.0.AND.IODA(25).NE.0) THEN GMSDRV
L2 = NDIM*(NDIM+1)/2 GMSDRV
NFILE = 23 GMSDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV
DO 120 I = 1,L2 GMSDRV
CORE(I) = CORE(I) * TOANG GMSDRV
120 CONTINUE GMSDRV
NFILE = 50 GMSDRV
CALL NBWRIT(CORE,L2,NFILE) GMSDRV
NFILE = 24 GMSDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV
DO 130 I = 1,L2 GMSDRV
CORE(I) = CORE(I) * TOANG GMSDRV
130 CONTINUE GMSDRV
NFILE = 51 GMSDRV
CALL NBWRIT(CORE,L2,NFILE) GMSDRV
NFILE = 25 GMSDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV
DO 140 I = 1,L2 GMSDRV
CORE(I) = CORE(I) * TOANG GMSDRV
140 CONTINUE GMSDRV
NFILE = 52 GMSDRV
CALL NBWRIT(CORE,L2,NFILE) GMSDRV
END IF GMSDRV
GMSDRV
Store the AO basis set info on the NBO DAF: (Note that two integers GMSDRV
and three integer arrays are stored first. Also remember that ICORE GMSDRV
and CORE occupy the same memory.) GMSDRV
GMSDRV
NEXP = 0 GMSDRV
DO 150 I = 1,MXGTOT GMSDRV
IF(EX(I).EQ.ZERO) GOTO 150 GMSDRV
NEXP = I GMSDRV
150 CONTINUE GMSDRV
DO 160 I = 1,2+3*NSHELL+5*NEXP GMSDRV
CORE(I) = ZERO GMSDRV
160 CONTINUE GMSDRV
ICORE(1) = NSHELL GMSDRV
ICORE(2) = NEXP GMSDRV
GMSDRV
NCOMP(I) -- the number of components in the Ith shell: GMSDRV
GMSDRV
II = 2 GMSDRV
DO 170 I = 1,NSHELL GMSDRV
II = II + 1 GMSDRV
ICORE(II) = KMAX(I) - KMIN(I) + 1 GMSDRV
170 CONTINUE GMSDRV
GMSDRV
NPRIM(I) -- the number of gaussian primitives in the Ith shell: GMSDRV
GMSDRV
DO 180 I = 1,NSHELL GMSDRV
II = II + 1 GMSDRV
ICORE(II) = KNG(I) GMSDRV
180 CONTINUE GMSDRV
GMSDRV
NPTR(I) -- pointer for the Ith shell into the gaussian parameters, GMSDRV
EXP, CS, CP, etc.: GMSDRV
GMSDRV
DO 190 I = 1,NSHELL GMSDRV
II = II + 1 GMSDRV
ICORE(II) = KSTART(I) GMSDRV
190 CONTINUE GMSDRV
GMSDRV
EXP(I) -- orbital exponents indexed by NPTR: GMSDRV
GMSDRV
DO 200 I = 1,NEXP GMSDRV
II = II + 1 GMSDRV
CORE(II) = EX(I) GMSDRV
200 CONTINUE GMSDRV
GMSDRV
CS,CP,CD,CF -- orbital coefficients: GMSDRV
GMSDRV
DO 210 I = 1,NEXP GMSDRV
II = II + 1 GMSDRV
CORE(II) = CS(I) GMSDRV
210 CONTINUE GMSDRV
DO 220 I = 1,NEXP GMSDRV
II = II + 1 GMSDRV
CORE(II) = CP(I) GMSDRV
220 CONTINUE GMSDRV
DO 230 I = 1,NEXP GMSDRV
II = II + 1 GMSDRV
CORE(II) = CD(I) GMSDRV
230 CONTINUE GMSDRV
DO 240 I = 1,NEXP GMSDRV
II = II + 1 GMSDRV
CORE(II) = ZERO GMSDRV
240 CONTINUE GMSDRV
NFILE = 5 GMSDRV
CALL NBWRIT(CORE,II,NFILE) GMSDRV
GMSDRV
RETURN GMSDRV
END GMSDRV
***********************************************************************GMSDRV
SUBROUTINE DELSCF(A,IA) GMSDRV
***********************************************************************GMSDRV
IMPLICIT REAL*8 (A-H,O-Z) GMSDRV
LOGICAL NEW,ERROR,SEQ GMSDRV
GMSDRV
NBO common blocks: GMSDRV
GMSDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GMSDRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GMSDRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GMSDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GMSDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GMSDRV
+ LFNDAF,LFNDEF GMSDRV
GMSDRV
GAMESS common blocks: GMSDRV
GMSDRV
PARAMETER (MXGTOT=5000, MXSH=1000, MXATM=50) GMSDRV
COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(99) GMSDRV
COMMON /INFOA / NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(MXATM),C(3,MXATM) GMSDRV
COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK GMSDRV
COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTG76 GMSDRV
LOGICAL PACK2E GMSDRV
GMSDRV
DIMENSION A(1),IA(NDIM) GMSDRV
GMSDRV
DATA TWO/2.0D0/ GMSDRV
GMSDRV
-----------------------------------------------------------------------GMSDRV
GMSDRV
SET POINTERS: GMSDRV
GMSDRV
NTRI = NDIM*(NDIM+1)/2 GMSDRV
NSQ = NDIM*NDIM GMSDRV
GMSDRV
A(IPT1) --- Density matrix (alpha) GMSDRV
A(IPT2) --- Density matrix (beta) GMSDRV
A(IPT3) --- Fock matrix (alpha) GMSDRV
A(IPT4) --- Fock matrix (beta) GMSDRV
A(IPT5) --- Core Hamiltonian matrix GMSDRV
A(IPT6) --- Integral buffer, scratch GMSDRV
A(IPT7) --- Integral buffer GMSDRV
A(IPT8) --- Integral buffer GMSDRV
GMSDRV
IPT1 = 1 + NDIM GMSDRV
IPT2 = IPT1 + NTRI GMSDRV
IPT3 = IPT2 + NTRI GMSDRV
IPT4 = IPT3 + NTRI GMSDRV
IPT5 = IPT4 + NTRI GMSDRV
IPT6 = IPT5 + NTRI GMSDRV
IPT7 = IPT6 + NINTMX GMSDRV
IPT8 = IPT7 + NINTMX GMSDRV
GMSDRV
SET UP ADDRESSING ARRAY: GMSDRV
GMSDRV
DO 50 I = 1,NDIM GMSDRV
IA(I) = (I*(I-1))/2 GMSDRV
50 CONTINUE GMSDRV
GMSDRV
REWIND INTEGRAL FILE: GMSDRV
GMSDRV
REWIND IS GMSDRV
GMSDRV
OPEN THE NBO DIRECT ACCESS FILE GMSDRV
GMSDRV
NEW = .FALSE. GMSDRV
CALL NBOPEN(NEW,ERROR) GMSDRV
IF(ERROR) THEN GMSDRV
WRITE(LFNPR,900) GMSDRV
STOP GMSDRV
END IF GMSDRV
GMSDRV
CALCULATE NUCLEAR REPULSION ENERGY: GMSDRV
GMSDRV
EN = ENUC(NAT,ZAN,C) GMSDRV
IF(UHF) THEN GMSDRV
GMSDRV
UHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTGMSDRV
AND SYMMETRIZE THE SKELETON FOCK MATRIX: GMSDRV
GMSDRV
ALPHA = .TRUE. GMSDRV
BETA = .FALSE. GMSDRV
CALL FENEWD(A(IPT1)) GMSDRV
ALPHA = .FALSE. GMSDRV
BETA = .TRUE. GMSDRV
CALL FENEWD(A(IPT2)) GMSDRV
CALL HSTARU(A(IPT1),A(IPT3),A(IPT2),A(IPT4),A(IPT7),A(IPT8), GMSDRV
+ A(IPT6),A(IPT7),A(IPT8),NINTMX,IA,NOPK) GMSDRV
CALL SYMH(A(IPT3),A(IPT6),IA) GMSDRV
CALL SYMH(A(IPT4),A(IPT6),IA) GMSDRV
GMSDRV
READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: GMSDRV
GMSDRV
CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11,NAV) GMSDRV
CALL VADD(A(IPT3),1,A(IPT5),1,A(IPT3),1,NTRI) GMSDRV
CALL VADD(A(IPT4),1,A(IPT5),1,A(IPT4),1,NTRI) GMSDRV
EHFA = TRACEP(A(IPT1),A(IPT5),NBAS) + GMSDRV
+ TRACEP(A(IPT1),A(IPT3),NBAS) GMSDRV
EHFB = TRACEP(A(IPT2),A(IPT5),NBAS) + GMSDRV
+ TRACEP(A(IPT2),A(IPT4),NBAS) GMSDRV
EHF = (EHFA + EHFB)/TWO GMSDRV
EDEL = EHF + EN GMSDRV
GMSDRV
RHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTGMSDRV
AND SYMMETRIZE THE SKELETON FOCK MATRIX: GMSDRV
GMSDRV
ELSE GMSDRV
CALL FENEWD(A(IPT1)) GMSDRV
CALL HSTAR(A(IPT1),A(IPT3),A(IPT6),A(IPT7),NINTMX,IA,NOPK) GMSDRV
CALL SYMH(A(IPT3),A(IPT6),IA) GMSDRV
GMSDRV
READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: GMSDRV
GMSDRV
CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11,NAV) GMSDRV
CALL VADD(A(IPT3),1,A(IPT5),1,A(IPT3),1,NTRI) GMSDRV
EHF1 = TRACEP(A(IPT1),A(IPT5),NDIM) GMSDRV
EHF2 = TRACEP(A(IPT1),A(IPT3),NDIM) GMSDRV
EHF = (EHF1 + EHF2)/TWO GMSDRV
EDEL = EHF + EN GMSDRV
END IF GMSDRV
GMSDRV
SAVE THE DELETION ENERGY ON THE NBO DIRECT ACCESS FILE AND CLOSE THE GMSDRV
FILE: GMSDRV
GMSDRV
CALL SVE0(EDEL) GMSDRV
SEQ = .FALSE. GMSDRV
CALL NBCLOS(SEQ) GMSDRV
RETURN GMSDRV
GMSDRV
900 FORMAT(/1X,'Error opening the NBO direct access file in ', GMSDRV
+ 'subroutine DELSCF.') GMSDRV
END GMSDRV
***********************************************************************GMSDRV
GMSDRV
E N D O F G M S N B O R O U T I N E S GMSDRV
GMSDRV
***********************************************************************GMSDRV
***********************************************************************HNDDRV
HNDDRV
HNDDRV
H N D N B O HNDDRV
HNDDRV
HNDDRV
HONDO VERSION OF NBO PROGRAM HNDDRV
HNDDRV
HNDDRV
DRIVER ROUTINES: HNDDRV
HNDDRV
SUBROUTINE RUNNBO HNDDRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) HNDDRV
SUBROUTINE DELSCF(A) HNDDRV
HNDDRV
***********************************************************************HNDDRV
SUBROUTINE RUNNBO HNDDRV
***********************************************************************HNDDRV
IMPLICIT REAL*8 (A-H,O-Z) HNDDRV
DIMENSION NBOOPT(10) HNDDRV
HNDDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, HNDDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, HNDDRV
+ LFNDAF,LFNDEF HNDDRV
HNDDRV
HONDO Common Block: HNDDRV
HNDDRV
COMMON/IOFILE/IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(99) HNDDRV
COMMON/MEMORY/MAXCOR,MAXLCM HNDDRV
COMMON/SCM/CORE(1) HNDDRV
HNDDRV
LFNIN = IR HNDDRV
LFNPR = IW HNDDRV
HNDDRV
Set NBO options. HNDDRV
HNDDRV
NBOOPT(1) = 0 HNDDRV
NBOOPT(2) = 0 HNDDRV
NBOOPT(3) = 0 HNDDRV
NBOOPT(4) = 0 HNDDRV
NBOOPT(5) = 0 HNDDRV
NBOOPT(6) = 0 HNDDRV
NBOOPT(7) = 0 HNDDRV
NBOOPT(8) = 0 HNDDRV
NBOOPT(9) = 0 HNDDRV
NBOOPT(10) = 7 HNDDRV
HNDDRV
Perform the NPA/NBO/NLMO analyses. HNDDRV
HNDDRV
CALL NBO(CORE,MAXCOR,NBOOPT) HNDDRV
HNDDRV
Perform the energetic analysis. HNDDRV
HNDDRV
10 NBOOPT(1) = 2 HNDDRV
CALL NBOEAN(CORE,MAXCOR,NBOOPT,IDONE) HNDDRV
IF(IDONE.NE.0) GOTO 20 HNDDRV
CALL DELSCF(CORE) HNDDRV
NBOOPT(1) = 3 HNDDRV
CALL NBOEAN(CORE,MAXCOR,NBOOPT,IDONE) HNDDRV
GOTO 10 HNDDRV
HNDDRV
20 RETURN HNDDRV
END HNDDRV
***********************************************************************HNDDRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) HNDDRV
***********************************************************************HNDDRV
IMPLICIT REAL*8 (A-H,O-Z) HNDDRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) HNDDRV
HNDDRV
----------------------------------------------------------------------HNDDRV
HNDDRV
This routine fetchs basis set information from the HONDO common HNDDRV
blocks and stores it in the NBO common blocks and direct access file HNDDRV
(DAF) for use by the NBO analysis. HNDDRV
HNDDRV
----------------------------------------------------------------------HNDDRV
HNDDRV
Routine FEAOIN accesses the following records of the dictionary file:HNDDRV
HNDDRV
2 --- Total energy HNDDRV
12 --- AO overlap matrix HNDDRV
14 --- AO Fock matrix (alpha) HNDDRV
15 --- AO to MO transformation matrix (alpha) HNDDRV
16 --- AO density matrix (bond order matrix) (alpha) HNDDRV
18 --- AO Fock matrix (beta) HNDDRV
19 --- AO to MO transformation matrix (beta) HNDDRV
20 --- AO density matrix (bond order matrix) (beta) HNDDRV
33 --- X dipole integrals HNDDRV
34 --- Y dipole integrals HNDDRV
35 --- Z dipole integrals HNDDRV
HNDDRV
----------------------------------------------------------------------HNDDRV
HNDDRV
NBO Common blocks HNDDRV
HNDDRV
HNDDRV
PARAMETER(MAXATM = 99,MAXBAS = 500) HNDDRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO HNDDRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO HNDDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT HNDDRV
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, HNDDRV
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, HNDDRV
+ JCORE,JPRINT(60) HNDDRV
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) HNDDRV
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), HNDDRV
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) HNDDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, HNDDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, HNDDRV
+ LFNDAF,LFNDEF HNDDRV
HNDDRV
HONDO Common blocks HNDDRV
HNDDRV
COMMON/IOFILE/IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(99) HNDDRV
COMMON/INFOA/NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(50),C(3,50) HNDDRV
COMMON/MOLNUC/NUC(50) HNDDRV
COMMON/NSHEL/EX(440),CS(440),CP(440),CD(440),CF(440),CG(440), HNDDRV
* KSTART(120),KATOM(120),KTYPE(120),KNG(120), HNDDRV
* KLOC(120),KMIN(120),KMAX(120),NSHELL HNDDRV
COMMON/RUNLAB/TITLE(10),ANAM(50),BNAM(50),BFLAB(512) HNDDRV
COMMON/SCFOPT/SCFTYP HNDDRV
COMMON/WFNOPT/WFNTYP HNDDRV
HNDDRV
DIMENSION LABELS(20),WFNS(6) HNDDRV
LOGICAL WSTATE(6,6),SOME HNDDRV
DIMENSION CM(3) HNDDRV
HNDDRV
Obtain the following information: HNDDRV
HNDDRV
ROHF =.TRUE. If RHF open shell wavefunction HNDDRV
=.FALSE. otherwise HNDDRV
HNDDRV
UHF =.TRUE. If UHF wavefunction HNDDRV
=.FALSE. otherwise HNDDRV
HNDDRV
AUHF =.TRUE. If spin-annihilated UHF wavefunction HNDDRV
=.FALSE. otherwise HNDDRV
HNDDRV
CI =.TRUE. If CI wavefunction HNDDRV
=.FALSE. otherwise HNDDRV
HNDDRV
OPEN =.TRUE. If open shell wavefunction HNDDRV
=.FALSE. otherwise HNDDRV
HNDDRV
COMPLX =.TRUE. If complex wavefunction HNDDRV
=.FALSE. otherwise HNDDRV
(Note: The program is not capable of handling this.) HNDDRV
HNDDRV
NATOMS Number of atomic centers HNDDRV
HNDDRV
NDIM Dimension of matrices (overlap and density) passed to pHNDDRV
HNDDRV
NBAS Number of basis functions (.le.NDIM) HNDDRV
HNDDRV
IPSEUD Set to zero if no pseudopotentials are used. HNDDRV
Set to one if pseudopotentials are used. HNDDRV
HNDDRV
IWCUBF This pertains only basis sets with F functions. HNDDRV
HNDDRV
If cartesian F functions are input, set IWCUBF to: HNDDRV
0, if these are to be transformed to the HNDDRV
standard set of pure F functions HNDDRV
1, if these are to be transformed to the HNDDRV
cubic set of pure F functions HNDDRV
HNDDRV
If pure F functions are input, set to IWCUBF to: HNDDRV
0, if these are standard F functions HNDDRV
1, if these are cubic F functions HNDDRV
HNDDRV
IATNO(I),I=1,NATOMS HNDDRV
List of atomic numbers HNDDRV
HNDDRV
LCTR(I),I=1,NBAS HNDDRV
List of atomic centers of the basis functions HNDDRV
(LCTR(3)=2 if basis function 3 is on atom 2) HNDDRV
HNDDRV
LANG(I),I=1,NBAS HNDDRV
List of angular symmetry information for the basis funcHNDDRV
HNDDRV
LABELS array contains NBO labels for the atomic orbitals HNDDRV
HNDDRV
DATA LABELS / HNDDRV
HNDDRV
S HNDDRV
--- HNDDRV
+ 1, HNDDRV
HNDDRV
Px Py Pz HNDDRV
--- --- --- HNDDRV
+ 101, 102, 103, HNDDRV
HNDDRV
Dxx Dyy Dzz Dxy Dxz Dyz HNDDRV
--- --- --- --- --- --- HNDDRV
+ 201, 204, 206, 202, 203, 205, HNDDRV
HNDDRV
Fxxx Fyyy Fzzz Fxxy Fxxz Fxyy Fxyz Fxzz Fyyz Fyzz HNDDRV
---- ---- ---- ---- ---- ---- ---- ---- ---- ---- HNDDRV
+ 301, 307, 310, 302, 303, 304, 305, 306, 308, 309 / HNDDRV
HNDDRV
HNDDRV
WSTATE array contains the values which should be set in the NBO commoHNDDRV
NBFLAG depending on wavefunction. HNDDRV
HNDDRV
DATA WSTATE / HNDDRV
ROHF UHF CI OPEN MCSCF AUHF HNDDRV
------- ------- ------ ------ ------ ------ HNDDRV
Wavefunction HNDDRV
RHF HNDDRV
+ .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., HNDDRV
UHF HNDDRV
+ .FALSE., .TRUE. , .FALSE., .TRUE. , .FALSE., .FALSE., HNDDRV
ROHF HNDDRV
+ .TRUE. , .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., HNDDRV
GVB HNDDRV
+ .TRUE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., HNDDRV
MCSCF HNDDRV
+ .FALSE., .FALSE., .FALSE., .FALSE., .TRUE. , .FALSE., HNDDRV
CI HNDDRV
+ .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., .FALSE./ HNDDRV
HNDDRV
HNDDRV
NAMELIST /WFN/ WFNFLG HNDDRV
DATA WFNFLG /0/ HNDDRV
DATA ZERO/0.0D0/ HNDDRV
DATA TOANG/0.529177249/ HNDDRV
HNDDRV
Wavefunction types: HNDDRV
HNDDRV
DATA SCFWFN,CIWFN/'SCF ','MCCI '/ HNDDRV
DATA WFNS /8HRHF , HNDDRV
+ 8HUHF , HNDDRV
+ 8HROHF , HNDDRV
+ 8HGVB , HNDDRV
+ 8HMCSCF , HNDDRV
+ 8HCI / HNDDRV
HNDDRV
Read in type of wavefunction from the $WFN namelist. HNDDRV
HNDDRV
REWIND IR HNDDRV
READ(IR,WFN,END=3) HNDDRV
GO TO 4 HNDDRV
3 CONTINUE HNDDRV
WRITE(IW,900) HNDDRV
STOP HNDDRV
4 CONTINUE HNDDRV
HNDDRV
Store job title on NBODAF: HNDDRV
HNDDRV
DO 5 I = 1,10 HNDDRV
CORE(I) = TITLE(I) HNDDRV
5 CONTINUE HNDDRV
NFILE = 2 HNDDRV
CALL NBWRIT(CORE,10,NFILE) HNDDRV
HNDDRV
Get the number of atoms from NAT and store the atomic numbers in HNDDRV
IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and HNDDRV
nuclear charges may not be equivalent if effective core potentials HNDDRV
(ECP) are used.) HNDDRV
HNDDRV
NATOMS = NAT HNDDRV
DO 10 I = 1,NAT HNDDRV
IATNO(I) = NUC(I) HNDDRV
IZNUC(I) = ZAN(I) HNDDRV
IF(IATNO(I).NE.IZNUC(I)) IPSEUD = 1 HNDDRV
10 CONTINUE HNDDRV
HNDDRV
KATOM array contains which atom the shell is on, KMIN and KMAX HNDDRV
determine the components in the shell by pointing to a range in the HNDDRV
LABELS array: HNDDRV
HNDDRV
II = 0 HNDDRV
DO 30 I = 1,NSHELL HNDDRV
IATOM = KATOM(I) HNDDRV
MIN = KMIN(I) HNDDRV
MAX = KMAX(I) HNDDRV
DO 20 J = MIN,MAX HNDDRV
II = II + 1 HNDDRV
LCTR(II) = IATOM HNDDRV
LANG(II) = LABELS(J) HNDDRV
20 CONTINUE HNDDRV
30 CONTINUE HNDDRV
HNDDRV
NBAS = II HNDDRV
NDIM = NBAS HNDDRV
HNDDRV
Inititialize various NBO options depending upon the wavefunction HNDDRV
type and basis set type. HNDDRV
HNDDRV
First, turn off the complex orbitals, indicate that the pure set HNDDRV
of F functions is desired when transforming from the cartesian set. HNDDRV
HNDDRV
COMPLX = .FALSE. HNDDRV
IWCUBF = 0 HNDDRV
ORTHO = .FALSE. HNDDRV
HNDDRV
Next set up the wavefunction switches. HNDDRV
HNDDRV
IF(WFNTYP.EQ.SCFWFN) THEN HNDDRV
IF(WFNFLG.EQ.0) THEN HNDDRV
IF(SCFTYP.EQ.WFNS(1)) ISTATE = 1 HNDDRV
IF(SCFTYP.EQ.WFNS(2)) ISTATE = 2 HNDDRV
IF(SCFTYP.EQ.WFNS(4)) ISTATE = 4 HNDDRV
IF(SCFTYP.EQ.WFNS(1).AND.MUL.GE.2) ISTATE = 3 HNDDRV
GOTO 60 HNDDRV
END IF HNDDRV
IF(WFNFLG.EQ.5) THEN HNDDRV
ISTATE = 6 HNDDRV
GOTO 60 HNDDRV
END IF HNDDRV
IF(WFNFLG.EQ.6) THEN HNDDRV
ISTATE = 6 HNDDRV
GOTO 60 HNDDRV
END IF HNDDRV
END IF HNDDRV
IF(WFNTYP.EQ.CIWFN) THEN HNDDRV
IF(WFNFLG.EQ.1) ISTATE = 5 HNDDRV
IF(WFNFLG.EQ.2) ISTATE = 6 HNDDRV
IF(WFNFLG.EQ.3) ISTATE = 6 HNDDRV
IF(WFNFLG.EQ.4) ISTATE = 6 HNDDRV
GOTO 60 HNDDRV
END IF HNDDRV
STOP 'Unknown WFNTYP' HNDDRV
HNDDRV
60 ROHF = WSTATE(1,ISTATE) HNDDRV
UHF = WSTATE(2,ISTATE) HNDDRV
CI = WSTATE(3,ISTATE) HNDDRV
OPEN = WSTATE(4,ISTATE) HNDDRV
MCSCF = WSTATE(5,ISTATE) HNDDRV
AUHF = WSTATE(6,ISTATE) HNDDRV
HNDDRV
No Fock matrices for ROHF, MCSCF, or CI wavefunctions: HNDDRV
HNDDRV
IF (ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 HNDDRV
HNDDRV
Expectation values of the Fock operator are in atomic units: HNDDRV
HNDDRV
MUNIT = 0 HNDDRV
HNDDRV
Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: HNDDRV
HNDDRV
ICORE(1) = NATOMS HNDDRV
ICORE(2) = NDIM HNDDRV
ICORE(3) = NBAS HNDDRV
ICORE(4) = MUNIT HNDDRV
ICORE(5) = 0 HNDDRV
IF(ROHF) ICORE(5) = 1 HNDDRV
ICORE(6) = 0 HNDDRV
IF(UHF) ICORE(6) = 1 HNDDRV
ICORE(7) = 0 HNDDRV
IF(CI) ICORE(7) = 1 HNDDRV
ICORE(8) = 0 HNDDRV
IF(OPEN) ICORE(8) = 1 HNDDRV
ICORE(9) = 0 HNDDRV
IF(MCSCF) ICORE(9) = 1 HNDDRV
ICORE(10) = 0 HNDDRV
IF(AUHF) ICORE(10) = 1 HNDDRV
ICORE(11) = 0 HNDDRV
IF(ORTHO) ICORE(11) = 1 HNDDRV
ICORE(12) = 1 HNDDRV
NFILE = 3 HNDDRV
CALL NBWRIT(ICORE,12,NFILE) HNDDRV
HNDDRV
Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: HNDDRV
HNDDRV
II = 0 HNDDRV
DO 70 I = 1,NATOMS HNDDRV
II = II + 1 HNDDRV
ICORE(II) = IATNO(I) HNDDRV
70 CONTINUE HNDDRV
DO 80 I = 1,NATOMS HNDDRV
II = II + 1 HNDDRV
ICORE(II) = IZNUC(I) HNDDRV
80 CONTINUE HNDDRV
DO 90 I = 1,NBAS HNDDRV
II = II + 1 HNDDRV
ICORE(II) = LCTR(I) HNDDRV
90 CONTINUE HNDDRV
DO 95 I = 1,NBAS HNDDRV
II = II + 1 HNDDRV
ICORE(II) = LANG(I) HNDDRV
95 CONTINUE HNDDRV
NFILE = 4 HNDDRV
CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) HNDDRV
HNDDRV
Fetch the total energy from the dictionary file and store it on the HNDDRV
NBO DAF: HNDDRV
HNDDRV
NFILE = 2 HNDDRV
CALL DAREAD(IDAF,IODA,CORE,3,NFILE) HNDDRV
CORE(1) = CORE(3) HNDDRV
CORE(2) = CORE(3) HNDDRV
NFILE = 8 HNDDRV
CALL NBWRIT(CORE,2,NFILE) HNDDRV
HNDDRV
Find the center of mass for this molecule: HNDDRV
HNDDRV
NCALL = 1 HNDDRV
SOME = .FALSE. HNDDRV
CALL DIPAMS(CORE,NCALL,NCODE,SOME) HNDDRV
SUM = ZERO HNDDRV
DO 96 I = 1,3 HNDDRV
CM(I) = ZERO HNDDRV
96 CONTINUE HNDDRV
DO 98 IAT = 1,NATOMS HNDDRV
SUM = SUM + CORE(IAT) HNDDRV
DO 97 I = 1,3 HNDDRV
CM(I) = CM(I) + CORE(IAT) * C(I,IAT) HNDDRV
97 CONTINUE HNDDRV
98 CONTINUE HNDDRV
IF(ABS(SUM).GT.1.0D-5) THEN HNDDRV
DO 99 I = 1,3 HNDDRV
CM(I) = CM(I) / SUM HNDDRV
99 CONTINUE HNDDRV
END IF HNDDRV
HNDDRV
Store the atomic coordinates on the NBO DAF: (Note that these HNDDRV
coordinates are used in the calculation of dipole moments.) HNDDRV
HNDDRV
I = 0 HNDDRV
DO 110 IAT = 1,NATOMS HNDDRV
DO 100 K = 1,3 HNDDRV
I = I + 1 HNDDRV
CORE(I) = (C(K,IAT) - CM(K)) * TOANG HNDDRV
100 CONTINUE HNDDRV
110 CONTINUE HNDDRV
NFILE = 9 HNDDRV
CALL NBWRIT(CORE,3*NATOMS,NFILE) HNDDRV
HNDDRV
Store the overlap matrix on the NBODAF: HNDDRV
HNDDRV
NFILE = 12 HNDDRV
L2 = NDIM*(NDIM+1)/2 HNDDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV
NFILE = 10 HNDDRV
CALL NBWRIT(CORE,L2,NFILE) HNDDRV
HNDDRV
Store the density matrices on the NBODAF: HNDDRV
HNDDRV
NFILE = 16 HNDDRV
L2 = NDIM*(NDIM+1)/2 HNDDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV
NFILE = 20 HNDDRV
CALL NBWRIT(CORE,L2,NFILE) HNDDRV
HNDDRV
IF(OPEN) THEN HNDDRV
NFILE = 20 HNDDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV
NFILE = 21 HNDDRV
CALL NBWRIT(CORE,L2,NFILE) HNDDRV
END IF HNDDRV
HNDDRV
Store the Fock matrices on the NBODAF: HNDDRV
HNDDRV
IF(IWFOCK.NE.0) THEN HNDDRV
NFILE = 14 HNDDRV
L2 = NDIM*(NDIM+1)/2 HNDDRV
IF(IODA(NFILE).GT.0) THEN HNDDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV
NFILE = 30 HNDDRV
CALL NBWRIT(CORE,L2,NFILE) HNDDRV
END IF HNDDRV
HNDDRV
IF(OPEN) THEN HNDDRV
NFILE = 18 HNDDRV
IF(IODA(NFILE).GT.0) THEN HNDDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV
NFILE = 31 HNDDRV
CALL NBWRIT(CORE,L2,NFILE) HNDDRV
END IF HNDDRV
END IF HNDDRV
END IF HNDDRV
HNDDRV
Store the AO to MO transformation matrices on the NBODAF: HNDDRV
HNDDRV
IF(IODA(15).NE.0) THEN HNDDRV
NFILE = 15 HNDDRV
L3 = NDIM*NDIM HNDDRV
CALL DAREAD(IDAF,IODA,CORE,L3,NFILE) HNDDRV
NFILE = 40 HNDDRV
CALL NBWRIT(CORE,L3,NFILE) HNDDRV
IF(OPEN) THEN HNDDRV
NFILE = 19 HNDDRV
CALL DAREAD(IDAF,IODA,CORE,L3,NFILE) HNDDRV
NFILE = 41 HNDDRV
CALL NBWRIT(CORE,L3,NFILE) HNDDRV
END IF HNDDRV
END IF HNDDRV
HNDDRV
Store the x,y,z dipole integrals on the NBODAF: HNDDRV
HNDDRV
IF(IODA(33).NE.0.AND.IODA(34).NE.0.AND.IODA(35).NE.0) THEN HNDDRV
L2 = NDIM*(NDIM+1)/2 HNDDRV
NFILE = 33 HNDDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV
DO 120 I = 1,L2 HNDDRV
CORE(I) = CORE(I) * TOANG HNDDRV
120 CONTINUE HNDDRV
NFILE = 50 HNDDRV
CALL NBWRIT(CORE,L2,NFILE) HNDDRV
NFILE = 34 HNDDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV
DO 130 I = 1,L2 HNDDRV
CORE(I) = CORE(I) * TOANG HNDDRV
130 CONTINUE HNDDRV
NFILE = 51 HNDDRV
CALL NBWRIT(CORE,L2,NFILE) HNDDRV
NFILE = 35 HNDDRV
CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV
DO 140 I = 1,L2 HNDDRV
CORE(I) = CORE(I) * TOANG HNDDRV
140 CONTINUE HNDDRV
NFILE = 52 HNDDRV
CALL NBWRIT(CORE,L2,NFILE) HNDDRV
END IF HNDDRV
HNDDRV
Store the AO basis set info on the NBO DAF: (Note that two integers HNDDRV
and three integer arrays are stored first. Also remember that ICORE HNDDRV
and CORE occupy the same memory.) HNDDRV
HNDDRV
NEXP = 0 HNDDRV
DO 150 I = 1,440 HNDDRV
IF(EX(I).EQ.ZERO) GOTO 150 HNDDRV
NEXP = I HNDDRV
150 CONTINUE HNDDRV
DO 160 I = 1,2+3*NSHELL+5*NEXP HNDDRV
CORE(I) = ZERO HNDDRV
160 CONTINUE HNDDRV
ICORE(1) = NSHELL HNDDRV
ICORE(2) = NEXP HNDDRV
HNDDRV
NCOMP(I) -- the number of components in the Ith shell: HNDDRV
HNDDRV
II = 2 HNDDRV
DO 170 I = 1,NSHELL HNDDRV
II = II + 1 HNDDRV
ICORE(II) = KMAX(I) - KMIN(I) + 1 HNDDRV
170 CONTINUE HNDDRV
HNDDRV
NPRIM(I) -- the number of gaussian primitives in the Ith shell: HNDDRV
HNDDRV
DO 180 I = 1,NSHELL HNDDRV
II = II + 1 HNDDRV
ICORE(II) = KNG(I) HNDDRV
180 CONTINUE HNDDRV
HNDDRV
NPTR(I) -- pointer for the Ith shell into the gaussian parameters, HNDDRV
EXP, CS, CP, etc.: HNDDRV
HNDDRV
DO 190 I = 1,NSHELL HNDDRV
II = II + 1 HNDDRV
ICORE(II) = KSTART(I) HNDDRV
190 CONTINUE HNDDRV
HNDDRV
EXP(I) -- orbital exponents indexed by NPTR: HNDDRV
HNDDRV
DO 200 I = 1,NEXP HNDDRV
II = II + 1 HNDDRV
CORE(II) = EX(I) HNDDRV
200 CONTINUE HNDDRV
HNDDRV
CS,CP,CD,CF -- orbital coefficients: HNDDRV
HNDDRV
DO 210 I = 1,NEXP HNDDRV
II = II + 1 HNDDRV
CORE(II) = CS(I) HNDDRV
210 CONTINUE HNDDRV
DO 220 I = 1,NEXP HNDDRV
II = II + 1 HNDDRV
CORE(II) = CP(I) HNDDRV
220 CONTINUE HNDDRV
DO 230 I = 1,NEXP HNDDRV
II = II + 1 HNDDRV
CORE(II) = CD(I) HNDDRV
230 CONTINUE HNDDRV
DO 240 I = 1,NEXP HNDDRV
II = II + 1 HNDDRV
CORE(II) = CF(I) HNDDRV
240 CONTINUE HNDDRV
NFILE = 5 HNDDRV
CALL NBWRIT(CORE,II,NFILE) HNDDRV
HNDDRV
900 FORMAT(/1X,'No namelist /WFN/ found. Stop. ') HNDDRV
RETURN HNDDRV
END HNDDRV
***********************************************************************HNDDRV
SUBROUTINE DELSCF(A) HNDDRV
***********************************************************************HNDDRV
IMPLICIT REAL*8 (A-H,O-Z) HNDDRV
LOGICAL NEW,ERROR,SEQ HNDDRV
HNDDRV
NBO common blocks: HNDDRV
HNDDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT HNDDRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO HNDDRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO HNDDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, HNDDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, HNDDRV
+ LFNDAF,LFNDEF HNDDRV
HNDDRV
HONDO common blocks: HNDDRV
HNDDRV
COMMON/IJPAIR/IA(1) HNDDRV
COMMON/IOFILE/IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(99) HNDDRV
COMMON/INFOA/NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(50),C(3,50) HNDDRV
COMMON/INTFIL/NOPK,NOK,NOSQUR,NINTMX,NHEX,NTUPL,PACK2E HNDDRV
LOGICAL PACK2E HNDDRV
HNDDRV
DIMENSION A(1) HNDDRV
HNDDRV
-----------------------------------------------------------------------HNDDRV
HNDDRV
SET POINTERS: HNDDRV
HNDDRV
NTRI = NDIM*(NDIM+1)/2 HNDDRV
NSQ = NDIM*NDIM HNDDRV
HNDDRV
A(IPT1) --- Density matrix (alpha) HNDDRV
A(IPT2) --- Density matrix (beta) HNDDRV
A(IPT3) --- Fock matrix (alpha) HNDDRV
A(IPT4) --- Fock matrix (beta) HNDDRV
A(IPT5) --- Core Hamiltonian matrix HNDDRV
A(IPT6) --- Integral buffer, scratch HNDDRV
A(IPT7) --- Integral buffer HNDDRV
A(IPT8) --- Integral buffer HNDDRV
HNDDRV
IPT1 = 1 HNDDRV
IPT2 = IPT1 + NTRI HNDDRV
IPT3 = IPT2 + NTRI HNDDRV
IPT4 = IPT3 + NTRI HNDDRV
IPT5 = IPT4 + NTRI HNDDRV
IPT6 = IPT5 + NTRI HNDDRV
IPT7 = IPT6 + NINTMX HNDDRV
IPT8 = IPT7 + NINTMX HNDDRV
HNDDRV
OPEN THE NBO DIRECT ACCESS FILE HNDDRV
HNDDRV
NEW = .FALSE. HNDDRV
CALL NBOPEN(NEW,ERROR) HNDDRV
IF(ERROR) THEN HNDDRV
WRITE(LFNPR,900) HNDDRV
STOP HNDDRV
END IF HNDDRV
HNDDRV
CALCULATE NUCLEAR REPULSION ENERGY: HNDDRV
HNDDRV
EN = ENUC(NAT,ZAN,C) HNDDRV
IF(UHF) THEN HNDDRV
HNDDRV
UHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTHNDDRV
AND SYMMETRIZE THE SKELETON FOCK MATRIX: HNDDRV
HNDDRV
ALPHA = .TRUE. HNDDRV
BETA = .FALSE. HNDDRV
CALL FENEWD(A(IPT1),NTRI) HNDDRV
ALPHA = .FALSE. HNDDRV
BETA = .TRUE. HNDDRV
CALL FENEWD(A(IPT2),NTRI) HNDDRV
CALL HSTARU(A(IPT1),A(IPT3),A(IPT2),A(IPT4),A(IPT7),A(IPT8), HNDDRV
+ A(IPT6),A(IPT7),A(IPT8),NINTMX,IA,NOPK) HNDDRV
CALL SYMFCK(A(IPT3),A(IPT6),IA) HNDDRV
CALL SYMFCK(A(IPT4),A(IPT6),IA) HNDDRV
HNDDRV
READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: HNDDRV
HNDDRV
CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11) HNDDRV
DO 100 I = 1,NX HNDDRV
A(I-1+IPT3) = A(I-1+IPT3) + A(I-1+IPT5) HNDDRV
100 A(I-1+IPT4) = A(I-1+IPT4) + A(I-1+IPT5) HNDDRV
EHFA = DOTTRI(A(IPT1),A(IPT5),NBAS) + HNDDRV
+ DOTTRI(A(IPT1),A(IPT3),NBAS) HNDDRV
EHFB = DOTTRI(A(IPT2),A(IPT5),NBAS) + HNDDRV
+ DOTTRI(A(IPT2),A(IPT4),NBAS) HNDDRV
EHF = (EHFA + EHFB)/2.0 HNDDRV
EDEL = EHF + EN HNDDRV
HNDDRV
RHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTHNDDRV
AND SYMMETRIZE THE SKELETON FOCK MATRIX: HNDDRV
HNDDRV
ELSE HNDDRV
CALL FENEWD(A(IPT1),NTRI) HNDDRV
CALL HSTAR(A(IPT1),A(IPT3),A(IPT6),A(IPT7),NINTMX,IA,NOPK) HNDDRV
CALL SYMFCK(A(IPT3),A(IPT6),IA) HNDDRV
HNDDRV
READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: HNDDRV
HNDDRV
CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11) HNDDRV
DO 200 I = 1,NX HNDDRV
200 A(I-1+IPT3) = A(I-1+IPT3) + A(I-1+IPT5) HNDDRV
EHF1 = DOTTRI(A(IPT1),A(IPT5),NBAS) HNDDRV
EHF2 = DOTTRI(A(IPT1),A(IPT3),NBAS) HNDDRV
EHF = (EHF1 + EHF2)/2.0 HNDDRV
EDEL = EHF + EN HNDDRV
END IF HNDDRV
HNDDRV
SAVE THE DELETION ENERGY ON THE NBO DIRECT ACCESS FILE AND CLOSE THE HNDDRV
FILE: HNDDRV
HNDDRV
CALL SVE0(EDEL) HNDDRV
SEQ = .FALSE. HNDDRV
CALL NBCLOS(SEQ) HNDDRV
RETURN HNDDRV
HNDDRV
900 FORMAT(/1X,'Error opening the NBO direct access file in ', HNDDRV
+ 'subroutine DELSCF.') HNDDRV
END HNDDRV
***********************************************************************HNDDRV
HNDDRV
E N D O F H N D N B O R O U T I N E S HNDDRV
HNDDRV
***********************************************************************HNDDRV
***********************************************************************AMPDRV
AMPDRV
AMPDRV
A M P N B O AMPDRV
AMPDRV
AMPDRV
AMPAC VERSION OF NBO PROGRAM AMPDRV
AMPDRV
AMPDRV
DRIVER ROUTINES: AMPDRV
AMPDRV
SUBROUTINE RUNNBO AMPDRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) AMPDRV
SUBROUTINE DELSCF(CORE,ICORE) AMPDRV
AMPDRV
***********************************************************************AMPDRV
SUBROUTINE RUNNBO AMPDRV
***********************************************************************AMPDRV
IMPLICIT REAL*8 (A-H,O-Z) AMPDRV
AMPDRV
PARAMETER(MAXATM = 99,MAXBAS = 500) AMPDRV
PARAMETER(MEMORY = 4*MAXBAS*MAXBAS) AMPDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, AMPDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, AMPDRV
+ LFNDAF,LFNDEF AMPDRV
AMPDRV
DIMENSION CORE(MEMORY),NBOOPT(10) AMPDRV
AMPDRV
LFNIN = 5 AMPDRV
LFNPR = 6 AMPDRV
AMPDRV
Set NBO options. AMPDRV
AMPDRV
NBOOPT(1) = 0 AMPDRV
NBOOPT(2) = 0 AMPDRV
NBOOPT(3) = 0 AMPDRV
NBOOPT(4) = 0 AMPDRV
NBOOPT(5) = 0 AMPDRV
NBOOPT(6) = 0 AMPDRV
NBOOPT(7) = 0 AMPDRV
NBOOPT(8) = 0 AMPDRV
NBOOPT(9) = 0 AMPDRV
NBOOPT(10) = 1 AMPDRV
AMPDRV
Perform the NPA/NBO/NLMO analyses. AMPDRV
AMPDRV
CALL NBO(CORE,MEMORY,NBOOPT) AMPDRV
AMPDRV
Perform the energetic analysis. AMPDRV
AMPDRV
10 NBOOPT(1) = 2 AMPDRV
CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) AMPDRV
IF(IDONE.NE.0) GOTO 20 AMPDRV
CALL DELSCF(CORE,CORE) AMPDRV
NBOOPT(1) = 3 AMPDRV
CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) AMPDRV
GOTO 10 AMPDRV
AMPDRV
20 RETURN AMPDRV
END AMPDRV
***********************************************************************AMPDRV
SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) AMPDRV
***********************************************************************AMPDRV
IMPLICIT REAL*8 (A-H,O-Z) AMPDRV
DIMENSION CORE(1),ICORE(1),NBOOPT(10) AMPDRV
DIMENSION LIST(9),NCORE(12) AMPDRV
AMPDRV
INCLUDE 'SIZES' AMPDRV
AMPDRV
NBO COMMON BLOCKS AMPDRV
AMPDRV
PARAMETER(MAXATM = 99,MAXBAS = 500) AMPDRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO AMPDRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO AMPDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT AMPDRV
COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, AMPDRV
+ IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, AMPDRV
+ JCORE,JPRINT(60) AMPDRV
COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) AMPDRV
COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), AMPDRV
+ LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) AMPDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, AMPDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, AMPDRV
+ LFNDAF,LFNDEF AMPDRV
AMPDRV
AMPAC COMMON BLOCKS: AMPDRV
AMPDRV
COMMON /NATORB/ NATORB(107) AMPDRV
COMMON /TITLES/ COMENT(10),TITLE(10) AMPDRV
COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK) AMPDRV
COMMON /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB) AMPDRV
COMMON /FOKMAT/ F(MPACK), FB(MPACK) AMPDRV
COMMON /GEOM / GEO(3,NUMATM) AMPDRV
COMMON /GEOKST/ NATOM,LABELS(NUMATM), AMPDRV
* NA(NUMATM), NB(NUMATM), NC(NUMATM) AMPDRV
COMMON /KEYWRD/ KEYWRD AMPDRV
CHARACTER*80 KEYWRD AMPDRV
AMPDRV
DATA LIST/51,151,152,153,254,251,255,253,252/ AMPDRV
DATA NCORE/2,10,18,28,36,46,54,68,78,86,100,110/ AMPDRV
AMPDRV
FEAOIN: (FETCH AO BASIS AND WAVE FUNCTION TYPE INFORMATION) AMPDRV
AMPDRV
OBTAIN THE FOLLOWING INFORMATION: AMPDRV
AMPDRV
ROHF =.TRUE. IF RHF OPEN SHELL WAVE FUNCTION AMPDRV
=.FALSE. OTHERWISE AMPDRV
AMPDRV
UHF =.TRUE. IF UHF WAVE FUNCTION AMPDRV
=.FALSE. OTHERWISE AMPDRV
AMPDRV
CI =.TRUE. IF UHF WAVE FUNCTION AMPDRV
=.FALSE. OTHERWISE AMPDRV
AMPDRV
OPEN =.TRUE. IF OPEN SHELL WAVE FUNCTION AMPDRV
=.FALSE. OTHERWISE AMPDRV
AMPDRV
COMPLX =.TRUE. IF COMPLEX WAVE FUNCTION AMPDRV
=.FALSE. OTHERWISE AMPDRV
(NOTE: THE PROGRAM IS NOT SET UP TO HANDLE THIS CASE) AMPDRV
AMPDRV
ORTHO =.TRUE. ORTHOGONAL AO BASIS SET AMPDRV
AMPDRV
NATOMS NUMBER OF ATOMIC CENTERS AMPDRV
AMPDRV
NDIM DIMENSION OF MATRICES (OVERLAP AND DENSITY) AMPDRV
AMPDRV
NBAS NUMBER OF BASIS FUNCTIONS (.LE.NDIM) AMPDRV
AMPDRV
IPSEUD SET TO ZERO IF NO PSEUDOPOTENTIALS ARE USED, AMPDRV
SET TO ONE IF PSEUDOPOTENTIALS ARE USED. AMPDRV
(THE ONLY EFFECT OF THIS IS TO SUPRESS THE LABELLING OFAMPDRV
ORBITALS WHEN ONE OR MORE ATOMS HAS A PSEUDOPOTENTIAL) AMPDRV
AMPDRV
IWCUBF THIS PERTAINS ONLY TO BASIS SETS WITH F FUNCTIONS. AMPDRV
AMPDRV
IF CARTESIAN F FUNCTIONS ARE INPUT, SET IWCUBF TO: AMPDRV
0, IF THESE ARE TO BE TRANSFORMED TO THE STANDARD AMPDRV
OF PURE F FUNCTIONS AMPDRV
1, IF THESE ARE TO BE TRANSFORMED TO THE CUBIC AMPDRV
SET OF PURE F FUNCTIONS AMPDRV
AMPDRV
IF PURE F FUNCTIONS ARE INPUT, SET TO IWCUBF TO: AMPDRV
0, IF THESE ARE STANDARD F FUNCTIONS AMPDRV
1, IF THESE ARE CUBIC F FUNCTIONS AMPDRV
AMPDRV
AMPDRV
IATNO(I),I=1,NATOMS AMPDRV
LIST OF ATOMIC NUMBERS AMPDRV
AMPDRV
LCTR(I),I=1,NBAS AMPDRV
LIST OF ATOMIC CENTERS OF THE BASIS FUNCTIONS AMPDRV
(LCTR(3)=2 IF BASIS FUNCT. 3 IS ON ATOM 2) AMPDRV
AMPDRV
LANG(I),I=1,NBAS AMPDRV
LIST OF ANGULAR SYMMETRY INFORMATION FOR THE BASIS AMPDRV
FUNCTIONS AMPDRV
AMPDRV
IWCUBF = 0 AMPDRV
IPSEUD = 0 AMPDRV
AMPDRV
CONSTRUCT ATOM AND AO BASIS INFORMATION LISTS: AMPDRV
IATNO(I) = ATOMIC NUMBER OF ATOM "I" AMPDRV
IZNUC(I) = NUCLEAR CHARGE ON ATOM "I" (IATNO(I)-# OF CORE ELECTRONAMPDRV
LCTR(I) = ATOMIC CENTER FOR BASIS FUNCTION "I" AMPDRV
LANG(I) = ANGULAR SYMMETRY LABEL FOR BASIS FUNCTION "I" AMPDRV
AMPDRV
IBAS = 0 AMPDRV
NAT = 0 AMPDRV
DO 200 I = 1,NATOM AMPDRV
IF(LABELS(I).EQ.99) GOTO 200 AMPDRV
NAT = NAT + 1 AMPDRV
IATNO(NAT) = LABELS(I) AMPDRV
DO 100 J = 1,12 AMPDRV
JJ = J AMPDRV
IF(IATNO(NAT)-NCORE(JJ).LT.0) GOTO 110 AMPDRV
100 CONTINUE AMPDRV
STOP 'UNKNOWN ATOM' AMPDRV
AMPDRV
110 JJ = JJ - 1 AMPDRV
IF(JJ.EQ.0) THEN AMPDRV
IZNUC(NAT) = IATNO(NAT) AMPDRV
ELSE AMPDRV
IZNUC(NAT) = IATNO(NAT) - NCORE(JJ) AMPDRV
IPSEUD = 1 AMPDRV
END IF AMPDRV
DO 150 J = 1,NATORB(LABELS(I)) AMPDRV
IBAS = IBAS + 1 AMPDRV
LCTR(IBAS) = NAT AMPDRV
LANG(IBAS) = LIST(J) AMPDRV
150 CONTINUE AMPDRV
200 CONTINUE AMPDRV
AMPDRV
PUT INFO INTO COMMON/NBINFO/: AMPDRV
AMPDRV
NATOMS = NAT AMPDRV
NDIM = IBAS AMPDRV
NBAS = IBAS AMPDRV
AMPDRV
EXPECTATION VALUES OF THE FOCK OPERATOR ARE IN ELECTRON VOLTS: AMPDRV
AMPDRV
MUNIT = 1 AMPDRV
AMPDRV
DETERMINE TYPE OF WAVE FUNCTION DENSITY MATRIX IS FROM: AMPDRV
AMPDRV
ORTHO = .TRUE. AMPDRV
IF(INDEX(KEYWRD,'C.I.').NE.0) CI = .TRUE. AMPDRV
IF(INDEX(KEYWRD,'UHF').NE.0) UHF = .TRUE. AMPDRV
IF(INDEX(KEYWRD,'OPEN').NE.0) OPEN = .TRUE. AMPDRV
IF(INDEX(KEYWRD,'DOUBLE').NE.0) OPEN = .TRUE. AMPDRV
IF(INDEX(KEYWRD,'TRIPLET').NE.0) OPEN = .TRUE. AMPDRV
IF(INDEX(KEYWRD,'QUARTET').NE.0) OPEN = .TRUE. AMPDRV
IF(INDEX(KEYWRD,'QUINTET').NE.0) OPEN = .TRUE. AMPDRV
IF(INDEX(KEYWRD,'SEXTET').NE.0) OPEN = .TRUE. AMPDRV
IF(UHF) OPEN = .TRUE. AMPDRV
IF(OPEN) UHF = .TRUE. AMPDRV
AMPDRV
IF(ROHF.OR.CI) IWFOCK = 0 AMPDRV
AMPDRV
STORE THE JOB TITLE ON THE NBO DAF: AMPDRV
AMPDRV
DO 210 I = 1,10 AMPDRV
CORE(I) = TITLE(I) AMPDRV
210 CONTINUE AMPDRV
NFILE = 2 AMPDRV
CALL NBWRIT(CORE,10,NFILE) AMPDRV
AMPDRV
STORE NATOMS, NDIM, NBAS, MUNIT, WAVEFUNCTION FLAGS, ISWEAN: AMPDRV
AMPDRV
ICORE(1) = NATOMS AMPDRV
ICORE(2) = NDIM AMPDRV
ICORE(3) = NBAS AMPDRV
ICORE(4) = MUNIT AMPDRV
ICORE(5) = 0 AMPDRV
IF(ROHF) ICORE(5) = 1 AMPDRV
ICORE(6) = 0 AMPDRV
IF(UHF) ICORE(6) = 1 AMPDRV
ICORE(7) = 0 AMPDRV
IF(CI) ICORE(7) = 1 AMPDRV
ICORE(8) = 0 AMPDRV
IF(OPEN) ICORE(8) = 1 AMPDRV
ICORE(9) = 0 AMPDRV
IF(MCSCF) ICORE(9) = 1 AMPDRV
ICORE(10) = 0 AMPDRV
IF(AUHF) ICORE(10) = 1 AMPDRV
ICORE(11) = 0 AMPDRV
IF(ORTHO) ICORE(11) = 1 AMPDRV
ICORE(12) = 1 AMPDRV
NFILE = 3 AMPDRV
CALL NBWRIT(ICORE,12,NFILE) AMPDRV
AMPDRV
STORE IATNO, IZNUC, LCTR, AND LANG ON NBO DAF: AMPDRV
AMPDRV
II = 0 AMPDRV
DO 220 I = 1,NATOMS AMPDRV
II = II + 1 AMPDRV
ICORE(II) = IATNO(I) AMPDRV
220 CONTINUE AMPDRV
DO 230 I = 1,NATOMS AMPDRV
II = II + 1 AMPDRV
ICORE(II) = IZNUC(I) AMPDRV
230 CONTINUE AMPDRV
DO 240 I = 1,NBAS AMPDRV
II = II + 1 AMPDRV
ICORE(II) = LCTR(I) AMPDRV
240 CONTINUE AMPDRV
DO 250 I = 1,NBAS AMPDRV
II = II + 1 AMPDRV
ICORE(II) = LANG(I) AMPDRV
250 CONTINUE AMPDRV
NFILE = 4 AMPDRV
CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) AMPDRV
AMPDRV
STORE ATOMIC COORDINATES ON THE NBO DAF: AMPDRV
AMPDRV
CALL GMETRY(GEO,CORE) AMPDRV
NFILE = 9 AMPDRV
CALL NBWRIT(CORE,3*NATOMS,NFILE) AMPDRV
AMPDRV
STORE THE DENSITY MATRICES ON THE NBO DAF: AMPDRV
AMPDRV
IWDM = 0 AMPDRV
L2 = NDIM*(NDIM+1)/2 AMPDRV
IF(OPEN) THEN AMPDRV
NFILE = 20 AMPDRV
CALL NBWRIT(PA,L2,NFILE) AMPDRV
NFILE = 21 AMPDRV
CALL NBWRIT(PB,L2,NFILE) AMPDRV
ELSE AMPDRV
NFILE = 20 AMPDRV
CALL NBWRIT(P,L2,NFILE) AMPDRV
END IF AMPDRV
AMPDRV
STORE THE FOCK MATRICES ON THE NBO DAF: AMPDRV
AMPDRV
IF(.NOT.ROHF.AND..NOT.CI) THEN AMPDRV
NFILE = 30 AMPDRV
CALL NBWRIT(F,L2,NFILE) AMPDRV
IF(OPEN) THEN AMPDRV
NFILE = 31 AMPDRV
CALL NBWRIT(FB,L2,NFILE) AMPDRV
END IF AMPDRV
END IF AMPDRV
AMPDRV
STORE THE AO TO MO TRANSFORMATIONS ON THE NBO DAF: AMPDRV
AMPDRV
L3 = NDIM*NDIM AMPDRV
NFILE = 40 AMPDRV
CALL NBWRIT(C,L3,NFILE) AMPDRV
IF(OPEN) THEN AMPDRV
NFILE = 41 AMPDRV
CALL NBWRIT(CBETA,L3,NFILE) AMPDRV
END IF AMPDRV
AMPDRV
RETURN AMPDRV
END AMPDRV
***********************************************************************AMPDRV
SUBROUTINE DELSCF(CORE,ICORE) AMPDRV
***********************************************************************AMPDRV
IMPLICIT REAL*8 (A-H,O-Z) AMPDRV
LOGICAL NEW,ERROR,SEQ AMPDRV
AMPDRV
NBO common blocks: AMPDRV
AMPDRV
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT AMPDRV
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO AMPDRV
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO AMPDRV
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, AMPDRV
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, AMPDRV
+ LFNDAF,LFNDEF AMPDRV
AMPDRV
AMPAC COMMON blocks: AMPDRV
AMPDRV
INCLUDE 'SIZES' AMPDRV
AMPDRV
COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), AMPDRV
+ NLAST(NUMATM), NORBS, NELECS, AMPDRV
+ NALPHA, NBETA, NCLOSE, NOPEN, NDUMY, FRACT AMPDRV
COMMON /HMATRX/ H(MPACK) AMPDRV
COMMON /WMATRX/ WJ(N2ELEC), WK(N2ELEC) AMPDRV
COMMON /FOKMAT/ F(MPACK), FB(MPACK) AMPDRV
COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK) AMPDRV
COMMON /ATHEAT/ ATHEAT AMPDRV
COMMON /ENUCLR/ ENUCLR AMPDRV
COMMON /GEOM / GEO(3,NUMATM) AMPDRV
AMPDRV
DIMENSION CORE(1),ICORE(1),W(N2ELEC) AMPDRV
EQUIVALENCE (W(1),WJ(1)) AMPDRV
AMPDRV
DATA TWO,TOKCAL/2.0D0,23.061D0/ AMPDRV
AMPDRV
Open the NBO direct access file: AMPDRV
AMPDRV
NEW = .FALSE. AMPDRV
CALL NBOPEN(NEW,ERROR) AMPDRV
IF(ERROR) THEN AMPDRV
WRITE(LFNPR,900) AMPDRV
STOP AMPDRV
END IF AMPDRV
AMPDRV
Compute the one-electron and two-electron integrals, given the atomicAMPDRV
coordinates. Also compute the nuclear repulsion contribution to the AMPDRV
SCF energy: AMPDRV
AMPDRV
CALL GMETRY(GEO,CORE) AMPDRV
CALL HCORE(CORE,H,W,WJ,WK,ENUCLR) AMPDRV
AMPDRV
Compute the SCF and deletion energies for UHF wavefunctions: AMPDRV
AMPDRV
LEN = NBAS * (NBAS + 1) / 2 AMPDRV
IF(UHF) THEN AMPDRV
AMPDRV
Read the spin densities from the NBO direct access file and calculateAMPDRV
to total density: AMPDRV
AMPDRV
ALPHA = .TRUE. AMPDRV
BETA = .FALSE. AMPDRV
CALL FEDRAW(PA,CORE) AMPDRV
CALL PACK(PA,NDIM,NBAS,LEN) AMPDRV
ALPHA = .FALSE. AMPDRV
BETA = .TRUE. AMPDRV
CALL FEDRAW(PB,CORE) AMPDRV
CALL PACK(PB,NDIM,NBAS,LEN) AMPDRV
DO 10 I = 1,LEN AMPDRV
P(I) = PA(I) + PB(I) AMPDRV
10 CONTINUE AMPDRV
AMPDRV
Alpha spin: construct the alpha Fock matrix: AMPDRV
AMPDRV
CALL COPY(H,F,LEN,LEN,1) AMPDRV
CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV
CALL FOCK1(F,P,PA,PB) AMPDRV
AMPDRV
Alpha spin: construct the alpha Fock matrix: AMPDRV
AMPDRV
CALL COPY(H,FB,LEN,LEN,1) AMPDRV
CALL FOCK2(FB,P,PB,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV
CALL FOCK1(FB,P,PB,PA) AMPDRV
AMPDRV
Determine the SCF energy: AMPDRV
AMPDRV
EE = HELECT(NBAS,PA,H,F) + HELECT(NBAS,PB,H,FB) AMPDRV
ESCF = (EE + ENUCLR) * TOKCAL + ATHEAT AMPDRV
AMPDRV
Repeat process for the deletion energy: AMPDRV
AMPDRV
ALPHA = .TRUE. AMPDRV
BETA = .FALSE. AMPDRV
CALL FENEWD(PA) AMPDRV
ALPHA = .FALSE. AMPDRV
BETA = .TRUE. AMPDRV
CALL FENEWD(PB) AMPDRV
DO 20 I = 1,LEN AMPDRV
P(I) = PA(I) + PB(I) AMPDRV
20 CONTINUE AMPDRV
CALL COPY(H,F,LEN,LEN,1) AMPDRV
CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV
CALL FOCK1(F,P,PA,PB) AMPDRV
CALL COPY(H,FB,LEN,LEN,1) AMPDRV
CALL FOCK2(FB,P,PB,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV
CALL FOCK1(FB,P,PB,PA) AMPDRV
EE = HELECT(NBAS,PA,H,F) + HELECT(NBAS,PB,H,FB) AMPDRV
EDEL = (EE + ENUCLR) * TOKCAL + ATHEAT AMPDRV
AMPDRV
Compute the SCF and deletion energies for RHF wavefunctions: AMPDRV
AMPDRV
ELSE AMPDRV
ALPHA = .FALSE. AMPDRV
BETA = .FALSE. AMPDRV
CALL FEDRAW(P,CORE) AMPDRV
CALL PACK(P,NDIM,NBAS,LEN) AMPDRV
DO 30 I = 1,LEN AMPDRV
PA(I) = P(I) / TWO AMPDRV
PB(I) = P(I) / TWO AMPDRV
30 CONTINUE AMPDRV
AMPDRV
Construct the Fock matrix: AMPDRV
AMPDRV
CALL COPY(H,F,LEN,LEN,1) AMPDRV
CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV
CALL FOCK1(F,P,PA,PB) AMPDRV
AMPDRV
Determine the SCF energy: AMPDRV
AMPDRV
EE = HELECT(NBAS,PA,H,F) * TWO AMPDRV
ESCF = (EE + ENUCLR) * TOKCAL + ATHEAT AMPDRV
AMPDRV
Repeat process for the deletion energy: AMPDRV
AMPDRV
CALL FENEWD(P) AMPDRV
DO 40 I = 1,LEN AMPDRV
PA(I) = P(I) / TWO AMPDRV
PB(I) = P(I) / TWO AMPDRV
40 CONTINUE AMPDRV
CALL COPY(H,F,LEN,LEN,1) AMPDRV
CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV
CALL FOCK1(F,P,PA,PB) AMPDRV
EE = HELECT(NBAS,PA,H,F) * TWO AMPDRV
EDEL = (EE + ENUCLR) * TOKCAL + ATHEAT AMPDRV
END IF AMPDRV
AMPDRV
Save these energies on the direct access file: AMPDRV
AMPDRV
CORE(1) = EDEL AMPDRV
CORE(2) = ESCF AMPDRV
NFILE = 8 AMPDRV
CALL NBWRIT(CORE,2,NFILE) AMPDRV
AMPDRV
Note that these energies are in units of kcal/mol!! AMPDRV
AMPDRV
MUNIT = 2 AMPDRV
NFILE = 3 AMPDRV
CALL NBREAD(ICORE,12,NFILE) AMPDRV
ICORE(4) = MUNIT AMPDRV
CALL NBWRIT(ICORE,12,NFILE) AMPDRV
AMPDRV
Close the NBO direct access file: AMPDRV
AMPDRV
SEQ = .FALSE. AMPDRV
CALL NBCLOS(SEQ) AMPDRV
RETURN AMPDRV
AMPDRV
900 FORMAT(/1X,'Error opening the NBO direct access file in ', AMPDRV
+ 'subroutine DELSCF.') AMPDRV
END AMPDRV
***********************************************************************AMPDRV
AMPDRV
E N D O F A M P N B O R O U T I N E S AMPDRV
AMPDRV
***********************************************************************AMPDRV
ÿ
|
