|
nbo
|
|
0origin,
README,
ch3nh2.arc,
enable.for,
g90.man,
gennbo.for,
junk,
nbo.man,
nbo.src,
readme.g90,
readme.nbo
|
|
|
C*****************************************************************************
C
C
C
C N B O P R O G R A M
C
C (SYSTEM INDEPENDENT ROUTINES)
C
C
C
C LAST PROGRAM MODIFICATION: OCTOBER 22, 1991
C
C
C !!! CRAY COMPILATION REQUIRES 64 BIT (-i64) INTEGERS !!!
C (SEE, IN PARTICULAR, SR JOBOPT, SR NBOPEN, AND SR DEBYTE)
C
C*****************************************************************************
C
C MAIN SUBROUTINE:
C
C SUBROUTINE NBO(CORE,NBOOPT,MEMORY)
C
C JOB INITIALIZATION ROUTINES: (CALLED BY SR NBO)
C
C SUBROUTINE NBOSET(NBOOPT)
C SUBROUTINE JOBOPT(NBOOPT)
C SUBROUTINE NBODIM(MEMORY)
C
C NAO/NBO/NLMO FORMATION ROUTINES: (CALLED BY SR NBO)
C
C SUBROUTINE NAODRV(DM,T,A)
C SUBROUTINE NAOSIM(DM,T,A)
C SUBROUTINE DMNAO(DM,T,A)
C SUBROUTINE DMSIM(DM,T,A)
C SUBROUTINE NBODRV(DM,T,A,MEMORY)
C
C ROUTINES CALLED BY THE NAO DRIVERS:
C
C SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF)
C SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF)
C SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR)
C SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK)
C SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO)
C SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG)
C
C ROUTINES CALLED BY SR NAO:
C
C SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM)
C SUBROUTINE ATDIAG(N,A,B,EVAL,C)
C SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM)
C SUBROUTINE NEWWTS(S,T,WT)
C SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK)
C SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK)
C SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2,
C + LIST,IRPNAO)
C SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
C + IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
C SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT)
C SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO)
C SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,IRPNAO)
C
C ROUTINES CALLED BY THE NBO/NLMO DRIVERS:
C
C SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C + P,TA,HYB,VA,VB,TOPO)
C SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C + P,TA,HYB,VA,VB,TOPO)
C SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C + P,TA,HYB,VA,VB,TOPO,IFLG)
C SUBROUTINE SRTNBO(T,BNDOCC)
C SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR)
C SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB)
C SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN)
C SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
C SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR)
C SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB)
C SUBROUTINE FNDMOL(IATOMS)
C SUBROUTINE NBOCLA(BNDOCC,ACCTHR)
C SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO)
C SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR)
C SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG)
C SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR)
C SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM)
C SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,SIAB,NOCC,NAB)
C SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX)
C SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX)
C SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC)
C
C ROUTINES CALLED BY SR NATHYB, SR CHOOSE:
C
C SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
C FUNCTION IWPRJ(NCTR)
C SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD)
C SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
C SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP)
C SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
C SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG)
C SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI)
C SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
C SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD)
C SUBROUTINE FORMT(T,Q,POL)
C SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
C
C ROUTINES CALLED BY SR NLMO:
C
C SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT,
C + NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
C SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL)
C
C NBO ENERGETIC ANALYSIS ROUTINES:
C
C SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE)
C SUBROUTINE NBODEL(A,MEMORY,IDONE)
C SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE,
C + ISPIN)
C SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN)
C SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK)
C SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL)
C
C NBO DIRECT ACCESS FILE (DAF) ROUTINES:
C
C SUBROUTINE NBFILE(NEW,ERROR)
C SUBROUTINE NBOPEN(NEW,ERROR)
C SUBROUTINE NBWRIT(IX,NX,IDAR)
C SUBROUTINE NBREAD(IX,NX,IDAR)
C SUBROUTINE NBCLOS(SEQ)
C SUBROUTINE NBINQR(IDAR)
C
C SUBROUTINE FETITL(TITLE)
C SUBROUTINE FEE0(EDEL,ETOT)
C SUBROUTINE SVE0(EDEL)
C SUBROUTINE FECOOR(ATCOOR)
C SUBROUTINE FESRAW(S)
C SUBROUTINE FEDRAW(DM,SCR)
C SUBROUTINE FEFAO(F,IWFOCK)
C SUBROUTINE FEAOMO(T,IT)
C SUBROUTINE FEDXYZ(DXYZ,I)
C SUBROUTINE SVNBO(T,OCC,ISCR)
C SUBROUTINE FENBO(T,OCC,ISCR,NELEC)
C SUBROUTINE FETNBO(T)
C SUBROUTINE SVPNAO(T)
C SUBROUTINE FEPNAO(T)
C SUBROUTINE SVSNAO(S)
C SUBROUTINE FESNAO(S)
C SUBROUTINE SVTNAB(T)
C SUBROUTINE FETNAB(T)
C SUBROUTINE SVTLMO(T)
C SUBROUTINE FETLMO(T)
C SUBROUTINE SVTNHO(T)
C SUBROUTINE FETNHO(T)
C SUBROUTINE SVPPAO(DM)
C SUBROUTINE FEPPAO(DM)
C SUBROUTINE SVTNAO(T)
C SUBROUTINE FETNAO(T)
C SUBROUTINE SVNLMO(T)
C SUBROUTINE FENLMO(T)
C SUBROUTINE SVDNAO(DM)
C SUBROUTINE FEDNAO(DM)
C SUBROUTINE SVFNBO(F)
C SUBROUTINE FEFNBO(F)
C SUBROUTINE SVNEWD(DM)
C SUBROUTINE FENEWD(DM)
C SUBROUTINE FEINFO(ICORE,ISWEAN)
C SUBROUTINE FEBAS(NSHELL,NEXP,ISCR)
C
C FREE FORMAT INPUT ROUTINES:
C
C SUBROUTINE STRTIN(LFNIN)
C SUBROUTINE RDCRD
C SUBROUTINE IFLD(INT,ERROR)
C SUBROUTINE RFLD(REAL,ERROR)
C SUBROUTINE HFLD(KEYWD,LENG,ENDD)
C SUBROUTINE FNDFLD
C FUNCTION EQUAL(IA,IB,L)
C
C OTHER SYSTEM-INDEPENDENT I/O ROUTINES:
C
C SUBROUTINE GENINP(NEWDAF)
C SUBROUTINE NBOINP(NBOOPT,IDONE)
C SUBROUTINE CORINP(IESS,ICOR)
C SUBROUTINE CHSINP(IESS,ICHS)
C SUBROUTINE DELINP(NBOOPT,IDONE)
C
C SUBROUTINE RDCORE(JCORE)
C SUBROUTINE WRPPNA(T,OCC,IFLG)
C SUBROUTINE RDPPNA(T,OCC,IFLG)
C SUBROUTINE WRTNAO(T,IFLG)
C SUBROUTINE RDTNAO(DM,T,SCR,IFLG)
C SUBROUTINE WRTNAB(T,IFLG)
C SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG)
C SUBROUTINE WRTNBO(T,BNDOCC,IFLG)
C SUBROUTINE WRNLMO(T,DM,IFLG)
C SUBROUTINE WRBAS(SCR,ISCR,LFN)
C SUBROUTINE WRARC(SCR,ISCR,LFN)
C
C SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG)
C SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL)
C SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN)
C SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR)
C SUBROUTINE ALTOUT(A,MR,MC,NR,NC)
C SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR)
C FUNCTION IOINQR(IFLG)
C SUBROUTINE LBLAO
C SUBROUTINE LBLNAO
C SUBROUTINE LBLNBO
C SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR)
C
C GENERAL UTILITY ROUTINES:
C
C SUBROUTINE ANGLES(X,Y,Z,THETA,PHI)
C FUNCTION BDFIND(IAT,JAT)
C SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR)
C SUBROUTINE CONSOL(AUT,ALT,NDIM,N)
C SUBROUTINE CONVIN(IJ,LEN,IK,ERROR)
C SUBROUTINE CONVRT(N,NC1,NC2)
C SUBROUTINE COPY(A,B,NDIM,NR,NC)
C SUBROUTINE CORTBL(IAT,ICORE,IECP)
C SUBROUTINE DEBYTE(I,IBYTE)
C SUBROUTINE HALT(WORD)
C SUBROUTINE IDIGIT(KINT,IK,ND,MAXD)
C FUNCTION IHTYP(IBO,JBO)
C SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR)
C SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT)
C SUBROUTINE MATMLT(A,B,V,NDIM,N)
C SUBROUTINE MATML2(A,B,V,NDIM,N)
C FUNCTION NAMEAT(IZ)
C SUBROUTINE NORMLZ(A,S,M,N)
C SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK)
C SUBROUTINE PACK(T,NDIM,NBAS,L2)
C SUBROUTINE RANK(EIG,N,NDIM,ARCRNK)
C SUBROUTINE SIMTRN(A,T,V,NDIM,N)
C SUBROUTINE SIMTRS(A,S,V,NDIM,N)
C SUBROUTINE TRANSP(A,NDIM,N)
C SUBROUTINE UNPACK(T,NDIM,NBAS,L2)
C SUBROUTINE VALTBL(IAT,IVAL)
C FUNCTION VECLEN(X,N,NDIM)
C
C SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR,
C + IERR)
C SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG)
C SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR)
C SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM)
C
C*****************************************************************************
SUBROUTINE NBO(CORE,MEMORY,NBOOPT)
C*****************************************************************************
C
C Input:
C CORE Core memory to be dynamically allocated for storage needs.
C MEMORY The number of REAL*8 words available in `CORE'.
C NBOOPT(10) List of NBO options as summarized below:
C
C NBOOPT(1) = -2 Do nothing
C = -1 Natural Population Analysis (NPA) only
C = 0 Perform NPA/NBO/NLMO analyses
C = 1 Perform NPA/NBO/NLMO analyses, don't read keywords
C = 2 Perform one Fock matrix deletion, forming new DM
C = 3 Evaluate and print the energy change from deletion
C
C NBOOPT(2) = 0 SCF density
C = 1 MP first order density
C = 3 MP2 density
C = 4 MP3 density
C = 5 MP4 density
C = 6 CI one-particle density
C = 7 CI density
C = 8 QCI/CC density
C = 9 Density correct to second order
C
C NBOOPT(3) = 1 Transform dipole moment matrices to NBO/NLMO bases
C
C NBOOPT(4) = 1 Allow strongly resonant Lewis Structures
C (Force the RESONANCE keyword)
C
C NBOOPT(5) = 1 Spin-annihilated UHF (AUHF) wavefunction
C
C NBOOPT(6-9) Unused
C
C NBOOPT(10) = 0 General version of the NBO program (GENNBO)
C = 1 AMPAC version
C = 6 GAMESS version
C = 7 HONDO version
C = 8x Gaussian 8x version
C------------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL NEWDAF,ERROR,SEQ
C
C NBO COMMON BLOCKS:
C
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
C
DIMENSION CORE(MEMORY),NBOOPT(10)
C
C IF NBOOPT(1).EQ.-2, THEN NO NBO ANALYSIS WAS REQUESTED:
C
IF(NBOOPT(1).EQ.-2) RETURN
C
C SET DEFAULT OPTIONS:
C
CALL NBOSET(NBOOPT)
C
C IF THIS IS THE GENERAL VERSION OF THE PROGRAM, READ THE $GENNBO KEYLIST:
C
IF(NBOOPT(10).EQ.0) THEN
CALL GENINP(NEWDAF)
ELSE
NEWDAF = .TRUE.
END IF
C
C SEARCH THE INPUT FILE FOR THE $NBO KEYLIST:
C
CALL NBOINP(NBOOPT,IDONE)
IF(IDONE.EQ.1) RETURN
C
C READ IN JOB OPTIONS FROM THE $NBO KEYLIST:
C
CALL JOBOPT(NBOOPT)
C
C CHECK FILENAME AND OPEN SEQUENTIAL FILES:
C
CALL NBFILE(NEWDAF,ERROR)
IF(ERROR) RETURN
C
C OPEN THE NBO DIRECT ACCESS FILE:
C
CALL NBOPEN(NEWDAF,ERROR)
IF(ERROR) THEN
WRITE(LFNPR,900)
RETURN
END IF
C
C FETCH ATOMS, BASIS, AND WAVE FUNCTION INFORMATION:
C
CALL FEAOIN(CORE,CORE,NBOOPT)
IF(COMPLX) RETURN
C
C WRITE THE JOB TITLE TO THE OUTPUT FILE:
C
CALL FETITL(CORE)
WRITE(LFNPR,910) (CORE(I),I=1,8)
C
C SET UP DIMENSIONING INFORMATION AND DETERMINE IF ENOUGH SPACE IS AVAILABLE:
C
CALL NBODIM(MEMORY)
C
C SET UP BASIC STORAGE:
C
C CORE(NDM) : NDIM BY NDIM MATRIX TO STORE DENSITY MATRIX
C CORE(NT) : NDIM BY NDIM MATRIX TO HOLD OVERLAP OR TRANSFORMATION MATRICES
C CORE(NSCR): SCRATCH STORAGE, DYNAMICALLY ALLOCATED ACCORDING NEEDS
C
N2 = NDIM*NDIM
NDM = 1
NT = NDM + N2
NSCR = NT + N2
MEM = MEMORY - NSCR + 1
C
C READ IN INPUT OVERLAP AND DENSITY MATRICES, AO BASIS:
C
ALPHA = .FALSE.
BETA = .FALSE.
ISPIN = 0
CALL FEDRAW(CORE(NDM),CORE(NSCR))
C
C SIMULATE THE NATURAL POPULATION ANALYSIS IF THE INPUT BASIS IS ORTHOGONAL:
C
IF(ORTHO) THEN
CALL NAOSIM(CORE(NDM),CORE(NT),CORE(NSCR))
C
C LOAD THE OVERLAP MATRIX INTO CORE(NT) AND PERFORM THE NATURAL POPULATION
C ANALYSIS:
C
ELSE
CALL FESRAW(CORE(NT))
CALL NAODRV(CORE(NDM),CORE(NT),CORE(NSCR))
END IF
C
C NOTE: CORE(NDM) NOW CONTAINS THE TOTAL DENSITY MATRIX IN THE NAO BASIS
C AND CORE(NT) CONTAINS THE AO TO NAO TRANSFORMATION
C
C PERFORM CLOSED SHELL NBO ANALYSIS:
C
IF(.NOT.OPEN) THEN
CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM)
ELSE
C
C PERFORM OPEN SHELL NBO ANALYSIS:
C
C FIRST, ANALYZE ALPHA DENSITY MATRIX:
C
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)
C
C NOW, ANALYZE BETA DENSITY MATRIX:
C
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
C
C CLOSE THE NBO DIRECT ACCESS FILE AND OTHER EXTERNAL FILES:
C
SEQ = .TRUE.
CALL NBCLOS(SEQ)
RETURN
C
900 FORMAT(/1X,'NBO direct access file could not be opened. NBO ',
+ 'program aborted.')
910 FORMAT(/1X,'Job title: ',8A8)
END
C*****************************************************************************
C
C JOB INITIALIZATION ROUTINES: (CALLED BY SR NBO)
C
C SUBROUTINE NBOSET(NBOOPT)
C SUBROUTINE JOBOPT(NBOOPT)
C SUBROUTINE NBODIM(MEMORY)
C
C*****************************************************************************
SUBROUTINE NBOSET(NBOOPT)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION NBOOPT(10)
C
PARAMETER(MAXATM = 99,MAXBAS = 500)
PARAMETER(MAXFIL = 40)
C
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
C
DATA TENTH,HALF/0.1D0,0.5D0/
C
C SET DEFAULT JOB OPTIONS: (MODIFICATIONS TO THESE DEFAULTS
C SHOULD NOT BE MADE HERE BUT LATER IN THIS SUBROUTINE)
C
C USE THE BOND-ORDER MATRIX, NOT THE OCCUPATION MATRIX (EXPECTATION
C VALUES OF THE DENSITY OPERATOR)
C
IWDM = 1
IW3C = 0
IWAPOL = 0
IWHYBS = 0
IWPNAO = 0
IWTNAO = 0
IWTNAB = 0
IWTNBO = 0
C
C USE THE FOCK MATRIX, IF THERE IS ONE:
C
IWFOCK = 1
C
C SET TO THE DESIRED PRINT LEVEL + 10:
C
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
C
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
C
C SET POSITIVE IN ROUTINE JOBOPT IF CHOSEN BY THE USER:
C
LFNDAF = -48
LFNDEF = 49
C
C SETTING NVAL NEGATIVE INDICATES THAT THIS VARIABLE HAS NOT
C BEEN DETERMINED YET:
C
NVAL = -1
C
C INITIALIZE THE CHARACTER STRING USED TO CREATE FILENAMES:
C
FILENM(1:4) = 'FILE'
DO 50 I = 5,80
FILENM(I:I) = CHAR(32)
50 CONTINUE
C
C THAT SOME THRESHOLDS ARE .LT.0 INDICATES THAT THESE VARIABLES HAVE NOT
C BEEN SET BY THE USER:
C
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
C
C SET JOB OPTIONS ACCORDING TO NBOOPT:
C
C SKIP THE COMPUTATION OF THE NBOS?
C
IF(NBOOPT(1).EQ.-1) JPRINT(1) = 1
C
C TURN OFF $CHOOSE AND $CORE KEYLISTS IF $NBO KEYLIST IS NOT TO
C BE READ:
C
IF(NBOOPT(1).EQ.1) ICHOOS = -1
IF(NBOOPT(1).EQ.1) JCORE = -1
C
C FORCE DIPOLE ANALYSIS?
C
IF(NBOOPT(3).NE.0) THEN
JPRINT(46) = 1
END IF
C
C FORCE RESONANCE KEYWORD?
C
IF(NBOOPT(4).NE.0) JPRINT(14) = 1
C
C PROGRAM VERSION:
C
JPRINT(2) = NBOOPT(10)
C
RETURN
END
C******************************************************************************
SUBROUTINE JOBOPT(NBOOPT)
C******************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR,END,EQUAL,NEXTWD,READ
DIMENSION NBOOPT(10),INTTMP(80)
C
PARAMETER(KEYLEN = 9)
PARAMETER(MAXFIL = 40)
C
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
C
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)
C
DIMENSION KALT(4),KBFGS(4),KPOWEL(6),KSAP(3)
C
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/
C
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/
C
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/
C
DATA KALT/1H$,1HE,1HN,1HD/,KBFGS/1HB,1HF,1HG,1HS/,
* KPOWEL/1HP,1HO,1HW,1HE,1HL,1HL/,KSAP/1HS,1HA,1HP/
C
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/
C
C READ IN JOB OPTIONS, IN A KEYWORD DIRECTED MANNER:
C
NUMOPT = 0
LENNM = 0
IF(NBOOPT(1).EQ.1) GOTO 4500
C
C BEGIN LOOP TO IDENTIFY KEYWORD "KEYWD":
C
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
C
C KEYWORD: 3CBOND -- SEARCH FOR THREE-CENTER BONDS
C (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
C 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
C 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
C KEYWORD: DETAIL -- PRINT DETAILS OF NBO SEARCH PROCEDURE
540 IF(.NOT.EQUAL(KEYWD,KDETL,6)) GO TO 550
IWDETL = 1
GO TO 100
C KEYWORD: MULAT -- PRINT MULLIKEN POPULATIONS BY ATOM
550 IF(.NOT.EQUAL(KEYWD,KMULA,5)) GO TO 560
IWMULP = 1
GO TO 100
C KEYWORD: MULORB -- PRINT MULLIKEN POPULATIONS BY ORBITAL AND ATOM
560 IF(.NOT.EQUAL(KEYWD,KMULOR,6)) GO TO 580
IWMULP = 2
GO TO 100
C KEYWORD: PRJTHR -- USER SETS VALUE OF PROJECTION THRESHOLD FOR NBO SEARCH
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C KEYWORD: NOBOND -- COMPUTE ONLY ONE-CENTER NBOS
680 IF(.NOT.EQUAL(KEYWD,KNOBND,6)) GO TO 690
JPRINT(10) = 1
GO TO 100
C KEYWORD: SKIPBO -- SKIP NBO PROCEDURE
690 IF(.NOT.EQUAL(KEYWD,KSKIPB,6)) GO TO 700
JPRINT(1) = 1
GO TO 100
C 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
C KEYWORD: BNDIDX -- PRINT BOND INDICES
710 IF(.NOT.EQUAL(KEYWD,KBNDID,6)) GO TO 730
JPRINT(12) = 1
GO TO 100
C KEYWORD: RESONANCE -- ALLOW STRONGLY "NON-LEWIS" NBO OCCUPANCIES
C (OVERRIDES AUTOMATIC SHUTDOWN OF NBO PROCEDURE IN STRONGLY
C DELOCALIZED CASES)
730 IF(.NOT.EQUAL(KEYWD,KRESON,5)) GO TO 740
JPRINT(14) = 1
GO TO 100
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C KEYWORD: NPA -- PRINT THE NATURAL POPULATION ANALYSIS
1120 IF(.NOT.EQUAL(KEYWD,KNPA,3)) GO TO 1130
JPRINT(4) = 1
GO TO 100
C KEYWORD: NBOSUM -- PRINT THE NBO SUMMARY
1130 IF(.NOT.EQUAL(KEYWD,KNBOSM,6)) GO TO 1140
JPRINT(6) = 1
GO TO 100
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C 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
C KEYWORD: APOLAR -- ENFORCE APOLAR BONDS:
1270 IF(.NOT.EQUAL(KEYWD,KPOLAR,6)) GO TO 1290
IWAPOL = 1
GO TO 100
C 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
C 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
C 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
C 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
C 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
C KEYWORD: NRT -- PERFORM NATURAL RESONANCE THEORY ANALYSIS:
C (NOTE THAT WE SHOULD CHECK THIS KEYWORD AFTER WE CHECK THE OTHER
C `NRT' KEYWORDS, LIKE `NRTOPT'. OTHERWISE, KEYWORD CONFLICTS CAN
C 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
C------------------------------------------------------------------------------
4500 CONTINUE
C
C IF OPTION `FILE' WAS SELECTED, EXTRACT THE FILENAME FROM HOLLERITH
C ARRAY INTTMP:
C
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
C------------------------------------------------------------------------------
C
C IF THE PRINT LEVEL IS SET TO ZERO AND NO OTHER OPTIONS WERE ENTERED,
C COMPLETELY SHUT OFF PROGRAM PRINTING:
C
IF(NUMOPT.EQ.1.AND.IPRINT.EQ.0) IPRINT = -1
C
C CHECK FOR JOB OPTIONS THAT ARE CURRENTLY INCOMPATABLE:
C
IF((IWDM.EQ.0).AND.(IWMULP.NE.0)) GO TO 4900
C
C CHECK FOR JOB OPTIONS THAT ARE STRICTLY INCOMPATIBLE:
C
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
C------------------------------------------------------------------------------
C
C START PRINTING NBO OUTPUT:
C
IF(IPRINT.GE.0) THEN
WRITE(LFNPR,6000)
IF(NUMOPT.GT.0) WRITE(LFNPR,6010)
C------------------------------------------------------------------------------
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)
C------------------------------------------------------------------------------
C
C JOB CONTROL KEYWORDS:
C
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)
C------------------------------------------------------------------------------
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)
C------------------------------------------------------------------------------
C
C JOB THRESHOLD KEYWORDS:
C
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
C------------------------------------------------------------------------------
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)
C------------------------------------------------------------------------------
C
C MATRIX OUTPUT KEYWORDS:
C
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
C------------------------------------------------------------------------------
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)
C------------------------------------------------------------------------------
C
C OTHER OUTPUT CONTROL KEYWORDS:
C
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)
C
IF(IPRINT.LT.10) THEN
WRITE(LFNPR,8500) IPRINT
ELSE
IPRINT = IPRINT - 10
END IF
C------------------------------------------------------------------------------
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)
C------------------------------------------------------------------------------
END IF
C
C SET PRINT LEVEL OPTIONS:
C
IF(IPRINT.GT.0) THEN
JPRINT(4) = 1
JPRINT(5) = 1
END IF
C
IF(IPRINT.GT.1) THEN
JPRINT(3) = 1
JPRINT(6) = 1
JPRINT(36) = 1
END IF
C
IF(IPRINT.GT.2) THEN
JPRINT(8) = 1
JPRINT(12) = 1
JPRINT(46) = 1
END IF
C
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
C
C TURN ON THE NLMO ANALYSIS IF REQUIRED:
C
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
C
C TAKE CARE OF THE PLOT OPTION:
C
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
C
C PRINT HYBRIDS IF THE NBO OUTPUT IS REQUESTED:
C
IWHYBS = JPRINT(5)
RETURN
C
C ABORT PROGRAM: UNRECOGNIZABLE KEYWORD ENCOUNTERED
C
4800 WRITE(LFNPR,9800) (KEYWD(I),I=1,6)
STOP
C
C INCOMPATIBLE JOB OPTIONS HAVE BEEN REQUESTED:
C
4900 CONTINUE
WRITE(LFNPR,9900)
STOP
C
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
C*****************************************************************************
SUBROUTINE NBODIM(MEMORY)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION NSPDFG(5,2)
C
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)
C
DATA IREAD/4HREAD/
C
C NBODIM: SET UP DIMENSIONING INFORMATION, LISTS IN COMMON/NBATOM/,
C AND COMPARE STORAGE NEEDS WITH AMOUNT OF STORAGE AVAILABLE
C
C FIND:
C MXAOLM, THE MAXIMUM NUMBER OF ATOMIC ORBITALS OF THE SAME SYMMETRY
C ON A SINGLE ATOM
C MXAO, THE MAXIMUM NUMBER OF ATOMIC ORBITALS PER ATOM
C MXBO, THE MAXIMUM NUMBER OF ATOMIC ORBITALS PER TWO-CENTER OR
C THREE-CENTER BOND
C
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
C
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
C
C IF IM.NE.1 (THAT IS, IF THIS IS NOT THE FIRST COMPONENT OF THE
C ANG. MOM. L FUNCTIONS ON THE ATOM), DON'T COUNT IT IN NSPDFG:
C
IF(IM.NE.1) GO TO 410
C
C ITYP=1 FOR CARTESIAN FUNCTION, =2 FOR TRUE SPHERICAL HARMONIC:
C
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
C
C NUMBER OF S ORBITALS= NO. S ORBS INPUT + NO. CARTESIAN D AND G ORBS:
C
NSPDFG(1,1) = NSPDFG(1,1) + NSPDFG(1,2) + NSPDFG(3,1) +
+ NSPDFG(5,1)
C
C NUMBER OF P ORBITALS= NO. P ORBS INPUT + NO. CARTESIAN F ORBS:
C
NSPDFG(2,1) = NSPDFG(2,1) + NSPDFG(2,2) + NSPDFG(4,1)
C
C NUMBER OF D ORBITALS= NO. D ORBS INPUT + NO. CARTESIAN G ORBS:
C
NSPDFG(3,1) = NSPDFG(3,1) + NSPDFG(3,2) + NSPDFG(5,1)
C
C NUMBER OF F ORBITALS:
C
NSPDFG(4,1) = NSPDFG(4,1) + NSPDFG(4,2)
C
C NUMBER OF G ORBITALS:
C
NSPDFG(5,1) = NSPDFG(5,1) + NSPDFG(5,2)
C
DO 430 IL = 1,5
IF(NSPDFG(IL,1).LE.MXAOLM) GO TO 430
MXAOLM = NSPDFG(IL,1)
430 CONTINUE
C
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
C
C COMPUTE STORAGE REQUIREMENTS AND COMPARE WITH AVAILABLE CORE SPACE:
C
C STORAGE FOR DENSITY MATRIX (DM) AND TRANSFORMATIONS (T):
C
NEED0 = 2*NDIM*NDIM
C
C COMPUTE STORAGE FOR NATURAL POPULATION ANALYSIS:
C
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
C
NEED = NATOMS*NATOMS + NATOMS + NATOMS*NATOMS + NATOMS*NATOMS +
+ NDIM*NDIM + NDIM
NEED1 = MAX(NEED1,NEED)
C
NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM
NEED1 = MAX(NEED1,NEED)
C
IF(JPRINT(9).NE.0) THEN
NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM*NDIM + NDIM*(NDIM+5)
NEED1 = MAX(NEED1,NEED)
END IF
C
NEED1 = NEED1 + NEED0
C
C COMPUTE STORAGE FOR NATURAL BOND ORBITAL ANALYSIS:
C
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)
C
IF(.NOT.ORTHO) THEN
NEED = NATOMS*NATOMS + 4*NDIM*NDIM + MXAO + 3*NDIM
NEED2 = MAX(NEED2,NEED)
END IF
C
NEED = NATOMS*NATOMS + NDIM + MXAO + NDIM*NDIM + NDIM*NDIM
+ + NDIM + NDIM
NEED2 = MAX(NEED2,NEED)
C
NEED = NATOMS*NATOMS + NDIM + NDIM + NDIM + NDIM*NDIM
NEED2 = MAX(NEED2,NEED)
C
IF(JPRINT(36).NE.0) THEN
NEED = NATOMS*NATOMS + NDIM + 3*NATOMS + NDIM*NDIM
+ + NDIM*NDIM + NDIM
NEED2 = MAX(NEED2,NEED)
END IF
C
NEED = NATOMS*NATOMS + NDIM + NDIM*NDIM + NDIM*NDIM
+ + NDIM*(NDIM+5)
NEED2 = MAX(NEED2,NEED)
C
IF(JPRINT(6).NE.0) THEN
NEED = NATOMS*NATOMS + NDIM + NDIM*NDIM + NDIM + NATOMS
+ + NDIM
NEED2 = MAX(NEED2,NEED)
END IF
C
C COMPUTE STORAGE FOR NATURAL LOCALIZED MOLECULAR ORBITAL ANALYSIS:
C
NEED3 = 0
IF(JPRINT(8).NE.0) THEN
NEED = NATOMS*NATOMS + NDIM + NDIM + NDIM*NDIM + NDIM*NDIM
NEED3 = MAX(NEED3,NEED)
C
NEED = NDIM + NDIM + NDIM + NATOMS*NATOMS + 2*NATOMS*NATOMS
+ + NDIM*NATOMS + NDIM*NATOMS*(NATOMS-1)/2 + NDIM*NDIM
NEED3 = MAX(NEED3,NEED)
C
NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM*NDIM + NDIM*(NDIM+5)
NEED3 = MAX(NEED3,NEED)
C
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
C
C PRINT SCRATCH STORAGE REQUIREMENTS:
C
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
C
990 WRITE(LFNPR,9900)
STOP
C
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
C**************************************************************************
C
C NAO/NBO/NLMO FORMATION ROUTINES: (CALLED BY SR NBO)
C
C SUBROUTINE NAODRV(DM,T,A)
C SUBROUTINE NAOSIM(DM,T,A)
C SUBROUTINE DMNAO(DM,T,A)
C SUBROUTINE DMSIM(DM,T,A)
C SUBROUTINE NBODRV(DM,T,A,MEMORY)
C
C**************************************************************************
SUBROUTINE NAODRV(DM,T,A)
C**************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C DRIVER SUBROUTINE TO CALCULATE NATURAL ATOMIC ORBITALS (NAOS)
C GIVEN 1-PARTICLE DENSITY MATRIX IN AN ARBITRARY ATOM-CENTERED
C ATOMIC ORBITAL BASIS SET.
C
C T = OVERLAP MATRIX FOR THE PRIMITIVE AO BASIS
C (ON RETURN, THIS IS THE AO TO NAO TRANSFORMATION MATRIX)
C DM = DENSITY MATRIX IN THE PRIMITIVE AO BASIS
C (OR BOND-ORDER MATRIX, IF IWDM = 1)
C
C THE SPIN NATURE OF DM IS INDICATED BY:
C ISPIN = 0: SPINLESS (CLOSED SHELL)
C ISPIN = +2: ALPHA SPIN
C ISPIN = -2: SPIN
C (ISPIN IS THE RECIPROCAL OF THE S(Z) QUANTUM NO.)
C
C A = SCRATCH STORAGE FROM THE MAIN PROGRAM. THE LOCATION OF A(1)
C IS IN THE COMMON BLOCK /SCM/ IN THE MAIN PROGRAM,
C AFTER THE STORAGE FOR THE MATRICES 'S','DM'
C ('A' IS THE VECTOR WHICH IS PARTITIONED
C ACCORDING TO THE STORAGE NEEDS OF EACH PROGRAM RUN)
C ATOM, BASIS, OPTION, NBINFO: COMMON BLOCKS WITH DATA TRANSFERED FROM
C FROM THE INPUT PROGRAMS.
C
C-----------------------------------------------------------------------------
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)
C
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(1)
CHARACTER*80 TITLE
C
DATA ONE/1.0D0/
DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/
C
C FORM LABELS FOR THE RAW AO BASIS SET:
C
CALL LBLAO
C
C COPY THE AO CENTERS AND LABELS FROM /NBAO/ TO /NBBAS/:
C
DO 5 I = 1,NBAS
LBL(I) = LCTR(I)
LORBC(I) = LANG(I)
5 CONTINUE
C
C WRITE OUT THE AO BASIS SET INFORMATION:
C
IF(JPRINT(22).GT.0) THEN
CALL WRBAS(A,A,JPRINT(22))
END IF
C
C WRITE OUT THE ARCHIVE FILE:
C
IF(JPRINT(7).NE.0) THEN
CALL WRARC(A,A,JPRINT(7))
END IF
C
C OUTPUT THE AO OVERLAP MATRIX:
C
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
C
C OUTPUT THE AO-MO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE AO FOCK MATRIX:
C
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
C
C OUTPUT THE AO BOND-ORDER MATRIX:
C
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
C
C CONVERT THE BOND-ORDER MATRIX TO THE DENSITY MATRIX:
C
IF(IWDM.NE.0) CALL SIMTRM(DM,T,A,NDIM,NBAS,IWMULP,IWCUBF)
C
C OUTPUT THE AO DENSITY MATRIX:
C
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
C
C OUTPUT THE AO DIPOLE MATRICES:
C
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
C
C ALLOCATE SCRATCH COMMON FOR NAO ROUTINES:
C
C A(I1) = V(NDIM) (ALSO USED FOR GUIDE(NATOMS,NATOMS))
C A(I2) = RENORM(NDIM)
C A(I3) = BLK(NDIM,NDIM)
C A(I4) = SBLK(MXAOLM,MXAOLM)
C A(I5) = EVAL(NDIM)
C A(I6) = C(MXAOLM,MXAOLM)
C A(I7) = EVECT(MXAOLM,MXAOLM)
C A(I8) = EVAL2(NDIM)
C LEAVE THIS LAST IN THE LIST SINCE THESE ARE INTEGERS:
C A(I9) = LISTAO(MXAOLM,9)
C
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
C IEND = I9 + 9*MXAOLM
C
C READ IN T-NAO, NAO LABELS, THE PNAO OVERLAP MATRIX, AND COMPUTE THE
C NAO DENSITY MATRIX: (NOTE THAT T CONTAINS THE PNAO OVERLAP MATRIX
C AFTER RDTNAO IS CALLED)
C
IF(IOINQR(IWTNAO).EQ.IREAD) THEN
CALL RDTNAO(DM,T,A(I1),IWTNAO)
GO TO 580
END IF
C
C TRANSFORM ALL SETS OF CARTESIAN D,F,G ORBITALS, AND RELABEL ALL ORBITALS:
C
CALL DFGORB(A(I2),DM,T,ICTRAN,IWCUBF,0,LFNPR)
C
C STORE PURE AO DENSITY MATRIX IN SCRATCH STORAGE:
C
CALL SVPPAO(DM)
C
C CONSOLIDATE DENSITY MATRIX AND OVERLAP MATRIX IN DM:
C
CALL CONSOL(DM,T,NDIM,NBAS)
C
C FIND NATURAL ATOMIC ORBITAL BASIS SET TRANSFORMATION T FROM DM:
C (UPON RETURN, DM CONTAINS THE FULL NAO DENSITY MATRIX)
C
CALL NAO(T,DM,A(I1),A(I3),A(I4),A(I5),A(I6),A(I7),A(I8),A(I9),
* NBLOCK)
C
C IF D ORBITALS WERE TRANSFORMED, TRANSFORM THE NAO TRANSFORMATION T
C SO THAT T IS THE TRANSFORM FROM THE ORIGINAL AO'S TO THE NAO'S:
C
IF(ICTRAN.NE.0) CALL DFGORB(A(I2),DM,T,IDTRAN,IWCUBF,1,LFNPR)
C
C SAVE TNAO FOR LATER USE:
C
CALL SVTNAO(T)
C
C IF D ORBITALS WERE TRANSFORMED, TRANSFORM THE PNAO TRANSFORMATION
C SO THAT IT IS THE TRANSFORM FROM THE ORIGINAL AO'S TO THE PNAO'S:
C
CALL FEPNAO(A(I3))
C
C FOR CASE THAT RPNAOS ARE WRITTEN TO DISK, SET OCCUPANCY WEIGHTS TO -1
C AS A SIGNAL THAT THEY SHOULD BE RECOMPUTED:
C
DO 260 I = 0,NBAS-1
260 A(I4+I) = -ONE
C
IF(ICTRAN.NE.0) CALL DFGORB(A(I2),DM,A(I3),IDTRAN,IWCUBF,1,LFNPR)
C
C COMPUTE NON-ORTHOGONAL NAO OVERLAP MATRIX, SPNAO:
C
CALL FESRAW(T)
CALL SIMTRS(T,A(I3),A(I4),NDIM,NBAS)
CALL SVSNAO(T)
C
C WRITE T-NAO, NAO LABELS, AND THE PNAO OVERLAP MATRIX:
C
IF(IOINQR(IWTNAO).EQ.IWRIT) CALL WRTNAO(T,IWTNAO)
C
C DM IS NOW THE DENSITY MATRIX IN THE NAO BASIS
C T IS THE NON-ORTHOGONAL PNAO OVERLAP MATRIX (!!!)
C
580 CONTINUE
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NATOMS
I4 = I3 + NATOMS*NATOMS
I5 = I4 + NATOMS*NATOMS
I6 = I5 + NDIM*NDIM
C IEND = I6 + NDIM
CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
C
C DO NOT DESTROY THE MATRIX AT A(I1). THIS HOLDS THE WIBERG BOND
C INDEX WHICH NEEDS TO BE PASSED TO THE NBO ROUTINES.
C
C SAVE THE NAO DENSITY MATRIX:
C
CALL SVDNAO(DM)
C
C FORM THE NAO LABELS:
C
CALL LBLNAO
C
C REORGANIZE THE SCRATCH VECTOR:
C
I1 = 1
I2 = I1 + NATOMS*NATOMS
C IEND = I2 + NDIM*NDIM
C
C OUTPUT THE AO-PNAO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE PNAO OVERLAP MATRIX:
C
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
C
C FETCH THE AO-NAO TRANSFORMATION FROM THE NBO DAF:
C
CALL FETNAO(T)
C
C PRINT THE AO-NAO TRANSFORMATION MATRIX:
C
IF(IOINQR(IWTNAO).EQ.IPRNT) THEN
TITLE = 'NAOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IWTNAO)
END IF
C
C OUTPUT THE NAO DIPOLE MATRICES:
C
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
C
C IF THIS IS AN OPEN SHELL WAVEFUNCTION, DON'T DO ANYTHING MORE:
C
IF(OPEN) RETURN
C
C OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
C
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
C IEND = I4 + NDIM*(NDIM+5)
CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
END IF
C
C REORGANIZE THE SCRATCH VECTOR:
C
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
C IEND = I3 + NDIM
C
C OUTPUT THE NAO FOCK MATRIX:
C
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
C
C OUTPUT THE NAO DENSITY MATRIX:
C
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
C*****************************************************************************
SUBROUTINE NAOSIM(DM,T,A)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1)
CHARACTER*80 TITLE
C
DATA ZERO,ONE/0.0D0,1.0D0/
DATA IPRNT,IWRIT/4HPRNT,4HWRIT/
C
C THIS ROUTINE SIMULATES THE ACTION OF THE NAO SUBPROGRAM:
C
C FORM LABELS FOR THE RAW AO BASIS SET:
C
CALL LBLAO
C
C COPY THE AO CENTERS AND LABELS FROM /NBAO/ TO /NBBAS/:
C
DO 5 I = 1,NBAS
LBL(I) = LCTR(I)
LORBC(I) = LANG(I)
5 CONTINUE
C
C WRITE OUT THE AO BASIS SET INFORMATION:
C
IF(JPRINT(22).GT.0) THEN
CALL WRBAS(A,A,JPRINT(22))
END IF
C
C WRITE OUT THE ARCHIVE FILE:
C
IF(JPRINT(7).NE.0) THEN
CALL WRARC(A,A,JPRINT(7))
END IF
C
C OUTPUT THE AO-MO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE AO FOCK MATRIX:
C
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
C
C OUTPUT THE AO DENSITY MATRIX:
C
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
C
C OUTPUT THE AO DIPOLE MATRICES:
C
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
C
C INITIALIZE THE AO TO NAO TRANSFORMATION MATRIX (UNIT MATRIX):
C
DO 20 J = 1,NBAS
DO 10 I = 1,NBAS
T(I,J) = ZERO
10 CONTINUE
T(J,J) = ONE
20 CONTINUE
C
C SAVE TNAO FOR LATER USE:
C
CALL SVTNAO(T)
C
C FILL ATOMIC ORBITAL INFORMATION LISTS:
C
DO 30 I = 1,NBAS
NAOCTR(I) = LCTR(I)
NAOL(I) = LANG(I)
LSTOCC(I) = 1
30 CONTINUE
C
C PERFORM THE NATURAL POPULATION ANALYSIS: (NOTE THAT ROUTINE NAOANL
C EXPECTS TO FIND THE OVERLAP MATRIX IN T, WHICH IS THE UNIT MATRIX
C FOR ORTHOGONAL BASIS SETS. UPON RETURN FROM NAOANL, T IS THE AO TO
C NAO TRANSFORMATION, WHICH IS STILL A UNIT MATRIX):
C
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NATOMS
I4 = I3 + NATOMS*NATOMS
I5 = I4 + NATOMS*NATOMS
I6 = I5 + NDIM*NDIM
C IEND = I6 + NDIM
CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
C
C DO NOT DESTROY THE MATRIX AT A(I1). THIS HOLDS THE WIBERG BOND
C INDEX WHICH NEEDS TO BE PASSED TO THE NBO ROUTINES.
C
C SAVE THE NAO DENSITY MATRIX:
C
CALL SVDNAO(DM)
C
C FORM THE NAO LABELS:
C
CALL LBLNAO
C
C IF THIS IS AN OPEN SHELL WAVEFUNCTION, DON'T DO ANYTHING MORE:
C
IF(OPEN) RETURN
C
C OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
C
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
C IEND = I4 + NDIM*(NDIM+5)
CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
END IF
C
C REORGANIZE THE SCRATCH VECTOR:
C
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
C IEND = I3 + NDIM
C
C OUTPUT THE NAO FOCK MATRIX:
C
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
C
C OUTPUT THE NAO DENSITY MATRIX:
C
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
C**************************************************************************
SUBROUTINE DMNAO(DM,T,A)
C**************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1)
CHARACTER*80 TITLE
C
DATA IPRNT,IWRIT/4HPRNT,4HWRIT/
C
C PLACE ALPHA OR BETA OCCUPATION MATRIX IN DM AND TRANSFORM FROM THE AO
C TO NAO BASIS:
C
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
C
C OUTPUT THE AO-MO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE AO FOCK MATRIX:
C
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
C
C FETCH ALPHA OR BETA DM (ACCORDING TO WHETHER ALPHA OR BETA IS TRUE):
C
CALL FEDRAW(DM,A)
C
C OUTPUT THE AO BOND-ORDER MATRIX:
C
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
C
C CONVERT THE BOND-ORDER MATRIX TO THE DENSITY MATRIX:
C
IF(IWDM.NE.0) THEN
I1 = 1
I2 = I1 + NDIM*NDIM
C IEND = I2 + NDIM*NDIM
CALL FESRAW(A(I1))
CALL SIMTRM(DM,A(I1),A(I2),NDIM,NBAS,IWMULP,IWCUBF)
END IF
C
C OUTPUT THE AO DENSITY MATRIX:
C
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
C
C TRANSFORM DM TO THE NAO BASIS:
C
CALL SIMTRS(DM,T,A,NDIM,NBAS)
C
C SAVE THE NAO DENSITY MATRIX IN SCRATCH STORAGE:
C
CALL SVDNAO(DM)
C
C PRINT THE NATURAL POPULATION ANALYSIS FOR THIS SPIN CASE:
C
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NATOMS
I4 = I3 + NATOMS*NATOMS
I5 = I4 + NATOMS*NATOMS
I6 = I5 + NDIM*NDIM
C IEND = I6 + NDIM
CALL FESNAO(T)
CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
C
C NOTE: DO NOT DESTROY THE WIBERG BOND INDEX WHICH IS STORED IN THE FIRST
C NATOMS*NATOMS ELEMENTS OF THE SCRATCH VECTOR A. THIS IS MATRIX IS
C REQUIRED FOR THE NBO ANALYSIS:
C
C NOTE THAT T IS NOW T-AO-NAO:
C
C FORM THE NAO LABELS:
C
CALL LBLNAO
C
C OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
C
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
C IEND = I4 + NDIM*(NDIM+5)
CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
END IF
C
C REORGANIZE THE SCRATCH VECTOR:
C
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
C IEND = I3 + NDIM
C
C OUTPUT THE NAO FOCK MATRIX:
C
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
C
C OUTPUT THE NAO DENSITY MATRIX:
C
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
C
2100 FORMAT(//1X,
* '***************************************************',/1X,
* '******* Alpha spin orbitals *******',/1X,
* '***************************************************')
2200 FORMAT(//1X,
* '***************************************************',/1X,
* '******* Beta spin orbitals *******',/1X,
* '***************************************************')
END
C**************************************************************************
SUBROUTINE DMSIM(DM,T,A)
C**************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1)
CHARACTER*80 TITLE
C
DATA IPRNT,IWRIT/4HPRNT,4HWRIT/
C
C SIMULATE THE ALPHA/BETA NAO SUBPROGRAM:
C
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
C
C OUTPUT THE AO-MO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE AO FOCK MATRIX:
C
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
C
C FETCH ALPHA OR BETA DM (ACCORDING TO WHETHER ALPHA OR BETA IS TRUE):
C
CALL FEDRAW(DM,A)
C
C OUTPUT THE AO DENSITY MATRIX:
C
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
C
C SAVE THE NAO DENSITY MATRIX IN SCRATCH STORAGE:
C
CALL SVDNAO(DM)
C
C PRINT THE NATURAL POPULATION ANALYSIS FOR THIS SPIN CASE:
C
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NATOMS
I4 = I3 + NATOMS*NATOMS
I5 = I4 + NATOMS*NATOMS
I6 = I5 + NDIM*NDIM
C IEND = I6 + NDIM
CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
C
C NOTE: DO NOT DESTROY THE WIBERG BOND INDEX WHICH IS STORED IN THE FIRST
C NATOMS*NATOMS ELEMENTS OF THE SCRATCH VECTOR A. THIS IS MATRIX IS
C REQUIRED FOR THE NBO ANALYSIS:
C
C FORM THE NAO LABELS:
C
CALL LBLNAO
C
C OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
C
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
C IEND = I4 + NDIM*(NDIM+5)
CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
END IF
C
C REORGANIZE THE SCRATCH VECTOR:
C
I1 = 1
I2 = I1 + NATOMS*NATOMS
I3 = I2 + NDIM*NDIM
C IEND = I3 + NDIM
C
C OUTPUT THE NAO FOCK MATRIX:
C
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
C
C PRINT THE NAO DENSITY MATRIX:
C
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
C
2100 FORMAT(//1X,
* '***************************************************',/1X,
* '******* Alpha spin orbitals *******',/1X,
* '***************************************************')
2200 FORMAT(//1X,
* '***************************************************',/1X,
* '******* Beta spin orbitals *******',/1X,
* '***************************************************')
END
C**************************************************************************
SUBROUTINE NBODRV(DM,T,A,MEMORY)
C**************************************************************************
C
C DRIVER SUBROUTINE TO CALCULATE NATURAL HYBRID ORBITALS (NHOS) AND
C NATURAL BOND ORBITALS (NBOS) FROM THE DENSITY MATRIX IN THE NAO BASIS
C
C T = SCRATCH STORAGE
C DM = NAO DENSITY MATRIX
C THE SPIN NATURE OF DM IS INDICATED BY:
C ISPIN = 0: SPINLESS (CLOSED SHELL)
C ISPIN = +2: ALPHA SPIN
C ISPIN = -2: SPIN
C (ISPIN IS THE RECIPROCAL OF THE S(Z) QUANTUM NO.)
C
C A = SCRATCH STORAGE FROM THE MAIN PROGRAM. THE LOCATION OF A(1)
C IS IN THE COMMON BLOCK /SCM/ IN THE MAIN PROGRAM,
C AFTER THE STORAGE FOR THE MATRICES 'S','DM'
C ('A' IS THE VECTOR WHICH IS PARTITIONED
C ACCORDING TO THE STORAGE NEEDS OF EACH PROGRAM RUN)
C ATOM, BASIS, OPTION, NBINFO: COMMON BLOCKS WITH DATA TRANSFERED FROM
C FROM THE INPUT PROGRAMS.
C
C-----------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
CHARACTER*80 TITLE
C
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
C
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(1)
C
DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/
DATA ZERO/0.0D0/
C
C SKIP NBO TRANSFORMATION IF REQUESTED:
C
IF(JPRINT(1).GT.0) THEN
WRITE(LFNPR,2000)
RETURN
END IF
C
C ORGANIZE SCRATCH STORAGE VECTOR A. WARNING: THIS IS REDEFINED
C SEVERAL TIMES AFTER THE NBOS ARE FORMED
C
C A(I0) = GUIDE(NATOMS,NATOMS)
C A(I1) = BNDOCC(NDIM)
C A(I2) = POL(NDIM,3)
C A(I3) = Q(MXAO,NDIM)
C A(I4) = V(NDIM)
C A(I5) = BLK(MXBO,MXBO)
C A(I6) = C(MXBO,MXBO)
C A(I7) = EVAL(MXBO)
C A(I8) = BORB(MXBO)
C A(I9) = P(MXAO,MXAO)
C A(I10) = PK(MXAO,MXAO)
C A(I11) = HYB(MXAO)
C A(I12) = VA(MXAO)
C A(I13) = VB(MXAO)
C
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
C IEND = I14 + NATOMS*NATOMS
C
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)
C
C READ IN T-NAB, LABEL, IBXM, TRANSFORM DM, AND FIND BNDOCC IF IWTNAB=IREAD:
C
IF(IOINQR(IWTNAB).EQ.IREAD) THEN
CALL RDTNAB(T,DM,A(I1),A(I2),IWTNAB)
ELSE
C
C SEARCH INPUT FILE FOR $CORE INPUT:
C
IF(.NOT.BETA) THEN
CALL CORINP(JPRINT(2),JCORE)
CALL RDCORE(JCORE)
END IF
C
C SEARCH INPUT FILE FOR $CHOOSE INPUT:
C
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
C
C CALCULATE NATURAL HYBRID ORBITALS AND BOND ORBITALS:
C
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))
C
C IF NBO SEARCH WAS ABANDONED, DON'T TRY TO DO ANYTHING FURTHER:
C
IF(JPRINT(1).LT.0) RETURN
C
C SORT THE NBOS BY ATOM:
C
CALL SRTNBO(T,A(I1))
C
C FORM THE NBO DENSITY MATRIX:
C
CALL SIMTRS(DM,T,A(I2),NDIM,NBAS)
C
C CHECK NHO OVERLAPS TO SEE IF BOND ORBITALS SHOULD BE RELABELLED:
C
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
C IEND = I6 + NDIM
CALL XCITED(DM,T,A(I2),A(I3),A(I4),A(I5),A(I6),A(I6))
END IF
END IF
C
C T NOW CONTAINS THE NAO-NBO TRANSFORMATION MATRIX
C DM NOW CONTAINS THE NBO DENSITY MATRIX
C A(I0) CONTAINS THE WIBERG BOND INDEX MATRIX ! DON'T DESTROY THIS
C A(I1) CONTAINS THE NBO OCCUPANCIES ! DON'T DESTROY THIS
C A(I2) IS SCRATCH SPACE
C
C SAVE THE NAO-NBO TRANSFORMATION ON THE NBO DAF:
C
CALL SVTNAB(T)
C
C FORM THE NBO LABELS:
C
CALL LBLNBO
C
C WRITE OUT THE ANALYSIS OF BOND ORBITALS:
C
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + NDIM
I3 = I2 + NDIM
I4 = I3 + NDIM
C IEND = I4 + NDIM*NDIM
CALL ANLYZE(T,A(I1),A(I2),A(I3),A(I4))
C
C WRITE OUT HYBRID DIRECTIONALITY AND BOND BENDING INFO:
C
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
C IEND = I5 + NDIM
CALL HYBDIR(A(I1),A(I2),A(I3),A(I4),A(I5))
END IF
C
C FIND MOLECULAR UNITS:
C
CALL FNDMOL(A(I2))
C
C CLASSIFY ALL THE NBOS ACCORDING TO DONOR/ACCEPTOR TYPE:
C
CALL NBOCLA(A(I1),ACCTHR)
C
C OUTPUT TRANSFORMATION MATRICES FOR THE PNHO AND NHO BASIS SETS,
C AND THE NHO DENSITY MATRIX, NHO FOCK MATRIX, AND NHO DIPOLE MATRICES:
C
C THE SECTION OF THE CODE MAKES USE OF T AND DM. THESE MATRICES
C WILL BE RESTORED LATER: [NOTE: DO NOT DESTROY INFO ALREADY STORED
C IN A(I0) AND A(I1)]
C
C REORGANIZE THE SCRATCH VECTOR:
C
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + NDIM
I3 = I2 + NDIM*NDIM
I4 = I3 + NDIM*NDIM
C IEND = I4 + NDIM*(NDIM+5)
C
C OUTPUT THE AO-PNHO TRANSFORMATION AND THE PNHO OVERLAP MATRIX:
C
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
C
C FORM THE AO-NHO TRANSFORMATION MATRIX:
C
CALL FETNAO(T)
CALL FETNHO(A(I2))
CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
C
C OUTPUT THE AO-NHO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE NAO-NHO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE NHO-MO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE NHO DENSITY MATRIX:
C
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
C
C OUTPUT THE NHO FOCK MATRIX:
C
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
C
C OUTPUT THE NHO DIPOLE MATRICES:
C
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
C
C OUTPUT TRANSFORMATION MATRICES FOR THE PNBO AND NBO BASIS SETS,
C AND THE NBO DENSITY MATRIX, NBO FOCK MATRIX, AND NBO DIPOLE MATRICES:
C
C [NOTE: DO NOT DESTROY INFO ALREADY STORED IN A(I0) AND A(I1)]
C
C REORGANIZE THE SCRATCH VECTOR:
C
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + NDIM
I3 = I2 + NDIM*NDIM
I4 = I3 + NDIM*NDIM
C IEND = I4 + NDIM*(NDIM+5)
C
C OUTPUT THE AO-PNBO TRANSFORMATION AND THE PNBO OVERLAP MATRIX:
C
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
C
C FORM THE AO-NBO TRANSFORMATION MATRIX:
C
CALL FETNAO(T)
CALL FETNAB(A(I2))
CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
C
C SAVE THE AO-NBO TRANSFORMATION, NBO OCCS, AND NBO LABELS ON NBO DAF:
C
CALL SVNBO(T,A(I1),A(I2))
C
C WRITE THE AO-NBO TRANSFORMATION WITH NBO LABELS AND OCCUPANCIES:
C
IF(IOINQR(IWTNBO).EQ.IWRIT) CALL WRTNBO(T,A(I1),IWTNBO)
C
C PRINT THE AO-NBO TRANSFORMATION MATRIX:
C
IF(IOINQR(IWTNBO).EQ.IPRNT) THEN
TITLE = 'NBOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IWTNBO)
END IF
C
C WRITE THE NAO-NBO TRANSFORMATION MATRIX:
C
IF(IOINQR(IWTNAB).EQ.IWRIT) THEN
CALL FETNAB(A(I2))
CALL WRTNAB(A(I2),IWTNAB)
END IF
C
C PRINT THE NAO-NBO TRANSFORMATION TO THE OUTPUT FILE:
C
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
C
C OUTPUT THE NHO-NBO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE NBO-MO TRANSFORMATION MATRIX:
C
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
C
C FORM THE NBO DENSITY MATRIX:
C
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)
C
C OUTPUT THE NBO DENSITY MATRIX:
C
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
C
C OUTPUT THE NBO FOCK MATRIX:
C
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
C
C OUTPUT THE NBO DIPOLE MATRICES:
C
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
C
C PERFORM PERTURBATIVE ANALYSIS OF THE NBO FOCK MATRIX:
C
IF(JPRINT(3).EQ.1.AND.IWFOCK.NE.0) CALL FNBOAN(A(I1),A(I2),A(I3))
C
C PRINT THE NBO SUMMARY:
C
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
C IEND = I5 + NDIM
CALL NBOSUM(A(I2),A(I1),A(I3),A(I4),A(I5))
END IF
C
C CONTINUE WITH THE CONSTRUCTION OF THE NLMOS:
C
IF(JPRINT(8).NE.0) THEN
C
C STORE IN A(I0) THE VECTOR RESON(NDIM), THE SQUARES OF THE DIAGONAL
C ELEMENTS OF THE NBO TO NLMO TRANSFORMATION MATRIX. IALARM SOUNDS
C THE ALARM THAT THE NLMO STEP IS TO BE SKIPPED:
C
C DM : NBO DENSITY ! TRANSFORMED TO NLMO BASIS ON RETURN
C A(I0): RESON(NDIM) ! PERCENTAGES OF PARENT NBO
C A(I1): LMOOCC(NDIM) ! NLMO OCCUPANCIES
C A(I2): TNLMO(NDIM,NDIM) ! NBO-NLMO TRANSFORM
C A(I3): TSYM ! SCRATCH
C
C (DO NOT DESTROY THE WIBERG BOND INDEX!)
C
I0 = 1 + NATOMS*NATOMS
I1 = I0 + NDIM
I2 = I1 + NDIM
I3 = I2 + NDIM*NDIM
C IEND = I3 + NDIM*NDIM
CALL NLMO(NBAS,DM,A(I1),A(I2),A(I3),A(I0),NOCC,IALARM)
IF(IALARM.NE.0) RETURN
C
C SAVE THE NBO TO NLMO TRANSFORMATION MATRIX ON THE NBO DAF:
C
CALL SVTLMO(A(I2))
C
C FORM THE NAO TO NLMO TRANSFORMATION IN T:
C
CALL FETNAB(T)
CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
C
C SET UP STORAGE FOR LMOANL:
C
C A(I0): RESON(NDIM)
C A(I1): LMOOCC(NDIM)
C A(I2): TS(NDIM)
C A(I3): BORDER(NATOMS,NATOMS)
C A(I4): OWBORD(NATOMS,NATOMS)
C A(I5): ATLMO(NOCC,NATOMS)
C A(I6): SIAB(NOCC,NAB)
C
C (DO NOT DESTROY THE WIBERG BOND INDEX!)
C
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
C 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)
C
C OUTPUT TRANSFORMATION MATRICES FOR THE PNLMO AND NLMO BASIS SETS,
C AND THE NLMO DENSITY MATRIX, NLMO FOCK MATRIX, AND NLMO DIPOLE MATRICES:
C
C REORGANIZE THE SCRATCH VECTOR:
C
C (DO NOT DESTROY THE WIBERG BOND INDEX!)
C
I0 = 1 + NATOMS*NATOMS
I1 = I0 + NDIM*NDIM
I2 = I1 + NDIM*NDIM
C IEND = I2 + NDIM*(NDIM+5)
C
C OUTPUT THE AO-PNLMO TRANSFORMATION AND THE PNLMO OVERLAP MATRIX:
C
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
C
C FORM THE AO-NLMO TRANSFORMATION MATRIX:
C
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)
C
C SAVE THE AO-NLMO TRANSFORMATION ON NBO DAF:
C
CALL SVNLMO(T)
C
C WRITE OUT THE AO-NLMO TRANSFORMATION MATRIX:
C
IO = IOINQR(JPRINT(23))
IF(IO.EQ.IWRIT) CALL WRNLMO(T,DM,JPRINT(23))
C
C PRINT THE AO-NLMO TRANSFORMATION MATRIX:
C
IF(IO.EQ.IPRNT) THEN
TITLE = 'NLMOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(23))
END IF
C
C OUTPUT THE NAO-NLMO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE NHO-NLMO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE NBO-NLMO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE NLMO-MO TRANSFORMATION MATRIX:
C
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
C
C OUTPUT THE NLMO DENSITY MATRIX:
C
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
C
C OUTPUT THE NLMO FOCK MATRIX:
C
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
C
C OUTPUT THE NLMO DIPOLE MATRICES:
C
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
C
C PERFORM THE NBO/NLMO DIPOLE MOMENT ANALYSIS:
C
C DM : NLMO DENSITY MATRIX
C T : AO-NLMO TRANSFORMATION MATRIX
C A(I1): C(NDIM,NDIM)
C A(I2): TNBO(NDIM,NDIM)
C A(I3): DX(NDIM,NDIM)
C A(I4): DY(NDIM,NDIM)
C A(I5): DZ(NDIM,NDIM)
C A(I6): SCR(NDIM,NDIM)
C A(I7): INDEX(NDIM)
C
C (DO NOT DESTROY THE WIBERG BOND INDEX!)
C
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
C 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
C
C PERFORM NATURAL RESONANCE THEORY ANALYSIS:
C
IF(JPRINT(32).NE.0) THEN
C
C CAREFULLY DETERMINE THE MAXIMUM NUMBER OF RESONANCE STRUCTURES
C (MAXRES) THAT THE SCRATCH VECTOR CAN ACCOMODATE. ASSUME THAT
C THERE WILL BE ROUGHLY 6(=NEL) ELEMENTS REQUIRED PER ATOM TO STORE
C THE TOPO MATRICES FOR EACH RESONANCE STRUCTURE: (1 FOR NUMBER OF
C BONDS, 1 FOR NUMBER OF LONE PAIRS, AND 4 BONDED ATOMS -- SEE
C SR TOPSTR)
C
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)
C
C CAREFULLY DETERMINE THE MAXIMUM NUMBER OF RESONANCE STRUCTURES (MAXRES)
C WHICH THE SCRATCH VECTOR CAN ACCOMODATE. ASSUME NDIM IS LARGER THAN
C MAXRES (THIS IS NOT USUALLY THE CASE):
C
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)
C
C CHECK THIS ASSUMPTION:
C
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
C
C PARTITION THE SCRATCH VECTOR:
C
I0 = 1
I1 = I0 + NATOMS*NATOMS
I2 = I1 + MAXRES*MAXREF
I3 = I2 + MAXRES*MAXREF
I4 = I3 + MAXREF
MEM = MEMORY - I4 + 1
C CALL NRTDRV(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4),MAXRES,MAXREF,
C + NLOW,LEN,NELEC,MEM)
END IF
RETURN
C
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
C*****************************************************************************
C
C ROUTINES CALLED BY THE NAO DRIVERS:
C
C SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF)
C SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF)
C SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR)
C SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK)
C SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO)
C SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG)
C
C*****************************************************************************
SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C SIMILARITY TRANSFORM A ==> S(TRANSPOSE)*A*S, USING SCRATCH VECTOR V.
C WRITE THE DIAGONAL ELEMENTS OF A*S BY CALLING SUBROUTINE MULANA IF
C IWMULP.NE.0
C (THESE ARE THE MULLIKEN POPULATIONS IF S= OVERLAP MATRIX
C AND A= BOND-ORDER MATRIX)
C
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
C*****************************************************************************
SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C
C PERFORM MAYER-MULLIKEN BOND ORDER ANALYSIS
C
C PRINT OUT DIAGONAL ELEMENTS OF BS=B*S, WHERE
C B= BOND-ORDER MATRIX, S= OVERLAP MATRIX, BOTH IN ORIGINAL AO BASIS
C THIS CONSTITUTES A MULLIKEN POPULATION ANALYSIS.
C
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
C 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
C
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
C*****************************************************************************
SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR)
C*****************************************************************************
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/
C**********************************************************************
C
C SUBROUTINE TO TRANSFORM THE OVERLAP AND DENSITY MATRICES IF D, F, G
C ORBITALS ARE PRESENT, OR TRANSFORM A TRANSFORMATION MATRIX SO THAT IT
C STARTS FROM THE RAW AO INSTEAD OF THE PURE AO BASIS
C THIS TRANSFORMATION WILL NOT WORK IF DM IS THE BOND-ORDER MATRIX.
C
C LIST(6,MAXBAS): THE LIST OF FUNCTIONS TO BE TRANSFORMED
C LIST(1,I),LIST(2,I),LIST(3,I) ARE CORRESPONDING SETS OF
C D,F, OR G FUNCTIONS. IT IS ASSUMED THAT, FOR EXAMPLE,
C THE THIRD DX2 FUNCTION FOUND IN THE ANGULAR MOMENTA LIST "LORB"
C CORRESPONDS TO THE THIRD DY2 AND THE THIRD DZ2 FUNCTIONS IN
C THE LIST OF BASIS FUNCTIONS!
C ITRAN=IDTRAN+IFTRAN+IGTRAN
C IDTRAN: THE NUMBER OF SETS OF CARTESIAN D ORBITALS FOUND
C IFTRAN: THE NUMBER OF SETS OF CARTESIAN F ORBITALS FOUND
C IGTRAN: THE NUMBER OF SETS OF CARTESIAN G ORBITALS FOUND
C A : THE TRANSFORMATION MATRIX
C
C ITOPT : IF ZERO, TRANSFORM DM AND S (IN T) FROM RAW AO TO PURE
C AO BASIS
C IF ONE, PRE-MULTIPLY T BY THE AO TO PURE AO TRANSF.
C --- THIS CONVERTS A TRANSF. THAT STARTS FROM PURE AOS
C TO A TRANSF. THAT STARTS FROM THE RAW AOS
C
C RENORM: RENORMALIZATION VECTOR FOR CARTESIAN TO PURE TRANSFORM.
C (PRODUCED IF ITOPT=0, USED AS INPUT IF ITOPT=1)
C
C**********************************************************************
DO 10 I=1,NBAS
10 LORB(I)=0
IDTRAN=0
N1=0
N2=0
N3=0
N4=0
N5=0
N6=0
C...CONSTRUCT LIST:
DO 70 IBAS=1,NBAS
C DX2:
IF(LORBC(IBAS).NE.201) GO TO 20
N1=N1+1
LIST(1,N1)=IBAS
GO TO 70
C DY2:
20 IF(LORBC(IBAS).NE.204) GO TO 30
N2=N2+1
LIST(2,N2)=IBAS
GO TO 70
C DZ2:
30 IF(LORBC(IBAS).NE.206) GO TO 40
N3=N3+1
LIST(3,N3)=IBAS
GO TO 70
C LABEL DXY:
40 IF(LORBC(IBAS).NE.202) GO TO 50
N4=N4+1
LORB(IBAS)=251
GO TO 70
C LABEL DXZ:
50 IF(LORBC(IBAS).NE.203) GO TO 60
N5 =N5+1
LORB(IBAS)=252
GO TO 70
C 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
C SET UP TRANSFORM. COEFF:
C S=R2=X2+Y2+Z2:
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
C D(X2-Y2):
A(1,2)= ONE
A(2,2)=-ONE
A(3,2)= ZERO
C 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
C...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)
C...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)
C...SET THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED:
LORB(M(1))=51
LORB(M(2))=254
LORB(M(3))=255
150 CONTINUE
C**********************************************************************
160 CONTINUE
C 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
C...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
C SET UP TRANSFORM. COEFF, CUBIC F ORBITALS
C PX=X*R2, PY=Y*R2, PZ=Z*Z2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
C FX(Z2-Y2), FY(Z2-X2), FZ(X2-Y2)
A(1,2)= ONE
A(2,2)=-ONE
A(3,2)= ZERO
C 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
C SET UP TRANSFORM. COEFF, FOR FIRST F BLOCK
C PX=X*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
C FX(X2-3Y2)
A(1,2)= ONE
A(2,2)=-THREE
A(3,2)= ZERO
C 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
C SET UP TRANSFORM. COEFF, FOR SECOND F BLOCK
C PY=Y*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
C FY(3X2-Y2)
A(1,2)= THREE
A(2,2)=-ONE
A(3,2)= ZERO
C FY(5Z2-R2)
A(1,3)=-ONE
A(2,3)=-ONE
A(3,3)= FOUR
GO TO 310
290 CONTINUE
C SET UP TRANSFORM. COEFF, FOR THIRD F BLOCK
C PZ Z*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
C FZ(X2-Y2)
A(1,2)= ONE
A(2,2)=-ONE
A(3,2)= ZERO
C 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
C...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)
C...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)
C...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
C 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
C 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)
C...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
C SET UP TRANSFORM. COEFF, FOR FIRST G BLOCK
C DXY=XY*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
C G(2S)
A(1,2)= ONE
A(2,2)=-ONE
A(3,2)= SIX
C 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
C SET UP TRANSFORM. COEFF, FOR SECOND G BLOCK
C DXZ=XZ*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
C G(1C)
A(1,2)=-THREE
A(2,2)=-THREE
A(3,2)= FOUR
C G(3C)
A(1,3)= ONE
A(2,3)=-THREE
A(3,3)= ZERO
GO TO 610
590 CONTINUE
C SET UP TRANSFORM. COEFF, FOR THIRD G BLOCK
C DYZ=YZ*R2
A(1,1)= ONE
A(2,1)= ONE
A(3,1)= ONE
C G(1S)
A(1,2)=-THREE
A(2,2)=-THREE
A(3,2)= FOUR
C 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
C...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)
C...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)
C...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
C G ORBITALS --- FOURTH (6X6) BLOCK
N1=0
N2=0
N3=0
N4=0
N5=0
N6=0
C...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
C SET UP TRANSFORM. COEFF, FOR FOURTH G BLOCK
C 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
C 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
C 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
C 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
C 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
C 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)
C...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)
C...TRANSFORM S AND DM:
C...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)
C...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
C 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
C 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
C 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
C*****************************************************************************
SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C********************************************************************
C
C MAIN SUBROUTINE 'NAO' FOR NATURAL ATOMIC ORBITAL BASIS SET.
C
C
C INPUT REQUIRED:
C S = OVERLAP MATRIX ELEMENTS IN LOWER TRIANGLE (BELOW DIAGONAL)
C = DENSITY MATRIX ELEMENTS IN UPPER TRIANGLE (INCLUDING DIAG.)
C (INPUT AO'S MUST(!) BE NORMALIZED. ON RETURN, S IS THE
C FULL DENSITY MATRIX. OVERLAP MATRIX ELEMENTS ARE LOST.)
C LBL = LIST OF ATOMIC CENTERS; LBL(I) = N IF ORBITAL I IS ON CENTER N
C LORB = LIST OF ANGULAR MOMENTUM TYPE FOR EACH ORBITAL;
C LORB(I) = N IF ORBITAL I IS OF 'TYPE' N.
C N = ( 51,151,152,153) = (S,PX,PY,PZ)
C = (251,252,253,254,255) = (DXY,DXZ,DYZ,D(X2-Y2),D(3Z2-R2))
C = (351-357 FOR THE 7 TYPES OF F ORBITALS)
C = (451-459 FOR THE 9 TYPES OF G ORBITALS)
C
C OUTPUT:
C T = TRANSFORMATION MATRIX FROM INPUT AO'S TO NAO'S (ROWS ARE
C LABELLED BY PRIMITIVE AO'S, COLUMNS BY NAO'S)
C NAOCTR = LIST OF ATOMIC CENTERS FOR NAO'S; NAOCTR(I) = N IF NAO # I
C IS ON CENTER #N.
C NAOL = LIST OF ANGULAR MOMENTUM TYPE FOR EACH NAO, SAME FORMAT AS "LORB"
C
C BEFORE RETURN:
C LSTOCC = LIST OF NATURAL MINIMAL BASIS ('OCCUPIED') ORBITALS;
C LSTOCC(I)=N (I=1,...,NOCC) MEANS THAT NAO #N BELONGS
C TO THE NMB SET.
C LSTEMT = LIST OF NATURAL RYDBERG BASIS ('EMPTY') ORBITALS;
C LSTEMT(I)=N (I=1,...,NEMT) MEANS THAT NAO #N BELONGS
C TO THE NRB SET.
C
C AFTER RETURN:
C LSTOCC(I) = 1 ONLY IF NAO #I BELONGS TO THE NMB SET.
C
C********************************************************************
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
C
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/
C
C SKIP T-NAO FORMATION IF IOINQR(IWPNAO).EQ.IREAD:
C
IF(IOINQR(IWPNAO).EQ.IREAD) GO TO 200
C
C ZERO TRANSFORMATION MATRIX T:
C
DO 10 J = 1,NBAS
LSTOCC(J) = 0
LSTEMT(J) = 0
DO 10 I = 1,NBAS
10 T(I,J) = ZERO
C
C NF COUNTS THE ACCUMULATED ORBITALS:
C
NF = 0
C
C NOCC COUNTS THE ACCUMULATED 'OCCUPIED' ORBITALS:
C NEMT COUNTS THE ACCUMULATED 'EMPTY' ORBITALS:
C
NOCC = 0
NEMT = 0
C
C BEGIN MAIN NAO LOOP OVER ATOMIC CENTERS:
C
DO 140 ICNTR = 1,NATOMS
C
C LOOP OVER ANGULAR MOMENTUM BLOCKS (S,P,D,F,G). NL COUNTS THE NUMBER
C OF ORBITALS IN EACH "M" COMPONENT OF THE "L" BLOCK:
C
DO 130 IL = 1,5
IF(NF.GT.NBAS) GO TO 130
L = IL - 1
M = 2*L + 1
C
C SCAN ORBITAL LABELS TO GATHER 'LISTAO' OF ORBITALS BELONGING TO
C PROPER ATOM AND ANGULAR MOMENTUM SYMMETRY:
C
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
C
C LOAD THIS LIST OF ORBITALS INTO BLK AND SBLK (DENSITY MATRIX AND
C OVERLAP ELEMENTS, RESP.), AND AVERAGE THE DENSITY MATRIX ELEMENTS
C OVER THE M COMPONENTS OF L FOR THE ATOM:
C
CALL LOADAV(LISTAO,NL,M,S,NDIM,BLK,SBLK,MXAOLM)
C
C SOLVE THE GENERALIZED EIGENVALUE PROBLEM:
C
CALL ATDIAG(NL,BLK,SBLK,EVAL,C)
C
C ORDER THE EIGENVECTORS BY OCCUPANCY EIGENVALUE:
C
CALL RANK(EVAL,NL,NL,LARC)
C
C LOOP OVER THE 2*L+1 COMPONENTS TO STORE T-NAO DATA:
C
DO 120 IM = 1,M
C
C PARTITION ORBITALS INTO 'OCCUPIED' AND 'EMPTY' SETS:
C
CALL SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,ICNTR,L,NL,NF,NDIM)
C
C STORE THE ORDERED EIGENVECTORS IN T:
C
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
C
C MAKE UP NAO ORBITAL LABELS:
C
NAOCTR(NF) = ICNTR
NAOL(NF) = L*100 + IM + 50
120 CONTINUE
130 CONTINUE
140 CONTINUE
200 CONTINUE
C
C READ IN PRE-ORTHOGONAL T-NAO DATA:
C
IF(IOINQR(IWPNAO).NE.IREAD) GO TO 300
CALL RDPPNA(T,OCC)
C
C RECOMPUTE AND SYMMETRY-AVERAGE WEIGHTS, REORGANIZE LSTOCC IF THE INPUT
C PNAOS ARE RPNAOS:
C
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
C
C WRITE PREORTHOGONAL T-NAO DATA TO LFNPPA:
C
IF(IOINQR(IWPNAO).EQ.IWRIT) CALL WRPPNA(T,OCC,IWPNAO)
C
C SAVE T-PNAO FOR LATER USE IN COMPUTING THE NON-ORTHOGONAL OVERLAPS
C BETWEEN NAOS OR NBOS:
C
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
C
C FINAL ORTHOGONALIZATION:
C
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)
C
C PUT P-PAO IN UPPER TRIANGLE OF S (AND DIAGONAL):
C
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))
C
C SELECT THE SIGNIFICANT RYDBERGS, PUT IN "LARC".
C PUT THE LIST OF THE REST OF THE RYDBERGS INTO "LISTAO",
C AND SET THE WEIGHTINGS OF THESE LOW OCCUPANCY ORBITALS TO ONE.
C THEN, DO A WEIGHTED ORTHOG. AMONG THE SIGNIFICANT RYDBERGS,
C SCHMIDT ORTHOG. THE LOW OCC. RYDS TO THESE, AND FINALLY
C DO A LOWDIN ORTHOG. AMONG THE LOW OCC. RYDS.:
C
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))
C
C RETURN OCCUPIED LIST 'LSTOCC' OF 1'S OR 0'S:
C
DO 820 I = 1,NBAS
820 LSTOCC(I) = 1
DO 840 I = 1,NEMT
840 LSTOCC(LSTEMT(I)) = 0
RETURN
END
C*****************************************************************************
SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO)
C*****************************************************************************
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
C
C Perform the Natural Population Analysis
C
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)
C
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)
C
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/
C
C TEST, TEST2, ALLOW, and ALLOW2 are numbers used in determining if the
C density matrix trace is close to being an integer. TEST2 (ALLOW2) must
C be slightly greater than twice TEST (ALLOW):
C
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'/
C
C If the f functions are a cubic set, insert the proper labels:
C
IF(IWCUBF.EQ.0) GOTO 20
DO 10 I = 1,7
II = I+9
10 ANGL(II) = CUBICF(I)
20 CONTINUE
C
C Update the NAO atom-atom valency matrix:
C
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
C
C Determine the NAO orbital energies if a Fock matrix exists. Use
C SPNAO to store TNAO:
C
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
C
C Label NAO's as either 'Cor', 'Val', or 'Ryd':
C
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)
C
C Loop over s,p,d,f orbitals:
C
DO 290 L = 0,3
ITYP = IANG(L+1)
LNUM = 2*L + 1
IF(ICORE(L+1).LE.0) GOTO 240
C
C Label core orbitals:
C
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
C
C Label valence orbitals:
C
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
C
C Assign `principal' quantum numbers using the NAO occupancies:
C
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
C
C Assign `principal' quantum numbers using the NAO Fock matrix elements:
C
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
C
C Count the total number of electrons:
C
TOT = ZERO
DO 600 INAO = 1,NBAS
TOT = TOT + DM(INAO,INAO)
600 CONTINUE
NEL = TOT + TENTH
C
C Store NEL for use by the output routines:
C
NLEW = NEL
C
C Check to see if the total number of electrons found is an integer:
C
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
C
C Write out Natural Population analysis:
C
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
C
C Add note about effective core potentials if used:
C
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
C
C Write out warnings for low occupancy core orbitals:
C
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
C
C Write out warnings for population inversions:
C
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
C
C Summarize the Natural Population Analysis:
C
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)
C
C Write out NMB and NRB populations and percentage occupancies:
C
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
C
C Write out Natural Electron Configuration:
C
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
C
C Remove low occupancy subshells:
C
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
C
C Write out Wiberg Bond Index Matrix if requested:
C
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)
C
C Write out overlap-weighted bond populations:
C
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)
C
C Write out MO bond orders:
C
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
C
C Save NAO info in COMMON/NBNAO/:
C
DO 888 I = 1,NBAS
NAOC(I) = NAOCTR(I)
NAOA(I) = NAOL(I)
888 CONTINUE
RETURN
C
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
C*****************************************************************************
SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
CHARACTER*80 TITLE
C
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)
C
DATA BASIS/' NAO',' NHO',' NBO','NLMO'/
DATA ZERO/0.0D0/
C
C Input:
C T -- transformation from AO basis to currect basis
C INDEX -- current basis = 2,3,4,5 (NAO,NHO,NBO,NLMO)
C IFLG -- number of columns of TMO to print
C or external LFN to write to
C
C Fetch the AO to MO transformation matrix:
C
CALL FEAOMO(C,IT)
IF(IT.EQ.0) RETURN
C
C Find the MO transformation matrix:
C
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
C
C Make sure the largest coefficient in each column is positive:
C
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
C
C Write or print the MO transformation matrix:
C
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
C
910 FORMAT(/1X,'Error calculating the ',A4,' to MO transformation')
920 FORMAT(1X,'The AO to ',A4,' transformation is not invertible')
END
C****************************************************************************
C
C ROUTINES CALLED BY SR NAO:
C
C SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM)
C SUBROUTINE ATDIAG(N,A,B,EVAL,C)
C SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM)
C SUBROUTINE NEWWTS(S,T,WT)
C SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK)
C SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK)
C SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2,
C + LIST,IRPNAO)
C SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
C + IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
C SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT)
C SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO)
C SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,IRPNAO)
C
C*****************************************************************************
SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM)
C*****************************************************************************
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/
C
C AVERAGE THE AO DENSITY MATRIX ELEMENTS OVER THE M=2*L+1 COMPONENTS
C OF L FOR A PARTICULAR ATOM.
C LOAD DENSITY MATRIX ELEMENTS (UPPER TRIANGLE OF S, INCL. DIAGONAL)
C INTO A, OVERLAP MATRIX ELEMENTS (LOWER TRIANGLE OF S) INTO B, FOR
C ORBITALS OF 'LIST'
C
DO 30 J=1,NL
DO 20 I=1,J
C 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
C DENSITY MATRIX ELEMENTS INTO A:
A(I,J)=AVE
A(J,I)=AVE
C 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
C*****************************************************************************
SUBROUTINE ATDIAG(N,A,B,EVAL,C)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C SOLVE GENERALIZED EIGENVALUE PROBLEM (A-EVAL*B)*C = 0.
C
C USE JACOBI TO DIAGONALIZE B**(-1/2)*A*B**(-1/2); A AND B ARE DESTROYED.
C
DIMENSION A(N,N),B(N,N),EVAL(N),C(N,N)
DATA ZERO,ONE/0.0D0,1.0D0/
C 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
C NOW SIMILARITY TRANSFORM A WITH B:
CALL SIMTRS(A,B,EVAL,N,N)
C DIAGONALIZE A:
CALL JACOBI(N,A,EVAL,C,N,N,1)
C 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
C MOVE FINAL EIGENVECTORS TO C:
CALL COPY(A,C,N,N,N)
RETURN
END
C*****************************************************************************
SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM)
C*****************************************************************************
C
C Select the set of natural minimal basis (NMB) orbitals for a particular
C atom and angular symmetry type: (up to atomic number 105)
C
C------------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
C
DIMENSION LSTOCC(NDIM),LSTEMT(NDIM)
DIMENSION ICORE(4),IVAL(4)
C
C If g orbitals or orbitals of even higher angular symmetry are selected,
C there are none in the NMB:
C
IF(L.GE.4) GOTO 100
C
C Find core and valence orbitals for this atom:
C
IECP = 0
CALL CORTBL(IAT,ICORE,IECP)
CALL VALTBL(IAT,IVAL)
C
C Determine the number of shells with angular symmetry L in the NMB.
C If there are a negative number of core orbitals, ignore them:
C
NSHELL = MAX0(ICORE(L+1),0) + IVAL(L+1)
IF(NSHELL.EQ.0) GOTO 100
C
C Select sets of occupied and empty NAO's:
C
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
C
C No NMB `L'-type orbitals found for this atom:
C
100 CONTINUE
DO 110 J = 1,NL
NEMT = NEMT + 1
LSTEMT(NEMT) = NF + J
110 CONTINUE
RETURN
END
C*****************************************************************************
SUBROUTINE NEWWTS(S,T,WT)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
DATA ZERO/0.0D0/
C
C 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
C 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
C 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
C
600 CONTINUE
TITLE = 'New symmetry-averaged occupancy weights:'
CALL AOUT(WT,NBAS,NBAS,1,TITLE,-1,1)
RETURN
C
END
C*****************************************************************************
SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C******************************************************************
C
C WORTH: OCCUPANCY WEIGHTED ORTHOGONALIZATION SUBROUTINE
C
C S: FULL OVERLAP MATRIX (PURE AO BASIS)
C (NOTE: UPPER TRIANGLE USED FOR SCRATCH, BUT RESTORED AGAIN)
C T: PURE AO TO PRE-NAO TRANSFORMATION
C LIST: LIST OF ORBITALS TO BE ORTHOGONALIZED
C N: NUMBER OF ORBITALS IN LIST
C OCC: LIST OF SYMMETRY AVERAGED OCCUPANCY WEIGHTINGS
C
C NOTE: BLK AND BIGBLK SHARE THE SAME STORAGE BUT ARE
C DIMENSIONED DIFFERENTLY.
C
C******************************************************************
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/
C
C IMPORTANT CONSTANTS:
C WTTHR ALL WEIGHTING FACTORS SMALLER THAN WTTHR ARE SET
C TO THE VALUE OF WTTHR.
C DIAGTH THRESHOLD FOR MATRIX DIAGONALIZATION USED IN
C SUBROUTINE JACOBI. IN JACOBI, THIS CONSTANT
C IS CALLED "DONETH".
C DANGER CRITERION FOR DECIDING THAT THE JOB SHOULD BE
C ABORTED DUE TO NUMERICAL PROBLEMS CAUSED BY NEAR
C LINEAR DEPENDENCIES IN THE BASIS SET. ALL
C EIGENVALUES OF THE WEIGHTED OVERLAP MATRIX MUST
C BE GREATER THAN DIAGTH*DANGER.
C
DATA WTTHR,DIAGTH,DANGER/1.0D-3,1.0D-12,1.0D3/
C
NTIME=NTIME+1
C MULTIPLY THE WEIGHT BY A CONSTANT SO THAT THE MAXIMUM WEIGHT IS ONE,
C 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
C 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)
C 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
C DIAGONALIZE S-TILDE (THE WEIGHTED OVERLAP MATRIX):
CALL JACOBI(N,S,EVAL,BLK,NDIM,N,0)
C
C 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
C
C THE UPPER TRIANGLE OF S (INCLUDING THE DIAGONAL)
C NOW CONTAINS THE -0.5 POWER OF THE WEIGHTED OVERLAP MATRIX,
C AND IS THE WEIGHTED ORTHOG. TRANSFORM THAT WE WANT.
C 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
C 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
C
900 WRITE(LFNPR,1000) EIGENV,TOOSML
STOP
C
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
C*****************************************************************************
SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C SCHMIDT ORTHOGONALIZATION OF COLUMN VECTORS IN T
C SCHMIDT ORTHOGONALIZE EACH EMPTY ORBITAL (SPECIFIED IN 'LSTEMT')
C TO THE ORTHONORMAL OCCUPIED (LSTOCC) ORBITALS;
C
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
C SCHMIDT ORTHOGONALIZE EACH UNOCCUPIED /UI> TO EACH /VJ>:
C...LOOP OVER UNOCCUPIED /UI>'S,
DO 120 I=1,NEMT
IP=LSTEMT(I)
C...LOOP OVER OCCUPIED /VJ>'S,
DO 60 J=1,NOCC
JP=LSTOCC(J)
C...CALCULATE SJI = ,
SJI=ZERO
DO 40 K=1,NBAS
40 SJI=SJI+SBLK(K,J)*T(K,IP)
C...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
C*****************************************************************************
SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2,
* LIST,IRPNAO)
C*****************************************************************************
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/
C
C COMPUTE NEW RYDBERG NAOS AFTER THE SCHMIDT ORTHOGONALIZATION TO
C THE MINIMAL NAO SET HAS BEEN DONE:
C
C IF REQUESTED (IRPNAO=JPRINT(11)=1), UPDATE PNAO TRANSFORMATION WITH TRYD:
C
IF(IRPNAO.EQ.1) CALL FEPNAO(TPNAO)
C
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)
C END OF LOOP STARTING AT 100
GO TO 100
300 CONTINUE
C 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
C
C SAVE UPDATED T-PNAO TRANSFORMATION:
C
IF(IRPNAO.EQ.1) CALL SVPNAO(TPNAO)
RETURN
END
C*****************************************************************************
SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
* IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
C*****************************************************************************
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/
C
C DIAGONALIZE ONE RYDBERG BLOCK, UPDATE T-NAO (IN T) AND, IF IRPNAO.EQ.1,
C UPDATE TPNAO:
C
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
C USE LIMTRN TO UPDATE T:
CALL LIMTRN(T,LIST,SBLK,DMBLK,NDIM,NBAS,NRYDC,NRYDC,1)
700 CONTINUE
C
IF(IRPNAO.EQ.0) RETURN
C
C UPDATE TPNAO, BUT DO THIS IN SUCH A WAY THAT THE INTRA-ATOMIC BLOCKS
C OF THE OVERLAP MATRIX IN THE REVISED PNAO MATRIX REMAIN DIAGONAL
C AND THAT THE PNAOS REMAIN NORMALIZED. IN ORDER TO ACCOMPLISH THIS,
C WE MUST LOWDIN-ORTHOGONALIZE THE RYDBERG TRANSFORMATION IN "SBLK":
C
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
C*****************************************************************************
SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT)
C*****************************************************************************
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/
C
C DIVIDE THE RYDBERG ORBITALS INTO 2 GROUPS:
C LIST1: RYDBERGS OF SIGNIFICANT OCCUPANCY ( .GT.WTTHR )
C
C LIST2: RYDBERGS OF VERY LOW OCCUPANCY ( .LT.WTTHR )
C
C WTTHR IS SET TO 0.0001
C
C SET THE WEIGHTINGS OF THE RYDBERGS IN LIST2 TO ONE SO THAT THE WEIGHTED
C ORTHOGONALIZATION THAT WILL LATER BE DONE AMONG THESE ORBITALS WILL
C BE IN FACT A LOWDIN ORTHOG.
C
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
C*****************************************************************************
SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
C REDIAGONALIZE THE SYMMETRY AVERAGED DM SUBBLOCKS FOR EACH ANGULAR
C SYMMETRY ON EACH ATOM:
C
C READ IN OLD T-PNAO INTO TPNAO SO THAT IT CAN BE UPDATED (IF IRPNAO.EQ.1):
C
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
C
C SAVE NEW T-PNAO FROM TPNAO:
C
CALL SVPNAO(TPNAO)
RETURN
END
C*****************************************************************************
SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,
* IRPNAO)
C*****************************************************************************
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/
C
C FIND THE REDIAGONALIZATION TRANSFORMATION FOR THE DM SUBBLOCK FOR
C THE ANGULAR MOMENTUM "IL" ON AN ATOM, PUT IN T2:
C
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
C
RETURN
END
C****************************************************************************
C
C ROUTINES CALLED BY THE NBO/NLMO DRIVERS:
C
C SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C + P,TA,HYB,VA,VB,TOPO)
C SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C + P,TA,HYB,VA,VB,TOPO)
C SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C + P,TA,HYB,VA,VB,TOPO,IFLG)
C SUBROUTINE SRTNBO(T,BNDOCC)
C SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR)
C SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB)
C SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN)
C SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
C SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR)
C SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB)
C SUBROUTINE FNDMOL(IATOMS)
C SUBROUTINE NBOCLA(BNDOCC,ACCTHR)
C SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO)
C SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR)
C SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG)
C SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR)
C SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM)
C SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,SIAB,NOCC,NAB)
C SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX)
C SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX)
C SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC)
C
C****************************************************************************
SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
* P,TA,HYB,VA,VB,TOPO)
C****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C Construct orthogonal matrix T for transformation from AO's to
C Natural Hybrid Bond Orbitals using input density matrix DM.
C
C REQUIRED INPUT INCLUDES:
C DM = DENSITY MATRIX IN ORTHONORMAL ATOMIC ORBITAL BASIS;
C REAL(1,NDIM;1,NDIM)
C NBAS = NO. OF ORBITALS = ACTUAL DIMENSION OF DM,S,T,NAOL,DMT
C NATOMS = NO. OF ATOMS (NOT INCLUDING GHOSTS) IN THE MOLECULE
C IATNO = LIST OF ATOMIC NUMBERS
C NAOCTR = ORBITAL LABEL LIST. NAOCTR(I)=IAT IF NAO # I IS ON ATOM IAT
C INTEGER(1,NDIM). NAOS OF GIVEN ATOM GROUPED TOGETHER.
C IW3C = 1 IF PROGRAM IS TO SEARCH FOR 3-CENTER BONDS,
C = 0 OTHERWISE
C GUIDE = WIBERG ATOM-ATOM BOND INDEX MATRIX, USED AS GUIDE FOR NBO SEARCH
C
C OUTPUT:
C T = BOND ORBITAL TRANSFORMATION MATRIX (NDIM,NDIM).
C ROWS ARE LABELLED BY NAOS, COLUMNS BY NBOS.
C LABEL = LIST OF BOND ORBITAL LABELS
C IBXM = PERMUTATION LIST OF BOND ORBITAL LABELS (VERY IMPORTANT!)
C
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/
C
C PRJINC, the amount to increase PRJTHR by if problems with linear
C dependency between the hybrids arise.
C
DATA PRJINC/0.05D0/
C
NOPVAL(I) = NORBS(I) - INO(I)
C
DETAIL = .FALSE.
IF(IWDETL.NE.0) DETAIL = .TRUE.
NOBOND = .FALSE.
IF(JPRINT(10).NE.0) NOBOND = .TRUE.
C
C Initial iteration loop: If no satisfactory Lewis structure (all
C antibond occupancies < 0.1) for THRESH = 1.90, THRESH is decremented
C up to 4 times by 0.1 in search of a better structure. If the DM is
C not spinless, THRESH is set to 0.90 and is decremented as above.
C
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
C
C Determine the atom ordering for the initial search for bonds:
C
IF(NATOMS.EQ.1) THEN
IORDER(1) = 1
GOTO 45
END IF
C
C Find the two atoms which have the largest bond index:
C
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
C
C Add atoms to IORDER according to these connectivities:
C
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
C
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
C
45 CONTINUE
ITER = 0
IALARM = 0
50 IF(IALARM.EQ.0) ITER = ITER + 1
C
C Store density matrix in upper triangle of T:
C
DO 60 J = 1,NBAS
DO 60 I = 1,J
60 T(I,J) = DM(I,J)
C
C Zero arrays Q, POL, IATHY, INO, and LABEL:
C
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
C
C Remove core orbitals from the density matrix:
C
IBD = 0
CALL CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
C
C Main NHO loops
C --------------
C Doubly occupied (IOCC=1) or singly occupied (IOCC=2) NHO's
C If ISPIN.NE.0, search is only for singly occupied nbos (IOCC=1):
C
OCCMX = THRESH
C
C Main NHO loops over singles, doubles, and triples of atoms:
C
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
C
C Lone pairs:
C
NCTR = 1
IAT1 = IORDER(IC)
IAT2 = 0
IAT3 = 0
GO TO 140
C
C Bond pairs:
C
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
C
C 3-center bonds:
C
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
C
C Deplete DM of one(two) center orbitals if search for two(three)
C center orbitals is beginning:
C
IF(IWPRJ(NCTR).NE.0)
* CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD)
C
C Load proper atomic blocks of DM into BLK:
C
CALL LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
C
C Diagonalize BLK:
C
CALL JACOBI(NB,BLK,EVAL,C,MXBO,MXBO,1)
C
C Rank eigenvectors by occupancy eigenvalue:
C
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)
C
C Throw out orbital if occupancy is less than the threshhold "OCCMX":
C
IF(OCC.LT.OCCMX) GO TO 280
C
C Check to see that bond orbital "BORB" doesn't contain previously used
C hybrids:
C
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
C
C Decompose "BORB" into its constituent atomic hybrids and store in Q:
C
CALL STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
C
C Construct bond orbital labels:
C
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
C
C Symmetric orthogonalization of principal hybrids:
C
CALL ORTHYB(Q,BLK,TA,EVAL,C,IALARM,0)
C
C IALARM sounds the alarm that there is linear dependency between some
C of the hybrids. The remedy is to increase prjthr and repeat the NBO
C search. IALARM is equal to the number of the violating atom.
C
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
C
C Augment open-valence atoms with non-arbitrary hybrids orthogonal to
C those found previously:
C
DO 580 IA = 1,NATOMS
IF(NOPVAL(IA).LE.0) GO TO 580
C
C IULA: upper limit of NAOs on atom. Find NMB, the number of natural
C minimal basis functions on the atom:
C
LLA = LL(IA)
IULA = UL(IA)
NMB = 0
DO 470 I = LLA,IULA
IF(LSTOCC(I).EQ.1) NMB = NMB + 1
470 CONTINUE
C
C Find the number of bond, core, and lone pair hybrids on the atom, IOCC:
C Also find IOCCLP, number of lone pair orbitals already found on IA, for
C use in labelling the extra lone pairs below:
C
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
C
C NEXLP: number of extra (low occupancy) LP orbitals on atom IAT. (This
C is the number of low occupancy orbitals with valence shell character)
C Set NEXLP to zero if (NMB-IOCC) is less than zero in order that the
C orbitals are not miscounted!!
C
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)
C
C Stash and label extra lone pairs that AUGMNT put in BLK: (These ar
C taken to be the highest occupied orbitals, which AUGMNT places first)
C
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
C
C Stash and label the Rydberg orbitals that AUGMNT put in BLK:
C
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
C
C Include antibond labels:
C
IBO = IBD
DO 660 I = 1,IBO
C
C Exit loop if LABEL(I,1) is 'LP', 'RY', or 'CR':
C
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
C
C Replace density matrix DM from T:
C
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
C
C Remember the alarm!
C
IF(IALARM.NE.0) GO TO 50
C
C Miscounted bond orbitals...exit for open shell:
C
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
C
C Find new polarization parameters for orthonormal hybrids:
C
CALL REPOL(DM,Q,POL,BLK,EVAL,C,IBD)
C
C Form final T-NAB (NAO to NBO transformation) from orthonormal
C hybrids:
C
CALL FORMT(T,Q,POL)
C
C Find occupancies, find total number of electrons and occupied orbitals:
C
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)
C
C Make sure all but the NOCC highest occupied NBOs are starred:
C
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
C
C Determine whether this is a good resonance structure:
C
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
C
C Before final return, write out info about core orbitals which
C were isolated in subroutine CORE:
C
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
C
C Problems with a bond orbital occupancy:
C
960 WRITE(LFNPR,1300) OCCI
JPRINT(1) = -1
RETURN
C
C Total number of electrons is not an integer:
C
970 WRITE(LFNPR,1310) TOTELE
JPRINT(1) = -1
RETURN
C
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
C*****************************************************************************
SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
* P,TA,HYB,VA,VB,TOPO)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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/
C
C Search for `ALPHA' or `BETA' character string in case of alpha or
C beta spin density matrices:
C
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
C
C Fill diagonal elements of the TOPO matrix with nominal numbers of
C lone pairs to be found on each atom:
C
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
C
C Read in chosen lone pairs, bonds, and 3-center bonds:
C
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
C
C Read in lone pairs:
C
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
C
C Read in bonds:
C
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
C
C Read in 3-center bonds:
C
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
C
C Modify nominal sets of lone pairs by number of bonds and 3-center
C bonds.
C
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
C
C Use CHOOSE to find bond orbitals using NTOPO and I3CTR:
C
IFLG = 0
CALL CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,P,TA,HYB,
+ VA,VB,TOPO,IFLG)
RETURN
C
810 WRITE(LFNPR,1180)
JPRINT(1) = -1
RETURN
C
820 WRITE(LFNPR,1190)
JPRINT(1) = -1
RETURN
830 WRITE(LFNPR,1130)
JPRINT(1) = -1
RETURN
C
840 WRITE(LFNPR,1140)
JPRINT(1) = -1
RETURN
C
860 WRITE(LFNPR,1160)
JPRINT(1) = -1
RETURN
C
870 WRITE(LFNPR,1170)
JPRINT(1) = -1
RETURN
C
1010 WRITE(LFNPR,1110) (KEYWD(I),I=1,6)
JPRINT(1) = -1
RETURN
C
1020 WRITE(LFNPR,1120)
JPRINT(1) = -1
RETURN
C
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
C*****************************************************************************
C
C SUBROUTINES CALLED BY NATHYB AND CHSDRV FOR FORMING NBOS
C
C
C*****************************************************************************
SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
* P,TA,HYB,VA,VB,TOPO,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C Construct orthogonal matrix T for transformation from AO's to
C Natural Hybrid Bond Orbitals using input density matrix DM
C with the chosen bonding pattern read from LFNIN
C
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)
C
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)
C
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/
C
C IFLG is a print flag on entering CHOOSE. If set to 0(1), CHOOSE
C will(not) print some output to LFNPR. On exit, if IFLG is set to
C -1, there was an error in finding the requested structure:
C
C PRJINC, the amount to increase PRJTHR by if problems with linear
C dependency between the hybrids arise.
C
DATA PRJINC/0.05D0/
C
NOPVAL(I) = NORBS(I) - INO(I)
C
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
C
C Initialize KTOPO and KFLG arrays: (KFLG is set to 1 if the 3-center
C bond has not been fund yet.)
C
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
C
C Determine the atom ordering for the search for bond orbitals:
C
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)
C
C Begin search for bond orbitals where the formal bond order is much
C greater than the corresponding Wiberg bond index:
C
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
C
C Add IAT and JAT to the atom permutation list IORDER:
C
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
C
C Return to here if it should prove necessary to raise PRJTHR:
C
35 CONTINUE
ITER = ITER + 1
OCCTHR = ABS(THRSET)
IF(ISPIN.NE.0) OCCTHR = OCCTHR - ONE
OCCTHR = OCCTHR + TENTH
C
C Store density matrix in upper triangle of T:
C
DO 50 J = 1,NBAS
DO 40 I = 1,J
T(I,J) = DM(I,J)
40 CONTINUE
50 CONTINUE
C
C Zero arrays Q,POL,IATHY,INO,LABEL:
C
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
C
C Remove core orbitals from the density matrix:
C
IBD = 0
CALL CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
C
C Return here if there are still more lone pairs or bonds to be found.
C Lower the occupancy threshold for acceptance by a tenth:
C
115 CONTINUE
OCCTHR = OCCTHR - TENTH
LEFT = .FALSE.
C
C ******** START DIRECTED NBO SEARCH *********
C
C Loop over numbers of centers, removing lone pairs and 2- and 3-center
C bonds from the density matrix according to KTOPO and I3CTR:
C
NCTR = 0
120 NCTR = NCTR + 1
C
C Deplete DM of one(two) center orbitals if search for two(three)
C center orbitals is beginning:
C
IF(NCTR.NE.1) CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD)
C
ICNTR = 0
C
C Return here for 3-c bonds and lone pairs:
C
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
C
C Return here for 2-c bonds:
C
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
C
C Load proper atomic blocks of DM into BLK, and diagonalize BLK:
C
200 CONTINUE
CALL LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
CALL JACOBI(NB,BLK,EVAL,C,MXBO,MXBO,1)
C
C Rank eigenvectors by occupancy eigenvalue:
C
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)
C
C Loop over eigenvalues selecting the NUM highest occupied:
C
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)
C
C If this is a low occupancy orbital, skip the rest of these and can come
C back to them later:
C
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
C
C Check to see if bond orbital "BORB" contains previously used hybrids:
C
C 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
C END IF
IBD = IBD + 1
IACCEP = IACCEP + 1
C
C Decompose "BORB" into its constituent atomic hybrids and store in Q:
C
CALL STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
C
C Construct bond orbital labels:
C
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
C
C ******** END OF LOOP FOR DIRECTED NBO SEARCH *********
C
300 CONTINUE
C
C If some orbitals were left behind, go back and fetch them:
C
IF(LEFT) THEN
OCCTHR = OCCMAX
GOTO 115
END IF
C
C Symmetrically orthogonalize principal hybrids:
C
CALL ORTHYB(Q,BLK,TA,EVAL,C,IALARM,IFLG)
C
C IALARM sounds the alarm that there is linear dependency between some of the
C hybrids. IALARM is equal to the number of the violating atom. Replenish
C DM from T and repeat the NBO search:
C
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
C
C Augment open-valence atoms with non-arbitrary hybrids orthogonal to those
C found previously:
C
DO 580 IA = 1,NATOMS
IF(NOPVAL(IA).LE.0) GOTO 580
C
C Find NMB, the number of natural minimal basis functions on this atom:
C
LLA = LL(IA)
IULA = UL(IA)
NMB = 0
DO 470 I = LLA,IULA
IF(LSTOCC(I).EQ.1) NMB = NMB + 1
470 CONTINUE
C
C Find the number of bond, core, and lone pair hybrids on this atom, IOCC.
C Also find IOCCLP, the number of lone pair orbitals already found
C on atom IA for use in labelling the extra lone pairs below:
C
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
C
C NEXLP, the number of extra (low occupancy) LP orbitals on atom IAT.
C (This is the number of low occupancy orbitals with valence shell character)
C Set NEXLP to zero if (NMB-IOCC) is less than zero!!
C
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)
C
C Stash and label extra lone pairs that AUGMNT put in BLK:
C (These are taken to be the highest occupied orbitals, which
C AUGMNT places first)
C
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
C
C Stash and label the Rydberg orbitals that AUGMNT put in BLK:
C
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
C
C Include antibond labels:
C
IBO = IBD
DO 660 I = 1,IBO
C
C Exit loop if LABEL(I,1) is 'LP', 'RY', OR 'CR':
C
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
C
C Replace density matrix DM from T:
C
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
C
C If the alarm sounded, repeat directed NBO search:
C
IF(IALARM.NE.0) GOTO 35
C
C Find new polarization parameters for orthonormal hybrids:
C
CALL REPOL(DM,Q,POL,BLK,EVAL,C,IBD)
C
C Form final T-NAB (NAO to NBO transformation) from orthonormal hybrids:
C
CALL FORMT(T,Q,POL)
C
C Find occupancies, find total number of electrons and occupied orbitals:
C
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)
C
C If the number of unstarred orbitals is not equal to the number of occupied
C MOs, then simply rank the orbitals by occupancy, and ``unstarr'' the NOCC
C highest occupied: (This can be dangerous! However, many of the subsequent
C routines assume the only NOCC orbitals are starred, and therefore, this
C mismatch must be corrected.)
C
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
C
C Determine whether this is a good resonance structure:
C
CALL CYCLES(ITER,ABS(THRSET),GUIDE,BNDOCC,TOPO,ICONT)
C
C Write out info about core orbitals which were isolated in subroutine
C CORE:
C
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
C
C Bad orbital occupancy:
C
960 IF(PRINT) WRITE(LFNPR,1300) OCCI
IFLG = -1
JPRINT(1) = -1
RETURN
C
C Total number of electrons is not an integer:
C
965 WRITE(LFNPR,1310) TOTELE
IFLG = -1
JPRINT(1) = -1
RETURN
C
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
C*****************************************************************************
SUBROUTINE SRTNBO(T,BNDOCC)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL PERMUT
C
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)
C
DIMENSION T(NDIM,NDIM),BNDOCC(NDIM)
DIMENSION NAME(3)
C
DATA LBD,L3C,NAME,LSTAR/'BD','3C','CR','LP','RY','*'/
C
C Reorder the NBOs according to bond type and constituent atomic centers:
C
C Fix atom ordering in the NBO labels:
C
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
C
C Place the 2- and 3-center bonds first in the list of NBOs: (No bonds if
C the NOBOND keyword was specified)
C
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
C
C Next add any core, lone pair, and Rydberg orbitals:
C
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
C
C Add in any antibonds:
C
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
C
C Lastly, make sure orbitals are ordered by serial number:
C
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
C*****************************************************************************
SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL FIRST
C
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/'*',' '/
C
C Form a temporary NAO to NHO transformation matrix. Check hybrid
C overlap to make sure the NBO's were properly labelled as Lewis
C and non-Lewis orbitals:
C
C Count number of hybrids as they are written out:
C
NHYB = 0
C
C Main loop over bond orbitals:
C
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
C
C Loop over atomic centers of bond orbital NBOND:
C
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
C
C Choose sign for polarization coefficients:
C
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
C
C Extract hybrid (HYB) from transformation matrix T; LTYP(I) is the
C orbital angular momentum quantum no. of A.O. # I:
C
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
C
C Check to see if this orbital has been found before:
C
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
C
C Add this hybrid to the temporary THYB:
C
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'
C
C THYB now contains the temporary NAO to NHO transformation matrix.
C Form the non-orthogonal PNHO overlap and NHO to NBO transformation matrices:
C
CALL FESNAO(S)
CALL SIMTRS(S,THYB,SCR,NDIM,NBAS)
C
CALL TRANSP(THYB,NDIM,NBAS)
CALL MATMLT(THYB,T,SCR,NDIM,NBAS)
C
C Check to see that the bonds and antibonds have the correct hybrid
C overlap. Fix the labels if there is a problem:
C
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
C
C Determine the number of occupied orbitals:
C
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)
C
C Count the number of unstarred orbitals:
C
ICNT = 0
DO 320 I = 1,NBAS
IF(LABEL(IBXM(I),2).NE.LSTAR) ICNT = ICNT + 1
320 CONTINUE
C
C If the number of unstarred orbitals is not equal to the number of
C occupied orbitals, fix the orbital labels:
C
IF(ICNT.NE.NOCC) THEN
DO 330 I = 1,NBAS
OCC(I) = DM(I,I)
330 CONTINUE
CALL RANK(OCC,NBAS,NDIM,ISCR)
C
C If there are more unstarred orbitals than occupied, add stars to the
C least occupied lone pairs:
C
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
C
C Remove stars from the highest occupied lone pairs/Rydbergs if there are
C too few starred orbitals:
C
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
C
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
C*****************************************************************************
SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
INTEGER UL
C
C Print out details of bond-orbital transformation from matrix T.
C
C Required input:
C T = Transformation matrix from S.R. NATHYB; REAL (1,NDIM;1,NDIM)
C NDIM = Declared dimensionality of array T
C NBAS = No. of orbitals = actual dimension of T, NAOL
C NAOL = Integer list of orbital angular momentum type
C NAOL(I)/100 = l = Q.N. of atomic orbital I
C IATNO = List of atomic numbers; IATNO(I) is the atomic number
C of atom I as an integer
C NATOMS = No. of atoms (not including ghosts) in the molecule
C IWHYBS = 1 if hybrid A.O. coefficients are to be printed,
C 0 otherwise
C LFNPR = Logical file number for printout.
C NAOCTR = List of atomic centers of OAO or NAO basis orbitals
C LABEL = List of bond orbital labels
C IBXM = Permutation list of bond orbitals
C BNDOCC = List of bond orbital occupancies
C ISPIN = 0 for spinless NBOs
C = 2 for alpha spin NBOs
C =-2 for beta spin NBOs
C
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/'-',' ','*',' '/
C
C Count the number of electrons:
C
TOTELE = ZERO
DO 20 I = 1,NBAS
TOTELE = TOTELE + BNDOCC(I)
20 CONTINUE
TOTELE = TOTELE + TENTH
NEL = TOTELE
TOTELE = NEL
C
C Count the number of core orbitals and the occupancies of the core,
C valence Lewis, valence non-Lewis, and extra-valence Rydberg orbitals.
C (Also count the number of electrons in the ECP, if employed)
C
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
C
C Write summary of NBO occupancies:
C
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
C
C Write out NBOs:
C
IF(JPRINT(5).EQ.1) THEN
WRITE(LFNPR,1000)
WRITE(LFNPR,1100) (LHYP,J=1,79)
END IF
C
C Main loop over bond orbitals:
C
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
C
C Loop over atomic centers of bond orbital NBOND:
C
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
C
C Choose sign for polarization coefficients:
C
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
C
C Extract hybrid (HYB) from transformation matrix T; LTYP(I) is the
C orbital angular momentum quantum no. of A.O. # I:
C
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)
C
C Find leading non-zero contribution to determine POW(L) for each L:
C
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
C
C Write out NHO for center ICTR:
C
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)
C
C If this is a new hybrid, form its label:
C
IF(MHYB.NE.NHYB) THEN
MHYB = NHYB
CALL LBLNHO(NHYB,NBOND,ICTR,NCTR)
END IF
170 CONTINUE
180 CONTINUE
RETURN
C
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
C*****************************************************************************
SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION HYB(MXAO),LTYP(MXAO),PCT(5)
C
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
C
C ANALYZE INPUT HYBRID 'HYB' FOR POLARIZATION COEFFICIENT 'COEF'
C AND PERCENTAGES OF EACH ANGULAR MOMENTUM COMPONENT.
C
DATA ZERO,THRESH,HUNDRD/0.0D0,1.D-4,100.0D0/
C
NL = 0
C
C ZERO PERCENTAGES AND POLARIZATION COEFFICIENT:
C
DO 10 L1 = 1,5
10 PCT(L1) = ZERO
COEF = ZERO
C
C LOOP OVER ATOMIC CONTRIBUTIONS TO HYBRID, COMPUTING PERCENTAGES
C AND POLARIZATION COEFFICIENT:
C
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
C
C CALCULATE PERCENTAGE CONTRIBUTION FOR EACH ANGULAR SYMMETRY:
C
DO 30 L1 = 1,5
30 PCT(L1) = PCT(L1)/COEF*HUNDRD
COEF = SQRT(COEF)
C
C SWITCH THE SIGN OF THE COEFFICIENT IF ISGN IS NEGATIVE:
C
IF(ISGN.LT.0) COEF = -COEF
C
C NORMALIZE THE HYBRID:
C
DO 50 I = 1,NH
50 HYB(I) = HYB(I)/COEF
C
C FIND THE MAXIMUM NUMBER OF ANGULAR MOMENTUM TYPES (NL):
C
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
C
800 CONTINUE
WRITE(LFNPR,900) L1-1
STOP
C
900 FORMAT(/1X,'AO with unknown angular symmetry, l = ',I3)
END
C*****************************************************************************
SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
DATA ZERO,ONE,THRESH/0.0D0,1.0D0,1.0D-4/
C
C FORM FULL NAO TO NHO TRANFORMATION IN THYB, ADDING ONE HYBRID WITH
C EACH CALL. PUT POLARIZATION COEF IN HYCOEF FOR EACH HYBRID.
C
C MAKE SURE THIS HYBRID ISN'T ALREADY IN THE LIST:
C
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
C
C ADD THIS HYBRID TO THE LIST:
C
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
C
900 FORMAT(/1X,'Hybrid ',I3,' has a ',
+ 'non-negligible overlap of ',F8.5,' with hybrid ',I3,'.')
END
C*****************************************************************************
SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
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/
C
C Compute hybrid directionality and bond bending for selected NBO's:
C
C Thresholds: ATHR -- Angular deviation threshold
C PTHR -- Percentage p-character threshold
C ETHR -- Occupancy threshold
C
CONV = 180.0/(4.0*ATAN(ONE))
WRITE(LFNPR,900) ABS(ATHR),ABS(PTHR),ABS(ETHR)
C
C Get atomic centers, NAO to NHO trans., and NAO to NBO trans.:
C
CALL FECOOR(ATCOOR)
CALL FETNHO(THYB)
CALL FETNAB(TBND)
CALL TRANSP(TBND,NDIM,NBAS)
CALL MATMLT(TBND,THYB,SCR,NDIM,NBAS)
C
C Loop over NBOs:
C
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
C
C Skip 3-center orbitals, core orbitals, low occupancy orbitals:
C
IF(LBL1.EQ.L3C) GO TO 100
IF(LBL1.EQ.LCR) GO TO 100
IF(BNDOCC(IBAS).LT.ABS(ETHR)) GO TO 100
C
C Find the hybrids which contribute to this NBO:
C
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
C
C Make sure the hybrids are on the proper nuclear centers and compute
C the percentage p-character in the hybrid:
C
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
C
C If these hybrids have low p-character, skip them:
C
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
C
C Compute the polar and azimuthal angles of each hybrid:
C
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
C
C Compute the deviation from the line of nuclear centers for 2-center
C orbitals:
C
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
C
C Write out directionality info:
C
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
C
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
C*****************************************************************************
SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION XYZ(3),HYB(1)
C
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
C
DATA ZERO,THRESH,CUTOFF/0.0D0,1.0D-4,1.0D-8/
C
C Add the px,py,pz components of this hybrid vectorially and determine
C its percentage p-character:
C
XYZ(1) = ZERO
XYZ(2) = ZERO
XYZ(3) = ZERO
PCENT = ZERO
HNORM = ZERO
C
C Make sure this hybrid is situated on the correct atom, JCTR:
C
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
C
C Find the sign of the largest s-component of this hybrid:
C
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
C
C If the sign of the largest s-component is negative, change the
C phase of this hybrid:
C
IF(JMAX.NE.0.AND.HYB(JMAX).LT.-THRESH) THEN
DO 30 INAO = 1,NBAS
HYB(INAO) = -HYB(INAO)
30 CONTINUE
ENDIF
C
C Sum the px,py,pz components of this hybrid, determine the percent
C p-character:
C
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
C
C Normalize the px,py,pz vector:
C
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
C
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
C*****************************************************************************
SUBROUTINE FNDMOL(IATOMS)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
DIMENSION IATOMS(NATOMS)
LOGICAL BDFIND
C
C FIND MOLECULAR UNITS : Modified algorithm replacing original which
C had problems with determining molecular units for odd numberings of
C atoms. (E. Glendening 3/12/88)
C
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
C
C SORT ATOMS IN MOLECULAR UNITS:
C
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
C
C ALPHA SPIN: SAVE BONDING INFO IN NMOLA,MOLATA,MOLECA:
C
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
C
C BETA SPIN: MAKE SURE THAT BETA MOLECULAR UNITS ARE THE SAME AS ALPHA:
C
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
C
800 WRITE(LFNPR,1800)
NMOLA = -NMOLA
RETURN
C
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
C*****************************************************************************
SUBROUTINE NBOCLA(BNDOCC,ACCTHR)
C*****************************************************************************
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/
C
C CLASSIFY NBOS ACCORDING TO DONOR/ACCEPTOR TYPE:
C
IF(ACCTHR.LE.ZERO) THEN
ACCTHR = THRESH
IF(ISPIN.NE.0) ACCTHR = ACCTHR - ONE
END IF
IF(ISPIN.NE.0) DONTHR = DONTHR / TWO
C
C MAKE UP LIST MOLLST OF WHICH "MOLECULE" EACH ATOM IS IN:
C
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
C
C MAKE UP LISTS OF NBO ORBITALS:
C NBOUNI(IBAS) = MOLECULAR UNIT
C NBOTYP(IBAS) = NUMBER OF CENTERS (+10 IF A LOW OCCUPANCY LONE PAIR)
C (+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
C
C LOW OCCUPANCY VALENCE ORBITAL
C
NBOTYP(IBAS) = NCTR + 10
GO TO 200
C
C ANTIBOND/RYDBERG
C
180 NBOTYP(IBAS) = NCTR + 20
C
C HIGH OCCUPANCY RY* OR BD* ORBITAL
C
IF(BNDOCC(IBAS).GT.DONTHR) NBOTYP(IBAS) = NCTR + 10
200 CONTINUE
RETURN
END
C*****************************************************************************
SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
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/
C
C PERFORM 2ND ORDER ANALYSIS OF THE FOCK MATRIX:
C
C ETHR1 IS THE THRESHOLD FOR PRINTING THE INTRAMOLECULAR PERTURBATIONAL
C ENERGIES (0.5 KCAL/MOL FOR CLOSED SHELL, 0.25 KCAL/MOL FOR OPEN SHELL)
C SIMILARLY, ETHR2 IS THE INTERMOLECULAR THRESHOLD, (0.05 KCAL/MOL).
C
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
C
C FETCH THE NBO FOCK MATRIX:
C
NTRI = NDIM * (NDIM+1)/2
CALL FEFNBO(F)
CALL UNPACK(F,NDIM,NBAS,NTRI)
C
C ANALYZE FOCK MATRIX:
C
C MAKE UP LIST MOLNBO(1,IBAS,IMOL) OF CORE/LP/BOND NBOS IN MOLEC. UNIT IMOL
C MOLNBO(2,IBAS,IMOL) OF RYDBERG/ANTIBOND NBOS IN MOLEC. IMOL
C
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
C
C DETERMINE THE CONVERSION FROM INPUT ENERGY UNITS TO KCAL:
C
IF(MUNIT.EQ.0) THEN
CONV = AUKCAL
ELSE IF(MUNIT.EQ.1) THEN
CONV = EVKCAL
ELSE
CONV = ONE
END IF
C
C LOOP OVER PAIRS OF UNITS:
C
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
C
C COMPUTE OCCUPANCY FACTOR TO MULTIPLY BY:
C
TOTOCC = BNDOCC(IBAS)+BNDOCC(JBAS)
FULLOC = TWO
IF(ISPIN.NE.0) FULLOC = ONE
OCCFAC = TOTOCC
IF(TOTOCC.GT.FULLOC) OCCFAC = TWO * FULLOC - TOTOCC
C
C MULTIPLY EPERT BY SUM OF OCCUPANCIES OF NBOS IBAS AND JBAS:
C
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
C
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
C*****************************************************************************
SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL FIRST
C
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)
C
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'/
C
C Set flag to zero -- Determine strong delocalizations from perturbative
C analysis of the NBO Fock matrix:
C
IFLG = 0
C
C Threshold for printing delocalizations:
C
THR1 = ABS(E2THR)
IF(ISPIN.NE.0) THR = THR/TWO
THR2 = THR1 / TEN
C
C Get Fock matrix if there is one:
C
IF(IWFOCK.NE.0) THEN
NTRI = NDIM * (NDIM+1)/2
CALL FEFNBO(F)
CALL UNPACK(F,NDIM,NBAS,NTRI)
END IF
C
C Print summary heading, then loop over molecules:
C
IF(IWFOCK.NE.0) THEN
WRITE(LFNPR,900)
ELSE
WRITE(LFNPR,910)
END IF
DO 200 IMOL = 1,NMOLEC
C
C Determine the molecular formula, the nuclear charge, and the number of
C ECP electrons of this molecular unit:
C
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)
C
C Loop over NBO's on this molecular unit:
C
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
C
C If there is a Fock matrix, find the orbital energy and principal
C delocalizations:
C
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
C
C Otherwise only write out orbital labels and occupancy:
C
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
C
C Make sure the total number of electrons is an integer if there is only
C one molecular unit:
C
IF(NMOLEC.EQ.1) THEN
TOTAL = TOTAL + TENTH
NEL = TOTAL
TOTAL = NEL
OCCRYD = TOTAL - OCCLEW - OCCNON
END IF
C
C Write a summary of the electron population on this molecular unit:
C
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
C
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
C*****************************************************************************
SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
DATA ZERO,ONE,CUTOFF,TENTH/0.0D0,1.0D0,1.0D-4,0.1D0/
DATA AUKCAL,EVKCAL/627.51,23.060/
C
C Determine the conversion factor to kcal:
C
IF(MUNIT.EQ.0) THEN
CONV = AUKCAL
ELSE IF(MUNIT.EQ.1) THEN
CONV = EVKCAL
ELSE
CONV = ONE
END IF
C
C Determine the strength of each delocalization:
C
DO 10 JBO = 1,NBAS
LIST(JBO) = 0
DEL(JBO) = ZERO
10 CONTINUE
C
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
C
C Sort delocalizations:
C
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
C*****************************************************************************
SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
PARAMETER (MAXCHR = 28, MAXD = 4)
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
DIMENSION LIST(NDIM),ISTR(80)
INTEGER IK(MAXD)
C
DATA ICOMMA,ILEFT,IRIGHT/',','(',')'/
C
C Build a character string (for the NBO summary table) which contains
C the delocalization information for NBO # IBO:
C
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
C
30 IL = IL - 1
RETURN
END
C*****************************************************************************
SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C FORM NATURAL LOCALIZED MOLECULAR ORBITALS FROM DENSITY MATRIX A.
C
C N: ACTUAL DIMENSION OF A,EVEC
C NDIM: DECLARED DIMENSION OF A,EVEC
C TSYM: SCRATCH
C RESON: SQUARES OF DIAGONAL ELEMENTS OF NBO TO NLMO TRANSF, TIMES 100%
C IALARM: ALARM THAT THE ORBITAL OCCUPANCIES ARE OUT OF ORDER AND THAT
C THE LMO STEP SHOULD BE AVOIDED
C
C THESE VALUES ARE SET:
C
C DIFFER = 1.0D-5
C
C DONE = 1.0D-10 (THIS IS THE PARAMETER FOR CONVERGENCE OF THE OFF-
C DIAGONAL MATRIX ELEMENTS.)
C
C EPS = 1.0D-11 (THIS PARAMETER HAS TO DO WITH THE MACHINE PRECISION
C AND SHOULD BE SET TO A VALUE BETWEEN "DONE" AND THE
C MACHINE PRECISION.)
C
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)
C
C IMPORTANT PARAMETERS:
C
DATA DIFFER,DONE,EPS/1.0D-5,1.0D-10,1.0D-11/
C
C NOFFMX IS SET TO THE DIMENSION OF VECTORS ILIST,JLIST,IOFF,JOFF,IUNIQ,JUNIQ:
C
DATA DEGTHR,NOFFMX/1.0D-3,100/
DATA ZERO,ONE,TEN,HUNDRD/0.0D0,1.0D0,10.0D0,100.0D0/
C
WRITE(LFNPR,8390)
THR1 = ONE - DEGTHR
THR2 = ONE - DEGTHR*5
NTIME = 0
C
C IF THERE IS ONLY ONE BASIS FUNCTION, SOLVE THIS TRIVIAL CASE AND RETURN:
C
IF(N.GT.1) GO TO 10
EVEC(1,1) = ONE
EVAL(1) = A(1,1)
RETURN
10 CONTINUE
C
DO 30 J = 1,N
DO 20 I = 1,N
20 EVEC(I,J) = ZERO
30 EVEC(J,J) = ONE
C
C COUNT THE NUMBER OF ELECTRONS AND OCCUPIED ORBITALS:
C
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
C
C CHECK IF OCCUPANCIES ARE IN ORDER:
C
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
C
C 21 OCT 1987. THE FOLLOWING FEATURE OF THE PROGRAM HAS BEEN
C TURNED OFF BECAUSE SOMETIMES IT IS NOT POSSIBLE TO DIAGONALIZE
C THE NBO DENSITY MATRIX WHEN ONE OF THE ``A'' NBOS IS DEGENERATE
C IN OCCUPANCY WITH ONE OR MORE ``B'' NBOS:
C
C THE "ABS(X).LT.DIFFER" PART OF THE NEXT LINE IS INCLUDED SO THAT
C NLMOS CAN BE COMPUTED WHEN A NUMBER OF ORBITALS ARE NEARLY
C DEGENERATE IN OCCUPANCY, AS FOR INSTANCE IN CLI6, WHERE SIX
C LITHIUM LONE PAIRS ARE DEGENERATE BUT ONLY ONE OF THEM CAN
C BE PLACED IN THE "OCCUPIED" SET OF NLMOS.
C IF(X.GT.ZERO.OR.ABS(X).LT.DIFFER) GO TO 100
C
C THE ABOVE STATEMENT IS REPLACED BY:
C
IF(X.GT.DIFFER) GO TO 100
C
C OCCUPANCIES OUT OF ORDER:
C
IALARM = 1
IF(ABS(X).GT.DIFFER) GO TO 80
WRITE(LFNPR,8010)
GO TO 90
80 WRITE(LFNPR,8000)
90 CONTINUE
RETURN
C
C START LOOP:
C
100 CONTINUE
NTIME = NTIME + 1
C
C FIRST, FIND ELEMENT A(IOCC,JEMT) OF LARGEST MAGNITUDE, OFFTOP:
C
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
C
C RETURN IF CONVERGENCE HAS BEEN ACHIEVED:
C
IF(OFFTOP.LT.DONE) GO TO 900
C
C FIND ALL ELEMENTS DEGENERATE WITH LARGEST ONE, OFFTOP:
C (CHECK CORRESPONDING DIAGONAL ELEMENTS ALSO)
C NOFF: NUMBER OF DEGENERATE ELEMENTS
C IOFF(K),JOFF(K): KTH DEGENERATE ELEMENT
C
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
C
C SKIP TEST OF DIAG. ELEM. IF SMALL (.LT.DIFFER):
C
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
C
S = AJJ - AII
ABSS = ABS(S)
C
C IF THE ROTATION IS VERY CLOSE TO 45 DEGREES, SET SIN AND COS TO 1/(ROOT 2)
C
TEST=EPS*OFFTOP
IF (ABSS.GT.TEST) GO TO 330
S=.707106781D0
C=S
GO TO 340
C
C 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)
C
C JACOBI ROTATION ANGLE: COS=C , SIN=S
C= SQRT(0.5D0+S)
S=2.D0*T*S/C
340 CONTINUE
C PRINT STATEMENTS FOR NLMO PROCEDURE DETAILS:
C WRITE(LFNPR,9903) OFFTOP,S,C,NOFF
C 9903 FORMAT(' ****** OFFTOP,S,C,NOFF:',3F14.9,I3)
C WRITE(LFNPR,9901) (IOFF(I),I=1,NOFF)
C 9901 FORMAT(' IOFF:',20I3)
C WRITE(LFNPR,9902) (JOFF(I),I=1,NOFF)
C 9902 FORMAT(' JOFF:',20I3)
C
C 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)
C
C 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
C
400 CONTINUE
C
C NOFF.GT.1:
C COMPUTE "AVERAGED" UNITARY TRANSFORMATION SO THAT SYMMETRY IS PRESERVED
C
C CONSTRUCT UNIQUE LISTS OF ORBITALS INVOLVED:
C
C IUNIQ(L): L-TH UNIQUE OCCUPIED ORB.
C NIUNIQ: NO. OF UNIQUE OCC. ORBS
C ILIST(L): LOCATION IN THE UNIQUE LIST (IUNIQ) OF THE I VALUE OF THE
C L-TH OFFDIAG. ELEMENT
C JUNIQ, NJUNIQ, AND JLIST ARE FOR THE EMPTY ORBITALS.
C
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
C
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
C CONSTRUCT TSYM:
CALL SYMUNI(TSYM,A,C,S,TSYM(N1),TSYM(N2),EVAL,NROT,
* NIUNIQ,NJUNIQ,
* ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
C
C MAKE IUNIQ INTO A COMPLETE LIST OF THE UNIQUE ORBITALS, AND TRANSFORM
C 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)
C SEE HOW MUCH THE ELEMENTS WERE REDUCED:
C DO 750 MOFF=1,NOFF
C I=IOFF(MOFF)
C J=JOFF(MOFF)
C WRITE(LFNPR,9920) I,J,(A(I,J))
C 9920 FORMAT(' I,J,AIJ:',2I3,F14.9)
C 750 CONTINUE
C
800 CONTINUE
C TOTELE=ZERO
C DO 810 J=1,N
C TOTELE=TOTELE+A(J,J)
C 810 CONTINUE
C TOT=NEL
C FRACT=TOTELE-TOT
C WRITE(LFNPR,7000) NOFF,TOTELE,FRACT
GO TO 100
C
C FINISHED: PLACE OCCUPANCIES IN EVAL AND COUNT UP ELECTRONS:
C
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
C
C FIND THE LARGEST OFF-DIAGONAL DENSITY MATRIX ELEMENT:
C
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
C
C IF THIS IS A CORRELATED WAVEFUNCTION, RETURN TO THE CALLING ROUTINE:
C
IF(CI.OR.MCSCF.OR.AUHF) RETURN
C
C FOR SCF WAVEFUNCTIONS, MAKE SURE THIS MATRIX ELEMENT IS SMALL:
C
IF(AMAX.LT.HUNDRD*HUNDRD*DONE) RETURN
WRITE(LFNPR,9550)
IALARM = 1
RETURN
C
C NON-INTEGER NUMBER OF ELECTRONS:
C
990 WRITE(LFNPR,9900) DIFFER,TOTELE
WRITE(LFNPR,9600)
WRITE(LFNPR,9610) (EVAL(I),I=1,NBAS)
IALARM = 1
RETURN
C
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
C*****************************************************************************
SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,
* SIAB,NOCC,NAB)
C*****************************************************************************
c Revision 1.2 88/03/03 11:29:56 reed
c To reduce amount of output, deleted some blank lines, commented out print
c of atom totals for bond orders, and the atomic contrib. to the NLMO is
c only printed if it is greater than 0.01%.
c
IMPLICIT REAL*8 (A-H,O-Z)
INTEGER UL
LOGICAL CLOSED
C
C PRINT OUT DETAILS OF NAO TO NLMO TRANSFORMATION IN MATRIX T.
C
C REQUIRED INPUT:
C NDIM = DECLARED DIMENSIONALITY OF ARRAY T
C NBAS = NO. OF ORBITALS = ACTUAL DIMENSION OF T, NAOL
C NAOL = INTEGER LIST OF ORBITAL ANG. MOMENTUM TYPE
C NAOL(I)/100 = L = Q.N. OF ATOMIC ORBITAL I
C IATNO = LIST OF ATOMIC NUMBERS; IATNO(I) IS THE NUCLEAR CHARGE
C OF ATOM I AS AN INTEGER
C NATOMS = NO. OF ATOMS (NOT INCLUDING GHOSTS) IN THE MOLECULE
C IWHYBS = 1 IF HYBRID A.O. COEFFICIENTS ARE TO BE PRINTED,
C 0 OTHERWISE.
C LFNPR = LOGICAL FILE NUMBER FOR PRINTOUT.
C NAOCTR = LIST OF ATOMIC CENTERS OF OAO OR NAO BASIS ORBITALS
C LABEL = LIST OF BOND ORBITAL LABELS
C IBXM = PERMUTATION LIST OF BOND ORBITALS
C BNDOCC = LIST OF BOND ORBITAL OCCUPANCIES
C ISPIN = 0 FOR CLOSED SHELL
C = 2 FOR ALPHA SPIN
C =-2 FOR BETA SPIN
C
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/
C
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)
C 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
C 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
C 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
C 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
C 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
C 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
C
C NOW, COMPUTE HYBRID OVERLAPS SIAB:
C
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
C IF(IAT.GT.2) GO TO 1130
C CALL ALTOUT(TS,1,NDIM,1,NDIM)
C 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
C IF(IAT.GT.2) GO TO 1300
C WRITE(LFNPR,9996) JAT,IAB,JALOW,JAHIGH,OVP,ANORM,
C * SIAB(NLMO,IAB)
C 9996 FORMAT(1X,'JAT,IAB,JALOW,JAHIGH,OVP,ANORM,SIAB:',
C * /5X,4I3,3F11.6)
GO TO 1300
1250 SIAB(NLMO,IAB)=ZERO
C IF(IAT.GT.2) GO TO 1300
C WRITE(LFNPR,9996) JAT,IAB,JALOW,JAHIGH,OVP,ANORM,
C * SIAB(NLMO,IAB)
1300 CONTINUE
1400 CONTINUE
1500 CONTINUE
C 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
C WRITE(LFNPR,8999) ALAMA2,ALAMB2,BO
C 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
C 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
C ZERO DIAGONAL ELEMENTS!
DO 2020 IAT=1,NATOMS
BORDER(IAT,IAT)=ZERO
2020 OWBORD(IAT,IAT)=ZERO
C 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
C
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
C*****************************************************************************
SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL TEST
C
C DM -- NLMO density matrix (input)
C T -- AO to NLMO transformation matrix (input)
C C -- NBO to NLMO transformation matrix (retrieved from NBODAF)
C TNBO -- AO to NBO transformation (retrieved from NBODAF)
C DX,DY,DZ -- AO dipole matrices (retrieved from NBODAF)
C SCR -- NDIM*NDIM word scratch vector
C INDEX -- temporary indexing array
C
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)
C
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 /
C
DEBYE = TOESU / TENTEN
C
C Copy the nuclear charges into CHARGE:
C
IF(ALPHA.OR..NOT.OPEN) THEN
DO 10 I = 1,NATOMS
CHARGE(I) = IZNUC(I)
10 CONTINUE
END IF
C
C Determine the number of occupied orbitals and make sure that the
C occupied NLMOs are at the beginning of the list:
C
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)
C
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
C
C Determine the occupancy factor:
C
ETA = TWO
IF(OPEN) ETA = ONE
C
C Compute the electronic contributions to the NBO bond dipole moments:
C
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
C
C Add the nuclear contributions to these bond dipole moments:
C
CALL DIPNUC(DX,DY,DZ,SCR,ETA,NOCC)
C
C Convert to Debye:
C
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
C
C Print dipole analysis:
C
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
C
C Build the label for this NBO/NLMO:
C
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
C
C Compute the NLMO bond dipole (the NBO bond dipoles are on the diagonal
C of DX,DY,DZ):
C
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
C
XNBO = XNBO + DX(I,I)
YNBO = YNBO + DY(I,I)
ZNBO = ZNBO + DZ(I,I)
XNLMO = XNLMO + X
YNLMO = YNLMO + Y
ZNLMO = ZNLMO + Z
C
C Compute the net dipole for these orbitals:
C
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)
C
WRITE(LFNPR,1060) I,(ISTR(J),J=1,14),X,Y,Z,TOTNLM,
+ DX(I,I),DY(I,I),DZ(I,I),TOT
C
C Print delocalization terms which are stronger than ABS(DTHR):
C
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
C
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
C
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
C
C Compute and print the correction for residual nuclear charges:
C
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
C
C Print net dipole moments:
C
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
C
C Compute and print the total delocalization correction:
C
X = XNLMO - XNBO
Y = YNLMO - YNBO
Z = ZNLMO - ZNBO
TOT = SQRT(X*X + Y*Y + Z*Z)
WRITE(LFNPR,1100) X,Y,Z,TOT
C
C Compute and print the NLMO coupling correction:
C
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
C
C Save the alpha spin dipoles:
C
IF(ALPHA) THEN
XDIP = XNLMO
YDIP = YNLMO
ZDIP = ZNLMO
END IF
C
C Print out the total dipole moment for open shell species:
C
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
C
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
C*****************************************************************************
SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION DXYZ(NDIM,NDIM),C(NDIM,NDIM),T(NDIM,NDIM),SCR(NDIM,NDIM)
C
C
C Compute the electronic contribution for the x (INDEX=1), y (=2),
C and z (=3) components of the dipole:
C
C Get the AO dipole matrix and transform to the NBO basis:
C
CALL FEDXYZ(DXYZ,INDEX)
IF(INDEX.EQ.0) RETURN
CALL SIMTRS(DXYZ,T,SCR,NDIM,NBAS)
C
C Compute the electronic contribution for doubly occupied, filled NBOs:
C
DO 30 I = 1,NOCC
SCR(I,I) = -ETA * DXYZ(I,I)
30 CONTINUE
C
C Compute delocalization contributions for each filled NBO:
C
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
C*****************************************************************************
SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
DATA ZERO/0.0D0/
C
C Fetch the atomic coordinates:
C
CALL FECOOR(ATCOOR)
C
C Calculate the nuclear contributions to the dipole moment:
C
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
C*****************************************************************************
C
C ROUTINES CALLED BY SR NATHYB, SR CHOOSE:
C
C SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
C FUNCTION IWPRJ(NCTR)
C SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD)
C SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
C SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP)
C SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
C SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG)
C SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI)
C SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
C SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD)
C SUBROUTINE FORMT(T,Q,POL)
C SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
C
C*****************************************************************************
SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C Label core, valence, and Rydberg NAO's and deplete DM of the density
C of the core orbitals
C
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'/
C
C Label NAO's on each center:
C
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)
C
C Loop over s,p,d,f orbitals:
C
DO 100 L = 0,3
ITYP = IANG(L+1)
LNUM = 2*L + 1
IF(ICORE(L+1).LE.0) GOTO 50
C
C Label core orbitals:
C
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
C
C Label valence orbitals:
C
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
C
C Isolate core orbitals on all atoms, removing their density from the
C density matrix:
C
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
C
C Deplete the density matrix of CR orbitals:
C
CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD)
RETURN
C
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
C*****************************************************************************
FUNCTION IWPRJ(NCTR)
C*****************************************************************************
DATA NCTR0/0/
C
C RETURN 0 (NO PROJECTION WANTED) IF NCTR IS UNCHANGED, 1 OTHERWISE.
C
IWPRJ=0
IF(NCTR.EQ.NCTR0) RETURN
IWPRJ=1
NCTR0=NCTR
RETURN
END
C*****************************************************************************
SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C DEPLETE DENSITY MATRIX DM OF CONTRIBUTION FROM B.O.'BORB':
C DM ==> DM - OCC*BORB*BORB(TRANSPOSE).
C
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)
C 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)
C MAIN LOOP OVER NBD AVAILABLE BOND ORBITALS:
DO 90 IBD=1,NBD
OCC=BNDOCC(IBD)
C 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
C 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)
C 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
C*****************************************************************************
SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C ZERO THE MATRIX 'BLK' AND LOAD IN ATOMIC BLOCKS OF DENSITY
C MATRIX 'DM' FOR THE ATOMS LISTED IN 'IAT'
C
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
C 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
C*****************************************************************************
SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C DETERMINE HOW MUCH OF BORB IS COMPOSED OF PREVIOUSLY USED HYBRIDS.
C
C RETURN HYBEXP(I) = EXPECTATION VALUE OF HYBRID "I" IN BORB OVER THE
C PROJECTION OPERATOR P FOR THE ATOM OF THE HYBRID.
C
C IF NO HYBRID ON ATOM I CONTRIBUTES TO BORB, HYBEXP(I) = ZERO.
C
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)
C
DIMENSION IAT(3),HYB(MXAO),BORB(MXBO),Q(MXAO,NDIM),P(MXAO,MXAO),
* PK(MXAO,MXAO),VA(MXAO),VB(MXAO),HYBEXP(3)
C
DATA ZERO,ONE,EPS/0.0D0,1.0D0,1.0D-5/
C
C LOOP OVER ATOMIC HYBRIDS:
C
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
C
C EXTRACT THE ITH ATOMIC HYBRID FROM BORB:
C
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
C
C DO HYBRIDS FROM THE ITH ATOM CONTRIBUTE TO BORB?
C
S = ZERO
DO 20 J = 1,MJ
S = S + HYB(J)**2
20 CONTINUE
IF(S.LT.EPS) GO TO 50
C
C DETERMINE THE PROJECTION EXPECTATION FOR THIS HYBRID:
C
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
C*****************************************************************************
SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C DECOMPOSE BOND ORBITAL 'BORB' AND STORE CONSTITUENT HYBRIDS IN Q
C
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)
C
DIMENSION POL(NDIM,3),Q(MXAO,NDIM),BORB(MXBO),IAT(3),HYB(MXAO)
C
DATA ZERO/0.0D0/
C
C LOOP OVER CENTERS:
C
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)
C
C EXTRACT HYBRID FROM BOND ORBITAL FOR ATOM IA:
C
KMIN = KMAX + 1
KMAX = KMAX + NU - NL + 1
MJ = 0
DO 10 K = KMIN,KMAX
MJ = MJ + 1
HYB(MJ) = BORB(K)
10 CONTINUE
C
C EXTRACT POLARIZATION COEFFICIENT, STORE IN 'POL':
C
PSQ = ZERO
DO 20 J = 1,MJ
PSQ = PSQ + HYB(J)**2
20 CONTINUE
P = SQRT(PSQ)
POL(IBD,I) = P
C
C ONE MORE HYBRID FOR ATOM IA:
C
INO(IA) = INO(IA) + 1
NCOL = ILL(IA) + INO(IA) - 1
C
C PLACE NORMALIZED HYBRID IN APPROPRIATE BLOCK OF Q:
C
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
C*****************************************************************************
SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C SYMMETRIC ORTHOGONALIZATION OF AVAILABLE HYBRIDS IN Q:
C
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)
C
DIMENSION Q(MXAO,NDIM),S(MXBO,MXBO),TA(MXAO,MXAO),
* EVAL(MXBO),C(MXBO,MXBO)
C
DATA ZERO,ONE/0.0D0,1.0D0/
DATA TOOSML/1.0D-4/
C
C TOOSML: "TOO SMALL" -- THRESHOLD FOR AN S MATRIX EIGENVALUE THAT IS TOO
C SMALL AND WILL CAUSE NUMERICAL PROBLEMS AND IS INDICATIVE OF NEAR-LINEAR
C DEPENDENCY IN THE HYBRIDS:
C
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
C
C LOAD IA-BLOCK OF Q INTO TA:
C
DO 10 J = 1,NH
DO 5 I = 1,MXAO
TA(I,J) = Q(I,IL+J-1)
5 CONTINUE
10 CONTINUE
C
C FORM OVERLAP MATRIX S = TA(TRANSP)*TA:
C
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
C
C DIAGONALIZE OVERLAP MATRIX:
C
CALL JACOBI(NH,S,EVAL,C,MXBO,MXBO,0)
C
C FORM INVERSE SQUARE ROOT OF S, STORE IN S: (AVOID NUMERICAL PROBLEMS
C OF LINEAR DEPENDENCE ("TOO SMALL" EIGENVALUES) BY PRESCREENING THE
C EIGENVALUES)
C
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
C
C FORM NEW TAP=TA*S**(-1/2), STORE IN C:
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
C
C REPLACE ORTHOGONALIZED TA IN ARRAY Q:
C
DO 90 J = 1,NH
DO 85 I = 1,MXAO
Q(I,IL+J-1) = C(I,J)
85 CONTINUE
90 CONTINUE
100 CONTINUE
C
C SYMMETRIC ORTHOGONALIZATION COMPLETE:
C
RETURN
C
C SOUND THE ALARM THAT TOO MANY HYBRIDS WERE FOUND ON THIS ATOM:
C
800 CONTINUE
IALARM = IA
IF(IFLG.EQ.0) WRITE(LFNPR,900) MXAO,IA,NH
RETURN
C
C SOUND THE ALARM THAT THERE ARE TOO MANY HYBRIDS OR THAT THERE IS
C LINEAR DEPENDENCY IN THE HYBRIDS!!
C
810 CONTINUE
IALARM = IA
IF(IFLG.EQ.0) WRITE(LFNPR,910) IA,EVAL(I),TOOSML
RETURN
C
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
C*****************************************************************************
SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C FORM PROJECTION MATRIX P TO ANNIHILATE COMPONENTS OF NK OCCUPIED
C HYBRIDS FOR ATOM IA.
C
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)
C
DIMENSION P(MXAO,MXAO),VK(MXAO),PI(MXAO),Q(MXAO,NDIM),
* PK(MXAO,MXAO)
C
DATA ZERO,ONE/0.0D0,1.0D0/
C
C INITIALIZE P = UNIT MATRIX:
C
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
C
C FORM PROJECTION MATRIX P = P1*P2*...*PK*...*PNK TO ANNIHILATE
C COMPONENTS OF THE NK OCCUPIED HYBRIDS VK: PK = I - VK*VK(T).
C LOOP OVER OCCUPIED HYBRIDS VK, K = 1,...,NK:
C
IF(NK.LE.0) RETURN
C
C EXTRACT OCCUPIED HYBRID VK FROM ARRAY Q:
C
DO 90 K = 1,NK
ICOL = ILL(IA) + K - 1
DO 30 I = 1,NB
VK(I) = Q(I,ICOL)
30 CONTINUE
C
C FORM PROJECTION MATRIX PK:
C
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
C
C ACCUMULATE TOTAL PROJECTOR P(K) = P(K-1)*PK:
C
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
C*****************************************************************************
SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
DIMENSION P(MXAO,MXAO),TA(MXAO,MXAO),DM(NDIM,NDIM),C(MXBO,MXBO),
+ EVAL(MXBO),BORB(MXBO),V(MXBO),BLK(MXBO,MXBO),LARC(NBAS)
C
DATA ZERO,EPS,PT99,ONE/0.0D0,1.0D-5,0.99D0,1.0D0/
C
C FIRST, FORM SET OF "OPTIMALLY DIAGONAL" UNIT VECTORS TO SPAN RYDBERG SPACE:
C
NAUG = NORB - NOCC
DO 10 I = 1,NORB
LARC(I) = 0
10 CONTINUE
C
C SELECT PROJECTED NAO UNIT VECTOR FROM PROJECTOR IN P:
C
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
C
C PUT VECTOR IN BORB, NORMALIZE, AND SAVE IN C:
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
C
C ADD BORB TO THE PROJECTOR IN P:
C
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
C
C PUT PROJECTED VECTORS IN TA, ORDERED ACCORDING TO THE NAO PARENT:
C
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
C
C LOAD DM BLOCK FOR ATOM IA IN BLK:
C
CALL LOAD(DM,IA,0,0,BLK,NORB)
C
C FORM BLOCK OF DM IN RYDBERG BASIS IN UPPER CORNER OF BLK:
C
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
C
C DIAGONALIZE DM:
C
CALL JACOBI(NAUG,BLK,EVAL,C,MXBO,MXBO,1)
C
C ORDER EIGENVECTORS BY OCCUPANCY (WITHIN EPS), FORM FINAL RYDBERG VECTORS:
C
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
C*****************************************************************************
SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL PRINT,FIRST
C
C DIAGONALIZE DENSITY MATRIX IN BASIS OF ORTHONORMAL HYBRIDS FOR
C EACH BOND ORBITAL TO FIND NEW POLARIZATION COEFFICIENTS.
C
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
C
DIMENSION DM(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3),
* BLK(MXBO,MXBO),EVAL(MXBO),C(MXBO,MXBO)
C
DATA ZERO,PT1,ONE,TWO/0.0D0,0.1D0,1.0D0,2.0D0/
DATA LSTAR/1H*/
C
C FIRST, COUNT NUMBER OF BONDS AND 3C BONDS:
C
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
C
C IAB+1 IS THE NUMBER OF THE FIRST ANTIBOND IN THE NBO LIST:
C
IAB = NBAS - NBOND - N3CB
C
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
C
C DIAGONALIZE 'BLK' AND EXTRACT NEW POLARIZATION COEFFICIENTS
C
CALL JACOBI(NCTR,BLK,EVAL,C,MXBO,MXBO,0)
CALL RANK(EVAL,NCTR,MXBO,LARC)
C
C MAKE SURE REPOLARIZATION IS NOT TOO DRASTIC (TAKE A LOOK AT THE BOND
C ORBITAL ONLY):
C
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
C
C STORE THE NEW POLARIZATION COEFFICIENTS IN POL:
C
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
C
C CONSTRAIN BONDS TO BE APOLAR, IF REQUESTED (NOT SET UP TO WORK WITH
C 3-CENTER BONDS):
C
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
C
900 FORMAT(1X,'WARNING: significant repolarization of NBO ',I3,' (S=',
+ F7.4,'); REPOL disabled.')
END
C*****************************************************************************
SUBROUTINE FORMT(T,Q,POL)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
INTEGER UL
C
C CONSTRUCTION OF FINAL TRANSFORMATION MATRIX T FROM ORTHONORMAL
C HYBRIDS; ROWS OF T LABELLED BY NAOS, COLUMNS BY NBOS.
C
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)
C
DATA LCR,LLP,LBD,LSTAR,LRY/'CR','LP','BD','*','RY'/
DATA ZERO/0.0D0/
C
C REORDER OCCUPIED NBOS TO PUT LONE AND CORE PAIRS LAST:
C
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
C
C PAIR BONDS:
C
IBO = IBO + 1
IBX(IBD) = IBO
GO TO 40
C
C CORE PAIRS:
C
15 ICR = ICR + 1
IBX(IBD) = ICR + NBDS - NCR - NLP
GO TO 40
C
C LONE PAIRS AND CORE PAIRS:
C
20 ILP = ILP + 1
IBX(IBD) = ILP + NBDS - NLP
GO TO 40
C
C ANTIBONDS:
C
30 IAB = IAB + 1
IBX(IBD) = NBDS + IAB
40 CONTINUE
C
C ZERO TRANSFORMATION ARRAY:
C
DO 60 I = 1,NBAS
DO 50 J = 1,NBAS
T(I,J) = ZERO
50 CONTINUE
60 CONTINUE
C
C DEPOSIT FINAL BOND ORBITALS IN MATRIX T:
C
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
C
C ANTIBOND ORBITALS: SEARCH OCCUPIED ORB. LIST TO GET PROPER HYBRIDS.
C SEARCH OCCUPIED BOND ORBS. FOR MATCH WITH ANTIBOND ATOMS:
C
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
C
C NEGATIVE IRNK = LABEL(K,3) MEANS BOND ORBITAL WAS ALREADY USED:
C
C FOUND MATCH; SET LABEL(K,3)<0:
C
KBD = K
LABEL(KBD,3) = -LABEL(KBD,3)
GO TO 100
90 CONTINUE
C
C COULDN'T FIND MATCH...EXIT:
C
WRITE(LFNPR,9000) IBD,(LABEL(IBD,JJ),JJ=1,6)
STOP
C
C DEPOSIT BOND ORBITALS IN T MATRIX:
C
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
C
C RESTORE LABEL(I,3) > 0:
C
DO 140 I = 1,NBAS
IF(LABEL(I,3).LT.0) LABEL(I,3) = -LABEL(I,3)
140 CONTINUE
C
C SET ARRAY IBXM: IBXM(IB) IS THE CURRENT LOCATION OF B.O. # IB:
C
DO 150 IB = 1,NBAS
I = IBX(IB)
150 IBXM(I) = IB
C
C SET PHASE OF 1-CENTER ORBITALS SUCH THAT THE LARGEST S-TYPE NAO CONTRIBUTION
C IS POSITIVE:
C
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
C
9000 FORMAT(/,1X,'Can''t find bond/antibond match for NBO ',
+ I3,2X,A2,A1,'(',I2,')',3I4)
END
C*****************************************************************************
SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
DIMENSION GUIDE(NATOMS,NATOMS),BNDOCC(NDIM),TOPO(NATOMS,NATOMS)
C
SAVE JTER,DEVMIN,RHOMIN,BEST,RHO,JBADL
C
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/
C
C Subroutine CYCLES controls the search for an acceptable resonance
C structure:
C
C Arguments:
C ITER : iteration counter incremented by the calling routine
C THRESH : occupancy threshold used in search for NBOs
C GUIDE : Wiberg bond index
C BNDOCC : array containing the NBO occupancies
C TOPO : bond index matrix to be compared with the Wiberg indices
C ICONT : control flag (see below)
C
C ITER, GUIDE, and BNDOCC are unaltered by this routine
C THRESH is modified by this routine, if the RESONANCE keyword is selected
C The TOPO matrix is constructed by this routine
C
C Control flag : (set by this routine)
C ICONT = 2 : an acceptable Lewis structure has been found, continue
C = 1 : an acceptable Lewis structure has been found, recompute the
C NBOs for this structure
C = 0 : bogus Lewis structure, terminate search for NBOs
C = -1 : occupancy threshold and/or atom ordering have been
C changed. Repeat the search for NBOs.
C
C Set atom permuting counter and minimum deviation in GUIDE-TOPO:
C
IF(ITER.EQ.1) THEN
JTER = 0
ICONT = -1
END IF
JTER = JTER + 1
IF(JTER.EQ.1) DEVMIN = HUNDRD
C
C The minimum occupancy threshold is 1.5e (0.5e for open shell):
C
THRMIN = ONEPT5
IF(ISPIN.NE.0) THRMIN = THRMIN - ONE
C
C Determine the number of low occupancy orbitals in the Lewis structure:
C
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
C
C Count the ECP electrons in the Lewis structure:
C
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
C
C Keep track of the best Lewis structure found so far:
C
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
C
C Count the number of core, lone pair, and bonding orbitals in this
C resonance structure:
C
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
C
C Build the TOPO matrix from lone pairs and 2- and 3-center bonds:
C
DO 50 I = 1,NATOMS
DO 40 J = 1,NATOMS
TOPO(I,J) = ZERO
40 CONTINUE
50 CONTINUE
C
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
C
C Determine the largest off-diagonal element of GUIDE-TOPO:
C
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
C
C Write info about this resonance structure:
C
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
C
C Decide if this structure is acceptable:
C
C * Accept the structure if CHOOSE was employed.
C * Accept the structure if there is only one atom.
C * Accept the structure if there are no low occupancy Lewis orbitals
C and DEV is less than DEVTHR.
C * Accept the structure if the NOBOND option was selected.
C
C Good resonance structure:
C
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
C
C Only one atom:
C
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
C
C Directed NBO search:
C
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
C
C NOBOND option selected:
C
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
C
C Structure accepted due to the specification of the RESONANCE keyword
C or the occupancy threshold. Otherwise, accept the structure only if
C there are no high occupancy Lewis orbitals:
C
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
C
C If DEV.EQ.DEVMIN.AND.SUM.EQ.RHOMIN or too many atoms permutations,
C stop atom permutations:
C
IF((ABS(DEV-DEVMIN).LT.SMALL.AND.ABS(SUM-RHOMIN).LT.SMALL).OR.
+ JTER.GE.JTERMX) THEN
C
C If the occupancy threshold was set by the user, accept the best
C structure:
C
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
C
C If the RESONANCE keyword was specified, pick the best resonance structure
C for this occupancy threshold, and possibly decrement the threshold and
C continue the search:
C
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
C
C Otherwise, accept the best structure, but only if it had no Lewis
C orbitals with occupancy less than the occupancy threshold:
C
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
C
C Loop through atom ordering to find alternative resonance structures:
C
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
C
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
C
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
C*****************************************************************************
C
C ROUTINES CALLED BY SR NLMO:
C
C SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT,
C + NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
C SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL)
C
C*****************************************************************************
SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT,
* NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
C*****************************************************************************
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
C
C AVERAGE GROUPS OF THE ELEMENTS OF THE TRANSFORMATION MATRIX TSYM
C SO THAT THE SYMMETRY INHERENT IN THE DENSITY MATRIX A IS PRESERVED,
C MAKING SURE THAT THE RESULTING "AVERAGED" TRANSFORMATION IS UNITARY
C
C
JST=NIUNIQ+1
NROT=JST-1+NJUNIQ
C
C 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
C
C 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
C
C 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
C
C 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
C
C 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
C
C 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
C
C 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
C
C 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
C
C FINALLY, THE CRUCIAL STEP OF SYMMETRICALLY ORTHOGONALIZING THE VECTORS
C SO THAT THE TRANSFORMATION IS UNITARY:
CALL SYMORT(OVLP,TSYM,BLK,NROT,NROT,EVAL)
RETURN
C
END
C*****************************************************************************
SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C******************************************************************
C
C SYMORT: SYMMETRIC ORTHOGONALIZATION SUBROUTINE
C
C S: FULL OVERLAP MATRIX (DESTROYED!)
C T: VECTORS TO BE ORTHOGED.
C N: NUMBER OF VECTORS
C
C NOTE: BLK AND BIGBLK SHARE THE SAME STORAGE BUT ARE
C DIMENSIONED DIFFERENTLY.
C THE SAME APPLIES FOR S AND SBLK.
C
C******************************************************************
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/
C
C IMPORTANT CONSTANTS:
C DIAGTH THRESHOLD FOR MATRIX DIAGONALIZATION USED IN
C SUBROUTINE JACOBI. IN JACOBI, THIS CONSTANT
C IS CALLED "DONETH".
C DANGER CRITERION FOR DECIDING THAT THE JOB SHOULD BE
C ABORTED DUE TO NUMERICAL PROBLEMS CAUSED BY NEAR
C LINEAR DEPENDENCIES IN THE BASIS SET. ALL
C EIGENVALUES OF THE WEIGHTED OVERLAP MATRIX MUST
C BE GREATER THAN DIAGTH*DANGER.
C
DATA DIAGTH,DANGER/1.0D-12,1.0D3/
C
C 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
C
C S NOW CONTAINS THE -0.5 POWER OF THE OVERLAP MATRIX,
C AND IS THE ORTHOG. TRANSFORM THAT WE WANT.
C 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
C
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
C*****************************************************************************
C
C NBO ENERGETIC ANALYSIS ROUTINES:
C
C SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE)
C SUBROUTINE NBODEL(A,MEMORY,IDONE)
C SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE,
C + ISPIN)
C SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN)
C SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK)
C SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL)
C
C*****************************************************************************
SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE)
C*****************************************************************************
C
C NBOEAN: CONTROLLER SUBROUTINE TO DO NBO ENERGETIC ANALYSIS
C BY FOCK MATRIX DELETION METHOD
C
C A(MEMORY) IS SCRATCH STORAGE
C
C NBOOPT(1) = 2 READ IN NEXT DELETION AND FORM NEW DM
C = 3 COMPUTE ENERGY CHANGE FOR THIS DELETION
C
C SET IDONE TO 1 IF NO DELETIONS ARE FOUND:
C
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR,NEW,SEQ
C
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
C
DIMENSION A(MEMORY),NBOOPT(10)
C
DATA THRNEG/-1.0D-3/
DATA ONE,AUKCAL,EVKCAL/1.0D0,627.51,23.061/
C
C OPEN THE OLD NBO DAF:
C
NEW = .FALSE.
CALL NBOPEN(NEW,ERROR)
IF(ERROR) THEN
IDONE = 1
RETURN
END IF
CALL FEINFO(A,ISWEAN)
C
C IF NBOOPT(1) = 3, COMPUTE THE ENERGY OF DELETION:
C
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
C
C PERFORM THE NBO ENERGETIC ANALYSIS:
C
C IF ISWEAN IS SET TO 1, SEARCH FOR THE $DEL KEYLIST:
C
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
C
C ROHF, MCSCF, CI, AND AUHF WAVE FUNCTIONS ARE NOT ACCEPTABLE:
C
IF(ROHF.OR.MCSCF.OR.CI.OR.AUHF) THEN
IDONE = 1
GOTO 900
END IF
C
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
C
IF(UHF) THEN
ISPIN = -2
ALPHA = .FALSE.
BETA = .TRUE.
CALL NBODEL(A,MEMORY,IDONE)
END IF
C
WRITE(LFNPR,3000)
SEQ = .FALSE.
CALL NBCLOS(SEQ)
RETURN
C
900 CONTINUE
SEQ = .FALSE.
CALL NBCLOS(SEQ)
RETURN
C
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
C*****************************************************************************
SUBROUTINE NBODEL(A,MEMORY,IDONE)
C*****************************************************************************
C
C NBODEL: SUBROUTINE TO DELETE BOND ORBITAL FOCK MATRIX ELEMENTS FOR
C A PARTICULAR SPIN CASE:
C ISPIN = 0 CLOSED SHELL
C 2 ALPHA SPIN
C -2 BETA SPIN
C
C IDONE IS SET EQUAL TO 1 IF THERE ARE NO MORE DELETIONS,
C 0 OTHERWISE.
C
C A(MEMORY) IS SCRATCH STORAGE
C
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL DONE
DIMENSION A(MEMORY),ICH(3,2),INAM(3),ISP(3)
C
C NBO Common Blocks:
C
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-/
C
C FNBO : NBO FOCK MATRIX (TRIANGULAR)
C TRF : TRUNCATED FOCK MATRIX (SQUARE)
C EIGVR : EIGENVECTORS OF FTRUNC
C DMNEW : NEW AO DM (FROM TRUNCATION) -- TRIANGULAR
C OCC : OCCUPATION VECTOR OF BOND ORBITALS
C OCCNEW: OCCUPATION VECTOR OF BOND ORBITALS, AFTER DELETION
C TNBO : AO TO NBO TRANSFORMATION MATRIX
C SCR : SCRATCH VECTOR
C
C SET UP STORAGE SPACE:
C
C A(N1): OCC
C A(N2): OCCNEW
C A(N3): TNBO
C A(N4): FNBO, EIGVR
C A(N5): SCR, TRF, DMNEW
C A(N6): SCR
C A(N7): IDEL
C
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))
C
C DELETE REQUESTED FOCK MATRIX ELEMENTS, FORMING TRUNCATED FOCK MATRIX
C IN TRF
C
C IDEL : LIST OF DELETED ORBITALS, ELEMENTS, OR BLOCKS
C ITYPE : TYPE OF DELETION: 1 FOR ORBITALS
C 2 FOR INDIVIDUAL MATRIX ELEMENTS
C 3 FOR ZEROING INTERSECTION BETWEEN TWO SETS
C OF ORBITALS
C 4 FOR ENTIRE MATRIX BLOCKS
C NDEL : NUMBER OF ORBITALS, ELEMENTS OR BLOCKS TO BE DELETED
C
CALL DELETE(A(N4),A(N5),NDIM,A(N7),NSQ,ITYPE,NDEL,NTRUNC,DONE,
+ ISPIN)
C
C IF NO MORE DELETIONS, EXIT PROGRAM
C
IF(DONE) GO TO 900
C DIAGONALIZE TRUNCATED FOCK MATRIX IN TRF
C
CALL JACOBI(NTRUNC,A(N5),A(N2),A(N4),NDIM,NDIM,0)
C
C CONSTRUCT NEW DENSITY MATRIX IN DM FROM EIGENVECTORS OF TRF,
C IN NBO BASIS:
C A(N2): EIGENVALUES OF TRF (ENTERING)
C A(N2): NEW NBO ORBITAL OCCUPANCIES (EXITING)
C
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)
C
C TAKE TRANSPOSE OF T SO THAT IT CAN TRANSFORM THE DENSITY MATRIX
C FROM THE NBO BASIS TO THE UNSYMMETRIZED AO BASIS:
C
CALL TRANSP(A(N3),NDIM,NDIM)
CALL SIMLTR(NDIM,NDIM,A(N5),A(N3),A(N4),A(N6),1)
CALL SVNEWD(A(N5))
C
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
C
900 CONTINUE
IDONE=1
RETURN
C
950 CONTINUE
WRITE(LFNPR,9500) NEND,MEMORY
IDONE=1
RETURN
C
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
C*****************************************************************************
SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE,
+ ISPIN)
C*****************************************************************************
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'/
C
C THIS SUBROUTINE IS CALLED AT THE START OF EACH DELETION AND READS
C IN FROM LFNIN THE INSTRUCTIONS FOR THIS DELETION
C
C NTRUNC= DIMENSION OF FOCK MATRIX AFTER DELETIONS:
NTRUNC=NDIM
WRITE(LFNPR,8700)
C 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
C 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)
C SEARCH FOR FIRST 3 LETTERS OF "DELETE", "ZERO", "SAME", "DESTAR",
C "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
C IF BETA DELETIONS ARE THE SAME AS THE ALPHA DELETIONS ALREADY READ IN,
C 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
C READ IN NUMBER OF ITEMS TO DELETE, NDEL:
CALL IFLD(NDEL,ERROR)
IF(ERROR) GO TO 9100
C READ IN TYPE OF DELETION AND DETERMINE IF IT IS ORBITAL, ELEMENT, OR BLOCK:
C (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
C NREAD=NUMBER OF NUMBERS THAT MUST BE READ
NREAD=NDEL*ITYPE
C READ IN ORBITALS,ELEMENTS, OR BLOCKS:
DO 90 I=1,NREAD
CALL IFLD(IDEL(I),ERROR)
IF(ERROR) GO TO 9500
90 CONTINUE
C
100 CONTINUE
IF(ITYPE.NE.1) GO TO 200
C DELETE NDEL ORBITALS, ADJUSTING NTRUNC ACCORDINGLY:
NTRUNC=NDIM-NDEL
C ORDER THE ORBITAL NUMBERS:
CALL ORDER(ISCR1,IDEL,NDEL,NDIM,ISCR2)
WRITE(LFNPR,8610) (IDEL(I),I=1,NDEL)
C 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
C 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
C 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
C 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
C 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
C DELETE INTERSECTION IN FOCK MATRIX BETWEEN PAIRS OF SETS OF ORBITALS:
600 ITYPE=3
C 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
C READ IN NUMBER OF PAIRS OF SETS OF ORBITALS, NDEL:
CALL IFLD(NDEL,ERROR)
IF(ERROR) GO TO 9500
LENG=5
C CHECK THE NEXT WORD TO SEE IF IT IS "DELOCALIZATION" INSTEAD OF "BLOCK":
C (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
C CHECK THE WORD TO SEE IF IT IS "ATOM" INSTEAD OF "BLOCK":
C (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
C READ IN THE NUMBER OF ORBITALS IN EACH SET OF THE PAIR, NSET1 AND NSET2:
C (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
C 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
C 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
C
C ZEROING OF DELOCALIZATION WITHIN OR BETWEEN MOLECULAR UNITS.
C
C USE THE NBO MOLECULAR UNIT (NBOUNI) AND NBO TYPE (NBOTYP) LISTS.
1000 CONTINUE
NSTART=0
DO 1100 K=1,NDEL
C SKIP THE NEXT WORD ("FROM"):
CALL HFLD(KEYWD,LENG,DONE)
C READ IN THE NUMBER OF THE FIRST MOLECULAR UNIT, IUNIT1:
CALL IFLD(IUNIT1,ERROR)
IF(ERROR) GO TO 9500
C 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
C 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
C 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
C 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
C
C ZEROING OF DELOCALIZATION BETWEEN GROUPS OF ATOMS
C
C USE THE NBO TYPE (NBOTYP) AND NBO LABEL (LABEL) LISTS.
1200 CONTINUE
MSTART=0
NSTART=0
C SKIP THE 'BLOCKS' BEFORE NSET1:
CALL HFLD(KEYWD,LENG,DONE)
DO 1400 K=1,NDEL
C READ IN THE NUMBER OF ATOMS IN EACH SET OF THE PAIR, NSET1 AND NSET2:
C (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
C 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)
C CONSTRUCT THE LIST OF THE TWO SETS OF ORBITALS FROM THE ATOM LISTS,
C 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.
C 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
C LIST1.AND.DONOR=.TRUE. CASE:
NSET1=NSET1+1
IDEL(NSTART+NSET1)=JBAS
GO TO 1300
C LIST2.AND.ACCPTR=.TRUE. CASE:
1290 CONTINUE
NSET2=NSET2+1
ISCR2(NSET2)=JBAS
1300 CONTINUE
C
IDEL(NSTART-1)=NSET1
IDEL(NSTART)=NSET2
NTOT=NSET1+NSET2
C PLACE ORBITAL SET 2 IN IDEL:
NSTRT2=NSTART+NSET1
DO 1320 I=1,NSET2
1320 IDEL(NSTRT2+I)=ISCR2(I)
C 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
C
C DELETE ALL VICINAL OR GEMINAL DELOCALIZATIONS:
C
3000 IVIC=1
WRITE(LFNPR,8550)
GOTO 3020
3010 IVIC=0
WRITE(LFNPR,8560)
3020 CONTINUE
ITYPE=3
C
C START BY FILLING TRF WITH FULL NBO FOCK MATRIX:
C
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
C
C FIND THE TOTAL NUMBER OF BLOCKS OF THE FOCK MATRIX TO DELETE:
C
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)
C
C VICINAL DELOCALIZATION:
C
IF(IVIC.EQ.1.AND.ITMP.EQ.LV) THEN
NACC=NACC+1
IDEL(NSTART+NACC+3)=JBAS
C
C GEMINAL DELOCALIZATION:
C
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
C
C 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
C DELETE ALL THE "STAR" NBOS ON ONE OR MORE MOLECULES:
C (SET ITYPE=1 FOR ORBITAL DELETIONS)
5000 CONTINUE
ITYPE=1
C READ IN THE NUMBER OF MOLECULAR UNITS TO "DESTAR":
CALL IFLD(NUNITS,ERROR)
IF(ERROR) GO TO 9500
C SKIP THE KEYWORD "UNITS":
LENG=3
CALL HFLD(KEYWD,LENG,DONE)
C READ IN THE NUMBERS OF THE UNITS TO DESTAR, FINDING THE STAR ORBITALS
C 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
C GO AND DO THE DELETIONS OF THE NDEL ORBITALS THAT ARE NOW IN IDEL:
GO TO 100
C
C 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
C GO AND DO THE DELETIONS OF THE NDEL ORBITALS THAT ARE NOW IN IDEL:
GO TO 100
C
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(/)
C
C 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
C*****************************************************************************
SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN)
C*****************************************************************************
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/
C ONETWO: ONE IF OPEN SHELL (ISPIN.NE.0), TWO IF CLOSED SHELL (DOUBLY OCC MOS)
ONETWO=TWO
IF(ISPIN.NE.0) ONETWO=ONE
C NTRUNC: DIMENSION OF TRUNCATED FOCK MATRIX
NTRUNC=NDIM
IF(ITYPE.EQ.1) NTRUNC=NDIM-NDEL
C RANK THE EIGENVALUES 'EIG' FROM THE TRUNCATED FOCK MATRIX FROM LOWEST
C TO HIGHEST IN 'NRANK':
CALL RNKEIG(NRANK,EIG,NTRUNC,NDIM,LOCC)
C PUT IN 'LOCC' THE LOCATIONS OF THE 'NMOOCC' LOWEST EIGENVALUES:
C (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
C NDELOR: NUMBER OF DELETED ORBITALS
NDELOR=NDIM-NTRUNC
C
C CONSTRUCT THE NEW NBO DENSITY MATRIX:
C
C 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
C ZERO ROWS OF THE NEW NBO DENSITY MATRIX THAT WERE ZEROED
C 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
C 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
C ZERO COLUMNS OF THE NEW NBO DENSITY MATRIX THAT WERE ZEROED
C IN THE TRUNCATION OF THE NBO FOCK MATRIX:
JOUT=JOUT+1
IJ=IJ+1
DM(IJ)=ZERO
GO TO 100
50 CONTINUE
C FIND DM(IJ) FROM THE EIGENVECTORS OF THE TRUNCATED NBO FOCK MATRIX IN 'U',
C 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
C*****************************************************************************
SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C RANK EIGENVALUES IN 'EIG', LOWEST VALUES FIRST, IN 'RANK':
C
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
C*****************************************************************************
SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION F(1),U(NDIM,1),S(1),R(1)
C TAKE U(TRANSPOSE)*F*U:
C F MATRIX TO BE TRANSFORMED (PACKED UPPER TRIANGULAR)
C U IS THE TRANSFORMATION MATRIX
C R IS THE MATRIX IN WHICH THE RESULT WILL BE RETURNED
C S IS A SCRATCH MATRIX OF DIMENSION N
C KNTROL....=0 RESULT RETURNED ONLY IN R
C =1 RESULT COPIED INTO F
C
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
C*****************************************************************************
C
C NBO DIRECT ACCESS FILE (DAF) ROUTINES:
C
C SUBROUTINE NBFILE(NEW,ERROR)
C SUBROUTINE NBOPEN(NEW,ERROR)
C SUBROUTINE NBWRIT(IX,NX,IDAR)
C SUBROUTINE NBREAD(IX,NX,IDAR)
C SUBROUTINE NBCLOS(SEQ)
C SUBROUTINE NBINQR(IDAR)
C
C SUBROUTINE FETITL(TITLE)
C SUBROUTINE FEE0(EDEL,ETOT)
C SUBROUTINE SVE0(EDEL)
C SUBROUTINE FECOOR(ATCOOR)
C SUBROUTINE FESRAW(S)
C SUBROUTINE FEDRAW(DM,SCR)
C SUBROUTINE FEFAO(F,IWFOCK)
C SUBROUTINE FEAOMO(T,IT)
C SUBROUTINE FEDXYZ(DXYZ,I)
C SUBROUTINE SVNBO(T,OCC,ISCR)
C SUBROUTINE FENBO(T,OCC,ISCR,NELEC)
C SUBROUTINE FETNBO(T)
C SUBROUTINE SVPNAO(T)
C SUBROUTINE FEPNAO(T)
C SUBROUTINE SVSNAO(S)
C SUBROUTINE FESNAO(S)
C SUBROUTINE SVTNAB(T)
C SUBROUTINE FETNAB(T)
C SUBROUTINE SVTLMO(T)
C SUBROUTINE FETLMO(T)
C SUBROUTINE SVTNHO(T)
C SUBROUTINE FETNHO(T)
C SUBROUTINE SVPPAO(DM)
C SUBROUTINE FEPPAO(DM)
C SUBROUTINE SVTNAO(T)
C SUBROUTINE FETNAO(T)
C SUBROUTINE SVNLMO(T)
C SUBROUTINE FENLMO(T)
C SUBROUTINE SVDNAO(DM)
C SUBROUTINE FEDNAO(DM)
C SUBROUTINE SVFNBO(F)
C SUBROUTINE FEFNBO(F)
C SUBROUTINE SVNEWD(DM)
C SUBROUTINE FENEWD(DM)
C SUBROUTINE FEINFO(ICORE,ISWEAN)
C SUBROUTINE FEBAS(NSHELL,NEXP,ISCR)
C
C*****************************************************************************
SUBROUTINE NBFILE(NEW,ERROR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL NEW,ERROR,NEED,THERE
CHARACTER*80 TEMP
C
PARAMETER (MAXFIL = 40)
C
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
C
DATA IWRIT,IREAD/4HWRIT,4HREAD/
C
C Create a list IFILE of external LFNs. First find the files that
C will be written:
C
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
C
C Add files that may be read:
C
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
C
C Make sure that no files are both written and read:
C
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
C
C Also check that the NBO DAF has its own LFN:
C
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
C
C Select an alternate filename if this one is not acceptable:
C
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) = '.'
C
C First check the DAF:
C
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
C
C Now check the rest:
C
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
C
C This is a good one!! If the filename has changed, write a warning:
C
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
C
C Open external files:
C
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
C
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
C*****************************************************************************
SUBROUTINE NBOPEN(NEW,ERROR)
C*****************************************************************************
C
C The following records of the NBO direct access file (DAF) are used:
C
C 1 --- NBODAF common block
C 2 --- Job title
C 3 --- NATOMS,NDIM,NBAS,MUNIT,wavefunction flags,ISWEAN
C 4 --- IATNO,IZNUC,LCTR,LANG
C 5 --- AO basis set information
C 8 --- Deletion energy, total energy
C 9 --- Atomic coordinates
C 10 --- AO overlap matrix
C 11 --- PNAO overlap matrix
C 20 --- AO density matrix (alpha)
C 21 --- AO density matrix (beta)
C 22 --- Pure AO density matrix
C 23 --- NAO density matrix (alpha)
C 24 --- NAO density matrix (beta)
C 25 --- AO density matrix with NBO deletions (alpha)
C 26 --- AO density matrix with NBO deletions (beta)
C 27 --- NBO occupancies (alpha)
C 28 --- NBO occupancies (beta)
C 30 --- AO Fock matrix (alpha)
C 31 --- AO Fock matrix (beta)
C 32 --- NAO Fock matrix (alpha)
C 33 --- NAO Fock matrix (beta)
C 34 --- NBO Fock matrix (alpha)
C 35 --- NBO Fock matrix (beta)
C 40 --- AO to MO transformation matrix (alpha)
C 41 --- AO to MO transformation matrix (beta)
C 42 --- AO to PNAO transformation matrix
C 43 --- AO to NAO transformation matrix
C 44 --- AO to NBO transformation matrix (alpha)
C 45 --- AO to NBO transformation matrix (beta)
C 46 --- AO to NLMO transformation matrix
C 47 --- NAO to NHO transformation matrix
C 48 --- NAO to NBO transformation matrix
C 49 --- NBO to NLMO transformation matrix
C 50 --- X dipole integrals
C 51 --- Y dipole integrals
C 52 --- Z dipole integrals
C 60 --- NBO labels (alpha)
C 61 --- NBO labels (beta)
C-----------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL NEW,ERROR
CHARACTER*80 TEMP
C
C Note that ISINGL is no longer a parameter (6/7/90):
C
PARAMETER (LENGTH = 256)
PARAMETER (NBDAR = 100)
PARAMETER (MAXFIL = 40)
C
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
C
DIMENSION IX(NBDAR+2),IXSNBO(LENGTH/2)
C
EQUIVALENCE (IXSNBO(1),IXDNBO(1))
EQUIVALENCE (IX(1),INBO)
C
SAVE ISW,LENREC
C
DATA IBLNK/1H /
DATA ISW/0/
C
C INBO : Fortran file number
C IONBO : Indexing array mapping the logical records of the
C NBO DAF onto the physical records of the disk file
C NAV : Number of physical records currently on the DAF
C NBDAR : Maximum number of logical records on the DAF
C
INBO = ABS(LFNDAF)
C
C Are we working on a 32 (ISINGL=2) or 64 (ISINGL=1) bit machine?
C
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
C
C Determine an appropriate record length for the NBO DAF:
C
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
C
C If I.EQ.1 at this point, ERR did not work properly in the preceding
C statement (this appears to be the case for the XL FORTRAN compiler
C running on an IBM RISC station/6000):
C
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
C
C Problems...
C
40 CONTINUE
WRITE(LFNPR,900)
ERROR = .TRUE.
RETURN
C
50 CONTINUE
ISW = 1
END IF
C
C Open the NBO direct access file (DAF) -- typically assigned to LFN48:
C
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
C
C If this is a new NBO DAF, write COMMON/NBODAF/ on the first record:
C
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)
C
C Otherwise, open the old file and read in COMMON/NBODAF/ from the
C first record:
C
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
C
C Error encountered while opening this file:
C
110 ERROR = .TRUE.
RETURN
C
900 FORMAT(/1X,'Routine NBOPEN could not determine an appropriate ',
+ 'record length.')
END
C*****************************************************************************
SUBROUTINE NBWRIT(IX,NX,IDAR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
PARAMETER (LENGTH = 256)
PARAMETER (NBDAR = 100)
C
COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
C
DIMENSION IX(1),IXSNBO(LENGTH/2)
C
EQUIVALENCE (IXSNBO(1),IXDNBO(1))
C
MAXIX = LENGTH * ISINGL / 2
LDAR = NX * ISINGL
IF(IONBO(IDAR).NE.0) GO TO 100
C
C If this is the first write to the NBO DAF:
C
IONBO(IDAR) = NAV
NBNAV = NAV
C
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
C
C Or if this is a rewrite:
C
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
C*****************************************************************************
SUBROUTINE NBREAD(IX,NX,IDAR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
PARAMETER (LENGTH = 256)
PARAMETER (NBDAR = 100)
C
COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
C
DIMENSION IX(1),IXSNBO(LENGTH/2)
C
EQUIVALENCE (IXSNBO(1),IXDNBO(1))
C
NBNAV = IONBO(IDAR)
MAXIX = LENGTH * ISINGL / 2
LDAR = NX * ISINGL
C
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
C*****************************************************************************
SUBROUTINE NBCLOS(SEQ)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL SEQ
C
PARAMETER (LENGTH = 256)
PARAMETER (NBDAR = 100)
PARAMETER (MAXFIL = 40)
C
COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
CHARACTER*80 FILENM
C
DIMENSION IX(NBDAR+2)
EQUIVALENCE (IX(1),INBO)
C
C First close the NBO direct access file, remembering to write
C COMMON/NBODAF/ to the first logical record:
C
NF = 1
NX = (NBDAR + 2) / ISINGL
CALL NBWRIT(IX,NX,NF)
CLOSE(UNIT=INBO, STATUS='KEEP')
C
C Then close the remainder of the files used by the NBO program:
C
DO 10 I = 1,NFILE
CLOSE(UNIT=ABS(IFILE(I)), STATUS='KEEP')
10 CONTINUE
RETURN
END
C*****************************************************************************
SUBROUTINE NBINQR(IDAR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
IF(IDAR.LT.1.OR.IDAR.GT.NBDAR) THEN
WRITE(LFNPR,900) IDAR,NBDAR
STOP
END IF
C
IF(IONBO(IDAR).EQ.0) IDAR = 0
RETURN
C
900 FORMAT(/1X,'NBO DAF record out of range: IDAR = ',I4,
+ ' NBDAR = ',I4)
END
C*****************************************************************************
SUBROUTINE FETITL(TITLE)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION TITLE(10)
C
C FETITL: FETCHES THE JOB TITLE FROM THE NBODAF:
C
NFILE = 2
CALL NBREAD(TITLE,10,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE FEE0(EDEL,ETOT)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION X(2)
C
C FEE0: FETCHES THE DELETION AND TOTAL SCF ENERGY
C
NFILE = 8
CALL NBREAD(X,2,NFILE)
EDEL = X(1)
ETOT = X(2)
RETURN
END
C*****************************************************************************
SUBROUTINE SVE0(EDEL)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION X(2)
C
C SVE0: SAVES THE DELETION ENERGY
C
NFILE = 8
CALL NBREAD(X,2,NFILE)
X(1) = EDEL
CALL NBWRIT(X,2,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE FECOOR(ATCOOR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION ATCOOR(3*NATOMS)
C
C FECOOR: FETCH THE ATOMIC CARTESIAN COORDINATES IN ANGSTROMS.
C
NFILE = 9
CALL NBREAD(ATCOOR,3*NATOMS,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE FEBAS(NSHELL,NEXP,ISCR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION ISCR(1)
C
C FEBAS: FETCHES THE BASIS SET INFO
C
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
C*****************************************************************************
SUBROUTINE FESRAW(S)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
DIMENSION S(NDIM,NDIM)
C
C FESRAW: FETCHES THE OVERLAP MATRIX (RAW AO. BASIS)
C INTO S(NDIM,NDIM) A FULL SQUARE MATRIX.
C
NFILE = 10
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(S,L2,NFILE)
CALL UNPACK(S,NDIM,NBAS,L2)
RETURN
END
C*****************************************************************************
SUBROUTINE FEDRAW(DM,SCR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION DM(1),SCR(1)
C
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
C
DATA NFILEA,NFILEB/20,21/
C
C FEDRAW: FETCHES THE DENSITY MATRIX (RAW A.O. BASIS) IN DM(NDIM,NDIM)
C IF ALPHA =.TRUE. FETCH ALPHA MATRIX
C IF BETA =.TRUE FETCH BETA MATRIX.
C IF OPEN .AND. .NOT.(ALPHA .OR. BETA) =.TRUE FETCH THE TOTAL D.M.
C
L2 = NDIM*(NDIM+1)/2
NFILE = NFILEA
IF(BETA) NFILE = NFILEB
CALL NBREAD(DM,L2,NFILE)
C
IF(.NOT.OPEN) GOTO 300
IF(ALPHA.OR.BETA) GOTO 300
CALL NBREAD(SCR,L2,NFILEB)
C
C FORM THE TOTAL DENSITY MATRIX:
C
DO 100 I = 1,L2
DM(I) = DM(I) + SCR(I)
100 CONTINUE
C
300 CALL UNPACK(DM,NDIM,NBAS,L2)
RETURN
END
C*****************************************************************************
SUBROUTINE FEFAO(F,IWFOCK)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION F(1)
C
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
C
DATA NFILEA,NFILEB/30,31/
C
C FEFAO: FETCHES THE AO FOCK MATRIX
C IF ALPHA .EQ. .TRUE. WE WANT THE ALPHA FOCK MATRIX
C IF BETA .EQ. .TRUE. WE WANT THE BETA FOCK MATRIX.
C IF THE REQUESTED MATRIX DOES NOT EXIST THEN IWFOCK = 0
C
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
C*****************************************************************************
SUBROUTINE FEAOMO(T,IT)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
C
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
C
DATA NFILEA,NFILEB/40,41/
C
C FEAOMO: FETCH THE AO TO MO TRANSFORMATION MATRIX:
C (IT = 1, AO TO MO TRANSFORM IS ON NBO DAF)
C (IT = 0, AO TO MO TRANSFORM IS NOT ON NBO DAF)
C
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
C*****************************************************************************
SUBROUTINE FEDXYZ(DXYZ,I)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION DXYZ(1)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
DATA NFILEX,NFILEY,NFILEZ/50,51,52/
C
C FEDXYZ: FETCH THE AO DIPOLE MOMENT MATRICES (IN ANGSTROMS)
C I=1: X I=2: Y I=3: Z
C
IF(I.EQ.1) NFILE = NFILEX
IF(I.EQ.2) NFILE = NFILEY
IF(I.EQ.3) NFILE = NFILEZ
C
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
C*****************************************************************************
SUBROUTINE SVNBO(T,OCC,ISCR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
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)
C
DIMENSION T(NDIM,NDIM),OCC(NDIM),ISCR(1)
C
C SVNBO: SAVES NBO INFORMATION (TRANSFORMATION, OCCUPANCIES, LABELS, ETC.)
C IF ALPHA .EQ. .TRUE. SAVE THE ALPHA INFORMATION
C IF BETA .EQ. .TRUE. SAVE THE BETA INFORMATION.
C
C SAVE THE AO TO NBO TRANSFORMATION MATRIX:
C
L1 = NDIM
L3 = NDIM*NDIM
L4 = 10*NDIM
NFILE = 44
IF (BETA) NFILE = 45
CALL NBWRIT(T,L3,NFILE)
C
C SAVE NBO ORBITAL OCCUPANCIES:
C
NFILE = 27
IF (BETA) NFILE = 28
CALL NBWRIT(OCC,L1,NFILE)
C
C SAVE THE LISTS OF NBO INFORMATION FOR LATER USE IN THE DELETIONS.
C PACK THE INFORMATION INTO ISCR(10*NDIM):
C
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
C
NFILE = 60
IF (BETA) NFILE = 61
CALL NBWRIT(ISCR,L4,NFILE)
C
RETURN
END
C*****************************************************************************
SUBROUTINE FENBO(T,OCC,ISCR,NELEC)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
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)
C
DIMENSION T(NDIM,NDIM),OCC(NDIM),ISCR(1)
C
DATA ZERO,TENTH /0.0D0,1.0D-1/
C
C FENBO: FETCHES NBO INFORMATION (TRANSFORMATION, OCCUPANCIES, LABELS, ETC.)
C IF ALPHA .EQ. .TRUE. FETCH THE ALPHA INFORMATION
C IF BETA .EQ. .TRUE. FETCH THE BETA INFORMATION.
C
C FETCH THE AO TO NBO TRANSFORMATION MATRIX:
C
L1 = NDIM
L3 = NDIM*NDIM
L4 = NDIM*10
NFILE = 44
IF (BETA) NFILE = 45
CALL NBREAD(T,L3,NFILE)
C
C FETCH NBO ORBITAL OCCUPANCIES:
C
NFILE = 27
IF (BETA) NFILE = 28
CALL NBREAD(OCC,L1,NFILE)
C
C COUNT UP THE TOTAL NUMBER OF ELECTRONS AS AN INTEGER NELEC:
C
ELE = ZERO
DO 10 I = 1,NBAS
ELE = ELE + OCC(I)
10 CONTINUE
ELE = ELE + TENTH
NELEC = ELE
C
C FETCH THE VARIOUS LISTS OF NBO INFORMATION FOR USE IN THE DELETIONS.
C UNPACK THE INFORMATION INTO LABEL(MAXBAS,6),IBXM(MAXBAS),IATNO(MAXBAS),
C NBOUNI(MAXBAS) AND NBOTYP(MAXBAS) FROM ISCR(10*NDIM):
C
NFILE = 60
IF (BETA) NFILE = 61
CALL NBREAD(ISCR,L4,NFILE)
C
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
C
RETURN
END
C*****************************************************************************
SUBROUTINE FETNBO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
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
C
C FETNBO: FETCH THE AO TO NBO TRANSFORMATION MATRIX
C
L3 = NDIM*NDIM
NFILE = 44
IF (BETA) NFILE = 45
CALL NBREAD(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE SVPNAO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C SVPNAO: SAVES THE AO TO PNAO TRANSFORMATION MATRIX.
C
NFILE = 42
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE FEPNAO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C FEPNAO: FETCHES THE AO TO PNAO TRANSFORMATION MATRIX.
C
NFILE = 42
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE SVSNAO(S)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION S(NDIM,NDIM)
C
C SVSNAO: SAVE THE OVERLAP MATRIX IN THE PNAO OR RPNAO BASIS SET.
C
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
C*****************************************************************************
SUBROUTINE FESNAO(S)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
DIMENSION S(NDIM,NDIM)
C
C FESNAO: FETCH THE OVERLAP MATRIX IN THE PNAO OR RPNAO BASIS SET.
C
NFILE = 11
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(S,L2,NFILE)
CALL UNPACK(S,NDIM,NBAS,L2)
RETURN
END
C*****************************************************************************
SUBROUTINE SVTNAB(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
C
C SVTNAB: SAVE THE NAO TO NBO TRANSFORMATION MATRIX.
C
NFILE = 48
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE FETNAB(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
C
C FETNAB: FETCH THE NAO TO NBO TRANSFORMATION MATRIX
C
NFILE = 48
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE SVTLMO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
C
C SVTLMO: SAVE THE NBO TO NLMO TRANSFORMATION MATRIX.
C
NFILE = 49
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE FETLMO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
C
C FETLMO: FETCH THE NBO TO NLMO TRANSFORMATION MATRIX
C
NFILE = 49
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE SVTNHO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
C
C SVTNHO: TEMPORARILY SAVE THE NAO TO NHO TRANSFORMATION
C
NFILE = 47
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE FETNHO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
C
C FETNHO: FETCH THE NAO TO NHO TRANSFORMATION
C
NFILE = 47
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE SVPPAO(DM)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION DM(NDIM,NDIM)
C
C SVPPAO: TEMPORARILY SAVES THE PURE AO (PAO) DENSITY MATRIX.
C (THIS IS NOT THE RAW AO BASIS, BUT THE BASIS AFTER THE
C TRANSFORMATION FROM CARTESIAN TO PURE D,F,G FUNCTIONS).
C
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
C*****************************************************************************
SUBROUTINE FEPPAO(DM)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION DM(NDIM,NDIM)
C
C FEPPAO: FETCHES THE PURE AO (PAO) DENSITY MATRIX.
C (THIS IS NOT THE RAW AO BASIS, BUT THE BASIS AFTER THE
C TRANSFORMATION FROM CARTESIAN TO PURE D,F,G FUNCTIONS).
C
NFILE = 22
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(DM,L2,NFILE)
CALL UNPACK(DM,NDIM,NBAS,L2)
RETURN
END
C*****************************************************************************
SUBROUTINE SVTNAO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
C SVTNAO: SAVE THE AO TO NAO TRANSFORMATION MATRIX.
C
IF(.NOT.ORTHO) THEN
NFILE = 43
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
END IF
RETURN
END
C*****************************************************************************
SUBROUTINE FETNAO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
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)
C
DATA ZERO,ONE/0.0D0,1.0D0/
C
C FETNAO: FETCHES THE AO TO NAO TRANSFORMATION MATRIX.
C
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
C*****************************************************************************
SUBROUTINE SVNLMO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
C
C SVNLMO: SAVE THE AO TO NLMO TRANSFORMATION MATRIX
C
NFILE = 46
L3 = NDIM*NDIM
CALL NBWRIT(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE FENLMO(T)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
DIMENSION T(NDIM,NDIM)
C
C FENLMO: FETCH THE AO TO NLMO TRANSFORMATION MATRIX
C
NFILE = 46
L3 = NDIM*NDIM
CALL NBREAD(T,L3,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE SVDNAO(DM)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
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)
C
C SVDNAO: SAVE THE NAO DENSITY MATRIX
C
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
C*****************************************************************************
SUBROUTINE FEDNAO(DM)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
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)
C
C FEDNAO: FETCHES THE NAO DENSITY MATRIX (AO DM FOR ORTHOGONAL BASIS SETS)
C
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
C*****************************************************************************
SUBROUTINE SVFNBO(F)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
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)
C
C SVFNBO: SAVES THE NBO FOCK MATRIX
C
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
C*****************************************************************************
SUBROUTINE FEFNBO(F)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION F(1)
C
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C FEFNBO: FETCHES THE NBO FOCK MATRIX, LEAVING IT IN TRIANGULAR FORM!!
C IF ALPHA.EQ.TRUE. WE WANT THE ALPHA FOCK MATRIX
C IF BETA.EQ.TRUE. WE WANT THE BETA FOCK MATRIX.
C
NFILE = 34
IF (BETA) NFILE = 35
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(F,L2,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE SVNEWD(DM)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION DM(1)
C
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C SVNEWD: SAVE THE NEW DENSITY MATRIX (RAW AO BASIS) FROM NBO DELETION
C
NFILE = 25
IF (BETA) NFILE = 26
L2 = NDIM*(NDIM+1)/2
CALL NBWRIT(DM,L2,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE FENEWD(DM)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION DM(1)
C
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C FENEWD: FETCH THE NEW DENSITY MATRIX (RAW AO BASIS)
C
NFILE = 25
IF (BETA) NFILE = 26
L2 = NDIM*(NDIM+1)/2
CALL NBREAD(DM,L2,NFILE)
RETURN
END
C*****************************************************************************
SUBROUTINE FEINFO(ICORE,ISWEAN)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
DIMENSION ICORE(12)
C
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
C
C Restore wavefunction information from the NBO DAF:
C
C Restore NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:
C
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)
C
C IF ISWEAN IS 1, SET ICORE(12) TO 0 AND WRITE TO NBO DAF. NOTE, ISWEAN IS
C SET TO 1 BY THE FEAOIN DRIVER ROUTINE. THIS TELLS THE ENERGETIC ANALYSIS
C ROUTINES TO SEARCH FOR THE $DEL KEYLIST. ISWEAN IS RESET TO 0 HERE SO
C THAT MULTIPLE DELETIONS CAN BE READ FROM A SINGLE $DEL KEYLIST:
C
IF(ISWEAN.EQ.1) THEN
ICORE(12) = 0
CALL NBWRIT(ICORE,12,NFILE)
END IF
RETURN
END
C*****************************************************************************
C
C FREE FORMAT INPUT ROUTINES:
C
C SUBROUTINE STRTIN(LFNIN)
C SUBROUTINE RDCRD
C SUBROUTINE IFLD(INT,ERROR)
C SUBROUTINE RFLD(REAL,ERROR)
C SUBROUTINE HFLD(KEYWD,LENG,ENDD)
C SUBROUTINE FNDFLD
C FUNCTION EQUAL(IA,IB,L)
C
C*****************************************************************************
C
C USER INSTRUCTIONS:
C
C 1. THE CHARACTER STRING "END" IS THE FIELD TERMINATING MARK:
C
C 2. COMMAS AND EQUAL SIGNS ARE TREATED AS EQUIVALENT TO BLANKS.
C COMMAS, EQUAL SIGNS, AND BLANKS DELIMIT INPUT ITEMS.
C
C 3. ALL CHARACTERS TO THE RIGHT OF AN EXCLAMATION MARK ! ARE TREATED AS
C COMMENTS, AND THE NEXT CARD IS READ IN WHEN THESE ARE ENCOUNTERED.
C
C 4. UPPER AND LOWER CASE CHARACTERS CAN BE READ BY THESE ROUTINES.
C HOWEVER, LOWER CASE CHARACTERS ARE CONVERTED TO UPPER CASE
C WHEN ENCOUNTERED.
C
C 5. TO READ IN DATA FOR THE FIRST TIME FROM LFN "LFNIN" (PERHAPS
C AFTER USING THESE SUBROUTINES TO READ IN DATA FROM ANOTHER LFN),
C OR TO CONTINUE READING IN DATA FROM LFNIN AFTER ENCOUNTERING
C A FIELD TERMINATING MARK, CALL STRTIN(LFNIN) (START INPUT)
C
C 6. TO FETCH THE NEXT NON-BLANK STRING OF CHARACTERS FROM LFN LFNIN,
C CALL HFLD(KEYWD,LENGTH,END),
C WHERE KEYWD IS A VECTOR OF DIMENSION "LENGTH" OR LONGER,
C LENGTH IS THE MAXIMUM NUMBER OF CHARACTERS TO FETCH,
C END MUST BE A DECLARED LOGICAL VARIABLE.
C UPON RETURN,
C END=.TRUE. IF A FIELD TERMINATING MARK WAS FOUND TO BE THE NEXT
C NON-BLANK CHARACTER STRING. OTHERWISE, END=.FALSE.
C END=.TRUE. AND LENGTH=0 MEANS THE END-OF-FILE WAS FOUND.
C LENGTH IS CHANGED TO THE ACTUAL NUMBER OF CHARACTERS IN STRING
C IF THIS IS LESS THAN THE VALUE OF LENGTH SET BY THE CALLING
C PROGRAM.
C KEYWD(1) THROUGH KEYWD(LENGTH) CONTAIN THE CHARACTER STRING,
C ONE CHARACTER PER ELEMENT OF KEYWD.
C
C 7. TO FETCH THE INTEGER VALUE OF THE NEXT CHARACTER STRING,
C CALL IFLD(INT,ERROR),
C WHERE INT IS THE VARIABLE TO BE READ,
C ERROR MUST BE A DECLARED LOGICAL VARIABLE.
C UPON RETURN,
C IF ERROR=.FALSE., AN INTEGER WAS FOUND AND PLACED IN "INT".
C IF ERROR=.TRUE. AND INT.GT.0, A FIELD TERMINATING MARK WAS
C FOUND AS THE NEXT CHARACTER STRING.
C IF ERROR=.TRUE. AND INT.LT.0, THE NEXT CHARACTER STRING FOUND
C WAS NEITHER AN INTEGER NOR A FIELD TERMINATING MARK.
C
C 8. TO FETCH THE REAL VALUE OF THE NEXT CHARACTER STRING,
C (AN EXPONENT IS ALLOWED, WITH OR WITHOUT AN "E" OR "F".
C IF NO LETTER IS PRESENT TO SIGNIFY THE EXPONENT FIELD,
C A + OR - SIGN MUST START THE EXPONENT. IF NO MANTISSA IS
C PRESENT, THE EXPONENT FIELD MUST START WITH A LETTER, AND
C THE MANTISSA IS SET TO ONE.)
C CALL RFLD(REAL,ERROR),
C WHERE REAL IS THE VARIABLE TO BE READ,
C ERROR MUST BE A DECLARED LOGICAL VARIABLE.
C UPON RETURN,
C IF ERROR=.FALSE., A REAL NUMBER WAS FOUND AND PLACED IN "REAL".
C IF ERROR=.TRUE. AND REAL.GT.1, A FIELD TERMINATING MARK WAS
C FOUND AS THE NEXT CHARACTER STRING.
C IF ERROR=.TRUE. AND REAL.LT.-1, THE NEXT CHARACTER STRING FOUND
C WAS NEITHER A REAL NUMBER NOR A FIELD TERMINATING MARK.
C
C 9. TO COMPARE THE CORRESPONDING FIRST L ELEMENTS OF EACH OF TWO VECTORS
C IA(L) AND IB(L) TO SEE IF THE VECTORS ARE EQUIVALENT,
C USE THE FUNCTION EQUAL(IA,IB,L).
C EQUAL MUST BE DECLARED LOGICAL IN THE CALLING PROGRAM,
C AND THE FUNCTION VALUE (.TRUE. OR .FALSE.) WILL TELL IF THE
C VECTORS IA AND IB ARE EQUAL UP TO ELEMENT L.
C NOTE: THIS FUNCTION IS USEFUL FOR DETERMINING IF A CHARACTER STRING
C READ BY A CALL TO HFLD MATCHES A CERTAIN KEYWORD WHICH IS STORED
C IN A VECTOR, ONE CHARACTER PER ELEMENT.
C
C
C*****************************************************************************
SUBROUTINE STRTIN(LFNIN)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
C
C INITIALIZE INPUT FROM LFN LFNIN:
C
LFN = LFNIN
END = .FALSE.
NEXT = .TRUE.
CALL RDCRD
C
RETURN
END
C*****************************************************************************
SUBROUTINE RDCRD
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C SUBROUTINE NAME CHANGED FROM RDCARD, DUE TO CONFLICT WITH GAMESS:
C
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
C
DATA IA,ICHARA,ICHARZ/1HA,1Ha,1Hz/
DATA IBLNK,IQ,II/1H ,1H`,1HI/
C
C READ IN THE NEXT CARD AT LFN:
C
READ(LFN,1000,END=800,ERR=800) ICD
C
C CHANGE ALL LOWER CASE CHARACTERS TO UPPER CASE:
C
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
C
C TREAT TABS AS SPACES:
C
ITAB = IBLNK + II - IQ
DO 20 I = 1,80
IF(ICD(I).EQ.ITAB) ICD(I) = IBLNK
20 CONTINUE
C
C RESET COLUMN POINTER, IPT:
C
IPT = 1
RETURN
C
C END OF FILE ENCOUNTERED
C
800 CONTINUE
END = .TRUE.
RETURN
C
1000 FORMAT(80A1)
END
C*****************************************************************************
SUBROUTINE IFLD(INT,ERROR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR
C
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
C
DATA ZERO,ONE,SMALL/0.0D0,1.0D0,1.0D-3/
C
C SEARCH LFN FOR THE NEXT STRING OF NON-BLANK CHARACTERS, SEE IF THEY
C FORM AN INTEGER (IF NOT, ERROR=.TRUE.) AND, IF SO, PLACE ITS NUMERICAL
C VALUE IN "INT":
C
INT = 0
CALL RFLD(REAL,ERROR)
C
C IF DECIMAL POINT OR AN EXPONENT.LT.0, ERROR = .TRUE.:
C
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
C
100 ERROR = .TRUE.
NEXT = .FALSE.
RETURN
END
C*****************************************************************************
SUBROUTINE RFLD(REAL,ERROR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR,EXPSGN,MANTIS
C
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
C
DIMENSION NCHAR(15)
C
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/
C
C SEARCH LFN FOR THE NEXT STRING OF NON-BLANK CHARACTERS, SEE IF THEY FORM
C A REAL NUMBER (EXPONENT IS OPTIONAL) (IF NOT, ERROR=.TRUE.) AND, IF SO,
C PLACE ITS NUMERICAL VALUE IN "REAL":
C
REAL = ZERO
SIGN = ONE
NDEC = 0
ISEXP = 1
NEXP = 0
EXPSGN = .FALSE.
EXP = .FALSE.
POINT = .FALSE.
ERROR = .FALSE.
MANTIS = .FALSE.
END = .FALSE.
C
C FIND THE NEXT STRING OF NON-BLANK CHARACTERS, "LOOK", OF LENGTH "LENGTH":
C
IF(NEXT) CALL FNDFLD
IF(END) GO TO 300
IF(LENGTH.EQ.0) GO TO 300
C
C FIND THE NUMERICAL VALUE OF THE CHARACTERS IN "LOOK":
C
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
C
C THIS CHARACTER IS A NUMBER:
C
60 CONTINUE
IF(EXP) GO TO 70
C
C ADD DIGIT TO MANTISSA:
C
MANTIS = .TRUE.
REAL = REAL * TEN + FLOAT(I - 1)
C
C IF WE ARE TO THE RIGHT OF A DECIMAL POINT, INCREMENT THE DECIMAL COUNTER:
C
IF(POINT) NDEC = NDEC + 1
GO TO 200
C
C ADD DIGIT TO EXPONENT:
C
70 NEXP = NEXP * 10 + (I - 1)
GO TO 200
C
C DECIMAL POINT:
C
80 IF(POINT) GO TO 300
POINT = .TRUE.
GO TO 200
C
C EXPONENT (+,-,D,E):
C
100 CONTINUE
GO TO (110,130,150,150), K
C
C PLUS SIGN: IF NOT FIRST CHARACTER, COUNT AS PART OF EXPONENT:
C
110 IF(J.EQ.1) GO TO 200
IF(EXPSGN) GO TO 200
EXPSGN = .TRUE.
EXP = .TRUE.
GO TO 200
C
C MINUS SIGN: IF NOT FIRST CHARACTER, COUNT AS PART OF EXPONENT:
C
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
C
C D OR E: START OF EXPONENT:
C
150 IF(EXP) GO TO 300
EXP = .TRUE.
200 CONTINUE
C
C SET FINAL VALUE OF REAL (IF NO MANTISSA, BUT EXPONENT PRESENT,
C SET MANTISSA TO ONE):
C
IF(EXP.AND..NOT.MANTIS) REAL = ONE
REAL = REAL * SIGN * (TEN**(-NDEC+ISEXP*NEXP))
NEXT = .TRUE.
RETURN
C
C NO REAL NUMBER FOUND, OR FIELD TERMINATING MARK:
C
300 CONTINUE
ERROR = .TRUE.
REAL = -TEN
IF(END) REAL = TEN
RETURN
END
C*****************************************************************************
SUBROUTINE HFLD(KEYWD,LENG,ENDD)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ENDD,EQUAL
C
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
C
DIMENSION KEYWD(LENG),KEND(3)
C
DATA NBLA/1H /
DATA KEND/1HE,1HN,1HD/
C
C SEARCH LFN AND FIND NEXT NON-BLANK STRING OF CHARACTERS AND PLACE
C IN THE VECTOR "KEYWD". LENG, FROM THE CALLING PROGRAM, IS MAXIMUM
C LENGTH OF STRING TO PUT IN THE VECTOR KEYWD. IF "LENGTH" IS LESS
C THAN "LENG", LENG IS SET TO LENGTH UPON RETURN:
C
IF(NEXT) CALL FNDFLD
ENDD = END
LENG1 = LENG
LENG = MIN0(LENGTH,LENG)
C
C PLACE LENG CHARACTERS INTO KEYWD:
C
DO 10 I = 1,LENG
KEYWD(I) = LOOK(I)
10 CONTINUE
C
C FILL THE REST OF KEYWD WITH BLANKS:
C
DO 20 I = LENG+1,LENG1
KEYWD(I) = NBLA
20 CONTINUE
NEXT = .TRUE.
C
C CHECK FOR END OF INPUT:
C
IF(EQUAL(LOOK,KEND,3)) ENDD = .TRUE.
RETURN
END
C*****************************************************************************
SUBROUTINE FNDFLD
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
COMMON/NBCRD2/POINT,END,NEXT,EXP
LOGICAL POINT,END,NEXT,EXP
C
DATA NBLA/1H /,NCOM/1H,/,NEXC/1H!/,NEQ/1H=/
C
C FIND NEXT NON-BLANK STRING OF CHARACTERS IN LFN. READ IN ANOTHER LINE
C OF LFN UNTIL NON-BLANK CHARACTERS ARE FOUND AND PLACE THEM IN "LOOK",
C OF LENGTH "LENGTH":
C
IF(END) GO TO 35
IF(IPT.GE.80) CALL RDCRD
IF(END) GO TO 35
C
C LOOK FOR START OF FIELD. SKIP TO NEXT CARD IF "!" IS ENCOUNTERED
C (COMMENT FIELD):
C
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
C
C NOTHING ADDITIONAL FOUND ON THIS CARD, CONTINUE WITH THE NEXT CARD:
C
30 CALL RDCRD
IF(.NOT.END) GO TO 10
C
C END OF FILE FOUND:
C
35 LENGTH = 0
RETURN
C
C LOOK FOR THE END OF THIS FIELD, COUNTING CHARACTERS AS WE GO AND
C STORING THESE CHARACTER IN LOOK:
C
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
C
C SET LENGTH TO THE LENGTH OF THE NEW STRING IN LOOK AND RESET IPT TO
C THE NEXT SPACE AFTER THIS STRING:
C
100 LENGTH = M
IPT = MCOL
NEXT = .FALSE.
RETURN
END
C*****************************************************************************
FUNCTION EQUAL(IA,IB,L)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL EQUAL
C
DIMENSION IA(L),IB(L)
C
C TEST IF THE FIRST L ELEMENTS OF VECTORS IA AND IB ARE EQUAL:
C
EQUAL = .FALSE.
DO 10 I = 1,L
IF(IA(I).NE.IB(I)) GO TO 20
10 CONTINUE
EQUAL = .TRUE.
20 RETURN
END
C*****************************************************************************
C
C OTHER SYSTEM-INDEPENDENT I/O ROUTINES:
C
C SUBROUTINE GENINP(NEWDAF)
C SUBROUTINE NBOINP(NBOOPT,IDONE)
C SUBROUTINE CORINP(IESS,ICOR)
C SUBROUTINE CHSINP(IESS,ICHS)
C SUBROUTINE DELINP(NBOOPT,IDONE)
C
C SUBROUTINE RDCORE(JCORE)
C SUBROUTINE WRPPNA(T,OCC,IFLG)
C SUBROUTINE RDPPNA(T,OCC,IFLG)
C SUBROUTINE WRTNAO(T,IFLG)
C SUBROUTINE RDTNAO(DM,T,SCR,IFLG)
C SUBROUTINE WRTNAB(T,IFLG)
C SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG)
C SUBROUTINE WRTNBO(T,BNDOCC,IFLG)
C SUBROUTINE WRNLMO(T,DM,IFLG)
C SUBROUTINE WRBAS(SCR,ISCR,LFN)
C SUBROUTINE WRARC(SCR,ISCR,LFN)
C
C SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG)
C SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL)
C SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN)
C SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR)
C SUBROUTINE ALTOUT(A,MR,MC,NR,NC)
C SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR)
C FUNCTION IOINQR(IFLG)
C SUBROUTINE LBLAO
C SUBROUTINE LBLNAO
C SUBROUTINE LBLNBO
C SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR)
C
C*****************************************************************************
SUBROUTINE GENINP(NEWDAF)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL NEWDAF,END,ERROR,EQUAL
C
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)
C
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
C
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/
C
C Initialize variables:
C
NBAS = 0
NATOMS = 0
MUNIT = 0
REUSE = .FALSE.
UPPER = .FALSE.
BOHR = .FALSE.
DENOP = .TRUE.
C
C Search LFNIN for $GEN:
C
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
C
C $GEN has been found, now read keywords:
C
20 LEN = 6
CALL HFLD(KEYWD,LEN,END)
IF(EQUAL(KEYWD,KEND,4)) GOTO 700
C
C Keyword REUSE -- reuse data already stored on the NBO DAF:
C
IF(EQUAL(KEYWD,KREUSE,5)) THEN
REUSE = .TRUE.
GOTO 20
END IF
C
C Keyword NBAS -- Specify the number of basis functions:
C
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
C
C Keyword NATOMS -- Specify the number of atoms:
C
IF(EQUAL(KEYWD,KNATOM,4)) THEN
CALL IFLD(NATOMS,ERROR)
IF(ERROR) STOP 'Error reading in number of atoms NATOMS'
GOTO 20
END IF
C
C Keyword UPPER -- Read only upper triangular portions of matrices:
C
IF(EQUAL(KEYWD,KUPPER,5)) THEN
UPPER = .TRUE.
GOTO 20
END IF
C
C Keyword OPEN -- Open shell species (alpha and beta matrices read):
C
IF(EQUAL(KEYWD,KOPEN,4)) THEN
OPEN = .TRUE.
GOTO 20
END IF
C
C Keyword ORTHO -- Orthogonal basis set (Skip NAO analysis):
C
IF(EQUAL(KEYWD,KORTHO,5)) THEN
ORTHO = .TRUE.
GOTO 20
END IF
C
C Keyword BOHR -- Atomic coordinates, dipole integrals in bohr:
C
IF(EQUAL(KEYWD,KBOHR,4)) THEN
BOHR = .TRUE.
GOTO 20
END IF
C
C Keyword BODM -- Input bond order matrix:
C
IF(EQUAL(KEYWD,KBODM,4)) THEN
DENOP = .FALSE.
GOTO 20
END IF
C
C Keyword EV -- Expectation values of the Fock operator are in eV:
C
IF(EQUAL(KEYWD,KEV,2)) THEN
MUNIT = 1
GOTO 20
END IF
C
C Keyword CUBICF -- Use set of cubic f functions:
C
IF(EQUAL(KEYWD,KCUBF,6)) THEN
IWCUBF = 1
GOTO 20
END IF
C
C Unknown keyword -- halt program:
C
WRITE(LFNPR,900) KEYWD
STOP
C
C End of $GEN input encountered, make sure GENNBO has all info needed:
C
700 CONTINUE
IF(REUSE) THEN
NEWDAF = .FALSE.
RETURN
ELSE
NEWDAF = .TRUE.
ENDIF
C
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
C
900 FORMAT(1X,'Unrecognized keyword >',6A1,'<')
END
C*****************************************************************************
SUBROUTINE NBOINP(NBOOPT,IDONE)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL END,EQUAL
DIMENSION NBOOPT(10)
DIMENSION KEYWD(6),KNBO(4)
C
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
C
DATA KNBO/1H$,1HN,1HB,1HO/
C
C If NBOOPT(1) = 1, don't search for keywords, just continue with
C default options:
C
IF(NBOOPT(1).EQ.1) THEN
IDONE = 0
RETURN
END IF
C
C If this is the GAMESS, HONDO, or general version of the NBO program,
C rewind the input file before searching for $NBO:
C
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)
C
C Search input file for $NBO:
C
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
C
C $NBO found -- continue with the NBO analysis:
C
50 CONTINUE
IDONE = 0
RETURN
C
C End of file encountered -- Stop NBO analysis, except for the general
C version of the program (set NBOOPT(1) so keywords are not read):
C
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
C*****************************************************************************
SUBROUTINE CORINP(IESS,ICOR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL END,EQUAL
C
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
C
DIMENSION KEYWD(6),KCOR(4),KCHS(4),KDEL(4),KNBO(4),KNRT(4)
C
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/
C
C If ICOR is set to -1, do not read in the $CORE keylist:
C
IF(ICOR.EQ.-1) RETURN
C
C If this is the GAMESS, HONDO, or general version of the NBO program,
C rewind the input file before searching for $CORE:
C
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)
C
C Search input file for $CORE:
C
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
C
C $CORE found:
C
50 CONTINUE
ICOR = 1
RETURN
C
C $NBO, $CHOOSE, $DEL -- discontinue the search for $CORE (GAUSSIAN, AMPAC)
C or $NRT continue searching for $CORE (GENNBO, GAMESS, HONDO)
C
60 CONTINUE
IF(IREP.EQ.0) GOTO 10
BACKSPACE(LFNIN)
ICOR = 0
RETURN
C
C End of file encountered:
C
70 CONTINUE
ICOR = 0
RETURN
END
C*****************************************************************************
SUBROUTINE CHSINP(IESS,ICHS)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL END,EQUAL
C
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
C
DIMENSION KEYWD(6),KCHS(4),KDEL(4),KNBO(4),KNRT(4)
C
DATA KCHS/1H$,1HC,1HH,1HO/,KDEL/1H$,1HD,1HE,1HL/,
+ KNBO/1H$,1HN,1HB,1HO/,KNRT/1H$,1HN,1HR,1HT/
C
C If ICHS is set to -1, do not search for the $CHOOSE keylist:
C
IF(ICHS.EQ.-1) RETURN
C
C If this is the GAMESS, HONDO, or general version of the NBO program,
C rewind the input file before searching for $CHOOSE:
C
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)
C
C Search input file for $CHOOSE:
C
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
C
C $CHOOSE found:
C
50 CONTINUE
ICHS = 1
RETURN
C
C $NBO, $DEL found -- discontinue the search for $CHOOSE (GAUSSIAN, AMPAC)
C or $NRT continue searching for $CHOOSE (GENNBO, GAMESS, HONDO)
C
60 CONTINUE
IF(IREP.EQ.0) GOTO 10
BACKSPACE(LFNIN)
ICHS = 0
RETURN
C
C End of file encountered:
C
70 CONTINUE
ICHS = 0
RETURN
END
C*****************************************************************************
SUBROUTINE DELINP(NBOOPT,IDONE)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL END,EQUAL
DIMENSION NBOOPT(10)
DIMENSION KEYWD(6),KDEL(4),KNBO(4)
C
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
C
DATA KDEL/1H$,1HD,1HE,1HL/,KNBO/1H$,1HN,1HB,1HO/
C
C If this is the GAMESS, HONDO, or general version of the NBO program,
C rewind the input file before searching for $DEL:
C
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)
C
C Search input file for $DEL:
C
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
C
C $DEL found -- continue with the NBO energetic analysis:
C
50 CONTINUE
IDONE = 0
RETURN
C
C $NBO found -- discontinue the search for $DEL (GAUSSIAN, AMPAC)
C continue searching for $DEL (GENNBO, GAMESS, HONDO)
C
60 CONTINUE
IF(IREP.EQ.0) GOTO 10
BACKSPACE(LFNIN)
IDONE = 1
RETURN
C
C End of file encountered -- Stop NBO energetic analysis
C
70 CONTINUE
IF(IREP.EQ.1) THEN
REWIND(LFNIN)
IREP = IREP + 1
GOTO 10
ELSE
IDONE = 1
END IF
RETURN
END
C*****************************************************************************
SUBROUTINE RDCORE(JCORE)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL ERROR
C
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
C
C Initialize the atomic core array:
C
DO 10 I = 1,NATOMS
IATCR(I) = -1
10 CONTINUE
C
C Read in modifications to the nominal core table:
C
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
C
810 WRITE(LFNPR,910) II
STOP
C
820 WRITE(LFNPR,920) II
STOP
C
830 WRITE(LFNPR,930) JJ,II
STOP
C
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
C*****************************************************************************
SUBROUTINE WRPPNA(T,OCC,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
DIMENSION T(NDIM,NDIM),OCC(NDIM)
CHARACTER*80 TITLE
C
C Write the PNAO information to the external file ABS(IFLG):
C
C NOTE: This is the pure-AO to PNAO transformation, not the raw AO
C to PNAO transform.
C
TITLE = 'PNAOs in the PAO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,-1,IFLG)
C
C Write the NAO orbital labels to the external file:
C
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)
C
C Write the PNAO orbital occupancies:
C
WRITE(LFN,910) (OCC(J),J=1,NBAS)
RETURN
C
900 FORMAT(1X,20I4)
910 FORMAT(1X,5F15.9)
END
C*****************************************************************************
SUBROUTINE RDPPNA(T,OCC,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
DIMENSION T(NDIM,NDIM),OCC(NDIM)
DIMENSION JOB(20)
LOGICAL ERROR
C
C Read the PNAO information from the external file ABS(IFLG/1000)
C
C NOTE: This is the pure-AO to PNAO transformation, not the raw AO
C to PNAO transform.
C
LFN = ABS(IFLG/1000)
WRITE(LFNPR,900)
C
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)
C
C Read in orbital labels from LFN:
C
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)
C
C Read orbital occupancies:
C
READ(LFN,1010,END=820) (OCC(J),J=1,NBAS)
RETURN
C
800 WRITE(LFNPR,950) LFN
STOP
C
810 WRITE(LFNPR,960) LFN
STOP
C
820 WRITE(LFNPR,970) LFN
STOP
C
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
C*****************************************************************************
SUBROUTINE WRTNAO(T,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
DIMENSION T(NDIM,NDIM)
CHARACTER*80 TITLE
C
C NOTE: T is the PNAO overlap matrix on return to the calling routine
C
C Fetch the AO to NAO transformation from the NBO DAF, and write
C it to the external file ABS(IFLG):
C
CALL FETNAO(T)
TITLE = 'NAOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG)
C
C Write the NAO orbital labels to the external file:
C
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)
C
C Fetch the PNAO overlap matrix from the NBO DAF, and store only the
C upper triangular portion on the external file:
C
CALL FESNAO(T)
TITLE = 'PNAO overlap matrix:'
CALL AOUT(T,NDIM,-NBAS,NBAS,TITLE,2,IFLG)
RETURN
C
900 FORMAT(1X,20I4)
END
C*****************************************************************************
SUBROUTINE RDTNAO(DM,T,SCR,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),SCR(NDIM)
DIMENSION JOB(20)
LOGICAL ERROR
C
C NOTE: T is the PNAO overlap matrix on return to the calling routine
C DM is the NAO density matrix on return
C
C Read in AO to NAO transformation from the external file ABS(IFLG/1000),
C and store it on the NBO DAF:
C
LFN = ABS(IFLG/1000)
WRITE(LFNPR,900)
C
REWIND(LFN)
CALL AREAD(T,NDIM,NBAS,NBAS,JOB,LFN,ERROR)
IF(ERROR) GOTO 800
WRITE(LFNPR,910) JOB
CALL SVTNAO(T)
C
C Transform the AO density matrix, presently in DM, to the NAO basis:
C
CALL SIMTRS(DM,T,SCR,NDIM,NBAS)
C
C Read in orbital labels from LFN:
C
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)
C
C Read the PNAO overlap from LFN, and save this matrix on the NBO DAF:
C
CALL AREAD(T,NDIM,-NBAS,NBAS,JOB,LFN,ERROR)
IF(ERROR) GOTO 820
CALL SVSNAO(T)
RETURN
C
800 WRITE(LFNPR,950) LFN
STOP
C
810 WRITE(LFNPR,960) LFN
STOP
C
820 WRITE(LFNPR,970) LFN
STOP
C
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
C*****************************************************************************
SUBROUTINE WRTNAB(T,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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)
C
DIMENSION T(NDIM,NDIM)
CHARACTER*80 TITLE
C
C Write the NAO to NBO transformation and NBO info to external file
C ABS(IFLG):
C
TITLE = 'NBOs in the NAO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,2,IFLG)
C
C Write the NBO labels:
C
LFN = ABS(IFLG)
DO 10 I = 1,NBAS
WRITE(LFN,900) (LABEL(I,J),J=1,6),IBXM(I)
10 CONTINUE
RETURN
C
900 FORMAT(1X,A2,A1,4I3,3X,I3)
END
C*****************************************************************************
SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),BNDOCC(NDIM),SCR(NDIM)
DIMENSION JOB(20)
LOGICAL ERROR
C
C Read the NAO to NBO transformation matrix from the external file
C ABS(IFLG/1000). Also read the NBO labels, the NBO occupancies,
C and transform the input NAO density matrix to the NBO basis:
C
LFN = ABS(IFLG/1000)
WRITE(LFNPR,900)
C
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)
C
C Read the NBO labels:
C
DO 10 I = 1,NBAS
READ(LFN,1000,END=810) (LABEL(I,J),J=1,6),IBXM(I)
10 CONTINUE
C
C Transform the NAO density matrix, DM, to the NBO basis, and store the
C NBO occupancies in BNDOCC:
C
CALL SIMTRS(DM,T,SCR,NDIM,NBAS)
DO 20 I = 1,NBAS
BNDOCC(I) = DM(I,I)
20 CONTINUE
RETURN
C
800 WRITE(LFNPR,950) LFN
STOP
C
810 WRITE(LFNPR,960) LFN
STOP
C
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
C*****************************************************************************
SUBROUTINE WRTNBO(T,BNDOCC,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
DIMENSION T(NDIM,NDIM),BNDOCC(1)
CHARACTER*80 TITLE
C
C Write the AO to NBO transformation matrix and NBO info to the external
C file ABS(IFLG):
C
TITLE = 'NBOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG)
C
C Write out the NBO occupancies:
C
LFN = ABS(IFLG)
WRITE(LFN,900) (BNDOCC(J),J=1,NBAS)
C
C Write out NBOUNI, NBOTYP, LABEL, IBXM, and IATNO:
C
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
C
900 FORMAT(1X,5F15.9)
910 FORMAT(1X,20I3)
920 FORMAT(1X,20A3)
END
C*****************************************************************************
SUBROUTINE WRNLMO(T,DM,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM)
CHARACTER*80 TITLE
C
C Write the AO to NLMO transformation matrix and NLMO info to the external
C file ABS(IFLG):
C
TITLE = 'NLMOs in the AO basis:'
CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG)
C
C Write out the NLMO occupancies:
C
LFN = ABS(IFLG)
WRITE(LFN,900) (DM(J,J),J=1,NBAS)
C
C Write out NBOUNI, NBOTYP, LABEL, IBXM, and IATNO:
C
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
C
900 FORMAT(1X,5F15.9)
910 FORMAT(1X,20I3)
920 FORMAT(1X,20A3)
END
C*****************************************************************************
SUBROUTINE WRBAS(SCR,ISCR,LFN)
C*****************************************************************************
C
C Save the AO basis set information on an external file:
C
C-----------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
C
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
C
DIMENSION SCR(1),ISCR(1)
C
C Fetch the number of shells NSHELL, the number of exponents NEXP,
C the NCOMP, NPRIM, and NPTR arrays, and the orbital exponents and
C coefficients from the NBO DAF:
C
CALL FEBAS(NSHELL,NEXP,ISCR)
C
C If NSHELL is zero, then no basis set info has been stored in the
C DAF:
C
IF(NSHELL.EQ.0) THEN
WRITE(LFNPR,900)
RETURN
END IF
C
C Partition the scratch arrays: (Note that SCR and ISCR occupy the same
C space in memory)
C
C ISCR: (integer)
C
C NSHELL NEXP NCOMP NPRIM NPTR
C +------+------+-------+-------+-------+-----------------------------------
C I1 I2 I3
C
C SCR: (real)
C ATCOOR
C EXP CS CP CD CF TITLE
C ---------------------------------------+-----+----+----+----+----+--------
C I4 I5 I6 I7 I8 I9
C
C ISCR(I1) : NCOMP(1..NSHELL)
C ISCR(I2) : NPRIM(1..NSHELL)
C ISCR(I3) : NPTR(1..NSHELL)
C SCR(I4) : EXP(1..NEXP)
C SCR(I5) : CS(1..NEXP)
C SCR(I6) : CP(1..NEXP)
C SCR(I7) : CD(1..NEXP)
C SCR(I8) : CF(1..NEXP)
C SCR(I9) : TITLE(10) or ATCOOR(3*NATOMS)
C
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
C IEND = I9 + MAX0(3*NATOMS,10)
C
C Fetch job title and write it to the AOINFO external file:
C
CALL FETITL(SCR(I9))
C
C Begin writing to the AOINFO external file:
C
WRITE(LFN,910) (SCR(I9+I),I=0,9)
WRITE(LFN,920) NATOMS,NSHELL,NEXP
C
C Fetch the atomic coordinates:
C
CALL FECOOR(SCR(I9))
C
C Write atomic numbers and coordinates to external file:
C
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)
C
C Write out information about each shell in the basis set:
C
C NCTR(I) -- atomic center of the Ith shell
C
C NCOMP(I) -- number of components in the Ith shell
C
C NPTR(I) -- pointer for the Ith shell into the primitive parameters
C of EXP, CS, CP, CD, and CF
C
C NPRIM(I) -- number of primitive functions in the Ith shell
C
C LABEL(1..NCOMP(I)) -- symmetry labels for the orbitals of this shell
C
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)
C
C Write out the primitive parameters:
C
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
C
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
C*****************************************************************************
SUBROUTINE WRARC(SCR,ISCR,LFN)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
PARAMETER (MAXD = 4)
C
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)
C
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)
C
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/
C
C Write the ARCHIVE file to LFN:
C
C This routine has been written assuming NBAS = NDIM. Skip if
C this condition is not satisfied:
C
IF(NBAS.NE.NDIM) THEN
WRITE(LFNPR,890)
RETURN
END IF
C
C Form the $GENNBO keylist in ISCR:
C
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
C
C Add the number of atoms and basis functions:
C
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
C
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
C
C If OPEN shell, add the OPEN keyword:
C
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
C
C If the AO basis is orthogonal, add the ORTHO keyword:
C
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
C
C Only UPPER triangular portions of symmetric matrices will be given:
C
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
C
C Enter the bond-order matrix, BODM, if possible:
C
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
C
C Add EV if the energy units are in electron volts:
C
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
C
C Add KCAL if the energy units are in kcal/mol:
C
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
C
C Add CUBICF if these types of orbitals are being used:
C
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
C
C Add $END:
C
DO 110 I = 1,4
NC = NC + 1
ISCR(NC) = KEND(I)
110 CONTINUE
C
C Write the $GENNBO keylist to the archive file:
C
WRITE(LFN,900) (ISCR(I),I=1,NC)
C
C Write the $NBO keylist to the archive file:
C
WRITE(LFN,910)
C
C Write the $COORD data list to the archive file:
C
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)
C
C Write the $BASIS datalist to the archive file (info from /NBAO/):
C
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)
C
C Write the $CONTRACT datalist to the archive file:
C
C Fetch the basis set info from the NBO DAF:
C
CALL FEBAS(NSHELL,NEXP,ISCR)
C
C Partition the scratch vector:
C
C ISCR(I1) : NCOMP(1..NSHELL)
C ISCR(I2) : NPRIM(1..NSHELL)
C ISCR(I3) : NPTR(1..NSHELL)
C SCR(I4) : EXP(1..NEXP)
C SCR(I5) : CS(1..NEXP)
C SCR(I6) : CP(1..NEXP)
C SCR(I7) : CD(1..NEXP)
C SCR(I8) : CF(1..NEXP)
C
I1 = 3
I2 = I1 + NSHELL
I3 = I2 + NSHELL
I4 = I3 + NSHELL
I5 = I4 + NEXP
I6 = I5 + NEXP
I7 = I6 + NEXP
I8 = I7 + NEXP
C IEND = I8 + NEXP
C
C If NSHELL is zero, then no basis set info was ever stored on
C the DAF:
C
IF(NSHELL.GT.0) THEN
C
C Write out numbers of shells and orbital exponents:
C
WRITE(LFN,980)
WRITE(LFN,970) ANSHLL,NSHELL
WRITE(LFN,970) ANEXP,NEXP
C
C Write out the number of components in each shell:
C
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
C
C Write out the number of primitives in each shell:
C
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
C
C Write out pointer array which maps orbital exponents and coefficients
C onto each shell:
C
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
C
C Write out orbital exponents:
C
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
C
C Write out the orbital coefficients for each angular symmetry type
C unless there are no basis functions of that type:
C
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
C
C Write the $OVERLAP datalist unless the AO basis is orthogonal:
C
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
C
C Write the $DENSITY datalist:
C
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)
C
C Write the $FOCK datalist:
C
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
C
C Write the $LCAOMO datalist:
C
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
C
C Write the $DIPOLE datalist:
C
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
C
C Reset logicals ALPHA and BETA:
C
ALPHA = ISPIN.EQ.2
BETA = ISPIN.EQ.-2
RETURN
C
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
C*****************************************************************************
SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(MR,1)
CHARACTER*80 TITLE
DIMENSION ISHELL(4)
C
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)
C
DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/
C
C Either write A to an external file, or print it in the output file:
C
C Input: A -- matrix to be printed or written out
C
C MR -- row dimension of matrix A in calling routine
C
C NR -- ABS(NR) is the actual number of rows to be output
C [if NR is negative, IFLG is negative (write), and
C ABS(NR).EQ.NC (square matrix), only the upper
C triangular portion is written out]
C
C NC -- actual number of columns in matrix A
C [used to determine if A is square, and as an upper
C limit on IFLG]
C
C TITLE -- CHARACTER*80 variable containing a matrix title
C
C INDEX -- Index selecting appropriate output labels
C 0 : Atom labels
C 1 : AO labels
C 2 : NAO labels
C 3 : NHO labels
C 4 : NBO labels
C 5 : NLMO labels
C
C IFLG -- print/write flag
C negative : write to LFN ABS(IFLG)
C positive : print IFLG columns of A
C 'FULL' : print the full matrix
C 'VAL' : print N columns of A, where N is the
C number of core + valence orbitals and
C is determined by this routine
C 'LEW' : print N columns of A, where N is the
C number of occupied orbitals and is
C determined by this routine
C
JFLG = IFLG
IF(JFLG.EQ.0) RETURN
C
C If JFLG is FULL, then output the total number of columns:
C
IF(JFLG.EQ.KFULL) JFLG = ABS(NC)
C
C If JFLG = VAL, output only the valence orbitals, determined from the
C core and valence tables:
C
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
C
C If JFLG is LEW, only output the occupied orbitals:
C
IF(JFLG.EQ.KLEW) JFLG = NLEW
C
C If JFLG is positive, print the matrix A in the output file:
C
IF(JFLG.GT.0) CALL APRINT(A,MR,NR,NC,TITLE,INDEX,JFLG)
C
C If JFLG is negative but greater than -1000, write matrix A to the external
C file ABS(JFLG):
C
IF(JFLG.LT.0.AND.JFLG.GT.-1000) CALL AWRITE(A,MR,NR,NC,TITLE,JFLG)
C
RETURN
END
C*****************************************************************************
SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(MR,1)
CHARACTER*80 TITLE
DIMENSION BASIS(5)
C
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
C
DATA BASIS/4H AO ,4H NAO,4H NHO,4H NBO,4HNLMO/
DATA ATOM,DASHES/4HAtom,8H--------/
DATA TENTH/0.1D0/
C
C Determine the number of columns of matrix A to print in the output file:
C
NCOL = MCOL
IF(NCOL.GT.ABS(NC)) NCOL = ABS(NC)
C
NN = ABS(NR)
ILABEL = INDEX
IF(ILABEL.EQ.5) ILABEL = 4
C
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
C
C Print the matrix title:
C
WRITE(LFNPR,1000) TITLE(1:78)
C
C Print the matrix A: (basis function labels)
C
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
C
C Print the matrix A: (atom labels)
C
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
C
C Print the matrix A: (no labels)
C
ELSE
CALL ALTOUT(A,MR,NCOL,NN,NCOL)
END IF
RETURN
C
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
C*****************************************************************************
SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(MR,1)
CHARACTER*80 TITLE
DIMENSION XJOB(10)
C
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
C
C Write the matrix A to the external file ABS(LFN). Include job title,
C matrix title, and specify the spin in needed:
C
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)
C
C If this is a square matrix and NR is negative, only write the upper
C triangular portion. Otherwise, write out the full matrix:
C
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
C
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
C*****************************************************************************
SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(MR,1),JOB(20)
DIMENSION ITEMP(20)
LOGICAL ERROR
C
COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
DATA IDASH,IALFA,IBETA/4H----,4HALPH,4HBETA/
C
C Read the matrix A to the external file LFN:
C
C Input: MR -- row dimension of matrix A in calling routine
C
C NR -- ABS(NR) is the actual number of rows to be read
C [if NR is negative and ABS(NR).EQ.NC (square matrix),
C only the upper triangular portion is stored in the
C input file. This routine will read the upper triangular
C portion and unpack it.]
C
C NC -- actual number of columns in matrix A
C [used to determine if A is square]
C
C LFN -- input file
C
C Output: JOB -- INTEGER array containing the job title
C [closed shell or alpha spin only]
C
C ERROR -- set to .true. if the end-of-file was encountered while
C reading
C
IF(ALPHA.OR..NOT.OPEN) READ(LFN,1000,END=800) JOB
IF(.NOT.OPEN) ISTR = IDASH
IF(ALPHA) ISTR = IALFA
IF(BETA) ISTR = IBETA
C
10 READ(LFN,1000,END=800) ITEMP
IF(ITEMP(1).NE.ISTR) GOTO 10
C
C If this is a square matrix and NR is negative, only read the upper
C triangular portion. Otherwise, read the full matrix:
C
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
C
800 ERROR = .TRUE.
RETURN
C
900 FORMAT(1X,5F15.9)
1000 FORMAT(1X,20A4)
END
C*****************************************************************************
SUBROUTINE ALTOUT(A,MR,MC,NR,NC)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
C
DIMENSION A(MR,MC)
C
C FOR 80 COLUMN OUTPUT:
C LIST ELEMENTS OF ARRAY A (MATRIX OR VECTOR).
C MR,MC DECLARED ROW AND COLUMN DIMENSIONALITY,
C NR,NC ACTUAL ROW AND COLUMN DIMENSIONALITY,
C
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
C*****************************************************************************
SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
INTEGER STRING(LEN)
LOGICAL READ,ERROR
C
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
C
DATA IW,IR,IP,IC,IV,IL/1HW,1HR,1HP,1HC,1HV,1HL/
DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/
C
C Interpret the KEYword PARameter STRING, storing the result in IFLG.
C (The default IFLG should be passed to this routine through IFLG)
C
C The following STRINGs are acceptable:
C
C STRING = Wnnn means write to the external file nnn (IFLG = -nnn)
C (if nnn is omitted, IFLG = -LFN)
C
C STRING = Rnnn means read from the external file nnn (IFLG = -nnn*1000)
C (if nnn is omitted, IFLG = -LFN)
C (READ must be true to allow reading)
C
C STRING = PnnnC means print nnn columns to the output file (IFLG = nnn)
C (if nnn is omitted, print full matrix, IFLG = 'FULL')
C (the C is optional, it means columns)
C
C STRING = PVAL means print val columns to output file (IFLG = 'VAL')
C (val is the number of core + valence orbitals)
C (only the V is necessary)
C
C
C STRING = PLEW means print lew columns to output file (IFLG = 'LEW'
C (lew is the number of occupied orbitals)
C (only the L is necessary)
C
C STRING = other IFLG is left untouched
C
ERROR = .FALSE.
C
C Process STRING = W..:
C
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
C
C Process STRING = R..:
C
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
C
C Process STRING = P..:
C
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
C
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
C*****************************************************************************
FUNCTION IOINQR(IFLG)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/
DATA KBLNK,KPRNT,KWRIT,KREAD/4H ,4HPRNT,4HWRIT,4HREAD/
C
C Interpret IFLG, determining whether the corresponding matrix should be
C printed, written out, or read:
C
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
C*****************************************************************************
SUBROUTINE LBLAO
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXD = 2)
C
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)
C
DIMENSION ISTR(MAXD),IANG(5),IXYZ(3),IBYTE(4),NUM(10)
C
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/
C
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
C*****************************************************************************
SUBROUTINE LBLNAO
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXD = 2)
C
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)
C
DIMENSION ISTR(MAXD),IANG(5),IXYZ(3),IBYTE(4),NUM(10)
C
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/
C
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
C*****************************************************************************
SUBROUTINE LBLNBO
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXD = 2)
INTEGER ISTR(MAXD),IBYTE(4)
C
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)
C
DATA IBLNK,IC,IL,IP,IR,IY,ISTAR,IHYP/' ','c','l','p','r','y','*',
+ '-'/
DATA ICR,ILP/'CR','LP'/
DATA ILEFT,IRIGHT/'(',')'/
C
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
C
C One-center labels:
C
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
C
C Two-center labels:
C
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)
C
C Three-center labels:
C
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
C*****************************************************************************
SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER(MAXD = 2)
INTEGER ISTR(MAXD),IBYTE(4)
C
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)
C
DATA IBLNK,IC,IL,IP,IR,IY,I3,ISTAR,IHYP/' ','c','l','p','r','y',
+ '3','*','-'/
DATA ICR,ILP/'CR','LP'/
DATA ILEFT,IRIGHT/'(',')'/
C
DO 10 I = 1,10
NHOLBL(I,INHO) = IBLNK
10 CONTINUE
IB = IBXM(INBO)
C
C One-center labels:
C
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
C
C Two-center and three-center labels:
C
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
C*****************************************************************************
C
C GENERAL UTILITY ROUTINES:
C
C SUBROUTINE ANGLES(X,Y,Z,THETA,PHI)
C FUNCTION BDFIND(IAT,JAT)
C SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR)
C SUBROUTINE CONSOL(AUT,ALT,NDIM,N)
C SUBROUTINE CONVIN(IJ,LEN,IK,ERROR)
C SUBROUTINE CONVRT(N,NC1,NC2)
C SUBROUTINE COPY(A,B,NDIM,NR,NC)
C SUBROUTINE CORTBL(IAT,ICORE,IECP)
C SUBROUTINE DEBYTE(I,IBYTE)
C SUBROUTINE HALT(WORD)
C SUBROUTINE IDIGIT(KINT,IK,ND,MAXD)
C FUNCTION IHTYP(IBO,JBO)
C SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR)
C SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT)
C SUBROUTINE MATMLT(A,B,V,NDIM,N)
C SUBROUTINE MATML2(A,B,V,NDIM,N)
C FUNCTION NAMEAT(IZ)
C SUBROUTINE NORMLZ(A,S,M,N)
C SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK)
C SUBROUTINE PACK(T,NDIM,NBAS,L2)
C SUBROUTINE RANK(EIG,N,NDIM,ARCRNK)
C SUBROUTINE SIMTRN(A,T,V,NDIM,N)
C SUBROUTINE SIMTRS(A,S,V,NDIM,N)
C SUBROUTINE TRANSP(A,NDIM,N)
C SUBROUTINE UNPACK(T,NDIM,NBAS,L2)
C SUBROUTINE VALTBL(IAT,IVAL)
C FUNCTION VECLEN(X,N,NDIM)
C
C SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR,
C + IERR)
C SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG)
C SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR)
C SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM)
C
C*****************************************************************************
SUBROUTINE ANGLES(X,Y,Z,THETA,PHI)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DATA ZERO,CUTOFF,ONE/0.0D0,1.0D-8,1.0D0/
C
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
C*****************************************************************************
FUNCTION BDFIND(IAT,JAT)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL BDFIND,IFOUND,JFOUND
C
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
C
DATA LSTAR/1H*/
C
C SET BDFIND=.TRUE. IF THERE IS AT LEAST ONE BOND BETWEEN ATOMS IAT AND JAT
C
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
C*****************************************************************************
SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION LISTA(NATOMS,2),ISTR(80)
C
PARAMETER (MAXD = 4)
DIMENSION INUM(MAXD),IBYTE(4)
DATA IC,IH,IBLNK,ILEFT,IRIGHT/'C','H',' ','(',')'/
C
C Build the chemical formula from the list of atoms in LISTA:
C
C Get chemical symbols:
C
DO 10 IAT = 1,NAT
LISTA(IAT,1) = NAMEAT(LISTA(IAT,1))
10 CONTINUE
C
C Alphabetize these symbols:
C
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
C
C Build chemical formula in ISTR:
C
C First carbon...
C
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
C
C then hydrogen...
C
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
C
C and now the rest...
C
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
C*****************************************************************************
SUBROUTINE CONSOL(AUT,ALT,NDIM,N)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C CONSOLIDATE AUT, ALT TO A SINGLE MATRIX, WITH AUT AS UPPER TRIANGLE
C (INCLUDING DIAGONAL) AND ALT AS LOWER TRIANGLE. STORE RESULT IN AUT.
C
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
C*****************************************************************************
SUBROUTINE CONVIN(IJ,LEN,IK,ERROR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION IJ(1)
DIMENSION INT(10)
LOGICAL ERROR
C
DATA INT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C Convert the array IJ(LEN) into an integer IK:
C
ERROR = .FALSE.
IF(LEN.LE.0) THEN
ERROR = .TRUE.
RETURN
END IF
C
C Make sure all elements of IJ are integers:
C
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
C
20 IL = IL + JJ * MULT
MULT = MULT * 10
30 CONTINUE
IK = IL
RETURN
END
C*****************************************************************************
SUBROUTINE CONVRT(N,NC1,NC2)
C*****************************************************************************
C
C CONVERT 2-DIGIT INTEGER 'N' TO TWO LITERAL CHARACTERS 'NC1','NC2'.
C
DIMENSION INT(10)
DATA ISP,INT/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0/
C
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
C*****************************************************************************
SUBROUTINE COPY(A,B,NDIM,NR,NC)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(NDIM,1),B(NDIM,1)
C
C COPY A TO B:
C
DO 20 J = 1,NC
DO 10 I = 1,NR
B(I,J) = A(I,J)
10 CONTINUE
20 CONTINUE
RETURN
END
C*****************************************************************************
SUBROUTINE CORTBL(IAT,ICORE,IECP)
C*****************************************************************************
C
C CORE TABLE:
C
C Determine the number of subshells of core orbitals of each angular
C symmetry for atom number IAT. ICORE is an integer array LMAX+1
C long which returns the number of subshells to the calling subroutine:
C the number of `s' subshells in ICORE(1), the number of `p' subshells
C in ICORE(2), etc...
C
C If the CORE option has been used, the core orbitals stored in the array
C IATCR are used rather than the core orbitals of the nominal core table.
C
C If IECP = 0 return the number of subshells, excluding subshells of
C an effective core potential.
C IF IECP = 1 return the number of subshells, including subshells of
C an effective core potential.
C
C Note: It is possible for a negative number of core orbitals be found
C if effective core potentials are employed. This happens when the
C number of core electrons in the effective core potential is either
C greater than the nominal number of core electrons or is greater than the
C number of core electrons requested when using the CORE option.
C
C------------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (LMAX = 3)
INTEGER CORE(57),ICORE(4),ITEMP(4),IORD(16),JORD(20),KORD(20)
C
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)
C
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/
C
C Initialize arrays. If there is no nuclear charge at this center,
C return to calling routine:
C
DO 10 L = 0,LMAX
ICORE(L+1) = 0
ITEMP(L+1) = 0
10 CONTINUE
IF(IATNO(IAT).LE.0) RETURN
C
C If the CORE option has not been used for this atom, use the nominal
C set of core orbitals:
C
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
C
C If the CORE option has been used, determine the number of core
C orbitals on this atom:
C
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
C
C If effective core potentials were used and IECP = 0, remove
C the core orbitals of the ECP:
C
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
C*****************************************************************************
SUBROUTINE DEBYTE(I,IBYTE)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION IBYTE(4),KB(4)
C
SAVE KB,KPAD,KSW
C
DATA KSW/0/
DATA KTMP/4HABCD/
C
C Extract four Hollerith characters from I, store in IBTYE:
C
C If this is the first time that this routine is called, determine
C in which bytes of an integer word the Hollerith characters reside:
C
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
C
C Determine the bit padding:
C
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
C
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
C
C Extract four Hollerith characters from I:
C
DO 100 K = 1,4
IBYTE(K) = MOD(I/KB(K),256)*KB(1) + KPAD
100 CONTINUE
RETURN
END
C*****************************************************************************
SUBROUTINE HALT(WORD)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
+ LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
+ LFNDAF,LFNDEF
C
DATA BLANK/1H /
C
IF(WORD.EQ.BLANK) RETURN
WRITE(LFNPR,1000) WORD
STOP
C
1000 FORMAT(' Non-integer encountered when trying to read variable ',
+ '/',A6,'/')
END
C*****************************************************************************
SUBROUTINE IDIGIT(KINT,IK,ND,MAXD)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION IK(MAXD),INT(10)
C
DATA IBLNK,INT/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0/
C
C CONVERTS THE INTEGER KINT INTO THE FIRST ND ELEMENTS OF HOLLERITH ARRAY
C IK(MAXD):
C
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
C
C SHIFT INTEGER REP IN IK SO THAT THE NUMBER OCCUPIES THE FIRST ND
C ELEMENTS:
C
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
C*****************************************************************************
FUNCTION IHTYP(IBO,JBO)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
LOGICAL BDFIND
C
PARAMETER(MAXATM = 99,MAXBAS = 500)
COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
+ LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
C
DATA IV,IG,IR/'v','g','r'/
C
C Determine whether the IBO->JBO delocalization is vicinal (IHTYP='v'),
C geminal (IHTYP='g'), or remote (IHTYP='r'):
C
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
C*****************************************************************************
SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C DIAGONALIZE REAL SYMMETRIC MATRIX A BY JACOBI ROTATIONS:
C N: ACTUAL DIMENSION OF A,EIVR
C NDIM: DECLARED DIMENSION OF A,EIVR
C ICONTR: CONTROL OPTION
C
C
C ******** MODIFIED VERSION, MARCH 1986 *************
C
C
C ICONTR = 0: REDUCE ALL OFF-DIAGONAL ELEMENTS TO "DONE" OR SMALLER
C -- THIS SETS FULMIX=.TRUE.
C
C ICONTR = 1: DO THE SAME AS FOR ICONTR=0 EXCEPT DO NOT MIX ORBITALS THAT
C ARE DEGENERATE TO WITHIN "DIFFER" IF THE OFFDIAGONAL ELEMENT CONNECTING
C THEM IS LESS THAN "DIFFER".
C -- THIS SETS FULMIX=.FALSE.
C
C FOR THE PURPOSES OF THE NAO AND NBO PROGRAMS, THESE VALUES ARE SET:
C
C DIFFER = 1.0D-5
C THRESHOLD FOR CONSIDERING TWO VECTORS NONDEGENERATE IF
C ICONTR=1
C DONE = 1.0D-13
C THIS IS THE PARAMETER FOR CONVERGENCE OF THE OFF-DIAGONAL
C MATRIX ELEMENTS. (ABSOLUTE) --- Reduced from 1.0D-10
C on 8/31/88. A more converged Fock matrix was required
C for the NBO deletions with symmetry to work properly
C (EDG) ---
C
C EPS = 0.5D-13
C THIS PARAMETER HAS TO DO WITH THE MACHINE PRECISION AND SHOULD
C BE SET TO A VALUE BETWEEN "DONE" AND THE MACHINE PRECISION.
C --- Reduced from 1.0D-11. 8/31/88 (EDG) ---
C
LOGICAL FULMIX
DIMENSION A(NDIM,1),EIVR(NVDIM,1),EIVU(1)
C 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/
C
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
C
C FIND THE ABSOLUTELY LARGEST ELEMENT OF A
C
C 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
C 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
C IF MATRIX IS ALREADY EFFECTIVELY DIAGONAL,
C PUT DIAGONAL ELEMENTS IN EIVU AND RETURN
IF(ATOP.LT.DONE) GO TO 260
IF(OFFTOP.LT.DONE) GO TO 260
C
C CALCULATE THE STOPPING CRITERION -- DSTOP
C
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
C
C CALCULATE THE THRESHOLD, THRSH
C
THRSH= SQRT(D/AVGF)*ATOP
C TO MAKE THRSH DIFFERENT THAN ANY MATRIX ELEMENT OF A, MULTIPLY BY 0.99
THRSH=THRSH*PT99
IF(THRSH.LT.DONE) THRSH=DONE
C
C START A SWEEP
C
90 IFLAG=0
DO 250 JCOL=2,N
JCOL1=JCOL-1
DO 250 IROW=1,JCOL1
AIJ=A(IROW,JCOL)
C
C COMPARE THE OFF-DIAGONAL ELEMENT WITH THRSH
C
ABSAIJ=ABS(AIJ)
IF (ABSAIJ.LT.THRSH) GO TO 250
AII=A(IROW,IROW)
AJJ=A(JCOL,JCOL)
S=AJJ-AII
ABSS=ABS(S)
C DON'T ROTATE THE VECTORS IROW AND JCOL IF IROW AND JCOL WOULD STILL
C BE DEGENERATE WITHIN "DIFFER":
IF(FULMIX) GO TO 100
IF((ABSS.LT.DIFFER).AND.(ABSAIJ.LT.DIFFER)) GO TO 250
100 CONTINUE
C
C CHECK TO SEE IF THE CHOSEN ROTATION IS LESS THAN THE ROUNDING ERROR
C IF SO , THEN DO NOT ROTATE.
C
TEST=EPS*ABSS
IF (ABSAIJ.LT.TEST) GO TO 250
IFLAG=1
C
C IF THE ROTATION IS VERY CLOSE TO 45 DEGREES, SET SIN AND COS
C TO 1/(ROOT 2).
C
TEST=EPS*ABSAIJ
IF (ABSS.GT.TEST) GO TO 130
S=.707106781D0
C=S
GO TO 140
C
C CALCULATION OF SIN AND COS FOR ROTATION THAT IS NOT VERY CLOSE
C TO 45 DEGREES
C
130 T=AIJ/S
S=0.25D0/ SQRT(0.25D0+T*T)
C
C COS=C , SIN=S
C
C= SQRT(0.5D0+S)
S=2.D0*T*S/C
C
C CALCULATION OF THE NEW ELEMENTS OF MATRIX A
C
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
C
C ROTATION COMPLETED
C
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
C
C CALCULATE THE NEW NORM D AND COMPARE WITH DSTOP
C
S=AIJ/ATOP
D=D-S*S
IF (D.GT.DSTOP) GO TO 240
C
C RECALCULATE DSTOP AND THRSH TO DISCARD ROUNDING ERRORS
C
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
C
C PLACE EIGENVALUES IN EIVU
C
260 CONTINUE
DO 270 J=1,N
EIVU(J)=A(J,J)
270 CONTINUE
RETURN
END
C*****************************************************************************
SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(NDIM,NDIM),M(NCDIM),A(NCDIM,NCDIM),B(NCDIM)
C...DO A LIMITED TRANSFORMATION OF T, INCLUDING ONLY THE "NC" ROWS AND
C COLUMNS SPECIFIED IN THE VECTOR "M":
C
C IOPT= 1 : TAKE T=T*A
C IOPT= 0 : TAKE T=A(TRANSPOSE)*T*A
C IOPT=-1 : TAKE T=A(TRANSPOSE)*T
C
C
IF(IOPT.EQ.1) GO TO 100
C 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
C 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
C*****************************************************************************
SUBROUTINE MATMLT(A,B,V,NDIM,N)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(1),B(1),V(NDIM)
DATA ZERO/0.0D0/
C
C MULTIPLY A*B (USING SCRATCH VECTOR V), STORE RESULT IN A:
C
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
C*****************************************************************************
SUBROUTINE MATML2(A,B,V,NDIM,N)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(1),B(1),V(NDIM)
DATA ZERO/0.0D0/
C B=A(TRANSPOSE)*B
C MULTIPLY A(TRANSPOSE)*B (USING SCRATCH VECTOR V), STORE RESULT IN B:
C ASSUME A*B IS A SYMMETRIC MATRIX, SO ALMOST HALF THE WORK IS SAVED.
C THIS CAN BE THE SECOND STEP IN A SIMILARITY TRANSFORMATION OF B BY A.
C
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
C*****************************************************************************
FUNCTION NAMEAT(IZ)
C*****************************************************************************
C
C RETURN ATOMIC SYMBOL FOR NUCLEAR CHARGE IZ (.LE. 103):
C
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'/
C
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
C*****************************************************************************
SUBROUTINE NORMLZ(A,S,M,N)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(M,M),S(M,M)
C
DATA ZERO,ONE /0.0D0,1.0D0/
C
C NORMALIZE COLUMNS OF A
C
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
C*****************************************************************************
SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C RANK POSITIVE ELEMENTS OF INTEGER 'LIST', LOWEST VALUES FIRST.
C
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
C*****************************************************************************
SUBROUTINE PACK(T,NDIM,NBAS,L2)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
C
DATA ZERO/0.0D0/
C
C PACK: PACKS A SYMMETRIC MATRIX T INTO AN UPPER TRIANGULAR MATRIX.
C T SHOULD BE DIMENSIONED (NDIM,NDIM) IN THE CALLING ROUTINE:
C
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'
C
DO 300 I = II+1,NDIM*NDIM
T(I) = ZERO
300 CONTINUE
RETURN
END
C*****************************************************************************
SUBROUTINE RANK(EIG,N,NDIM,ARCRNK)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C ORDER NUMBERS IN 'EIG', HIGHEST VALUES FIRST,
C AND CONSTRUCT 'ARCRNK':
C ARCRNK(I) IS THE OLD LOCATION OF THE I-TH HIGHEST VALUE IN EIG
C NOTE: UPON RETURN, EIG(I) IS THE I-TH HIGHEST VALUE IN EIG
C IMPORTANT: NUMBERS IN EIG ARE NOT SWITCHED UNLESS THEY DIFFER
C BY MORE THAN "DIFFER": 5.0D-8
C
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
C*****************************************************************************
SUBROUTINE SIMTRN(A,T,V,NDIM,N)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C SIMILARITY TRANSFORM A ==> T(TRANSPOSE)*A*T, USING SCRATCH VECTOR V.
C
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
C*****************************************************************************
SUBROUTINE SIMTRS(A,S,V,NDIM,N)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
C
C SIMILARITY TRANSFORM A ==> S(TRANSPOSE)*A*S, USING SCRATCH VECTOR V.
C FAST VERSION --- ASSUMES RESULT IS A SYMMETRIC MATRIX
C
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
C*****************************************************************************
SUBROUTINE TRANSP(A,NDIM,N)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION A(NDIM,NDIM)
C
C TRANSPOSE MATRIX A, STORE RESULT IN A.
C
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
C*****************************************************************************
SUBROUTINE UNPACK(T,NDIM,NBAS,L2)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION T(1)
C
C UNPACK: UNPACKS AN UPPER TRIANGULAR MATRIX (VECTOR L2 LONG) INTO A
C SYMMETRIC MATRIX T(NBAS,NBAS). NOTE: T SHOULD BE DIMENSIONED
C (NDIM,NDIM) IN THE CALLING ROUTINE.
C
C FIRST SPREAD OUT THE L2 NUMBERS INTO THE UPPER PART OF THE WHOLE ARRAY.
C
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
C
C NOW FILL IN THE HOLES IN THE OUTPUT ARRAY.
C
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
C
RETURN
END
C*****************************************************************************
SUBROUTINE VALTBL(IAT,IVAL)
C*****************************************************************************
C
C VALENCE TABLE:
C
C Determine the number of sets of valence orbitals of each angular
C symmetry for atom number IAT. IVAL is an integer array LMAX+1
C long which returns the number of sets to the calling subroutine:
C the number of `s' subshells in IVAL(1), the number of `p' subshells
C in IVAL(2), etc...
C
C------------------------------------------------------------------------------
IMPLICIT REAL*8 (A-H,O-Z)
PARAMETER (LMAX = 3)
DIMENSION IVAL(4),ICORE(4),IORD(20)
C
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)
C
DATA IORD/1,1,3,1,3,1,5,3,1,5,3,1,7,5,3,1,7,5,3,1/
C
DO 10 L = 0,LMAX
IVAL(L+1) = 0
10 CONTINUE
C
C Count the number of filled or partially filled subshells:
C
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
C
C Remove the core subshells. Note: if there are more core orbitals
C in the effective core potential than in the nominal core table or
C from the CORE option, remove these extra core orbitals from the
C set of valence orbitals:
C
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
C*****************************************************************************
FUNCTION VECLEN(X,N,NDIM)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION X(NDIM)
DATA ZERO/0.0D0/
C
SUM = ZERO
DO 10 I = 1,N
SUM = SUM + X(I)*X(I)
10 CONTINUE
VECLEN = SQRT(SUM)
RETURN
END
C*****************************************************************************
SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR,
+ IERR)
C*****************************************************************************
C
C Solve the system of linear equations A * X = B for matrix X
C ~ ~ ~ ~
C Input
C -------
C * Coefficient matrix A of dimension (N,N) with actual
C dimension (NDIM,NDIM).
C * Matrix B of dimension (N,M) with actual dimension
C (NDIM,MDIM)
C * Working space SCR dimensioned (NDIM,NDIM+5).
C * Zero tolerance ZERTOL.
C * Threshold on Euclidean norm (vector length) of the
C error vector relative to the norm of a column of X.
C * Maximum number of iterations MAXIT allowed during
C iterative improvement.
C * Logical file number LFNPR for printing during iterative
C improvement. Set to zero to no printing is desired.
C
C Output
C --------
C * Solution X of dimension (N,M) with actual dimension
C (NDIM,MDIM).
C * Euclidean norm of the final error vector, EPS.
C * Number of iterations taken during interative improvement,
C MAXIT.
C * Error flag : IERR = -1 Iterative improvement did not
C converge
C IERR = 0 No errors encountered
C IERR = 1 A matrix is not invertible
C
C------------------------------------------------------------------------------
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/
C
IF(N.LT.1) STOP 'Dimension N is not positive'
C
C Partition scratch space:
C
I1 = 1
I2 = I1 + NDIM*NDIM
I3 = I2 + NDIM
I4 = I3 + NDIM
I5 = I4 + NDIM
I6 = I5 + NDIM
C
C Perform Gauss elimination with scaled partial pivoting:
C
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
C
C Loop over columns of X and B:
C
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
C
C Use back-substitution and iterative improvement to determine
C the solution X:
C
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
C
C Copy solution into X:
C
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
C
EPS = EPSMAX
MAXIT = ITSMAX
RETURN
END
C*****************************************************************************
SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG)
C*****************************************************************************
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/
C
C Initial IFLAG. If IFLAG is 1, then an even number of interchanges
C has been carried out. If equal to -1, then an odd number of inter-
C changes have taken place. If IFLAG is set to zero on return to the
C calling routine, then the matrix is not invertible:
C
IFLAG = 1
C
C Copy coefficient matrix A to W:
C
CALL COPY(A,W,NDIM,N,N)
C
C Initialize D and IPIVOT:
C
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
C
C Loop over rows, factorizing matrix W:
C
DO 100 K = 1,N-1
C
C Determine the pivot row ISTAR:
C
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
C
C Eliminate X(K) from rows K+1,...,N:
C
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
C*****************************************************************************
SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR)
C*****************************************************************************
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/
C
C Find initial guess for X by back substitution:
C
CALL COPY(B,E,NDIM,N,1)
CALL SUBST(X,W,E,IPIVOT,N,NDIM)
IF(MAXIT.EQ.0) RETURN
C
C Iterate until the vector length of the error vector relative to
C X is less than EPS:
C
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
C
C Print out iterative improvement info:
C
IF(LFNPR.GT.0) THEN
WRITE(LFNPR,900) ITER,RELLEN
END IF
C
C If too many iterations have taken place, halt furthur iterations:
C
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
C
C Error vector is converged:
C
ELSE
IF(LFNPR.GT.0) WRITE(LFNPR,920)
EPS = RELLEN
MAXIT = ITER
RETURN
END IF
GOTO 10
C
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
C*****************************************************************************
SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM)
C*****************************************************************************
IMPLICIT REAL*8 (A-H,O-Z)
DIMENSION X(NDIM),W(NDIM,NDIM),B(NDIM),IPIVOT(NDIM)
DATA ZERO/0.0D0/
C
IF(N.EQ.1) THEN
X(1) = B(1)/W(1,1)
RETURN
END IF
C
C Use multipliers stored in W and back substitution to find X:
C
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
C*****************************************************************************
C
C E N D O F N B O P R O G R A M
C
C*****************************************************************************
C***********************************************************************GENDRV
C GENDRV
C GENDRV
C G E N N B O GENDRV
C GENDRV
C GENDRV
C GENERAL VERSION OF NBO PROGRAM GENDRV
C GENDRV
C GENDRV
C DRIVER ROUTINES: GENDRV
C GENDRV
C SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GENDRV
C SUBROUTINE CRDINP(TITLE,ATCOOR,BOHR) GENDRV
C SUBROUTINE BASINP GENDRV
C SUBROUTINE CONINP(CORE,ICORE) GENDRV
C SUBROUTINE SINP(CORE,UPPER) GENDRV
C SUBROUTINE DMINP(CORE,UPPER) GENDRV
C SUBROUTINE FINP(CORE,UPPER,END) GENDRV
C SUBROUTINE TINP(CORE) GENDRV
C SUBROUTINE DIPINP(CORE,UPPER,BOHR) GENDRV
C GENDRV
C***********************************************************************GENDRV
* PROGRAM GENNBO GENDRV
C***********************************************************************GENDRV
* IMPLICIT REAL*8 (A-H,O-Z) GENDRV
C GENDRV
* PARAMETER(MEMORY = 1000000) GENDRV
* DIMENSION CORE(MEMORY),NBOOPT(10) GENDRV
C GENDRV
* COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
* + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
* + LFNDAF,LFNDEF GENDRV
C GENDRV
* LFNIN = 5 GENDRV
* LFNPR = 6 GENDRV
C GENDRV
C Set NBO options. GENDRV
C 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
C GENDRV
C Perform the NPA/NBO/NLMO analyses. GENDRV
C GENDRV
* CALL NBO(CORE,MEMORY,NBOOPT) GENDRV
C GENDRV
* CALL EXIT GENDRV
* END GENDRV
C***********************************************************************GENDRV
* SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GENDRV
C***********************************************************************GENDRV
* IMPLICIT REAL*8 (A-H,O-Z) GENDRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) GENDRV
* LOGICAL END GENDRV
C 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
C GENDRV
* IF(REUSE) THEN GENDRV
C GENDRV
C Restore wavefunction information from the NBO DAF: GENDRV
C GENDRV
C Restore NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: GENDRV
C 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
C GENDRV
C No Fock matrix from ROHF, MCSCF, or CI wave functions: GENDRV
C GENDRV
* IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 GENDRV
C GENDRV
C Restore IATNO, IZNUC, LCTR, LANG: GENDRV
C 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
C GENDRV
C Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: GENDRV
C 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
C GENDRV
C Read wavefunction info, density matrix, etc. from LFNIN: GENDRV
C GENDRV
C Read in job title, atoms, nuclear charges, and coords: GENDRV
C GENDRV
* CALL CRDINP(CORE,CORE,BOHR) GENDRV
C GENDRV
C Read in the AO basis set: GENDRV
C GENDRV
* CALL CONINP(CORE,CORE) GENDRV
C GENDRV
C Read basis function labels and centers: GENDRV
C GENDRV
* CALL BASINP GENDRV
C GENDRV
C Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: GENDRV
C 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
C GENDRV
C Read the overlap matrix from LFNIN and store on the NBO DAF: GENDRV
C GENDRV
* IF(.NOT.ORTHO) CALL SINP(CORE,UPPER) GENDRV
C GENDRV
C Read the density matrix from LFNIN and store on the NBO DAF: GENDRV
C GENDRV
* CALL DMINP(CORE,UPPER) GENDRV
* IF(DENOP) IWDM = 0 GENDRV
C GENDRV
C Read the Fock matrix from LFNIN and store on the NBO DAF: GENDRV
C 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
C GENDRV
C Read the AO to MO transformation matrix from LFNIN and store on the GENDRV
C NBO DAF: GENDRV
C GENDRV
* CALL TINP(CORE) GENDRV
C GENDRV
C Read the dipole integrals from LFNIN and store on the NBO DAF: GENDRV
C GENDRV
* CALL DIPINP(CORE,UPPER,BOHR) GENDRV
* END IF GENDRV
* RETURN GENDRV
* END GENDRV
C***********************************************************************GENDRV
* SUBROUTINE CRDINP(TITLE,ATCOOR,BOHR) GENDRV
C***********************************************************************GENDRV
* IMPLICIT REAL*8 (A-H,O-Z) GENDRV
* DIMENSION KEYWD(6),KCOORD(6) GENDRV
* LOGICAL ERROR,END,BOHR,EQUAL GENDRV
C 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
C GENDRV
* DIMENSION TITLE(10),ATCOOR(3*NATOMS) GENDRV
C GENDRV
* DATA KCOORD/1H$,1HC,1HO,1HO,1HR,1HD/ GENDRV
* DATA TOANG/0.529177249/ GENDRV
C GENDRV
C Search LFNIN for $COORD datalist: GENDRV
C 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
C GENDRV
C Read job title and store on NBO DAF: GENDRV
C GENDRV
* READ(LFNIN,1000) (TITLE(I),I=1,10) GENDRV
* NFILE = 2 GENDRV
* CALL NBWRIT(TITLE,10,NFILE) GENDRV
C GENDRV
C Loop over atoms, reading atomic number, nuclear charge, and coords: GENDRV
C 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
C GENDRV
C Convert atomic coords to angstroms if entered in bohr: GENDRV
C GENDRV
* IF(BOHR) THEN GENDRV
* DO 200 I = 1,3*NATOMS GENDRV
* ATCOOR(I) = ATCOOR(I) * TOANG GENDRV
* 200 CONTINUE GENDRV
* END IF GENDRV
C GENDRV
C Store the atomic coordinates on the NBO DAF: GENDRV
C GENDRV
* NFILE = 9 GENDRV
* CALL NBWRIT(ATCOOR,3*NATOMS,NFILE) GENDRV
* RETURN GENDRV
C GENDRV
*1000 FORMAT(10A8) GENDRV
* END GENDRV
C***********************************************************************GENDRV
* SUBROUTINE BASINP GENDRV
C***********************************************************************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
C 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
C 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
C GENDRV
C Search LFNIN for $BASIS datalist: GENDRV
C 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
C GENDRV
C Read in BOTH LCTR and LANG arrays: GENDRV
C 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
C GENDRV
C Keyword CENTER -- basis function centers: GENDRV
C 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
C GENDRV
C Keyword LABEL -- basis orbital symmetries: GENDRV
C 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
C GENDRV
C Unknown keyword -- halt program: GENDRV
C GENDRV
* WRITE(LFNPR,900) KEYWD GENDRV
* STOP GENDRV
C GENDRV
C Make sure that both the orbital centers and symmetries are read: GENDRV
C 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
C GENDRV
* 900 FORMAT(1X,'Unrecognized keyword >',6A1,'<') GENDRV
* END GENDRV
C***********************************************************************GENDRV
* SUBROUTINE CONINP(CORE,ICORE) GENDRV
C***********************************************************************GENDRV
* IMPLICIT REAL*8 (A-H,O-Z) GENDRV
* LOGICAL ERROR,END,EQUAL GENDRV
C GENDRV
* COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
* + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
* + LFNDAF,LFNDEF GENDRV
C 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
C 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
C GENDRV
C Search LFNIN for the $CONTRACT datalist: GENDRV
C 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
C 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
C GENDRV
C Keyword NSHELL -- number of shells of basis functions: GENDRV
C 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
C GENDRV
C Keyword NEXP -- number of orbital exponents in basis: GENDRV
C 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
C GENDRV
C If NSHELL and NEXP are not specified before the remainder of the GENDRV
C datalist, abort: GENDRV
C GENDRV
* IF(MSHELL.EQ.0.OR.MEXP.EQ.0) THEN GENDRV
* WRITE(LFNPR,900) GENDRV
* STOP GENDRV
* END IF GENDRV
C GENDRV
C If NSHELL and NEXP have been specified, partition the scratch vector:GENDRV
C GENDRV
C ICORE(I1) : NCOMP(1..NSHELL) GENDRV
C ICORE(I2) : NPRIM(1..NSHELL) GENDRV
C ICORE(I3) : NPTR(1..NSHELL) GENDRV
C CORE(I4) : EXP(1..NEXP) GENDRV
C CORE(I5) : CS(1..NEXP) GENDRV
C CORE(I6) : CP(1..NEXP) GENDRV
C CORE(I7) : CD(1..NEXP) GENDRV
C CORE(I8) : CF(1..NEXP) GENDRV
C 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
C GENDRV
C Keyword NCOMP -- number of components in each shell: GENDRV
C 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
C GENDRV
C Keyword NPRIM -- number of primitives in each shell: GENDRV
C 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
C GENDRV
C Keyword NPTR -- pointer array into exponents and coefficients: GENDRV
C 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
C GENDRV
C Keyword EXP -- orbital exponents: GENDRV
C 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
C GENDRV
C Keyword CS -- s orbital coefficients: GENDRV
C 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
C GENDRV
C Keyword CP -- p orbital coefficients: GENDRV
C 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
C GENDRV
C Keyword CD -- d orbital coefficients: GENDRV
C 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
C GENDRV
C Keyword CF -- f orbital coefficients: GENDRV
C 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
C GENDRV
C $END -- $CONTRACT datalist complete: GENDRV
C 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
C GENDRV
C Write info obtained in the datalist on the NBO DAF: GENDRV
C GENDRV
* LEN = IEND - 1 GENDRV
* NFILE = 5 GENDRV
* CALL NBWRIT(CORE,LEN,NFILE) GENDRV
* RETURN GENDRV
* END IF GENDRV
C GENDRV
C Unknown keyword -- halt program: GENDRV
C GENDRV
* WRITE(LFNPR,910) KEYWD GENDRV
* STOP GENDRV
C 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
C***********************************************************************GENDRV
* SUBROUTINE SINP(CORE,UPPER) GENDRV
C***********************************************************************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
C 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
C GENDRV
* DATA KOVER/1H$,1HO,1HV,1HE,1HR/ GENDRV
C GENDRV
C Search LFNIN for $OVERLAP datalist: GENDRV
C 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
C GENDRV
C Number of elements to read in: GENDRV
C GENDRV
* NEL = NDIM*NDIM GENDRV
* IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV
C GENDRV
C Read in the AO overlap matrix: GENDRV
C 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
C GENDRV
C Store the overlap matrix on the NBO DAF: GENDRV
C GENDRV
* NFILE = 10 GENDRV
* CALL NBWRIT(CORE,NEL,NFILE) GENDRV
* RETURN GENDRV
* END GENDRV
C***********************************************************************GENDRV
* SUBROUTINE DMINP(CORE,UPPER) GENDRV
C***********************************************************************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
C 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
C GENDRV
* DATA KDENS/1H$,1HD,1HE,1HN,1HS/ GENDRV
C GENDRV
C Search LFNIN for $DENSITY datalist: GENDRV
C 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
C GENDRV
C Number of elements to read in: GENDRV
C GENDRV
* NEL = NDIM*NDIM GENDRV
* IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV
C GENDRV
C Read in the AO density matrix: GENDRV
C 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
C GENDRV
C Store the density matrix on the NBO DAF: GENDRV
C GENDRV
* NFILE = 20 GENDRV
* CALL NBWRIT(CORE,NEL,NFILE) GENDRV
C GENDRV
C Read in and store the beta density matrix if this is open shell: GENDRV
C 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
C***********************************************************************GENDRV
* SUBROUTINE FINP(CORE,UPPER,END) GENDRV
C***********************************************************************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
C 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
C GENDRV
* DATA KFOCK/1H$,1HF,1HO,1HC,1HK/ GENDRV
C GENDRV
C Search LFNIN for $FOCK datalist: GENDRV
C 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
C GENDRV
C Number of elements to read in: GENDRV
C GENDRV
* NEL = NDIM*NDIM GENDRV
* IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV
C GENDRV
C Read in the AO Fock matrix: GENDRV
C 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
C GENDRV
C Store the Fock matrix on the NBO DAF: GENDRV
C GENDRV
* NFILE = 30 GENDRV
* CALL NBWRIT(CORE,NEL,NFILE) GENDRV
C GENDRV
C Read in and store the beta Fock matrix if this is open shell: GENDRV
C 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
C***********************************************************************GENDRV
* SUBROUTINE TINP(CORE) GENDRV
C***********************************************************************GENDRV
* IMPLICIT REAL*8 (A-H,O-Z) GENDRV
* DIMENSION CORE(1) GENDRV
* DIMENSION KEYWD(6),KAOMO(7) GENDRV
* LOGICAL ERROR,END,EQUAL GENDRV
C 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
C GENDRV
* DATA KAOMO/1H$,1HL,1HC,1HA,1HO,1HM,1HO/ GENDRV
C GENDRV
C Search LFNIN for $LCAOMO datalist: GENDRV
C 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
C GENDRV
C Read in the AO to MO transformation matrix: GENDRV
C 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
C GENDRV
C Store the transformation matrix on the NBO DAF: GENDRV
C GENDRV
* NFILE = 40 GENDRV
* CALL NBWRIT(CORE,NEL,NFILE) GENDRV
C GENDRV
C Read in and store the beta transformation matrix if this is an open GENDRV
C shell wavevfunction: GENDRV
C 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
C***********************************************************************GENDRV
* SUBROUTINE DIPINP(CORE,UPPER,BOHR) GENDRV
C***********************************************************************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
C 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
C GENDRV
* DATA KDIPOL/1H$,1HD,1HI,1HP,1HO,1HL/ GENDRV
* DATA TOANG/0.529177249/ GENDRV
C GENDRV
C Search LFNIN for $DIPOLE datalist: GENDRV
C 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
C GENDRV
C Number of elements to read in: GENDRV
C GENDRV
* NEL = NDIM*NDIM GENDRV
* IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV
C GENDRV
C Read in the x dipole integral matrix: GENDRV
C 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
C GENDRV
C Convert to angstroms, if necessary: GENDRV
C GENDRV
* IF(BOHR) THEN GENDRV
* DO 30 I = 1,NEL GENDRV
* CORE(I) = CORE(I) * TOANG GENDRV
* 30 CONTINUE GENDRV
* END IF GENDRV
C GENDRV
C Store the dipole integral matrix on the NBO DAF: GENDRV
C GENDRV
* NFILE = 50 GENDRV
* CALL NBWRIT(CORE,NEL,NFILE) GENDRV
C GENDRV
C Read in the y dipole integral matrix: GENDRV
C 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
C GENDRV
C Convert to angstroms, if necessary: GENDRV
C GENDRV
* IF(BOHR) THEN GENDRV
* DO 50 I = 1,NEL GENDRV
* CORE(I) = CORE(I) * TOANG GENDRV
* 50 CONTINUE GENDRV
* END IF GENDRV
C GENDRV
* NFILE = 51 GENDRV
* CALL NBWRIT(CORE,NEL,NFILE) GENDRV
C GENDRV
C Read in the z dipole integral matrix: GENDRV
C 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
C GENDRV
C Convert to angstroms, if necessary: GENDRV
C GENDRV
* IF(BOHR) THEN GENDRV
* DO 70 I = 1,NEL GENDRV
* CORE(I) = CORE(I) * TOANG GENDRV
* 70 CONTINUE GENDRV
* END IF GENDRV
C GENDRV
* NFILE = 52 GENDRV
* CALL NBWRIT(CORE,NEL,NFILE) GENDRV
C GENDRV
* RETURN GENDRV
* END GENDRV
C***********************************************************************GENDRV
C GENDRV
C E N D O F G E N N B O R O U T I N E S GENDRV
C GENDRV
C***********************************************************************GENDRV
C***********************************************************************G90DRV
C G90DRV
C G90DRV
C G 9 0 N B O G90DRV
C G90DRV
C G90DRV
C GAUSSIAN 90 VERSION OF NBO PROGRAM G90DRV
C G90DRV
C G90DRV
C DRIVER ROUTINES: G90DRV
C G90DRV
C SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G90DRV
C SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G90DRV
C SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G90DRV
C G90DRV
C***********************************************************************G90DRV
* SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G90DRV
C***********************************************************************G90DRV
* IMPLICIT REAL*8 (A-H,O-Z) G90DRV
C G90DRV
* PARAMETER (MAXFIL = 40) G90DRV
C 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
C G90DRV
* DIMENSION CORE(MEMORY),IOP(50) G90DRV
* DIMENSION NBOOPT(10) G90DRV
C G90DRV
* DATA TENTH/0.1D0/ G90DRV
C G90DRV
* LFNIN = 5 G90DRV
* LFNPR = 6 G90DRV
C G90DRV
C Set NBO options. G90DRV
C G90DRV
* DO 10 I = 1,9 G90DRV
* NBOOPT(I) = IOP(I+39) G90DRV
* 10 CONTINUE G90DRV
* NBOOPT(10) = 90 G90DRV
C G90DRV
C --- G90 patch --- G90DRV
C 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
C G90DRV
C --- NBO analysis --- G90DRV
C G90DRV
* ICONTR = 0 G90DRV
* IF(ABS(NBOOPT(1)).LT.2) THEN G90DRV
* CALL CHARPN(4HNBO ) G90DRV
* CALL NBO(CORE,MEMORY,NBOOPT) G90DRV
C G90DRV
C Store the name of the NBO direct access file on the RWFiles G90DRV
C 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
C G90DRV
C --- NBO energetic analysis --- G90DRV
C G90DRV
* ELSE IF(NBOOPT(1).EQ.2) THEN G90DRV
C G90DRV
C Retrieve the name of the NBO direct access file from the RWFiles G90DRV
C 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
C 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
C G90DRV
* RETURN G90DRV
* END G90DRV
C***********************************************************************G90DRV
* SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G90DRV
C***********************************************************************G90DRV
* IMPLICIT REAL*8 (A-H,O-Z) G90DRV
* LOGICAL GOTDEN G90DRV
C-----------------------------------------------------------------------G90DRV
C G90DRV
C Routine FEAOIN accesses the following records of the RWFs: G90DRV
C G90DRV
C 501 --- Total energy G90DRV
C 502 --- Job title G90DRV
C 506 --- Basis set information G90DRV
C 512 --- Effective core potential information G90DRV
C 514 --- AO overlap matrix G90DRV
C 518 --- AO dipole integrals G90DRV
C 524 --- MO coefficients (alpha) G90DRV
C 526 --- MO coefficients (beta) G90DRV
C 536 --- AO Fock matrix (alpha) G90DRV
C 538 --- AO Fock matrix (beta) G90DRV
C 603 --- AO density matrix G90DRV
C G90DRV
C ----------------------------------------------------------------------G90DRV
C G90DRV
C NBO Common blocks G90DRV
C G90DRV
* PARAMETER(MAXATM = 99,MAXBAS = 500) G90DRV
C 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
C G90DRV
C GAUSSIAN 90 Common blocks G90DRV
C 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
C G90DRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) G90DRV
* DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G90DRV
C G90DRV
C Obtain the following information: G90DRV
C G90DRV
C ROHF =.TRUE. If RHF open shell wavefunction G90DRV
C =.FALSE. otherwise G90DRV
C G90DRV
C UHF =.TRUE. If UHF wavefunction G90DRV
C =.FALSE. otherwise G90DRV
C G90DRV
C AUHF =.TRUE. If spin-annihilated UHF wavefunction G90DRV
C =.FALSE. otherwise G90DRV
C G90DRV
C CI =.TRUE. If CI wavefunction G90DRV
C =.FALSE. otherwise G90DRV
C G90DRV
C OPEN =.TRUE. If open shell wavefunction G90DRV
C =.FALSE. otherwise G90DRV
C G90DRV
C COMPLX =.TRUE. If complex wavefunction G90DRV
C =.FALSE. otherwise G90DRV
C (Note: The program is not capable of handling this.) G90DRV
C G90DRV
C NATOMS Number of atomic centers G90DRV
C G90DRV
C NDIM Dimension of matrices (overlap and density) G90DRV
C G90DRV
C NBAS Number of basis functions (.le.NDIM) G90DRV
C G90DRV
C IPSEUD Set to one if pseudopotentials are used. G90DRV
C G90DRV
C IWCUBF This pertains only basis sets with F functions. G90DRV
C G90DRV
C If cartesian F functions are input, set IWCUBF to: G90DRV
C 0, if these are to be transformed to the G90DRV
C standard set of pure F functions G90DRV
C 1, if these are to be transformed to the G90DRV
C cubic set of pure F functions G90DRV
C G90DRV
C If pure F functions are input, set to IWCUBF to: G90DRV
C 0, if these are standard F functions G90DRV
C 1, if these are cubic F functions G90DRV
C G90DRV
C IATNO(I),I=1,NATOMS G90DRV
C List of atomic numbers G90DRV
C G90DRV
C LCTR(I),I=1,NBAS G90DRV
C List of atomic centers of the basis functions G90DRV
C (LCTR(3)=2 if basis function 3 is on atom 2) G90DRV
C G90DRV
C LANG(I),I=1,NBAS G90DRV
C List of angular symmetry information for the AO basis G90DRV
C 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
C G90DRV
C Store job title on NBODAF: G90DRV
C 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
C G90DRV
C Get the number of atoms from NAT and store the atomic numbers in G90DRV
C IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G90DRV
C nuclear charges may not be equivalent if effective core potentials G90DRV
C (ECP) are used.) G90DRV
C 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
C G90DRV
C Restore the basis set to COMMON/B/: G90DRV
C G90DRV
* LEN = 30000 + INTOWP(14002) G90DRV
* CALL TREAD(506,EXX,LEN,1,LEN,1,0) G90DRV
C G90DRV
C The Gaussian programs do not use cubic f basis functions. G90DRV
C Determine which set of d and f functions are being used, G90DRV
C Cartesian or pure): G90DRV
C G90DRV
* IWCUBF = 0 G90DRV
* CALL ILSW(2,2,I5D6D) G90DRV
* CALL ILSW(2,16,I7F10F) G90DRV
C G90DRV
C Construct the AO information lists: LCTR and LANG G90DRV
C 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
C G90DRV
C Is an s orbital in the shell? G90DRV
C 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
C G90DRV
C s orbital: G90DRV
C G90DRV
* IBAS = IBAS + 1 G90DRV
* LCTR(IBAS) = NCTR G90DRV
* LANG(IBAS) = LISTS G90DRV
C G90DRV
C Is a set of p orbitals in the shell? G90DRV
C 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
C G90DRV
C p orbitals: G90DRV
C G90DRV
* DO 40 I = 1,3 G90DRV
* IBAS = IBAS + 1 G90DRV
* LCTR(IBAS) = NCTR G90DRV
* LANG(IBAS) = LISTP(I) G90DRV
* 40 CONTINUE G90DRV
C G90DRV
C d orbitals: G90DRV
C 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
C G90DRV
C f orbitals: G90DRV
C 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
C G90DRV
C Determine the type of wave function the density matrix is from: G90DRV
C 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
C G90DRV
C No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G90DRV
C G90DRV
* IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G90DRV
C G90DRV
C Expectation values of the Fock operator are in atomic units: G90DRV
C G90DRV
* MUNIT = 0 G90DRV
C G90DRV
C Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G90DRV
C 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
C G90DRV
C Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G90DRV
C 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
C G90DRV
C Fetch the total energy from the RWF and store it on the NBODAF: G90DRV
C 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
C G90DRV
C Store the atomic coordinates on the NBO DAF: (Note that these G90DRV
C coordinates are used in the calculation of dipole moments.) G90DRV
C 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
C G90DRV
C Store the overlap matrix on the NBODAF: G90DRV
C 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
C G90DRV
C Store the density matrices on the NBODAF: G90DRV
C 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
C 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
C G90DRV
* IF(OPEN) THEN G90DRV
* NFILE = 21 G90DRV
* CALL NBWRIT(CORE(L2+1),L2,NFILE) G90DRV
* END IF G90DRV
C G90DRV
C Store the Fock matrices on the NBODAF: G90DRV
C 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
C 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
C G90DRV
C Store the AO to MO transformation matrices on the NBODAF: G90DRV
C 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
C 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
C G90DRV
C Store the x,y,z dipole integrals on the NBODAF: G90DRV
C 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
C G90DRV
C Store the AO basis set info on the NBO DAF: (Note that two integers G90DRV
C and three integer arrays are stored first. Also remember that ICORE G90DRV
C and CORE occupy the same memory.) G90DRV
C 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
C G90DRV
C Determine if Cartesian or pure D and F functions are used: G90DRV
C G90DRV
* CALL ILSW(2,2,I5D6D) G90DRV
* CALL ILSW(2,16,I7F10F) G90DRV
C G90DRV
C NCOMP(I) -- the number of components in the Ith shell: G90DRV
C 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
C G90DRV
C Determine if an S orbital is in the shell: G90DRV
C 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
C G90DRV
C S orbital: G90DRV
C G90DRV
* ICORE(II) = ICORE(II) + 1 G90DRV
C G90DRV
C Determine if a set of P orbitals is in the shell: G90DRV
C 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
C G90DRV
C P orbital: G90DRV
C G90DRV
* ICORE(II) = ICORE(II) + 3 G90DRV
C G90DRV
C If MAXL is less than 2 then there are no D or F orbitals: G90DRV
C If MAXL is greater than 2 then there must be F orbitals: G90DRV
C G90DRV
* 340 IF(MAXL.LT.2) GO TO 400 G90DRV
* IF(MAXL.GT.2) GO TO 370 G90DRV
C G90DRV
C D orbital: G90DRV
C G90DRV
* IMAX = I5D6D + 5 G90DRV
* ICORE(II) = ICORE(II) + IMAX G90DRV
C G90DRV
C If MAXL is less than 3 then there are no F orbitals: G90DRV
C G90DRV
* 370 IF(MAXL.LT.3) GO TO 400 G90DRV
C G90DRV
C F orbital: G90DRV
C G90DRV
* IMAX=7 G90DRV
* IF(I7F10F.EQ.1) IMAX=10 G90DRV
* ICORE(II) = ICORE(II) + IMAX G90DRV
C G90DRV
C Skip here when no more orbitals are found: G90DRV
C G90DRV
* 400 CONTINUE G90DRV
* 420 CONTINUE G90DRV
C G90DRV
C NPRIM(I) -- the number of gaussian primitives in the Ith shell: G90DRV
C G90DRV
* DO 480 I = 1,NSHELL G90DRV
* II = II + 1 G90DRV
* ICORE(II) = SHELLN(I) G90DRV
* 480 CONTINUE G90DRV
C G90DRV
C NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G90DRV
C EXP, CS, CP, etc.: G90DRV
C G90DRV
* DO 490 I = 1,NSHELL G90DRV
* II = II + 1 G90DRV
* ICORE(II) = SHELLA(I) G90DRV
* 490 CONTINUE G90DRV
C G90DRV
C EXP(I) -- orbital exponents indexed by NPTR: G90DRV
C G90DRV
* DO 500 I = 1,NEXP G90DRV
* II = II + 1 G90DRV
* CORE(II) = EXX(I) G90DRV
* 500 CONTINUE G90DRV
C G90DRV
C CS,CP -- orbital coefficients: G90DRV
C 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
C G90DRV
C Zero CD and CF arrays: G90DRV
C G90DRV
* IHOLD = II G90DRV
* DO 550 I = 1,2*NEXP G90DRV
* II = II + 1 G90DRV
* CORE(II) = ZERO G90DRV
* 550 CONTINUE G90DRV
C G90DRV
C Build CD and CF from C3 and C4: G90DRV
C 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
C G90DRV
* 900 WRITE(LFNPR,990) G90DRV
* RETURN G90DRV
C 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
C***********************************************************************G90DRV
* SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G90DRV
C***********************************************************************G90DRV
* IMPLICIT REAL*8 (A-H,O-Z) G90DRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) G90DRV
* LOGICAL NEW,ERROR,SEQ G90DRV
C 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
C G90DRV
C If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G90DRV
C DAF to the RWFs. G90DRV
C 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
C G90DRV
C If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G90DRV
C 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
C G90DRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ', G90DRV
* + 'subroutine DELSCF.') G90DRV
* END G90DRV
C***********************************************************************G90DRV
C G90DRV
C E N D O F G 9 0 N B O R O U T I N E S G90DRV
C G90DRV
C***********************************************************************G90DRV
C***********************************************************************G88DRV
C G88DRV
C G88DRV
C G 8 8 N B O G88DRV
C G88DRV
C G88DRV
C GAUSSIAN 88 VERSION OF NBO PROGRAM G88DRV
C G88DRV
C G88DRV
C DRIVER ROUTINES: G88DRV
C G88DRV
C SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G88DRV
C SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G88DRV
C SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G88DRV
C G88DRV
C***********************************************************************G88DRV
* SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G88DRV
C***********************************************************************G88DRV
* IMPLICIT REAL*8 (A-H,O-Z) G88DRV
C G88DRV
* PARAMETER (MAXFIL = 40) G88DRV
C 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
C G88DRV
* DIMENSION CORE(1),IOP(50) G88DRV
* DIMENSION NBOOPT(10) G88DRV
C G88DRV
* LFNIN = 5 G88DRV
* LFNPR = 6 G88DRV
C G88DRV
* DATA TENTH/0.1D0/ G88DRV
C G88DRV
C Set NBO options. G88DRV
C G88DRV
* DO 10 I = 1,9 G88DRV
* NBOOPT(I) = IOP(I+39) G88DRV
* 10 CONTINUE G88DRV
* NBOOPT(10) = 88 G88DRV
C G88DRV
C --- NBO analysis --- G88DRV
C G88DRV
* ICONTR = 0 G88DRV
* IF(ABS(NBOOPT(1)).LT.2) THEN G88DRV
* CALL CHARPN(4HNBO ) G88DRV
* CALL NBO(CORE,MEMORY,NBOOPT) G88DRV
C G88DRV
C Store the name of the NBO direct access file on the RWFiles G88DRV
C 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
C G88DRV
C --- NBO energetic analysis --- G88DRV
C G88DRV
* ELSE IF(NBOOPT(1).EQ.2) THEN G88DRV
C G88DRV
C Retrieve the name of the NBO direct access file from the RWFiles G88DRV
C 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
C 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
C G88DRV
* RETURN G88DRV
* END G88DRV
C***********************************************************************G88DRV
* SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G88DRV
C***********************************************************************G88DRV
* IMPLICIT REAL*8 (A-H,O-Z) G88DRV
* LOGICAL GOTDEN G88DRV
C-----------------------------------------------------------------------G88DRV
C G88DRV
C Routine FEAOIN accesses the following records of the RWFs: G88DRV
C G88DRV
C 501 --- Total energy G88DRV
C 502 --- Job title G88DRV
C 506 --- Basis set information G88DRV
C 512 --- Effective core potential information G88DRV
C 514 --- AO overlap matrix G88DRV
C 518 --- AO dipole integrals G88DRV
C 524 --- MO coefficients (alpha) G88DRV
C 526 --- MO coefficients (beta) G88DRV
C 536 --- AO Fock matrix (alpha) G88DRV
C 538 --- AO Fock matrix (beta) G88DRV
C 603 --- AO density matrix G88DRV
C G88DRV
C ----------------------------------------------------------------------G88DRV
C G88DRV
C NBO Common blocks G88DRV
C G88DRV
* PARAMETER(MAXATM = 99,MAXBAS = 500) G88DRV
C 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
C G88DRV
C GAUSSIAN 88 Common blocks G88DRV
C 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
C G88DRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) G88DRV
* DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G88DRV
C G88DRV
C Obtain the following information: G88DRV
C G88DRV
C ROHF =.TRUE. If RHF open shell wavefunction G88DRV
C =.FALSE. otherwise G88DRV
C G88DRV
C UHF =.TRUE. If UHF wavefunction G88DRV
C =.FALSE. otherwise G88DRV
C G88DRV
C AUHF =.TRUE. If spin-annihilated UHF wavefunction G88DRV
C =.FALSE. otherwise G88DRV
C G88DRV
C CI =.TRUE. If CI wavefunction G88DRV
C =.FALSE. otherwise G88DRV
C G88DRV
C OPEN =.TRUE. If open shell wavefunction G88DRV
C =.FALSE. otherwise G88DRV
C G88DRV
C COMPLX =.TRUE. If complex wavefunction G88DRV
C =.FALSE. otherwise G88DRV
C (Note: The program is not capable of handling this.) G88DRV
C G88DRV
C NATOMS Number of atomic centers G88DRV
C G88DRV
C NDIM Dimension of matrices (overlap and density) G88DRV
C G88DRV
C NBAS Number of basis functions (.le.NDIM) G88DRV
C G88DRV
C IPSEUD Set to one if pseudopotentials are used. G88DRV
C G88DRV
C IWCUBF This pertains only basis sets with F functions. G88DRV
C G88DRV
C If cartesian F functions are input, set IWCUBF to: G88DRV
C 0, if these are to be transformed to the G88DRV
C standard set of pure F functions G88DRV
C 1, if these are to be transformed to the G88DRV
C cubic set of pure F functions G88DRV
C G88DRV
C If pure F functions are input, set to IWCUBF to: G88DRV
C 0, if these are standard F functions G88DRV
C 1, if these are cubic F functions G88DRV
C G88DRV
C IATNO(I),I=1,NATOMS G88DRV
C List of atomic numbers G88DRV
C G88DRV
C LCTR(I),I=1,NBAS G88DRV
C List of atomic centers of the basis functions G88DRV
C (LCTR(3)=2 if basis function 3 is on atom 2) G88DRV
C G88DRV
C LANG(I),I=1,NBAS G88DRV
C List of angular symmetry information for the AO basis G88DRV
C 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
C G88DRV
C Store job title on NBODAF: G88DRV
C 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
C G88DRV
C Get the number of atoms from NAT and store the atomic numbers in G88DRV
C IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G88DRV
C nuclear charges may not be equivalent if effective core potentials G88DRV
C (ECP) are used.) G88DRV
C 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
C G88DRV
C Restore the basis set to COMMON/B/: G88DRV
C G88DRV
* LEN = 30000 + INTOWP(14002) G88DRV
* CALL TREAD(506,EXX,LEN,1,LEN,1,0) G88DRV
C G88DRV
C The Gaussian programs do not use cubic f basis functions. G88DRV
C Determine which set of d and f functions are being used, G88DRV
C Cartesian or pure): G88DRV
C G88DRV
* IWCUBF = 0 G88DRV
* CALL ILSW(2,2,I5D6D) G88DRV
* CALL ILSW(2,16,I7F10F) G88DRV
C G88DRV
C Construct the AO information lists: LCTR and LANG G88DRV
C 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
C G88DRV
C Is an s orbital in the shell? G88DRV
C 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
C G88DRV
C s orbital: G88DRV
C G88DRV
* IBAS = IBAS + 1 G88DRV
* LCTR(IBAS) = NCTR G88DRV
* LANG(IBAS) = LISTS G88DRV
C G88DRV
C Is a set of p orbitals in the shell? G88DRV
C 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
C G88DRV
C p orbitals: G88DRV
C G88DRV
* DO 40 I = 1,3 G88DRV
* IBAS = IBAS + 1 G88DRV
* LCTR(IBAS) = NCTR G88DRV
* LANG(IBAS) = LISTP(I) G88DRV
* 40 CONTINUE G88DRV
C G88DRV
C d orbitals: G88DRV
C 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
C G88DRV
C f orbitals: G88DRV
C 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
C G88DRV
C Determine the type of wave function the density matrix is from: G88DRV
C 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
C G88DRV
C No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G88DRV
C G88DRV
* IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G88DRV
C G88DRV
C Expectation values of the Fock operator are in atomic units: G88DRV
C G88DRV
* MUNIT = 0 G88DRV
C G88DRV
C Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G88DRV
C 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
C G88DRV
C Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G88DRV
C 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
C G88DRV
C Fetch the total energy from the RWF and store it on the NBODAF: G88DRV
C 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
C G88DRV
C Store the atomic coordinates on the NBO DAF: (Note that these G88DRV
C coordinates are used in the calculation of dipole moments.) G88DRV
C 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
C G88DRV
C Store the overlap matrix on the NBODAF: G88DRV
C 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
C G88DRV
C Store the density matrices on the NBODAF: G88DRV
C 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
C 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
C G88DRV
* IF(OPEN) THEN G88DRV
* NFILE = 21 G88DRV
* CALL NBWRIT(CORE(L2+1),L2,NFILE) G88DRV
* END IF G88DRV
C G88DRV
C Store the Fock matrices on the NBODAF: G88DRV
C 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
C 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
C G88DRV
C Store the AO to MO transformation matrices on the NBODAF: G88DRV
C 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
C 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
C G88DRV
C Store the x,y,z dipole integrals on the NBODAF: G88DRV
C 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
C G88DRV
C Store the AO basis set info on the NBO DAF: (Note that two integers G88DRV
C and three integer arrays are stored first. Also remember that ICORE G88DRV
C and CORE occupy the same memory.) G88DRV
C 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
C G88DRV
C Determine if Cartesian or pure D and F functions are used: G88DRV
C G88DRV
* CALL ILSW(2,2,I5D6D) G88DRV
* CALL ILSW(2,16,I7F10F) G88DRV
C G88DRV
C NCOMP(I) -- the number of components in the Ith shell: G88DRV
C 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
C G88DRV
C Determine if an S orbital is in the shell: G88DRV
C 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
C G88DRV
C S orbital: G88DRV
C G88DRV
* ICORE(II) = ICORE(II) + 1 G88DRV
C G88DRV
C Determine if a set of P orbitals is in the shell: G88DRV
C 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
C G88DRV
C P orbital: G88DRV
C G88DRV
* ICORE(II) = ICORE(II) + 3 G88DRV
C G88DRV
C If MAXL is less than 2 then there are no D or F orbitals: G88DRV
C If MAXL is greater than 2 then there must be F orbitals: G88DRV
C G88DRV
* 340 IF(MAXL.LT.2) GO TO 400 G88DRV
* IF(MAXL.GT.2) GO TO 370 G88DRV
C G88DRV
C D orbital: G88DRV
C G88DRV
* IMAX = I5D6D + 5 G88DRV
* ICORE(II) = ICORE(II) + IMAX G88DRV
C G88DRV
C If MAXL is less than 3 then there are no F orbitals: G88DRV
C G88DRV
* 370 IF(MAXL.LT.3) GO TO 400 G88DRV
C G88DRV
C F orbital: G88DRV
C G88DRV
* IMAX=7 G88DRV
* IF(I7F10F.EQ.1) IMAX=10 G88DRV
* ICORE(II) = ICORE(II) + IMAX G88DRV
C G88DRV
C Skip here when no more orbitals are found: G88DRV
C G88DRV
* 400 CONTINUE G88DRV
* 420 CONTINUE G88DRV
C G88DRV
C NPRIM(I) -- the number of gaussian primitives in the Ith shell: G88DRV
C G88DRV
* DO 480 I = 1,NSHELL G88DRV
* II = II + 1 G88DRV
* ICORE(II) = SHELLN(I) G88DRV
* 480 CONTINUE G88DRV
C G88DRV
C NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G88DRV
C EXP, CS, CP, etc.: G88DRV
C G88DRV
* DO 490 I = 1,NSHELL G88DRV
* II = II + 1 G88DRV
* ICORE(II) = SHELLA(I) G88DRV
* 490 CONTINUE G88DRV
C G88DRV
C EXP(I) -- orbital exponents indexed by NPTR: G88DRV
C G88DRV
* DO 500 I = 1,NEXP G88DRV
* II = II + 1 G88DRV
* CORE(II) = EXX(I) G88DRV
* 500 CONTINUE G88DRV
C G88DRV
C CS,CP -- orbital coefficients: G88DRV
C 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
C G88DRV
C Zero CD and CF arrays: G88DRV
C G88DRV
* IHOLD = II G88DRV
* DO 550 I = 1,2*NEXP G88DRV
* II = II + 1 G88DRV
* CORE(II) = ZERO G88DRV
* 550 CONTINUE G88DRV
C G88DRV
C Build CD and CF from C3 and C4: G88DRV
C 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
C G88DRV
* 900 WRITE(LFNPR,990) G88DRV
* RETURN G88DRV
C 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
C***********************************************************************G88DRV
* SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G88DRV
C***********************************************************************G88DRV
* IMPLICIT REAL*8 (A-H,O-Z) G88DRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) G88DRV
* LOGICAL NEW,ERROR,SEQ G88DRV
C 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
C G88DRV
C If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G88DRV
C DAF to the RWFs. G88DRV
C 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
C G88DRV
C If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G88DRV
C 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
C G88DRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ', G88DRV
* + 'subroutine DELSCF.') G88DRV
* END G88DRV
C***********************************************************************G88DRV
C G88DRV
C E N D O F G 8 8 N B O R O U T I N E S G88DRV
C G88DRV
C***********************************************************************G88DRV
C***********************************************************************G86DRV
C G86DRV
C G86DRV
C G 8 6 N B O G86DRV
C G86DRV
C G86DRV
C GAUSSIAN 86 VERSION OF NBO PROGRAM G86DRV
C G86DRV
C G86DRV
C DRIVER ROUTINES: G86DRV
C G86DRV
C SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G86DRV
C SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G86DRV
C SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G86DRV
C G86DRV
C***********************************************************************G86DRV
* SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G86DRV
C***********************************************************************G86DRV
* IMPLICIT REAL*8 (A-H,O-Z) G86DRV
C G86DRV
* PARAMETER (MAXFIL = 40) G86DRV
C 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
C G86DRV
* DIMENSION CORE(1),IOP(50) G86DRV
* DIMENSION NBOOPT(10) G86DRV
C G86DRV
* LFNIN = 5 G86DRV
* LFNPR = 6 G86DRV
C G86DRV
* DATA TENTH/0.1D0/ G86DRV
C G86DRV
C Set NBO options. G86DRV
C G86DRV
* DO 10 I = 1,9 G86DRV
* NBOOPT(I) = IOP(I+39) G86DRV
* 10 CONTINUE G86DRV
* NBOOPT(10) = 86 G86DRV
C G86DRV
C --- NBO analysis --- G86DRV
C G86DRV
* ICONTR = 0 G86DRV
* IF(ABS(NBOOPT(1)).LT.2) THEN G86DRV
* CALL CHARPN(4HNBO ) G86DRV
* CALL NBO(CORE,MEMORY,NBOOPT) G86DRV
C G86DRV
C Store the name of the NBO direct access file on the RWFiles G86DRV
C 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
C G86DRV
C --- NBO energetic analysis --- G86DRV
C G86DRV
* ELSE IF(NBOOPT(1).EQ.2) THEN G86DRV
C G86DRV
C Retrieve the name of the NBO direct access file from the RWFiles G86DRV
C 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
C 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
C G86DRV
* RETURN G86DRV
* END G86DRV
C***********************************************************************G86DRV
* SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G86DRV
C***********************************************************************G86DRV
* IMPLICIT REAL*8 (A-H,O-Z) G86DRV
C-----------------------------------------------------------------------G86DRV
C G86DRV
C Routine FEAOIN accesses the following records of the RWFs: G86DRV
C G86DRV
C 203 --- CI density matrix (alpha) G86DRV
C 204 --- CI density matrix (beta) G86DRV
C 501 --- Total energy G86DRV
C 502 --- Job title G86DRV
C 506 --- Basis set information G86DRV
C 512 --- Effective core potential information G86DRV
C 514 --- AO overlap matrix G86DRV
C 518 --- AO dipole integrals G86DRV
C 524 --- MO coefficients (alpha) G86DRV
C 526 --- MO coefficients (beta) G86DRV
C 528 --- SCF density matrix (alpha) G86DRV
C 530 --- SCF density matrix (beta) G86DRV
C 536 --- AO Fock matrix (alpha) G86DRV
C 538 --- AO Fock matrix (beta) G86DRV
C G86DRV
C ----------------------------------------------------------------------G86DRV
C G86DRV
C NBO Common blocks G86DRV
C G86DRV
* PARAMETER(MAXATM = 99,MAXBAS = 500) G86DRV
C 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
C G86DRV
C GAUSSIAN 86 Common blocks G86DRV
C 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
C G86DRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) G86DRV
* DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G86DRV
C G86DRV
C Obtain the following information: G86DRV
C G86DRV
C ROHF =.TRUE. If RHF open shell wavefunction G86DRV
C =.FALSE. otherwise G86DRV
C G86DRV
C UHF =.TRUE. If UHF wavefunction G86DRV
C =.FALSE. otherwise G86DRV
C G86DRV
C AUHF =.TRUE. If spin-annihilated UHF wavefunction G86DRV
C =.FALSE. otherwise G86DRV
C G86DRV
C CI =.TRUE. If CI wavefunction G86DRV
C =.FALSE. otherwise G86DRV
C G86DRV
C OPEN =.TRUE. If open shell wavefunction G86DRV
C =.FALSE. otherwise G86DRV
C G86DRV
C COMPLX =.TRUE. If complex wavefunction G86DRV
C =.FALSE. otherwise G86DRV
C (Note: The program is not capable of handling this.) G86DRV
C G86DRV
C NATOMS Number of atomic centers G86DRV
C G86DRV
C NDIM Dimension of matrices (overlap and density) G86DRV
C G86DRV
C NBAS Number of basis functions (.le.NDIM) G86DRV
C G86DRV
C IPSEUD Set to one if pseudopotentials are used. G86DRV
C G86DRV
C IWCUBF This pertains only basis sets with F functions. G86DRV
C G86DRV
C If cartesian F functions are input, set IWCUBF to: G86DRV
C 0, if these are to be transformed to the G86DRV
C standard set of pure F functions G86DRV
C 1, if these are to be transformed to the G86DRV
C cubic set of pure F functions G86DRV
C G86DRV
C If pure F functions are input, set to IWCUBF to: G86DRV
C 0, if these are standard F functions G86DRV
C 1, if these are cubic F functions G86DRV
C G86DRV
C IATNO(I),I=1,NATOMS G86DRV
C List of atomic numbers G86DRV
C G86DRV
C LCTR(I),I=1,NBAS G86DRV
C List of atomic centers of the basis functions G86DRV
C (LCTR(3)=2 if basis function 3 is on atom 2) G86DRV
C G86DRV
C LANG(I),I=1,NBAS G86DRV
C List of angular symmetry information for the AO basis G86DRV
C 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
C G86DRV
C Store job title on NBODAF: G86DRV
C 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
C G86DRV
C Get the number of atoms from NAT and store the atomic numbers in G86DRV
C IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G86DRV
C nuclear charges may not be equivalent if effective core potentials G86DRV
C (ECP) are used.) G86DRV
C 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
C G86DRV
C Restore the basis set to COMMON/B/: G86DRV
C G86DRV
* LEN = 6000 + INTOWP(2802) G86DRV
* CALL TREAD(506,EXX,LEN,1,LEN,1,0) G86DRV
C G86DRV
C The Gaussian programs do not use cubic f basis functions. G86DRV
C Determine which set of d and f functions are being used, G86DRV
C Cartesian or pure): G86DRV
C G86DRV
* IWCUBF = 0 G86DRV
* CALL ILSW(2,2,I5D6D) G86DRV
* CALL ILSW(2,16,I7F10F) G86DRV
C G86DRV
C Construct the AO information lists: LCTR and LANG G86DRV
C 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
C G86DRV
C Is an s orbital in the shell? G86DRV
C 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
C G86DRV
C s orbital: G86DRV
C G86DRV
* IBAS = IBAS + 1 G86DRV
* LCTR(IBAS) = NCTR G86DRV
* LANG(IBAS) = LISTS G86DRV
C G86DRV
C Is a set of p orbitals in the shell? G86DRV
C 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
C G86DRV
C p orbitals: G86DRV
C G86DRV
* DO 40 I = 1,3 G86DRV
* IBAS = IBAS + 1 G86DRV
* LCTR(IBAS) = NCTR G86DRV
* LANG(IBAS) = LISTP(I) G86DRV
* 40 CONTINUE G86DRV
C G86DRV
C d orbitals: G86DRV
C 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
C G86DRV
C f orbitals: G86DRV
C 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
C G86DRV
C Determine the type of wave function the density matrix is from: G86DRV
C 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
C G86DRV
C No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G86DRV
C G86DRV
* IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G86DRV
C G86DRV
C Expectation values of the Fock operator are in atomic units: G86DRV
C G86DRV
* MUNIT = 0 G86DRV
C G86DRV
C Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G86DRV
C 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
C G86DRV
C Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G86DRV
C 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
C G86DRV
C Fetch the total energy from the RWF and store it on the NBODAF: G86DRV
C 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
C G86DRV
C Store the atomic coordinates on the NBO DAF: (Note that these G86DRV
C coordinates are used in the calculation of dipole moments.) G86DRV
C 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
C G86DRV
C Store the overlap matrix on the NBODAF: G86DRV
C 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
C G86DRV
C Store the density matrices on the NBODAF: G86DRV
C 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
C G86DRV
C Store the Fock matrices on the NBODAF: G86DRV
C 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
C 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
C G86DRV
C Store the AO to MO transformation matrices on the NBODAF: G86DRV
C 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
C 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
C G86DRV
C Store the x,y,z dipole integrals on the NBODAF: G86DRV
C 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
C G86DRV
C Store the AO basis set info on the NBO DAF: (Note that two integers G86DRV
C and three integer arrays are stored first. Also remember that ICORE G86DRV
C and CORE occupy the same memory.) G86DRV
C 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
C G86DRV
C Determine if Cartesian or pure D and F functions are used: G86DRV
C G86DRV
* CALL ILSW(2,2,I5D6D) G86DRV
* CALL ILSW(2,16,I7F10F) G86DRV
C G86DRV
C NCOMP(I) -- the number of components in the Ith shell: G86DRV
C 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
C G86DRV
C Determine if an S orbital is in the shell: G86DRV
C 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
C G86DRV
C S orbital: G86DRV
C G86DRV
* ICORE(II) = ICORE(II) + 1 G86DRV
C G86DRV
C Determine if a set of P orbitals is in the shell: G86DRV
C 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
C G86DRV
C P orbital: G86DRV
C G86DRV
* ICORE(II) = ICORE(II) + 3 G86DRV
C G86DRV
C If MAXL is less than 2 then there are no D or F orbitals: G86DRV
C If MAXL is greater than 2 then there must be F orbitals: G86DRV
C G86DRV
* 340 IF(MAXL.LT.2) GO TO 400 G86DRV
* IF(MAXL.GT.2) GO TO 370 G86DRV
C G86DRV
C D orbital: G86DRV
C G86DRV
* IMAX = I5D6D + 5 G86DRV
* ICORE(II) = ICORE(II) + IMAX G86DRV
C G86DRV
C If MAXL is less than 3 then there are no F orbitals: G86DRV
C G86DRV
* 370 IF(MAXL.LT.3) GO TO 400 G86DRV
C G86DRV
C F orbital: G86DRV
C G86DRV
* IMAX=7 G86DRV
* IF(I7F10F.EQ.1) IMAX=10 G86DRV
* ICORE(II) = ICORE(II) + IMAX G86DRV
C G86DRV
C Skip here when no more orbitals are found: G86DRV
C G86DRV
* 400 CONTINUE G86DRV
* 420 CONTINUE G86DRV
C G86DRV
C NPRIM(I) -- the number of gaussian primitives in the Ith shell: G86DRV
C G86DRV
* DO 480 I = 1,NSHELL G86DRV
* II = II + 1 G86DRV
* ICORE(II) = SHELLN(I) G86DRV
* 480 CONTINUE G86DRV
C G86DRV
C NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G86DRV
C EXP, CS, CP, etc.: G86DRV
C G86DRV
* DO 490 I = 1,NSHELL G86DRV
* II = II + 1 G86DRV
* ICORE(II) = SHELLA(I) G86DRV
* 490 CONTINUE G86DRV
C G86DRV
C EXP(I) -- orbital exponents indexed by NPTR: G86DRV
C G86DRV
* DO 500 I = 1,NEXP G86DRV
* II = II + 1 G86DRV
* CORE(II) = EXX(I) G86DRV
* 500 CONTINUE G86DRV
C G86DRV
C CS,CP -- orbital coefficients: G86DRV
C 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
C G86DRV
C Zero CD and CF arrays: G86DRV
C G86DRV
* IHOLD = II G86DRV
* DO 550 I = 1,2*NEXP G86DRV
* II = II + 1 G86DRV
* CORE(II) = ZERO G86DRV
* 550 CONTINUE G86DRV
C G86DRV
C Build CD and CF from C3 and C4: G86DRV
C 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
C G86DRV
* 900 WRITE(LFNPR,1000) G86DRV
* RETURN G86DRV
C G86DRV
*1000 FORMAT(/1X,'The NBO program is not set up to handle complex ', G86DRV
* + 'wave functions') G86DRV
* END G86DRV
C***********************************************************************G86DRV
* SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G86DRV
C***********************************************************************G86DRV
* IMPLICIT REAL*8 (A-H,O-Z) G86DRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) G86DRV
* LOGICAL NEW,ERROR,SEQ G86DRV
C 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
C G86DRV
C If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G86DRV
C DAF to the RWFs. G86DRV
C 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
C G86DRV
C If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G86DRV
C 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
C G86DRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ', G86DRV
* + 'subroutine DELSCF.') G86DRV
* END G86DRV
C***********************************************************************G86DRV
C G86DRV
C E N D O F G 8 6 N B O R O U T I N E S G86DRV
C G86DRV
C***********************************************************************G86DRV
C***********************************************************************G82DRV
C G82DRV
C G82DRV
C G 8 2 N B O G82DRV
C G82DRV
C G82DRV
C GAUSSIAN 82 VERSION OF NBO PROGRAM G82DRV
C G82DRV
C G82DRV
C DRIVER ROUTINES: G82DRV
C G82DRV
C SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G82DRV
C SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G82DRV
C SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G82DRV
C G82DRV
C***********************************************************************G82DRV
* SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G82DRV
C***********************************************************************G82DRV
* IMPLICIT REAL*8 (A-H,O-Z) G82DRV
C G82DRV
* PARAMETER (MAXFIL = 40) G82DRV
C 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
C G82DRV
* DIMENSION CORE(1),IOP(50) G82DRV
* DIMENSION NBOOPT(10) G82DRV
C G82DRV
* LFNIN = 5 G82DRV
* LFNPR = 6 G82DRV
C G82DRV
* DATA TENTH/0.1D0/ G82DRV
C G82DRV
C Set NBO options. G82DRV
C G82DRV
* DO 10 I = 1,9 G82DRV
* NBOOPT(I) = IOP(I+39) G82DRV
* 10 CONTINUE G82DRV
* NBOOPT(10) = 82 G82DRV
C G82DRV
C --- NBO analysis --- G82DRV
C G82DRV
* ICONTR = 0 G82DRV
* IF(ABS(NBOOPT(1)).LT.2) THEN G82DRV
* CALL CHARPN(4HNBO ) G82DRV
* CALL NBO(CORE,MEMORY,NBOOPT) G82DRV
C G82DRV
C Store the name of the NBO direct access file on the RWFiles G82DRV
C 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
C G82DRV
C --- NBO energetic analysis --- G82DRV
C G82DRV
* ELSE IF(NBOOPT(1).EQ.2) THEN G82DRV
C G82DRV
C Retrieve the name of the NBO direct access file from the RWFiles G82DRV
C 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
C 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
C G82DRV
* RETURN G82DRV
* END G82DRV
C***********************************************************************G82DRV
* SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G82DRV
C***********************************************************************G82DRV
* IMPLICIT REAL*8 (A-H,O-Z) G82DRV
C-----------------------------------------------------------------------G82DRV
C G82DRV
C Routine FEAOIN accesses the following records of the RWFs: G82DRV
C G82DRV
C 203 --- CI density matrix (alpha) G82DRV
C 204 --- CI density matrix (beta) G82DRV
C 501 --- Total energy G82DRV
C 502 --- Job title G82DRV
C 506 --- Basis set information G82DRV
C 512 --- Effective core potential information G82DRV
C 514 --- AO overlap matrix G82DRV
C 518 --- x dipole integrals G82DRV
C 519 --- y dipole integrals G82DRV
C 520 --- z dipole integrals G82DRV
C 524 --- MO coefficients (alpha) G82DRV
C 526 --- MO coefficients (beta) G82DRV
C 528 --- SCF density matrix (alpha) G82DRV
C 530 --- SCF density matrix (beta) G82DRV
C 536 --- AO Fock matrix (alpha) G82DRV
C 538 --- AO Fock matrix (beta) G82DRV
C G82DRV
C ----------------------------------------------------------------------G82DRV
C G82DRV
C NBO Common blocks G82DRV
C G82DRV
* PARAMETER(MAXATM = 99,MAXBAS = 500) G82DRV
C 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
C G82DRV
C GAUSSIAN 82 Common blocks G82DRV
C 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
C G82DRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) G82DRV
* DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G82DRV
C G82DRV
C Obtain the following information: G82DRV
C G82DRV
C ROHF =.TRUE. If RHF open shell wavefunction G82DRV
C =.FALSE. otherwise G82DRV
C G82DRV
C UHF =.TRUE. If UHF wavefunction G82DRV
C =.FALSE. otherwise G82DRV
C G82DRV
C AUHF =.TRUE. If spin-annihilated UHF wavefunction G82DRV
C =.FALSE. otherwise G82DRV
C G82DRV
C CI =.TRUE. If CI wavefunction G82DRV
C =.FALSE. otherwise G82DRV
C G82DRV
C OPEN =.TRUE. If open shell wavefunction G82DRV
C =.FALSE. otherwise G82DRV
C G82DRV
C COMPLX =.TRUE. If complex wavefunction G82DRV
C =.FALSE. otherwise G82DRV
C (Note: The program is not capable of handling this.) G82DRV
C G82DRV
C NATOMS Number of atomic centers G82DRV
C G82DRV
C NDIM Dimension of matrices (overlap and density) G82DRV
C G82DRV
C NBAS Number of basis functions (.le.NDIM) G82DRV
C G82DRV
C IPSEUD Set to one if pseudopotentials are used. G82DRV
C G82DRV
C IWCUBF This pertains only basis sets with F functions. G82DRV
C G82DRV
C If cartesian F functions are input, set IWCUBF to: G82DRV
C 0, if these are to be transformed to the G82DRV
C standard set of pure F functions G82DRV
C 1, if these are to be transformed to the G82DRV
C cubic set of pure F functions G82DRV
C G82DRV
C If pure F functions are input, set to IWCUBF to: G82DRV
C 0, if these are standard F functions G82DRV
C 1, if these are cubic F functions G82DRV
C G82DRV
C IATNO(I),I=1,NATOMS G82DRV
C List of atomic numbers G82DRV
C G82DRV
C LCTR(I),I=1,NBAS G82DRV
C List of atomic centers of the basis functions G82DRV
C (LCTR(3)=2 if basis function 3 is on atom 2) G82DRV
C G82DRV
C LANG(I),I=1,NBAS G82DRV
C List of angular symmetry information for the AO basis G82DRV
C 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
C G82DRV
C Store job title on NBODAF: G82DRV
C 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
C G82DRV
C Get the number of atoms from NAT and store the atomic numbers in G82DRV
C IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G82DRV
C nuclear charges may not be equivalent if effective core potentials G82DRV
C (ECP) are used.) G82DRV
C 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
C G82DRV
C Restore the basis set to COMMON/B/: G82DRV
C G82DRV
* LEN = 1200 + INTOWP(562) G82DRV
* CALL TREAD(506,EXX,LEN,1,LEN,1,0) G82DRV
C G82DRV
C The Gaussian programs do not use cubic f basis functions. G82DRV
C Determine which set of d and f functions are being used, G82DRV
C Cartesian or pure): G82DRV
C G82DRV
* IWCUBF = 0 G82DRV
* CALL ILSW(2,2,I5D6D) G82DRV
* CALL ILSW(2,16,I7F10F) G82DRV
C G82DRV
C Construct the AO information lists: LCTR and LANG G82DRV
C 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
C G82DRV
C Is an s orbital in the shell? G82DRV
C 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
C G82DRV
C s orbital: G82DRV
C G82DRV
* IBAS = IBAS + 1 G82DRV
* LCTR(IBAS) = NCTR G82DRV
* LANG(IBAS) = LISTS G82DRV
C G82DRV
C Is a set of p orbitals in the shell? G82DRV
C 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
C G82DRV
C p orbitals: G82DRV
C G82DRV
* DO 40 I = 1,3 G82DRV
* IBAS = IBAS + 1 G82DRV
* LCTR(IBAS) = NCTR G82DRV
* LANG(IBAS) = LISTP(I) G82DRV
* 40 CONTINUE G82DRV
C G82DRV
C d orbitals: G82DRV
C 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
C G82DRV
C f orbitals: G82DRV
C 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
C G82DRV
C Determine the type of wave function the density matrix is from: G82DRV
C 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
C G82DRV
C No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G82DRV
C G82DRV
* IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G82DRV
C G82DRV
C Expectation values of the Fock operator are in atomic units: G82DRV
C G82DRV
* MUNIT = 0 G82DRV
C G82DRV
C Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G82DRV
C 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
C G82DRV
C Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G82DRV
C 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
C G82DRV
C Fetch the total energy from the RWF and store it on the NBODAF: G82DRV
C 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
C G82DRV
C Store the atomic coordinates on the NBO DAF: (Note that these G82DRV
C coordinates are used in the calculation of dipole moments.) G82DRV
C 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
C G82DRV
C Store the overlap matrix on the NBODAF: G82DRV
C 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
C G82DRV
C Store the density matrices on the NBODAF: G82DRV
C 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
C G82DRV
C Store the Fock matrices on the NBODAF: G82DRV
C 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
C 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
C G82DRV
C Store the AO to MO transformation matrices on the NBODAF: G82DRV
C 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
C 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
C G82DRV
C Store the x,y,z dipole integrals on the NBODAF: G82DRV
C 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
C G82DRV
C Store the AO basis set info on the NBO DAF: (Note that two integers G82DRV
C and three integer arrays are stored first. Also remember that ICORE G82DRV
C and CORE occupy the same memory.) G82DRV
C 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
C G82DRV
C Determine if Cartesian or pure D and F functions are used: G82DRV
C G82DRV
* CALL ILSW(2,2,I5D6D) G82DRV
* CALL ILSW(2,16,I7F10F) G82DRV
C G82DRV
C NCOMP(I) -- the number of components in the Ith shell: G82DRV
C 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
C G82DRV
C Determine if an S orbital is in the shell: G82DRV
C 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
C G82DRV
C S orbital: G82DRV
C G82DRV
* ICORE(II) = ICORE(II) + 1 G82DRV
C G82DRV
C Determine if a set of P orbitals is in the shell: G82DRV
C 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
C G82DRV
C P orbital: G82DRV
C G82DRV
* ICORE(II) = ICORE(II) + 3 G82DRV
C G82DRV
C If MAXL is less than 2 then there are no D or F orbitals: G82DRV
C If MAXL is greater than 2 then there must be F orbitals: G82DRV
C G82DRV
* 340 IF(MAXL.LT.2) GO TO 400 G82DRV
* IF(MAXL.GT.2) GO TO 370 G82DRV
C G82DRV
C D orbital: G82DRV
C G82DRV
* IMAX = I5D6D + 5 G82DRV
* ICORE(II) = ICORE(II) + IMAX G82DRV
C G82DRV
C If MAXL is less than 3 then there are no F orbitals: G82DRV
C G82DRV
* 370 IF(MAXL.LT.3) GO TO 400 G82DRV
C G82DRV
C F orbital: G82DRV
C G82DRV
* IMAX=7 G82DRV
* IF(I7F10F.EQ.1) IMAX=10 G82DRV
* ICORE(II) = ICORE(II) + IMAX G82DRV
C G82DRV
C Skip here when no more orbitals are found: G82DRV
C G82DRV
* 400 CONTINUE G82DRV
* 420 CONTINUE G82DRV
C G82DRV
C NPRIM(I) -- the number of gaussian primitives in the Ith shell: G82DRV
C G82DRV
* DO 480 I = 1,NSHELL G82DRV
* II = II + 1 G82DRV
* ICORE(II) = SHELLN(I) G82DRV
* 480 CONTINUE G82DRV
C G82DRV
C NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G82DRV
C EXP, CS, CP, etc.: G82DRV
C G82DRV
* DO 490 I = 1,NSHELL G82DRV
* II = II + 1 G82DRV
* ICORE(II) = SHELLA(I) G82DRV
* 490 CONTINUE G82DRV
C G82DRV
C EXP(I) -- orbital exponents indexed by NPTR: G82DRV
C G82DRV
* DO 500 I = 1,NEXP G82DRV
* II = II + 1 G82DRV
* CORE(II) = EXX(I) G82DRV
* 500 CONTINUE G82DRV
C G82DRV
C CS,CP -- orbital coefficients: G82DRV
C 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
C G82DRV
C Zero CD and CF arrays: G82DRV
C G82DRV
* IHOLD = II G82DRV
* DO 550 I = 1,2*NEXP G82DRV
* II = II + 1 G82DRV
* CORE(II) = ZERO G82DRV
* 550 CONTINUE G82DRV
C G82DRV
C Build CD and CF from C3 and C4: G82DRV
C 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
C G82DRV
* 900 WRITE(LFNPR,1000) G82DRV
* RETURN G82DRV
C G82DRV
*1000 FORMAT(/1X,'The NBO program is not set up to handle complex ', G82DRV
* + 'wave functions') G82DRV
* END G82DRV
C***********************************************************************G82DRV
* SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G82DRV
C***********************************************************************G82DRV
* IMPLICIT REAL*8 (A-H,O-Z) G82DRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) G82DRV
* LOGICAL NEW,ERROR,SEQ G82DRV
C 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
C G82DRV
C If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G82DRV
C DAF to the RWFs. G82DRV
C 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
C G82DRV
C If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G82DRV
C 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
C G82DRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ', G82DRV
* + 'subroutine DELSCF.') G82DRV
* END G82DRV
C***********************************************************************G82DRV
C G82DRV
C E N D O F G 8 2 N B O R O U T I N E S G82DRV
C G82DRV
C***********************************************************************G82DRV
C***********************************************************************GMSDRV
C GMSDRV
C GMSDRV
C G M S N B O GMSDRV
C GMSDRV
C GMSDRV
C GAMESS VERSION OF NBO PROGRAM GMSDRV
C GMSDRV
C GMSDRV
C DRIVER ROUTINES: GMSDRV
C GMSDRV
C SUBROUTINE RUNNBO GMSDRV
C SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GMSDRV
C SUBROUTINE DELSCF(A,IA) GMSDRV
C GMSDRV
C***********************************************************************GMSDRV
* SUBROUTINE RUNNBO GMSDRV
C***********************************************************************GMSDRV
* IMPLICIT REAL*8 (A-H,O-Z) GMSDRV
* DIMENSION NBOOPT(10) GMSDRV
C GMSDRV
* COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GMSDRV
* + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GMSDRV
* + LFNDAF,LFNDEF GMSDRV
C GMSDRV
C GAMESS Common Block: GMSDRV
C GMSDRV
* COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(99) GMSDRV
* COMMON /FMCOM/ CORE(1) GMSDRV
C GMSDRV
* LFNIN = IR GMSDRV
* LFNPR = IW GMSDRV
C GMSDRV
C Determine the amount of available memory for the NBO analysis. GMSDRV
C GMSDRV
* CALL VALFM(ICUR) GMSDRV
* CALL GOTFM(MEMORY) GMSDRV
C GMSDRV
C Set NBO options. GMSDRV
C 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
C GMSDRV
C Perform the NPA/NBO/NLMO analyses. GMSDRV
C GMSDRV
* CALL NBO(CORE(ICUR+1),MEMORY,NBOOPT) GMSDRV
C GMSDRV
C Perform the energetic analysis. GMSDRV
C 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
C GMSDRV
* 20 RETURN GMSDRV
* END GMSDRV
C***********************************************************************GMSDRV
* SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GMSDRV
C***********************************************************************GMSDRV
* IMPLICIT REAL*8 (A-H,O-Z) GMSDRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) GMSDRV
C GMSDRV
C ----------------------------------------------------------------------GMSDRV
C GMSDRV
C This routine fetchs basis set information from the GAMESS common GMSDRV
C blocks and stores it in the NBO common blocks and direct access file GMSDRV
C (DAF) for use by the NBO analysis. GMSDRV
C GMSDRV
C ----------------------------------------------------------------------GMSDRV
C GMSDRV
C Routine FEAOIN accesses the following records of the dictionary file:GMSDRV
C GMSDRV
C 2 --- Total energy GMSDRV
C 12 --- AO overlap matrix GMSDRV
C 14 --- AO Fock matrix (alpha) GMSDRV
C 15 --- AO to MO transformation matrix (alpha) GMSDRV
C 16 --- AO density matrix (bond order matrix) (alpha) GMSDRV
C 18 --- AO Fock matrix (beta) GMSDRV
C 19 --- AO to MO transformation matrix (beta) GMSDRV
C 20 --- AO density matrix (bond order matrix) (beta) GMSDRV
C 23 --- X dipole integrals GMSDRV
C 24 --- Y dipole integrals GMSDRV
C 25 --- Z dipole integrals GMSDRV
C GMSDRV
C ----------------------------------------------------------------------GMSDRV
C GMSDRV
C NBO Common blocks GMSDRV
C GMSDRV
C 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
C GMSDRV
* DIMENSION LABELS(20),WFNS(6) GMSDRV
* LOGICAL WSTATE(6,6) GMSDRV
C GMSDRV
C GAMESS Common blocks GMSDRV
C 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
C GMSDRV
C Obtain the following information: GMSDRV
C GMSDRV
C ROHF =.TRUE. If RHF open shell wavefunction GMSDRV
C =.FALSE. otherwise GMSDRV
C GMSDRV
C UHF =.TRUE. If UHF wavefunction GMSDRV
C =.FALSE. otherwise GMSDRV
C GMSDRV
C AUHF =.TRUE. If spin-annihilated UHF wavefunction GMSDRV
C =.FALSE. otherwise GMSDRV
C GMSDRV
C CI =.TRUE. If CI wavefunction GMSDRV
C =.FALSE. otherwise GMSDRV
C GMSDRV
C OPEN =.TRUE. If open shell wavefunction GMSDRV
C =.FALSE. otherwise GMSDRV
C GMSDRV
C COMPLX =.TRUE. If complex wavefunction GMSDRV
C =.FALSE. otherwise GMSDRV
C (Note: The program is not capable of handling this.) GMSDRV
C GMSDRV
C NATOMS Number of atomic centers GMSDRV
C GMSDRV
C NDIM Dimension of matrices (overlap and density) GMSDRV
C GMSDRV
C NBAS Number of basis functions (.le.NDIM) GMSDRV
C GMSDRV
C IPSEUD Set to one if pseudopotentials are used. GMSDRV
C GMSDRV
C IWCUBF This pertains only basis sets with F functions. GMSDRV
C GMSDRV
C If cartesian F functions are input, set IWCUBF to: GMSDRV
C 0, if these are to be transformed to the GMSDRV
C standard set of pure F functions GMSDRV
C 1, if these are to be transformed to the GMSDRV
C cubic set of pure F functions GMSDRV
C GMSDRV
C If pure F functions are input, set to IWCUBF to: GMSDRV
C 0, if these are standard F functions GMSDRV
C 1, if these are cubic F functions GMSDRV
C GMSDRV
C IATNO(I),I=1,NATOMS GMSDRV
C List of atomic numbers GMSDRV
C GMSDRV
C LCTR(I),I=1,NBAS GMSDRV
C List of atomic centers of the basis functions GMSDRV
C (LCTR(3)=2 if basis function 3 is on atom 2) GMSDRV
C GMSDRV
C LANG(I),I=1,NBAS GMSDRV
C List of angular symmetry information for the basis GMSDRV
C functions GMSDRV
C GMSDRV
C LABELS array contains NBO labels for the atomic orbitals GMSDRV
C GMSDRV
* DATA LABELS / GMSDRV
C GMSDRV
C s GMSDRV
C --- GMSDRV
* + 1, GMSDRV
C GMSDRV
C px py pz GMSDRV
C --- --- --- GMSDRV
* + 101, 102, 103, GMSDRV
C GMSDRV
C dxx dyy dzz dxy dxz dyz GMSDRV
C --- --- --- --- --- --- GMSDRV
* + 201, 204, 206, 202, 203, 205, GMSDRV
C GMSDRV
C fxxx fyyy fzzz fxxy fxxz fxyy fxyz fxzz fyyz fyzz GMSDRV
C ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- GMSDRV
* + 301, 307, 310, 302, 303, 304, 305, 306, 308, 309 / GMSDRV
C GMSDRV
C GMSDRV
C WSTATE array contains the values which should be set in the NBO GMSDRV
C common block /NBFLAG/ depending on wavefunction. GMSDRV
C GMSDRV
* DATA WSTATE / GMSDRV
C logical variable in common NBFLAG GMSDRV
C ROHF UHF CI OPEN MCSCF AUHF GMSDRV
C ------- ------- ------ ------ ------ ------ GMSDRV
C Wavefunction GMSDRV
C RHF GMSDRV
* + .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., GMSDRV
C UHF GMSDRV
* + .FALSE., .TRUE. , .FALSE., .TRUE. , .FALSE., .FALSE., GMSDRV
C ROHF GMSDRV
* + .TRUE. , .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., GMSDRV
C GVB GMSDRV
* + .TRUE., .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., GMSDRV
C MCSCF GMSDRV
* + .FALSE., .FALSE., .FALSE., .FALSE., .TRUE. , .FALSE., GMSDRV
C CI GMSDRV
* + .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., .FALSE./ GMSDRV
C GMSDRV
C GMSDRV
C Wavefunction types: GMSDRV
C GMSDRV
* DATA WFNS /8HRHF , GMSDRV
* + 8HUHF , GMSDRV
* + 8HROHF , GMSDRV
* + 8HGVB , GMSDRV
* + 8HMCSCF , GMSDRV
* + 8HCI / GMSDRV
C GMSDRV
* DATA ZERO/0.0D0/ GMSDRV
* DATA TOANG/0.529177249/ GMSDRV
C GMSDRV
C Store job title on NBODAF: GMSDRV
C GMSDRV
* DO 5 I = 1,10 GMSDRV
* CORE(I) = TITLE(I) GMSDRV
* 5 CONTINUE GMSDRV
* NFILE = 2 GMSDRV
* CALL NBWRIT(CORE,10,NFILE) GMSDRV
C GMSDRV
C Get the number of atoms from NAT and store the atomic numbers in GMSDRV
C IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and GMSDRV
C nuclear charges may not be equivalent if effective core potentials GMSDRV
C (ECP) are used.) GMSDRV
C 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
C GMSDRV
C KATOM array contains which atom the shell is on, KMIN and KMAX GMSDRV
C determine the components in the shell by pointing to a range in the GMSDRV
C LABELS array: GMSDRV
C 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
C GMSDRV
* NBAS = II GMSDRV
* NDIM = NBAS GMSDRV
C GMSDRV
C Inititialize various NBO options depending upon the wavefunction GMSDRV
C type and basis set type. GMSDRV
C GMSDRV
C First, turn off the complex orbitals, indicate that the pure set GMSDRV
C of F functions is desired when transforming from the cartesian set. GMSDRV
C GMSDRV
* COMPLX = .FALSE. GMSDRV
* IWCUBF = 0 GMSDRV
* ORTHO = .FALSE. GMSDRV
C GMSDRV
C Next set up the wavefunction flags. GMSDRV
C 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
C 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
C GMSDRV
C No Fock matrices for ROHF, MCSCF, or CI wavefunctions: GMSDRV
C GMSDRV
* IF (ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 GMSDRV
C GMSDRV
C Expectation values of the Fock operator are in atomic units: GMSDRV
C GMSDRV
* MUNIT = 0 GMSDRV
C GMSDRV
C Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: GMSDRV
C 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
C GMSDRV
C Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: GMSDRV
C 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
C GMSDRV
C Fetch the total energy from the dictionary file and store it on the GMSDRV
C NBO DAF: GMSDRV
C 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
C GMSDRV
C Store the atomic coordinates on the NBO DAF: (Note that these GMSDRV
C coordinates are used in the calculation of dipole moments. GAMESS GMSDRV
C requires the Cartesian origin to be at the center of mass!!) GMSDRV
C 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
C GMSDRV
C Store the overlap matrix on the NBODAF: GMSDRV
C 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
C GMSDRV
C Store the density matrices on the NBODAF: GMSDRV
C 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
C 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
C GMSDRV
C Store the Fock matrices on the NBODAF: GMSDRV
C 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
C 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
C GMSDRV
C Store the AO to MO transformation matrices on the NBODAF: GMSDRV
C 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
C GMSDRV
C Store the x,y,z dipole integrals on the NBODAF: GMSDRV
C 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
C GMSDRV
C Store the AO basis set info on the NBO DAF: (Note that two integers GMSDRV
C and three integer arrays are stored first. Also remember that ICORE GMSDRV
C and CORE occupy the same memory.) GMSDRV
C 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
C GMSDRV
C NCOMP(I) -- the number of components in the Ith shell: GMSDRV
C 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
C GMSDRV
C NPRIM(I) -- the number of gaussian primitives in the Ith shell: GMSDRV
C GMSDRV
* DO 180 I = 1,NSHELL GMSDRV
* II = II + 1 GMSDRV
* ICORE(II) = KNG(I) GMSDRV
* 180 CONTINUE GMSDRV
C GMSDRV
C NPTR(I) -- pointer for the Ith shell into the gaussian parameters, GMSDRV
C EXP, CS, CP, etc.: GMSDRV
C GMSDRV
* DO 190 I = 1,NSHELL GMSDRV
* II = II + 1 GMSDRV
* ICORE(II) = KSTART(I) GMSDRV
* 190 CONTINUE GMSDRV
C GMSDRV
C EXP(I) -- orbital exponents indexed by NPTR: GMSDRV
C GMSDRV
* DO 200 I = 1,NEXP GMSDRV
* II = II + 1 GMSDRV
* CORE(II) = EX(I) GMSDRV
* 200 CONTINUE GMSDRV
C GMSDRV
C CS,CP,CD,CF -- orbital coefficients: GMSDRV
C 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
C GMSDRV
* RETURN GMSDRV
* END GMSDRV
C***********************************************************************GMSDRV
* SUBROUTINE DELSCF(A,IA) GMSDRV
C***********************************************************************GMSDRV
* IMPLICIT REAL*8 (A-H,O-Z) GMSDRV
* LOGICAL NEW,ERROR,SEQ GMSDRV
C GMSDRV
C NBO common blocks: GMSDRV
C 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
C GMSDRV
C GAMESS common blocks: GMSDRV
C 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
C GMSDRV
* DIMENSION A(1),IA(NDIM) GMSDRV
C GMSDRV
* DATA TWO/2.0D0/ GMSDRV
C GMSDRV
C-----------------------------------------------------------------------GMSDRV
C GMSDRV
C SET POINTERS: GMSDRV
C GMSDRV
* NTRI = NDIM*(NDIM+1)/2 GMSDRV
* NSQ = NDIM*NDIM GMSDRV
C GMSDRV
C A(IPT1) --- Density matrix (alpha) GMSDRV
C A(IPT2) --- Density matrix (beta) GMSDRV
C A(IPT3) --- Fock matrix (alpha) GMSDRV
C A(IPT4) --- Fock matrix (beta) GMSDRV
C A(IPT5) --- Core Hamiltonian matrix GMSDRV
C A(IPT6) --- Integral buffer, scratch GMSDRV
C A(IPT7) --- Integral buffer GMSDRV
C A(IPT8) --- Integral buffer GMSDRV
C 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
C GMSDRV
C SET UP ADDRESSING ARRAY: GMSDRV
C GMSDRV
* DO 50 I = 1,NDIM GMSDRV
* IA(I) = (I*(I-1))/2 GMSDRV
* 50 CONTINUE GMSDRV
C GMSDRV
C REWIND INTEGRAL FILE: GMSDRV
C GMSDRV
* REWIND IS GMSDRV
C GMSDRV
C OPEN THE NBO DIRECT ACCESS FILE GMSDRV
C GMSDRV
* NEW = .FALSE. GMSDRV
* CALL NBOPEN(NEW,ERROR) GMSDRV
* IF(ERROR) THEN GMSDRV
* WRITE(LFNPR,900) GMSDRV
* STOP GMSDRV
* END IF GMSDRV
C GMSDRV
C CALCULATE NUCLEAR REPULSION ENERGY: GMSDRV
C GMSDRV
* EN = ENUC(NAT,ZAN,C) GMSDRV
* IF(UHF) THEN GMSDRV
C GMSDRV
C UHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTGMSDRV
C AND SYMMETRIZE THE SKELETON FOCK MATRIX: GMSDRV
C 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
C GMSDRV
C READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: GMSDRV
C 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
C GMSDRV
C RHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTGMSDRV
C AND SYMMETRIZE THE SKELETON FOCK MATRIX: GMSDRV
C 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
C GMSDRV
C READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: GMSDRV
C 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
C GMSDRV
C SAVE THE DELETION ENERGY ON THE NBO DIRECT ACCESS FILE AND CLOSE THE GMSDRV
C FILE: GMSDRV
C GMSDRV
* CALL SVE0(EDEL) GMSDRV
* SEQ = .FALSE. GMSDRV
* CALL NBCLOS(SEQ) GMSDRV
* RETURN GMSDRV
C GMSDRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ', GMSDRV
* + 'subroutine DELSCF.') GMSDRV
* END GMSDRV
C***********************************************************************GMSDRV
C GMSDRV
C E N D O F G M S N B O R O U T I N E S GMSDRV
C GMSDRV
C***********************************************************************GMSDRV
C***********************************************************************HNDDRV
C HNDDRV
C HNDDRV
C H N D N B O HNDDRV
C HNDDRV
C HNDDRV
C HONDO VERSION OF NBO PROGRAM HNDDRV
C HNDDRV
C HNDDRV
C DRIVER ROUTINES: HNDDRV
C HNDDRV
C SUBROUTINE RUNNBO HNDDRV
C SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) HNDDRV
C SUBROUTINE DELSCF(A) HNDDRV
C HNDDRV
C***********************************************************************HNDDRV
* SUBROUTINE RUNNBO HNDDRV
C***********************************************************************HNDDRV
* IMPLICIT REAL*8 (A-H,O-Z) HNDDRV
* DIMENSION NBOOPT(10) HNDDRV
C HNDDRV
* COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, HNDDRV
* + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, HNDDRV
* + LFNDAF,LFNDEF HNDDRV
C HNDDRV
C HONDO Common Block: HNDDRV
C HNDDRV
* COMMON/IOFILE/IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(99) HNDDRV
* COMMON/MEMORY/MAXCOR,MAXLCM HNDDRV
* COMMON/SCM/CORE(1) HNDDRV
C HNDDRV
* LFNIN = IR HNDDRV
* LFNPR = IW HNDDRV
C HNDDRV
C Set NBO options. HNDDRV
C 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
C HNDDRV
C Perform the NPA/NBO/NLMO analyses. HNDDRV
C HNDDRV
* CALL NBO(CORE,MAXCOR,NBOOPT) HNDDRV
C HNDDRV
C Perform the energetic analysis. HNDDRV
C 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
C HNDDRV
* 20 RETURN HNDDRV
* END HNDDRV
C***********************************************************************HNDDRV
* SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) HNDDRV
C***********************************************************************HNDDRV
* IMPLICIT REAL*8 (A-H,O-Z) HNDDRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) HNDDRV
C HNDDRV
C ----------------------------------------------------------------------HNDDRV
C HNDDRV
C This routine fetchs basis set information from the HONDO common HNDDRV
C blocks and stores it in the NBO common blocks and direct access file HNDDRV
C (DAF) for use by the NBO analysis. HNDDRV
C HNDDRV
C ----------------------------------------------------------------------HNDDRV
C HNDDRV
C Routine FEAOIN accesses the following records of the dictionary file:HNDDRV
C HNDDRV
C 2 --- Total energy HNDDRV
C 12 --- AO overlap matrix HNDDRV
C 14 --- AO Fock matrix (alpha) HNDDRV
C 15 --- AO to MO transformation matrix (alpha) HNDDRV
C 16 --- AO density matrix (bond order matrix) (alpha) HNDDRV
C 18 --- AO Fock matrix (beta) HNDDRV
C 19 --- AO to MO transformation matrix (beta) HNDDRV
C 20 --- AO density matrix (bond order matrix) (beta) HNDDRV
C 33 --- X dipole integrals HNDDRV
C 34 --- Y dipole integrals HNDDRV
C 35 --- Z dipole integrals HNDDRV
C HNDDRV
C ----------------------------------------------------------------------HNDDRV
C HNDDRV
C NBO Common blocks HNDDRV
C HNDDRV
C 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
C HNDDRV
C HONDO Common blocks HNDDRV
C 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
C HNDDRV
* DIMENSION LABELS(20),WFNS(6) HNDDRV
* LOGICAL WSTATE(6,6),SOME HNDDRV
* DIMENSION CM(3) HNDDRV
C HNDDRV
C Obtain the following information: HNDDRV
C HNDDRV
C ROHF =.TRUE. If RHF open shell wavefunction HNDDRV
C =.FALSE. otherwise HNDDRV
C HNDDRV
C UHF =.TRUE. If UHF wavefunction HNDDRV
C =.FALSE. otherwise HNDDRV
C HNDDRV
C AUHF =.TRUE. If spin-annihilated UHF wavefunction HNDDRV
C =.FALSE. otherwise HNDDRV
C HNDDRV
C CI =.TRUE. If CI wavefunction HNDDRV
C =.FALSE. otherwise HNDDRV
C HNDDRV
C OPEN =.TRUE. If open shell wavefunction HNDDRV
C =.FALSE. otherwise HNDDRV
C HNDDRV
C COMPLX =.TRUE. If complex wavefunction HNDDRV
C =.FALSE. otherwise HNDDRV
C (Note: The program is not capable of handling this.) HNDDRV
C HNDDRV
C NATOMS Number of atomic centers HNDDRV
C HNDDRV
C NDIM Dimension of matrices (overlap and density) passed to pHNDDRV
C HNDDRV
C NBAS Number of basis functions (.le.NDIM) HNDDRV
C HNDDRV
C IPSEUD Set to zero if no pseudopotentials are used. HNDDRV
C Set to one if pseudopotentials are used. HNDDRV
C HNDDRV
C IWCUBF This pertains only basis sets with F functions. HNDDRV
C HNDDRV
C If cartesian F functions are input, set IWCUBF to: HNDDRV
C 0, if these are to be transformed to the HNDDRV
C standard set of pure F functions HNDDRV
C 1, if these are to be transformed to the HNDDRV
C cubic set of pure F functions HNDDRV
C HNDDRV
C If pure F functions are input, set to IWCUBF to: HNDDRV
C 0, if these are standard F functions HNDDRV
C 1, if these are cubic F functions HNDDRV
C HNDDRV
C IATNO(I),I=1,NATOMS HNDDRV
C List of atomic numbers HNDDRV
C HNDDRV
C LCTR(I),I=1,NBAS HNDDRV
C List of atomic centers of the basis functions HNDDRV
C (LCTR(3)=2 if basis function 3 is on atom 2) HNDDRV
C HNDDRV
C LANG(I),I=1,NBAS HNDDRV
C List of angular symmetry information for the basis funcHNDDRV
C HNDDRV
C LABELS array contains NBO labels for the atomic orbitals HNDDRV
C HNDDRV
* DATA LABELS / HNDDRV
C HNDDRV
C S HNDDRV
C --- HNDDRV
* + 1, HNDDRV
C HNDDRV
C Px Py Pz HNDDRV
C --- --- --- HNDDRV
* + 101, 102, 103, HNDDRV
C HNDDRV
C Dxx Dyy Dzz Dxy Dxz Dyz HNDDRV
C --- --- --- --- --- --- HNDDRV
* + 201, 204, 206, 202, 203, 205, HNDDRV
C HNDDRV
C Fxxx Fyyy Fzzz Fxxy Fxxz Fxyy Fxyz Fxzz Fyyz Fyzz HNDDRV
C ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- HNDDRV
* + 301, 307, 310, 302, 303, 304, 305, 306, 308, 309 / HNDDRV
C HNDDRV
C HNDDRV
C WSTATE array contains the values which should be set in the NBO commoHNDDRV
C NBFLAG depending on wavefunction. HNDDRV
C HNDDRV
* DATA WSTATE / HNDDRV
C ROHF UHF CI OPEN MCSCF AUHF HNDDRV
C ------- ------- ------ ------ ------ ------ HNDDRV
C Wavefunction HNDDRV
C RHF HNDDRV
* + .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., HNDDRV
C UHF HNDDRV
* + .FALSE., .TRUE. , .FALSE., .TRUE. , .FALSE., .FALSE., HNDDRV
C ROHF HNDDRV
* + .TRUE. , .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., HNDDRV
C GVB HNDDRV
* + .TRUE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., HNDDRV
C MCSCF HNDDRV
* + .FALSE., .FALSE., .FALSE., .FALSE., .TRUE. , .FALSE., HNDDRV
C CI HNDDRV
* + .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., .FALSE./ HNDDRV
C HNDDRV
C HNDDRV
* NAMELIST /WFN/ WFNFLG HNDDRV
* DATA WFNFLG /0/ HNDDRV
* DATA ZERO/0.0D0/ HNDDRV
* DATA TOANG/0.529177249/ HNDDRV
C HNDDRV
C Wavefunction types: HNDDRV
C HNDDRV
* DATA SCFWFN,CIWFN/'SCF ','MCCI '/ HNDDRV
* DATA WFNS /8HRHF , HNDDRV
* + 8HUHF , HNDDRV
* + 8HROHF , HNDDRV
* + 8HGVB , HNDDRV
* + 8HMCSCF , HNDDRV
* + 8HCI / HNDDRV
C HNDDRV
C Read in type of wavefunction from the $WFN namelist. HNDDRV
C 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
C HNDDRV
C Store job title on NBODAF: HNDDRV
C HNDDRV
* DO 5 I = 1,10 HNDDRV
* CORE(I) = TITLE(I) HNDDRV
* 5 CONTINUE HNDDRV
* NFILE = 2 HNDDRV
* CALL NBWRIT(CORE,10,NFILE) HNDDRV
C HNDDRV
C Get the number of atoms from NAT and store the atomic numbers in HNDDRV
C IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and HNDDRV
C nuclear charges may not be equivalent if effective core potentials HNDDRV
C (ECP) are used.) HNDDRV
C 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
C HNDDRV
C KATOM array contains which atom the shell is on, KMIN and KMAX HNDDRV
C determine the components in the shell by pointing to a range in the HNDDRV
C LABELS array: HNDDRV
C 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
C HNDDRV
* NBAS = II HNDDRV
* NDIM = NBAS HNDDRV
C HNDDRV
C Inititialize various NBO options depending upon the wavefunction HNDDRV
C type and basis set type. HNDDRV
C HNDDRV
C First, turn off the complex orbitals, indicate that the pure set HNDDRV
C of F functions is desired when transforming from the cartesian set. HNDDRV
C HNDDRV
* COMPLX = .FALSE. HNDDRV
* IWCUBF = 0 HNDDRV
* ORTHO = .FALSE. HNDDRV
C HNDDRV
C Next set up the wavefunction switches. HNDDRV
C 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
C 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
C HNDDRV
C No Fock matrices for ROHF, MCSCF, or CI wavefunctions: HNDDRV
C HNDDRV
* IF (ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 HNDDRV
C HNDDRV
C Expectation values of the Fock operator are in atomic units: HNDDRV
C HNDDRV
* MUNIT = 0 HNDDRV
C HNDDRV
C Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: HNDDRV
C 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
C HNDDRV
C Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: HNDDRV
C 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
C HNDDRV
C Fetch the total energy from the dictionary file and store it on the HNDDRV
C NBO DAF: HNDDRV
C 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
C HNDDRV
C Find the center of mass for this molecule: HNDDRV
C 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
C HNDDRV
C Store the atomic coordinates on the NBO DAF: (Note that these HNDDRV
C coordinates are used in the calculation of dipole moments.) HNDDRV
C 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
C HNDDRV
C Store the overlap matrix on the NBODAF: HNDDRV
C 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
C HNDDRV
C Store the density matrices on the NBODAF: HNDDRV
C 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
C 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
C HNDDRV
C Store the Fock matrices on the NBODAF: HNDDRV
C 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
C 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
C HNDDRV
C Store the AO to MO transformation matrices on the NBODAF: HNDDRV
C 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
C HNDDRV
C Store the x,y,z dipole integrals on the NBODAF: HNDDRV
C 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
C HNDDRV
C Store the AO basis set info on the NBO DAF: (Note that two integers HNDDRV
C and three integer arrays are stored first. Also remember that ICORE HNDDRV
C and CORE occupy the same memory.) HNDDRV
C 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
C HNDDRV
C NCOMP(I) -- the number of components in the Ith shell: HNDDRV
C 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
C HNDDRV
C NPRIM(I) -- the number of gaussian primitives in the Ith shell: HNDDRV
C HNDDRV
* DO 180 I = 1,NSHELL HNDDRV
* II = II + 1 HNDDRV
* ICORE(II) = KNG(I) HNDDRV
* 180 CONTINUE HNDDRV
C HNDDRV
C NPTR(I) -- pointer for the Ith shell into the gaussian parameters, HNDDRV
C EXP, CS, CP, etc.: HNDDRV
C HNDDRV
* DO 190 I = 1,NSHELL HNDDRV
* II = II + 1 HNDDRV
* ICORE(II) = KSTART(I) HNDDRV
* 190 CONTINUE HNDDRV
C HNDDRV
C EXP(I) -- orbital exponents indexed by NPTR: HNDDRV
C HNDDRV
* DO 200 I = 1,NEXP HNDDRV
* II = II + 1 HNDDRV
* CORE(II) = EX(I) HNDDRV
* 200 CONTINUE HNDDRV
C HNDDRV
C CS,CP,CD,CF -- orbital coefficients: HNDDRV
C 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
C HNDDRV
* 900 FORMAT(/1X,'No namelist /WFN/ found. Stop. ') HNDDRV
* RETURN HNDDRV
* END HNDDRV
C***********************************************************************HNDDRV
* SUBROUTINE DELSCF(A) HNDDRV
C***********************************************************************HNDDRV
* IMPLICIT REAL*8 (A-H,O-Z) HNDDRV
* LOGICAL NEW,ERROR,SEQ HNDDRV
C HNDDRV
C NBO common blocks: HNDDRV
C 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
C HNDDRV
C HONDO common blocks: HNDDRV
C 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
C HNDDRV
* DIMENSION A(1) HNDDRV
C HNDDRV
C-----------------------------------------------------------------------HNDDRV
C HNDDRV
C SET POINTERS: HNDDRV
C HNDDRV
* NTRI = NDIM*(NDIM+1)/2 HNDDRV
* NSQ = NDIM*NDIM HNDDRV
C HNDDRV
C A(IPT1) --- Density matrix (alpha) HNDDRV
C A(IPT2) --- Density matrix (beta) HNDDRV
C A(IPT3) --- Fock matrix (alpha) HNDDRV
C A(IPT4) --- Fock matrix (beta) HNDDRV
C A(IPT5) --- Core Hamiltonian matrix HNDDRV
C A(IPT6) --- Integral buffer, scratch HNDDRV
C A(IPT7) --- Integral buffer HNDDRV
C A(IPT8) --- Integral buffer HNDDRV
C 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
C HNDDRV
C OPEN THE NBO DIRECT ACCESS FILE HNDDRV
C HNDDRV
* NEW = .FALSE. HNDDRV
* CALL NBOPEN(NEW,ERROR) HNDDRV
* IF(ERROR) THEN HNDDRV
* WRITE(LFNPR,900) HNDDRV
* STOP HNDDRV
* END IF HNDDRV
C HNDDRV
C CALCULATE NUCLEAR REPULSION ENERGY: HNDDRV
C HNDDRV
* EN = ENUC(NAT,ZAN,C) HNDDRV
* IF(UHF) THEN HNDDRV
C HNDDRV
C UHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTHNDDRV
C AND SYMMETRIZE THE SKELETON FOCK MATRIX: HNDDRV
C 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
C HNDDRV
C READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: HNDDRV
C 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
C HNDDRV
C RHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTHNDDRV
C AND SYMMETRIZE THE SKELETON FOCK MATRIX: HNDDRV
C 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
C HNDDRV
C READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: HNDDRV
C 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
C HNDDRV
C SAVE THE DELETION ENERGY ON THE NBO DIRECT ACCESS FILE AND CLOSE THE HNDDRV
C FILE: HNDDRV
C HNDDRV
* CALL SVE0(EDEL) HNDDRV
* SEQ = .FALSE. HNDDRV
* CALL NBCLOS(SEQ) HNDDRV
* RETURN HNDDRV
C HNDDRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ', HNDDRV
* + 'subroutine DELSCF.') HNDDRV
* END HNDDRV
C***********************************************************************HNDDRV
C HNDDRV
C E N D O F H N D N B O R O U T I N E S HNDDRV
C HNDDRV
C***********************************************************************HNDDRV
C***********************************************************************AMPDRV
C AMPDRV
C AMPDRV
C A M P N B O AMPDRV
C AMPDRV
C AMPDRV
C AMPAC VERSION OF NBO PROGRAM AMPDRV
C AMPDRV
C AMPDRV
C DRIVER ROUTINES: AMPDRV
C AMPDRV
C SUBROUTINE RUNNBO AMPDRV
C SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) AMPDRV
C SUBROUTINE DELSCF(CORE,ICORE) AMPDRV
C AMPDRV
C***********************************************************************AMPDRV
* SUBROUTINE RUNNBO AMPDRV
C***********************************************************************AMPDRV
* IMPLICIT REAL*8 (A-H,O-Z) AMPDRV
C 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
C AMPDRV
* DIMENSION CORE(MEMORY),NBOOPT(10) AMPDRV
C AMPDRV
* LFNIN = 5 AMPDRV
* LFNPR = 6 AMPDRV
C AMPDRV
C Set NBO options. AMPDRV
C 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
C AMPDRV
C Perform the NPA/NBO/NLMO analyses. AMPDRV
C AMPDRV
* CALL NBO(CORE,MEMORY,NBOOPT) AMPDRV
C AMPDRV
C Perform the energetic analysis. AMPDRV
C 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
C AMPDRV
* 20 RETURN AMPDRV
* END AMPDRV
C***********************************************************************AMPDRV
* SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) AMPDRV
C***********************************************************************AMPDRV
* IMPLICIT REAL*8 (A-H,O-Z) AMPDRV
* DIMENSION CORE(1),ICORE(1),NBOOPT(10) AMPDRV
* DIMENSION LIST(9),NCORE(12) AMPDRV
C AMPDRV
* INCLUDE 'SIZES' AMPDRV
C AMPDRV
C NBO COMMON BLOCKS AMPDRV
C 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
C AMPDRV
C AMPAC COMMON BLOCKS: AMPDRV
C 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
C 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
C AMPDRV
C FEAOIN: (FETCH AO BASIS AND WAVE FUNCTION TYPE INFORMATION) AMPDRV
C AMPDRV
C OBTAIN THE FOLLOWING INFORMATION: AMPDRV
C AMPDRV
C ROHF =.TRUE. IF RHF OPEN SHELL WAVE FUNCTION AMPDRV
C =.FALSE. OTHERWISE AMPDRV
C AMPDRV
C UHF =.TRUE. IF UHF WAVE FUNCTION AMPDRV
C =.FALSE. OTHERWISE AMPDRV
C AMPDRV
C CI =.TRUE. IF UHF WAVE FUNCTION AMPDRV
C =.FALSE. OTHERWISE AMPDRV
C AMPDRV
C OPEN =.TRUE. IF OPEN SHELL WAVE FUNCTION AMPDRV
C =.FALSE. OTHERWISE AMPDRV
C AMPDRV
C COMPLX =.TRUE. IF COMPLEX WAVE FUNCTION AMPDRV
C =.FALSE. OTHERWISE AMPDRV
C (NOTE: THE PROGRAM IS NOT SET UP TO HANDLE THIS CASE) AMPDRV
C AMPDRV
C ORTHO =.TRUE. ORTHOGONAL AO BASIS SET AMPDRV
C AMPDRV
C NATOMS NUMBER OF ATOMIC CENTERS AMPDRV
C AMPDRV
C NDIM DIMENSION OF MATRICES (OVERLAP AND DENSITY) AMPDRV
C AMPDRV
C NBAS NUMBER OF BASIS FUNCTIONS (.LE.NDIM) AMPDRV
C AMPDRV
C IPSEUD SET TO ZERO IF NO PSEUDOPOTENTIALS ARE USED, AMPDRV
C SET TO ONE IF PSEUDOPOTENTIALS ARE USED. AMPDRV
C (THE ONLY EFFECT OF THIS IS TO SUPRESS THE LABELLING OFAMPDRV
C ORBITALS WHEN ONE OR MORE ATOMS HAS A PSEUDOPOTENTIAL) AMPDRV
C AMPDRV
C IWCUBF THIS PERTAINS ONLY TO BASIS SETS WITH F FUNCTIONS. AMPDRV
C AMPDRV
C IF CARTESIAN F FUNCTIONS ARE INPUT, SET IWCUBF TO: AMPDRV
C 0, IF THESE ARE TO BE TRANSFORMED TO THE STANDARD AMPDRV
C OF PURE F FUNCTIONS AMPDRV
C 1, IF THESE ARE TO BE TRANSFORMED TO THE CUBIC AMPDRV
C SET OF PURE F FUNCTIONS AMPDRV
C AMPDRV
C IF PURE F FUNCTIONS ARE INPUT, SET TO IWCUBF TO: AMPDRV
C 0, IF THESE ARE STANDARD F FUNCTIONS AMPDRV
C 1, IF THESE ARE CUBIC F FUNCTIONS AMPDRV
C AMPDRV
C AMPDRV
C IATNO(I),I=1,NATOMS AMPDRV
C LIST OF ATOMIC NUMBERS AMPDRV
C AMPDRV
C LCTR(I),I=1,NBAS AMPDRV
C LIST OF ATOMIC CENTERS OF THE BASIS FUNCTIONS AMPDRV
C (LCTR(3)=2 IF BASIS FUNCT. 3 IS ON ATOM 2) AMPDRV
C AMPDRV
C LANG(I),I=1,NBAS AMPDRV
C LIST OF ANGULAR SYMMETRY INFORMATION FOR THE BASIS AMPDRV
C FUNCTIONS AMPDRV
C AMPDRV
* IWCUBF = 0 AMPDRV
* IPSEUD = 0 AMPDRV
C AMPDRV
C CONSTRUCT ATOM AND AO BASIS INFORMATION LISTS: AMPDRV
C IATNO(I) = ATOMIC NUMBER OF ATOM "I" AMPDRV
C IZNUC(I) = NUCLEAR CHARGE ON ATOM "I" (IATNO(I)-# OF CORE ELECTRONAMPDRV
C LCTR(I) = ATOMIC CENTER FOR BASIS FUNCTION "I" AMPDRV
C LANG(I) = ANGULAR SYMMETRY LABEL FOR BASIS FUNCTION "I" AMPDRV
C 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
C 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
C AMPDRV
C PUT INFO INTO COMMON/NBINFO/: AMPDRV
C AMPDRV
* NATOMS = NAT AMPDRV
* NDIM = IBAS AMPDRV
* NBAS = IBAS AMPDRV
C AMPDRV
C EXPECTATION VALUES OF THE FOCK OPERATOR ARE IN ELECTRON VOLTS: AMPDRV
C AMPDRV
* MUNIT = 1 AMPDRV
C AMPDRV
C DETERMINE TYPE OF WAVE FUNCTION DENSITY MATRIX IS FROM: AMPDRV
C 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
C AMPDRV
* IF(ROHF.OR.CI) IWFOCK = 0 AMPDRV
C AMPDRV
C STORE THE JOB TITLE ON THE NBO DAF: AMPDRV
C AMPDRV
* DO 210 I = 1,10 AMPDRV
* CORE(I) = TITLE(I) AMPDRV
* 210 CONTINUE AMPDRV
* NFILE = 2 AMPDRV
* CALL NBWRIT(CORE,10,NFILE) AMPDRV
C AMPDRV
C STORE NATOMS, NDIM, NBAS, MUNIT, WAVEFUNCTION FLAGS, ISWEAN: AMPDRV
C 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
C AMPDRV
C STORE IATNO, IZNUC, LCTR, AND LANG ON NBO DAF: AMPDRV
C 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
C AMPDRV
C STORE ATOMIC COORDINATES ON THE NBO DAF: AMPDRV
C AMPDRV
* CALL GMETRY(GEO,CORE) AMPDRV
* NFILE = 9 AMPDRV
* CALL NBWRIT(CORE,3*NATOMS,NFILE) AMPDRV
C AMPDRV
C STORE THE DENSITY MATRICES ON THE NBO DAF: AMPDRV
C 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
C AMPDRV
C STORE THE FOCK MATRICES ON THE NBO DAF: AMPDRV
C 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
C AMPDRV
C STORE THE AO TO MO TRANSFORMATIONS ON THE NBO DAF: AMPDRV
C 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
C AMPDRV
* RETURN AMPDRV
* END AMPDRV
C***********************************************************************AMPDRV
* SUBROUTINE DELSCF(CORE,ICORE) AMPDRV
C***********************************************************************AMPDRV
* IMPLICIT REAL*8 (A-H,O-Z) AMPDRV
* LOGICAL NEW,ERROR,SEQ AMPDRV
C AMPDRV
C NBO common blocks: AMPDRV
C 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
C AMPDRV
C AMPAC COMMON blocks: AMPDRV
C AMPDRV
* INCLUDE 'SIZES' AMPDRV
C 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
C AMPDRV
* DIMENSION CORE(1),ICORE(1),W(N2ELEC) AMPDRV
* EQUIVALENCE (W(1),WJ(1)) AMPDRV
C AMPDRV
* DATA TWO,TOKCAL/2.0D0,23.061D0/ AMPDRV
C AMPDRV
C Open the NBO direct access file: AMPDRV
C AMPDRV
* NEW = .FALSE. AMPDRV
* CALL NBOPEN(NEW,ERROR) AMPDRV
* IF(ERROR) THEN AMPDRV
* WRITE(LFNPR,900) AMPDRV
* STOP AMPDRV
* END IF AMPDRV
C AMPDRV
C Compute the one-electron and two-electron integrals, given the atomicAMPDRV
C coordinates. Also compute the nuclear repulsion contribution to the AMPDRV
C SCF energy: AMPDRV
C AMPDRV
* CALL GMETRY(GEO,CORE) AMPDRV
* CALL HCORE(CORE,H,W,WJ,WK,ENUCLR) AMPDRV
C AMPDRV
C Compute the SCF and deletion energies for UHF wavefunctions: AMPDRV
C AMPDRV
* LEN = NBAS * (NBAS + 1) / 2 AMPDRV
* IF(UHF) THEN AMPDRV
C AMPDRV
C Read the spin densities from the NBO direct access file and calculateAMPDRV
C to total density: AMPDRV
C 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
C AMPDRV
C Alpha spin: construct the alpha Fock matrix: AMPDRV
C 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
C AMPDRV
C Alpha spin: construct the alpha Fock matrix: AMPDRV
C 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
C AMPDRV
C Determine the SCF energy: AMPDRV
C AMPDRV
* EE = HELECT(NBAS,PA,H,F) + HELECT(NBAS,PB,H,FB) AMPDRV
* ESCF = (EE + ENUCLR) * TOKCAL + ATHEAT AMPDRV
C AMPDRV
C Repeat process for the deletion energy: AMPDRV
C 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
C AMPDRV
C Compute the SCF and deletion energies for RHF wavefunctions: AMPDRV
C 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
C AMPDRV
C Construct the Fock matrix: AMPDRV
C 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
C AMPDRV
C Determine the SCF energy: AMPDRV
C AMPDRV
* EE = HELECT(NBAS,PA,H,F) * TWO AMPDRV
* ESCF = (EE + ENUCLR) * TOKCAL + ATHEAT AMPDRV
C AMPDRV
C Repeat process for the deletion energy: AMPDRV
C 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
C AMPDRV
C Save these energies on the direct access file: AMPDRV
C AMPDRV
* CORE(1) = EDEL AMPDRV
* CORE(2) = ESCF AMPDRV
* NFILE = 8 AMPDRV
* CALL NBWRIT(CORE,2,NFILE) AMPDRV
C AMPDRV
C Note that these energies are in units of kcal/mol!! AMPDRV
C AMPDRV
* MUNIT = 2 AMPDRV
* NFILE = 3 AMPDRV
* CALL NBREAD(ICORE,12,NFILE) AMPDRV
* ICORE(4) = MUNIT AMPDRV
* CALL NBWRIT(ICORE,12,NFILE) AMPDRV
C AMPDRV
C Close the NBO direct access file: AMPDRV
C AMPDRV
* SEQ = .FALSE. AMPDRV
* CALL NBCLOS(SEQ) AMPDRV
* RETURN AMPDRV
C AMPDRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ', AMPDRV
* + 'subroutine DELSCF.') AMPDRV
* END AMPDRV
C***********************************************************************AMPDRV
C AMPDRV
C E N D O F A M P N B O R O U T I N E S AMPDRV
C AMPDRV
C***********************************************************************AMPDRV
|
