***************************************************************************** N B O P R O G R A M (SYSTEM INDEPENDENT ROUTINES) LAST PROGRAM MODIFICATION: OCTOBER 22, 1991 !!! CRAY COMPILATION REQUIRES 64 BIT (-i64) INTEGERS !!! (SEE, IN PARTICULAR, SR JOBOPT, SR NBOPEN, AND SR DEBYTE) ***************************************************************************** MAIN SUBROUTINE: SUBROUTINE NBO(CORE,NBOOPT,MEMORY) JOB INITIALIZATION ROUTINES: (CALLED BY SR NBO) SUBROUTINE NBOSET(NBOOPT) SUBROUTINE JOBOPT(NBOOPT) SUBROUTINE NBODIM(MEMORY) NAO/NBO/NLMO FORMATION ROUTINES: (CALLED BY SR NBO) SUBROUTINE NAODRV(DM,T,A) SUBROUTINE NAOSIM(DM,T,A) SUBROUTINE DMNAO(DM,T,A) SUBROUTINE DMSIM(DM,T,A) SUBROUTINE NBODRV(DM,T,A,MEMORY) ROUTINES CALLED BY THE NAO DRIVERS: SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF) SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF) SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR) SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK) SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO) SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG) ROUTINES CALLED BY SR NAO: SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM) SUBROUTINE ATDIAG(N,A,B,EVAL,C) SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM) SUBROUTINE NEWWTS(S,T,WT) SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK) SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK) SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2, + LIST,IRPNAO) SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2, + IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO) SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT) SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO) SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,IRPNAO) ROUTINES CALLED BY THE NBO/NLMO DRIVERS: SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO) SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO) SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO,IFLG) SUBROUTINE SRTNBO(T,BNDOCC) SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR) SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB) SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN) SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB) SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR) SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB) SUBROUTINE FNDMOL(IATOMS) SUBROUTINE NBOCLA(BNDOCC,ACCTHR) SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO) SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR) SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG) SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR) SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM) SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,SIAB,NOCC,NAB) SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX) SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX) SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC) ROUTINES CALLED BY SR NATHYB, SR CHOOSE: SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR) FUNCTION IWPRJ(NCTR) SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD) SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB) SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP) SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB) SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG) SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI) SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB) SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD) SUBROUTINE FORMT(T,Q,POL) SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT) ROUTINES CALLED BY SR NLMO: SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT, + NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM) SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL) NBO ENERGETIC ANALYSIS ROUTINES: SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE) SUBROUTINE NBODEL(A,MEMORY,IDONE) SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE, + ISPIN) SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN) SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK) SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL) NBO DIRECT ACCESS FILE (DAF) ROUTINES: SUBROUTINE NBFILE(NEW,ERROR) SUBROUTINE NBOPEN(NEW,ERROR) SUBROUTINE NBWRIT(IX,NX,IDAR) SUBROUTINE NBREAD(IX,NX,IDAR) SUBROUTINE NBCLOS(SEQ) SUBROUTINE NBINQR(IDAR) SUBROUTINE FETITL(TITLE) SUBROUTINE FEE0(EDEL,ETOT) SUBROUTINE SVE0(EDEL) SUBROUTINE FECOOR(ATCOOR) SUBROUTINE FESRAW(S) SUBROUTINE FEDRAW(DM,SCR) SUBROUTINE FEFAO(F,IWFOCK) SUBROUTINE FEAOMO(T,IT) SUBROUTINE FEDXYZ(DXYZ,I) SUBROUTINE SVNBO(T,OCC,ISCR) SUBROUTINE FENBO(T,OCC,ISCR,NELEC) SUBROUTINE FETNBO(T) SUBROUTINE SVPNAO(T) SUBROUTINE FEPNAO(T) SUBROUTINE SVSNAO(S) SUBROUTINE FESNAO(S) SUBROUTINE SVTNAB(T) SUBROUTINE FETNAB(T) SUBROUTINE SVTLMO(T) SUBROUTINE FETLMO(T) SUBROUTINE SVTNHO(T) SUBROUTINE FETNHO(T) SUBROUTINE SVPPAO(DM) SUBROUTINE FEPPAO(DM) SUBROUTINE SVTNAO(T) SUBROUTINE FETNAO(T) SUBROUTINE SVNLMO(T) SUBROUTINE FENLMO(T) SUBROUTINE SVDNAO(DM) SUBROUTINE FEDNAO(DM) SUBROUTINE SVFNBO(F) SUBROUTINE FEFNBO(F) SUBROUTINE SVNEWD(DM) SUBROUTINE FENEWD(DM) SUBROUTINE FEINFO(ICORE,ISWEAN) SUBROUTINE FEBAS(NSHELL,NEXP,ISCR) FREE FORMAT INPUT ROUTINES: SUBROUTINE STRTIN(LFNIN) SUBROUTINE RDCRD SUBROUTINE IFLD(INT,ERROR) SUBROUTINE RFLD(REAL,ERROR) SUBROUTINE HFLD(KEYWD,LENG,ENDD) SUBROUTINE FNDFLD FUNCTION EQUAL(IA,IB,L) OTHER SYSTEM-INDEPENDENT I/O ROUTINES: SUBROUTINE GENINP(NEWDAF) SUBROUTINE NBOINP(NBOOPT,IDONE) SUBROUTINE CORINP(IESS,ICOR) SUBROUTINE CHSINP(IESS,ICHS) SUBROUTINE DELINP(NBOOPT,IDONE) SUBROUTINE RDCORE(JCORE) SUBROUTINE WRPPNA(T,OCC,IFLG) SUBROUTINE RDPPNA(T,OCC,IFLG) SUBROUTINE WRTNAO(T,IFLG) SUBROUTINE RDTNAO(DM,T,SCR,IFLG) SUBROUTINE WRTNAB(T,IFLG) SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG) SUBROUTINE WRTNBO(T,BNDOCC,IFLG) SUBROUTINE WRNLMO(T,DM,IFLG) SUBROUTINE WRBAS(SCR,ISCR,LFN) SUBROUTINE WRARC(SCR,ISCR,LFN) SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG) SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL) SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN) SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR) SUBROUTINE ALTOUT(A,MR,MC,NR,NC) SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR) FUNCTION IOINQR(IFLG) SUBROUTINE LBLAO SUBROUTINE LBLNAO SUBROUTINE LBLNBO SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR) GENERAL UTILITY ROUTINES: SUBROUTINE ANGLES(X,Y,Z,THETA,PHI) FUNCTION BDFIND(IAT,JAT) SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR) SUBROUTINE CONSOL(AUT,ALT,NDIM,N) SUBROUTINE CONVIN(IJ,LEN,IK,ERROR) SUBROUTINE CONVRT(N,NC1,NC2) SUBROUTINE COPY(A,B,NDIM,NR,NC) SUBROUTINE CORTBL(IAT,ICORE,IECP) SUBROUTINE DEBYTE(I,IBYTE) SUBROUTINE HALT(WORD) SUBROUTINE IDIGIT(KINT,IK,ND,MAXD) FUNCTION IHTYP(IBO,JBO) SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR) SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT) SUBROUTINE MATMLT(A,B,V,NDIM,N) SUBROUTINE MATML2(A,B,V,NDIM,N) FUNCTION NAMEAT(IZ) SUBROUTINE NORMLZ(A,S,M,N) SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK) SUBROUTINE PACK(T,NDIM,NBAS,L2) SUBROUTINE RANK(EIG,N,NDIM,ARCRNK) SUBROUTINE SIMTRN(A,T,V,NDIM,N) SUBROUTINE SIMTRS(A,S,V,NDIM,N) SUBROUTINE TRANSP(A,NDIM,N) SUBROUTINE UNPACK(T,NDIM,NBAS,L2) SUBROUTINE VALTBL(IAT,IVAL) FUNCTION VECLEN(X,N,NDIM) SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR, + IERR) SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG) SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR) SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM) ***************************************************************************** SUBROUTINE NBO(CORE,MEMORY,NBOOPT) ***************************************************************************** Input: CORE Core memory to be dynamically allocated for storage needs. MEMORY The number of REAL*8 words available in `CORE'. NBOOPT(10) List of NBO options as summarized below: NBOOPT(1) = -2 Do nothing = -1 Natural Population Analysis (NPA) only = 0 Perform NPA/NBO/NLMO analyses = 1 Perform NPA/NBO/NLMO analyses, don't read keywords = 2 Perform one Fock matrix deletion, forming new DM = 3 Evaluate and print the energy change from deletion NBOOPT(2) = 0 SCF density = 1 MP first order density = 3 MP2 density = 4 MP3 density = 5 MP4 density = 6 CI one-particle density = 7 CI density = 8 QCI/CC density = 9 Density correct to second order NBOOPT(3) = 1 Transform dipole moment matrices to NBO/NLMO bases NBOOPT(4) = 1 Allow strongly resonant Lewis Structures (Force the RESONANCE keyword) NBOOPT(5) = 1 Spin-annihilated UHF (AUHF) wavefunction NBOOPT(6-9) Unused NBOOPT(10) = 0 General version of the NBO program (GENNBO) = 1 AMPAC version = 6 GAMESS version = 7 HONDO version = 8x Gaussian 8x version ------------------------------------------------------------------------------ IMPLICIT REAL*8 (A-H,O-Z) LOGICAL NEWDAF,ERROR,SEQ NBO COMMON BLOCKS: PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION CORE(MEMORY),NBOOPT(10) IF NBOOPT(1).EQ.-2, THEN NO NBO ANALYSIS WAS REQUESTED: IF(NBOOPT(1).EQ.-2) RETURN SET DEFAULT OPTIONS: CALL NBOSET(NBOOPT) IF THIS IS THE GENERAL VERSION OF THE PROGRAM, READ THE $GENNBO KEYLIST: IF(NBOOPT(10).EQ.0) THEN CALL GENINP(NEWDAF) ELSE NEWDAF = .TRUE. END IF SEARCH THE INPUT FILE FOR THE $NBO KEYLIST: CALL NBOINP(NBOOPT,IDONE) IF(IDONE.EQ.1) RETURN READ IN JOB OPTIONS FROM THE $NBO KEYLIST: CALL JOBOPT(NBOOPT) CHECK FILENAME AND OPEN SEQUENTIAL FILES: CALL NBFILE(NEWDAF,ERROR) IF(ERROR) RETURN OPEN THE NBO DIRECT ACCESS FILE: CALL NBOPEN(NEWDAF,ERROR) IF(ERROR) THEN WRITE(LFNPR,900) RETURN END IF FETCH ATOMS, BASIS, AND WAVE FUNCTION INFORMATION: CALL FEAOIN(CORE,CORE,NBOOPT) IF(COMPLX) RETURN WRITE THE JOB TITLE TO THE OUTPUT FILE: CALL FETITL(CORE) WRITE(LFNPR,910) (CORE(I),I=1,8) SET UP DIMENSIONING INFORMATION AND DETERMINE IF ENOUGH SPACE IS AVAILABLE: CALL NBODIM(MEMORY) SET UP BASIC STORAGE: CORE(NDM) : NDIM BY NDIM MATRIX TO STORE DENSITY MATRIX CORE(NT) : NDIM BY NDIM MATRIX TO HOLD OVERLAP OR TRANSFORMATION MATRICES CORE(NSCR): SCRATCH STORAGE, DYNAMICALLY ALLOCATED ACCORDING NEEDS N2 = NDIM*NDIM NDM = 1 NT = NDM + N2 NSCR = NT + N2 MEM = MEMORY - NSCR + 1 READ IN INPUT OVERLAP AND DENSITY MATRICES, AO BASIS: ALPHA = .FALSE. BETA = .FALSE. ISPIN = 0 CALL FEDRAW(CORE(NDM),CORE(NSCR)) SIMULATE THE NATURAL POPULATION ANALYSIS IF THE INPUT BASIS IS ORTHOGONAL: IF(ORTHO) THEN CALL NAOSIM(CORE(NDM),CORE(NT),CORE(NSCR)) LOAD THE OVERLAP MATRIX INTO CORE(NT) AND PERFORM THE NATURAL POPULATION ANALYSIS: ELSE CALL FESRAW(CORE(NT)) CALL NAODRV(CORE(NDM),CORE(NT),CORE(NSCR)) END IF NOTE: CORE(NDM) NOW CONTAINS THE TOTAL DENSITY MATRIX IN THE NAO BASIS AND CORE(NT) CONTAINS THE AO TO NAO TRANSFORMATION PERFORM CLOSED SHELL NBO ANALYSIS: IF(.NOT.OPEN) THEN CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM) ELSE PERFORM OPEN SHELL NBO ANALYSIS: FIRST, ANALYZE ALPHA DENSITY MATRIX: ALPHA = .TRUE. BETA = .FALSE. ISPIN = 2 IF(ORTHO) THEN CALL DMSIM(CORE(NDM),CORE(NT),CORE(NSCR)) ELSE CALL DMNAO(CORE(NDM),CORE(NT),CORE(NSCR)) END IF CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM) NOW, ANALYZE BETA DENSITY MATRIX: ALPHA = .FALSE. BETA = .TRUE. ISPIN = -2 IF(ORTHO) THEN CALL DMSIM(CORE(NDM),CORE(NT),CORE(NSCR)) ELSE CALL DMNAO(CORE(NDM),CORE(NT),CORE(NSCR)) END IF CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM) END IF CLOSE THE NBO DIRECT ACCESS FILE AND OTHER EXTERNAL FILES: SEQ = .TRUE. CALL NBCLOS(SEQ) RETURN 900 FORMAT(/1X,'NBO direct access file could not be opened. NBO ', + 'program aborted.') 910 FORMAT(/1X,'Job title: ',8A8) END ***************************************************************************** JOB INITIALIZATION ROUTINES: (CALLED BY SR NBO) SUBROUTINE NBOSET(NBOOPT) SUBROUTINE JOBOPT(NBOOPT) SUBROUTINE NBODIM(MEMORY) ***************************************************************************** SUBROUTINE NBOSET(NBOOPT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION NBOOPT(10) PARAMETER(MAXATM = 99,MAXBAS = 500) PARAMETER(MAXFIL = 40) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBLBL/NLEW,NVAL,LBL(10,MAXBAS,4) COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) CHARACTER*80 FILENM DATA TENTH,HALF/0.1D0,0.5D0/ SET DEFAULT JOB OPTIONS: (MODIFICATIONS TO THESE DEFAULTS SHOULD NOT BE MADE HERE BUT LATER IN THIS SUBROUTINE) USE THE BOND-ORDER MATRIX, NOT THE OCCUPATION MATRIX (EXPECTATION VALUES OF THE DENSITY OPERATOR) IWDM = 1 IW3C = 0 IWAPOL = 0 IWHYBS = 0 IWPNAO = 0 IWTNAO = 0 IWTNAB = 0 IWTNBO = 0 USE THE FOCK MATRIX, IF THERE IS ONE: IWFOCK = 1 SET TO THE DESIRED PRINT LEVEL + 10: IPRINT = 12 IPSEUD = 0 IWDETL = 0 IWMULP = 0 ICHOOS = 0 KOPT = 0 JCORE = 0 IWCUBF = 0 OPEN = .FALSE. ORTHO = .FALSE. UHF = .FALSE. AUHF = .FALSE. ROHF = .FALSE. CI = .FALSE. MCSCF = .FALSE. COMPLX = .FALSE. DO 10 I = 1,60 JPRINT(I) = 0 10 CONTINUE LFNAO = 31 LFNPNA = 32 LFNNAO = 33 LFNPNH = 34 LFNNHO = 35 LFNPNB = 36 LFNNBO = 37 LFNPNL = 38 LFNNLM = 39 LFNMO = 40 LFNDM = 41 LFNNAB = 42 LFNPPA = 43 LFNARC = 47 SET POSITIVE IN ROUTINE JOBOPT IF CHOSEN BY THE USER: LFNDAF = -48 LFNDEF = 49 SETTING NVAL NEGATIVE INDICATES THAT THIS VARIABLE HAS NOT BEEN DETERMINED YET: NVAL = -1 INITIALIZE THE CHARACTER STRING USED TO CREATE FILENAMES: FILENM(1:4) = 'FILE' DO 50 I = 5,80 FILENM(I:I) = CHAR(32) 50 CONTINUE THAT SOME THRESHOLDS ARE .LT.0 INDICATES THAT THESE VARIABLES HAVE NOT BEEN SET BY THE USER: THRSET = -1.9D0 PRJSET = -0.2D0 ACCTHR = -TENTH CRTSET = 1.999 E2THR = -HALF ATHR = -1.000 PTHR = -25.000 ETHR = -0.100 DTHR = -0.020 DLTHR = -1.000 CHSTHR = -0.100 SET JOB OPTIONS ACCORDING TO NBOOPT: SKIP THE COMPUTATION OF THE NBOS? IF(NBOOPT(1).EQ.-1) JPRINT(1) = 1 TURN OFF $CHOOSE AND $CORE KEYLISTS IF $NBO KEYLIST IS NOT TO BE READ: IF(NBOOPT(1).EQ.1) ICHOOS = -1 IF(NBOOPT(1).EQ.1) JCORE = -1 FORCE DIPOLE ANALYSIS? IF(NBOOPT(3).NE.0) THEN JPRINT(46) = 1 END IF FORCE RESONANCE KEYWORD? IF(NBOOPT(4).NE.0) JPRINT(14) = 1 PROGRAM VERSION: JPRINT(2) = NBOOPT(10) RETURN END ****************************************************************************** SUBROUTINE JOBOPT(NBOOPT) ****************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ERROR,END,EQUAL,NEXTWD,READ DIMENSION NBOOPT(10),INTTMP(80) PARAMETER(KEYLEN = 9) PARAMETER(MAXFIL = 40) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) CHARACTER*80 FILENM DIMENSION KEYWD(KEYLEN),K3CBND(6),KEPERT(6),KLFNPR(5),KTHRSH(6), * KDETL(6),KMULA(5),KMULOR(6),KPRJTH(6),KNBNLM(7), * KAOPRE(6),KNLMO(4),KNAOMO(5),KNBOMO(5),KNOBND(6),KNPA(3), * KSKIPB(6),KRPNAO(5),KBNDID(6),KNLMMO(6),KRESON(5),KPPNAO(7), * KAONAO(5),KNANBO(6),KAONBO(5),KAONLM(6),KFNBO(4),KFNLMO(5), * KDMNBO(5),KDMNLM(6),KPRINT(5),KNANLM(7),KSPNAO(5),KSPNHO(5), * KSPNBO(5),KAOINF(6),KAOPNB(6),KAOMO(4),KNAONH(6),KNHNLM(7), * KAONHO(5),KFNHO(4),KAOPNH(6),KFNAO(4),KNHONB(6),KSPNLM(6), * KNRT(3),KDMNHO(5),KDMNAO(5),KPLOT(4),KAOPNL(7),KDIAO(4), * KBEND(4),KNHOMO(5),KSAO(3),KFAO(3),KDMAO(4),KBOAO(4),KDINLM(6), * KNBOSM(6),KNBO(3),KDIPOL(6),KDINAO(5),KDINHO(5),KDINBO(5), * KNBDAF(6),KARCHV(7),KFILE(4),KPOLAR(6),KNRTOP(6),KNRTRF(6), * KCHSTH(6),KNRTDT(6),KNRTTH(6) DIMENSION KALT(4),KBFGS(4),KPOWEL(6),KSAP(3) DATA K3CBND/1H3,1HC,1HB,1HO,1HN,1HD/,KLFNPR/1HL,1HF,1HN,1HP,1HR/, * KTHRSH/1HT,1HH,1HR,1HE,1HS,1HH/,KEPERT/1HE,1H2,1HP,1HE,1HR,1HT/, * KPLOT/1HP,1HL,1HO,1HT/,KDETL/1HD,1HE,1HT,1HA,1HI,1HL/, * KMULA/1HM,1HU,1HL,1HA,1HT/,KMULOR/1HM,1HU,1HL,1HO,1HR,1HB/, * KPRJTH/1HP,1HR,1HJ,1HT,1HH,1HR/,KAOPRE/1HA,1HO,1HP,1HN,1HA,1HO/, * KNLMO/1HN,1HL,1HM,1HO/,KNPA/1HN,1HP,1HA/,KNBO/1HN,1HB,1HO/, * KNAOMO/1HN,1HA,1HO,1HM,1HO/,KNBOMO/1HN,1HB,1HO,1HM,1HO/, * KNOBND/1HN,1HO,1HB,1HO,1HN,1HD/,KSKIPB/1HS,1HK,1HI,1HP,1HB,1HO/, * KRPNAO/1HR,1HP,1HN,1HA,1HO/,KBNDID/1HB,1HN,1HD,1HI,1HD,1HX/, * KNLMMO/1HN,1HL,1HM,1HO,1HM,1HO/,KRESON/1HR,1HE,1HS,1HO,1HN/, * KPPNAO/1HP,1HA,1HO,1HP,1HN,1HA,1HO/,KAONAO/1HA,1HO,1HN,1HA,1HO/, * KNANBO/1HN,1HA,1HO,1HN,1HB,1HO/,KAONBO/1HA,1HO,1HN,1HB,1HO/ DATA KAONLM/1HA,1HO,1HN,1HL,1HM,1HO/,KFNBO/1HF,1HN,1HB,1HO/, * KFNLMO/1HF,1HN,1HL,1HM,1HO/,KPRINT/1HP,1HR,1HI,1HN,1HT/, * KDMNBO/1HD,1HM,1HN,1HB,1HO/,KDMNLM/1HD,1HM,1HN,1HL,1HM,1HO/, * KNANLM/1HN,1HA,1HO,1HN,1HL,1HM,1HO/,KAOMO/1HA,1HO,1HM,1HO/, * KSPNAO/1HS,1HP,1HN,1HA,1HO/,KSPNHO/1HS,1HP,1HN,1HH,1HO/, * KSPNBO/1HS,1HP,1HN,1HB,1HO/,KFNAO/1HF,1HN,1HA,1HO/, * KAOINF/1HA,1HO,1HI,1HN,1HF,1HO/,KAOPNB/1HA,1HO,1HP,1HN,1HB,1HO/, * KAONHO/1HA,1HO,1HN,1HH,1HO/,KFNHO/1HF,1HN,1HH,1HO/, * KAOPNH/1HA,1HO,1HP,1HN,1HH,1HO/,KNRT/1HN,1HR,1HT/, * KNBNLM/1HN,1HB,1HO,1HN,1HL,1HM,1HO/,KDIAO/1HD,1HI,1HA,1HO/, * KDMNHO/1HD,1HM,1HN,1HH,1HO/,KDMNAO/1HD,1HM,1HN,1HA,1HO/, * KBEND/1HB,1HE,1HN,1HD/,KNBOSM/1HN,1HB,1HO,1HS,1HU,1HM/, * KNHOMO/1HN,1HH,1HO,1HM,1HO/,KSAO/1HS,1HA,1HO/,KFAO/1HF,1HA,1HO/ DATA KDMAO/1HD,1HM,1HA,1HO/,KBOAO/1HB,1HO,1HA,1HO/, * KDIPOL/1HD,1HI,1HP,1HO,1HL,1HE/,KNAONH/1HN,1HA,1HO,1HN,1HH,1HO/, * KNHNLM/1HN,1HH,1HO,1HN,1HL,1HM,1HO/,KDINAO/1HD,1HI,1HN,1HA,1HO/, * KNHONB/1HN,1HH,1HO,1HN,1HB,1HO/,KSPNLM/1HS,1HP,1HN,1HL,1HM,1HO/, * KAOPNL/1HA,1HO,1HP,1HN,1HL,1HM,1HO/,KDINHO/1HD,1HI,1HN,1HH,1HO/, * KDINBO/1HD,1HI,1HN,1HB,1HO/,KDINLM/1HD,1HI,1HN,1HL,1HM,1HO/, * KNBDAF/1HN,1HB,1HO,1HD,1HA,1HF/, * KARCHV/1HA,1HR,1HC,1HH,1HI,1HV,1HE/,KFILE/1HF,1HI,1HL,1HE/, * KPOLAR/1HA,1HP,1HO,1HL,1HA,1HR/,KNRTOP/1HN,1HR,1HT,1HO,1HP,1HT/, * KNRTRF/1HN,1HR,1HT,1HR,1HE,1HF/,KCHSTH/1HC,1HH,1HS,1HT,1HH,1HR/, * KNRTDT/1HN,1HR,1HT,1HD,1HT,1HL/, * KNRTTH/1HN,1HR,1HT,1HT,1HH,1HR/ DATA KALT/1H$,1HE,1HN,1HD/,KBFGS/1HB,1HF,1HG,1HS/, * KPOWEL/1HP,1HO,1HW,1HE,1HL,1HL/,KSAP/1HS,1HA,1HP/ DATA ZERO,ONE/0.0D0,1.0D0/ DATA IFULL,IVAL,ILEW/4HFULL,3HVAL,3HLEW/ DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/ DATA IA,IB,IP/1HA,1HB,1HP/ READ IN JOB OPTIONS, IN A KEYWORD DIRECTED MANNER: NUMOPT = 0 LENNM = 0 IF(NBOOPT(1).EQ.1) GOTO 4500 BEGIN LOOP TO IDENTIFY KEYWORD "KEYWD": NEXTWD = .TRUE. 100 LENG = KEYLEN IF(NEXTWD) CALL HFLD(KEYWD,LENG,END) NEXTWD = .TRUE. IF((LENG.EQ.0).OR.END) GO TO 4500 IF(EQUAL(KEYWD,KALT,4)) GO TO 4500 NUMOPT = NUMOPT + 1 KEYWORD: 3CBOND -- SEARCH FOR THREE-CENTER BONDS (DEFAULT IS TO SEARCH ONLY FOR ONE- AND TWO-CENTER NBOS) IF(.NOT.EQUAL(KEYWD,K3CBND,6)) GO TO 500 IW3C = 1 GO TO 100 KEYWORD: LFNPR -- SPECIFY OUTPUT LFN 500 IF(.NOT.EQUAL(KEYWD,KLFNPR,5)) GO TO 510 CALL IFLD(LFNPR,ERROR) IF(ERROR) CALL HALT('LFNPR') GO TO 100 KEYWORD: THRESH -- SPECIFY FIXED OCCUPANCY THRESHOLD FOR NBO SEARCH 510 IF(.NOT.EQUAL(KEYWD,KTHRSH,6)) GO TO 540 CALL RFLD(THRSET,ERROR) IF(ERROR) CALL HALT('THRESH') GO TO 100 KEYWORD: DETAIL -- PRINT DETAILS OF NBO SEARCH PROCEDURE 540 IF(.NOT.EQUAL(KEYWD,KDETL,6)) GO TO 550 IWDETL = 1 GO TO 100 KEYWORD: MULAT -- PRINT MULLIKEN POPULATIONS BY ATOM 550 IF(.NOT.EQUAL(KEYWD,KMULA,5)) GO TO 560 IWMULP = 1 GO TO 100 KEYWORD: MULORB -- PRINT MULLIKEN POPULATIONS BY ORBITAL AND ATOM 560 IF(.NOT.EQUAL(KEYWD,KMULOR,6)) GO TO 580 IWMULP = 2 GO TO 100 KEYWORD: PRJTHR -- USER SETS VALUE OF PROJECTION THRESHOLD FOR NBO SEARCH FOR REJECTING LINEARLY DEPENDENT HYBRIDS 580 IF(.NOT.EQUAL(KEYWD,KPRJTH,6)) GO TO 610 CALL RFLD(PRJSET,ERROR) IF(ERROR) CALL HALT('PRJTHR') GO TO 100 KEYWORD: FNBO -- PRINT NBO FOCK MATRIX 610 IF(.NOT.EQUAL(KEYWD,KFNBO,4)) GO TO 620 JPRINT(37) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(37),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(37).EQ.IVAL) JPRINT(37) = IFULL END IF GO TO 100 KEYWORD: AOPNAO -- OUTPUT RAW AO TO PNAO TRANSFORMATION 620 IF(.NOT.EQUAL(KEYWD,KAOPRE,6)) GO TO 640 JPRINT(44) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(44),LFNPNA,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(44).EQ.IVAL) JPRINT(44) = IFULL IF(JPRINT(44).EQ.ILEW) JPRINT(44) = IFULL END IF GO TO 100 KEYWORD: NLMOMO -- COMPUTE AND PRINT NLMO TO MO TRANSF. 640 IF(.NOT.EQUAL(KEYWD,KNLMMO,6)) GO TO 650 JPRINT(13) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(13),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. END IF GO TO 100 KEYWORD: NLMO -- COMPUTE AND PRINT NLMOS 650 IF(.NOT.EQUAL(KEYWD,KNLMO,4)) GO TO 660 IF(LENG.NE.4) GO TO 660 JPRINT(8) = 1 GO TO 100 KEYWORD: NAOMO -- COMPUTE AND PRINT NAO TO MO TRANSF. 660 IF(.NOT.EQUAL(KEYWD,KNAOMO,5)) GO TO 670 JPRINT(9) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(9),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. END IF GO TO 100 KEYWORD: NBOMO -- COMPUTE AND PRINT NBO TO MO TRANSF. 670 IF(.NOT.EQUAL(KEYWD,KNBOMO,5)) GO TO 680 JPRINT(45) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(45),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. END IF GO TO 100 KEYWORD: NOBOND -- COMPUTE ONLY ONE-CENTER NBOS 680 IF(.NOT.EQUAL(KEYWD,KNOBND,6)) GO TO 690 JPRINT(10) = 1 GO TO 100 KEYWORD: SKIPBO -- SKIP NBO PROCEDURE 690 IF(.NOT.EQUAL(KEYWD,KSKIPB,6)) GO TO 700 JPRINT(1) = 1 GO TO 100 KEYWORD: RPNAO -- COMPUTE REVISED PURE AO TO PNAO TRANSF. 700 IF(.NOT.EQUAL(KEYWD,KRPNAO,5)) GO TO 710 JPRINT(11) = 1 GO TO 100 KEYWORD: BNDIDX -- PRINT BOND INDICES 710 IF(.NOT.EQUAL(KEYWD,KBNDID,6)) GO TO 730 JPRINT(12) = 1 GO TO 100 KEYWORD: RESONANCE -- ALLOW STRONGLY "NON-LEWIS" NBO OCCUPANCIES (OVERRIDES AUTOMATIC SHUTDOWN OF NBO PROCEDURE IN STRONGLY DELOCALIZED CASES) 730 IF(.NOT.EQUAL(KEYWD,KRESON,5)) GO TO 740 JPRINT(14) = 1 GO TO 100 KEYWORD: PAOPNAO -- I/O WITH PAO TO PNAO TRANSFORMATION 740 IF(.NOT.EQUAL(KEYWD,KPPNAO,7)) GO TO 750 IWPNAO = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .TRUE. CALL KEYPAR(KEYWD,LENG,IWPNAO,LFNPPA,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(IWPNAO.EQ.IVAL) IWPNAO = IFULL IF(IWPNAO.EQ.ILEW) IWPNAO = IFULL END IF GO TO 100 KEYWORD: AONAO -- I/O WITH AO TO NAO TRANSFORMATION 750 IF(.NOT.EQUAL(KEYWD,KAONAO,5)) GO TO 760 IWTNAO = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .TRUE. CALL KEYPAR(KEYWD,LENG,IWTNAO,LFNNAO,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(IWTNAO.EQ.IVAL) IWTNAO = IFULL IF(IWTNAO.EQ.ILEW) IWTNAO = IFULL END IF GO TO 100 KEYWORD: NAONBO -- I/O WITH NAO TO NBO TRANSFORMATION 760 IF(.NOT.EQUAL(KEYWD,KNANBO,6)) GO TO 770 IWTNAB = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .TRUE. CALL KEYPAR(KEYWD,LENG,IWTNAB,LFNNAB,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(IWTNAB.EQ.IVAL) IWTNAB = IFULL END IF GO TO 100 KEYWORD: AONBO -- OUTPUT AO TO NBO TRANSF. INFORMATION 770 IF(.NOT.EQUAL(KEYWD,KAONBO,5)) GO TO 780 IWTNBO = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,IWTNBO,LFNNBO,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(IWTNBO.EQ.IVAL) IWTNBO = IFULL END IF GO TO 100 KEYWORD: FNLMO -- PRINT NLMO FOCK MATRIX 780 IF(.NOT.EQUAL(KEYWD,KFNLMO,5)) GO TO 790 JPRINT(15) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(15),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(15).EQ.IVAL) JPRINT(15) = IFULL END IF GO TO 100 KEYWORD: DMNBO -- PRINT NBO DENSITY MATRIX 790 IF(.NOT.EQUAL(KEYWD,KDMNBO,5)) GO TO 800 JPRINT(16) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(16),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(16).EQ.IVAL) JPRINT(16) = IFULL END IF GO TO 100 KEYWORD: DMNLMO -- PRINT NLMO DENSITY MATRIX 800 IF(.NOT.EQUAL(KEYWD,KDMNLM,6)) GO TO 810 JPRINT(17) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(17),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(17).EQ.IVAL) JPRINT(17) = IFULL END IF GO TO 100 KEYWORD: AONLMO -- COMPUTE AND OUTPUT AO TO NLMO TRANSF. 810 IF(.NOT.EQUAL(KEYWD,KAONLM,6)) GO TO 820 JPRINT(23) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(23),LFNNLM,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(23).EQ.IVAL) JPRINT(23) = IFULL END IF GO TO 100 KEYWORD: PRINT -- READ IN PRINT OPTION LEVEL "IPRINT" 820 IF(.NOT.EQUAL(KEYWD,KPRINT,5)) GO TO 830 CALL IFLD(IPRINT,ERROR) IF(ERROR) CALL HALT('PRINT') GO TO 100 KEYWORD: NAONLMO -- PRINT NAO TO NLMO TRANSFORMATION MATRIX 830 IF(.NOT.EQUAL(KEYWD,KNANLM,7)) GO TO 840 JPRINT(18) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(18),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(18).EQ.IVAL) JPRINT(18) = IFULL END IF GO TO 100 KEYWORD: SPNAO -- PRINT S-PNAO OVERLAP MATRIX 840 IF(.NOT.EQUAL(KEYWD,KSPNAO,5)) GO TO 850 JPRINT(19) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(19),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(19).EQ.IVAL) JPRINT(19) = IFULL IF(JPRINT(19).EQ.ILEW) JPRINT(19) = IFULL END IF GO TO 100 KEYWORD: SPNHO -- PRINT S-PNHO OVERLAP MATRIX 850 IF(.NOT.EQUAL(KEYWD,KSPNHO,5)) GO TO 860 JPRINT(20) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(20),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(20).EQ.IVAL) JPRINT(20) = IFULL IF(JPRINT(20).EQ.ILEW) JPRINT(20) = IFULL END IF GO TO 100 KEYWORD: NHONLMO -- OUTPUT THE NHO TO NLMO TRANSFORMATION 860 IF(.NOT.EQUAL(KEYWD,KNHNLM,7)) GO TO 870 JPRINT(24) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(24),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(24).EQ.IVAL) JPRINT(24) = IFULL END IF GO TO 100 KEYWORD: SPNBO -- PRINT S-PNBO OVERLAP MATRIX 870 IF(.NOT.EQUAL(KEYWD,KSPNBO,5)) GO TO 880 JPRINT(21) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(21),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(21).EQ.IVAL) JPRINT(21) = IFULL END IF GO TO 100 KEYWORD: AOINFO -- WRITE BASIS SET INFO 880 IF(.NOT.EQUAL(KEYWD,KAOINF,6)) GO TO 910 JPRINT(22) = LFNAO CALL IFLD(ITEMP,ERROR) IF(.NOT.ERROR) JPRINT(22) = ABS(ITEMP) GO TO 100 KEYWORD: AOPNBO -- WRITE AO TO PNBO TRANSFORMATION 910 IF(.NOT.EQUAL(KEYWD,KAOPNB,6)) GO TO 920 JPRINT(25) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(25),LFNPNB,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(25).EQ.IVAL) JPRINT(25) = IFULL END IF GO TO 100 KEYWORD: AOMO -- WRITE AO TO MO TRANSFORMATION 920 IF(.NOT.EQUAL(KEYWD,KAOMO,4)) GO TO 930 JPRINT(26) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(26),LFNMO,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. END IF GO TO 100 KEYWORD: DMAO -- WRITE AO DENSITY MATRIX 930 IF(.NOT.EQUAL(KEYWD,KDMAO,4)) GO TO 940 JPRINT(27) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(27),LFNDM,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(27).EQ.IVAL) JPRINT(27) = IFULL IF(JPRINT(27).EQ.ILEW) JPRINT(27) = IFULL END IF GO TO 100 KEYWORD: AONHO -- WRITE AO TO NHO TRANSFORMATION 940 IF(.NOT.EQUAL(KEYWD,KAONHO,5)) GO TO 950 JPRINT(28) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(28),LFNNHO,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(28).EQ.IVAL) JPRINT(28) = IFULL IF(JPRINT(28).EQ.ILEW) JPRINT(28) = IFULL END IF GO TO 100 KEYWORD: FNHO -- PRINT NHO FOCK MATRIX 950 IF(.NOT.EQUAL(KEYWD,KFNHO,4)) GO TO 960 JPRINT(29) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(29),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(29).EQ.IVAL) JPRINT(29) = IFULL IF(JPRINT(29).EQ.ILEW) JPRINT(29) = IFULL END IF GO TO 100 KEYWORD: AOPNHO -- WRITE AO TO PNHO TRANSFORMATION 960 IF(.NOT.EQUAL(KEYWD,KAOPNH,6)) GO TO 970 JPRINT(30) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(30),LFNPNH,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(30).EQ.IVAL) JPRINT(30) = IFULL IF(JPRINT(30).EQ.ILEW) JPRINT(30) = IFULL END IF GO TO 100 KEYWORD: FNAO -- PRINT NAO FOCK MATRIX 970 IF(.NOT.EQUAL(KEYWD,KFNAO,4)) GO TO 990 JPRINT(31) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(31),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(31).EQ.IVAL) JPRINT(31) = IFULL IF(JPRINT(31).EQ.ILEW) JPRINT(31) = IFULL END IF GO TO 100 KEYWORD: NAONHO -- OUTPUT THE NAO TO NHO TRANSFORMATION 990 IF(.NOT.EQUAL(KEYWD,KNAONH,6)) GO TO 1010 JPRINT(33) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(33),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(33).EQ.IVAL) JPRINT(33) = IFULL IF(JPRINT(33).EQ.ILEW) JPRINT(33) = IFULL END IF GO TO 100 KEYWORD: DMNHO -- PRINT NHO DENSITY MATRIX 1010 IF(.NOT.EQUAL(KEYWD,KDMNHO,5)) GO TO 1020 JPRINT(34) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(34),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(34).EQ.IVAL) JPRINT(34) = IFULL IF(JPRINT(34).EQ.ILEW) JPRINT(34) = IFULL END IF GO TO 100 KEYWORD: DMNAO -- PRINT NAO DENSITY MATRIX 1020 IF(.NOT.EQUAL(KEYWD,KDMNAO,5)) GO TO 1040 JPRINT(35) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(35),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(35).EQ.IVAL) JPRINT(35) = IFULL IF(JPRINT(35).EQ.ILEW) JPRINT(35) = IFULL END IF GO TO 100 KEYWORD: BEND -- PRINT NHO DIRECTIONALITY AND BOND BENDING INFO 1040 IF(.NOT.EQUAL(KEYWD,KBEND,4)) GO TO 1050 JPRINT(36) = 1 CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 ATHR = ABS(TEMP) CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 PTHR = ABS(TEMP) IF(PTHR.LT.ONE) PTHR = ONE CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 ETHR = ABS(TEMP) GO TO 100 KEYWORD: NHOMO -- COMPUTE AND PRINT NHO TO MO TRANSF. 1050 IF(.NOT.EQUAL(KEYWD,KNHOMO,5)) GO TO 1060 JPRINT(38) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(38),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. END IF GO TO 100 KEYWORD: SAO -- PRINT AO OVERLAP MATRIX 1060 IF(.NOT.EQUAL(KEYWD,KSAO,3)) GO TO 1070 JPRINT(39) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(39),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(39).EQ.IVAL) JPRINT(39) = IFULL IF(JPRINT(39).EQ.ILEW) JPRINT(39) = IFULL END IF GO TO 100 KEYWORD: FAO -- PRINT AO FOCK MATRIX 1070 IF(.NOT.EQUAL(KEYWD,KFAO,3)) GO TO 1080 JPRINT(40) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(40),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(40).EQ.IVAL) JPRINT(40) = IFULL IF(JPRINT(40).EQ.ILEW) JPRINT(40) = IFULL END IF GO TO 100 KEYWORD: NHONBO -- OUTPUT NHO TO NBO TRANSFORMATION 1080 IF(.NOT.EQUAL(KEYWD,KNHONB,6)) GO TO 1090 JPRINT(41) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(41),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(41).EQ.IVAL) JPRINT(41) = IFULL END IF GO TO 100 KEYWORD: BOAO -- PRINT AO BOND-ORDER MATRIX 1090 IF(.NOT.EQUAL(KEYWD,KBOAO,4)) GO TO 1100 JPRINT(42) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(42),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(42).EQ.IVAL) JPRINT(42) = IFULL IF(JPRINT(42).EQ.ILEW) JPRINT(42) = IFULL END IF GO TO 100 KEYWORD: E2PERT -- 2ND-ORDER PERTURBATIVE ANALYSIS OF THE NBO FOCK MATRIX 1100 IF(.NOT.EQUAL(KEYWD,KEPERT,6)) GO TO 1110 JPRINT(3) = 1 CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 E2THR = ABS(TEMP) GO TO 100 KEYWORD: PLOT -- WRITE AO BASIS, DENSITY, AND TRANSFORMS FOR PLOTTING 1110 IF(.NOT.EQUAL(KEYWD,KPLOT,4)) GO TO 1120 JPRINT(43) = 1 GO TO 100 KEYWORD: NPA -- PRINT THE NATURAL POPULATION ANALYSIS 1120 IF(.NOT.EQUAL(KEYWD,KNPA,3)) GO TO 1130 JPRINT(4) = 1 GO TO 100 KEYWORD: NBOSUM -- PRINT THE NBO SUMMARY 1130 IF(.NOT.EQUAL(KEYWD,KNBOSM,6)) GO TO 1140 JPRINT(6) = 1 GO TO 100 KEYWORD: NBO -- PRINT THE NBO ANALYSIS 1140 IF(.NOT.EQUAL(KEYWD,KNBO,3)) GO TO 1150 IF(LENG.NE.3) GO TO 1150 JPRINT(5) = 1 GO TO 100 KEYWORD: DIPOLE -- PRINT NBO/NLMO DIPOLE ANALYSIS: 1150 IF(.NOT.EQUAL(KEYWD,KDIPOL,6)) GO TO 1160 JPRINT(46) = 1 CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 DTHR = ABS(TEMP) GO TO 100 KEYWORD: NBONLMO -- PRINT NBO TO NLMO TRANSFORMATION MATRIX 1160 IF(.NOT.EQUAL(KEYWD,KNBNLM,7)) GO TO 1170 JPRINT(47) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(47),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(47).EQ.IVAL) JPRINT(47) = IFULL END IF GO TO 100 KEYWORD: SPNLMO -- OUTPUT THE PNLMO OVERLAP MATRIX 1170 IF(.NOT.EQUAL(KEYWD,KSPNLM,6)) GO TO 1180 JPRINT(48) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(48),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(48).EQ.IVAL) JPRINT(48) = IFULL END IF GO TO 100 KEYWORD: AOPNLMO -- OUTPUT THE AO-PNLMO TRANSFORMATION MATRIX 1180 IF(.NOT.EQUAL(KEYWD,KAOPNL,7)) GO TO 1190 JPRINT(49) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(49),LFNPNL,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(49).EQ.IVAL) JPRINT(49) = IFULL END IF GO TO 100 KEYWORD: DIAO -- OUTPUT THE AO DIPOLE INTEGRALS 1190 IF(.NOT.EQUAL(KEYWD,KDIAO,4)) GO TO 1200 JPRINT(50) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(50),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(50).EQ.IVAL) JPRINT(50) = IFULL IF(JPRINT(50).EQ.ILEW) JPRINT(50) = IFULL END IF GO TO 100 KEYWORD: DINAO -- OUTPUT THE NAO DIPOLE INTEGRALS 1200 IF(.NOT.EQUAL(KEYWD,KDINAO,5)) GO TO 1210 JPRINT(51) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(51),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(51).EQ.IVAL) JPRINT(51) = IFULL IF(JPRINT(51).EQ.ILEW) JPRINT(51) = IFULL END IF GO TO 100 KEYWORD: DINHO -- OUTPUT THE NHO DIPOLE INTEGRALS 1210 IF(.NOT.EQUAL(KEYWD,KDINHO,5)) GO TO 1220 JPRINT(52) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(52),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(52).EQ.IVAL) JPRINT(52) = IFULL IF(JPRINT(52).EQ.ILEW) JPRINT(52) = IFULL END IF GO TO 100 KEYWORD: DINBO -- OUTPUT THE NBO DIPOLE INTEGRALS 1220 IF(.NOT.EQUAL(KEYWD,KDINBO,5)) GO TO 1230 JPRINT(53) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(53),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(53).EQ.IVAL) JPRINT(53) = IFULL END IF GO TO 100 KEYWORD: DINLMO -- OUTPUT THE NLMO DIPOLE INTEGRALS 1230 IF(.NOT.EQUAL(KEYWD,KDINLM,6)) GO TO 1240 JPRINT(54) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(54),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(54).EQ.IVAL) JPRINT(54) = IFULL END IF GO TO 100 KEYWORD: NBODAF -- CHOOSE AN ALTERNATE DAF 1240 IF(.NOT.EQUAL(KEYWD,KNBDAF,6)) GO TO 1250 LFNDAF = ABS(LFNDAF) CALL IFLD(ITEMP,ERROR) IF(.NOT.ERROR) LFNDAF = ABS(ITEMP) GO TO 100 KEYWORD: ARCHIVE -- WRITE THE ARCHIVE FILE 1250 IF(.NOT.EQUAL(KEYWD,KARCHV,7)) GO TO 1260 JPRINT(7) = LFNARC CALL IFLD(ITEMP,ERROR) IF(.NOT.ERROR) JPRINT(7) = ABS(ITEMP) GO TO 100 KEYWORD: FILE -- SELECT ALTERNATE FILENAME 1260 IF(.NOT.EQUAL(KEYWD,KFILE,4)) GO TO 1270 LENG = 80 CALL HFLD(INTTMP,LENG,END) IF(.NOT.END) LENNM = LENG GO TO 100 KEYWORD: APOLAR -- ENFORCE APOLAR BONDS: 1270 IF(.NOT.EQUAL(KEYWD,KPOLAR,6)) GO TO 1290 IWAPOL = 1 GO TO 100 KEYWORD: NRTOPT -- OPTIMIZE NRT WEIGHTS: 1290 IF(.NOT.EQUAL(KEYWD,KNRTOP,6)) GO TO 1300 IF(JPRINT(14).EQ.0) JPRINT(14) = 1 IF(JPRINT(32).EQ.0) JPRINT(32) = 1 JPRINT(55) = IB LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN IF(EQUAL(KEYWD,KBFGS,4)) THEN JPRINT(55) = IB ELSE IF(EQUAL(KEYWD,KPOWEL,6)) THEN JPRINT(55) = IP ELSE IF(EQUAL(KEYWD,KSAP,3)) THEN JPRINT(55) = 1234567 IF(LENG.GT.3) CALL CONVIN(KEYWD(4),LENG-3,JPRINT(55),ERROR) IF(ERROR) CALL HALT('NRTOPT') JPRINT(55) = ABS(JPRINT(55)) ELSE IF(EQUAL(KEYWD,KSAP,2)) THEN JPRINT(55) = -1234567 IF(LENG.GT.2) CALL CONVIN(KEYWD(3),LENG-2,JPRINT(55),ERROR) IF(ERROR) CALL HALT('NRTOPT') JPRINT(55) = -ABS(JPRINT(55)) ELSE NEXTWD = .FALSE. END IF END IF GO TO 100 KEYWORD: NRTREF -- NUMBER OF REFERENCE STRUCTURES IN NRT ANALYSIS 1300 IF(.NOT.EQUAL(KEYWD,KNRTRF,6)) GO TO 1310 IF(JPRINT(14).EQ.0) JPRINT(14) = 1 IF(JPRINT(32).EQ.0) JPRINT(32) = 1 CALL IFLD(ITEMP,ERROR) IF(ERROR) GO TO 100 JPRINT(56) = MAX(1,ABS(ITEMP)) GO TO 100 KEYWORD: CHSTHR -- SET THE OCCUPANCY THRESHOLD IN CHOOSE 1310 IF(.NOT.EQUAL(KEYWD,KCHSTH,6)) GO TO 1320 CHSTHR = ABS(CHSTHR) CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 CHSTHR = ABS(TEMP) GO TO 100 KEYWORD: NRTDTL -- DETAIL NRT ANALYSIS 1320 IF(.NOT.EQUAL(KEYWD,KNRTDT,6)) GO TO 1340 IF(JPRINT(14).EQ.0) JPRINT(14) = 1 IF(JPRINT(32).EQ.0) JPRINT(32) = 1 JPRINT(57) = 1 CALL IFLD(ITEMP,ERROR) IF(ERROR) GO TO 100 JPRINT(57) = MAX(1,ABS(ITEMP)) GO TO 100 KEYWORD: NRTTHR -- SET THRESHOLD FOR DELOCALIZATION LIST 1340 IF(.NOT.EQUAL(KEYWD,KNRTTH,6)) GO TO 1360 IF(JPRINT(14).EQ.0) JPRINT(14) = 1 IF(JPRINT(32).EQ.0) JPRINT(32) = 1 DLTHR = ABS(DLTHR) CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 DLTHR = ABS(TEMP) GO TO 100 KEYWORD: NRT -- PERFORM NATURAL RESONANCE THEORY ANALYSIS: (NOTE THAT WE SHOULD CHECK THIS KEYWORD AFTER WE CHECK THE OTHER `NRT' KEYWORDS, LIKE `NRTOPT'. OTHERWISE, KEYWORD CONFLICTS CAN OCCUR.) 1360 IF(.NOT.EQUAL(KEYWD,KNRT,3)) GO TO 1370 JPRINT(14) = 1 JPRINT(32) = 1 CALL IFLD(ITEMP,ERROR) IF(.NOT.ERROR) JPRINT(32) = ITEMP GO TO 100 1370 GO TO 4800 ------------------------------------------------------------------------------ 4500 CONTINUE IF OPTION `FILE' WAS SELECTED, EXTRACT THE FILENAME FROM HOLLERITH ARRAY INTTMP: IF(LENNM.NE.0) THEN IDIV = IB - IA DO 4510 I = 1,LENNM FILENM(I:I) = CHAR(MOD((INTTMP(I)-IA)/IDIV,256) + 65) 4510 CONTINUE DO 4520 I = LENNM+1,80 FILENM(I:I) = CHAR(32) 4520 CONTINUE END IF ------------------------------------------------------------------------------ IF THE PRINT LEVEL IS SET TO ZERO AND NO OTHER OPTIONS WERE ENTERED, COMPLETELY SHUT OFF PROGRAM PRINTING: IF(NUMOPT.EQ.1.AND.IPRINT.EQ.0) IPRINT = -1 CHECK FOR JOB OPTIONS THAT ARE CURRENTLY INCOMPATABLE: IF((IWDM.EQ.0).AND.(IWMULP.NE.0)) GO TO 4900 CHECK FOR JOB OPTIONS THAT ARE STRICTLY INCOMPATIBLE: IF(ORTHO) THEN IWTNAO = 0 JPRINT(9) = 0 JPRINT(11) = 0 JPRINT(18) = 0 JPRINT(19) = 0 JPRINT(20) = 0 JPRINT(21) = 0 JPRINT(25) = 0 JPRINT(30) = 0 JPRINT(31) = 0 JPRINT(33) = 0 JPRINT(35) = 0 JPRINT(39) = 0 JPRINT(44) = 0 JPRINT(48) = 0 JPRINT(49) = 0 JPRINT(51) = 0 END IF ------------------------------------------------------------------------------ START PRINTING NBO OUTPUT: IF(IPRINT.GE.0) THEN WRITE(LFNPR,6000) IF(NUMOPT.GT.0) WRITE(LFNPR,6010) ------------------------------------------------------------------------------ 6000 FORMAT(/1X,79('*')/,13X, * 'N A T U R A L A T O M I C O R B I T A L A N D'/, * 10X,'N A T U R A L B O N D O R B I T A L ', * 'A N A L Y S I S',/1X,79('*')) 6010 FORMAT(1X) ------------------------------------------------------------------------------ JOB CONTROL KEYWORDS: IF(JPRINT(4).NE.0) WRITE(LFNPR,6020) IF(JPRINT(5).NE.0) WRITE(LFNPR,6030) IF(JPRINT(6).NE.0) WRITE(LFNPR,6040) IF(JPRINT(14).NE.0) WRITE(LFNPR,6050) IF(JPRINT(10).NE.0) WRITE(LFNPR,6060) IF(IW3C.NE.0) WRITE(LFNPR,6070) IF(JPRINT(1).NE.0) WRITE(LFNPR,6080) IF(JPRINT(8).NE.0) WRITE(LFNPR,6090) IF(JPRINT(32).NE.0) WRITE(LFNPR,6100) IF(JPRINT(55).EQ.IB) THEN WRITE(LFNPR,6110) ELSE IF(JPRINT(55).EQ.IP) THEN WRITE(LFNPR,6111) ELSE IF(JPRINT(55).LT.0) THEN WRITE(LFNPR,6112) ELSE IF(JPRINT(55).GT.0) THEN WRITE(LFNPR,6113) END IF IF(JPRINT(56).NE.0) WRITE(LFNPR,6120) JPRINT(56) IF(DLTHR.GE.ZERO) WRITE(LFNPR,6160) DLTHR IF(JPRINT(57).NE.0) WRITE(LFNPR,6170) JPRINT(57) ------------------------------------------------------------------------------ 6020 FORMAT(1X,' /NPA / : Print Natural Population Analysis') 6030 FORMAT(1X,' /NBO / : Print Natural Bond Orbital Analysis') 6040 FORMAT(1X,' /NBOSUM / : Print summary of the NBO analysis') 6050 FORMAT(1X,' /RESON / : Allow strongly delocalized NBO ', * 'set') 6060 FORMAT(1X,' /NOBOND / : No two-center NBO search') 6070 FORMAT(1X,' /3CBOND / : Search for 3-center bonds') 6080 FORMAT(1X,' /SKIPBO / : Skip NBO transformation step') 6090 FORMAT(1X,' /NLMO / : Form Natural Localized Molecular', * ' Orbitals') 6100 FORMAT(1X,' /NRT / : Perform Natural Resonance Theory ', * 'Analysis') 6110 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ', * 'BFGS method') 6111 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ', * 'POWELL method') 6112 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ', * 'ANNEAL method') 6113 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ', * 'ANNEAL method + penalty') 6120 FORMAT(1X,' /NRTREF / : Number of reference structures set', * ' to',I3) 6160 FORMAT(1X,' /NRTTHR / : Set to ',F5.2) 6170 FORMAT(1X,' /NRTDTL / : Set to ',I2) ------------------------------------------------------------------------------ JOB THRESHOLD KEYWORDS: IF(JPRINT(36).NE.0) WRITE(LFNPR,6500) IF(ATHR.GE.ZERO.OR.PTHR.GE.ZERO.OR.ETHR.GE.ZERO) + WRITE(LFNPR,6510) ABS(ATHR),ABS(PTHR),ABS(ETHR) IF(JPRINT(3).NE.0) WRITE(LFNPR,6520) IF(E2THR.GT.ZERO) WRITE(LFNPR,6530) E2THR IF(JPRINT(46).NE.0) WRITE(LFNPR,6540) IF(DTHR.GE.ZERO) WRITE(LFNPR,6550) ABS(DTHR) IF(THRSET.GT.ZERO) WRITE(LFNPR,6560) THRSET IF(PRJSET.GT.ZERO) WRITE(LFNPR,6570) PRJSET IF(CHSTHR.GT.ZERO) WRITE(LFNPR,6580) CHSTHR ------------------------------------------------------------------------------ 6500 FORMAT(1X,' /BEND / : Print NHO directionality table') 6510 FORMAT(1X,' Print thresholds set to (',F4.1, * ',',F5.1,',',F5.2,')') 6520 FORMAT(1X,' /E2PERT / : Analyze NBO Fock matrix') 6530 FORMAT(1X,' Print threshold set to ',F5.2) 6540 FORMAT(1X,' /DIPOLE / : Print NBO/NLMO dipole moment ', * 'analysis') 6550 FORMAT(1X,' Print threshold set to ',F5.2) 6560 FORMAT(1X,' /THRESH / : Set to ',F5.2) 6570 FORMAT(1X,' /PRJTHR / : Set to ',F5.2) 6580 FORMAT(1X,' /CHSTHR / : Set to ',F5.2) ------------------------------------------------------------------------------ MATRIX OUTPUT KEYWORDS: IF(JPRINT(44).EQ.IFULL) THEN WRITE(LFNPR,7000) ELSE IF(IOINQR(JPRINT(44)).EQ.IPRNT) THEN WRITE(LFNPR,7002) JPRINT(44) ELSE IF(IOINQR(JPRINT(44)).EQ.IWRIT) THEN WRITE(LFNPR,7004) ABS(JPRINT(44)) END IF IF(IWTNAO.EQ.IFULL) THEN WRITE(LFNPR,7010) ELSE IF(IOINQR(IWTNAO).EQ.IPRNT) THEN WRITE(LFNPR,7012) IWTNAO ELSE IF(IOINQR(IWTNAO).EQ.IWRIT) THEN WRITE(LFNPR,7014) ABS(IWTNAO) ELSE IF(IOINQR(IWTNAO).EQ.IREAD) THEN WRITE(LFNPR,7016) ABS(IWTNAO/1000) END IF IF(JPRINT(30).EQ.IFULL) THEN WRITE(LFNPR,7020) ELSE IF(IOINQR(JPRINT(30)).EQ.IPRNT) THEN WRITE(LFNPR,7022) JPRINT(30) ELSE IF(IOINQR(JPRINT(30)).EQ.IWRIT) THEN WRITE(LFNPR,7024) ABS(JPRINT(30)) END IF IF(JPRINT(28).EQ.IFULL) THEN WRITE(LFNPR,7030) ELSE IF(IOINQR(JPRINT(28)).EQ.IPRNT) THEN WRITE(LFNPR,7032) JPRINT(28) ELSE IF(IOINQR(JPRINT(28)).EQ.IWRIT) THEN WRITE(LFNPR,7034) ABS(JPRINT(28)) END IF IF(JPRINT(25).EQ.IFULL) THEN WRITE(LFNPR,7040) ELSE IF(JPRINT(25).EQ.ILEW) THEN WRITE(LFNPR,7042) ELSE IF(IOINQR(JPRINT(25)).EQ.IPRNT) THEN WRITE(LFNPR,7044) JPRINT(25) ELSE IF(IOINQR(JPRINT(25)).EQ.IWRIT) THEN WRITE(LFNPR,7046) ABS(JPRINT(25)) END IF IF(IWTNBO.EQ.IFULL) THEN WRITE(LFNPR,7050) ELSE IF(IWTNBO.EQ.ILEW) THEN WRITE(LFNPR,7052) ELSE IF(IOINQR(IWTNBO).EQ.IPRNT) THEN WRITE(LFNPR,7054) IWTNBO ELSE IF(IOINQR(IWTNBO).EQ.IWRIT) THEN WRITE(LFNPR,7056) ABS(IWTNBO) END IF IF(JPRINT(49).EQ.IFULL) THEN WRITE(LFNPR,7060) ELSE IF(JPRINT(49).EQ.ILEW) THEN WRITE(LFNPR,7062) ELSE IF(IOINQR(JPRINT(49)).EQ.IPRNT) THEN WRITE(LFNPR,7064) JPRINT(49) ELSE IF(IOINQR(JPRINT(49)).EQ.IWRIT) THEN WRITE(LFNPR,7066) ABS(JPRINT(49)) END IF IF(JPRINT(23).EQ.IFULL) THEN WRITE(LFNPR,7070) ELSE IF(JPRINT(23).EQ.ILEW) THEN WRITE(LFNPR,7072) ELSE IF(IOINQR(JPRINT(23)).EQ.IPRNT) THEN WRITE(LFNPR,7074) JPRINT(23) ELSE IF(IOINQR(JPRINT(23)).EQ.IWRIT) THEN WRITE(LFNPR,7076) ABS(JPRINT(23)) END IF IF(JPRINT(26).EQ.IFULL) THEN WRITE(LFNPR,7080) ELSE IF(JPRINT(26).EQ.IVAL) THEN WRITE(LFNPR,7082) ELSE IF(JPRINT(26).EQ.ILEW) THEN WRITE(LFNPR,7084) ELSE IF(IOINQR(JPRINT(26)).EQ.IPRNT) THEN WRITE(LFNPR,7086) JPRINT(26) ELSE IF(IOINQR(JPRINT(26)).EQ.IWRIT) THEN WRITE(LFNPR,7088) ABS(JPRINT(26)) END IF IF(IWPNAO.EQ.IFULL) THEN WRITE(LFNPR,7090) ELSE IF(IOINQR(IWPNAO).EQ.IPRNT) THEN WRITE(LFNPR,7092) IWPNAO ELSE IF(IOINQR(IWPNAO).EQ.IWRIT) THEN WRITE(LFNPR,7094) ABS(IWPNAO) ELSE IF(IOINQR(IWPNAO).EQ.IREAD) THEN WRITE(LFNPR,7096) ABS(IWPNAO/1000) END IF IF(JPRINT(33).EQ.IFULL) THEN WRITE(LFNPR,7100) ELSE IF(IOINQR(JPRINT(33)).EQ.IPRNT) THEN WRITE(LFNPR,7102) JPRINT(33) ELSE IF(IOINQR(JPRINT(33)).EQ.IWRIT) THEN WRITE(LFNPR,7104) ABS(JPRINT(33)) END IF IF(IWTNAB.EQ.IFULL) THEN WRITE(LFNPR,7110) ELSE IF(IWTNAB.EQ.ILEW) THEN WRITE(LFNPR,7112) ELSE IF(IOINQR(IWTNAB).EQ.IPRNT) THEN WRITE(LFNPR,7114) IWTNAB ELSE IF(IOINQR(IWTNAB).EQ.IWRIT) THEN WRITE(LFNPR,7116) ABS(IWTNAB) ELSE IF(IOINQR(IWTNAB).EQ.IREAD) THEN WRITE(LFNPR,7118) ABS(IWTNAB/1000) END IF IF(JPRINT(18).EQ.IFULL) THEN WRITE(LFNPR,7120) ELSE IF(JPRINT(18).EQ.ILEW) THEN WRITE(LFNPR,7122) ELSE IF(IOINQR(JPRINT(18)).EQ.IPRNT) THEN WRITE(LFNPR,7124) JPRINT(18) ELSE IF(IOINQR(JPRINT(18)).EQ.IWRIT) THEN WRITE(LFNPR,7126) ABS(JPRINT(18)) END IF IF(JPRINT(9).EQ.IFULL) THEN WRITE(LFNPR,7130) ELSE IF(JPRINT(9).EQ.IVAL) THEN WRITE(LFNPR,7132) ELSE IF(JPRINT(9).EQ.ILEW) THEN WRITE(LFNPR,7134) ELSE IF(IOINQR(JPRINT(9)).EQ.IPRNT) THEN WRITE(LFNPR,7136) JPRINT(9) ELSE IF(IOINQR(JPRINT(9)).EQ.IWRIT) THEN WRITE(LFNPR,7138) ABS(JPRINT(9)) END IF IF(JPRINT(41).EQ.IFULL) THEN WRITE(LFNPR,7140) ELSE IF(JPRINT(41).EQ.ILEW) THEN WRITE(LFNPR,7142) ELSE IF(IOINQR(JPRINT(41)).EQ.IPRNT) THEN WRITE(LFNPR,7144) JPRINT(41) ELSE IF(IOINQR(JPRINT(41)).EQ.IWRIT) THEN WRITE(LFNPR,7146) ABS(JPRINT(41)) END IF IF(JPRINT(24).EQ.IFULL) THEN WRITE(LFNPR,7150) ELSE IF(JPRINT(24).EQ.ILEW) THEN WRITE(LFNPR,7152) ELSE IF(IOINQR(JPRINT(24)).EQ.IPRNT) THEN WRITE(LFNPR,7154) JPRINT(24) ELSE IF(IOINQR(JPRINT(24)).EQ.IWRIT) THEN WRITE(LFNPR,7156) ABS(JPRINT(24)) END IF IF(JPRINT(38).EQ.IFULL) THEN WRITE(LFNPR,7160) ELSE IF(JPRINT(38).EQ.IVAL) THEN WRITE(LFNPR,7162) ELSE IF(JPRINT(38).EQ.ILEW) THEN WRITE(LFNPR,7164) ELSE IF(IOINQR(JPRINT(38)).EQ.IPRNT) THEN WRITE(LFNPR,7166) JPRINT(38) ELSE IF(IOINQR(JPRINT(38)).EQ.IWRIT) THEN WRITE(LFNPR,7168) ABS(JPRINT(38)) END IF IF(JPRINT(47).EQ.IFULL) THEN WRITE(LFNPR,7170) ELSE IF(JPRINT(47).EQ.ILEW) THEN WRITE(LFNPR,7172) ELSE IF(IOINQR(JPRINT(47)).EQ.IPRNT) THEN WRITE(LFNPR,7174) JPRINT(47) ELSE IF(IOINQR(JPRINT(47)).EQ.IWRIT) THEN WRITE(LFNPR,7176) ABS(JPRINT(47)) END IF IF(JPRINT(45).EQ.IFULL) THEN WRITE(LFNPR,7180) ELSE IF(JPRINT(45).EQ.IVAL) THEN WRITE(LFNPR,7182) ELSE IF(JPRINT(45).EQ.ILEW) THEN WRITE(LFNPR,7184) ELSE IF(IOINQR(JPRINT(45)).EQ.IPRNT) THEN WRITE(LFNPR,7186) JPRINT(45) ELSE IF(IOINQR(JPRINT(45)).EQ.IWRIT) THEN WRITE(LFNPR,7188) ABS(JPRINT(45)) END IF IF(JPRINT(13).EQ.IFULL) THEN WRITE(LFNPR,7190) ELSE IF(JPRINT(13).EQ.IVAL) THEN WRITE(LFNPR,7192) ELSE IF(JPRINT(13).EQ.ILEW) THEN WRITE(LFNPR,7194) ELSE IF(IOINQR(JPRINT(13)).EQ.IPRNT) THEN WRITE(LFNPR,7196) JPRINT(13) ELSE IF(IOINQR(JPRINT(13)).EQ.IWRIT) THEN WRITE(LFNPR,7198) ABS(JPRINT(13)) END IF IF(JPRINT(42).EQ.IFULL) THEN WRITE(LFNPR,7200) ELSE IF(IOINQR(JPRINT(42)).EQ.IPRNT) THEN WRITE(LFNPR,7202) JPRINT(42) ELSE IF(IOINQR(JPRINT(42)).EQ.IWRIT) THEN WRITE(LFNPR,7204) ABS(JPRINT(42)) END IF IF(JPRINT(27).EQ.IFULL) THEN WRITE(LFNPR,7210) ELSE IF(IOINQR(JPRINT(27)).EQ.IPRNT) THEN WRITE(LFNPR,7212) JPRINT(27) ELSE IF(IOINQR(JPRINT(27)).EQ.IWRIT) THEN WRITE(LFNPR,7214) ABS(JPRINT(27)) END IF IF(JPRINT(35).EQ.IFULL) THEN WRITE(LFNPR,7220) ELSE IF(IOINQR(JPRINT(35)).EQ.IPRNT) THEN WRITE(LFNPR,7222) JPRINT(35) ELSE IF(IOINQR(JPRINT(35)).EQ.IWRIT) THEN WRITE(LFNPR,7224) ABS(JPRINT(35)) END IF IF(JPRINT(34).EQ.IFULL) THEN WRITE(LFNPR,7230) ELSE IF(IOINQR(JPRINT(34)).EQ.IPRNT) THEN WRITE(LFNPR,7232) JPRINT(34) ELSE IF(IOINQR(JPRINT(34)).EQ.IWRIT) THEN WRITE(LFNPR,7234) ABS(JPRINT(34)) END IF IF(JPRINT(16).EQ.IFULL) THEN WRITE(LFNPR,7240) ELSE IF(JPRINT(16).EQ.ILEW) THEN WRITE(LFNPR,7242) ELSE IF(IOINQR(JPRINT(16)).EQ.IPRNT) THEN WRITE(LFNPR,7244) JPRINT(16) ELSE IF(IOINQR(JPRINT(16)).EQ.IWRIT) THEN WRITE(LFNPR,7246) ABS(JPRINT(16)) END IF IF(JPRINT(17).EQ.IFULL) THEN WRITE(LFNPR,7250) ELSE IF(JPRINT(17).EQ.ILEW) THEN WRITE(LFNPR,7252) ELSE IF(IOINQR(JPRINT(17)).EQ.IPRNT) THEN WRITE(LFNPR,7254) JPRINT(17) ELSE IF(IOINQR(JPRINT(17)).EQ.IWRIT) THEN WRITE(LFNPR,7256) ABS(JPRINT(17)) END IF IF(JPRINT(40).EQ.IFULL) THEN WRITE(LFNPR,7260) ELSE IF(IOINQR(JPRINT(40)).EQ.IPRNT) THEN WRITE(LFNPR,7262) JPRINT(40) ELSE IF(IOINQR(JPRINT(40)).EQ.IWRIT) THEN WRITE(LFNPR,7264) ABS(JPRINT(40)) END IF IF(JPRINT(31).EQ.IFULL) THEN WRITE(LFNPR,7270) ELSE IF(IOINQR(JPRINT(31)).EQ.IPRNT) THEN WRITE(LFNPR,7272) JPRINT(31) ELSE IF(IOINQR(JPRINT(31)).EQ.IWRIT) THEN WRITE(LFNPR,7274) ABS(JPRINT(31)) END IF IF(JPRINT(29).EQ.IFULL) THEN WRITE(LFNPR,7280) ELSE IF(IOINQR(JPRINT(29)).EQ.IPRNT) THEN WRITE(LFNPR,7282) JPRINT(29) ELSE IF(IOINQR(JPRINT(29)).EQ.IWRIT) THEN WRITE(LFNPR,7284) ABS(JPRINT(29)) END IF IF(JPRINT(37).EQ.IFULL) THEN WRITE(LFNPR,7290) ELSE IF(JPRINT(37).EQ.ILEW) THEN WRITE(LFNPR,7292) ELSE IF(IOINQR(JPRINT(37)).EQ.IPRNT) THEN WRITE(LFNPR,7294) JPRINT(37) ELSE IF(IOINQR(JPRINT(37)).EQ.IWRIT) THEN WRITE(LFNPR,7296) ABS(JPRINT(37)) END IF IF(JPRINT(15).EQ.IFULL) THEN WRITE(LFNPR,7300) ELSE IF(JPRINT(15).EQ.ILEW) THEN WRITE(LFNPR,7302) ELSE IF(IOINQR(JPRINT(15)).EQ.IPRNT) THEN WRITE(LFNPR,7304) JPRINT(15) ELSE IF(IOINQR(JPRINT(15)).EQ.IWRIT) THEN WRITE(LFNPR,7306) ABS(JPRINT(15)) END IF IF(JPRINT(50).EQ.IFULL) THEN WRITE(LFNPR,7310) ELSE IF(IOINQR(JPRINT(50)).EQ.IPRNT) THEN WRITE(LFNPR,7312) JPRINT(50) ELSE IF(IOINQR(JPRINT(50)).EQ.IWRIT) THEN WRITE(LFNPR,7314) ABS(JPRINT(50)) END IF IF(JPRINT(51).EQ.IFULL) THEN WRITE(LFNPR,7320) ELSE IF(IOINQR(JPRINT(51)).EQ.IPRNT) THEN WRITE(LFNPR,7322) JPRINT(51) ELSE IF(IOINQR(JPRINT(51)).EQ.IWRIT) THEN WRITE(LFNPR,7324) ABS(JPRINT(51)) END IF IF(JPRINT(52).EQ.IFULL) THEN WRITE(LFNPR,7330) ELSE IF(IOINQR(JPRINT(52)).EQ.IPRNT) THEN WRITE(LFNPR,7332) JPRINT(52) ELSE IF(IOINQR(JPRINT(52)).EQ.IWRIT) THEN WRITE(LFNPR,7334) ABS(JPRINT(52)) END IF IF(JPRINT(53).EQ.IFULL) THEN WRITE(LFNPR,7340) ELSE IF(JPRINT(53).EQ.ILEW) THEN WRITE(LFNPR,7342) ELSE IF(IOINQR(JPRINT(53)).EQ.IPRNT) THEN WRITE(LFNPR,7344) JPRINT(53) ELSE IF(IOINQR(JPRINT(53)).EQ.IWRIT) THEN WRITE(LFNPR,7346) ABS(JPRINT(53)) END IF IF(JPRINT(54).EQ.IFULL) THEN WRITE(LFNPR,7350) ELSE IF(JPRINT(54).EQ.ILEW) THEN WRITE(LFNPR,7352) ELSE IF(IOINQR(JPRINT(54)).EQ.IPRNT) THEN WRITE(LFNPR,7354) JPRINT(54) ELSE IF(IOINQR(JPRINT(54)).EQ.IWRIT) THEN WRITE(LFNPR,7356) ABS(JPRINT(54)) END IF IF(JPRINT(39).EQ.IFULL) THEN WRITE(LFNPR,7360) ELSE IF(IOINQR(JPRINT(39)).EQ.IPRNT) THEN WRITE(LFNPR,7362) JPRINT(39) ELSE IF(IOINQR(JPRINT(39)).EQ.IWRIT) THEN WRITE(LFNPR,7364) ABS(JPRINT(39)) END IF IF(JPRINT(19).EQ.IFULL) THEN WRITE(LFNPR,7370) ELSE IF(IOINQR(JPRINT(19)).EQ.IPRNT) THEN WRITE(LFNPR,7372) JPRINT(19) ELSE IF(IOINQR(JPRINT(19)).EQ.IWRIT) THEN WRITE(LFNPR,7374) ABS(JPRINT(19)) END IF IF(JPRINT(20).EQ.IFULL) THEN WRITE(LFNPR,7380) ELSE IF(IOINQR(JPRINT(20)).EQ.IPRNT) THEN WRITE(LFNPR,7382) JPRINT(20) ELSE IF(IOINQR(JPRINT(20)).EQ.IWRIT) THEN WRITE(LFNPR,7384) ABS(JPRINT(20)) END IF IF(JPRINT(21).EQ.IFULL) THEN WRITE(LFNPR,7390) ELSE IF(JPRINT(21).EQ.ILEW) THEN WRITE(LFNPR,7392) ELSE IF(IOINQR(JPRINT(21)).EQ.IPRNT) THEN WRITE(LFNPR,7394) JPRINT(21) ELSE IF(IOINQR(JPRINT(21)).EQ.IWRIT) THEN WRITE(LFNPR,7396) ABS(JPRINT(21)) END IF IF(JPRINT(48).EQ.IFULL) THEN WRITE(LFNPR,7400) ELSE IF(JPRINT(48).EQ.ILEW) THEN WRITE(LFNPR,7402) ELSE IF(IOINQR(JPRINT(48)).EQ.IPRNT) THEN WRITE(LFNPR,7404) JPRINT(48) ELSE IF(IOINQR(JPRINT(48)).EQ.IWRIT) THEN WRITE(LFNPR,7406) ABS(JPRINT(48)) END IF ------------------------------------------------------------------------------ 7000 FORMAT(1X,' /AOPNAO / : Print the AO to PNAO transformation') 7002 FORMAT(1X,' /AOPNAO / : Print ',I3,' columns of the AO to ', * 'PNAO transformation') 7004 FORMAT(1X,' /AOPNAO / : Write the AO to PNAO transformation', * ' to LFN',I3) 7010 FORMAT(1X,' /AONAO / : Print the AO to NAO transformation') 7012 FORMAT(1X,' /AONAO / : Print ',I3,' columns of the AO ', * 'to NAO transformation') 7014 FORMAT(1X,' /AONAO / : Write the AO to NAO transformation ', * 'to LFN',I3) 7016 FORMAT(1X,' /AONAO / : Read AO to NAO transformation from ', * 'LFN',I3) 7020 FORMAT(1X,' /AOPNHO / : Print the AO to PNHO ', * 'transformation') 7022 FORMAT(1X,' /AOPNHO / : Print ',I3,' columns of the AO to ', * 'PNHO transformation') 7024 FORMAT(1X,' /AOPNHO / : Write the AO to PNHO transformation', * ' to LFN',I3) 7030 FORMAT(1X,' /AONHO / : Print the AO to NHO transformation') 7032 FORMAT(1X,' /AONHO / : Print ',I3,' columns of the AO to ', * 'NHO transformation') 7034 FORMAT(1X,' /AONHO / : Write the AO to NHO transformation ', * 'to LFN',I3) 7040 FORMAT(1X,' /AOPNBO / : Print the AO to PNBO ', * 'transformation') 7042 FORMAT(1X,' /AOPNBO / : Print the occupied PNBOs in the AO ', * 'basis') 7044 FORMAT(1X,' /AOPNBO / : Print ',I3,' columns of the AO to ', * 'PNBO transformation') 7046 FORMAT(1X,' /AOPNBO / : Write the AO to PNBO transformation', * ' to LFN',I3) 7050 FORMAT(1X,' /AONBO / : Print the AO to NBO transformation') 7052 FORMAT(1X,' /AONBO / : Print the occupied NBOs in the AO ', * 'basis') 7054 FORMAT(1X,' /AONBO / : Print ',I3,' columns of the AO ', * 'to NBO transformation') 7056 FORMAT(1X,' /AONBO / : Write the AO to NBO transformation ', * 'to LFN',I3) 7060 FORMAT(1X,' /AOPNLMO/ : Print the AO to PNLMO ', * 'transformation') 7062 FORMAT(1X,' /AOPNLMO/ : Print the occupied PNLMOs in the AO', * ' basis') 7064 FORMAT(1X,' /AOPNLMO/ : Print ',I3,' columns of the AO to ', * 'PNLMO transformation') 7066 FORMAT(1X,' /AOPNLMO/ : Write the AO to PNLMO transformatio', * 'n to LFN',I3) 7070 FORMAT(1X,' /AONLMO / : Print the AO to NLMO ', * 'transformation') 7072 FORMAT(1X,' /AONLMO / : Print the occupied NLMOs in the AO ', * 'basis') 7074 FORMAT(1X,' /AONLMO / : Print ',I3,' columns of the AO to ', * 'NLMO transformation') 7076 FORMAT(1X,' /AONLMO / : Write the AO to NLMO transformation', * ' to LFN',I3) 7080 FORMAT(1X,' /AOMO / : Print all MOs in the AO basis') 7082 FORMAT(1X,' /AOMO / : Print core and valence MOs in ', * 'the AO basis') 7084 FORMAT(1X,' /AOMO / : Print the occupied MOs in the AO ', * 'basis') 7086 FORMAT(1X,' /AOMO / : Print ',I3,' lowest energy MOs ', * 'in the AO basis') 7088 FORMAT(1X,' /AOMO / : Write the AO to MO transformation ', * 'to LFN',I3) 7090 FORMAT(1X,' /PAOPNAO/ : Print the PAO to PNAO ', * 'transformation') 7092 FORMAT(1X,' /PAOPNAO/ : Print ',I3,' columns of the PAO ', * 'to PNAO transformation') 7094 FORMAT(1X,' /PAOPNAO/ : Write the PAO to PNAO ', * 'transformation to LFN',I3) 7096 FORMAT(1X,' /PAOPNAO/ : Read PAO to PNAO transformation ', * 'from LFN',I3) 7100 FORMAT(1X,' /NAONHO / : Print the NAO to NHO transformation') 7102 FORMAT(1X,' /NAONHO / : Print ',I3,' columns of the NAO ', * 'to NHO transformation') 7104 FORMAT(1X,' /NAONHO / : Write the NAO to NHO transformation', * ' to LFN',I3) 7110 FORMAT(1X,' /NAONBO / : Print the NAO to NBO transformation') 7112 FORMAT(1X,' /NAONBO / : Print the occupied NBOs in the NAO ', * 'basis') 7114 FORMAT(1X,' /NAONBO / : Print ',I3,' columns of the NAO ', * 'to NBO transformation') 7116 FORMAT(1X,' /NAONBO / : Write the NAO to NBO transformation', * ' to LFN',I3) 7118 FORMAT(1X,' /NAONBO / : Read NAO to NBO transformation from', * ' LFN',I3) 7120 FORMAT(1X,' /NAONLMO/ : Print the NAO to NLMO ', * 'transformation') 7122 FORMAT(1X,' /NAONLMO/ : Print the occupied NLMOs in the NAO', * ' basis') 7124 FORMAT(1X,' /NAONLMO/ : Print ',I3,' columns of the NAO ', * 'to NLMO transformation') 7126 FORMAT(1X,' /NAONLMO/ : Write the NAO to NLMO ', * 'transformation to LFN',I3) 7130 FORMAT(1X,' /NAOMO / : Print all MOs in the NAO basis') 7132 FORMAT(1X,' /NAOMO / : Print core and valence MOs in ', * 'the NAO basis') 7134 FORMAT(1X,' /NAOMO / : Print the occupied MOs in the NAO ', * 'basis') 7136 FORMAT(1X,' /NAOMO / : Print ',I3,' lowest energy MOs ', * 'in the NAO basis') 7138 FORMAT(1X,' /NAOMO / : Write the NAO to MO transformation ', * 'to LFN',I3) 7140 FORMAT(1X,' /NHONBO / : Print the NHO to NBO transformation') 7142 FORMAT(1X,' /NHONBO / : Print the occupied NBOs in the NHO ', * 'basis') 7144 FORMAT(1X,' /NHONBO / : Print ',I3,' columns of the NHO ', * 'to NBO transformation') 7146 FORMAT(1X,' /NHONBO / : Write the NHO to NBO transformation', * ' to LFN',I3) 7150 FORMAT(1X,' /NHONLMO/ : Print the NHO to NLMO ', * 'transformation') 7152 FORMAT(1X,' /NHONLMO/ : Print the occupied NLMOs in the NHO', * ' basis') 7154 FORMAT(1X,' /NHONLMO/ : Print ',I3,' columns of the NHO ', * 'to NLMO transformation') 7156 FORMAT(1X,' /NHONLMO/ : Write the NHO to NLMO ', * 'transformation to LFN',I3) 7160 FORMAT(1X,' /NHOMO / : Print all MOs in the NHO basis') 7162 FORMAT(1X,' /NHOMO / : Print core and valence MOs in ', * 'the NHO basis') 7164 FORMAT(1X,' /NHOMO / : Print the occupied MOs in the NHO ', * 'basis') 7166 FORMAT(1X,' /NHOMO / : Print ',I3,' lowest energy MOs ', * 'in the NHO basis') 7168 FORMAT(1X,' /NHOMO / : Write the NHO to MO transformation ', * 'to LFN',I3) 7170 FORMAT(1X,' /NBONLMO/ : Print the NBO to NLMO ', * 'transformation') 7172 FORMAT(1X,' /NBONLMO/ : Print the occupied NLMOs in the NBO', * ' basis') 7174 FORMAT(1X,' /NBONLMO/ : Print ',I3,' columns of the NBO ', * 'to NLMO transformation') 7176 FORMAT(1X,' /NBONLMO/ : Write the NBO to NLMO ', * 'transformation to LFN',I3) 7180 FORMAT(1X,' /NBOMO / : Print all MOs in the NBO basis') 7182 FORMAT(1X,' /NBOMO / : Print core and valence MOs in ', * 'the NBO basis') 7184 FORMAT(1X,' /NBOMO / : Print the occupied MOs in the NBO ', * 'basis') 7186 FORMAT(1X,' /NBOMO / : Print ',I3,' lowest energy MOs ', * 'in the NBO basis') 7188 FORMAT(1X,' /NBOMO / : Write the NBO to MO transformation ', * 'to LFN',I3) 7190 FORMAT(1X,' /NLMOMO / : Print all MOs in the NLMO basis') 7192 FORMAT(1X,' /NLMOMO / : Print core and valence MOs in ', * 'the NLMO basis') 7194 FORMAT(1X,' /NLMOMO / : Print the occupied MOs in the NLMO ', * 'basis') 7196 FORMAT(1X,' /NLMOMO / : Print ',I3,' lowest energy MOs ', * 'in the NLMO basis') 7198 FORMAT(1X,' /NLMOMO / : Write the NLMO to MO transformation', * ' to LFN',I3) 7200 FORMAT(1X,' /BOAO / : Print the AO bond-order matrix') 7202 FORMAT(1X,' /BOAO / : Print ',I3,' columns of the AO ', * 'bond-order matrix') 7204 FORMAT(1X,' /BOAO / : Write the AO bond-order matrix to ', * 'LFN',I3) 7210 FORMAT(1X,' /DMAO / : Print the AO density matrix') 7212 FORMAT(1X,' /DMAO / : Print ',I3,' columns of the AO ', * 'density matrix') 7214 FORMAT(1X,' /DMAO / : Write the AO density matrix to ', * 'LFN',I3) 7220 FORMAT(1X,' /DMNAO / : Print the NAO density matrix') 7222 FORMAT(1X,' /DMNAO / : Print ',I3,' columns of the NAO ', * 'density matrix') 7224 FORMAT(1X,' /DMNAO / : Write the NAO density matrix to ', * 'LFN',I3) 7230 FORMAT(1X,' /DMNHO / : Print the NHO density matrix') 7232 FORMAT(1X,' /DMNHO / : Print ',I3,' columns of the NHO ', * 'density matrix') 7234 FORMAT(1X,' /DMNHO / : Write the NHO density matrix to ', * 'LFN',I3) 7240 FORMAT(1X,' /DMNBO / : Print the NBO density matrix') 7242 FORMAT(1X,' /DMNBO / : Print the density matrix elements ', * 'of the occupied NBOs') 7244 FORMAT(1X,' /DMNBO / : Print ',I3,' columns of the NBO ', * 'density matrix') 7246 FORMAT(1X,' /DMNBO / : Write the NBO density matrix to ', * 'LFN',I3) 7250 FORMAT(1X,' /DMNLMO / : Print the NLMO density matrix') 7252 FORMAT(1X,' /DMNLMO / : Print the density matrix elements ', * 'of the occupied NLMOs') 7254 FORMAT(1X,' /DMNLMO / : Print ',I3,' columns of the NLMO ', * 'density matrix') 7256 FORMAT(1X,' /DMNLMO / : Write the NLMO density matrix to ', * 'LFN',I3) 7260 FORMAT(1X,' /FAO / : Print the AO Fock matrix') 7262 FORMAT(1X,' /FAO / : Print ',I3,' columns of the AO ', * 'Fock matrix') 7264 FORMAT(1X,' /FAO / : Write the AO Fock matrix to ', * 'LFN',I3) 7270 FORMAT(1X,' /FNAO / : Print the NAO Fock matrix') 7272 FORMAT(1X,' /FNAO / : Print ',I3,' columns of the NAO ', * 'Fock matrix') 7274 FORMAT(1X,' /FNAO / : Write the NAO Fock matrix to ', * 'LFN',I3) 7280 FORMAT(1X,' /FNHO / : Print the NHO Fock matrix') 7282 FORMAT(1X,' /FNHO / : Print ',I3,' columns of the NHO ', * 'Fock matrix') 7284 FORMAT(1X,' /FNHO / : Write the NHO Fock matrix to ', * 'LFN',I3) 7290 FORMAT(1X,' /FNBO / : Print the NBO Fock matrix') 7292 FORMAT(1X,' /FNBO / : Print the Fock matrix elements of ', * 'the occupied NBOs') 7294 FORMAT(1X,' /FNBO / : Print ',I3,' columns of the NBO ', * 'Fock matrix') 7296 FORMAT(1X,' /FNBO / : Write the NBO Fock matrix to ', * 'LFN',I3) 7300 FORMAT(1X,' /FNLMO / : Print the NLMO Fock matrix') 7302 FORMAT(1X,' /FNLMO / : Print the Fock matrix elements of ', * 'the occupied NLMOs') 7304 FORMAT(1X,' /FNLMO / : Print ',I3,' columns of the NLMO ', * 'Fock matrix') 7306 FORMAT(1X,' /FNLMO / : Write the NLMO Fock matrix to ', * 'LFN',I3) 7310 FORMAT(1X,' /DIAO / : Print the AO dipole integrals') 7312 FORMAT(1X,' /DIAO / : Print ',I3,' columns of the AO ', * 'dipole matrices') 7314 FORMAT(1X,' /DIAO / : Write the AO dipole integrals', * ' to LFN',I3) 7320 FORMAT(1X,' /DINAO / : Print the NAO dipole integrals') 7322 FORMAT(1X,' /DINAO / : Print ',I3,' columns of the NAO ', * 'dipole matrices') 7324 FORMAT(1X,' /DINAO / : Write the NAO dipole integrals', * ' to LFN',I3) 7330 FORMAT(1X,' /DINHO / : Print the NHO dipole integrals') 7332 FORMAT(1X,' /DINHO / : Print ',I3,' columns of the NHO ', * 'dipole matrices') 7334 FORMAT(1X,' /DINHO / : Write the NHO dipole integrals', * ' to LFN',I3) 7340 FORMAT(1X,' /DINBO / : Print the NBO dipole integrals') 7342 FORMAT(1X,' /DINBO / : Print the dipole integrals of ', * 'occupied NBOs') 7344 FORMAT(1X,' /DINBO / : Print ',I3,' columns of the NBO ', * 'dipole matrices') 7346 FORMAT(1X,' /DINBO / : Write the NBO dipole integrals', * ' to LFN',I3) 7350 FORMAT(1X,' /DINLMO / : Print the NLMO dipole integrals') 7352 FORMAT(1X,' /DINLMO / : Print the dipole integrals of ', * 'occupied NLMOs') 7354 FORMAT(1X,' /DINLMO / : Print ',I3,' columns of the NLMO ', * 'dipole matrices') 7356 FORMAT(1X,' /DINLMO / : Write the NLMO dipole integrals', * ' to LFN',I3) 7360 FORMAT(1X,' /SAO / : Print the AO overlap matrix') 7362 FORMAT(1X,' /SAO / : Print ',I3,' columns of the AO ', * 'overlap matrix') 7364 FORMAT(1X,' /SAO / : Write the AO overlap matrix to ', * 'LFN',I3) 7370 FORMAT(1X,' /SPNAO / : Print the PNAO overlap matrix') 7372 FORMAT(1X,' /SPNAO / : Print ',I3,' columns of the PNAO ', * 'overlap matrix') 7374 FORMAT(1X,' /SPNAO / : Write the PNAO overlap matrix to ', * 'LFN',I3) 7380 FORMAT(1X,' /SPNHO / : Print the PNHO overlap matrix') 7382 FORMAT(1X,' /SPNHO / : Print ',I3,' columns of the PNHO ', * 'overlap matrix') 7384 FORMAT(1X,' /SPNHO / : Write the PNHO overlap matrix to ', * 'LFN',I3) 7390 FORMAT(1X,' /SPNBO / : Print the PNBO overlap matrix') 7392 FORMAT(1X,' /SPNBO / : Print the overlap matrix elements ', * 'of the occupied PNBOs') 7394 FORMAT(1X,' /SPNBO / : Print ',I3,' columns of the PNBO ', * 'overlap matrix') 7396 FORMAT(1X,' /SPNBO / : Write the PNBO overlap matrix to ', * 'LFN',I3) 7400 FORMAT(1X,' /SPNLMO / : Print the PNLMO overlap matrix') 7402 FORMAT(1X,' /SPNLMO / : Print the overlap matrix elements ', * 'of the occupied PNLMOs') 7404 FORMAT(1X,' /SPNLMO / : Print ',I3,' columns of the PNLMO ', * 'overlap matrix') 7406 FORMAT(1X,' /SPNLMO / : Write the PNLMO overlap matrix to ', * 'LFN',I3) ------------------------------------------------------------------------------ OTHER OUTPUT CONTROL KEYWORDS: IF(LFNPR.NE.6) WRITE(LFNPR,8000) LFNPR IF(JPRINT(43).NE.0) WRITE(LFNPR,8010) IF(IWDETL.NE.0) WRITE(LFNPR,8020) IF(JPRINT(7).NE.0) WRITE(LFNPR,8030) JPRINT(7) IF(JPRINT(12).NE.0) WRITE(LFNPR,8040) IF(LFNDAF.GE.0) WRITE(LFNPR,8050) LFNDAF IF(JPRINT(22).NE.0) WRITE(LFNPR,8060) JPRINT(22) IF(IWMULP.EQ.1) WRITE(LFNPR,8070) IF(IWMULP.EQ.2) WRITE(LFNPR,8080) IF(IWAPOL.NE.0) WRITE(LFNPR,8090) IF(JPRINT(11).NE.0) WRITE(LFNPR,8100) IF(LENNM.NE.0) WRITE(LFNPR,8110) FILENM(1:52) IF(IPRINT.LT.10) THEN WRITE(LFNPR,8500) IPRINT ELSE IPRINT = IPRINT - 10 END IF ------------------------------------------------------------------------------ 8000 FORMAT(1X,' /LFNPR / : set to',I3) 8010 FORMAT(1X,' /PLOT / : Write information for the orbital', * ' plotter') 8020 FORMAT(1X,' /DETAIL / : Write out details of NBO search') 8030 FORMAT(1X,' /ARCHIVE/ : Write the archive file to LFN',I3) 8040 FORMAT(1X,' /BNDIDX / : Print bond indices based on ', * 'the NAO density matrix') 8050 FORMAT(1X,' /NBODAF / : NBO direct access file written on', * ' LFN',I3) 8060 FORMAT(1X,' /AOINFO / : Write AO information to LFN',I3) 8070 FORMAT(1X,' /MULAT / : Print Mulliken populations', * ' by atom') 8080 FORMAT(1X,' /MULORB / : Print Mulliken populations', * ' by orbital and atom') 8090 FORMAT(1X,' /APOLAR / : Enforce apolar NBOs') 8100 FORMAT(1X,' /RPNAO / : Revise TPNAO with TRYD and TRED') 8110 FORMAT(1X,' /FILE / : Set to ',A52) 8500 FORMAT(1X,' /PRINT / : Print level set to',I3) ------------------------------------------------------------------------------ END IF SET PRINT LEVEL OPTIONS: IF(IPRINT.GT.0) THEN JPRINT(4) = 1 JPRINT(5) = 1 END IF IF(IPRINT.GT.1) THEN JPRINT(3) = 1 JPRINT(6) = 1 JPRINT(36) = 1 END IF IF(IPRINT.GT.2) THEN JPRINT(8) = 1 JPRINT(12) = 1 JPRINT(46) = 1 END IF IF(IPRINT.GT.3) THEN IF(JPRINT(7).EQ.0) JPRINT(7) = LFNARC IF(JPRINT(9).EQ.0) JPRINT(9) = IFULL IF(JPRINT(13).EQ.0) JPRINT(13) = IFULL JPRINT(14) = 1 IF(JPRINT(15).EQ.0) JPRINT(15) = IFULL IF(JPRINT(16).EQ.0) JPRINT(16) = IFULL IF(JPRINT(17).EQ.0) JPRINT(17) = IFULL IF(JPRINT(18).EQ.0) JPRINT(18) = IFULL IF(JPRINT(19).EQ.0) JPRINT(19) = IFULL IF(JPRINT(20).EQ.0) JPRINT(20) = IFULL IF(JPRINT(21).EQ.0) JPRINT(21) = IFULL IF(JPRINT(24).EQ.0) JPRINT(24) = IFULL IF(JPRINT(29).EQ.0) JPRINT(29) = IFULL IF(JPRINT(31).EQ.0) JPRINT(31) = IFULL IF(JPRINT(32).EQ.0) JPRINT(32) = 1 IF(JPRINT(33).EQ.0) JPRINT(33) = IFULL IF(JPRINT(34).EQ.0) JPRINT(34) = IFULL IF(JPRINT(35).EQ.0) JPRINT(35) = IFULL IF(JPRINT(37).EQ.0) JPRINT(37) = IFULL IF(JPRINT(38).EQ.0) JPRINT(38) = IFULL IF(JPRINT(39).EQ.0) JPRINT(39) = IFULL IF(JPRINT(40).EQ.0) JPRINT(40) = IFULL IF(JPRINT(41).EQ.0) JPRINT(41) = IFULL IF(JPRINT(42).EQ.0) JPRINT(42) = IFULL JPRINT(43) = 1 IF(JPRINT(45).EQ.0) JPRINT(45) = IFULL IF(JPRINT(47).EQ.0) JPRINT(47) = IFULL IF(JPRINT(48).EQ.0) JPRINT(48) = IFULL IF(JPRINT(50).EQ.0) JPRINT(50) = IFULL IF(JPRINT(51).EQ.0) JPRINT(51) = IFULL IF(JPRINT(52).EQ.0) JPRINT(52) = IFULL IF(JPRINT(53).EQ.0) JPRINT(53) = IFULL IF(JPRINT(54).EQ.0) JPRINT(54) = IFULL IF(JPRINT(55).EQ.0) JPRINT(55) = 1 IF(IWTNAB.EQ.0) IWTNAB = IFULL IWDETL = 1 IF(IWDM.NE.0) IWMULP = 2 END IF TURN ON THE NLMO ANALYSIS IF REQUIRED: IF(JPRINT(13).NE.0) JPRINT(8) = 1 IF(JPRINT(15).NE.0) JPRINT(8) = 1 IF(JPRINT(17).NE.0) JPRINT(8) = 1 IF(JPRINT(18).NE.0) JPRINT(8) = 1 IF(JPRINT(23).NE.0) JPRINT(8) = 1 IF(JPRINT(46).NE.0) JPRINT(8) = 1 IF(JPRINT(47).NE.0) JPRINT(8) = 1 IF(JPRINT(48).NE.0) JPRINT(8) = 1 IF(JPRINT(49).NE.0) JPRINT(8) = 1 IF(JPRINT(54).NE.0) JPRINT(8) = 1 TAKE CARE OF THE PLOT OPTION: IF(JPRINT(43).NE.0) THEN JPRINT(8) = 1 IF(JPRINT(22).EQ.0) JPRINT(22) = LFNAO IF(IWTNAO.EQ.0) IWTNAO = -LFNNAO IF(JPRINT(28).EQ.0) JPRINT(28) = -LFNNHO IF(IWTNBO.EQ.0) IWTNBO = -LFNNBO IF(JPRINT(23).EQ.0) JPRINT(23) = -LFNNLM IF(JPRINT(26).EQ.0) JPRINT(26) = -LFNMO IF(JPRINT(27).EQ.0) JPRINT(27) = -LFNDM IF(JPRINT(44).EQ.0) JPRINT(44) = -LFNPNA IF(JPRINT(30).EQ.0) JPRINT(30) = -LFNPNH IF(JPRINT(25).EQ.0) JPRINT(25) = -LFNPNB IF(JPRINT(49).EQ.0) JPRINT(49) = -LFNPNL END IF PRINT HYBRIDS IF THE NBO OUTPUT IS REQUESTED: IWHYBS = JPRINT(5) RETURN ABORT PROGRAM: UNRECOGNIZABLE KEYWORD ENCOUNTERED 4800 WRITE(LFNPR,9800) (KEYWD(I),I=1,6) STOP INCOMPATIBLE JOB OPTIONS HAVE BEEN REQUESTED: 4900 CONTINUE WRITE(LFNPR,9900) STOP 9800 FORMAT(1X,'Error: Unrecognizable keyword >>',6A1,'<<',/,1X, * 'Program must halt.') 9900 FORMAT(1X,'The NBO program must stop because the options /MULAT/', + ' and /MULORB/',/1X,'currently require the AO bond order matrix', + ', rather than the AO density',/1X,'matrix. The program could ', + 'be modified to permit this.') END ***************************************************************************** SUBROUTINE NBODIM(MEMORY) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DIMENSION NSPDFG(5,2) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBBAS/LABEL(MAXBAS,6),LVAL(MAXBAS),IMVAL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) DATA IREAD/4HREAD/ NBODIM: SET UP DIMENSIONING INFORMATION, LISTS IN COMMON/NBATOM/, AND COMPARE STORAGE NEEDS WITH AMOUNT OF STORAGE AVAILABLE FIND: MXAOLM, THE MAXIMUM NUMBER OF ATOMIC ORBITALS OF THE SAME SYMMETRY ON A SINGLE ATOM MXAO, THE MAXIMUM NUMBER OF ATOMIC ORBITALS PER ATOM MXBO, THE MAXIMUM NUMBER OF ATOMIC ORBITALS PER TWO-CENTER OR THREE-CENTER BOND DO 300 I = 1,NBAS LM = LANG(I) LVAL(I) = LM/100 IM = LM - LVAL(I)*100 IF(IM.GT.50) IM = IM - 50 IMVAL(I) = IM 300 CONTINUE MXAO = 0 MXAO2 = 0 MXAO3 = 0 MXAOLM = 0 LLU = 0 DO 500 I = 1,NATOMS N = 0 DO 400 IL = 1,5 DO 400 ITYP = 1,2 400 NSPDFG(IL,ITYP) = 0 DO 410 J = 1,NBAS IF(LCTR(J).NE.I) GO TO 410 LM = LANG(J) L = LM/100 IM = LM - L*100 IF IM.NE.1 (THAT IS, IF THIS IS NOT THE FIRST COMPONENT OF THE ANG. MOM. L FUNCTIONS ON THE ATOM), DON'T COUNT IT IN NSPDFG: IF(IM.NE.1) GO TO 410 ITYP=1 FOR CARTESIAN FUNCTION, =2 FOR TRUE SPHERICAL HARMONIC: ITYP = 1 IF(IM.GT.50) ITYP = 2 IL = L + 1 NSPDFG(IL,ITYP) = NSPDFG(IL,ITYP)+1 410 IF(LCTR(J).EQ.I) N = N + 1 NUMBER OF S ORBITALS= NO. S ORBS INPUT + NO. CARTESIAN D AND G ORBS: NSPDFG(1,1) = NSPDFG(1,1) + NSPDFG(1,2) + NSPDFG(3,1) + + NSPDFG(5,1) NUMBER OF P ORBITALS= NO. P ORBS INPUT + NO. CARTESIAN F ORBS: NSPDFG(2,1) = NSPDFG(2,1) + NSPDFG(2,2) + NSPDFG(4,1) NUMBER OF D ORBITALS= NO. D ORBS INPUT + NO. CARTESIAN G ORBS: NSPDFG(3,1) = NSPDFG(3,1) + NSPDFG(3,2) + NSPDFG(5,1) NUMBER OF F ORBITALS: NSPDFG(4,1) = NSPDFG(4,1) + NSPDFG(4,2) NUMBER OF G ORBITALS: NSPDFG(5,1) = NSPDFG(5,1) + NSPDFG(5,2) DO 430 IL = 1,5 IF(NSPDFG(IL,1).LE.MXAOLM) GO TO 430 MXAOLM = NSPDFG(IL,1) 430 CONTINUE NORBS(I) = N LL(I) = LLU + 1 LU(I) = LL(I) + N - 1 LLU = LU(I) IF(N.LE.MXAO) GO TO 460 MXAO3 = MXAO2 MXAO2 = MXAO MXAO = N GO TO 500 460 IF(N.LE.MXAO2) GO TO 480 MXAO3 = MXAO2 MXAO2 = N GO TO 500 480 IF(N.LE.MXAO3) GO TO 500 MXAO3 = N 500 CONTINUE MXBO = MXAO + MXAO2 IF(IW3C.EQ.1) MXBO = MXBO + MXAO3 COMPUTE STORAGE REQUIREMENTS AND COMPARE WITH AVAILABLE CORE SPACE: STORAGE FOR DENSITY MATRIX (DM) AND TRANSFORMATIONS (T): NEED0 = 2*NDIM*NDIM COMPUTE STORAGE FOR NATURAL POPULATION ANALYSIS: NEED1 = 0 IO = IOINQR(IWTNAO) IF(IO.NE.IREAD.AND..NOT.ORTHO) THEN NEED = NDIM + NDIM + NDIM*NDIM + MXAOLM*MXAOLM + NDIM + + MXAOLM*MXAOLM + MXAOLM*MXAOLM + NDIM + 9*MXAOLM NEED1 = MAX(NEED1,NEED) END IF NEED = NATOMS*NATOMS + NATOMS + NATOMS*NATOMS + NATOMS*NATOMS + + NDIM*NDIM + NDIM NEED1 = MAX(NEED1,NEED) NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM NEED1 = MAX(NEED1,NEED) IF(JPRINT(9).NE.0) THEN NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM*NDIM + NDIM*(NDIM+5) NEED1 = MAX(NEED1,NEED) END IF NEED1 = NEED1 + NEED0 COMPUTE STORAGE FOR NATURAL BOND ORBITAL ANALYSIS: NEED2 = 0 IF(JPRINT(1).EQ.0) THEN IF(IOINQR(IWTNAB).NE.IREAD) THEN NEED = NATOMS*NATOMS + NDIM + 3*NDIM + MXAO*NDIM + NDIM + + MXBO*MXBO + MXBO*MXBO + MXBO + MXBO + MXAO*MXAO + + MXAO*MXAO + MXAO + MXAO + MXAO + NATOMS*NATOMS ELSE NEED = NATOMS*NATOMS + NDIM + 3*NDIM END IF NEED2 = MAX(NEED2,NEED) IF(.NOT.ORTHO) THEN NEED = NATOMS*NATOMS + 4*NDIM*NDIM + MXAO + 3*NDIM NEED2 = MAX(NEED2,NEED) END IF NEED = NATOMS*NATOMS + NDIM + MXAO + NDIM*NDIM + NDIM*NDIM + + NDIM + NDIM NEED2 = MAX(NEED2,NEED) NEED = NATOMS*NATOMS + NDIM + NDIM + NDIM + NDIM*NDIM NEED2 = MAX(NEED2,NEED) IF(JPRINT(36).NE.0) THEN NEED = NATOMS*NATOMS + NDIM + 3*NATOMS + NDIM*NDIM + + NDIM*NDIM + NDIM NEED2 = MAX(NEED2,NEED) END IF NEED = NATOMS*NATOMS + NDIM + NDIM*NDIM + NDIM*NDIM + + NDIM*(NDIM+5) NEED2 = MAX(NEED2,NEED) IF(JPRINT(6).NE.0) THEN NEED = NATOMS*NATOMS + NDIM + NDIM*NDIM + NDIM + NATOMS + + NDIM NEED2 = MAX(NEED2,NEED) END IF COMPUTE STORAGE FOR NATURAL LOCALIZED MOLECULAR ORBITAL ANALYSIS: NEED3 = 0 IF(JPRINT(8).NE.0) THEN NEED = NATOMS*NATOMS + NDIM + NDIM + NDIM*NDIM + NDIM*NDIM NEED3 = MAX(NEED3,NEED) NEED = NDIM + NDIM + NDIM + NATOMS*NATOMS + 2*NATOMS*NATOMS + + NDIM*NATOMS + NDIM*NATOMS*(NATOMS-1)/2 + NDIM*NDIM NEED3 = MAX(NEED3,NEED) NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM*NDIM + NDIM*(NDIM+5) NEED3 = MAX(NEED3,NEED) IF(JPRINT(46).NE.0) THEN NEED = NDIM*NDIM + NDIM*NDIM + NDIM*NDIM + NDIM*NDIM + + NDIM*NDIM + NDIM*NDIM + NDIM + NATOMS*NATOMS NEED3 = MAX(NEED3,NEED) END IF END IF END IF PRINT SCRATCH STORAGE REQUIREMENTS: IF(IPRINT.GE.0) THEN IF(JPRINT(1).EQ.0) THEN IF(JPRINT(8).NE.0) THEN WRITE(LFNPR,3300) NEED1,NEED2,NEED3,MEMORY ELSE NEED3 = 0 WRITE(LFNPR,3200) NEED1,NEED2,MEMORY END IF ELSE NEED2 = 0 NEED3 = 0 WRITE(LFNPR,3100) NEED1,MEMORY END IF END IF IF(NEED1.GT.MEMORY.OR.NEED2.GT.MEMORY.OR.NEED3.GT.MEMORY) GOTO 990 RETURN 990 WRITE(LFNPR,9900) STOP 3100 FORMAT(/1X,'Storage needed:',I6,' in NPA (',I7,' available)') 3200 FORMAT(/1X,'Storage needed:',I6,' in NPA,',I6,' in NBO (',I7, + ' available)') 3300 FORMAT(/1X,'Storage needed:',I6,' in NPA,',I6,' in NBO,',I6, + ' in NLMO (',I7,' available)') 9900 FORMAT(/1X,'*** Not enough core storage is available ***'/) END ************************************************************************** NAO/NBO/NLMO FORMATION ROUTINES: (CALLED BY SR NBO) SUBROUTINE NAODRV(DM,T,A) SUBROUTINE NAOSIM(DM,T,A) SUBROUTINE DMNAO(DM,T,A) SUBROUTINE DMSIM(DM,T,A) SUBROUTINE NBODRV(DM,T,A,MEMORY) ************************************************************************** SUBROUTINE NAODRV(DM,T,A) ************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DRIVER SUBROUTINE TO CALCULATE NATURAL ATOMIC ORBITALS (NAOS) GIVEN 1-PARTICLE DENSITY MATRIX IN AN ARBITRARY ATOM-CENTERED ATOMIC ORBITAL BASIS SET. T = OVERLAP MATRIX FOR THE PRIMITIVE AO BASIS (ON RETURN, THIS IS THE AO TO NAO TRANSFORMATION MATRIX) DM = DENSITY MATRIX IN THE PRIMITIVE AO BASIS (OR BOND-ORDER MATRIX, IF IWDM = 1) THE SPIN NATURE OF DM IS INDICATED BY: ISPIN = 0: SPINLESS (CLOSED SHELL) ISPIN = +2: ALPHA SPIN ISPIN = -2: SPIN (ISPIN IS THE RECIPROCAL OF THE S(Z) QUANTUM NO.) A = SCRATCH STORAGE FROM THE MAIN PROGRAM. THE LOCATION OF A(1) IS IN THE COMMON BLOCK /SCM/ IN THE MAIN PROGRAM, AFTER THE STORAGE FOR THE MATRICES 'S','DM' ('A' IS THE VECTOR WHICH IS PARTITIONED ACCORDING TO THE STORAGE NEEDS OF EACH PROGRAM RUN) ATOM, BASIS, OPTION, NBINFO: COMMON BLOCKS WITH DATA TRANSFERED FROM FROM THE INPUT PROGRAMS. ----------------------------------------------------------------------------- PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(1) CHARACTER*80 TITLE DATA ONE/1.0D0/ DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/ FORM LABELS FOR THE RAW AO BASIS SET: CALL LBLAO COPY THE AO CENTERS AND LABELS FROM /NBAO/ TO /NBBAS/: DO 5 I = 1,NBAS LBL(I) = LCTR(I) LORBC(I) = LANG(I) 5 CONTINUE WRITE OUT THE AO BASIS SET INFORMATION: IF(JPRINT(22).GT.0) THEN CALL WRBAS(A,A,JPRINT(22)) END IF WRITE OUT THE ARCHIVE FILE: IF(JPRINT(7).NE.0) THEN CALL WRARC(A,A,JPRINT(7)) END IF OUTPUT THE AO OVERLAP MATRIX: IO = IOINQR(JPRINT(39)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'AO overlap matrix:' CALL AOUT(T,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(39)) END IF OUTPUT THE AO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(26)) IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN CALL FEAOMO(A,IT) IF(IT.NE.0) THEN TITLE = 'MOs in the AO basis:' CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26)) END IF END IF OUTPUT THE AO FOCK MATRIX: IO = IOINQR(JPRINT(40)) IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN CALL FEFAO(A,IWFOCK) IF(IWFOCK.NE.0) THEN TITLE = 'AO Fock matrix:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40)) END IF END IF OUTPUT THE AO BOND-ORDER MATRIX: IO = IOINQR(JPRINT(42)) IF(IWDM.EQ.1.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN TITLE = 'Spinless AO bond-order matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(42)) END IF CONVERT THE BOND-ORDER MATRIX TO THE DENSITY MATRIX: IF(IWDM.NE.0) CALL SIMTRM(DM,T,A,NDIM,NBAS,IWMULP,IWCUBF) OUTPUT THE AO DENSITY MATRIX: IO = IOINQR(JPRINT(27)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'Spinless AO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27)) END IF OUTPUT THE AO DIPOLE MATRICES: IO = IOINQR(JPRINT(50)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO x dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF IX = 2 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO y dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF IX = 3 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO z dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF END IF ALLOCATE SCRATCH COMMON FOR NAO ROUTINES: A(I1) = V(NDIM) (ALSO USED FOR GUIDE(NATOMS,NATOMS)) A(I2) = RENORM(NDIM) A(I3) = BLK(NDIM,NDIM) A(I4) = SBLK(MXAOLM,MXAOLM) A(I5) = EVAL(NDIM) A(I6) = C(MXAOLM,MXAOLM) A(I7) = EVECT(MXAOLM,MXAOLM) A(I8) = EVAL2(NDIM) LEAVE THIS LAST IN THE LIST SINCE THESE ARE INTEGERS: A(I9) = LISTAO(MXAOLM,9) NBLOCK = MXAOLM*MXAOLM I1 = 1 I2 = I1 + NDIM I3 = I2 + NDIM I4 = I3 + NDIM*NDIM I5 = I4 + NBLOCK I6 = I5 + NDIM I7 = I6 + NBLOCK I8 = I7 + NBLOCK I9 = I8 + NDIM IEND = I9 + 9*MXAOLM READ IN T-NAO, NAO LABELS, THE PNAO OVERLAP MATRIX, AND COMPUTE THE NAO DENSITY MATRIX: (NOTE THAT T CONTAINS THE PNAO OVERLAP MATRIX AFTER RDTNAO IS CALLED) IF(IOINQR(IWTNAO).EQ.IREAD) THEN CALL RDTNAO(DM,T,A(I1),IWTNAO) GO TO 580 END IF TRANSFORM ALL SETS OF CARTESIAN D,F,G ORBITALS, AND RELABEL ALL ORBITALS: CALL DFGORB(A(I2),DM,T,ICTRAN,IWCUBF,0,LFNPR) STORE PURE AO DENSITY MATRIX IN SCRATCH STORAGE: CALL SVPPAO(DM) CONSOLIDATE DENSITY MATRIX AND OVERLAP MATRIX IN DM: CALL CONSOL(DM,T,NDIM,NBAS) FIND NATURAL ATOMIC ORBITAL BASIS SET TRANSFORMATION T FROM DM: (UPON RETURN, DM CONTAINS THE FULL NAO DENSITY MATRIX) CALL NAO(T,DM,A(I1),A(I3),A(I4),A(I5),A(I6),A(I7),A(I8),A(I9), * NBLOCK) IF D ORBITALS WERE TRANSFORMED, TRANSFORM THE NAO TRANSFORMATION T SO THAT T IS THE TRANSFORM FROM THE ORIGINAL AO'S TO THE NAO'S: IF(ICTRAN.NE.0) CALL DFGORB(A(I2),DM,T,IDTRAN,IWCUBF,1,LFNPR) SAVE TNAO FOR LATER USE: CALL SVTNAO(T) IF D ORBITALS WERE TRANSFORMED, TRANSFORM THE PNAO TRANSFORMATION SO THAT IT IS THE TRANSFORM FROM THE ORIGINAL AO'S TO THE PNAO'S: CALL FEPNAO(A(I3)) FOR CASE THAT RPNAOS ARE WRITTEN TO DISK, SET OCCUPANCY WEIGHTS TO -1 AS A SIGNAL THAT THEY SHOULD BE RECOMPUTED: DO 260 I = 0,NBAS-1 260 A(I4+I) = -ONE IF(ICTRAN.NE.0) CALL DFGORB(A(I2),DM,A(I3),IDTRAN,IWCUBF,1,LFNPR) COMPUTE NON-ORTHOGONAL NAO OVERLAP MATRIX, SPNAO: CALL FESRAW(T) CALL SIMTRS(T,A(I3),A(I4),NDIM,NBAS) CALL SVSNAO(T) WRITE T-NAO, NAO LABELS, AND THE PNAO OVERLAP MATRIX: IF(IOINQR(IWTNAO).EQ.IWRIT) CALL WRTNAO(T,IWTNAO) DM IS NOW THE DENSITY MATRIX IN THE NAO BASIS T IS THE NON-ORTHOGONAL PNAO OVERLAP MATRIX (!!!) 580 CONTINUE I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NATOMS I4 = I3 + NATOMS*NATOMS I5 = I4 + NATOMS*NATOMS I6 = I5 + NDIM*NDIM IEND = I6 + NDIM CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6)) DO NOT DESTROY THE MATRIX AT A(I1). THIS HOLDS THE WIBERG BOND INDEX WHICH NEEDS TO BE PASSED TO THE NBO ROUTINES. SAVE THE NAO DENSITY MATRIX: CALL SVDNAO(DM) FORM THE NAO LABELS: CALL LBLNAO REORGANIZE THE SCRATCH VECTOR: I1 = 1 I2 = I1 + NATOMS*NATOMS IEND = I2 + NDIM*NDIM OUTPUT THE AO-PNAO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(44)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEPNAO(T) TITLE = 'PNAOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(44)) END IF OUTPUT THE PNAO OVERLAP MATRIX: IO = IOINQR(JPRINT(19)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FESNAO(A(I2)) TITLE = 'PNAO overlap matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(19)) END IF FETCH THE AO-NAO TRANSFORMATION FROM THE NBO DAF: CALL FETNAO(T) PRINT THE AO-NAO TRANSFORMATION MATRIX: IF(IOINQR(IWTNAO).EQ.IPRNT) THEN TITLE = 'NAOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IWTNAO) END IF OUTPUT THE NAO DIPOLE MATRICES: IO = IOINQR(JPRINT(51)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO x dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51)) END IF IX = 2 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO y dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51)) END IF IX = 3 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO z dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51)) END IF END IF IF THIS IS AN OPEN SHELL WAVEFUNCTION, DON'T DO ANYTHING MORE: IF(OPEN) RETURN OUTPUT THE NAO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(9)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9)) END IF REORGANIZE THE SCRATCH VECTOR: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM IEND = I3 + NDIM OUTPUT THE NAO FOCK MATRIX: IO = IOINQR(JPRINT(31)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31)) END IF END IF OUTPUT THE NAO DENSITY MATRIX: IO = IOINQR(JPRINT(35)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NAO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35)) END IF RETURN END ***************************************************************************** SUBROUTINE NAOSIM(DM,T,A) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1) CHARACTER*80 TITLE DATA ZERO,ONE/0.0D0,1.0D0/ DATA IPRNT,IWRIT/4HPRNT,4HWRIT/ THIS ROUTINE SIMULATES THE ACTION OF THE NAO SUBPROGRAM: FORM LABELS FOR THE RAW AO BASIS SET: CALL LBLAO COPY THE AO CENTERS AND LABELS FROM /NBAO/ TO /NBBAS/: DO 5 I = 1,NBAS LBL(I) = LCTR(I) LORBC(I) = LANG(I) 5 CONTINUE WRITE OUT THE AO BASIS SET INFORMATION: IF(JPRINT(22).GT.0) THEN CALL WRBAS(A,A,JPRINT(22)) END IF WRITE OUT THE ARCHIVE FILE: IF(JPRINT(7).NE.0) THEN CALL WRARC(A,A,JPRINT(7)) END IF OUTPUT THE AO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(26)) IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN CALL FEAOMO(A,IT) IF(IT.NE.0) THEN TITLE = 'MOs in the AO basis:' CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26)) END IF END IF OUTPUT THE AO FOCK MATRIX: IO = IOINQR(JPRINT(40)) IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN CALL FEFAO(A,IWFOCK) IF(IWFOCK.NE.0) THEN TITLE = 'AO Fock matrix:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40)) END IF END IF OUTPUT THE AO DENSITY MATRIX: IO = IOINQR(JPRINT(27)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'Spinless AO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27)) END IF OUTPUT THE AO DIPOLE MATRICES: IO = IOINQR(JPRINT(50)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO x dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF IX = 2 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO y dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF IX = 3 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO z dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF END IF INITIALIZE THE AO TO NAO TRANSFORMATION MATRIX (UNIT MATRIX): DO 20 J = 1,NBAS DO 10 I = 1,NBAS T(I,J) = ZERO 10 CONTINUE T(J,J) = ONE 20 CONTINUE SAVE TNAO FOR LATER USE: CALL SVTNAO(T) FILL ATOMIC ORBITAL INFORMATION LISTS: DO 30 I = 1,NBAS NAOCTR(I) = LCTR(I) NAOL(I) = LANG(I) LSTOCC(I) = 1 30 CONTINUE PERFORM THE NATURAL POPULATION ANALYSIS: (NOTE THAT ROUTINE NAOANL EXPECTS TO FIND THE OVERLAP MATRIX IN T, WHICH IS THE UNIT MATRIX FOR ORTHOGONAL BASIS SETS. UPON RETURN FROM NAOANL, T IS THE AO TO NAO TRANSFORMATION, WHICH IS STILL A UNIT MATRIX): I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NATOMS I4 = I3 + NATOMS*NATOMS I5 = I4 + NATOMS*NATOMS I6 = I5 + NDIM*NDIM IEND = I6 + NDIM CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6)) DO NOT DESTROY THE MATRIX AT A(I1). THIS HOLDS THE WIBERG BOND INDEX WHICH NEEDS TO BE PASSED TO THE NBO ROUTINES. SAVE THE NAO DENSITY MATRIX: CALL SVDNAO(DM) FORM THE NAO LABELS: CALL LBLNAO IF THIS IS AN OPEN SHELL WAVEFUNCTION, DON'T DO ANYTHING MORE: IF(OPEN) RETURN OUTPUT THE NAO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(9)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9)) END IF REORGANIZE THE SCRATCH VECTOR: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM IEND = I3 + NDIM OUTPUT THE NAO FOCK MATRIX: IO = IOINQR(JPRINT(31)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31)) END IF END IF OUTPUT THE NAO DENSITY MATRIX: IO = IOINQR(JPRINT(35)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NAO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35)) END IF RETURN END ************************************************************************** SUBROUTINE DMNAO(DM,T,A) ************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1) CHARACTER*80 TITLE DATA IPRNT,IWRIT/4HPRNT,4HWRIT/ PLACE ALPHA OR BETA OCCUPATION MATRIX IN DM AND TRANSFORM FROM THE AO TO NAO BASIS: IF(ALPHA) THEN IF(JPRINT(4).NE.0) WRITE(LFNPR,2100) ELSE DO 70 I = 1,NBAS NAOCTR(I) = NAOC(I) NAOL(I) = NAOA(I) LBL(I) = LCTR(I) LORBC(I) = LANG(I) 70 CONTINUE CALL FETNAO(T) IF(JPRINT(4).NE.0) WRITE(LFNPR,2200) END IF OUTPUT THE AO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(26)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEAOMO(A,IT) IF(IT.NE.0) THEN TITLE = 'MOs in the AO basis:' CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26)) END IF END IF OUTPUT THE AO FOCK MATRIX: IO = IOINQR(JPRINT(40)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A,IWFOCK) IF(IWFOCK.NE.0) THEN TITLE = 'AO Fock matrix:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40)) END IF END IF FETCH ALPHA OR BETA DM (ACCORDING TO WHETHER ALPHA OR BETA IS TRUE): CALL FEDRAW(DM,A) OUTPUT THE AO BOND-ORDER MATRIX: IO = IOINQR(JPRINT(42)) IF(IWDM.NE.0.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN TITLE = 'AO bond-order matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(42)) END IF CONVERT THE BOND-ORDER MATRIX TO THE DENSITY MATRIX: IF(IWDM.NE.0) THEN I1 = 1 I2 = I1 + NDIM*NDIM IEND = I2 + NDIM*NDIM CALL FESRAW(A(I1)) CALL SIMTRM(DM,A(I1),A(I2),NDIM,NBAS,IWMULP,IWCUBF) END IF OUTPUT THE AO DENSITY MATRIX: IO = IOINQR(JPRINT(27)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'AO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27)) END IF TRANSFORM DM TO THE NAO BASIS: CALL SIMTRS(DM,T,A,NDIM,NBAS) SAVE THE NAO DENSITY MATRIX IN SCRATCH STORAGE: CALL SVDNAO(DM) PRINT THE NATURAL POPULATION ANALYSIS FOR THIS SPIN CASE: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NATOMS I4 = I3 + NATOMS*NATOMS I5 = I4 + NATOMS*NATOMS I6 = I5 + NDIM*NDIM IEND = I6 + NDIM CALL FESNAO(T) CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6)) NOTE: DO NOT DESTROY THE WIBERG BOND INDEX WHICH IS STORED IN THE FIRST NATOMS*NATOMS ELEMENTS OF THE SCRATCH VECTOR A. THIS IS MATRIX IS REQUIRED FOR THE NBO ANALYSIS: NOTE THAT T IS NOW T-AO-NAO: FORM THE NAO LABELS: CALL LBLNAO OUTPUT THE NAO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(9)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9)) END IF REORGANIZE THE SCRATCH VECTOR: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM IEND = I3 + NDIM OUTPUT THE NAO FOCK MATRIX: IO = IOINQR(JPRINT(31)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31)) END IF END IF OUTPUT THE NAO DENSITY MATRIX: IO = IOINQR(JPRINT(35)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NAO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35)) END IF RETURN 2100 FORMAT(//1X, * '***************************************************',/1X, * '******* Alpha spin orbitals *******',/1X, * '***************************************************') 2200 FORMAT(//1X, * '***************************************************',/1X, * '******* Beta spin orbitals *******',/1X, * '***************************************************') END ************************************************************************** SUBROUTINE DMSIM(DM,T,A) ************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1) CHARACTER*80 TITLE DATA IPRNT,IWRIT/4HPRNT,4HWRIT/ SIMULATE THE ALPHA/BETA NAO SUBPROGRAM: IF(ALPHA) THEN IF(JPRINT(4).NE.0) WRITE(LFNPR,2100) ELSE DO 70 I = 1,NBAS NAOCTR(I) = NAOC(I) NAOL(I) = NAOA(I) LBL(I) = LCTR(I) LORBC(I) = LANG(I) 70 CONTINUE CALL FETNAO(T) IF(JPRINT(4).NE.0) WRITE(LFNPR,2200) END IF OUTPUT THE AO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(26)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEAOMO(A,IT) IF(IT.NE.0) THEN TITLE = 'MOs in the AO basis:' CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26)) END IF END IF OUTPUT THE AO FOCK MATRIX: IO = IOINQR(JPRINT(40)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A,IWFOCK) IF(IWFOCK.NE.0) THEN TITLE = 'AO Fock matrix:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40)) END IF END IF FETCH ALPHA OR BETA DM (ACCORDING TO WHETHER ALPHA OR BETA IS TRUE): CALL FEDRAW(DM,A) OUTPUT THE AO DENSITY MATRIX: IO = IOINQR(JPRINT(27)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'AO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27)) END IF SAVE THE NAO DENSITY MATRIX IN SCRATCH STORAGE: CALL SVDNAO(DM) PRINT THE NATURAL POPULATION ANALYSIS FOR THIS SPIN CASE: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NATOMS I4 = I3 + NATOMS*NATOMS I5 = I4 + NATOMS*NATOMS I6 = I5 + NDIM*NDIM IEND = I6 + NDIM CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6)) NOTE: DO NOT DESTROY THE WIBERG BOND INDEX WHICH IS STORED IN THE FIRST NATOMS*NATOMS ELEMENTS OF THE SCRATCH VECTOR A. THIS IS MATRIX IS REQUIRED FOR THE NBO ANALYSIS: FORM THE NAO LABELS: CALL LBLNAO OUTPUT THE NAO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(9)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9)) END IF REORGANIZE THE SCRATCH VECTOR: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM IEND = I3 + NDIM OUTPUT THE NAO FOCK MATRIX: IO = IOINQR(JPRINT(31)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31)) END IF END IF PRINT THE NAO DENSITY MATRIX: IO = IOINQR(JPRINT(35)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NAO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35)) END IF RETURN 2100 FORMAT(//1X, * '***************************************************',/1X, * '******* Alpha spin orbitals *******',/1X, * '***************************************************') 2200 FORMAT(//1X, * '***************************************************',/1X, * '******* Beta spin orbitals *******',/1X, * '***************************************************') END ************************************************************************** SUBROUTINE NBODRV(DM,T,A,MEMORY) ************************************************************************** DRIVER SUBROUTINE TO CALCULATE NATURAL HYBRID ORBITALS (NHOS) AND NATURAL BOND ORBITALS (NBOS) FROM THE DENSITY MATRIX IN THE NAO BASIS T = SCRATCH STORAGE DM = NAO DENSITY MATRIX THE SPIN NATURE OF DM IS INDICATED BY: ISPIN = 0: SPINLESS (CLOSED SHELL) ISPIN = +2: ALPHA SPIN ISPIN = -2: SPIN (ISPIN IS THE RECIPROCAL OF THE S(Z) QUANTUM NO.) A = SCRATCH STORAGE FROM THE MAIN PROGRAM. THE LOCATION OF A(1) IS IN THE COMMON BLOCK /SCM/ IN THE MAIN PROGRAM, AFTER THE STORAGE FOR THE MATRICES 'S','DM' ('A' IS THE VECTOR WHICH IS PARTITIONED ACCORDING TO THE STORAGE NEEDS OF EACH PROGRAM RUN) ATOM, BASIS, OPTION, NBINFO: COMMON BLOCKS WITH DATA TRANSFERED FROM FROM THE INPUT PROGRAMS. ----------------------------------------------------------------------------- IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*80 TITLE PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM), + NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM) COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(1) DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/ DATA ZERO/0.0D0/ SKIP NBO TRANSFORMATION IF REQUESTED: IF(JPRINT(1).GT.0) THEN WRITE(LFNPR,2000) RETURN END IF ORGANIZE SCRATCH STORAGE VECTOR A. WARNING: THIS IS REDEFINED SEVERAL TIMES AFTER THE NBOS ARE FORMED A(I0) = GUIDE(NATOMS,NATOMS) A(I1) = BNDOCC(NDIM) A(I2) = POL(NDIM,3) A(I3) = Q(MXAO,NDIM) A(I4) = V(NDIM) A(I5) = BLK(MXBO,MXBO) A(I6) = C(MXBO,MXBO) A(I7) = EVAL(MXBO) A(I8) = BORB(MXBO) A(I9) = P(MXAO,MXAO) A(I10) = PK(MXAO,MXAO) A(I11) = HYB(MXAO) A(I12) = VA(MXAO) A(I13) = VB(MXAO) I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + 3*NDIM I4 = I3 + MXAO*NDIM I5 = I4 + NDIM I6 = I5 + MXBO*MXBO I7 = I6 + MXBO*MXBO I8 = I7 + MXBO I9 = I8 + MXBO I10 = I9 + MXAO*MXAO I11 = I10 + MXAO*MXAO I12 = I11 + MXAO I13 = I12 + MXAO I14 = I13 + MXAO IEND = I14 + NATOMS*NATOMS IF(JPRINT(5).NE.0.AND.ISPIN.EQ.0) WRITE(LFNPR,1400) IF(JPRINT(5).NE.0.AND.ISPIN.EQ.2) WRITE(LFNPR,1410) IF(JPRINT(5).NE.0.AND.ISPIN.EQ.-2) WRITE(LFNPR,1420) READ IN T-NAB, LABEL, IBXM, TRANSFORM DM, AND FIND BNDOCC IF IWTNAB=IREAD: IF(IOINQR(IWTNAB).EQ.IREAD) THEN CALL RDTNAB(T,DM,A(I1),A(I2),IWTNAB) ELSE SEARCH INPUT FILE FOR $CORE INPUT: IF(.NOT.BETA) THEN CALL CORINP(JPRINT(2),JCORE) CALL RDCORE(JCORE) END IF SEARCH INPUT FILE FOR $CHOOSE INPUT: IF(.NOT.BETA) THEN CALL CHSINP(JPRINT(2),ICHOOS) IF(OPEN.AND.ICHOOS.EQ.1.AND.JPRINT(32).NE.0) THEN WRITE(LFNPR,1390) ICHOOS = 0 END IF END IF CALCULATE NATURAL HYBRID ORBITALS AND BOND ORBITALS: IF(ICHOOS.NE.1) CALL NATHYB(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4), + A(I5),A(I6),A(I7),A(I8),A(I9),A(I10), + A(I11),A(I12),A(I13),A(I14)) IF(ICHOOS.EQ.1) CALL CHSDRV(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4), + A(I5),A(I6),A(I7),A(I8),A(I9),A(I10), + A(I11),A(I12),A(I13),A(I14)) IF NBO SEARCH WAS ABANDONED, DON'T TRY TO DO ANYTHING FURTHER: IF(JPRINT(1).LT.0) RETURN SORT THE NBOS BY ATOM: CALL SRTNBO(T,A(I1)) FORM THE NBO DENSITY MATRIX: CALL SIMTRS(DM,T,A(I2),NDIM,NBAS) CHECK NHO OVERLAPS TO SEE IF BOND ORBITALS SHOULD BE RELABELLED: IF(.NOT.ORTHO) THEN I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + MXAO I4 = I3 + NDIM*NDIM I5 = I4 + NDIM*NDIM I6 = I5 + NDIM IEND = I6 + NDIM CALL XCITED(DM,T,A(I2),A(I3),A(I4),A(I5),A(I6),A(I6)) END IF END IF T NOW CONTAINS THE NAO-NBO TRANSFORMATION MATRIX DM NOW CONTAINS THE NBO DENSITY MATRIX A(I0) CONTAINS THE WIBERG BOND INDEX MATRIX ! DON'T DESTROY THIS A(I1) CONTAINS THE NBO OCCUPANCIES ! DON'T DESTROY THIS A(I2) IS SCRATCH SPACE SAVE THE NAO-NBO TRANSFORMATION ON THE NBO DAF: CALL SVTNAB(T) FORM THE NBO LABELS: CALL LBLNBO WRITE OUT THE ANALYSIS OF BOND ORBITALS: I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + NDIM I4 = I3 + NDIM IEND = I4 + NDIM*NDIM CALL ANLYZE(T,A(I1),A(I2),A(I3),A(I4)) WRITE OUT HYBRID DIRECTIONALITY AND BOND BENDING INFO: IF(JPRINT(36).NE.0) THEN I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + 3*NATOMS I4 = I3 + NDIM*NDIM I5 = I4 + NDIM*NDIM IEND = I5 + NDIM CALL HYBDIR(A(I1),A(I2),A(I3),A(I4),A(I5)) END IF FIND MOLECULAR UNITS: CALL FNDMOL(A(I2)) CLASSIFY ALL THE NBOS ACCORDING TO DONOR/ACCEPTOR TYPE: CALL NBOCLA(A(I1),ACCTHR) OUTPUT TRANSFORMATION MATRICES FOR THE PNHO AND NHO BASIS SETS, AND THE NHO DENSITY MATRIX, NHO FOCK MATRIX, AND NHO DIPOLE MATRICES: THE SECTION OF THE CODE MAKES USE OF T AND DM. THESE MATRICES WILL BE RESTORED LATER: [NOTE: DO NOT DESTROY INFO ALREADY STORED IN A(I0) AND A(I1)] REORGANIZE THE SCRATCH VECTOR: I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) OUTPUT THE AO-PNHO TRANSFORMATION AND THE PNHO OVERLAP MATRIX: IO = IOINQR(JPRINT(20)) JO = IOINQR(JPRINT(30)) IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR. + (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN CALL FEPNAO(T) CALL FETNHO(A(I2)) CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS) CALL FESRAW(A(I2)) CALL NORMLZ(T,A(I2),NDIM,NBAS) IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN TITLE = 'PNHOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(30)) END IF IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'PNHO overlap matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(20)) END IF ENDIF FORM THE AO-NHO TRANSFORMATION MATRIX: CALL FETNAO(T) CALL FETNHO(A(I2)) CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS) OUTPUT THE AO-NHO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(28)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NHOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(28)) END IF OUTPUT THE NAO-NHO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(33)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FETNHO(A(I2)) TITLE = 'NHOs in the NAO basis:' CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,2,JPRINT(33)) END IF OUTPUT THE NHO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(38)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FRMTMO(T,A(I2),A(I3),A(I4),3,JPRINT(38)) END IF OUTPUT THE NHO DENSITY MATRIX: IO = IOINQR(JPRINT(34)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEDRAW(DM,A(I2)) IF(IWDM.EQ.1) THEN CALL FESRAW(A(I2)) CALL SIMTRS(DM,A(I2),A(I3),NDIM,NBAS) END IF CALL SIMTRS(DM,T,A(I2),NDIM,NBAS) TITLE = 'NHO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,3,JPRINT(34)) END IF OUTPUT THE NHO FOCK MATRIX: IO = IOINQR(JPRINT(29)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NHO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(29)) END IF END IF OUTPUT THE NHO DIPOLE MATRICES: IO = IOINQR(JPRINT(52)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NHO x dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52)) END IF IX = 2 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NHO y dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52)) END IF IX = 3 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NHO z dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52)) END IF END IF OUTPUT TRANSFORMATION MATRICES FOR THE PNBO AND NBO BASIS SETS, AND THE NBO DENSITY MATRIX, NBO FOCK MATRIX, AND NBO DIPOLE MATRICES: [NOTE: DO NOT DESTROY INFO ALREADY STORED IN A(I0) AND A(I1)] REORGANIZE THE SCRATCH VECTOR: I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) OUTPUT THE AO-PNBO TRANSFORMATION AND THE PNBO OVERLAP MATRIX: IO = IOINQR(JPRINT(21)) JO = IOINQR(JPRINT(25)) IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR. + (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN CALL FEPNAO(T) CALL FETNAB(A(I2)) CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS) CALL FESRAW(A(I2)) CALL NORMLZ(T,A(I2),NDIM,NBAS) IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN TITLE = 'PNBOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(25)) END IF IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'PNBO overlap matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(21)) END IF END IF FORM THE AO-NBO TRANSFORMATION MATRIX: CALL FETNAO(T) CALL FETNAB(A(I2)) CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS) SAVE THE AO-NBO TRANSFORMATION, NBO OCCS, AND NBO LABELS ON NBO DAF: CALL SVNBO(T,A(I1),A(I2)) WRITE THE AO-NBO TRANSFORMATION WITH NBO LABELS AND OCCUPANCIES: IF(IOINQR(IWTNBO).EQ.IWRIT) CALL WRTNBO(T,A(I1),IWTNBO) PRINT THE AO-NBO TRANSFORMATION MATRIX: IF(IOINQR(IWTNBO).EQ.IPRNT) THEN TITLE = 'NBOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IWTNBO) END IF WRITE THE NAO-NBO TRANSFORMATION MATRIX: IF(IOINQR(IWTNAB).EQ.IWRIT) THEN CALL FETNAB(A(I2)) CALL WRTNAB(A(I2),IWTNAB) END IF PRINT THE NAO-NBO TRANSFORMATION TO THE OUTPUT FILE: IF(IOINQR(IWTNAB).EQ.IPRNT) THEN CALL FETNAB(A(I2)) TITLE = 'NBOs in the NAO basis:' CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,2,IWTNAB) END IF OUTPUT THE NHO-NBO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(41)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FETNHO(A(I2)) CALL TRANSP(A(I2),NDIM,NBAS) CALL FETNAB(A(I3)) CALL MATMLT(A(I2),A(I3),A(I4),NDIM,NBAS) TITLE = 'NBOs in the NHO basis:' CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,3,JPRINT(41)) END IF OUTPUT THE NBO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(45)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FRMTMO(T,A(I2),A(I3),A(I4),4,JPRINT(45)) END IF FORM THE NBO DENSITY MATRIX: CALL FEDRAW(DM,A(I2)) IF(IWDM.EQ.1.AND..NOT.ORTHO) THEN CALL FESRAW(A(I2)) CALL SIMTRS(DM,A(I2),A(I3),NDIM,NBAS) END IF CALL SIMTRS(DM,T,A(I2),NDIM,NBAS) OUTPUT THE NBO DENSITY MATRIX: IO = IOINQR(JPRINT(16)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NBO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,4,JPRINT(16)) END IF OUTPUT THE NBO FOCK MATRIX: CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) CALL SVFNBO(A(I2)) IO = IOINQR(JPRINT(37)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NBO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(37)) END IF END IF OUTPUT THE NBO DIPOLE MATRICES: IO = IOINQR(JPRINT(53)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NBO x dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53)) END IF IX = 2 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NBO y dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53)) END IF IX = 3 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NBO z dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53)) END IF END IF PERFORM PERTURBATIVE ANALYSIS OF THE NBO FOCK MATRIX: IF(JPRINT(3).EQ.1.AND.IWFOCK.NE.0) CALL FNBOAN(A(I1),A(I2),A(I3)) PRINT THE NBO SUMMARY: IF(JPRINT(6).EQ.1) THEN I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + NDIM*NDIM I4 = I3 + NDIM I5 = I4 + NATOMS IEND = I5 + NDIM CALL NBOSUM(A(I2),A(I1),A(I3),A(I4),A(I5)) END IF CONTINUE WITH THE CONSTRUCTION OF THE NLMOS: IF(JPRINT(8).NE.0) THEN STORE IN A(I0) THE VECTOR RESON(NDIM), THE SQUARES OF THE DIAGONAL ELEMENTS OF THE NBO TO NLMO TRANSFORMATION MATRIX. IALARM SOUNDS THE ALARM THAT THE NLMO STEP IS TO BE SKIPPED: DM : NBO DENSITY ! TRANSFORMED TO NLMO BASIS ON RETURN A(I0): RESON(NDIM) ! PERCENTAGES OF PARENT NBO A(I1): LMOOCC(NDIM) ! NLMO OCCUPANCIES A(I2): TNLMO(NDIM,NDIM) ! NBO-NLMO TRANSFORM A(I3): TSYM ! SCRATCH (DO NOT DESTROY THE WIBERG BOND INDEX!) I0 = 1 + NATOMS*NATOMS I1 = I0 + NDIM I2 = I1 + NDIM I3 = I2 + NDIM*NDIM IEND = I3 + NDIM*NDIM CALL NLMO(NBAS,DM,A(I1),A(I2),A(I3),A(I0),NOCC,IALARM) IF(IALARM.NE.0) RETURN SAVE THE NBO TO NLMO TRANSFORMATION MATRIX ON THE NBO DAF: CALL SVTLMO(A(I2)) FORM THE NAO TO NLMO TRANSFORMATION IN T: CALL FETNAB(T) CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS) SET UP STORAGE FOR LMOANL: A(I0): RESON(NDIM) A(I1): LMOOCC(NDIM) A(I2): TS(NDIM) A(I3): BORDER(NATOMS,NATOMS) A(I4): OWBORD(NATOMS,NATOMS) A(I5): ATLMO(NOCC,NATOMS) A(I6): SIAB(NOCC,NAB) (DO NOT DESTROY THE WIBERG BOND INDEX!) NAB = NATOMS*(NATOMS-1)/2 IF(NATOMS.EQ.1) NAB = 1 I0 = 1 + NATOMS*NATOMS I1 = I0 + NDIM I2 = I1 + NDIM I3 = I2 + NDIM I4 = I3 + NATOMS*NATOMS I5 = I4 + NATOMS*NATOMS I6 = I5 + NOCC*NATOMS I7 = I6 + NOCC*NAB IEND = I7 + NDIM*NDIM CALL COPY(DM,A(I7),NDIM,NBAS,NBAS) CALL LMOANL(T,A(I7),A(I0),A(I1),A(I2),A(I3),A(I4),A(I5), + A(I6),NOCC,NAB) OUTPUT TRANSFORMATION MATRICES FOR THE PNLMO AND NLMO BASIS SETS, AND THE NLMO DENSITY MATRIX, NLMO FOCK MATRIX, AND NLMO DIPOLE MATRICES: REORGANIZE THE SCRATCH VECTOR: (DO NOT DESTROY THE WIBERG BOND INDEX!) I0 = 1 + NATOMS*NATOMS I1 = I0 + NDIM*NDIM I2 = I1 + NDIM*NDIM IEND = I2 + NDIM*(NDIM+5) OUTPUT THE AO-PNLMO TRANSFORMATION AND THE PNLMO OVERLAP MATRIX: IO = IOINQR(JPRINT(48)) JO = IOINQR(JPRINT(49)) IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR. + (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN CALL FEPNAO(T) CALL FETNAB(A(I0)) CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS) CALL FETLMO(A(I0)) CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS) CALL FESRAW(A(I0)) CALL NORMLZ(T,A(I0),NDIM,NBAS) IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN TITLE = 'PNLMOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(49)) END IF IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS) TITLE = 'PNLMO overlap matrix:' CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(48)) END IF END IF FORM THE AO-NLMO TRANSFORMATION MATRIX: CALL FETNAO(T) CALL FETNAB(A(I0)) CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS) CALL FETLMO(A(I0)) CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS) SAVE THE AO-NLMO TRANSFORMATION ON NBO DAF: CALL SVNLMO(T) WRITE OUT THE AO-NLMO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(23)) IF(IO.EQ.IWRIT) CALL WRNLMO(T,DM,JPRINT(23)) PRINT THE AO-NLMO TRANSFORMATION MATRIX: IF(IO.EQ.IPRNT) THEN TITLE = 'NLMOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(23)) END IF OUTPUT THE NAO-NLMO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(18)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FETNAB(A(I0)) CALL FETLMO(A(I1)) CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS) TITLE = 'NLMOs in the NAO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,2,JPRINT(18)) END IF OUTPUT THE NHO-NLMO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(24)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FETNHO(A(I0)) CALL TRANSP(A(I0),NDIM,NBAS) CALL FETNAB(A(I1)) CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS) CALL FETLMO(A(I1)) CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS) TITLE = 'NLMOs in the NHO basis:' CALL AOUT(A(I0),NDIM,NBAS,NBAS,TITLE,3,JPRINT(24)) END IF OUTPUT THE NBO-NLMO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(47)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FETLMO(A(I0)) TITLE = 'NLMOs in the NBO basis:' CALL AOUT(A(I0),NDIM,NBAS,NBAS,TITLE,4,JPRINT(47)) END IF OUTPUT THE NLMO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(13)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FRMTMO(T,A(I0),A(I1),A(I2),5,JPRINT(13)) END IF OUTPUT THE NLMO DENSITY MATRIX: IO = IOINQR(JPRINT(17)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NLMO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,5,JPRINT(17)) END IF OUTPUT THE NLMO FOCK MATRIX: IO = IOINQR(JPRINT(15)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I0),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS) TITLE = 'NLMO Fock matrix:' CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(15)) END IF END IF OUTPUT THE NLMO DIPOLE MATRICES: IO = IOINQR(JPRINT(54)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A(I0),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS) TITLE = 'NLMO x dipole integrals:' CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54)) END IF IX = 2 CALL FEDXYZ(A(I0),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS) TITLE = 'NLMO y dipole integrals:' CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54)) END IF IX = 3 CALL FEDXYZ(A(I0),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS) TITLE = 'NLMO z dipole integrals:' CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54)) END IF END IF PERFORM THE NBO/NLMO DIPOLE MOMENT ANALYSIS: DM : NLMO DENSITY MATRIX T : AO-NLMO TRANSFORMATION MATRIX A(I1): C(NDIM,NDIM) A(I2): TNBO(NDIM,NDIM) A(I3): DX(NDIM,NDIM) A(I4): DY(NDIM,NDIM) A(I5): DZ(NDIM,NDIM) A(I6): SCR(NDIM,NDIM) A(I7): INDEX(NDIM) (DO NOT DESTROY THE WIBERG BOND INDEX!) IF(JPRINT(46).NE.0) THEN I1 = 1 + NATOMS*NATOMS I2 = I1 + NDIM*NDIM I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM I5 = I4 + NDIM*NDIM I6 = I5 + NDIM*NDIM I7 = I6 + NDIM*NDIM IEND = I7 + NDIM CALL DIPANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6),A(I7)) END IF END IF PERFORM NATURAL RESONANCE THEORY ANALYSIS: IF(JPRINT(32).NE.0) THEN CAREFULLY DETERMINE THE MAXIMUM NUMBER OF RESONANCE STRUCTURES (MAXRES) THAT THE SCRATCH VECTOR CAN ACCOMODATE. ASSUME THAT THERE WILL BE ROUGHLY 6(=NEL) ELEMENTS REQUIRED PER ATOM TO STORE THE TOPO MATRICES FOR EACH RESONANCE STRUCTURE: (1 FOR NUMBER OF BONDS, 1 FOR NUMBER OF LONE PAIRS, AND 4 BONDED ATOMS -- SEE SR TOPSTR) NEL = 6 TOT = ZERO DO 80 IBAS = 1,NBAS TOT = TOT + DM(IBAS,IBAS) 80 CONTINUE NELEC = NINT(TOT) NLOW = NATOMS*(NATOMS-1)/2 MAXREF = MAX(JPRINT(56),1) CAREFULLY DETERMINE THE MAXIMUM NUMBER OF RESONANCE STRUCTURES (MAXRES) WHICH THE SCRATCH VECTOR CAN ACCOMODATE. ASSUME NDIM IS LARGER THAN MAXRES (THIS IS NOT USUALLY THE CASE): IC = NDIM*NDIM + 4*NDIM + MXAO*NDIM + NDIM + MXBO*MXBO + + MXBO*MXBO + MXBO + MXBO + MXAO*MXAO + MXAO*MXAO + + MXAO + MXAO + MXAO + NATOMS*NATOMS + NDIM*MAXREF + + NDIM*NDIM + MAXREF + MAXREF + NDIM*MAXREF + NDIM + + NDIM*NDIM + NDIM*NDIM + NDIM*NDIM + NATOMS*NATOMS + + MAXREF - MEMORY IB = NDIM*MAXREF + 6*MAXREF + NLOW*MAXREF + 9 + NATOMS*NEL IA = 0 MAXRES = INT(-IC / IB) CHECK THIS ASSUMPTION: IF(MAXRES.GT.NDIM) THEN IC = IC - NDIM*NDIM - NDIM*NDIM IA = 2 DET = SQRT(REAL(IB * IB - 4 * IA * IC)) MAXRES = INT((-REAL(IB) + DET) / REAL(2 * IA)) END IF IF(MAXRES.GT.NDIM*NDIM) THEN IC = IC - NDIM*NDIM IB = IB + 1 IA = 2 DET = SQRT(REAL(IB * IB - 4 * IA * IC)) MAXRES = INT((-REAL(IB) + DET) / REAL(2 * IA)) END IF LEN = NEL * NATOMS * MAXRES PARTITION THE SCRATCH VECTOR: I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + MAXRES*MAXREF I3 = I2 + MAXRES*MAXREF I4 = I3 + MAXREF MEM = MEMORY - I4 + 1 CALL NRTDRV(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4),MAXRES,MAXREF, + NLOW,LEN,NELEC,MEM) END IF RETURN 1390 FORMAT(/1X,'WARNING: The $CHOOSE keylist is incompatible with ', + 'the NRT analysis for open',/1X,' shell NBO analyses.', + ' Program execution will continue, ignoring the',/1X,' ', + ' $CHOOSE keylist.') 1400 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS:') 1410 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS,', * ' alpha spin orbitals:') 1420 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS,', * ' beta spin orbitals:') 2000 FORMAT(//1X,'NBO analysis skipped by request.') END ***************************************************************************** ROUTINES CALLED BY THE NAO DRIVERS: SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF) SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF) SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR) SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK) SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO) SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG) ***************************************************************************** SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SIMILARITY TRANSFORM A ==> S(TRANSPOSE)*A*S, USING SCRATCH VECTOR V. WRITE THE DIAGONAL ELEMENTS OF A*S BY CALLING SUBROUTINE MULANA IF IWMULP.NE.0 (THESE ARE THE MULLIKEN POPULATIONS IF S= OVERLAP MATRIX AND A= BOND-ORDER MATRIX) DIMENSION A(NDIM,NDIM),S(NDIM,NDIM),V(1) CALL MATMLT(A,S,V,NDIM,N) I1=NDIM+1 IF(IWMULP.NE.0) CALL MULANA(A,V(1),V(I1),IWMULP,IWCUBF) CALL MATML2(S,A,V,NDIM,N) RETURN END ***************************************************************************** SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PERFORM MAYER-MULLIKEN BOND ORDER ANALYSIS PRINT OUT DIAGONAL ELEMENTS OF BS=B*S, WHERE B= BOND-ORDER MATRIX, S= OVERLAP MATRIX, BOTH IN ORIGINAL AO BASIS THIS CONSTITUTES A MULLIKEN POPULATION ANALYSIS. PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION BS(NDIM,NDIM),VMAYER(NATOMS),BMAYER(NATOMS,NATOMS), * IANG(5),ANGL(60),LANG(60),CUBICF(7) CHARACTER*80 TITLE DATA IANG/'s','p','d','f','g'/ DATA LANG/ 51,151,152,153,251,252,253,254,255, * 351,352,353,354,355,356,357, * 451,452,453,454,455,456,457,458,459, * 1,101,102,103,201,202,203,204,205,206, * 301,302,303,304,305,306,307,308,309,310, * 401,402,403,404,405,406,407,408,409,410, * 411,412,413,414,415/ DATA ANGL/4H ,4Hx ,4Hy ,4Hz ,4Hxy ,4Hxz ,4Hyz , * 4Hx2y2,4Hz2 ,4H(0) ,4H(c1),4H(s1),4H(c2),4H(s2),4H(c3), * 4H(s3),4H(0) ,4H(c1),4H(s1),4H(c2),4H(s2),4H(c3),4H(s3), * 4H(c4),4H(s4), * 4H ,4Hx ,4Hy ,4Hz ,4Hxx ,4Hxy ,4Hxz , * 4Hyy ,4Hyz ,4Hzz ,4Hxxx ,4Hxxy ,4Hxxz ,4Hxyy ,4Hxyz , * 4Hxzz ,4Hyyy ,4Hyyz ,4Hyzz ,4Hzzz ,4Hxxxx,4Hxxxy,4Hxxxz, * 4Hxxyy,4Hxxyz,4Hxxzz,4Hxyyy,4Hxyyz,4Hxyzz,4Hxzzz,4Hyyyy, * 4Hyyyz,4Hyyzz,4Hyzzz,4Hzzzz/ DATA CUBICF/4H(d1),4H(d2),4H(d3),4H(b) ,4H(e1),4H(e2),4H(e3)/ DATA ZERO/0.0D0/ IF(IWCUBF.EQ.0) GO TO 20 IF THE F FUNCTIONS ARE A CUBIC SET, INSERT THE PROPER LABELS: DO 10 I=1,7 II=I+9 10 ANGL(II)=CUBICF(I) 20 CONTINUE IF(IWMULP.EQ.1) WRITE(LFNPR,1000) IF(IWMULP.EQ.2) WRITE(LFNPR,1100) IF(IWMULP.EQ.2) WRITE(LFNPR,1200) SUMT=ZERO DO 100 I=1,NATOMS VMAYER(I)=ZERO DO 100 J=1,NATOMS 100 BMAYER(I,J)=ZERO DO 300 IAT=1,NATOMS IZ=IATNO(IAT) NAM=NAMEAT(IZ) SUMAT=ZERO DO 200 I=1,NBAS IF(LBL(I).NE.IAT) GO TO 200 LM=LORBC(I) L=LM/100 IL=IANG(L+1) DO 130 ILM=1,60 IF(LM.EQ.LANG(ILM)) GO TO 140 130 CONTINUE STOP 140 CONTINUE OCC=BS(I,I) SUMAT=SUMAT+OCC IF(IWMULP.EQ.2) WRITE(LFNPR,1300) I,NAM,IAT,IL,ANGL(ILM),OCC DO 180 J=1,NBAS JAT=LBL(J) IF(JAT.EQ.IAT) GO TO 180 BMAYER(IAT,JAT)=BMAYER(IAT,JAT)+BS(I,J)*BS(J,I) 180 CONTINUE 200 CONTINUE IF(IWMULP.EQ.1) WRITE(LFNPR,1800) NAM,IAT,SUMAT IF(IWMULP.EQ.2) WRITE(LFNPR,1900) NAM,IAT,SUMAT 300 SUMT=SUMT+SUMAT IF(IWMULP.NE.0) WRITE(LFNPR,1600) SUMT TITLE = 'Mayer-Mulliken atom-atom bond order matrix:' CALL AOUT(BMAYER,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS) DO 310 I=1,NATOMS DO 310 J=1,NATOMS 310 VMAYER(I)=VMAYER(I)+BMAYER(I,J) TITLE = 'Mayer-Mulliken valencies by atom:' CALL AOUT(VMAYER,NATOMS,NATOMS,1,TITLE,0,1) RETURN 1000 FORMAT(//1X,'Total gross Mulliken populations by atom:', * //4X,'Atom #',7X,'Total') 1100 FORMAT(//1X,'Input atomic orbitals, gross Mulliken populations:', +//1X,' AO',2X,'Atom #',2X,'lang',2X,'Mulliken Population', +4X,'Atom #',7X,'Total') 1200 FORMAT(1X,79('-')) 1300 FORMAT(1X,I3,3X,A2,I3,2X,A1,A4,F13.7) 1600 FORMAT(/1X,'Total number of electrons: ',F11.6) 1800 FORMAT(5X,A2,I3,F15.7) 1900 FORMAT(44X,A2,I3,F15.7) END ***************************************************************************** SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LIST(6,MAXBAS),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(6,6),B(6),M(6), * RENORM(NDIM), * LF(3,3),LFCUB(3,3),LFT(3,3),LFCUBT(3,3),LG(3,3),LGT(3,3) DATA LF /301,304,306,302,307,309,303,308,310/ DATA LFCUB /306,304,301,309,302,307,303,308,310/ DATA LFT /151,356,352,152,357,353,153,354,351/ DATA LFCUBT/151,355,351,152,356,352,153,357,353/ DATA LG /402,407,409,403,408,410,405,412,414/ DATA LGT /251,455,459,252,452,456,253,453,457/ DATA ZERO,ONE,TWO,THREE,FOUR,SIX,EIGHT * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,6.0D0,8.0D0/ ********************************************************************** SUBROUTINE TO TRANSFORM THE OVERLAP AND DENSITY MATRICES IF D, F, G ORBITALS ARE PRESENT, OR TRANSFORM A TRANSFORMATION MATRIX SO THAT IT STARTS FROM THE RAW AO INSTEAD OF THE PURE AO BASIS THIS TRANSFORMATION WILL NOT WORK IF DM IS THE BOND-ORDER MATRIX. LIST(6,MAXBAS): THE LIST OF FUNCTIONS TO BE TRANSFORMED LIST(1,I),LIST(2,I),LIST(3,I) ARE CORRESPONDING SETS OF D,F, OR G FUNCTIONS. IT IS ASSUMED THAT, FOR EXAMPLE, THE THIRD DX2 FUNCTION FOUND IN THE ANGULAR MOMENTA LIST "LORB" CORRESPONDS TO THE THIRD DY2 AND THE THIRD DZ2 FUNCTIONS IN THE LIST OF BASIS FUNCTIONS! ITRAN=IDTRAN+IFTRAN+IGTRAN IDTRAN: THE NUMBER OF SETS OF CARTESIAN D ORBITALS FOUND IFTRAN: THE NUMBER OF SETS OF CARTESIAN F ORBITALS FOUND IGTRAN: THE NUMBER OF SETS OF CARTESIAN G ORBITALS FOUND A : THE TRANSFORMATION MATRIX ITOPT : IF ZERO, TRANSFORM DM AND S (IN T) FROM RAW AO TO PURE AO BASIS IF ONE, PRE-MULTIPLY T BY THE AO TO PURE AO TRANSF. --- THIS CONVERTS A TRANSF. THAT STARTS FROM PURE AOS TO A TRANSF. THAT STARTS FROM THE RAW AOS RENORM: RENORMALIZATION VECTOR FOR CARTESIAN TO PURE TRANSFORM. (PRODUCED IF ITOPT=0, USED AS INPUT IF ITOPT=1) ********************************************************************** DO 10 I=1,NBAS 10 LORB(I)=0 IDTRAN=0 N1=0 N2=0 N3=0 N4=0 N5=0 N6=0 ...CONSTRUCT LIST: DO 70 IBAS=1,NBAS DX2: IF(LORBC(IBAS).NE.201) GO TO 20 N1=N1+1 LIST(1,N1)=IBAS GO TO 70 DY2: 20 IF(LORBC(IBAS).NE.204) GO TO 30 N2=N2+1 LIST(2,N2)=IBAS GO TO 70 DZ2: 30 IF(LORBC(IBAS).NE.206) GO TO 40 N3=N3+1 LIST(3,N3)=IBAS GO TO 70 LABEL DXY: 40 IF(LORBC(IBAS).NE.202) GO TO 50 N4=N4+1 LORB(IBAS)=251 GO TO 70 LABEL DXZ: 50 IF(LORBC(IBAS).NE.203) GO TO 60 N5 =N5+1 LORB(IBAS)=252 GO TO 70 LABEL DYZ: 60 IF(LORBC(IBAS).NE.205) GO TO 70 N6=N6+1 LORB(IBAS)=253 70 CONTINUE IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1950 IF(N1.NE.N4.OR.N1.NE.N5.OR.N1.NE.N6) GO TO 1950 IDTRAN=N1 IF(IDTRAN.EQ.0) GO TO 160 SET UP TRANSFORM. COEFF: S=R2=X2+Y2+Z2: A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE D(X2-Y2): A(1,2)= ONE A(2,2)=-ONE A(3,2)= ZERO D(3Z2-R2)=-X2-Y2+2Z2: A(1,3)=-ONE A(2,3)=-ONE A(3,3)= TWO IF(ITOPT.EQ.0) GO TO 110 DO 90 J=1,3 RENOR=RENORM(LIST(J,1)) DO 90 I=1,3 90 A(I,J)=A(I,J)*RENOR CALL TRANSP(A,6,3) 110 CONTINUE ...LOOP OVER D SETS IN DLIST: DO 150 ID=1,IDTRAN M(1)=LIST(1,ID) M(2)=LIST(2,ID) M(3)=LIST(3,ID) ...TRANSFORM S AND DM: IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1) IF(ITOPT.NE.0) GO TO 150 CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0) CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0) ...SET THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED: LORB(M(1))=51 LORB(M(2))=254 LORB(M(3))=255 150 CONTINUE ********************************************************************** 160 CONTINUE F ORBITALS IFTRAN=0 DO 400 IFBLK=1,3 N1=0 N2=0 N3=0 IF(IWCUBF.NE.0) GO TO 190 LF1=LF(1,IFBLK) LF2=LF(2,IFBLK) LF3=LF(3,IFBLK) GO TO 200 190 CONTINUE LF1=LFCUB(1,IFBLK) LF2=LFCUB(2,IFBLK) LF3=LFCUB(3,IFBLK) 200 CONTINUE ...CONSTRUCT THE LIST: DO 260 IBAS=1,NBAS IF(LORBC(IBAS).NE.LF1) GO TO 220 N1=N1+1 LIST(1,N1)=IBAS GO TO 260 220 IF(LORBC(IBAS).NE.LF2) GO TO 230 N2=N2+1 LIST(2,N2)=IBAS GO TO 260 230 IF(LORBC(IBAS).NE.LF3) GO TO 260 N3=N3+1 LIST(3,N3)=IBAS GO TO 260 260 CONTINUE IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1960 IF(IFBLK.EQ.1) IFTRAN=N1 IF((IFBLK.NE.1).AND.(IFTRAN.NE.N1)) GO TO 1960 IF(IFTRAN.EQ.0) GO TO 500 IF(IWCUBF.EQ.0) GO TO 270 SET UP TRANSFORM. COEFF, CUBIC F ORBITALS PX=X*R2, PY=Y*R2, PZ=Z*Z2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE FX(Z2-Y2), FY(Z2-X2), FZ(X2-Y2) A(1,2)= ONE A(2,2)=-ONE A(3,2)= ZERO FX(5Z2-3R2), FY(5Y2-3R2), FZ(5Z2-3R2) A(1,3)=-THREE A(2,3)=-THREE A(3,3)= TWO GO TO 310 270 IF(IFBLK.GT.1) GO TO 280 SET UP TRANSFORM. COEFF, FOR FIRST F BLOCK PX=X*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE FX(X2-3Y2) A(1,2)= ONE A(2,2)=-THREE A(3,2)= ZERO FX(5Z2-R2) A(1,3)=-ONE A(2,3)=-ONE A(3,3)= FOUR GO TO 310 280 IF(IFBLK.EQ.3) GO TO 290 SET UP TRANSFORM. COEFF, FOR SECOND F BLOCK PY=Y*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE FY(3X2-Y2) A(1,2)= THREE A(2,2)=-ONE A(3,2)= ZERO FY(5Z2-R2) A(1,3)=-ONE A(2,3)=-ONE A(3,3)= FOUR GO TO 310 290 CONTINUE SET UP TRANSFORM. COEFF, FOR THIRD F BLOCK PZ Z*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE FZ(X2-Y2) A(1,2)= ONE A(2,2)=-ONE A(3,2)= ZERO FZ(5Z2-3R2) A(1,3)=-THREE A(2,3)=-THREE A(3,3)= TWO 310 CONTINUE IF(ITOPT.EQ.0) GO TO 330 DO 320 J=1,3 RENOR=RENORM(LIST(J,1)) DO 320 I=1,3 320 A(I,J)=A(I,J)*RENOR CALL TRANSP(A,6,3) 330 CONTINUE ...LOOP OVER F SETS IN LIST: DO 390 IT=1,IFTRAN M(1)=LIST(1,IT) M(2)=LIST(2,IT) M(3)=LIST(3,IT) ...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0) IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1) IF(ITOPT.NE.0) GO TO 340 CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0) CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0) ...FIX THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED: 340 CONTINUE IF(IWCUBF.NE.0) GO TO 350 LORB(M(1))=LFT(1,IFBLK) LORB(M(2))=LFT(2,IFBLK) LORB(M(3))=LFT(3,IFBLK) GO TO 390 350 CONTINUE LORB(M(1))=LFCUBT(1,IFBLK) LORB(M(2))=LFCUBT(2,IFBLK) LORB(M(3))=LFCUBT(3,IFBLK) 390 CONTINUE 400 CONTINUE SEARCH FOR FXYZ AND RELABEL: LF1=305 LF1T=355 IF(IWCUBF.NE.0) LF1T=354 N1=0 DO 420 IBAS=1,NBAS IF(LORBC(IBAS).NE.LF1) GO TO 420 N1=N1+1 LORB(IBAS)=LF1T 420 CONTINUE IF(IFTRAN.NE.N1) GO TO 1960 500 CONTINUE G ORBITALS IGTRAN=0 DO 800 IGBLK=1,3 N1=0 N2=0 N3=0 LG1=LG(1,IGBLK) LG2=LG(2,IGBLK) LG3=LG(3,IGBLK) ...CONSTRUCT THE LIST: DO 560 IBAS=1,NBAS LANG=LORBC(IBAS) IF(LANG.NE.LG1) GO TO 520 N1=N1+1 LIST(1,N1)=IBAS GO TO 560 520 IF(LANG.NE.LG2) GO TO 530 N2=N2+1 LIST(2,N2)=IBAS GO TO 560 530 IF(LANG.NE.LG3) GO TO 560 N3=N3+1 LIST(3,N3)=IBAS GO TO 560 560 CONTINUE IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1970 IF(IGBLK.EQ.1) IGTRAN=N1 IF((IGBLK.NE.1).AND.(IGTRAN.NE.N1)) GO TO 1970 IF(IGTRAN.EQ.0) GO TO 1000 IF(IGBLK.GT.1) GO TO 580 SET UP TRANSFORM. COEFF, FOR FIRST G BLOCK DXY=XY*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE G(2S) A(1,2)= ONE A(2,2)=-ONE A(3,2)= SIX G(4S) A(1,3)= ONE A(2,3)=-ONE A(3,3)= ZERO GO TO 610 580 IF(IGBLK.EQ.3) GO TO 590 SET UP TRANSFORM. COEFF, FOR SECOND G BLOCK DXZ=XZ*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE G(1C) A(1,2)=-THREE A(2,2)=-THREE A(3,2)= FOUR G(3C) A(1,3)= ONE A(2,3)=-THREE A(3,3)= ZERO GO TO 610 590 CONTINUE SET UP TRANSFORM. COEFF, FOR THIRD G BLOCK DYZ=YZ*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE G(1S) A(1,2)=-THREE A(2,2)=-THREE A(3,2)= FOUR G(3S) A(1,3)= THREE A(2,3)=-ONE A(3,3)= ZERO 610 CONTINUE IF(ITOPT.EQ.0) GO TO 630 DO 620 J=1,3 RENOR=RENORM(LIST(J,1)) DO 620 I=1,3 620 A(I,J)=A(I,J)*RENOR CALL TRANSP(A,6,3) 630 CONTINUE ...LOOP OVER G SETS IN LIST: DO 690 IT=1,IGTRAN M(1)=LIST(1,IT) M(2)=LIST(2,IT) M(3)=LIST(3,IT) ...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0) IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1) IF(ITOPT.NE.0) GO TO 660 CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0) CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0) ...FIX THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED: 660 CONTINUE LORB(M(1))=LGT(1,IGBLK) LORB(M(2))=LGT(2,IGBLK) LORB(M(3))=LGT(3,IGBLK) 690 CONTINUE 800 CONTINUE G ORBITALS --- FOURTH (6X6) BLOCK N1=0 N2=0 N3=0 N4=0 N5=0 N6=0 ...CONSTRUCT THE LIST: DO 870 IBAS=1,NBAS LANG=LORBC(IBAS) IF(LANG.NE.401) GO TO 820 N1=N1+1 LIST(1,N1)=IBAS GO TO 870 820 IF(LANG.NE.411) GO TO 830 N2=N2+1 LIST(2,N2)=IBAS GO TO 870 830 IF(LANG.NE.415) GO TO 840 N3=N3+1 LIST(3,N3)=IBAS GO TO 870 840 IF(LANG.NE.404) GO TO 850 N4=N4+1 LIST(1,N4)=IBAS GO TO 870 850 IF(LANG.NE.406) GO TO 860 N5=N5+1 LIST(2,N5)=IBAS GO TO 870 860 IF(LANG.NE.413) GO TO 870 N6=N6+1 LIST(3,N6)=IBAS GO TO 870 870 CONTINUE IF(IGTRAN.NE.N1.OR.N1.NE.N2.OR.N1.NE.N3) GO TO 1970 IF(N1.NE.N4.OR.N1.NE.N5.OR.N1.NE.N6) GO TO 1970 SET UP TRANSFORM. COEFF, FOR FOURTH G BLOCK S=(R2)2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE A(4,1)= TWO A(5,1)= TWO A(6,1)= TWO D(3Z2-R2) A(1,2)=-ONE A(2,2)=-ONE A(3,2)= TWO A(4,2)=-TWO A(5,2)= ONE A(6,2)= ONE D(X2-Y2) A(1,3)= ONE A(2,3)=-ONE A(3,3)= ZERO A(4,3)= ZERO A(5,3)= ONE A(6,3)=-ONE G(0) A(1,4)= THREE A(2,4)= THREE A(3,4)= EIGHT A(4,4)= SIX A(5,4)=-SIX*FOUR A(6,4)=-SIX*FOUR G(2C) A(1,5)=-ONE A(2,5)=-ONE A(3,5)= ZERO A(4,5)= SIX A(5,5)=-SIX A(6,5)= ZERO G(4C) A(1,6)= ONE A(2,6)= ONE A(3,6)= ZERO A(4,6)=-SIX A(5,6)= ZERO A(6,6)= ZERO IF(ITOPT.EQ.0) GO TO 930 DO 920 J=1,6 RENOR=RENORM(LIST(J,1)) DO 920 I=1,6 920 A(I,J)=A(I,J)*RENOR CALL TRANSP(A,6,6) 930 CONTINUE IF(ITOPT.NE.0) CALL TRANSP(A,6,6) ...LOOP OVER G SETS IN LIST: DO 960 IT=1,IGTRAN M(1)=LIST(1,IT) M(2)=LIST(2,IT) M(3)=LIST(3,IT) M(4)=LIST(4,IT) M(5)=LIST(5,IT) M(6)=LIST(6,IT) ...TRANSFORM S AND DM: ...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0) IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,6,-1) IF(ITOPT.NE.0) GO TO 950 CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,6,0) CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,6,0) ...CHANGE THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED: 950 CONTINUE LORB(M(1))=51 LORB(M(2))=254 LORB(M(3))=255 LORB(M(4))=451 LORB(M(5))=454 LORB(M(6))=458 960 CONTINUE RENORMALIZATION, ITOPT=0 : 1000 CONTINUE ITRAN=IDTRAN+IFTRAN+IGTRAN IF(ITOPT.NE.0) RETURN IF(ITRAN.EQ.0) GO TO 1200 DO 1020 I=1,NBAS X=T(I,I) 1020 RENORM(I)=ONE/SQRT(X) DO 1040 I=1,NBAS DO 1040 J=1,NBAS RIJ=RENORM(I)*RENORM(J) T(I,J)=T(I,J)*RIJ 1040 DM(I,J)=DM(I,J)*RIJ RELABELLING OF NON-TRANSFORMED ORBITALS: 1200 CONTINUE DO 1230 I=1,NBAS IF(LORB(I).NE.0) GO TO 1230 LANG=LORBC(I) LORB(I)=LANG L=LANG/100 IDIF=LANG-L*100 IF(IDIF.GT.50) GO TO 1230 LORB(I)=LORB(I)+50 1230 CONTINUE RETURN ERROR MESSAGES: 1950 WRITE(LFNPR,1951) 1951 FORMAT(' Unequal numbers of d function components were', +' found in the input.',/,' These cannot be properly transformed-', +'-perhaps they were improperly labelled.') STOP 1960 WRITE(LFNPR,1961) 1961 FORMAT(' Unequal numbers of f function components were', +' found in the input.',/,' These cannot be properly transformed-', +'-perhaps they were improperly labelled.') STOP 1970 WRITE(LFNPR,1971) 1971 FORMAT(' Unequal numbers of g function components were', +' found in the input.',/,' These cannot be properly transformed-', +'-perhaps they were improperly labelled.') STOP END ***************************************************************************** SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) ******************************************************************** MAIN SUBROUTINE 'NAO' FOR NATURAL ATOMIC ORBITAL BASIS SET. INPUT REQUIRED: S = OVERLAP MATRIX ELEMENTS IN LOWER TRIANGLE (BELOW DIAGONAL) = DENSITY MATRIX ELEMENTS IN UPPER TRIANGLE (INCLUDING DIAG.) (INPUT AO'S MUST(!) BE NORMALIZED. ON RETURN, S IS THE FULL DENSITY MATRIX. OVERLAP MATRIX ELEMENTS ARE LOST.) LBL = LIST OF ATOMIC CENTERS; LBL(I) = N IF ORBITAL I IS ON CENTER N LORB = LIST OF ANGULAR MOMENTUM TYPE FOR EACH ORBITAL; LORB(I) = N IF ORBITAL I IS OF 'TYPE' N. N = ( 51,151,152,153) = (S,PX,PY,PZ) = (251,252,253,254,255) = (DXY,DXZ,DYZ,D(X2-Y2),D(3Z2-R2)) = (351-357 FOR THE 7 TYPES OF F ORBITALS) = (451-459 FOR THE 9 TYPES OF G ORBITALS) OUTPUT: T = TRANSFORMATION MATRIX FROM INPUT AO'S TO NAO'S (ROWS ARE LABELLED BY PRIMITIVE AO'S, COLUMNS BY NAO'S) NAOCTR = LIST OF ATOMIC CENTERS FOR NAO'S; NAOCTR(I) = N IF NAO # I IS ON CENTER #N. NAOL = LIST OF ANGULAR MOMENTUM TYPE FOR EACH NAO, SAME FORMAT AS "LORB" BEFORE RETURN: LSTOCC = LIST OF NATURAL MINIMAL BASIS ('OCCUPIED') ORBITALS; LSTOCC(I)=N (I=1,...,NOCC) MEANS THAT NAO #N BELONGS TO THE NMB SET. LSTEMT = LIST OF NATURAL RYDBERG BASIS ('EMPTY') ORBITALS; LSTEMT(I)=N (I=1,...,NEMT) MEANS THAT NAO #N BELONGS TO THE NRB SET. AFTER RETURN: LSTOCC(I) = 1 ONLY IF NAO #I BELONGS TO THE NMB SET. ******************************************************************** PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),OCC(NDIM),BLK(NDIM,NDIM), + SBLK(MXAOLM,MXAOLM),EVAL(NBAS),EVAL2(NBAS), + LISTAO(MXAOLM,9),C(NBLOCK),EVECT(MXAOLM,MXAOLM) CHARACTER*80 TITLE DATA ZERO,ONE/0.0D0,1.0D0/ DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/ SKIP T-NAO FORMATION IF IOINQR(IWPNAO).EQ.IREAD: IF(IOINQR(IWPNAO).EQ.IREAD) GO TO 200 ZERO TRANSFORMATION MATRIX T: DO 10 J = 1,NBAS LSTOCC(J) = 0 LSTEMT(J) = 0 DO 10 I = 1,NBAS 10 T(I,J) = ZERO NF COUNTS THE ACCUMULATED ORBITALS: NF = 0 NOCC COUNTS THE ACCUMULATED 'OCCUPIED' ORBITALS: NEMT COUNTS THE ACCUMULATED 'EMPTY' ORBITALS: NOCC = 0 NEMT = 0 BEGIN MAIN NAO LOOP OVER ATOMIC CENTERS: DO 140 ICNTR = 1,NATOMS LOOP OVER ANGULAR MOMENTUM BLOCKS (S,P,D,F,G). NL COUNTS THE NUMBER OF ORBITALS IN EACH "M" COMPONENT OF THE "L" BLOCK: DO 130 IL = 1,5 IF(NF.GT.NBAS) GO TO 130 L = IL - 1 M = 2*L + 1 SCAN ORBITAL LABELS TO GATHER 'LISTAO' OF ORBITALS BELONGING TO PROPER ATOM AND ANGULAR MOMENTUM SYMMETRY: DO 20 IM = 1,M LANG = 100*L + IM + 50 NL = 0 DO 20 I = 1,NBAS IF((LBL(I).NE.ICNTR).OR.(LORB(I).NE.LANG)) GO TO 20 NL = NL + 1 LISTAO(NL,IM) = I 20 CONTINUE IF(NL.EQ.0) GO TO 140 LOAD THIS LIST OF ORBITALS INTO BLK AND SBLK (DENSITY MATRIX AND OVERLAP ELEMENTS, RESP.), AND AVERAGE THE DENSITY MATRIX ELEMENTS OVER THE M COMPONENTS OF L FOR THE ATOM: CALL LOADAV(LISTAO,NL,M,S,NDIM,BLK,SBLK,MXAOLM) SOLVE THE GENERALIZED EIGENVALUE PROBLEM: CALL ATDIAG(NL,BLK,SBLK,EVAL,C) ORDER THE EIGENVECTORS BY OCCUPANCY EIGENVALUE: CALL RANK(EVAL,NL,NL,LARC) LOOP OVER THE 2*L+1 COMPONENTS TO STORE T-NAO DATA: DO 120 IM = 1,M PARTITION ORBITALS INTO 'OCCUPIED' AND 'EMPTY' SETS: CALL SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,ICNTR,L,NL,NF,NDIM) STORE THE ORDERED EIGENVECTORS IN T: DO 120 J = 1,NL JR = LARC(J) NF = NF + 1 OCC(NF) = EVAL(J) DO 110 I = 1,NL IAO = LISTAO(I,IM) IJR = I + NL*(JR-1) T(IAO,NF) = C(IJR) 110 CONTINUE MAKE UP NAO ORBITAL LABELS: NAOCTR(NF) = ICNTR NAOL(NF) = L*100 + IM + 50 120 CONTINUE 130 CONTINUE 140 CONTINUE 200 CONTINUE READ IN PRE-ORTHOGONAL T-NAO DATA: IF(IOINQR(IWPNAO).NE.IREAD) GO TO 300 CALL RDPPNA(T,OCC) RECOMPUTE AND SYMMETRY-AVERAGE WEIGHTS, REORGANIZE LSTOCC IF THE INPUT PNAOS ARE RPNAOS: IF(OCC(1).LT.ZERO) CALL NEWWTS(S,T,OCC) NOCC = 0 NEMT = 0 LANG = 0 ILBL = 1 NLANG = 0 DO 280 I = 1,NBAS IF(LSTOCC(I).GT.0) NOCC = NOCC + 1 IF((NAOCTR(I).NE.ILBL).OR.(NAOL(I).NE.LANG)) GO TO 240 NLANG = NLANG + 1 GO TO 250 240 IF(NLANG.GT.MXAOLM) MXAOLM = NLANG NLANG = 1 ILBL = NAOCTR(I) LANG = NAOL(I) 250 CONTINUE DO 260 J = 1,NBAS 260 IF(LSTOCC(J).EQ.I) GO TO 280 NEMT = NEMT + 1 LSTEMT(NEMT) = I 280 CONTINUE 300 CONTINUE WRITE PREORTHOGONAL T-NAO DATA TO LFNPPA: IF(IOINQR(IWPNAO).EQ.IWRIT) CALL WRPPNA(T,OCC,IWPNAO) SAVE T-PNAO FOR LATER USE IN COMPUTING THE NON-ORTHOGONAL OVERLAPS BETWEEN NAOS OR NBOS: CALL SVPNAO(T) IF(IOINQR(IWPNAO).EQ.IPRNT) THEN TITLE = 'PNAOs in the PAO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,-1,IWPNAO) END IF FINAL ORTHOGONALIZATION: DO 450 I = 1,NBAS DO 440 J = 1,I 440 S(J,I) = S(I,J) 450 S(I,I) = ONE CALL WORTH(S,T,BLK,LSTOCC,NDIM,NBAS,NOCC,OCC,EVAL,BLK) IF(NEMT.EQ.0) GO TO 700 CALL SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,BLK) PUT P-PAO IN UPPER TRIANGLE OF S (AND DIAGONAL): CALL FEPPAO(BLK) DO 460 J = 1,NBAS DO 460 I = 1,J 460 S(I,J) = BLK(I,J) CALL NEWRYD(T,S,BLK,C,SBLK,EVECT,OCC,EVAL,EVAL2,LISTAO, * JPRINT(11)) SELECT THE SIGNIFICANT RYDBERGS, PUT IN "LARC". PUT THE LIST OF THE REST OF THE RYDBERGS INTO "LISTAO", AND SET THE WEIGHTINGS OF THESE LOW OCCUPANCY ORBITALS TO ONE. THEN, DO A WEIGHTED ORTHOG. AMONG THE SIGNIFICANT RYDBERGS, SCHMIDT ORTHOG. THE LOW OCC. RYDS TO THESE, AND FINALLY DO A LOWDIN ORTHOG. AMONG THE LOW OCC. RYDS.: CALL RYDSEL(LSTEMT,NEMT,NSEL1,LARC,NSEL2,LISTAO,OCC) IF(NSEL1.EQ.0) GO TO 690 CALL WORTH(S,T,BLK,LARC,NDIM,NBAS,NSEL1,OCC,EVAL,BLK) IF(NSEL2.EQ.0) GO TO 700 690 CONTINUE IF(NSEL1.NE.0) * CALL SHMDT(T,S,NDIM,NBAS,NSEL1,LARC,NSEL2,LISTAO,BLK) CALL WORTH(S,T,BLK,LISTAO,NDIM,NBAS,NSEL2,OCC,EVAL,BLK) 700 CONTINUE CALL FEPPAO(S) CALL SIMTRS(S,T,OCC,NDIM,NBAS) CALL REDIAG(S,T,BLK,OCC,SBLK,C,LISTAO,JPRINT(11)) RETURN OCCUPIED LIST 'LSTOCC' OF 1'S OR 0'S: DO 820 I = 1,NBAS 820 LSTOCC(I) = 1 DO 840 I = 1,NEMT 840 LSTOCC(LSTEMT(I)) = 0 RETURN END ***************************************************************************** SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*80 TITLE LOGICAL FIRST,CORE,ALLZER LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO Perform the Natural Population Analysis PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBLBL/NLEW,NVAL,LBLS(10,MAXBAS,4) DIMENSION DM(NDIM,NDIM),SPNAO(NDIM,NDIM),BINDEX(NATOMS,NATOMS), * BINDT(NATOMS),OVPOP(NATOMS,NATOMS),F(NDIM,NDIM),ENAO(NDIM), * JPRIN(MAXBAS),ICORE(4),IVAL(4),NWARN(MAXATM),LABEC(20,2), * OCCEC(20),BMO(NATOMS,NATOMS) DIMENSION IANG(5),ANGL(25),LANG(25),CUBICF(7) DATA IRYD/'Ryd'/ DATA IANG/'s','p','d','f','g'/ DATA LANG/ 51,151,152,153,251,252,253,254,255, * 351,352,353,354,355,356,357, * 451,452,453,454,455,456,457,458,459/ DATA ANGL/4H ,4Hx ,4Hy ,4Hz ,4Hxy ,4Hxz ,4Hyz , * 4Hx2y2,4Hz2 ,4H(0) ,4H(C1),4H(S1),4H(C2),4H(S2),4H(C3), * 4H(S3),4H(0) ,4H(C1),4H(S1),4H(C2),4H(S2),4H(C3),4H(S3), * 4H(C4),4H(S4)/ DATA CUBICF/4H(D1),4H(D2),4H(D3),4H(B) ,4H(E1),4H(E2),4H(E3)/ DATA ZERO,TENTH,TWO/0.0D0,0.1D0,2.0D0/ TEST, TEST2, ALLOW, and ALLOW2 are numbers used in determining if the density matrix trace is close to being an integer. TEST2 (ALLOW2) must be slightly greater than twice TEST (ALLOW): DATA TEST,TEST2/1.0D-5,2.1D-5/ DATA ALLOW,ALLOW2/1.0D-3,2.1D-3/ DATA ICHCOR,ICHVAL,ICHRYD/'Cor','Val','Ryd'/ If the f functions are a cubic set, insert the proper labels: IF(IWCUBF.EQ.0) GOTO 20 DO 10 I = 1,7 II = I+9 10 ANGL(II) = CUBICF(I) 20 CONTINUE Update the NAO atom-atom valency matrix: DO 30 J = 1,NATOMS DO 30 I = 1,NATOMS OVPOP(I,J) = ZERO BMO(I,J) = ZERO 30 BINDEX(I,J) = ZERO DO 50 I = 1,NBAS IAT = NAOCTR(I) DO 40 J = 1,NBAS JAT = NAOCTR(J) IF(JAT.NE.IAT) THEN SIJ = SPNAO(I,J) DMIJ = DM(I,J) DMIJ2 = DMIJ*DMIJ DMSIJ = DMIJ*SIJ BINDEX(JAT,IAT) = BINDEX(JAT,IAT) + DMIJ2 BMO(JAT,IAT) = BMO(JAT,IAT) + DMIJ OVPOP(JAT,IAT) = OVPOP(JAT,IAT) + DMSIJ END IF 40 CONTINUE 50 CONTINUE Determine the NAO orbital energies if a Fock matrix exists. Use SPNAO to store TNAO: CALL FETNAO(SPNAO) IFOCK = IWFOCK IF(OPEN.AND..NOT.(ALPHA.OR.BETA)) IFOCK = 0 IF(IFOCK.EQ.1) THEN CALL FEFAO(F,IWFOCK) IF(IWFOCK.NE.0) THEN DO 80 I = 1,NBAS ENRG = ZERO DO 70 J = 1,NBAS DO 60 K = 1,NBAS ENRG = ENRG + SPNAO(J,I)*F(J,K)*SPNAO(K,I) 60 CONTINUE 70 CONTINUE ENAO(I) = ENRG 80 CONTINUE END IF END IF Label NAO's as either 'Cor', 'Val', or 'Ryd': DO 200 I = 1,NBAS LTYP(I) = IRYD 200 CONTINUE IECP = 0 DO 300 NCTR = 1,NATOMS CALL CORTBL(NCTR,ICORE,IECP) CALL VALTBL(NCTR,IVAL) Loop over s,p,d,f orbitals: DO 290 L = 0,3 ITYP = IANG(L+1) LNUM = 2*L + 1 IF(ICORE(L+1).LE.0) GOTO 240 Label core orbitals: DO 230 M = 1,ICORE(L+1) DO 220 LA = 1,LNUM MORB = 0 OCC = -1.0 DO 210 N = 1,NBAS LM = NAOL(N) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(N),50) IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND. + DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND. + LA.EQ.NA) THEN MORB = N OCC = DM(N,N) END IF 210 CONTINUE IF(MORB.EQ.0) THEN WRITE(LFNPR,2500) ITYP,NAMEAT(IATNO(NCTR)),NCTR, + (ICORE(I),I=1,4),M,LA STOP END IF LTYP(MORB) = ICHCOR 220 CONTINUE 230 CONTINUE 240 CONTINUE IF(IVAL(L+1).LE.0) GOTO 280 Label valence orbitals: DO 270 M = 1,IVAL(L+1) DO 260 LA = 1,LNUM MORB = 0 OCC = -1.0 DO 250 N = 1,NBAS LM = NAOL(N) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(N),50) IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND. + DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND. + LA.EQ.NA) THEN MORB = N OCC = DM(N,N) END IF 250 CONTINUE IF(MORB.EQ.0) THEN WRITE(LFNPR,2600) ITYP,NAMEAT(IATNO(NCTR)),NCTR, + (IVAL(I),I=1,4),M,LA STOP END IF LTYP(MORB) = ICHVAL 260 CONTINUE 270 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE Assign `principal' quantum numbers using the NAO occupancies: DO 390 I = 1,NBAS IPRIN(I) = 0 390 CONTINUE DO 450 NCTR = 1,NATOMS IECP = 1 CALL CORTBL(NCTR,IVAL,IECP) IECP = 0 CALL CORTBL(NCTR,ICORE,IECP) DO 440 L = 0,4 ITYP = IANG(L+1) MMAX = 2*L + 1 DO 430 M = 1,MMAX IF(L.EQ.4) THEN N = 3 ELSE N = IVAL(L+1) - ICORE(L+1) + L END IF 400 CONTINUE MORB = 0 OCC = -1.0 DO 410 J = 1,NBAS LM = NAOL(J) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(J),50) IF(NAOCTR(J).EQ.NCTR.AND.IL.EQ.ITYP.AND. + DM(J,J).GT.OCC.AND.IPRIN(J).EQ.0.AND. + M.EQ.NA) THEN MORB = J OCC = DM(J,J) END IF 410 CONTINUE IF(MORB.EQ.0) GOTO 420 N = N + 1 IPRIN(MORB) = N GOTO 400 420 CONTINUE 430 CONTINUE 440 CONTINUE 450 CONTINUE Assign `principal' quantum numbers using the NAO Fock matrix elements: IF(IFOCK.EQ.0) GOTO 580 DO 490 I = 1,NBAS JPRIN(I) = 0 490 CONTINUE DO 550 NCTR = 1,NATOMS IECP = 1 CALL CORTBL(NCTR,IVAL,IECP) IECP = 0 CALL CORTBL(NCTR,ICORE,IECP) DO 540 L = 0,4 ITYP = IANG(L+1) MMAX = 2*L + 1 DO 530 M = 1,MMAX IF(L.EQ.4) THEN N = 3 ELSE N = IVAL(L+1) - ICORE(L+1) + L END IF 500 CONTINUE MORB = 0 ENRG = 1.0D6 DO 510 J = 1,NBAS LM = NAOL(J) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(J),50) IF(NAOCTR(J).EQ.NCTR.AND.IL.EQ.ITYP.AND. + ENAO(J).LT.ENRG.AND.JPRIN(J).EQ.0.AND. + M.EQ.NA) THEN MORB = J ENRG = ENAO(J) END IF 510 CONTINUE IF(MORB.EQ.0) GOTO 520 N = N + 1 JPRIN(MORB) = N GOTO 500 520 CONTINUE 530 CONTINUE 540 CONTINUE 550 CONTINUE 580 CONTINUE Count the total number of electrons: TOT = ZERO DO 600 INAO = 1,NBAS TOT = TOT + DM(INAO,INAO) 600 CONTINUE NEL = TOT + TENTH Store NEL for use by the output routines: NLEW = NEL Check to see if the total number of electrons found is an integer: IF(TOT.GE.ZERO) THEN SUMTT = TOT + TEST SUMTI = AINT(SUMTT) SUMTF = SUMTT - SUMTI IF(SUMTF.GT.TEST2) THEN SUMTT = TOT + ALLOW SUMTI = AINT(SUMTT) SUMTF = SUMTT - SUMTI IF(SUMTF.GT.ALLOW2) THEN WRITE(LFNPR,955) JPRINT(4) = -1 ELSE WRITE(LFNPR,956) END IF END IF ELSE WRITE(LFNPR,955) JPRINT(4) = -1 END IF Write out Natural Population analysis: IF(JPRINT(4).NE.0) THEN IF(IFOCK.EQ.1) THEN WRITE(LFNPR,900) ELSE WRITE(LFNPR,910) END IF JCTR = 1 DO 700 I = 1,NBAS NCTR = NAOCTR(I) IF(NCTR.NE.JCTR) THEN WRITE(LFNPR,*) JCTR = NCTR END IF IAT = IATNO(NCTR) NAM = NAMEAT(IAT) LM = NAOL(I) L = LM/100 IL = IANG(L+1) DO 680 ILM = 1,25 IF(LM.EQ.LANG(ILM)) GOTO 690 680 CONTINUE 690 CONTINUE OCC = DM(I,I) IF(OCC.LT.ZERO) OCC = ZERO IF(IFOCK.EQ.1) THEN WRITE(LFNPR,920) I,NAM,NCTR,IL,ANGL(ILM),LTYP(I), + JPRIN(I),IL,OCC,ENAO(I) ELSE WRITE(LFNPR,920) I,NAM,NCTR,IL,ANGL(ILM),LTYP(I), + IPRIN(I),IL,OCC END IF 700 CONTINUE Add note about effective core potentials if used: IECP = 0 DO 710 I = 1,NATOMS IECP = IECP + IATNO(I) - IZNUC(I) 710 CONTINUE IF(IPSEUD.NE.0) THEN IF(ALPHA.OR.BETA) IECP = IECP/2 WRITE(LFNPR,930) IECP END IF Write out warnings for low occupancy core orbitals: CRTHRS = CRTSET IF(ALPHA.OR.BETA) CRTHRS = CRTHRS - 1.0 DO 715 N = 1,NATOMS NWARN(N) = 0 715 CONTINUE DO 720 I = 1,NBAS ICTR = NAOCTR(I) IF(LTYP(I).EQ.ICHCOR.AND.DM(I,I).LT.CRTHRS) + NWARN(ICTR) = NWARN(ICTR) + 1 720 CONTINUE FIRST = .TRUE. DO 725 N = 1,NATOMS NAM = NAMEAT(IATNO(N)) IF(NWARN(N).EQ.1) THEN IF(FIRST) THEN WRITE(LFNPR,931) CRTHRS,NAM,N FIRST = .FALSE. ELSE WRITE(LFNPR,932) CRTHRS,NAM,N END IF ELSE IF(NWARN(N).GT.1) THEN IF(FIRST) THEN WRITE(LFNPR,933) NWARN(N),CRTHRS,NAM,N FIRST = .FALSE. ELSE WRITE(LFNPR,934) NWARN(N),CRTHRS,NAM,N END IF END IF 725 CONTINUE Write out warnings for population inversions: IF(IFOCK.EQ.1) THEN DO 730 N = 1,NATOMS NWARN(N) = 0 730 CONTINUE DO 735 I = 1,NBAS ICTR = NAOCTR(I) IF(IPRIN(I).NE.JPRIN(I)) NWARN(ICTR) = 1 IPRIN(I) = JPRIN(I) 735 CONTINUE FIRST = .TRUE. DO 738 N = 1,NATOMS NAM = NAMEAT(IATNO(N)) IF(NWARN(N).GT.0) THEN IF(FIRST) THEN WRITE(LFNPR,936) NAM,N FIRST = .FALSE. ELSE WRITE(LFNPR,937) NAM,N END IF END IF 738 CONTINUE END IF Summarize the Natural Population Analysis: WRITE(LFNPR,939) SUMAC = ZERO SUMAV = ZERO SUMAR = ZERO NOMAC = 0 DO 750 I = 1,NATOMS SUMC = ZERO SUMV = ZERO SUMR = ZERO NAM = NAMEAT(IATNO(I)) DO 740 J = 1,NBAS IF(NAOCTR(J).EQ.I) THEN OCC = DM(J,J) IF(OCC.LT.ZERO) OCC = ZERO IF(LTYP(J).EQ.ICHCOR) SUMC = SUMC + OCC IF(LTYP(J).EQ.ICHVAL) SUMV = SUMV + OCC IF(LTYP(J).EQ.ICHRYD) SUMR = SUMR + OCC IF(LTYP(J).EQ.ICHCOR) NOMAC = NOMAC + 2 END IF 740 CONTINUE TOT = SUMC + SUMV + SUMR IF(ALPHA.OR.BETA) THEN CHG = IZNUC(I)/2.0 - TOT ELSE CHG = IZNUC(I) - TOT END IF ECP = FLOAT(IATNO(I) - IZNUC(I)) IF(ALPHA.OR.BETA) ECP = ECP/TWO WRITE(LFNPR,940) NAM,I,CHG,SUMC+ECP,SUMV,SUMR,TOT+ECP SUMAC = SUMAC + SUMC SUMAV = SUMAV + SUMV SUMAR = SUMAR + SUMR 750 CONTINUE TOT = SUMAC + SUMAV + SUMAR CHG = -1.0 * TOT IF(ALPHA.OR.BETA) THEN NOMAC = NOMAC/2 DO 760 I = 1,NATOMS CHG = CHG + IZNUC(I)/2.0 760 CONTINUE ELSE DO 770 I = 1,NATOMS CHG = CHG + IZNUC(I) 770 CONTINUE END IF WRITE(LFNPR,950) CHG,SUMAC+FLOAT(IECP),SUMAV,SUMAR, + TOT+FLOAT(IECP) Write out NMB and NRB populations and percentage occupancies: WRITE(LFNPR,960) NOMA = NEL NOMAV = NOMA - NOMAC SUMA = SUMAC + SUMAV IF(IPSEUD.NE.0) THEN ECP = IECP SUMA = SUMA + ECP NOMA = NOMA + IECP WRITE(LFNPR,970) ECP END IF IF(NOMAC.NE.0) THEN PCENT = SUMAC/NOMAC * 100.0 WRITE(LFNPR,980) SUMAC,PCENT,NOMAC ELSE IF(SUMAC.NE.ZERO) THEN PCENT = ZERO WRITE(LFNPR,980) SUMAC,PCENT,NOMAC END IF IF(NOMAV.NE.0) THEN PCENT = SUMAV/NOMAV * 100.0 WRITE(LFNPR,990) SUMAV,PCENT,NOMAV ELSE IF(SUMAV.NE.ZERO) THEN PCENT = ZERO WRITE(LFNPR,990) SUMAV,PCENT,NOMAV END IF IF(NOMA.NE.0) THEN PCENT = SUMA/NOMA * 100.0 ELSE PCENT = ZERO END IF WRITE(LFNPR,1000) SUMA,PCENT,NOMA IF(NOMA.NE.0) THEN PCENT = SUMAR/NOMA * 100.0 WRITE(LFNPR,1010) SUMAR,PCENT,NOMA ELSE IF(SUMAR.NE.ZERO) THEN PCENT = 0 WRITE(LFNPR,1010) SUMAR,PCENT,NOMA END IF Write out Natural Electron Configuration: WRITE(LFNPR,1040) DO 899 NCTR = 1,NATOMS ICT = 0 IECP = 1 CALL CORTBL(NCTR,ICORE,IECP) DO 870 NPL = 1,8 DO 860 N = 1,NPL L = NPL - N IF(L.GE.0.AND.L.LT.N) THEN IF(N.GT.ICORE(L+1)+L) THEN ICT = ICT + 1 LABEC(ICT,1) = N LABEC(ICT,2) = IANG(L+1) OCCEC(ICT) = ZERO END IF END IF 860 CONTINUE 870 CONTINUE DO 890 I = 1,NBAS ICTR = NAOCTR(I) IF(ICTR.EQ.NCTR.AND.LTYP(I).NE.ICHCOR) THEN NORB = NAOL(I)/100 IL = IANG(NORB+1) DO 880 J = 1,ICT IF(IPRIN(I).EQ.LABEC(J,1).AND. + IL.EQ.LABEC(J,2)) THEN OCCEC(J) = OCCEC(J) + DM(I,I) GOTO 890 END IF 880 CONTINUE END IF 890 CONTINUE IF(LABEC(1,1).NE.1) THEN CORE = .TRUE. ELSE CORE = .FALSE. END IF THOLD = 5.0D-3 JMAX = ICT Remove low occupancy subshells: DO 893 JCT = 1,ICT 891 CONTINUE IF(OCCEC(JCT).LT.THOLD) THEN ALLZER = .TRUE. DO 892 KCT = JCT,ICT-1 LABEC(KCT,1) = LABEC(KCT+1,1) LABEC(KCT,2) = LABEC(KCT+1,2) OCCEC(KCT) = OCCEC(KCT+1) IF(OCCEC(KCT).GE.THOLD) ALLZER = .FALSE. 892 CONTINUE OCCEC(ICT) = ZERO IF(ALLZER) THEN JMAX = JCT - 1 GOTO 895 END IF GOTO 891 END IF 893 CONTINUE 895 CONTINUE NAM = NAMEAT(IATNO(NCTR)) IF(JMAX.EQ.0) THEN IF(.NOT.CORE) THEN WRITE(LFNPR,1050) NAM,NCTR ELSE WRITE(LFNPR,1060) NAM,NCTR END IF ELSE IF(.NOT.CORE) THEN WRITE(LFNPR,1050) NAM,NCTR,((LABEC(K,J),J=1,2),OCCEC(K), + K=1,JMAX) ELSE WRITE(LFNPR,1060) NAM,NCTR,((LABEC(K,J),J=1,2),OCCEC(K), + K=1,JMAX) END IF END IF 899 CONTINUE END IF IF(JPRINT(4).LT.0) STOP Write out Wiberg Bond Index Matrix if requested: IF(JPRINT(12).NE.0) THEN TITLE = 'Wiberg bond index matrix in the NAO basis:' CALL AOUT(BINDEX,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS) DO 3010 IAT = 1,NATOMS BINDT(IAT) = ZERO DO 3000 JAT = 1,NATOMS IF(IAT.EQ.JAT) GOTO 3000 BINDT(IAT) = BINDT(IAT) + BINDEX(JAT,IAT) 3000 CONTINUE 3010 CONTINUE TITLE = 'Wiberg bond index, Totals by atom:' CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1) Write out overlap-weighted bond populations: TITLE = 'Atom-atom overlap-weighted NAO bond order:' CALL AOUT(OVPOP,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS) DO 3030 IAT = 1,NATOMS BINDT(IAT) = ZERO DO 3020 JAT = 1,NATOMS IF(IAT.EQ.JAT) GOTO 3020 BINDT(IAT) = BINDT(IAT) + OVPOP(JAT,IAT) 3020 CONTINUE 3030 CONTINUE TITLE(1:43) = 'Atom-atom overlap-weighted NAO bond order, ' TITLE(44:58) = 'Totals by atom:' CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1) Write out MO bond orders: TITLE = 'MO bond order:' CALL AOUT(BMO,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS) DO 3050 IAT = 1,NATOMS BINDT(IAT) = ZERO DO 3040 JAT = 1,NATOMS IF(IAT.EQ.JAT) GOTO 3040 BINDT(IAT) = BINDT(IAT) + BMO(JAT,IAT) 3040 CONTINUE 3050 CONTINUE TITLE = 'MO atomic valencies:' CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1) END IF Save NAO info in COMMON/NBNAO/: DO 888 I = 1,NBAS NAOC(I) = NAOCTR(I) NAOA(I) = NAOL(I) 888 CONTINUE RETURN 900 FORMAT(//,1X, +'NATURAL POPULATIONS: Natural atomic orbital occupancies ',/,1X, +' ',/,1X, +' NAO Atom # lang Type(AO) Occupancy Energy ',/,1X, +'---------------------------------------------------------') 910 FORMAT(//,1X, +'NATURAL POPULATIONS: Natural atomic orbital occupancies ',/,1X, +' ',/,1X, +' NAO Atom # lang Type(AO) Occupancy ',/,1X, +'------------------------------------------- ') 920 FORMAT(1X,I3,3X,A2,I3,2X,A1,A4,2X,A3,'(',I2,A1,')',4X, + F8.5,4X,F10.5) 930 FORMAT(/,1X, +'[',I3,' electrons found in the effective core potential]') 931 FORMAT(/,1X, +'WARNING: 1 low occupancy (<',F6.4,'e) core orbital found ', +'on ',A2,I2) 932 FORMAT(1X, +' 1 low occupancy (<',F6.4,'e) core orbital found ', +'on ',A2,I2) 933 FORMAT(/,1X, +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals found', +' on ',A2,I2) 934 FORMAT(1X, +' ',I3,' low occupancy (<',F6.4,'e) core orbitals found', +' on ',A2,I2) 936 FORMAT(/,1X, +'WARNING: Population inversion found on atom ',A2,I2) 937 FORMAT(1X, +' Population inversion found on atom ',A2,I2) 939 FORMAT(//,1X, +'Summary of Natural Population Analysis: ',/,1X, +' ',/,1X, +' Natural Population ',/,1X, +' Natural ',47('-'),/,1X,3X,'Atom #',5X, +'Charge',8X,'Core',6X,'Valence',4X,'Rydberg',6X,'Total',/,1X, +71('-')) 940 FORMAT(1X,4X,A2,I3,2X,F9.5,4X,F9.5,3X,F9.5,2X,F9.5,3X,F9.5) 950 FORMAT(1X,71('='),/,1X,' * Total *',F9.5,4X,F9.5,3X,F9.5,2X, + F9.5,3X,F9.5) 955 FORMAT(/1X, +'Number of electrons is not an integer! Please check your ', +'data.',/) 956 FORMAT(/1X, +'WARNING: Number of electrons is not within 1.0D-5 of an', +' integer.'/) 960 FORMAT(/,1X, +' Natural Population ',/,1X, +'--------------------------------------------------------') 970 FORMAT(1X,' Effective Core ',F10.5) 980 FORMAT(1X,' Core ',F10.5,' (',F8.4, +'% of ',I3,')') 990 FORMAT(1X,' Valence ',F10.5,' (',F8.4, +'% of ',I3,')') 1000 FORMAT(1X,' Natural Minimal Basis ',F10.5,' (',F8.4, +'% of ',I3,')') 1010 FORMAT(1X,' Natural Rydberg Basis ',F10.5,' (',F8.4, +'% of ',I3,')',/,1X, +'--------------------------------------------------------') 1040 FORMAT(/1X, +' Atom # Natural Electron Configuration',/,1X, + 76('-')) 1050 FORMAT(1X,4X,A2,I3,6X,6X,(13(I1,A1,'(',F5.2,')'))) 1060 FORMAT(1X,4X,A2,I3,6X,'[core]',(13(I1,A1,'(',F5.2,')'))) 2500 FORMAT(/1X,'Subroutine NAOANL could not find a ',A1,'-type ', + 'core orbital on atom ',A2,I2,'.',/,1X,'ICORE :',4I3, + ' M :',I3,' LA :',I3) 2600 FORMAT(/1X,'Subroutine NAOANL could not find a ',A1,'-type ', + 'valence orbital on atom ',A2,I2,'.',/,1X,'IVAL :',4I3, + ' M :',I3,' LA :',I3) END ***************************************************************************** SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*80 TITLE PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),TMO(NDIM,NDIM),C(NDIM,NDIM), + SCR(NDIM*(NDIM+5)) DIMENSION BASIS(4) DATA BASIS/' NAO',' NHO',' NBO','NLMO'/ DATA ZERO/0.0D0/ Input: T -- transformation from AO basis to currect basis INDEX -- current basis = 2,3,4,5 (NAO,NHO,NBO,NLMO) IFLG -- number of columns of TMO to print or external LFN to write to Fetch the AO to MO transformation matrix: CALL FEAOMO(C,IT) IF(IT.EQ.0) RETURN Find the MO transformation matrix: ZERTOL = 1.0E-8 EPS = 1.0E-8 MAXIT = 10 LFN0 = 0 CALL LINEQ(T,TMO,C,SCR,NBAS,NBAS,NDIM,NDIM,ZERTOL,EPS,MAXIT, + LFN0,IERR) IF(IERR.NE.0) THEN WRITE(LFNPR,910) BASIS(INDEX-1) IF(IERR.EQ.1) WRITE(LFNPR,920) BASIS(INDEX-1) STOP END IF Make sure the largest coefficient in each column is positive: DO 30 KCOL = 1,NBAS TMAX = ZERO DO 10 JROW = 1,NBAS IF(ABS(TMO(JROW,KCOL)).GT.ABS(TMAX)) TMAX = TMO(JROW,KCOL) 10 CONTINUE IF(TMAX.LT.ZERO) THEN DO 20 JROW = 1,NBAS TMO(JROW,KCOL) = -TMO(JROW,KCOL) 20 CONTINUE END IF 30 CONTINUE Write or print the MO transformation matrix: IF(INDEX.EQ.2) TITLE = 'MOs in the NAO basis:' IF(INDEX.EQ.3) TITLE = 'MOs in the NHO basis:' IF(INDEX.EQ.4) TITLE = 'MOs in the NBO basis:' IF(INDEX.EQ.5) TITLE = 'MOs in the NLMO basis:' CALL AOUT(TMO,NDIM,NBAS,NBAS,TITLE,INDEX,IFLG) RETURN 910 FORMAT(/1X,'Error calculating the ',A4,' to MO transformation') 920 FORMAT(1X,'The AO to ',A4,' transformation is not invertible') END **************************************************************************** ROUTINES CALLED BY SR NAO: SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM) SUBROUTINE ATDIAG(N,A,B,EVAL,C) SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM) SUBROUTINE NEWWTS(S,T,WT) SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK) SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK) SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2, + LIST,IRPNAO) SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2, + IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO) SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT) SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO) SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,IRPNAO) ***************************************************************************** SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION S(NDIM,NDIM),LISTAO(MXAOLM,9),A(NL,NL),B(NL,NL) DATA ONE,ZERO/1.0D0,0.0D0/ AVERAGE THE AO DENSITY MATRIX ELEMENTS OVER THE M=2*L+1 COMPONENTS OF L FOR A PARTICULAR ATOM. LOAD DENSITY MATRIX ELEMENTS (UPPER TRIANGLE OF S, INCL. DIAGONAL) INTO A, OVERLAP MATRIX ELEMENTS (LOWER TRIANGLE OF S) INTO B, FOR ORBITALS OF 'LIST' DO 30 J=1,NL DO 20 I=1,J FIND AVERAGE DM ELEMENT OVER THE VALUES OF IM: SUM=ZERO DO 10 IM=1,M IAO=LISTAO(I,IM) JAO=LISTAO(J,IM) 10 SUM=SUM+S(IAO,JAO) AVE=SUM/M DENSITY MATRIX ELEMENTS INTO A: A(I,J)=AVE A(J,I)=AVE OVERLAP MATRIX ELEMENTS INTO B: B(I,J)=S(JAO,IAO) 20 B(J,I)=B(I,J) 30 B(J,J)=ONE RETURN END ***************************************************************************** SUBROUTINE ATDIAG(N,A,B,EVAL,C) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SOLVE GENERALIZED EIGENVALUE PROBLEM (A-EVAL*B)*C = 0. USE JACOBI TO DIAGONALIZE B**(-1/2)*A*B**(-1/2); A AND B ARE DESTROYED. DIMENSION A(N,N),B(N,N),EVAL(N),C(N,N) DATA ZERO,ONE/0.0D0,1.0D0/ FIRST FORM B**(-1/2) AND STORE IT IN B: CALL JACOBI(N,B,EVAL,C,N,N,0) DO 10 I=1,N 10 EVAL(I)=ONE/SQRT(EVAL(I)) DO 30 I=1,N DO 30 J=1,I TEMP=ZERO DO 20 K=1,N 20 TEMP=TEMP+EVAL(K)*C(I,K)*C(J,K) B(I,J)=TEMP 30 B(J,I)=TEMP NOW SIMILARITY TRANSFORM A WITH B: CALL SIMTRS(A,B,EVAL,N,N) DIAGONALIZE A: CALL JACOBI(N,A,EVAL,C,N,N,1) MULTIPLY B*C TO GET EIGENVECTORS FOR ORIGINAL PROBLEM, STORE IN A: DO 50 I=1,N DO 50 J=1,N TEMP=ZERO DO 40 K=1,N 40 TEMP=TEMP+B(I,K)*C(K,J) 50 A(I,J)=TEMP MOVE FINAL EIGENVECTORS TO C: CALL COPY(A,C,N,N,N) RETURN END ***************************************************************************** SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM) ***************************************************************************** Select the set of natural minimal basis (NMB) orbitals for a particular atom and angular symmetry type: (up to atomic number 105) ------------------------------------------------------------------------------ IMPLICIT REAL*8 (A-H,O-Z) DIMENSION LSTOCC(NDIM),LSTEMT(NDIM) DIMENSION ICORE(4),IVAL(4) If g orbitals or orbitals of even higher angular symmetry are selected, there are none in the NMB: IF(L.GE.4) GOTO 100 Find core and valence orbitals for this atom: IECP = 0 CALL CORTBL(IAT,ICORE,IECP) CALL VALTBL(IAT,IVAL) Determine the number of shells with angular symmetry L in the NMB. If there are a negative number of core orbitals, ignore them: NSHELL = MAX0(ICORE(L+1),0) + IVAL(L+1) IF(NSHELL.EQ.0) GOTO 100 Select sets of occupied and empty NAO's: DO 10 J = 1,NSHELL NOCC = NOCC + 1 LSTOCC(NOCC) = NF + J 10 CONTINUE LEFT = NL - NSHELL IF(LEFT.EQ.0) RETURN DO 20 J = 1,LEFT NEMT = NEMT + 1 LSTEMT(NEMT) = NF + NSHELL + J 20 CONTINUE RETURN No NMB `L'-type orbitals found for this atom: 100 CONTINUE DO 110 J = 1,NL NEMT = NEMT + 1 LSTEMT(NEMT) = NF + J 110 CONTINUE RETURN END ***************************************************************************** SUBROUTINE NEWWTS(S,T,WT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),WT(NDIM) CHARACTER*80 TITLE DATA ZERO/0.0D0/ RECOMPUTE OCCUPANCY WEIGHTS NOCC=0 DO 20 I=1,NBAS SUM=ZERO DO 10 J=1,NBAS DO 10 K=1,NBAS SJK=S(J,K) IF(J.GT.K) SJK=S(K,J) 10 SUM=SUM+T(J,I)*SJK*T(K,I) WT(I)=SUM REFORMAT LIST LSTOCC: IF(LSTOCC(I).EQ.0) GO TO 20 NOCC=NOCC+1 LSTOCC(NOCC)=I 20 CONTINUE NSTART=NOCC+1 DO 40 I=NSTART,NDIM 40 LSTOCC(I)=0 SYMMETRY-AVERAGE WEIGHTS: NL=1 IORB=0 100 IORB=IORB+NL IF(IORB.GT.NBAS) GO TO 600 NL=1 ILBL=NAOCTR(IORB) IL=NAOL(IORB)/100 NM=IL*2+1 IMAX=NBAS-IORB DO 130 IADD=1,IMAX JORB=IORB+IADD JORBL=NAOL(JORB)/100 IF(NAOCTR(JORB).NE.ILBL.OR.JORBL.NE.IL) GO TO 140 130 NL=NL+1 140 NC=NL/NM DO 500 I=1,NC SUM=ZERO DO 300 M=1,NM INAO=IORB+(I-1)+(M-1)*NC 300 SUM=SUM+WT(INAO) AV=SUM/NM DO 400 M=1,NM INAO=IORB+(I-1)+(M-1)*NC 400 WT(INAO)=AV 500 CONTINUE GO TO 100 600 CONTINUE TITLE = 'New symmetry-averaged occupancy weights:' CALL AOUT(WT,NBAS,NBAS,1,TITLE,-1,1) RETURN END ***************************************************************************** SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) ****************************************************************** WORTH: OCCUPANCY WEIGHTED ORTHOGONALIZATION SUBROUTINE S: FULL OVERLAP MATRIX (PURE AO BASIS) (NOTE: UPPER TRIANGLE USED FOR SCRATCH, BUT RESTORED AGAIN) T: PURE AO TO PRE-NAO TRANSFORMATION LIST: LIST OF ORBITALS TO BE ORTHOGONALIZED N: NUMBER OF ORBITALS IN LIST OCC: LIST OF SYMMETRY AVERAGED OCCUPANCY WEIGHTINGS NOTE: BLK AND BIGBLK SHARE THE SAME STORAGE BUT ARE DIMENSIONED DIFFERENTLY. ****************************************************************** DIMENSION S(NDIM,NDIM),T(NDIM,NDIM),BLK(N,N) DIMENSION OCC(NDIM),LIST(NDIM),EVAL(NDIM),BIGBLK(NDIM,NDIM) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA ZERO,ONE/0.0D0,1.0D0/ DATA NTIME/0/ IMPORTANT CONSTANTS: WTTHR ALL WEIGHTING FACTORS SMALLER THAN WTTHR ARE SET TO THE VALUE OF WTTHR. DIAGTH THRESHOLD FOR MATRIX DIAGONALIZATION USED IN SUBROUTINE JACOBI. IN JACOBI, THIS CONSTANT IS CALLED "DONETH". DANGER CRITERION FOR DECIDING THAT THE JOB SHOULD BE ABORTED DUE TO NUMERICAL PROBLEMS CAUSED BY NEAR LINEAR DEPENDENCIES IN THE BASIS SET. ALL EIGENVALUES OF THE WEIGHTED OVERLAP MATRIX MUST BE GREATER THAN DIAGTH*DANGER. DATA WTTHR,DIAGTH,DANGER/1.0D-3,1.0D-12,1.0D3/ NTIME=NTIME+1 MULTIPLY THE WEIGHT BY A CONSTANT SO THAT THE MAXIMUM WEIGHT IS ONE, AND SET ANY RESULTING WEIGHT THAT IS LESS THAN WTTHR TO THE VALUE OF WTTHR: WTMAX=ZERO DO 10 I=1,N IP=LIST(I) IF(OCC(IP).GT.WTMAX) WTMAX=OCC(IP) 10 CONTINUE DO 20 I=1,N IP=LIST(I) EVAL(IP)=OCC(IP)/WTMAX IF(EVAL(IP).LT.WTTHR) EVAL(IP)=WTTHR 20 CONTINUE FORM THE WEIGHTED PRE-NAO VECTORS: DO 30 J=1,N JP=LIST(J) DO 30 I=1,NBAS 30 T(I,JP)=T(I,JP)*EVAL(JP) FORM THE WEIGHTED OVERLAP MATRIX OF THE VECTORS IN THE UPPER TRIANGLE OF S: DO 70 I=1,N IP=LIST(I) DO 70 J=1,NBAS SIJ=ZERO DO 40 K=1,NBAS TKI=T(K,IP) IF(TKI.EQ.ZERO) GO TO 40 SIJ=SIJ+TKI*S(K,J) 40 CONTINUE 70 BIGBLK(J,I)=SIJ DO 100 I=1,N DO 100 J=1,I JP=LIST(J) SIJ=ZERO DO 90 K=1,NBAS TKJ=T(K,JP) IF(TKJ.EQ.ZERO) GO TO 90 SIJ=SIJ+BIGBLK(K,I)*TKJ 90 CONTINUE 100 S(J,I)=SIJ DIAGONALIZE S-TILDE (THE WEIGHTED OVERLAP MATRIX): CALL JACOBI(N,S,EVAL,BLK,NDIM,N,0) FORM THE INVERSE SQRT OF THE OVERLAP MATRIX OF THESE WEIGHTED VECTORS: SMLEST=ONE TOOSML=DIAGTH*DANGER DO 150 I=1,N EIGENV=EVAL(I) IF(EIGENV.LT.TOOSML) GO TO 900 EVAL(I)=ONE/SQRT(EIGENV) IF(EIGENV.LT.SMLEST) SMLEST=EIGENV 150 CONTINUE DO 170 I=1,N DO 170 J=1,I SIJ=ZERO DO 160 K=1,N 160 SIJ=SIJ+EVAL(K)*BLK(I,K)*BLK(J,K) 170 S(J,I)=SIJ THE UPPER TRIANGLE OF S (INCLUDING THE DIAGONAL) NOW CONTAINS THE -0.5 POWER OF THE WEIGHTED OVERLAP MATRIX, AND IS THE WEIGHTED ORTHOG. TRANSFORM THAT WE WANT. NOW, FORM THE TOTAL TRANSFORMATION: DO 300 I=1,NBAS DO 260 J=1,N EVAL(J)=ZERO DO 220 K=1,J KP=LIST(K) TIK=T(I,KP) IF(TIK.EQ.ZERO) GO TO 220 EVAL(J)=EVAL(J)+TIK*S(K,J) 220 CONTINUE JP1=J+1 DO 240 K=JP1,N KP=LIST(K) TIK=T(I,KP) IF(TIK.EQ.ZERO) GO TO 240 EVAL(J)=EVAL(J)+TIK*S(J,K) 240 CONTINUE 260 CONTINUE DO 280 J=1,N JP=LIST(J) 280 T(I,JP)=EVAL(J) 300 CONTINUE RESTORE FULL OVERLAP MATRIX S: DO 400 I=1,NBAS IM1=I-1 DO 380 J=1,IM1 380 S(J,I)=S(I,J) 400 S(I,I)=ONE RETURN 900 WRITE(LFNPR,1000) EIGENV,TOOSML STOP 1000 FORMAT(//1X,'An eigenvalue of the weighted PRE-NAO overlap', +' matrix of ',F10.5,' has been',/,1X,'found, which is lower than', +' the allowed threshold of ',F10.5,'. This is',/,1X,'probably', +' caused by either an error in the data given to the analysis', +' program',/,1X,'or by numerical problems caused by near linear', +' dependencies among the basis',/,1X,'functions.') END ***************************************************************************** SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SCHMIDT ORTHOGONALIZATION OF COLUMN VECTORS IN T SCHMIDT ORTHOGONALIZE EACH EMPTY ORBITAL (SPECIFIED IN 'LSTEMT') TO THE ORTHONORMAL OCCUPIED (LSTOCC) ORBITALS; DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),LSTOCC(NDIM),LSTEMT(NDIM), * SBLK(NDIM,NDIM) DATA ZERO/0.0D0/ DO 30 I=1,NBAS DO 30 J=1,NOCC JP=LSTOCC(J) SJI=ZERO DO 10 K=1,NBAS 10 SJI=SJI+T(K,JP)*S(K,I) 30 SBLK(I,J)=SJI SCHMIDT ORTHOGONALIZE EACH UNOCCUPIED /UI> TO EACH /VJ>: ...LOOP OVER UNOCCUPIED /UI>'S, DO 120 I=1,NEMT IP=LSTEMT(I) ...LOOP OVER OCCUPIED /VJ>'S, DO 60 J=1,NOCC JP=LSTOCC(J) ...CALCULATE SJI = , SJI=ZERO DO 40 K=1,NBAS 40 SJI=SJI+SBLK(K,J)*T(K,IP) ...AND REPLACE EACH /UI> = /UI> - SJI*/VJ>. DO 50 K=1,NBAS 50 T(K,IP)=T(K,IP)-SJI*T(K,JP) 60 CONTINUE 120 CONTINUE RETURN END ***************************************************************************** SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2, * LIST,IRPNAO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),TPNAO(NDIM,NDIM),OCC(NDIM), + DMBLK(MXAOLM,MXAOLM),SBLK(MXAOLM,MXAOLM),EVAL(NBAS), + EVECT(MXAOLM,MXAOLM),EVAL2(NBAS),LIST(MXAOLM) DATA ONE/1.0D0/ COMPUTE NEW RYDBERG NAOS AFTER THE SCHMIDT ORTHOGONALIZATION TO THE MINIMAL NAO SET HAS BEEN DONE: IF REQUESTED (IRPNAO=JPRINT(11)=1), UPDATE PNAO TRANSFORMATION WITH TRYD: IF(IRPNAO.EQ.1) CALL FEPNAO(TPNAO) NL=1 IORB=0 100 IORB=IORB+NL IF(IORB.GT.NBAS) GO TO 300 NL=1 ILBL=NAOCTR(IORB) IL=NAOL(IORB)/100 NM=IL*2+1 IMAX=NBAS-IORB DO 130 IADD=1,IMAX JORB=IORB+IADD JORBL=NAOL(JORB)/100 IF(NAOCTR(JORB).NE.ILBL.OR.JORBL.NE.IL) GO TO 140 130 NL=NL+1 140 NC=NL/NM NSKIP=0 IMAX=IORB-1+NC DO 150 I=1,NBAS INAO=LSTOCC(I) IF(INAO.LT.IORB.OR.INAO.GT.IMAX) GO TO 150 NSKIP=NSKIP+1 150 CONTINUE IF(NSKIP.EQ.NC) GO TO 100 NSTART=NSKIP+1 NRYDC=NC-NSKIP CALL RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2, * IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO) END OF LOOP STARTING AT 100 GO TO 100 300 CONTINUE RESTORE S: DO 350 I=1,NBAS IM1=I-1 DO 340 J=1,IM1 340 S(J,I)=S(I,J) 350 S(I,I)=ONE SAVE UPDATED T-PNAO TRANSFORMATION: IF(IRPNAO.EQ.1) CALL SVPNAO(TPNAO) RETURN END ***************************************************************************** SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2, * IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),TPNAO(NDIM,NDIM),OCC(NBAS), * DMBLK(NRYDC,NRYDC),SBLK(NRYDC,NRYDC),EVAL(NBAS), * EVECT(NRYDC,NRYDC),LARC(NRYDC),LIST(NRYDC),EVAL2(NBAS) DATA ZERO/0.0D0/ DIAGONALIZE ONE RYDBERG BLOCK, UPDATE T-NAO (IN T) AND, IF IRPNAO.EQ.1, UPDATE TPNAO: II=0 DO 20 I=1,NRYDC DO 20 J=1,NRYDC DMBLK(I,J)=ZERO SBLK(I,J)=ZERO 20 CONTINUE DO 500 I=NSTART,NC II=II+1 DO 300 M=1,NM INAO=IORB+(I-1)+(M-1)*NC DO 140 K=1,NBAS DMSUM=ZERO SSUM=ZERO KM1=K-1 DO 100 L=1,KM1 TLI=T(L,INAO) DMSUM=DMSUM+TLI*S(L,K) 100 SSUM=SSUM+TLI*S(K,L) TKI=T(K,INAO) DMSUM=DMSUM+TKI*S(K,K) SSUM=SSUM+TKI KP1=K+1 DO 120 L=KP1,NBAS TLI=T(L,INAO) DMSUM=DMSUM+TLI*S(K,L) 120 SSUM=SSUM+TLI*S(L,K) EVAL(K)=DMSUM EVAL2(K)=SSUM 140 CONTINUE JJ=0 DO 240 J=NSTART,I JJ=JJ+1 JNAO=IORB+(J-1)+(M-1)*NC DMSUM=ZERO SSUM=ZERO DO 200 K=1,NBAS TKJ=T(K,JNAO) DMSUM=DMSUM+EVAL(K)*TKJ 200 SSUM=SSUM+EVAL2(K)*TKJ DMBLK(II,JJ)=DMBLK(II,JJ)+DMSUM SBLK(II,JJ)=SBLK(II,JJ)+SSUM 240 CONTINUE 300 CONTINUE DO 350 JJ=1,II DMBLK(II,JJ)=DMBLK(II,JJ)/NM DMBLK(JJ,II)=DMBLK(II,JJ) SBLK(II,JJ)=SBLK(II,JJ)/NM 350 SBLK(JJ,II)=SBLK(II,JJ) 500 CONTINUE CALL ATDIAG(NRYDC,DMBLK,SBLK,EVAL,EVECT) CALL RANK(EVAL,NRYDC,NRYDC,LARC) DO 600 J=1,NRYDC JC=LARC(J) DO 600 I=1,NRYDC 600 SBLK(I,J)=EVECT(I,JC) DO 700 M=1,NM JJ=0 DO 680 J=NSTART,NC JJ=JJ+1 JNAO=IORB+(J-1)+(M-1)*NC OCC(JNAO)=EVAL(JJ) LIST(JJ)=JNAO 680 CONTINUE USE LIMTRN TO UPDATE T: CALL LIMTRN(T,LIST,SBLK,DMBLK,NDIM,NBAS,NRYDC,NRYDC,1) 700 CONTINUE IF(IRPNAO.EQ.0) RETURN UPDATE TPNAO, BUT DO THIS IN SUCH A WAY THAT THE INTRA-ATOMIC BLOCKS OF THE OVERLAP MATRIX IN THE REVISED PNAO MATRIX REMAIN DIAGONAL AND THAT THE PNAOS REMAIN NORMALIZED. IN ORDER TO ACCOMPLISH THIS, WE MUST LOWDIN-ORTHOGONALIZE THE RYDBERG TRANSFORMATION IN "SBLK": CALL SYMORT(EVECT,SBLK,DMBLK,NRYDC,NRYDC,EVAL) DO 800 M=1,NM JJ=0 DO 780 J=NSTART,NC JJ=JJ+1 LIST(JJ)=IORB+(J-1)+(M-1)*NC 780 CONTINUE CALL LIMTRN(TPNAO,LIST,SBLK,DMBLK,NDIM,NBAS,NRYDC,NRYDC,1) 800 CONTINUE RETURN END ***************************************************************************** SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION WT(NDIM),LIST1(NBAS),LIST2(NBAS),LSTEMT(NBAS) DATA ONE,WTTHR/1.0D0,1.0D-4/ DIVIDE THE RYDBERG ORBITALS INTO 2 GROUPS: LIST1: RYDBERGS OF SIGNIFICANT OCCUPANCY ( .GT.WTTHR ) LIST2: RYDBERGS OF VERY LOW OCCUPANCY ( .LT.WTTHR ) WTTHR IS SET TO 0.0001 SET THE WEIGHTINGS OF THE RYDBERGS IN LIST2 TO ONE SO THAT THE WEIGHTED ORTHOGONALIZATION THAT WILL LATER BE DONE AMONG THESE ORBITALS WILL BE IN FACT A LOWDIN ORTHOG. NSEL1=0 NSEL2=0 DO 100 I=1,NEMT IRYD=LSTEMT(I) IF(WT(IRYD).LT.WTTHR) GO TO 50 NSEL1=NSEL1+1 LIST1(NSEL1)=IRYD GO TO 100 50 CONTINUE NSEL2=NSEL2+1 LIST2(NSEL2)=IRYD WT(IRYD)=ONE 100 CONTINUE RETURN END ***************************************************************************** SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LDEG(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),TPNAO(NDIM,NDIM), + C(MXAOLM,MXAOLM),EVAL(NDIM),BLK(MXAOLM,MXAOLM),IRANK(NBAS) REDIAGONALIZE THE SYMMETRY AVERAGED DM SUBBLOCKS FOR EACH ANGULAR SYMMETRY ON EACH ATOM: READ IN OLD T-PNAO INTO TPNAO SO THAT IT CAN BE UPDATED (IF IRPNAO.EQ.1): IF(IRPNAO.EQ.1) CALL FEPNAO(TPNAO) NF = 0 IORB = 0 NL = 1 10 IORB = IORB + NL IF(IORB.GT.NBAS) GO TO 100 NL = 1 ILBL = NAOCTR(IORB) IL = NAOL(IORB)/100 NM = IL*2 + 1 IMAX = NBAS - IORB DO 30 IADD = 1,IMAX JORB = IORB + IADD JORBL = NAOL(JORB)/100 IF((NAOCTR(JORB).NE.ILBL).OR.(JORBL.NE.IL)) GO TO 40 30 NL = NL + 1 40 NC = NL/NM IF(NC.EQ.1) GO TO 80 CALL REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK, * IRPNAO) GO TO 10 80 DO 90 M = 1,NM NF = NF + 1 90 CONTINUE GO TO 10 100 CONTINUE IF(IRPNAO.EQ.0) RETURN SAVE NEW T-PNAO FROM TPNAO: CALL SVPNAO(TPNAO) RETURN END ***************************************************************************** SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK, * IRPNAO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LDEG(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION DM(NDIM,NDIM),BLK(NC,NC),C(NC,NC),EVAL(NDIM), + T(NDIM,NDIM),TPNAO(NDIM,NDIM),IRANK(NBAS) DATA ZERO/0.0D0/ FIND THE REDIAGONALIZATION TRANSFORMATION FOR THE DM SUBBLOCK FOR THE ANGULAR MOMENTUM "IL" ON AN ATOM, PUT IN T2: NM = IL*2 + 1 DO 30 J = 1,NC DO 30 I = 1,J SUM = ZERO DO 10 M = 1,NM INAO = IORB + I-1 + (M-1)*NC JNAO = IORB + J-1 + (M-1)*NC 10 SUM = SUM + DM(INAO,JNAO) AVE = SUM/NM BLK(I,J) = AVE 30 BLK(J,I) = AVE CALL JACOBI(NC,BLK,EVAL,C,NC,NC,1) CALL RANK(EVAL,NC,NC,LARC) DO 80 J = 1,NC JC = LARC(J) DO 80 I = 1,NC 80 BLK(I,J) = C(I,JC) DO 110 M = 1,NM DO 100 J = 1,NC NF = NF + 1 100 IRANK(J) = NF CALL LIMTRN(T,IRANK,BLK,C,NDIM,NBAS,NC,NC,1) CALL LIMTRN(DM,IRANK,BLK,C,NDIM,NBAS,NC,NC,0) IF(IRPNAO.EQ.1) CALL LIMTRN(TPNAO,IRANK,BLK,C,NDIM,NBAS,NC,NC,1) 110 CONTINUE RETURN END **************************************************************************** ROUTINES CALLED BY THE NBO/NLMO DRIVERS: SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO) SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO) SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO,IFLG) SUBROUTINE SRTNBO(T,BNDOCC) SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR) SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB) SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN) SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB) SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR) SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB) SUBROUTINE FNDMOL(IATOMS) SUBROUTINE NBOCLA(BNDOCC,ACCTHR) SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO) SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR) SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG) SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR) SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM) SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,SIAB,NOCC,NAB) SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX) SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX) SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC) **************************************************************************** SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, * P,TA,HYB,VA,VB,TOPO) **************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) Construct orthogonal matrix T for transformation from AO's to Natural Hybrid Bond Orbitals using input density matrix DM. REQUIRED INPUT INCLUDES: DM = DENSITY MATRIX IN ORTHONORMAL ATOMIC ORBITAL BASIS; REAL(1,NDIM;1,NDIM) NBAS = NO. OF ORBITALS = ACTUAL DIMENSION OF DM,S,T,NAOL,DMT NATOMS = NO. OF ATOMS (NOT INCLUDING GHOSTS) IN THE MOLECULE IATNO = LIST OF ATOMIC NUMBERS NAOCTR = ORBITAL LABEL LIST. NAOCTR(I)=IAT IF NAO # I IS ON ATOM IAT INTEGER(1,NDIM). NAOS OF GIVEN ATOM GROUPED TOGETHER. IW3C = 1 IF PROGRAM IS TO SEARCH FOR 3-CENTER BONDS, = 0 OTHERWISE GUIDE = WIBERG ATOM-ATOM BOND INDEX MATRIX, USED AS GUIDE FOR NBO SEARCH OUTPUT: T = BOND ORBITAL TRANSFORMATION MATRIX (NDIM,NDIM). ROWS ARE LABELLED BY NAOS, COLUMNS BY NBOS. LABEL = LIST OF BOND ORBITAL LABELS IBXM = PERMUTATION LIST OF BOND ORBITAL LABELS (VERY IMPORTANT!) LOGICAL DETAIL,NOBOND,FIRST LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO INTEGER UL PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM), + N3CTR,I3CTR(10,3) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),V(NDIM),BORB(MXBO), * POL(NDIM,3),BNDOCC(NDIM),NAME(3),HYBEXP(3), * Q(MXAO,NDIM),BLK(MXBO,MXBO),EVAL(MXBO),C(MXBO,MXBO), * P(MXAO,MXAO),TA(MXAO,MXAO),HYB(MXAO),VA(MXAO),VB(MXAO), * GUIDE(NATOMS,NATOMS),TOPO(NATOMS*NATOMS) DATA GTHRSH/1.5D-1/ DATA ISTAR,IBLNK/'*',' '/ DATA NAME/'LP','BD','3C'/ DATA LRY,LCR/'RY','CR'/ DATA ZERO,ZEROP,TENTH,ONE,TWO,FOUR * /0.D0,1.D-6,0.1D0,1.0D0,2.0D0,4.0D0/ DATA TWOP/2.0001D0/ DATA PT8,PT99/0.8D0,0.99D0/ PRJINC, the amount to increase PRJTHR by if problems with linear dependency between the hybrids arise. DATA PRJINC/0.05D0/ NOPVAL(I) = NORBS(I) - INO(I) DETAIL = .FALSE. IF(IWDETL.NE.0) DETAIL = .TRUE. NOBOND = .FALSE. IF(JPRINT(10).NE.0) NOBOND = .TRUE. Initial iteration loop: If no satisfactory Lewis structure (all antibond occupancies < 0.1) for THRESH = 1.90, THRESH is decremented up to 4 times by 0.1 in search of a better structure. If the DM is not spinless, THRESH is set to 0.90 and is decremented as above. PRJTHR = ABS(PRJSET) THRESH = ABS(THRSET) IF(ISPIN.NE.0) THRESH = THRESH - ONE IF(NOBOND) THRESH = ONE IF(NOBOND.AND.(ISPIN.NE.0)) THRESH = ONE/TWO IF(ISPIN.NE.0) GTHRSH = GTHRSH/FOUR Determine the atom ordering for the initial search for bonds: IF(NATOMS.EQ.1) THEN IORDER(1) = 1 GOTO 45 END IF Find the two atoms which have the largest bond index: GMAX = ZERO DO 10 J = 2,NATOMS DO 5 I = 1,J-1 IF(GUIDE(I,J).GT.GMAX) THEN GMAX = GUIDE(I,J) IAT = I END IF 5 CONTINUE 10 CONTINUE IORDER(1) = IAT Add atoms to IORDER according to these connectivities: ICNT = 1 INXT = ICNT JCNT = ICNT 15 IPTR = INXT I1ST = 1 DO 20 I = 1,NATOMS TOPO(I) = GUIDE(I,IORDER(IPTR)) 20 CONTINUE CALL RANK(TOPO,NATOMS,NATOMS,JORDER) JPTR = 1 25 IF(TOPO(JPTR).GT.PT8) THEN IFLG = 1 DO 30 I = 1,ICNT IF(IORDER(I).EQ.JORDER(JPTR)) IFLG = 0 30 CONTINUE IF(IFLG.EQ.1) THEN ICNT = ICNT + 1 IORDER(ICNT) = JORDER(JPTR) IF(I1ST.EQ.1) THEN I1ST = 0 INXT = ICNT END IF END IF ELSE GOTO 35 END IF JPTR = JPTR + 1 GOTO 25 35 CONTINUE IF(I1ST.EQ.1) THEN JCNT = JCNT + 1 INXT = JCNT IF(INXT.GT.NATOMS) GOTO 45 IF(INXT.GT.ICNT) THEN KPTR = 0 40 KPTR = KPTR + 1 KFLG = 1 DO 41 I = 1,ICNT IF(IORDER(I).EQ.KPTR) KFLG = 0 41 CONTINUE IF(KFLG.EQ.0) GOTO 40 ICNT = ICNT + 1 IORDER(ICNT) = KPTR END IF END IF GOTO 15 45 CONTINUE ITER = 0 IALARM = 0 50 IF(IALARM.EQ.0) ITER = ITER + 1 Store density matrix in upper triangle of T: DO 60 J = 1,NBAS DO 60 I = 1,J 60 T(I,J) = DM(I,J) Zero arrays Q, POL, IATHY, INO, and LABEL: DO 100 I = 1,NBAS DO 70 K = 1,2 70 LABEL(I,K) = IBLNK DO 80 K = 3,6 80 LABEL(I,K) = 0 DO 90 K = 1,3 POL(I,K) = ZERO 90 IATHY(I,K) = 0 DO 100 K = 1,MXAO 100 Q(K,I) = ZERO DO 110 I = 1,NATOMS 110 INO(I) = 0 Remove core orbitals from the density matrix: IBD = 0 CALL CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR) Main NHO loops -------------- Doubly occupied (IOCC=1) or singly occupied (IOCC=2) NHO's If ISPIN.NE.0, search is only for singly occupied nbos (IOCC=1): OCCMX = THRESH Main NHO loops over singles, doubles, and triples of atoms: NA1 = NATOMS + 1 DO 310 IA1 = 1,NA1 IA = IA1 - 1 IF((IA.GT.0).AND.(NOPVAL(IORDER(IA)).LE.0)) GO TO 310 DO 300 IB1 = 1,NA1 IB = IB1 - 1 IF((IB.GT.0).AND.(NOPVAL(IORDER(IB)).LE.0)) GO TO 300 DO 290 IC1 = 2,NA1 IC = IC1 - 1 IF((IC.GT.0).AND.(NOPVAL(IORDER(IC)).LE.0)) GO TO 290 IF(IA.NE.0) GO TO 130 IF(IB.NE.0) GO TO 120 Lone pairs: NCTR = 1 IAT1 = IORDER(IC) IAT2 = 0 IAT3 = 0 GO TO 140 Bond pairs: 120 CONTINUE IF(NOBOND) GO TO 290 NCTR = 2 IAT1 = IORDER(IB) IAT2 = IORDER(IC) IAT3 = 0 IF(IAT1.GE.IAT2) GO TO 290 IF(GUIDE(IAT1,IAT2).LT.GTHRSH) GO TO 290 GO TO 140 3-center bonds: 130 CONTINUE IF(IW3C.NE.1) GO TO 320 NCTR = 3 IAT1 = IORDER(IA) IAT2 = IORDER(IB) IAT3 = IORDER(IC) IF(IAT1.GE.IAT2) GO TO 300 IF(IAT2.GE.IAT3) GO TO 290 IF(GUIDE(IAT1,IAT2).GT.GTHRSH) GO TO 140 IF(GUIDE(IAT1,IAT3).GT.GTHRSH) GO TO 140 IF(GUIDE(IAT2,IAT3).GT.GTHRSH) GO TO 140 GO TO 290 140 CONTINUE Deplete DM of one(two) center orbitals if search for two(three) center orbitals is beginning: IF(IWPRJ(NCTR).NE.0) * CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD) Load proper atomic blocks of DM into BLK: CALL LOAD(DM,IAT1,IAT2,IAT3,BLK,NB) Diagonalize BLK: CALL JACOBI(NB,BLK,EVAL,C,MXBO,MXBO,1) Rank eigenvectors by occupancy eigenvalue: CALL RANK(EVAL,NB,MXBO,LARC) IF(DETAIL) WRITE(LFNPR,1400) IAT1,IAT2,IAT3 IF(DETAIL) WRITE(LFNPR,1403) THRESH IF(DETAIL) WRITE(LFNPR,1405) (EVAL(IRNK),IRNK=1,NB) IACCEP = 0 DO 250 IRNK = 1,NB IR = LARC(IRNK) OCC = EVAL(IRNK) DO 200 I = 1,NB 200 BORB(I) = C(I,IR) IF(DETAIL) WRITE(LFNPR,1410) IRNK,OCC IF(DETAIL) WRITE(LFNPR,1420) (BORB(I),I=1,NB) Throw out orbital if occupancy is less than the threshhold "OCCMX": IF(OCC.LT.OCCMX) GO TO 280 Check to see that bond orbital "BORB" doesn't contain previously used hybrids: IF(NCTR.EQ.1) GO TO 240 CALL PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,TA,HYB,VA,VB,HYBEXP) IF(.NOT.DETAIL) GO TO 220 DO 210 IHYB = 1,NCTR 210 WRITE(LFNPR,1500) IHYB,HYBEXP(IHYB) 220 CONTINUE DO 230 IHYB = 1,NCTR 230 IF(HYBEXP(IHYB).LT.PRJTHR) GO TO 250 240 CONTINUE IBD = IBD + 1 IACCEP = IACCEP + 1 Decompose "BORB" into its constituent atomic hybrids and store in Q: CALL STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB) Construct bond orbital labels: LABEL(IBD,1) = NAME(NCTR) LABEL(IBD,2) = IBLNK LABEL(IBD,3) = IACCEP LABEL(IBD,4) = IAT1 LABEL(IBD,5) = IAT2 LABEL(IBD,6) = IAT3 BNDOCC(IBD) = OCC IF(DETAIL) WRITE(LFNPR,1600) IBD,(LABEL(IBD,I),I=1,3) 250 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE 310 CONTINUE 320 CONTINUE Symmetric orthogonalization of principal hybrids: CALL ORTHYB(Q,BLK,TA,EVAL,C,IALARM,0) IALARM sounds the alarm that there is linear dependency between some of the hybrids. The remedy is to increase prjthr and repeat the NBO search. IALARM is equal to the number of the violating atom. IF(IALARM.NE.0) THEN OLDPRJ = PRJTHR PRJTHR = OLDPRJ + PRJINC IF(JPRINT(5).NE.0) WRITE(LFNPR,1800) OLDPRJ,PRJTHR IF(PRJTHR.GE.PT99) THEN WRITE(LFNPR,1810) IALARM JPRINT(1) = -1 RETURN END IF GOTO 700 END IF Augment open-valence atoms with non-arbitrary hybrids orthogonal to those found previously: DO 580 IA = 1,NATOMS IF(NOPVAL(IA).LE.0) GO TO 580 IULA: upper limit of NAOs on atom. Find NMB, the number of natural minimal basis functions on the atom: LLA = LL(IA) IULA = UL(IA) NMB = 0 DO 470 I = LLA,IULA IF(LSTOCC(I).EQ.1) NMB = NMB + 1 470 CONTINUE Find the number of bond, core, and lone pair hybrids on the atom, IOCC: Also find IOCCLP, number of lone pair orbitals already found on IA, for use in labelling the extra lone pairs below: IOCC = 0 IOCCLP = 0 DO 480 IB = 1,IBD IF((LABEL(IB,4).NE.IA).AND.(LABEL(IB,5).NE.IA).AND. * (LABEL(IB,6).NE.IA)) GO TO 480 IOCC = IOCC + 1 IF(LABEL(IB,1).EQ.NAME(1)) IOCCLP = IOCCLP + 1 480 CONTINUE NEXLP: number of extra (low occupancy) LP orbitals on atom IAT. (This is the number of low occupancy orbitals with valence shell character) Set NEXLP to zero if (NMB-IOCC) is less than zero in order that the orbitals are not miscounted!! NEXLP = NMB - IOCC IF(NEXLP.LT.0) NEXLP = 0 NOCC = INO(IA) CALL FRMPRJ(P,IA,Q,NOCC,TA,VA,VB) NORB = NORBS(IA) NAUGM = NORB - NOCC CALL AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB) Stash and label extra lone pairs that AUGMNT put in BLK: (These ar taken to be the highest occupied orbitals, which AUGMNT places first) DO 510 IAUGM = 1,NEXLP DO 500 J = 1,NORB 500 BORB(J) = BLK(J,IAUGM) IBD = IBD + 1 CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB) LABEL(IBD,1) = NAME(1) LABEL(IBD,2) = IBLNK LABEL(IBD,3) = IAUGM + IOCCLP LABEL(IBD,4) = IA LABEL(IBD,5) = 0 LABEL(IBD,6) = 0 510 CONTINUE Stash and label the Rydberg orbitals that AUGMNT put in BLK: IRYD = 0 NSTART = NEXLP + 1 DO 540 IAUGM = NSTART,NAUGM DO 530 J = 1,NORB 530 BORB(J) = BLK(J,IAUGM) IBD = IBD + 1 IRYD = IRYD + 1 CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB) LABEL(IBD,1) = LRY LABEL(IBD,2) = ISTAR LABEL(IBD,3) = IRYD LABEL(IBD,4) = IA LABEL(IBD,5) = 0 LABEL(IBD,6) = 0 540 CONTINUE 580 CONTINUE Include antibond labels: IBO = IBD DO 660 I = 1,IBO Exit loop if LABEL(I,1) is 'LP', 'RY', or 'CR': IF(LABEL(I,1).EQ.NAME(1)) GO TO 660 IF(LABEL(I,1).EQ.LRY) GO TO 660 IF(LABEL(I,1).EQ.LCR) GO TO 660 NAB = 1 IF(LABEL(I,1).EQ.NAME(3)) NAB = 2 DO 650 IAB = 1,NAB IBD = IBD + 1 DO 640 J = 1,6 640 LABEL(IBD,J) = LABEL(I,J) LABEL(IBD,2) = ISTAR 650 CONTINUE 660 CONTINUE Replace density matrix DM from T: 700 CONTINUE DO 740 J=1,NBAS DO 740 I=1,J DM(I,J)=T(I,J) DM(J,I)=DM(I,J) T(J,I)=ZERO 740 T(I,J)=ZERO Remember the alarm! IF(IALARM.NE.0) GO TO 50 Miscounted bond orbitals...exit for open shell: IF(IBD.NE.NBAS) THEN WRITE(LFNPR,1200) THRESH,IBD,NBAS WRITE(LFNPR,1210) (I,(LABEL(I,J),J=1,6),I=1,IBD) STOP END IF Find new polarization parameters for orthonormal hybrids: CALL REPOL(DM,Q,POL,BLK,EVAL,C,IBD) Form final T-NAB (NAO to NBO transformation) from orthonormal hybrids: CALL FORMT(T,Q,POL) Find occupancies, find total number of electrons and occupied orbitals: TOTELE = ZERO DO 800 I = 1,NBAS OCCI = ZERO DO 790 J = 1,NBAS DO 790 K = 1,NBAS 790 OCCI = OCCI + T(J,I) * DM(J,K) * T(K,I) IF(ABS(OCCI).LT.ZEROP) OCCI = ZERO IF(OCCI.GT.TWOP) GO TO 960 ZEROPM = -ZEROP IF(OCCI.LT.ZEROPM) GO TO 960 BNDOCC(I) = OCCI V(I) = OCCI TOTELE = TOTELE + BNDOCC(I) 800 CONTINUE NEL = TOTELE + TENTH IF(ABS(TOTELE-NEL).GT.5E-4) GO TO 970 TOTELE = NEL NOCC = NEL IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2) Make sure all but the NOCC highest occupied NBOs are starred: CALL RANK(V,NBAS,NDIM,LARC) DO 804 I = 1,NOCC IR = LARC(I) LABEL(IBXM(IR),2) = IBLNK 804 CONTINUE DO 805 I = NOCC+1,NBAS IR = LARC(I) LABEL(IBXM(IR),2) = ISTAR 805 CONTINUE Determine whether this is a good resonance structure: CALL CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT) IF(ICONT.EQ.0) THEN JPRINT(1) = -1 RETURN END IF IF(ICONT.EQ.-1) GO TO 50 IF(ICONT.EQ.1) GO TO 50 Before final return, write out info about core orbitals which were isolated in subroutine CORE: CRTHRS = CRTSET IF(ISPIN.NE.0) CRTHRS = CRTHRS - ONE FIRST = .TRUE. DO 952 IAT = 1,NATOMS ILOW = 0 DO 951 I = 1,NBAS IF(LABEL(IBXM(I),1).EQ.LCR.AND.LABEL(IBXM(I),4).EQ.IAT + .AND.BNDOCC(I).LT.CRTHRS) ILOW = ILOW + 1 951 CONTINUE IF(ILOW.NE.0) THEN IF(FIRST) THEN FIRST = .FALSE. NAM = NAMEAT(IATNO(IAT)) IF(ILOW.NE.1) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,3010) ILOW,CRTHRS,NAM,IAT ELSE IF(JPRINT(5).EQ.1) WRITE(LFNPR,3011) ILOW,CRTHRS,NAM,IAT END IF ELSE NAM = NAMEAT(IATNO(IAT)) IF(ILOW.NE.1) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,3020) ILOW,CRTHRS,NAM,IAT ELSE IF(JPRINT(5).EQ.1) WRITE(LFNPR,3021) ILOW,CRTHRS,NAM,IAT END IF END IF END IF 952 CONTINUE RETURN Problems with a bond orbital occupancy: 960 WRITE(LFNPR,1300) OCCI JPRINT(1) = -1 RETURN Total number of electrons is not an integer: 970 WRITE(LFNPR,1310) TOTELE JPRINT(1) = -1 RETURN 1200 FORMAT(/,1X,'For an occupancy threshold of ',F4.2,' the search', + ' for NBOs found',/,1X,I3,' orbitals orbitals rather than ',I4) 1210 FORMAT(3X,'Label ',I3,':',A3,A1,I2,3I3) 1300 FORMAT(/,1X,'A bond orbital with an occupancy of ',F8.5, + ' electrons was found!',/,1X,'Please check you input data.') 1310 FORMAT(/,1X,'The total number of electron is not an integer:', + F10.5,/,1X,'Please check your input data.') 1400 FORMAT(/,1X,'Search of DM block between the following atoms:', + 3I4) 1403 FORMAT(6X,'Select orbitals with eigenvalue > ',F9.6) 1405 FORMAT(6X,8F9.6) 1410 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':') 1420 FORMAT(11X,8F7.4) 1500 FORMAT(11X,'Hybrid ',I1,' in eigenvector has a projection ', + 'expectation of ',F6.3) 1600 FORMAT(11X,'*** NBO accepted: Number',I3,'. Label:',A2,A1, + '(',I2,')') 1800 FORMAT(/4X,'PRJTHR will be raised from ',F6.3,' to',F6.3, + ' and the NBO search repeated.',/) 1810 FORMAT(//,1X,'Linearly independent hybrids for atom',I3, +' cannot be found.',/,1X,'The NBO program must abort.') 3010 FORMAT(/,1X, +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals ', +'found on ',A2,I2) 3011 FORMAT(/,1X, +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbital ', +'found on ',A2,I2) 3020 FORMAT(1X, +' ',I3,' low occupancy (<',F6.4,'e) core orbitals ', +'found on ',A2,I2) 3021 FORMAT(1X, +' ',I3,' low occupancy (<',F6.4,'e) core orbital ', +'found on ',A2,I2) END ***************************************************************************** SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, * P,TA,HYB,VA,VB,TOPO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL END,ERROR,EQUAL PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM), + N3CTR,I3CTR(10,3) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),GUIDE(NATOMS,NATOMS), * BNDOCC(NDIM),POL(NDIM,3),Q(MXAO,NDIM),V(NDIM),BLK(MXBO,MXBO), * C(MXBO,MXBO),EVAL(MXBO),BORB(MXBO),P(MXAO,MXAO),TA(MXAO,MXAO), * HYB(MXAO),VA(MXAO),VB(MXAO),TOPO(NATOMS,NATOMS) DIMENSION KEYWD(6),KLONE(4),KBOND(4),K3CBON(6),KALPHA(5), * KBETA(4),IVAL(4),KALT(4) DATA KLONE/1HL,1HO,1HN,1HE/, * KBOND/1HB,1HO,1HN,1HD/, * K3CBON/1H3,1HC,1HB,1HO,1HN,1HD/, * KALPHA/1HA,1HL,1HP,1HH,1HA/, * KBETA/1HB,1HE,1HT,1HA/, * KS/1HS/,KD/1HD/,KT/1HT/,KQ/1HQ/, * KALT/1H$,1HE,1HN,1HD/ Search for `ALPHA' or `BETA' character string in case of alpha or beta spin density matrices: IF(ISPIN.EQ.2) THEN 20 LENG = 5 CALL HFLD(KEYWD,LENG,END) IF(END.AND.LENG.EQ.0) GOTO 810 IF(.NOT.EQUAL(KEYWD,KALPHA,5)) GOTO 20 CONTINUE ELSE IF(ISPIN.EQ.-2) THEN 30 LENG = 5 CALL HFLD(KEYWD,LENG,END) IF(END.AND.LENG.EQ.0) GOTO 820 IF(.NOT.EQUAL(KEYWD,KBETA,4)) GOTO 30 CONTINUE END IF Fill diagonal elements of the TOPO matrix with nominal numbers of lone pairs to be found on each atom: DO 50 IAT = 1,NATOMS NLP = 0 CALL VALTBL(IAT,IVAL) DO 40 L = 0,3 NLP = NLP + IVAL(L+1)*(2*L + 1) 40 CONTINUE NTOPO(IAT,IAT) = 100 + NLP 50 CONTINUE Read in chosen lone pairs, bonds, and 3-center bonds: NCTR = 0 N3CTR = 0 60 CONTINUE LENG = 6 CALL HFLD(KEYWD,LENG,END) IF(END.OR.EQUAL(KEYWD,KALT,4)) GOTO 300 NCTRO = NCTR NCTR = 0 IF(EQUAL(KEYWD,KLONE,4)) NCTR = 1 IF(EQUAL(KEYWD,KBOND,4)) NCTR = 2 IF(EQUAL(KEYWD,K3CBON,6)) NCTR = 3 IF(NCTR.EQ.0) GO TO 1010 IF(NCTR.LT.NCTRO) GO TO 1020 GOTO (100,150,200), NCTR Read in lone pairs: 100 CONTINUE CALL IFLD(IAT,ERROR) IF(ERROR) THEN LENG = 6 CALL HFLD(KEYWD,LENG,END) GO TO 60 END IF CALL IFLD(NUM,ERROR) IF(ERROR) GOTO 830 NTOPO(IAT,IAT) = NUM GOTO 100 Read in bonds: 150 CONTINUE LENG = 1 CALL HFLD(KEYWD,LENG,END) IF(END) GOTO 60 NUM = 0 IF(EQUAL(KEYWD,KS,1)) NUM = 1 IF(EQUAL(KEYWD,KD,1)) NUM = 2 IF(EQUAL(KEYWD,KT,1)) NUM = 3 IF(EQUAL(KEYWD,KQ,1)) NUM = 4 IF(NUM.EQ.0) GOTO 840 CALL IFLD(IAT1,ERROR) IF(ERROR) GOTO 840 CALL IFLD(IAT2,ERROR) IF(ERROR) GOTO 840 IAT = MAX0(IAT1,IAT2) JAT = MIN0(IAT1,IAT2) NTOPO(IAT,JAT) = NUM NTOPO(JAT,IAT) = NUM GOTO 150 Read in 3-center bonds: 200 CONTINUE IF(IW3C.NE.1) IW3C = 1 LENG = 1 CALL HFLD(KEYWD,LENG,END) IF(END) GOTO 60 NUM = 0 IF(EQUAL(KEYWD,KS,1)) NUM = 1 IF(EQUAL(KEYWD,KD,1)) NUM = 2 IF(EQUAL(KEYWD,KT,1)) NUM = 3 IF(EQUAL(KEYWD,KQ,1)) NUM = 4 IF(NUM.EQ.0) GOTO 860 CALL IFLD(IAT1,ERROR) IF(ERROR) GOTO 860 CALL IFLD(IAT2,ERROR) IF(ERROR) GOTO 860 CALL IFLD(IAT3,ERROR) IF(ERROR) GOTO 860 N3CTR = N3CTR + 1 IF(N3CTR.GT.10) GOTO 870 I3CTR(N3CTR,1) = IAT1 I3CTR(N3CTR,2) = IAT2 I3CTR(N3CTR,3) = IAT3 GOTO 200 Modify nominal sets of lone pairs by number of bonds and 3-center bonds. 300 CONTINUE DO 330 IAT = 1,NATOMS NLP = NTOPO(IAT,IAT) IF(NLP.LT.100) GOTO 330 NLP = MOD(NLP,100) NBD = 0 DO 310 JAT = 1,NATOMS IF(IAT.NE.JAT.AND.NTOPO(JAT,IAT).NE.0) THEN NBD = NBD + NTOPO(JAT,IAT) END IF 310 CONTINUE DO 320 KAT = 1,3 DO 315 JAT = 1,N3CTR IF(I3CTR(JAT,KAT).EQ.IAT) NBD = NBD + 1 315 CONTINUE 320 CONTINUE NLP = NLP - NBD IF(NLP.LT.0) NLP = 0 NTOPO(IAT,IAT) = NLP 330 CONTINUE Use CHOOSE to find bond orbitals using NTOPO and I3CTR: IFLG = 0 CALL CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,P,TA,HYB, + VA,VB,TOPO,IFLG) RETURN 810 WRITE(LFNPR,1180) JPRINT(1) = -1 RETURN 820 WRITE(LFNPR,1190) JPRINT(1) = -1 RETURN 830 WRITE(LFNPR,1130) JPRINT(1) = -1 RETURN 840 WRITE(LFNPR,1140) JPRINT(1) = -1 RETURN 860 WRITE(LFNPR,1160) JPRINT(1) = -1 RETURN 870 WRITE(LFNPR,1170) JPRINT(1) = -1 RETURN 1010 WRITE(LFNPR,1110) (KEYWD(I),I=1,6) JPRINT(1) = -1 RETURN 1020 WRITE(LFNPR,1120) JPRINT(1) = -1 RETURN 1110 FORMAT(/1X,'Error in input of bond orbitals:',/,1X, * 'Keyword for orbital type is not LONE, BOND, or 3CBOND (read `', * 6A1,''')') 1120 FORMAT(/1X,'Error in input of bond orbitals:',/,1X, * 'Orbital types should be in the order: LONE, BOND, 3CBOND') 1130 FORMAT(/1X,'Error in input of bond orbitals:',/,1X, * 'Unrecognizable characters in input of lone orbitals') 1140 FORMAT(/1X,'Error in input of bond orbitals:',/,1X, * 'Unrecognizable characters in input of two center orbitals') 1160 FORMAT(/1X,'Error in input of bond orbitals:',/,1X, * 'Unrecognizable characters in input of three center orbitals') 1170 FORMAT(/1X,'Too many three center bonds:', * ' Increase parameter MAX3C') 1180 FORMAT(/1X,'End of file encountered before the word ALPHA was ', * 'found') 1190 FORMAT(/1X,'End of file encountered before the word BETA was ', * 'found') END ***************************************************************************** SUBROUTINES CALLED BY NATHYB AND CHSDRV FOR FORMING NBOS ***************************************************************************** SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, * P,TA,HYB,VA,VB,TOPO,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) Construct orthogonal matrix T for transformation from AO's to Natural Hybrid Bond Orbitals using input density matrix DM with the chosen bonding pattern read from LFNIN LOGICAL DETAIL,FIRST,PRINT,LEFT INTEGER UL PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM), + N3CTR,I3CTR(10,3) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),GUIDE(NATOMS,NATOMS), * BNDOCC(NDIM),POL(NDIM,3),Q(MXAO,NDIM),V(NDIM),BLK(MXBO,MXBO), * C(MXBO,MXBO),EVAL(MXBO),BORB(MXBO),P(MXAO,MXAO),TA(MXAO,MXAO), * HYB(MXAO),VA(MXAO),VB(MXAO),TOPO(NATOMS,NATOMS) DIMENSION NAME(3),HYBEXP(3),KTOPO(MAXATM,MAXATM),KFLG(10) DIMENSION SCR(MAXATM*(MAXATM-1)/2),IPT(MAXATM*(MAXATM-1)/2) DATA ISTAR,IBLNK,NAME,LRY,LCR/'*',' ','LP','BD','3C','RY','CR'/ DATA ZERO,ZEROP,TENTH,PT99,ONE,TWO,TWOP + /0.0D0,1.0D-6,0.1D0,0.99D0,1.0D0,2.0D0,2.0001D0/ IFLG is a print flag on entering CHOOSE. If set to 0(1), CHOOSE will(not) print some output to LFNPR. On exit, if IFLG is set to -1, there was an error in finding the requested structure: PRJINC, the amount to increase PRJTHR by if problems with linear dependency between the hybrids arise. DATA PRJINC/0.05D0/ NOPVAL(I) = NORBS(I) - INO(I) PRINT = .FALSE. IF(IFLG.EQ.0) PRINT = .TRUE. IF(JPRINT(5).EQ.0) PRINT = .FALSE. DETAIL = .FALSE. IF(IWDETL.NE.0) DETAIL = .TRUE. PRJTHR = ABS(PRJSET) ITER = 0 Initialize KTOPO and KFLG arrays: (KFLG is set to 1 if the 3-center bond has not been fund yet.) DO 10 I = 1,NATOMS DO 5 J = 1,I KTOPO(I,J) = NTOPO(I,J) KTOPO(J,I) = NTOPO(J,I) 5 CONTINUE 10 CONTINUE DO 15 I = 1,N3CTR KFLG(I) = 1 15 CONTINUE Determine the atom ordering for the search for bond orbitals: IF(NATOMS.EQ.1) THEN IORDER(1) = 1 ELSE II = 0 DO 20 JAT = 2,NATOMS DO 19 IAT = 1,JAT-1 II = II + 1 SCR(II) = KTOPO(IAT,JAT) - GUIDE(IAT,JAT) 19 CONTINUE 20 CONTINUE NN = NATOMS * (NATOMS - 1) / 2 CALL RANK(SCR,NN,NN,IPT) Begin search for bond orbitals where the formal bond order is much greater than the corresponding Wiberg bond index: IPOS = 0 JPOS = 0 21 CONTINUE JPOS = JPOS + 1 IF(JPOS.GT.NN) STOP 'Problems with atom permutation list' IAT = IPT(JPOS) JAT = 2 22 CONTINUE IF(JAT.GT.IAT) GOTO 23 IAT = IAT - JAT + 1 JAT = JAT + 1 GOTO 22 23 CONTINUE Add IAT and JAT to the atom permutation list IORDER: MFLG = 0 DO 24 I = 1,IPOS IF(IORDER(I).EQ.IAT) MFLG = 1 24 CONTINUE IF(MFLG.EQ.0) THEN IPOS = IPOS + 1 IORDER(IPOS) = IAT END IF MFLG = 0 DO 25 I = 1,IPOS IF(IORDER(I).EQ.JAT) MFLG = 1 25 CONTINUE IF(MFLG.EQ.0) THEN IPOS = IPOS + 1 IORDER(IPOS) = JAT END IF IF(IPOS.LT.NATOMS) GOTO 21 END IF Return to here if it should prove necessary to raise PRJTHR: 35 CONTINUE ITER = ITER + 1 OCCTHR = ABS(THRSET) IF(ISPIN.NE.0) OCCTHR = OCCTHR - ONE OCCTHR = OCCTHR + TENTH Store density matrix in upper triangle of T: DO 50 J = 1,NBAS DO 40 I = 1,J T(I,J) = DM(I,J) 40 CONTINUE 50 CONTINUE Zero arrays Q,POL,IATHY,INO,LABEL: DO 100 I = 1,NBAS DO 60 K = 1,2 LABEL(I,K) = IBLNK 60 CONTINUE DO 70 K = 3,6 LABEL(I,K) = 0 70 CONTINUE DO 80 K = 1,3 POL(I,K) = ZERO IATHY(I,K) = 0 80 CONTINUE DO 90 K = 1,MXAO Q(K,I) = ZERO 90 CONTINUE 100 CONTINUE DO 110 I = 1,NATOMS INO(I) = 0 110 CONTINUE Remove core orbitals from the density matrix: IBD = 0 CALL CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR) Return here if there are still more lone pairs or bonds to be found. Lower the occupancy threshold for acceptance by a tenth: 115 CONTINUE OCCTHR = OCCTHR - TENTH LEFT = .FALSE. ******** START DIRECTED NBO SEARCH ********* Loop over numbers of centers, removing lone pairs and 2- and 3-center bonds from the density matrix according to KTOPO and I3CTR: NCTR = 0 120 NCTR = NCTR + 1 Deplete DM of one(two) center orbitals if search for two(three) center orbitals is beginning: IF(NCTR.NE.1) CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD) ICNTR = 0 Return here for 3-c bonds and lone pairs: 130 ICNTR = ICNTR + 1 IF(NCTR.EQ.1) THEN IF(ICNTR.GT.NATOMS) GOTO 120 NUM = KTOPO(IORDER(ICNTR),IORDER(ICNTR)) IF(NUM.LE.0) GOTO 130 IAT1 = IORDER(ICNTR) IAT2 = 0 IAT3 = 0 GOTO 200 ELSE IF(NCTR.EQ.2) THEN IF(ICNTR.GT.NATOMS) GOTO 120 JCNTR = ICNTR Return here for 2-c bonds: 150 JCNTR = JCNTR + 1 IF(JCNTR.GT.NATOMS) GOTO 130 NUM = KTOPO(IORDER(JCNTR),IORDER(ICNTR)) IF(NUM.EQ.0) GOTO 150 IAT1 = MIN(IORDER(ICNTR),IORDER(JCNTR)) IAT2 = MAX(IORDER(ICNTR),IORDER(JCNTR)) IAT3 = 0 GOTO 200 ELSE IF(NCTR.EQ.3) THEN IF(ICNTR.GT.N3CTR) GOTO 120 IF(KFLG(ICNTR).EQ.0) GOTO 130 NUM = 1 IAT1 = MIN(I3CTR(ICNTR,1),I3CTR(ICNTR,2),I3CTR(ICNTR,3)) IAT3 = MAX(I3CTR(ICNTR,1),I3CTR(ICNTR,2),I3CTR(ICNTR,3)) IAT2 = I3CTR(ICNTR,1) IF(IAT2.EQ.IAT1.OR.IAT2.EQ.IAT3) IAT2 = I3CTR(ICNTR,2) IF(IAT2.EQ.IAT1.OR.IAT2.EQ.IAT3) IAT2 = I3CTR(ICNTR,3) GOTO 200 ELSE GOTO 300 END IF Load proper atomic blocks of DM into BLK, and diagonalize BLK: 200 CONTINUE CALL LOAD(DM,IAT1,IAT2,IAT3,BLK,NB) CALL JACOBI(NB,BLK,EVAL,C,MXBO,MXBO,1) Rank eigenvectors by occupancy eigenvalue: CALL RANK(EVAL,NB,MXBO,LARC) IF(DETAIL) WRITE(LFNPR,1400) IAT1,IAT2,IAT3 IF(DETAIL) WRITE(LFNPR,1402) NUM,OCCTHR IF(DETAIL) WRITE(LFNPR,1405) (EVAL(IRNK),IRNK=1,NB) Loop over eigenvalues selecting the NUM highest occupied: IACCEP = 0 DO 250 IRNK = 1,NB IR = LARC(IRNK) OCC = EVAL(IRNK) DO 210 I = 1,NB 210 BORB(I) = C(I,IR) IF(DETAIL) WRITE(LFNPR,1410) IRNK,OCC IF(DETAIL) WRITE(LFNPR,1420) (BORB(I),I=1,NB) If this is a low occupancy orbital, skip the rest of these and can come back to them later: IF(OCC.LT.OCCTHR) THEN IF(NCTR.EQ.1) THEN KTOPO(IAT1,IAT1) = NUM - IACCEP IF(DETAIL) WRITE(LFNPR,1610) KTOPO(IAT1,IAT1) ELSE IF(NCTR.EQ.2) THEN KTOPO(IAT1,IAT2) = NUM - IACCEP KTOPO(IAT2,IAT1) = KTOPO(IAT1,IAT2) IF(DETAIL) WRITE(LFNPR,1610) KTOPO(IAT1,IAT2) ELSE IONE = 1 IF(DETAIL) WRITE(LFNPR,1610) IONE END IF IF(LEFT) THEN IF(OCCMAX.LT.OCC) OCCMAX = OCC ELSE LEFT = .TRUE. OCCMAX = OCC END IF GOTO 280 END IF Check to see if bond orbital "BORB" contains previously used hybrids: IF(NCTR.NE.1) THEN CALL PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,TA,HYB,VA,VB,HYBEXP) IF(DETAIL) THEN DO 220 IHYB = 1,NCTR WRITE(LFNPR,1500) IHYB,HYBEXP(IHYB) 220 CONTINUE END IF DO 230 IHYB = 1,NCTR IF(HYBEXP(IHYB).LT.PRJTHR) GOTO 250 230 CONTINUE END IF IBD = IBD + 1 IACCEP = IACCEP + 1 Decompose "BORB" into its constituent atomic hybrids and store in Q: CALL STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB) Construct bond orbital labels: IF(NCTR.EQ.1) THEN ISHIFT = NTOPO(IAT1,IAT1) - KTOPO(IAT1,IAT1) ELSE IF(NCTR.EQ.2) THEN ISHIFT = NTOPO(IAT1,IAT2) - KTOPO(IAT1,IAT2) ELSE ISHIFT = 0 END IF LABEL(IBD,1) = NAME(NCTR) LABEL(IBD,2) = IBLNK LABEL(IBD,3) = IACCEP + ISHIFT LABEL(IBD,4) = IAT1 LABEL(IBD,5) = IAT2 LABEL(IBD,6) = IAT3 BNDOCC(IBD) = OCC IF(DETAIL) WRITE(LFNPR,1600) IBD,(LABEL(IBD,I),I=1,3) IF(IACCEP.EQ.NUM) THEN IF(NCTR.EQ.1) THEN KTOPO(IAT1,IAT1) = 0 ELSE IF(NCTR.EQ.2) THEN KTOPO(IAT1,IAT2) = 0 KTOPO(IAT2,IAT1) = 0 ELSE KFLG(ICNTR) = 0 END IF GOTO 280 END IF 250 CONTINUE IF(IACCEP.NE.NUM.AND.NCTR.EQ.2.AND.PRINT) * WRITE(LFNPR,2000) PRJTHR,IACCEP,NUM,IAT1,IAT2 IF(IACCEP.NE.NUM.AND.NCTR.EQ.3.AND.PRINT) * WRITE(LFNPR,2100) PRJTHR,IACCEP,NUM,IAT1,IAT2,IAT3 IFLG = -1 280 IF(NCTR.EQ.1.OR.NCTR.EQ.3) THEN GOTO 130 ELSE 290 JCNTR=JCNTR+1 IF(JCNTR.GT.NATOMS) GOTO 130 NUM=KTOPO(IORDER(JCNTR),IORDER(ICNTR)) IF(NUM.EQ.0) GOTO 290 IAT1=IORDER(ICNTR) IAT2=IORDER(JCNTR) IAT3=0 GOTO 200 END IF ******** END OF LOOP FOR DIRECTED NBO SEARCH ********* 300 CONTINUE If some orbitals were left behind, go back and fetch them: IF(LEFT) THEN OCCTHR = OCCMAX GOTO 115 END IF Symmetrically orthogonalize principal hybrids: CALL ORTHYB(Q,BLK,TA,EVAL,C,IALARM,IFLG) IALARM sounds the alarm that there is linear dependency between some of the hybrids. IALARM is equal to the number of the violating atom. Replenish DM from T and repeat the NBO search: IF(IALARM.NE.0) THEN OLDPRJ = PRJTHR PRJTHR = OLDPRJ + PRJINC IF(PRINT) WRITE(LFNPR,1800) OLDPRJ,PRJTHR IF(PRJTHR.GE.PT99) THEN IF(PRINT) WRITE(LFNPR,1810) IALARM IFLG = -1 JPRINT(1) = -1 RETURN END IF GOTO 700 END IF Augment open-valence atoms with non-arbitrary hybrids orthogonal to those found previously: DO 580 IA = 1,NATOMS IF(NOPVAL(IA).LE.0) GOTO 580 Find NMB, the number of natural minimal basis functions on this atom: LLA = LL(IA) IULA = UL(IA) NMB = 0 DO 470 I = LLA,IULA IF(LSTOCC(I).EQ.1) NMB = NMB + 1 470 CONTINUE Find the number of bond, core, and lone pair hybrids on this atom, IOCC. Also find IOCCLP, the number of lone pair orbitals already found on atom IA for use in labelling the extra lone pairs below: IOCC = 0 IOCCLP = 0 DO 480 IB = 1,IBD IF((LABEL(IB,4).NE.IA).AND.(LABEL(IB,5).NE.IA).AND. * (LABEL(IB,6).NE.IA)) GOTO 480 IOCC = IOCC + 1 IF(LABEL(IB,1).EQ.NAME(1)) THEN IOCCLP = IOCCLP + 1 END IF 480 CONTINUE NEXLP, the number of extra (low occupancy) LP orbitals on atom IAT. (This is the number of low occupancy orbitals with valence shell character) Set NEXLP to zero if (NMB-IOCC) is less than zero!! NEXLP = NMB - IOCC IF(NEXLP.LT.0) NEXLP = 0 NOCC = INO(IA) CALL FRMPRJ(P,IA,Q,NOCC,TA,VA,VB) NORB = NORBS(IA) NAUGM = NORB - NOCC CALL AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB) Stash and label extra lone pairs that AUGMNT put in BLK: (These are taken to be the highest occupied orbitals, which AUGMNT places first) DO 510 IAUGM = 1,NEXLP DO 500 J = 1,NORB 500 BORB(J) = BLK(J,IAUGM) IBD = IBD + 1 CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB) LABEL(IBD,1) = NAME(1) LABEL(IBD,2) = ISTAR LABEL(IBD,3) = IAUGM+IOCCLP LABEL(IBD,4) = IA LABEL(IBD,5) = 0 LABEL(IBD,6) = 0 510 CONTINUE Stash and label the Rydberg orbitals that AUGMNT put in BLK: IRYD = 0 NSTART = NEXLP + 1 DO 540 IAUGM = NSTART,NAUGM DO 530 J = 1,NORB 530 BORB(J) = BLK(J,IAUGM) IBD = IBD + 1 IRYD = IRYD + 1 CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB) LABEL(IBD,1) = LRY LABEL(IBD,2) = ISTAR LABEL(IBD,3) = IRYD LABEL(IBD,4) = IA LABEL(IBD,5) = 0 LABEL(IBD,6) = 0 540 CONTINUE 580 CONTINUE Include antibond labels: IBO = IBD DO 660 I = 1,IBO Exit loop if LABEL(I,1) is 'LP', 'RY', OR 'CR': IF(LABEL(I,1).EQ.NAME(1)) GOTO 660 IF(LABEL(I,1).EQ.LRY) GOTO 660 IF(LABEL(I,1).EQ.LCR) GOTO 660 NAB = 1 IF(LABEL(I,1).EQ.NAME(3)) NAB = 2 DO 650 IAB = 1,NAB IBD = IBD + 1 DO 640 J = 1,6 640 LABEL(IBD,J) = LABEL(I,J) LABEL(IBD,2) = ISTAR 650 CONTINUE 660 CONTINUE IF(IBD.EQ.NBAS) GOTO 670 WRITE(LFNPR,2200) STOP 670 CONTINUE Replace density matrix DM from T: 700 CONTINUE DO 750 J = 1,NBAS DO 740 I = 1,J DM(I,J) = T(I,J) DM(J,I) = DM(I,J) T(J,I) = ZERO T(I,J) = ZERO 740 CONTINUE 750 CONTINUE If the alarm sounded, repeat directed NBO search: IF(IALARM.NE.0) GOTO 35 Find new polarization parameters for orthonormal hybrids: CALL REPOL(DM,Q,POL,BLK,EVAL,C,IBD) Form final T-NAB (NAO to NBO transformation) from orthonormal hybrids: CALL FORMT(T,Q,POL) Find occupancies, find total number of electrons and occupied orbitals: TOTELE = ZERO DO 800 I = 1,NBAS OCCI = ZERO DO 790 J = 1,NBAS DO 790 K = 1,NBAS 790 OCCI = OCCI + T(J,I) * DM(J,K) * T(K,I) IF(ABS(OCCI).LT.ZEROP) OCCI = ZERO IF(OCCI.GT.TWOP) GO TO 960 ZEROPM = -ZEROP IF(OCCI.LT.ZEROPM) GO TO 960 BNDOCC(I) = OCCI V(I) = OCCI TOTELE = TOTELE + BNDOCC(I) 800 CONTINUE NEL = TOTELE + TENTH IF(ABS(TOTELE-NEL).GT.5E-4) GO TO 965 TOTELE = NEL NOCC = NEL IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2) If the number of unstarred orbitals is not equal to the number of occupied MOs, then simply rank the orbitals by occupancy, and ``unstarr'' the NOCC highest occupied: (This can be dangerous! However, many of the subsequent routines assume the only NOCC orbitals are starred, and therefore, this mismatch must be corrected.) NOSTR = 0 DO 801 I = 1,NBAS IF(LABEL(IBXM(I),2).NE.ISTAR) NOSTR = NOSTR + 1 801 CONTINUE IF(NOSTR.NE.NOCC) THEN CALL RANK(V,NBAS,NDIM,LARC) DO 804 I = 1,NOCC IR = LARC(I) LABEL(IBXM(IR),2) = IBLNK 804 CONTINUE DO 805 I = NOCC+1,NBAS IR = LARC(I) LABEL(IBXM(IR),2) = ISTAR 805 CONTINUE END IF Determine whether this is a good resonance structure: CALL CYCLES(ITER,ABS(THRSET),GUIDE,BNDOCC,TOPO,ICONT) Write out info about core orbitals which were isolated in subroutine CORE: IF(.NOT.PRINT) GOTO 953 CRTHRS = CRTSET IF(ISPIN.NE.0) CRTHRS = CRTHRS - ONE FIRST = .TRUE. DO 952 IAT = 1,NATOMS ILOW = 0 DO 951 I = 1,NBAS IF(LABEL(IBXM(I),1).EQ.LCR.AND.LABEL(IBXM(I),4).EQ.IAT + .AND.BNDOCC(I).LT.CRTHRS) ILOW = ILOW + 1 951 CONTINUE IF(ILOW.NE.0) THEN IF(FIRST) THEN FIRST = .FALSE. NAM = NAMEAT(IATNO(IAT)) IF(ILOW.NE.1) THEN WRITE(LFNPR,3010) ILOW,CRTHRS,NAM,IAT ELSE WRITE(LFNPR,3011) ILOW,CRTHRS,NAM,IAT END IF ELSE NAM = NAMEAT(IATNO(IAT)) IF(ILOW.NE.1) THEN WRITE(LFNPR,3020) ILOW,CRTHRS,NAM,IAT ELSE WRITE(LFNPR,3021) ILOW,CRTHRS,NAM,IAT END IF END IF END IF 952 CONTINUE 953 CONTINUE RETURN Bad orbital occupancy: 960 IF(PRINT) WRITE(LFNPR,1300) OCCI IFLG = -1 JPRINT(1) = -1 RETURN Total number of electrons is not an integer: 965 WRITE(LFNPR,1310) TOTELE IFLG = -1 JPRINT(1) = -1 RETURN 1300 FORMAT(/,1X,'A bond orbital with an occupancy of ',F8.5, + ' electrons was found!',/,1X,'Please check you input data.') 1310 FORMAT(/,1X,'The total number of electron is not an integer:', + F10.5,/,1X,'Please check your input data.') 1400 FORMAT(/,1X,'Search of DM block between the following atoms:', + 3I4) 1402 FORMAT(6X,'Select ',I2,' orbital(s) with eigenvalue > ',F9.6) 1405 FORMAT(6X,8F9.6) 1410 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':') 1420 FORMAT(11X,8F7.4) 1500 FORMAT(11X,'Hybrid ',I1,' in eigenvector has a projection ', + 'expectation of ',F6.3) 1600 FORMAT(11X,'*** NBO accepted: Number',I3,'. Label:',A2,A1, + '(',I2,')') 1610 FORMAT(1X,'Still need to find',I2,' more orbital(s)') 1800 FORMAT(/4X,'PRJTHR will be raised from ',F6.3,' to',F6.3, + ' and the NBO search repeated.',/) 1810 FORMAT(//,1X,'Linearly independent hybrids for atom',I3, +' cannot be found.',/,1X,'The NBO program must abort.') 2000 FORMAT(/,1X,'At a projection threshold of',F6.3,', only ',I1, + ' of the ',I1,' requested bonds',/,1X,'between atoms ',I2, + ' and ',I2,' can be constructed. The NBO analysis will',/, + 1X,'continue, augmenting the NBO set with extra lone pairs ', + 'on the atoms',/,1X,'as necessary.') 2100 FORMAT(/,1X,'At a projection threshold of',F6.3,', only ',I1, + ' of the ',I1,' requested bonds',/,1X,'between atoms ',I2,', ', + I2,', and ',I2,' can be constructed. The NBO analysis',/,1X, + 'will continue, augmenting the NBO set with extra lone pairs ', + 'on the',/,1X,'atoms as necessary.') 2200 FORMAT(/,1X,'Miscounted orbitals, program must abort') 3010 FORMAT(/,1X, +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals ', +'found on ',A2,I2) 3011 FORMAT(/,1X, +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbital ', +'found on ',A2,I2) 3020 FORMAT(1X, +' ',I3,' low occupancy (<',F6.4,'e) core orbitals ', +'found on ',A2,I2) 3021 FORMAT(1X, +' ',I3,' low occupancy (<',F6.4,'e) core orbital ', +'found on ',A2,I2) END ***************************************************************************** SUBROUTINE SRTNBO(T,BNDOCC) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL PERMUT PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) DIMENSION T(NDIM,NDIM),BNDOCC(NDIM) DIMENSION NAME(3) DATA LBD,L3C,NAME,LSTAR/'BD','3C','CR','LP','RY','*'/ Reorder the NBOs according to bond type and constituent atomic centers: Fix atom ordering in the NBO labels: DO 100 I = 1,NBAS NCTR = 0 DO 10 J = 4,6 IF(LABEL(I,J).NE.0) THEN NCTR = NCTR + 1 LARC(NCTR) = LABEL(I,J) END IF 10 CONTINUE DO 30 J = 1,NCTR-1 DO 20 K = 1,NCTR-J IF(LARC(K).GT.LARC(K+1)) THEN ITEMP = LARC(K) LARC(K) = LARC(K+1) LARC(K+1) = ITEMP END IF 20 CONTINUE 30 CONTINUE DO 40 J = 1,NCTR LABEL(I,J+3) = LARC(J) 40 CONTINUE DO 50 J = NCTR+1,3 LABEL(I,J+3) = 0 50 CONTINUE 100 CONTINUE Place the 2- and 3-center bonds first in the list of NBOs: (No bonds if the NOBOND keyword was specified) ICNT = 0 IF(JPRINT(10).EQ.0) THEN DO 200 I = 1,NATOMS-1 DO 190 J = I+1,NATOMS IF(I.NE.J) THEN K = -1 110 K = K + 1 DO 180 L = ICNT+1,NBAS LBL1 = LABEL(IBXM(L),1) LBL2 = LABEL(IBXM(L),2) LBL3 = LABEL(IBXM(L),3) LBL4 = LABEL(IBXM(L),4) LBL5 = LABEL(IBXM(L),5) LBL6 = LABEL(IBXM(L),6) IF((LBL1.EQ.LBD.OR.LBL1.EQ.L3C).AND.LBL2.NE.LSTAR) THEN IF(LBL4.EQ.I.AND.LBL5.EQ.J.AND.LBL6.EQ.K) THEN ICNT = ICNT + 1 LABEL(IBXM(L),1) = LABEL(IBXM(ICNT),1) LABEL(IBXM(L),2) = LABEL(IBXM(ICNT),2) LABEL(IBXM(L),3) = LABEL(IBXM(ICNT),3) LABEL(IBXM(L),4) = LABEL(IBXM(ICNT),4) LABEL(IBXM(L),5) = LABEL(IBXM(ICNT),5) LABEL(IBXM(L),6) = LABEL(IBXM(ICNT),6) LABEL(IBXM(ICNT),1) = LBL1 LABEL(IBXM(ICNT),2) = LBL2 LABEL(IBXM(ICNT),3) = LBL3 LABEL(IBXM(ICNT),4) = LBL4 LABEL(IBXM(ICNT),5) = LBL5 LABEL(IBXM(ICNT),6) = LBL6 TEMP = BNDOCC(L) BNDOCC(L) = BNDOCC(ICNT) BNDOCC(ICNT) = TEMP DO 170 M = 1,NBAS TEMP = T(M,L) T(M,L) = T(M,ICNT) T(M,ICNT) = TEMP 170 CONTINUE END IF END IF 180 CONTINUE IF(IW3C.NE.0.AND.K.EQ.0) K = J IF(K.GT.0.AND.K.LT.NATOMS) GOTO 110 END IF 190 CONTINUE 200 CONTINUE END IF Next add any core, lone pair, and Rydberg orbitals: DO 300 II = 1,3 DO 290 I = 1,NATOMS DO 280 J = ICNT+1,NBAS LBL1 = LABEL(IBXM(J),1) LBL4 = LABEL(IBXM(J),4) IF(LBL1.EQ.NAME(II).AND.LBL4.EQ.I) THEN ICNT = ICNT + 1 DO 260 K = 1,6 ITEMP = LABEL(IBXM(J),K) LABEL(IBXM(J),K) = LABEL(IBXM(ICNT),K) LABEL(IBXM(ICNT),K) = ITEMP 260 CONTINUE TEMP = BNDOCC(J) BNDOCC(J) = BNDOCC(ICNT) BNDOCC(ICNT) = TEMP DO 270 K = 1,NBAS TEMP = T(K,J) T(K,J) = T(K,ICNT) T(K,ICNT) = TEMP 270 CONTINUE END IF 280 CONTINUE 290 CONTINUE 300 CONTINUE Add in any antibonds: IF(JPRINT(10).EQ.0) THEN DO 400 I = 1,NATOMS-1 DO 390 J = I+1,NATOMS IF(I.NE.J) THEN K = -1 IF(IW3C.NE.0) K = J 310 K = K + 1 DO 380 L = ICNT+1,NBAS LBL1 = LABEL(IBXM(L),1) LBL2 = LABEL(IBXM(L),2) LBL3 = LABEL(IBXM(L),3) LBL4 = LABEL(IBXM(L),4) LBL5 = LABEL(IBXM(L),5) LBL6 = LABEL(IBXM(L),6) IF((LBL1.EQ.LBD.OR.LBL1.EQ.L3C).AND.LBL2.EQ.LSTAR) THEN IF(LBL4.EQ.I.AND.LBL5.EQ.J.AND.LBL6.EQ.K) THEN ICNT = ICNT + 1 LABEL(IBXM(L),1) = LABEL(IBXM(ICNT),1) LABEL(IBXM(L),2) = LABEL(IBXM(ICNT),2) LABEL(IBXM(L),3) = LABEL(IBXM(ICNT),3) LABEL(IBXM(L),4) = LABEL(IBXM(ICNT),4) LABEL(IBXM(L),5) = LABEL(IBXM(ICNT),5) LABEL(IBXM(L),6) = LABEL(IBXM(ICNT),6) LABEL(IBXM(ICNT),1) = LBL1 LABEL(IBXM(ICNT),2) = LBL2 LABEL(IBXM(ICNT),3) = LBL3 LABEL(IBXM(ICNT),4) = LBL4 LABEL(IBXM(ICNT),5) = LBL5 LABEL(IBXM(ICNT),6) = LBL6 TEMP = BNDOCC(L) BNDOCC(L) = BNDOCC(ICNT) BNDOCC(ICNT) = TEMP DO 370 M = 1,NBAS TEMP = T(M,L) T(M,L) = T(M,ICNT) T(M,ICNT) = TEMP 370 CONTINUE END IF END IF 380 CONTINUE IF(K.GT.0.AND.K.LT.NATOMS) GOTO 310 END IF 390 CONTINUE 400 CONTINUE END IF Lastly, make sure orbitals are ordered by serial number: 410 PERMUT = .FALSE. DO 500 I = 1,NBAS-1 IF(LABEL(IBXM(I),1).EQ.LABEL(IBXM(I+1),1)) THEN IF(LABEL(IBXM(I),2).EQ.LABEL(IBXM(I+1),2)) THEN IF(LABEL(IBXM(I),4).EQ.LABEL(IBXM(I+1),4)) THEN IF(LABEL(IBXM(I),5).EQ.LABEL(IBXM(I+1),5)) THEN IF(LABEL(IBXM(I),6).EQ.LABEL(IBXM(I+1),6)) THEN IF(LABEL(IBXM(I),3).GT.LABEL(IBXM(I+1),3)) THEN PERMUT = .TRUE. LBL3 = LABEL(IBXM(I),3) LABEL(IBXM(I),3) = LABEL(IBXM(I+1),3) LABEL(IBXM(I+1),3) = LBL3 TEMP = BNDOCC(I) BNDOCC(I) = BNDOCC(I+1) BNDOCC(I+1) = TEMP DO 490 J = 1,NBAS TEMP = T(J,I) T(J,I) = T(J,I+1) T(J,I+1) = TEMP 490 CONTINUE END IF END IF END IF END IF END IF END IF 500 CONTINUE IF(PERMUT) GOTO 410 RETURN END ***************************************************************************** SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL FIRST PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),HYB(MXAO),THYB(NDIM,NDIM), + S(NDIM,NDIM),OCC(NDIM),SCR(NDIM),ISCR(NDIM) DIMENSION PCT(5),IAT(3) DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/ DATA ZERO,TENTH,ONE,THRESH/0.0D0,0.1D0,1.0D0,1.0D-4/ DATA LSTAR,LBLNK/'*',' '/ Form a temporary NAO to NHO transformation matrix. Check hybrid overlap to make sure the NBO's were properly labelled as Lewis and non-Lewis orbitals: Count number of hybrids as they are written out: NHYB = 0 Main loop over bond orbitals: DO 200 NBOND = 1,NBAS IB = IBXM(NBOND) LBL = LABEL(IB,1) IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR = 1 IF(LBL.EQ.LBD) NCTR = 2 IF(LBL.EQ.L3C) NCTR = 3 Loop over atomic centers of bond orbital NBOND: DO 190 ICTR = 1,NCTR I = LABEL(IB,ICTR+3) KL = LL(I) KU = LU(I) DO 120 K = 1,MXAO LTYP(K) = 0 120 HYB(K) = ZERO Choose sign for polarization coefficients: ISGN = 1 IF(LABEL(IB,2).NE.LSTAR) GO TO 130 IF(ICTR.LT.2) GO TO 130 IF(ICTR.EQ.3) IPAR3C = -IPAR3C IF(ICTR.EQ.3.AND.IPAR3C.GT.0) GO TO 130 ISGN = -ISGN 130 CONTINUE Extract hybrid (HYB) from transformation matrix T; LTYP(I) is the orbital angular momentum quantum no. of A.O. # I: KH = 0 DO 140 K = KL,KU KH = KH + 1 HYB(KH) = T(K,NBOND) 140 LTYP(KH) = NAOA(K)/100 CALL HTYPE(HYB,LTYP,MXAO,KH,COEF,PCT,NL,ISGN) IF(ABS(COEF).LT.THRESH) GO TO 190 Check to see if this orbital has been found before: DO 160 IHYB = 1,NHYB TEMP = ZERO IH = 0 DO 150 K = KL,KU IH = IH + 1 TEMP = TEMP + HYB(IH)*THYB(K,IHYB) 150 CONTINUE IF(ABS(ABS(TEMP)-ONE).LT.THRESH) GO TO 190 IF(ABS(TEMP).GT.THRESH) THEN WRITE(LFNPR,900) NHYB+1,NBOND,ICTR,TEMP,IHYB STOP END IF 160 CONTINUE Add this hybrid to the temporary THYB: NHYB = NHYB + 1 IF(NHYB.GT.NBAS) STOP 'Too many hybrids' DO 170 K = 1,NBAS THYB(K,NHYB) = ZERO 170 CONTINUE IH = 0 DO 180 K = KL,KU IH = IH + 1 THYB(K,NHYB) = HYB(IH) 180 CONTINUE 190 CONTINUE 200 CONTINUE IF(NHYB.LT.NBAS) STOP 'Missing hybrids' THYB now contains the temporary NAO to NHO transformation matrix. Form the non-orthogonal PNHO overlap and NHO to NBO transformation matrices: CALL FESNAO(S) CALL SIMTRS(S,THYB,SCR,NDIM,NBAS) CALL TRANSP(THYB,NDIM,NBAS) CALL MATMLT(THYB,T,SCR,NDIM,NBAS) Check to see that the bonds and antibonds have the correct hybrid overlap. Fix the labels if there is a problem: FIRST = .TRUE. DO 300 NBOND = 1,NBAS IB = IBXM(NBOND) LBL1 = LABEL(IB,1) IF(LBL1.EQ.LLP.OR.LBL1.EQ.LCR.OR.LBL1.EQ.LRY) ICTR = 1 IF(LBL1.EQ.LBD) ICTR = 2 IF(LBL1.EQ.L3C) ICTR = 3 NCTR = 0 DO 210 IHYB = 1,NHYB IF(ABS(THYB(IHYB,NBOND)).GT.THRESH) THEN NCTR = NCTR + 1 IF(NCTR.GT.3) THEN WRITE(LFNPR,910) NBOND STOP END IF IAT(NCTR) = IHYB END IF 210 CONTINUE IF(NCTR.GT.ICTR) THEN WRITE(LFNPR,920) ICTR,NBOND,NCTR STOP END IF IF(NCTR.GT.1) THEN ISGN = 1 DO 230 JCTR = 1,NCTR-1 DO 220 KCTR = JCTR+1,NCTR JHYB = IAT(JCTR) KHYB = IAT(KCTR) TEMP = S(JHYB,KHYB)*THYB(JHYB,NBOND)*THYB(KHYB,NBOND) IF(TEMP.LT.ZERO) ISGN = -1 220 CONTINUE 230 CONTINUE LBL2 = LABEL(IB,2) IF(LBL2.EQ.LBLNK.AND.ISGN.EQ.-1) THEN IF(FIRST.AND.JPRINT(5).NE.0) WRITE(LFNPR,930) FIRST = .FALSE. LABEL(IB,2) = LSTAR IF(JPRINT(5).NE.0) WRITE(LFNPR,940) NBOND,LBL1,LSTAR ELSE IF(LBL2.EQ.LSTAR.AND.ISGN.EQ.1) THEN IF(FIRST.AND.JPRINT(5).NE.0) WRITE(LFNPR,930) FIRST = .FALSE. LABEL(IB,2) = LBLNK IF(JPRINT(5).NE.0) WRITE(LFNPR,940) NBOND,LBL1,LBLNK END IF END IF 300 CONTINUE Determine the number of occupied orbitals: TOT = ZERO DO 310 I = 1,NBAS TOT = TOT + DM(I,I) 310 CONTINUE NOCC = TOT + TENTH IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2) Count the number of unstarred orbitals: ICNT = 0 DO 320 I = 1,NBAS IF(LABEL(IBXM(I),2).NE.LSTAR) ICNT = ICNT + 1 320 CONTINUE If the number of unstarred orbitals is not equal to the number of occupied orbitals, fix the orbital labels: IF(ICNT.NE.NOCC) THEN DO 330 I = 1,NBAS OCC(I) = DM(I,I) 330 CONTINUE CALL RANK(OCC,NBAS,NDIM,ISCR) If there are more unstarred orbitals than occupied, add stars to the least occupied lone pairs: IF(ICNT.GT.NOCC) THEN IDIFF = ICNT - NOCC DO 350 I = 1,IDIFF IP = 0 DO 340 J = 1,NBAS JP = IBXM(ISCR(J)) IF(LABEL(JP,1).EQ.LLP.AND.LABEL(JP,2).NE.LSTAR) IP = J 340 CONTINUE IF(IP.EQ.0) THEN WRITE(LFNPR,950) ICNT,NOCC STOP END IF LABEL(IBXM(ISCR(IP)),2) = LSTAR IF(JPRINT(5).NE.0) WRITE(LFNPR,940) ISCR(IP), + LABEL(IBXM(ISCR(IP)),1),LSTAR 350 CONTINUE Remove stars from the highest occupied lone pairs/Rydbergs if there are too few starred orbitals: ELSE IDIFF = NOCC - ICNT DO 370 I = 1,IDIFF IP = 0 DO 360 J = NBAS,1,-1 JP = IBXM(ISCR(J)) IF((LABEL(JP,1).EQ.LLP.OR.LABEL(JP,1).EQ.LRY) + .AND.LABEL(JP,2).EQ.LSTAR) IP = J 360 CONTINUE IF(IP.EQ.0) THEN WRITE(LFNPR,950) ICNT,NOCC STOP END IF LABEL(IBXM(ISCR(IP)),2) = LBLNK IF(JPRINT(5).NE.0) WRITE(LFNPR,940) ISCR(IP), + LABEL(IBXM(ISCR(IP)),1),LBLNK 370 CONTINUE END IF END IF RETURN 900 FORMAT(/1X,'Hybrid ',I3,' (NBO ',I3,', Center ',I2,') has a ', + 'non-negligible overlap of ',F8.5,/,1X,'with hybrid ',I3,'.') 910 FORMAT(/1X,'NBO ',I3,' has hybrid contributions from more than ', + '3 atomic centers.') 920 FORMAT(/1X,'Error: the ',I1,'-center NBO ',I3,' has ', + 'contributions from ',I2,' atomic centers.') 930 FORMAT(/1X,' --- Apparent excited state configuration ', + '---',/1X,'The following "inverted" NBO labels reflect the ', + 'actual hybrid overlap:') 940 FORMAT(1X,' NBO ',I3,' has been relabelled ',A2,A1) 950 FORMAT(/1X,'Unable to label the NBOs properly: ',I3,' unstarred ', + 'orbitals',/1X,' ',I3, + ' occupied orbitals') END ***************************************************************************** SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) INTEGER UL Print out details of bond-orbital transformation from matrix T. Required input: T = Transformation matrix from S.R. NATHYB; REAL (1,NDIM;1,NDIM) NDIM = Declared dimensionality of array T NBAS = No. of orbitals = actual dimension of T, NAOL NAOL = Integer list of orbital angular momentum type NAOL(I)/100 = l = Q.N. of atomic orbital I IATNO = List of atomic numbers; IATNO(I) is the atomic number of atom I as an integer NATOMS = No. of atoms (not including ghosts) in the molecule IWHYBS = 1 if hybrid A.O. coefficients are to be printed, 0 otherwise LFNPR = Logical file number for printout. NAOCTR = List of atomic centers of OAO or NAO basis orbitals LABEL = List of bond orbital labels IBXM = Permutation list of bond orbitals BNDOCC = List of bond orbital occupancies ISPIN = 0 for spinless NBOs = 2 for alpha spin NBOs =-2 for beta spin NBOs PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR DIMENSION T(NDIM,NDIM),HYB(MXAO),BNDOCC(NDIM),THYB(NDIM,NDIM), * PCT(5),POW(5),LNAME(5),ISP(3),NAM(3),ICH(3,2),HYCOEF(NDIM) DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/ DATA LNAME/'s','p','d','f','g'/ DATA ZERO,THRESH,T99,T99P/0.0D0,1.D-2,99.99D0,99.995D0/ DATA TENTH,HUNDRD,TTHOTH/0.1D0,100.0D0,0.0001D0/ DATA LHYP,LBLNK,LSTAR,L2BLNK/'-',' ','*',' '/ Count the number of electrons: TOTELE = ZERO DO 20 I = 1,NBAS TOTELE = TOTELE + BNDOCC(I) 20 CONTINUE TOTELE = TOTELE + TENTH NEL = TOTELE TOTELE = NEL Count the number of core orbitals and the occupancies of the core, valence Lewis, valence non-Lewis, and extra-valence Rydberg orbitals. (Also count the number of electrons in the ECP, if employed) MCR = 0 OCCCR = ZERO OCCVL = ZERO OCCVNL = ZERO DO 50 I = 1,NBAS IF(LABEL(IBXM(I),2).NE.LSTAR) THEN IF(LABEL(IBXM(I),1).EQ.LCR) THEN MCR = MCR + 1 OCCCR = OCCCR + BNDOCC(I) ELSE OCCVL = OCCVL + BNDOCC(I) END IF ELSE IF(LABEL(IBXM(I),1).NE.LRY) THEN OCCVNL = OCCVNL + BNDOCC(I) END IF END IF 50 CONTINUE OCCEVR = TOTELE - OCCCR - OCCVL - OCCVNL IF(ISPIN.EQ.0) THEN MCR = 2 * MCR END IF MVL = NEL - MCR MECP = 0 IF(IPSEUD.NE.0) THEN DO 60 I = 1,NATOMS MECP = MECP + IATNO(I) - IZNUC(I) 60 CONTINUE IF(ISPIN.NE.0) MECP = MECP/2 END IF MLEW = MCR + MVL + MECP OCCLEW = OCCCR + OCCVL + MECP OCCNON = OCCVNL + OCCEVR Write summary of NBO occupancies: IF(JPRINT(5).EQ.1.AND.NEL.NE.0) THEN WRITE(LFNPR,2000) IF(IPSEUD.NE.0) WRITE(LFNPR,2010) FLOAT(MECP) IF(MCR.NE.0) THEN PCENT = OCCCR/MCR * HUNDRD WRITE(LFNPR,2020) OCCCR,PCENT,MCR END IF IF(MVL.NE.0) THEN PCENT = OCCVL/MVL * HUNDRD WRITE(LFNPR,2030) OCCVL,PCENT,MVL END IF WRITE(LFNPR,2040) PCENT = OCCLEW/MLEW * HUNDRD WRITE(LFNPR,2050) OCCLEW,PCENT,MLEW WRITE(LFNPR,2060) PCENT = OCCVNL/MLEW * HUNDRD WRITE(LFNPR,2070) OCCVNL,PCENT,MLEW PCENT = OCCEVR/MLEW * HUNDRD WRITE(LFNPR,2080) OCCEVR,PCENT,MLEW WRITE(LFNPR,2040) PCENT = OCCNON/MLEW * HUNDRD WRITE(LFNPR,2090) OCCNON,PCENT,MLEW WRITE(LFNPR,2100) END IF Write out NBOs: IF(JPRINT(5).EQ.1) THEN WRITE(LFNPR,1000) WRITE(LFNPR,1100) (LHYP,J=1,79) END IF Main loop over bond orbitals: NHYB = 0 MHYB = 0 IPAR3C = 1 DO 180 NBOND = 1,NBAS IB = IBXM(NBOND) LBL = LABEL(IB,1) IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR = 1 IF(LBL.EQ.LBD) NCTR = 2 IF(LBL.EQ.L3C) NCTR = 3 DO 110 I = 1,3 IA = LABEL(IB,I+3) CALL CONVRT(IA,ICH(I,1),ICH(I,2)) NAM(I) = L2BLNK IF(IA.GT.0) NAM(I) = NAMEAT(IATNO(IA)) ISP(I) = LHYP IF(I.GE.NCTR) ISP(I) = LBLNK 110 CONTINUE Loop over atomic centers of bond orbital NBOND: DO 170 ICTR = 1,NCTR I = LABEL(IB,ICTR+3) NEL = NAMEAT(IATNO(I)) KL = LL(I) KU = UL(I) DO 120 K = 1,MXAO LTYP(K) = 0 120 HYB(K) = ZERO Choose sign for polarization coefficients: ISGN = 1 IF(LABEL(IB,2).NE.LSTAR) GO TO 130 IF(ICTR.LT.2) GO TO 130 IF(ICTR.EQ.3) IPAR3C = -IPAR3C IF(ICTR.EQ.3.AND.IPAR3C.GT.0) GO TO 130 ISGN = -ISGN 130 CONTINUE Extract hybrid (HYB) from transformation matrix T; LTYP(I) is the orbital angular momentum quantum no. of A.O. # I: KH = 0 DO 140 K = KL,KU KH = KH + 1 HYB(KH) = T(K,NBOND) 140 LTYP(KH) = NAOA(K)/100 CALL HTYPE(HYB,LTYP,MXAO,KH,COEF,PCT,NL,ISGN) Find leading non-zero contribution to determine POW(L) for each L: LSTD = 0 DO 160 L = 1,NL IF(LSTD.GT.0) GO TO 150 POW(L) = ZERO STD = PCT(L) IF(STD.LT.THRESH) GO TO 160 LSTD = L 150 POW(L) = PCT(L)/STD IF(POW(L).GT.T99P) POW(L) = T99 160 CONTINUE Write out NHO for center ICTR: COEFSQ = COEF * COEF * HUNDRD NL1 = NL IF(NL1.GT.3) NL1 = 3 IF(ICTR.EQ.1.AND.NCTR.EQ.1.AND.JPRINT(5).EQ.1) + WRITE(LFNPR,1210) NBOND,BNDOCC(NBOND), + (LABEL(IB,K),K=1,3),NAM(1),ICH(1,1),ICH(1,2), + PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1) IF(ICTR.EQ.1.AND.NCTR.GT.1.AND.JPRINT(5).EQ.1) + WRITE(LFNPR,1220) NBOND,BNDOCC(NBOND), + (LABEL(IB,K),K=1,3), + (NAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3) IF(NCTR.NE.1.AND.JPRINT(5).EQ.1) WRITE(LFNPR,1300) COEFSQ, + COEF,NEL,I,PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1) IF(NL.GT.3.AND.JPRINT(5).EQ.1) WRITE(LFNPR,1310) + (LNAME(L),POW(L),PCT(L),L=4,NL) IF(IWHYBS.NE.0.AND.BNDOCC(NBOND).GT.TTHOTH.AND.JPRINT(5).EQ.1) + WRITE(LFNPR,1500) (HYB(K),K=1,KH) CALL FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB) If this is a new hybrid, form its label: IF(MHYB.NE.NHYB) THEN MHYB = NHYB CALL LBLNHO(NHYB,NBOND,ICTR,NCTR) END IF 170 CONTINUE 180 CONTINUE RETURN 1000 FORMAT(//,1X,' (Occupancy) Bond orbital/ Coefficients/ ', + 'Hybrids') 1100 FORMAT(1X,80A1) 1210 FORMAT(1X,I3,'. (',F7.5,') ',A2,A1,'(',I2,')',A2,2A1,12X, + ' s(',F6.2,'%)',2(A1,F5.2,'(',F6.2,'%)')) 1220 FORMAT(1X,I3,'. (',F7.5,') ',A2,A1,'(',I2,')',3(A2,3A1)) 1300 FORMAT(16X,'(',F6.2,'%)',2X, + F7.4,'*',A2,I2,' s(',F6.2,'%)',2(A1,F5.2,'(',F6.2,'%)')) 1310 FORMAT(50X,2(A1,F5.2,'(',F6.2,'%)')) 1500 FORMAT(39X,5F8.4) 2000 FORMAT(/,1X,56('-')) 2010 FORMAT(1X,' Effective Core ',F9.5) 2020 FORMAT(1X,' Core ',F9.5,' (',F7.3,'% of ', + I3,')') 2030 FORMAT(1X,' Valence Lewis ',F9.5,' (',F7.3,'% of ', + I3,')') 2040 FORMAT(2X,18('='),7X,28('=')) 2050 FORMAT(1X,' Total Lewis ',F9.5,' (',F7.3,'% of ', + I3,')') 2060 FORMAT(2X,53('-')) 2070 FORMAT(1X,' Valence non-Lewis ',F9.5,' (',F7.3,'% of ', + I3,')') 2080 FORMAT(1X,' Rydberg non-Lewis ',F9.5,' (',F7.3,'% of ', + I3,')') 2090 FORMAT(1X,' Total non-Lewis ',F9.5,' (',F7.3,'% of ', + I3,')') 2100 FORMAT(1X,56('-')) END ***************************************************************************** SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION HYB(MXAO),LTYP(MXAO),PCT(5) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF ANALYZE INPUT HYBRID 'HYB' FOR POLARIZATION COEFFICIENT 'COEF' AND PERCENTAGES OF EACH ANGULAR MOMENTUM COMPONENT. DATA ZERO,THRESH,HUNDRD/0.0D0,1.D-4,100.0D0/ NL = 0 ZERO PERCENTAGES AND POLARIZATION COEFFICIENT: DO 10 L1 = 1,5 10 PCT(L1) = ZERO COEF = ZERO LOOP OVER ATOMIC CONTRIBUTIONS TO HYBRID, COMPUTING PERCENTAGES AND POLARIZATION COEFFICIENT: DO 20 I = 1,NH L1 = LTYP(I) + 1 IF(L1.GT.5) GO TO 800 PCT(L1) = PCT(L1) + HYB(I)**2 20 COEF = COEF + HYB(I)**2 IF(ABS(COEF).LT.THRESH) RETURN CALCULATE PERCENTAGE CONTRIBUTION FOR EACH ANGULAR SYMMETRY: DO 30 L1 = 1,5 30 PCT(L1) = PCT(L1)/COEF*HUNDRD COEF = SQRT(COEF) SWITCH THE SIGN OF THE COEFFICIENT IF ISGN IS NEGATIVE: IF(ISGN.LT.0) COEF = -COEF NORMALIZE THE HYBRID: DO 50 I = 1,NH 50 HYB(I) = HYB(I)/COEF FIND THE MAXIMUM NUMBER OF ANGULAR MOMENTUM TYPES (NL): DO 60 I = 1,NH IF(ABS(HYB(I)).LT.THRESH) GO TO 60 IF(LTYP(I).LE.NL) GO TO 60 NL = LTYP(I) 60 CONTINUE NL = NL + 1 RETURN 800 CONTINUE WRITE(LFNPR,900) L1-1 STOP 900 FORMAT(/1X,'AO with unknown angular symmetry, l = ',I3) END ***************************************************************************** SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION HYB(1),THYB(NDIM,NDIM),HYCOEF(NDIM) DATA ZERO,ONE,THRESH/0.0D0,1.0D0,1.0D-4/ FORM FULL NAO TO NHO TRANFORMATION IN THYB, ADDING ONE HYBRID WITH EACH CALL. PUT POLARIZATION COEF IN HYCOEF FOR EACH HYBRID. MAKE SURE THIS HYBRID ISN'T ALREADY IN THE LIST: IF(ABS(COEF).LT.THRESH) RETURN DO 20 IHYB = 1,NHYB TEMP = ZERO IH = 0 DO 10 K = KL,KU IH = IH + 1 TEMP = TEMP + HYB(IH)*THYB(K,IHYB) 10 CONTINUE IF(ABS(ABS(TEMP)-ONE).LT.THRESH) RETURN IF(ABS(TEMP).GT.THRESH) THEN WRITE(LFNPR,900) NHYB+1,TEMP,IHYB STOP END IF 20 CONTINUE ADD THIS HYBRID TO THE LIST: NHYB = NHYB + 1 IF(NHYB.GT.NBAS) STOP 'Too many hybrids' DO 50 I = 1,NBAS THYB(I,NHYB) = ZERO 50 CONTINUE IH = 0 DO 70 I = KL,KU IH = IH + 1 THYB(I,NHYB) = HYB(IH) 70 CONTINUE HYCOEF(NHYB) = COEF IF(NHYB.NE.NBAS) RETURN CALL SVTNHO(THYB) RETURN 900 FORMAT(/1X,'Hybrid ',I3,' has a ', + 'non-negligible overlap of ',F8.5,' with hybrid ',I3,'.') END ***************************************************************************** SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS), + IPRIN(MAXBAS) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION BNDOCC(NDIM),ATCOOR(NATOMS*3),THYB(NDIM,NDIM), + TBND(NDIM,NDIM),SCR(NDIM) DIMENSION ISTR(8),PHYB(3),XYZ(3,2),KHYB(3),AZI(2),POL(2),DEV(2) DIMENSION ISKIP(2) DATA LCR,LLP,LRY,LBD,L3C/'CR','LP','RY','BD','3C'/ DATA LHYP/'-'/ DATA ZERO,ONE,THRESH,CUTOFF/0.0D0,1.0D0,1.0D-4,1.0D-8/ Compute hybrid directionality and bond bending for selected NBO's: Thresholds: ATHR -- Angular deviation threshold PTHR -- Percentage p-character threshold ETHR -- Occupancy threshold CONV = 180.0/(4.0*ATAN(ONE)) WRITE(LFNPR,900) ABS(ATHR),ABS(PTHR),ABS(ETHR) Get atomic centers, NAO to NHO trans., and NAO to NBO trans.: CALL FECOOR(ATCOOR) CALL FETNHO(THYB) CALL FETNAB(TBND) CALL TRANSP(TBND,NDIM,NBAS) CALL MATMLT(TBND,THYB,SCR,NDIM,NBAS) Loop over NBOs: ICNT = 0 DO 100 IBAS = 1,NBAS IB = IBXM(IBAS) LBL1 = LABEL(IB,1) LBL2 = LABEL(IB,2) LBL3 = LABEL(IB,3) IF(LBL1.EQ.LLP.OR.LBL1.EQ.LRY) NCTR = 1 IF(LBL1.EQ.LBD) NCTR = 2 Skip 3-center orbitals, core orbitals, low occupancy orbitals: IF(LBL1.EQ.L3C) GO TO 100 IF(LBL1.EQ.LCR) GO TO 100 IF(BNDOCC(IBAS).LT.ABS(ETHR)) GO TO 100 Find the hybrids which contribute to this NBO: ICTR = 0 DO 10 IHYB = 1,NBAS IF(ABS(TBND(IBAS,IHYB)).GT.THRESH) THEN ICTR = ICTR + 1 KHYB(ICTR) = IHYB END IF 10 CONTINUE IF(ICTR.NE.NCTR) THEN WRITE(LFNPR,910) NCTR,IBAS,ICTR STOP END IF Make sure the hybrids are on the proper nuclear centers and compute the percentage p-character in the hybrid: DO 30 ICTR = 1,NCTR IHYB = KHYB(ICTR) JCTR = LABEL(IB,ICTR+3) CALL HYBCMP(XYZ(1,ICTR),PHYB(ICTR),IHYB,JCTR,THYB(1,IHYB)) 30 CONTINUE If these hybrids have low p-character, skip them: ISKIP(1) = 0 ISKIP(2) = 0 IF(NCTR.EQ.1.AND.PHYB(1).LT.ABS(PTHR)) GO TO 100 IF(NCTR.EQ.2) THEN IF(PHYB(1).LT.ABS(PTHR)) ISKIP(1) = 1 IF(PHYB(2).LT.ABS(PTHR)) ISKIP(2) = 1 IF(ISKIP(1).EQ.1.AND.ISKIP(2).EQ.1) GO TO 100 END IF Compute the polar and azimuthal angles of each hybrid: DO 70 ICTR = 1,NCTR IF(ISKIP(ICTR).EQ.1) GO TO 70 CALL ANGLES(XYZ(1,ICTR),XYZ(2,ICTR),XYZ(3,ICTR),POL(ICTR), + AZI(ICTR)) 70 CONTINUE Compute the deviation from the line of nuclear centers for 2-center orbitals: IF(NCTR.EQ.2) THEN ICTR = LABEL(IB,4) JCTR = LABEL(IB,5) X = ATCOOR(JCTR*3-2) - ATCOOR(ICTR*3-2) Y = ATCOOR(JCTR*3-1) - ATCOOR(ICTR*3-1) Z = ATCOOR(JCTR*3) - ATCOOR(ICTR*3) IF(ABS(X).LT.CUTOFF) X = ZERO IF(ABS(Y).LT.CUTOFF) Y = ZERO IF(ABS(Z).LT.CUTOFF) Z = ZERO R = SQRT(X*X + Y*Y + Z*Z) X = X / R Y = Y / R Z = Z / R CALL ANGLES(X,Y,Z,THETA,PHI) PROJ = XYZ(1,1)*X + XYZ(2,1)*Y + XYZ(3,1)*Z IF(ABS(PROJ-ONE).LT.CUTOFF) THEN DEV(1) = ZERO ELSE IF(ABS(PROJ+ONE).LT.CUTOFF) THEN DEV(1) = 180.0 ELSE IF(PROJ.LT.ONE.AND.PROJ.GT.-ONE) THEN DEV(1) = ACOS(PROJ) * CONV DEV(1) = ABS(DEV(1)) ELSE STOP 'ArcCosine out of bounds in SR HYBDIR' END IF PROJ = XYZ(1,2)*X + XYZ(2,2)*Y + XYZ(3,2)*Z IF(ABS(PROJ-ONE).LT.CUTOFF) THEN DEV(2) = 180.0 ELSE IF(ABS(PROJ+ONE).LT.CUTOFF) THEN DEV(2) = ZERO ELSE IF(PROJ.LT.ONE.AND.PROJ.GT.-ONE) THEN DEV(2) = ACOS(PROJ) * CONV DEV(2) = ABS(ABS(DEV(2)) - 180.0) ELSE STOP 'ArcCosine out of bounds in SR HYBDIR' END IF IF(DEV(1).LT.ABS(ATHR)) ISKIP(1) = 1 IF(DEV(2).LT.ABS(ATHR)) ISKIP(2) = 1 IF(ISKIP(1).EQ.1.AND.ISKIP(2).EQ.1) GO TO 100 END IF Write out directionality info: ICNT = ICNT + 1 ISTR(1) = LBL1 ISTR(2) = LBL2 ISTR(3) = LBL3 ISTR(4) = NAMEAT(IATNO(LABEL(IB,4))) ISTR(5) = LABEL(IB,4) IF(NCTR.EQ.2) THEN ISTR(6) = LHYP ISTR(7) = NAMEAT(IATNO(LABEL(IB,5))) ISTR(8) = LABEL(IB,5) IF(ISKIP(1).EQ.1) THEN WRITE(LFNPR,940) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(2), + AZI(2),DEV(2) ELSE IF(ISKIP(2).EQ.1) THEN WRITE(LFNPR,950) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(1), + AZI(1),DEV(1) ELSE WRITE(LFNPR,960) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(1), + AZI(1),DEV(1),POL(2),AZI(2),DEV(2) END IF ELSE WRITE(LFNPR,970) IBAS,(ISTR(I),I=1,5),POL(1),AZI(1) END IF 100 CONTINUE IF(ICNT.EQ.0) WRITE(LFNPR,980) RETURN 900 FORMAT(//1X,'NHO Directionality and "Bond Bending" (deviations ', + 'from line of nuclear centers)',//1X,' [Thresholds for ', + 'printing: angular deviation > ',F4.1,' degree]',/1X, + ' hybrid p-character > ',F4.1, + '%',/1X,' orbital occupancy ', + '> ',F4.2,'e',//1X,' Line of Centers ', + ' Hybrid 1 Hybrid 2',/1X,' ', + '--------------- ------------------- ------------------',/1X, + ' NBO Theta Phi Theta Phi Dev ', + 'Theta Phi Dev',/1X,'=====================================', + '==========================================') 910 FORMAT(/1X,'Error: the ',I1,'-center NBO ',I3,' has ', + 'contributions from ',I2,' atomic centers.') 940 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1, + ' -- -- -- ',F5.1,2X,F5.1,1X,F5.1) 950 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1, + 3X,F5.1,2X,F5.1,1X,F5.1,' -- -- --') 960 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1, + 3X,F5.1,2X,F5.1,1X,F5.1,4X,F5.1,2X,F5.1,1X,F5.1) 970 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,' -- --',4X, + F5.1,2X,F5.1,' -- -- -- --') 980 FORMAT(1X,' None exceeding thresholds') END ***************************************************************************** SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION XYZ(3),HYB(1) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA ZERO,THRESH,CUTOFF/0.0D0,1.0D-4,1.0D-8/ Add the px,py,pz components of this hybrid vectorially and determine its percentage p-character: XYZ(1) = ZERO XYZ(2) = ZERO XYZ(3) = ZERO PCENT = ZERO HNORM = ZERO Make sure this hybrid is situated on the correct atom, JCTR: JMAX = 1 TMAX = ABS(HYB(1)) DO 10 INAO = 2,NBAS IF(ABS(HYB(INAO)).GT.TMAX) THEN JMAX = INAO TMAX = ABS(HYB(INAO)) END IF 10 CONTINUE IF(NAOC(JMAX).NE.JCTR) THEN WRITE(LFNPR,920) IHYB,JCTR,NAOC(JMAX) STOP END IF Find the sign of the largest s-component of this hybrid: JMAX = 0 TMAX = ZERO DO 20 INAO = 1,NBAS L = NAOA(INAO)/100 IF(L.EQ.0.AND.ABS(HYB(INAO)).GT.TMAX) THEN JMAX = INAO TMAX = ABS(HYB(INAO)) END IF 20 CONTINUE If the sign of the largest s-component is negative, change the phase of this hybrid: IF(JMAX.NE.0.AND.HYB(JMAX).LT.-THRESH) THEN DO 30 INAO = 1,NBAS HYB(INAO) = -HYB(INAO) 30 CONTINUE ENDIF Sum the px,py,pz components of this hybrid, determine the percent p-character: DO 40 INAO = 1,NBAS IF(NAOC(INAO).EQ.JCTR) THEN L = NAOA(INAO)/100 IF(L.EQ.1) THEN PCENT = PCENT + HYB(INAO)*HYB(INAO) M = MOD(NAOA(INAO),50) XYZ(M) = XYZ(M) + HYB(INAO) END IF HNORM = HNORM + HYB(INAO)*HYB(INAO) END IF 40 CONTINUE IF(HNORM.LT.THRESH) THEN WRITE(LFNPR,930) JCTR,IHYB STOP END IF PCENT = PCENT/HNORM * 100.0 Normalize the px,py,pz vector: HNORM = ZERO DO 50 IX = 1,3 IF(ABS(XYZ(IX)).LT.CUTOFF) XYZ(IX) = ZERO HNORM = HNORM + XYZ(IX)*XYZ(IX) 50 CONTINUE HNORM = SQRT(HNORM) IF(ABS(HNORM).LT.CUTOFF) THEN PCENT = ZERO ELSE DO 60 IX = 1,3 XYZ(IX) = XYZ(IX)/HNORM 60 CONTINUE END IF RETURN 920 FORMAT(/1X,'Expected to find hybrid ',I3,' on nuclear center ', + I2,' rather than center ',I2,'.') 930 FORMAT(/1X,'The atomic orbitals on nuclear center ',I2,' do not ', + 'contribute to hybrid ',I3,'.') END ***************************************************************************** SUBROUTINE FNDMOL(IATOMS) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM), + NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION IATOMS(NATOMS) LOGICAL BDFIND FIND MOLECULAR UNITS : Modified algorithm replacing original which had problems with determining molecular units for odd numberings of atoms. (E. Glendening 3/12/88) NMOLEC = 0 DO 20 I = 1,NATOMS MOLAT(I) = 0 DO 10 J = 1,NATOMS MOLEC(I,J) = 0 10 CONTINUE 20 CONTINUE DO 30 I = 1,NATOMS IATOMS(I) = I 30 CONTINUE LATOMS = NATOMS 40 CONTINUE NMOLEC = NMOLEC+1 MOLAT(NMOLEC) = 1 MOLEC(NMOLEC,1) = IATOMS(1) LATOMS = LATOMS-1 IF(LATOMS.NE.0) THEN DO 50 I = 1,LATOMS IATOMS(I) = IATOMS(I+1) 50 CONTINUE IAT = 1 60 CONTINUE I = 1 70 CONTINUE IF(BDFIND(MOLEC(NMOLEC,IAT),IATOMS(I))) THEN MOLAT(NMOLEC) = MOLAT(NMOLEC)+1 MOLEC(NMOLEC,MOLAT(NMOLEC)) = IATOMS(I) LATOMS = LATOMS-1 IF(I.LE.LATOMS) THEN DO 80 J = I,LATOMS IATOMS(J) = IATOMS(J+1) 80 CONTINUE END IF ELSE I = I+1 END IF IF(I.LE.LATOMS) GOTO 70 IAT = IAT+1 IF(IAT.LE.MOLAT(NMOLEC).AND.LATOMS.NE.0) GOTO 60 END IF IF(LATOMS.GT.0) GOTO 40 SORT ATOMS IN MOLECULAR UNITS: DO 110 I = 1,NMOLEC DO 100 J = 1,MOLAT(I)-1 DO 90 K = 1,MOLAT(I)-J IF(MOLEC(I,K).GT.MOLEC(I,K+1)) THEN ITEMP = MOLEC(I,K) MOLEC(I,K) = MOLEC(I,K+1) MOLEC(I,K+1) = ITEMP END IF 90 CONTINUE 100 CONTINUE 110 CONTINUE ALPHA SPIN: SAVE BONDING INFO IN NMOLA,MOLATA,MOLECA: IF(ISPIN.EQ.2) THEN NMOLA = NMOLEC DO 610 IMOL = 1,NMOLEC MOLATA(IMOL) = MOLAT(IMOL) IMOLAT = MOLAT(IMOL) DO 600 IATMOL = 1,IMOLAT MOLECA(IMOL,IATMOL) = MOLEC(IMOL,IATMOL) 600 CONTINUE 610 CONTINUE BETA SPIN: MAKE SURE THAT BETA MOLECULAR UNITS ARE THE SAME AS ALPHA: ELSE IF(ISPIN.EQ.-2) THEN IF(NMOLA.NE.NMOLEC) GO TO 800 DO 730 IMOL = 1,NMOLEC IMOLAT = MOLAT(IMOL) IF(IMOLAT.NE.MOLATA(IMOL)) GO TO 800 DO 720 IATMOL = 1,IMOLAT IF(MOLECA(IMOL,IATMOL).NE.MOLEC(IMOL,IATMOL)) GO TO 800 720 CONTINUE 730 CONTINUE END IF RETURN 800 WRITE(LFNPR,1800) NMOLA = -NMOLA RETURN 1800 FORMAT(/1X,'The molecular units found in the alpha and beta ', + 'manifolds are inequivalent.',/1X,'For labelling purposes, ', + 'the molecular units of the beta system will be used.') END ***************************************************************************** SUBROUTINE NBOCLA(BNDOCC,ACCTHR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),MOLLST(MAXBAS),IATHY(MAXBAS,3) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM), + NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM) DIMENSION BNDOCC(NBAS) DATA LBD,L3C,LSTAR/2HBD,2H3C,1H*/ DATA THRESH,ONE,ZERO,TWO/1.50D0,1.0D0,0.0D0,2.0D0/ DATA DONTHR/1.0D-1/ CLASSIFY NBOS ACCORDING TO DONOR/ACCEPTOR TYPE: IF(ACCTHR.LE.ZERO) THEN ACCTHR = THRESH IF(ISPIN.NE.0) ACCTHR = ACCTHR - ONE END IF IF(ISPIN.NE.0) DONTHR = DONTHR / TWO MAKE UP LIST MOLLST OF WHICH "MOLECULE" EACH ATOM IS IN: DO 80 IAT = 1,NATOMS DO 60 IMOL = 1,NMOLEC IMOLAT = MOLAT(IMOL) DO 50 IATMOL = 1,IMOLAT IF(MOLEC(IMOL,IATMOL).EQ.IAT) GO TO 70 50 CONTINUE 60 CONTINUE STOP 'ROUTINE NBOCLA' 70 MOLLST(IAT) = IMOL 80 CONTINUE MAKE UP LISTS OF NBO ORBITALS: NBOUNI(IBAS) = MOLECULAR UNIT NBOTYP(IBAS) = NUMBER OF CENTERS (+10 IF A LOW OCCUPANCY LONE PAIR) (+20 IF AN ANTIBOND/RYDBERG) DO 200 IBAS = 1,NBAS IB = IBXM(IBAS) IAT = LABEL(IB,4) IMOL = MOLLST(IAT) NBOUNI(IBAS) = IMOL LAB = LABEL(IB,1) NCTR = 1 IF(LAB.EQ.LBD) NCTR = 2 IF(LAB.EQ.L3C) NCTR = 3 NBOTYP(IBAS) = NCTR IF(LABEL(IB,2).EQ.LSTAR) GO TO 180 IF(BNDOCC(IBAS).GT.ACCTHR) GO TO 200 LOW OCCUPANCY VALENCE ORBITAL NBOTYP(IBAS) = NCTR + 10 GO TO 200 ANTIBOND/RYDBERG 180 NBOTYP(IBAS) = NCTR + 20 HIGH OCCUPANCY RY* OR BD* ORBITAL IF(BNDOCC(IBAS).GT.DONTHR) NBOTYP(IBAS) = NCTR + 10 200 CONTINUE RETURN END ***************************************************************************** SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),MOLLST(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM), + NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR DIMENSION BNDOCC(NBAS),F(NDIM,NDIM),MOLNBO(2,NBAS,NMOLEC) DIMENSION INAM(3),JNAM(3),ICH(3,2),JCH(3,2),ISP(3),JSP(3) DATA LBD/2HBD/,L3C/2H3C/,LBLNK1/1H /,LBLNK2/2H /,LHYP/1H-/ DATA HUNDTH/0.01D0/ DATA AUKCAL/627.51D0/,EVKCAL/23.060D0/ DATA ZERO,ONE,TWO,TEN/0.0D0,1.0D0,2.0D0,1.0D1/ PERFORM 2ND ORDER ANALYSIS OF THE FOCK MATRIX: ETHR1 IS THE THRESHOLD FOR PRINTING THE INTRAMOLECULAR PERTURBATIONAL ENERGIES (0.5 KCAL/MOL FOR CLOSED SHELL, 0.25 KCAL/MOL FOR OPEN SHELL) SIMILARLY, ETHR2 IS THE INTERMOLECULAR THRESHOLD, (0.05 KCAL/MOL). ETHR1 = ABS(E2THR) IF(ISPIN.NE.0.AND.E2THR.LT.ZERO) ETHR1 = ETHR1/TWO ETHR2 = ABS(E2THR)/TEN IF(ISPIN.NE.0.AND.E2THR.LT.ZERO) ETHR2 = ETHR2/TWO FETCH THE NBO FOCK MATRIX: NTRI = NDIM * (NDIM+1)/2 CALL FEFNBO(F) CALL UNPACK(F,NDIM,NBAS,NTRI) ANALYZE FOCK MATRIX: MAKE UP LIST MOLNBO(1,IBAS,IMOL) OF CORE/LP/BOND NBOS IN MOLEC. UNIT IMOL MOLNBO(2,IBAS,IMOL) OF RYDBERG/ANTIBOND NBOS IN MOLEC. IMOL DO 200 IMOL = 1,NMOLEC NOCC = 0 NSTAR = 0 DO 110 IBAS = 1,NBAS DO 100 I = 1,2 MOLNBO(I,IBAS,IMOL) = 0 100 CONTINUE 110 CONTINUE DO 150 IBAS = 1,NBAS IF(IMOL.NE.NBOUNI(IBAS)) GO TO 150 IF(NBOTYP(IBAS).GT.20) GO TO 130 NOCC = NOCC + 1 MOLNBO(1,NOCC,IMOL) = IBAS IF(NBOTYP(IBAS).LT.10) GO TO 150 130 CONTINUE NSTAR = NSTAR + 1 MOLNBO(2,NSTAR,IMOL) = IBAS 150 CONTINUE 200 CONTINUE DETERMINE THE CONVERSION FROM INPUT ENERGY UNITS TO KCAL: IF(MUNIT.EQ.0) THEN CONV = AUKCAL ELSE IF(MUNIT.EQ.1) THEN CONV = EVKCAL ELSE CONV = ONE END IF LOOP OVER PAIRS OF UNITS: WRITE(LFNPR,2700) ETHR1 IF(NMOLEC.GT.1) WRITE(LFNPR,2710) ETHR2 IF(MUNIT.EQ.0) THEN WRITE(LFNPR,2720) ELSE IF(MUNIT.EQ.1) THEN WRITE(LFNPR,2730) ELSE WRITE(LFNPR,2740) END IF DO 400 IMOL = 1,NMOLEC DO 400 JMOL = 1,NMOLEC IF(IMOL.EQ.JMOL) WRITE(LFNPR,2300) IMOL IF(IMOL.NE.JMOL) WRITE(LFNPR,2400) IMOL,JMOL ETHRSH = ETHR1 IF(IMOL.NE.JMOL) ETHRSH = ETHR2 NELE = 0 DO 305 IOCC = 1,NBAS IBAS = MOLNBO(1,IOCC,IMOL) IF(IBAS.EQ.0) GO TO 305 IB = IBXM(IBAS) LBL = LABEL(IB,1) NCTR = 1 IF(LBL.EQ.LBD) NCTR = 2 IF(LBL.EQ.L3C) NCTR = 3 DO 250 I = 1,3 IA = LABEL(IB,I+3) CALL CONVRT(IA,ICH(I,1),ICH(I,2)) INAM(I) = LBLNK2 IF(IA.GT.0) INAM(I) = NAMEAT(IATNO(IA)) ISP(I) = LHYP IF(I.GE.NCTR) ISP(I) = LBLNK1 250 CONTINUE DO 300 JSTAR = 1,NBAS JBAS = MOLNBO(2,JSTAR,JMOL) IF(JBAS.EQ.0) GO TO 300 IF(IBAS.EQ.JBAS) GO TO 300 DE = F(JBAS,JBAS) - F(IBAS,IBAS) IF(DE.LT.HUNDTH) GO TO 300 ABSFIJ = ABS(F(IBAS,JBAS)) EPERT = (ABSFIJ**2)/DE COMPUTE OCCUPANCY FACTOR TO MULTIPLY BY: TOTOCC = BNDOCC(IBAS)+BNDOCC(JBAS) FULLOC = TWO IF(ISPIN.NE.0) FULLOC = ONE OCCFAC = TOTOCC IF(TOTOCC.GT.FULLOC) OCCFAC = TWO * FULLOC - TOTOCC MULTIPLY EPERT BY SUM OF OCCUPANCIES OF NBOS IBAS AND JBAS: EPERT = EPERT * OCCFAC EKCAL = EPERT * CONV IF(EKCAL.LT.ETHRSH) GO TO 300 NELE = NELE + 1 JB = IBXM(JBAS) LBL = LABEL(JB,1) NCTR = 1 IF(LBL.EQ.LBD) NCTR = 2 IF(LBL.EQ.L3C) NCTR = 3 DO 260 J = 1,3 JA = LABEL(JB,J+3) CALL CONVRT(JA,JCH(J,1),JCH(J,2)) JNAM(J) = LBLNK2 IF(JA.GT.0) JNAM(J) = NAMEAT(IATNO(JA)) JSP(J) = LHYP IF(J.GE.NCTR) JSP(J) = LBLNK1 260 CONTINUE WRITE(LFNPR,2800) IBAS,(LABEL(IB,K),K=1,3), * (INAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,2), * INAM(3),ICH(3,1),ICH(3,2), * JBAS,(LABEL(JB,K),K=1,3), * (JNAM(K),JCH(K,1),JCH(K,2),JSP(K),K=1,2), * JNAM(3),JCH(3,1),JCH(3,2), * EKCAL,DE,ABSFIJ 300 CONTINUE 305 CONTINUE IF(NELE.EQ.0) WRITE(LFNPR,2500) 400 CONTINUE RETURN 2300 FORMAT(/1X,'within unit ',I2) 2400 FORMAT(/1X,'from unit ',I2,' to unit ',I2) 2500 FORMAT(1X,' None above threshold') 2700 FORMAT(//,1X,'Second Order Perturbation Theory Analysis ', * 'of Fock Matrix in NBO Basis'//,1X, * ' Threshold for printing: ',F5.2,' kcal/mol') 2710 FORMAT(1X,' (Intermolecular threshold:',F5.2,' kcal/mol)') 2720 FORMAT(56X,' E(2) E(j)-E(i) F(i,j)'/ * 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X, * 'kcal/mol a.u. a.u. ',/1X,79('=')) 2730 FORMAT(56X,' E(2) E(j)-E(i) F(i,j)'/ * 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X, * 'kcal/mol e.V. e.V. ',/1X,79('=')) 2740 FORMAT(56X,' E(2) E(j)-E(i) F(i,j)'/ * 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X, * 'kcal/mol kcal kcal ',/1X,79('=')) 2800 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1, * '/',I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1, * F8.2,F8.2,F9.3) END ***************************************************************************** SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL FIRST PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM), + NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM) COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION F(NDIM,NDIM),BNDOCC(NDIM),LIST(NDIM),LISTA(NATOMS,2), + SCR(1) DIMENSION ISTR(80),ILAB(9) DATA ZERO,EPS,TWO,TEN,HUNDRD/0.0D0,5.0D-6,2.0D0,1.0D1,1.0D2/ DATA TENTH/1.0D-1/ DATA LSTAR,LRY/'*','RY'/ Set flag to zero -- Determine strong delocalizations from perturbative analysis of the NBO Fock matrix: IFLG = 0 Threshold for printing delocalizations: THR1 = ABS(E2THR) IF(ISPIN.NE.0) THR = THR/TWO THR2 = THR1 / TEN Get Fock matrix if there is one: IF(IWFOCK.NE.0) THEN NTRI = NDIM * (NDIM+1)/2 CALL FEFNBO(F) CALL UNPACK(F,NDIM,NBAS,NTRI) END IF Print summary heading, then loop over molecules: IF(IWFOCK.NE.0) THEN WRITE(LFNPR,900) ELSE WRITE(LFNPR,910) END IF DO 200 IMOL = 1,NMOLEC Determine the molecular formula, the nuclear charge, and the number of ECP electrons of this molecular unit: NAT = 0 MECP = 0 CHARGE = ZERO DO 20 IAT = 1,MOLAT(IMOL) KAT = IATNO(MOLEC(IMOL,IAT)) MECP = MECP + FLOAT(KAT - IZNUC(MOLEC(IMOL,IAT))) CHARGE = CHARGE + FLOAT(KAT) DO 10 JAT = 1,NAT IF(LISTA(JAT,1).EQ.KAT) THEN LISTA(JAT,2) = LISTA(JAT,2) + 1 GO TO 20 END IF 10 CONTINUE NAT = NAT + 1 LISTA(NAT,1) = KAT LISTA(NAT,2) = 1 20 CONTINUE IF(ISPIN.NE.0) MECP = MECP/2 IF(ISPIN.NE.0) CHARGE = CHARGE/TWO CALL CHEM(NAT,NATOMS,LISTA,NL,ISTR) WRITE(LFNPR,920) IMOL,(ISTR(I),I=1,NL) Loop over NBO's on this molecular unit: OCCLEW = FLOAT(MECP) OCCNON = ZERO OCCRYD = ZERO DO 190 IBAS = 1,NBAS IF(NBOUNI(IBAS).EQ.IMOL) THEN IB = IBXM(IBAS) ILAB(1) = LABEL(IB,1) ILAB(2) = LABEL(IB,2) ILAB(3) = LABEL(IB,3) IPTR = 3 NCTR = MOD(NBOTYP(IBAS),10) DO 30 ICTR = 1,NCTR IPTR = IPTR + 2 ILAB(IPTR) = LABEL(IB,ICTR+3) ILAB(IPTR-1) = NAMEAT(IATNO(ILAB(IPTR))) 30 CONTINUE OCC = BNDOCC(IBAS) IF(ILAB(1).EQ.LRY) THEN OCCRYD = OCCRYD + OCC ELSE IF(ILAB(2).EQ.LSTAR) THEN OCCNON = OCCNON + OCC ELSE OCCLEW = OCCLEW + OCC END IF If there is a Fock matrix, find the orbital energy and principal delocalizations: IF(IWFOCK.NE.0) THEN ENRG = F(IBAS,IBAS) CALL GETDEL(IBAS,OCC,THR1,THR2,NL,LIST,SCR,F,IFLG) FIRST = .TRUE. IL = 0 40 CALL DLCSTR(IBAS,IL,NL,LIST,ML,ISTR) IF(FIRST) THEN IF(NCTR.EQ.1) THEN WRITE(LFNPR,930) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG, + (ISTR(J),J=1,ML) ELSE IF(NCTR.EQ.2) THEN WRITE(LFNPR,940) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG, + (ISTR(J),J=1,ML) ELSE WRITE(LFNPR,950) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG, + (ISTR(J),J=1,ML) END IF FIRST = .FALSE. ELSE WRITE(LFNPR,960) (ISTR(J),J=1,ML) END IF IF(IL.LT.NL) GO TO 40 Otherwise only write out orbital labels and occupancy: ELSE IF(NCTR.EQ.1) THEN WRITE(LFNPR,930) IBAS,(ILAB(I),I=1,IPTR),OCC ELSE IF(NCTR.EQ.2) THEN WRITE(LFNPR,940) IBAS,(ILAB(I),I=1,IPTR),OCC ELSE WRITE(LFNPR,950) IBAS,(ILAB(I),I=1,IPTR),OCC END IF END IF END IF 190 CONTINUE WRITE(LFNPR,970) TOTAL = OCCLEW + OCCNON + OCCRYD Make sure the total number of electrons is an integer if there is only one molecular unit: IF(NMOLEC.EQ.1) THEN TOTAL = TOTAL + TENTH NEL = TOTAL TOTAL = NEL OCCRYD = TOTAL - OCCLEW - OCCNON END IF Write a summary of the electron population on this molecular unit: IF(ABS(TOTAL-FLOAT(NINT(TOTAL))).LT.1.0D-5) + TOTAL = FLOAT(NINT(TOTAL)) CHARGE = CHARGE - TOTAL IF(TOTAL.GT.EPS) THEN PLEW = OCCLEW/TOTAL*HUNDRD PNON = OCCNON/TOTAL*HUNDRD PRYD = OCCRYD/TOTAL*HUNDRD ELSE PLEW = ZERO PNON = ZERO PRYD = ZERO END IF WRITE(LFNPR,980) OCCLEW,PLEW WRITE(LFNPR,990) OCCNON,PNON WRITE(LFNPR,1000) OCCRYD,PRYD WRITE(LFNPR,970) WRITE(LFNPR,1010) IMOL,TOTAL,HUNDRD WRITE(LFNPR,1020) IMOL,CHARGE IF(IMOL.LT.NMOLEC) WRITE(LFNPR,*) 200 CONTINUE RETURN 900 FORMAT(//1X,'Natural Bond Orbitals (Summary):',//53X,'Principal ', + 'Delocalizations',/1X,' NBO Occupancy ', + ' Energy (geminal,vicinal,remote)',/1X,79('=')) 910 FORMAT(//1X,'Natural Bond Orbitals (Summary):',//1X,' ', + 'NBO Occupancy ',/1X,40('-')) 920 FORMAT(1X,'Molecular unit ',I2,' ',60A1) 930 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,10X,F9.5,F12.5,4X,28A1) 940 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,'-',A2,I2,5X,F9.5,F12.5, + 4X,28A1) 950 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,'-',A2,I2,'-',A2,I2,F9.5, + F12.5,4X,28A1) 960 FORMAT(52X,28A1) 970 FORMAT(1X,' -------------------------------') 980 FORMAT(1X,' Total Lewis',F11.5,' (',F8.4,'%)') 990 FORMAT(1X,' Valence non-Lewis',F11.5,' (',F8.4,'%)') 1000 FORMAT(1X,' Rydberg non-Lewis',F11.5,' (',F8.4,'%)') 1010 FORMAT(1X,' Total unit ',I2,F11.5,' (',F8.4,'%)') 1020 FORMAT(1X,' Charge unit ',I2,F11.5) END ***************************************************************************** SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) DIMENSION LIST(NDIM),DEL(NDIM),DELOC(NDIM,NDIM) DATA ZERO,ONE,CUTOFF,TENTH/0.0D0,1.0D0,1.0D-4,0.1D0/ DATA AUKCAL,EVKCAL/627.51,23.060/ Determine the conversion factor to kcal: IF(MUNIT.EQ.0) THEN CONV = AUKCAL ELSE IF(MUNIT.EQ.1) THEN CONV = EVKCAL ELSE CONV = ONE END IF Determine the strength of each delocalization: DO 10 JBO = 1,NBAS LIST(JBO) = 0 DEL(JBO) = ZERO 10 CONTINUE NL = 0 IF(OCC.LT.TENTH) RETURN DO 20 JBO = 1,NBAS IF(IBO.NE.JBO) THEN IF(NBOTYP(JBO).GE.10) THEN DEL(JBO) = DELOC(IBO,JBO)*DELOC(IBO,JBO) IF(IFLG.EQ.0) THEN DIV = ABS(DELOC(IBO,IBO)-DELOC(JBO,JBO)) IF(DIV.NE.ZERO) THEN DEL(JBO) = OCC * DEL(JBO)/DIV * CONV ELSE DEL(JBO) = ZERO END IF END IF END IF IF(DEL(JBO).GT.THR2.AND.NBOUNI(IBO).NE.NBOUNI(JBO)) THEN NL = NL + 1 LIST(NL) = JBO ELSE IF(DEL(JBO).GT.THR1) THEN NL = NL + 1 LIST(NL) = JBO END IF END IF 20 CONTINUE Sort delocalizations: DO 100 I = 1,NL DO 90 J = 1,NL-1 KBO = LIST(J) LBO = LIST(J+1) IF(DEL(LBO)-DEL(KBO).GT.CUTOFF) THEN LIST(J) = LBO LIST(J+1) = KBO END IF 90 CONTINUE 100 CONTINUE RETURN END ***************************************************************************** SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (MAXCHR = 28, MAXD = 4) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION LIST(NDIM),ISTR(80) INTEGER IK(MAXD) DATA ICOMMA,ILEFT,IRIGHT/',','(',')'/ Build a character string (for the NBO summary table) which contains the delocalization information for NBO # IBO: ML = 0 10 IL = IL + 1 IF(IL.GT.NL) GO TO 30 CALL IDIGIT(LIST(IL),IK,ND,MAXD) IF(ML+ND+4.GT.MAXCHR) GO TO 30 IF(ML.NE.0) THEN ML = ML + 1 ISTR(ML) = ICOMMA END IF DO 20 I = 1,ND ML = ML + 1 ISTR(ML) = IK(I) 20 CONTINUE ML = ML + 1 ISTR(ML) = ILEFT ML = ML + 1 ISTR(ML) = IHTYP(IBO,LIST(IL)) ML = ML + 1 ISTR(ML) = IRIGHT GO TO 10 30 IL = IL - 1 RETURN END ***************************************************************************** SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) FORM NATURAL LOCALIZED MOLECULAR ORBITALS FROM DENSITY MATRIX A. N: ACTUAL DIMENSION OF A,EVEC NDIM: DECLARED DIMENSION OF A,EVEC TSYM: SCRATCH RESON: SQUARES OF DIAGONAL ELEMENTS OF NBO TO NLMO TRANSF, TIMES 100% IALARM: ALARM THAT THE ORBITAL OCCUPANCIES ARE OUT OF ORDER AND THAT THE LMO STEP SHOULD BE AVOIDED THESE VALUES ARE SET: DIFFER = 1.0D-5 DONE = 1.0D-10 (THIS IS THE PARAMETER FOR CONVERGENCE OF THE OFF- DIAGONAL MATRIX ELEMENTS.) EPS = 1.0D-11 (THIS PARAMETER HAS TO DO WITH THE MACHINE PRECISION AND SHOULD BE SET TO A VALUE BETWEEN "DONE" AND THE MACHINE PRECISION.) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ZEROJ COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DIMENSION A(NDIM,NDIM),EVEC(NDIM,1),EVAL(1),TSYM(1),RESON(NDIM) DIMENSION ROT(2,2) DIMENSION ILIST(100),JLIST(100),IOFF(100),JOFF(100),IUNIQ(100), + JUNIQ(100) IMPORTANT PARAMETERS: DATA DIFFER,DONE,EPS/1.0D-5,1.0D-10,1.0D-11/ NOFFMX IS SET TO THE DIMENSION OF VECTORS ILIST,JLIST,IOFF,JOFF,IUNIQ,JUNIQ: DATA DEGTHR,NOFFMX/1.0D-3,100/ DATA ZERO,ONE,TEN,HUNDRD/0.0D0,1.0D0,10.0D0,100.0D0/ WRITE(LFNPR,8390) THR1 = ONE - DEGTHR THR2 = ONE - DEGTHR*5 NTIME = 0 IF THERE IS ONLY ONE BASIS FUNCTION, SOLVE THIS TRIVIAL CASE AND RETURN: IF(N.GT.1) GO TO 10 EVEC(1,1) = ONE EVAL(1) = A(1,1) RETURN 10 CONTINUE DO 30 J = 1,N DO 20 I = 1,N 20 EVEC(I,J) = ZERO 30 EVEC(J,J) = ONE COUNT THE NUMBER OF ELECTRONS AND OCCUPIED ORBITALS: TOTELE = ZERO DO 50 I = 1,N 50 TOTELE = TOTELE + A(I,I) TOTELE = TOTELE + DIFFER NOCC = TOTELE IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2) NVIRST = NOCC + 1 CHECK IF OCCUPANCIES ARE IN ORDER: IALARM = 0 VIRMAX = ZERO DO 60 J = NVIRST,N IF(A(J,J).LT.VIRMAX) GO TO 60 VIRMAX = A(J,J) 60 CONTINUE OCCMIN = HUNDRD DO 70 I = 1,NOCC IF(A(I,I).GT.OCCMIN) GO TO 70 OCCMIN = A(I,I) 70 CONTINUE X = OCCMIN - VIRMAX 21 OCT 1987. THE FOLLOWING FEATURE OF THE PROGRAM HAS BEEN TURNED OFF BECAUSE SOMETIMES IT IS NOT POSSIBLE TO DIAGONALIZE THE NBO DENSITY MATRIX WHEN ONE OF THE ``A'' NBOS IS DEGENERATE IN OCCUPANCY WITH ONE OR MORE ``B'' NBOS: THE "ABS(X).LT.DIFFER" PART OF THE NEXT LINE IS INCLUDED SO THAT NLMOS CAN BE COMPUTED WHEN A NUMBER OF ORBITALS ARE NEARLY DEGENERATE IN OCCUPANCY, AS FOR INSTANCE IN CLI6, WHERE SIX LITHIUM LONE PAIRS ARE DEGENERATE BUT ONLY ONE OF THEM CAN BE PLACED IN THE "OCCUPIED" SET OF NLMOS. IF(X.GT.ZERO.OR.ABS(X).LT.DIFFER) GO TO 100 THE ABOVE STATEMENT IS REPLACED BY: IF(X.GT.DIFFER) GO TO 100 OCCUPANCIES OUT OF ORDER: IALARM = 1 IF(ABS(X).GT.DIFFER) GO TO 80 WRITE(LFNPR,8010) GO TO 90 80 WRITE(LFNPR,8000) 90 CONTINUE RETURN START LOOP: 100 CONTINUE NTIME = NTIME + 1 FIRST, FIND ELEMENT A(IOCC,JEMT) OF LARGEST MAGNITUDE, OFFTOP: OFFTOP = ZERO DO 200 JEMT = NVIRST,N DO 200 IOCC = 1,NOCC ABSAIJ = ABS(A(IOCC,JEMT)) IF(ABSAIJ.LT.OFFTOP) GO TO 200 OFFTOP = ABSAIJ AII = A(IOCC,IOCC) AJJ = A(JEMT,JEMT) 200 CONTINUE RETURN IF CONVERGENCE HAS BEEN ACHIEVED: IF(OFFTOP.LT.DONE) GO TO 900 FIND ALL ELEMENTS DEGENERATE WITH LARGEST ONE, OFFTOP: (CHECK CORRESPONDING DIAGONAL ELEMENTS ALSO) NOFF: NUMBER OF DEGENERATE ELEMENTS IOFF(K),JOFF(K): KTH DEGENERATE ELEMENT OFFTST = OFFTOP * THR1 AIIL = AII*THR2 AJJL = AJJ*THR2 AIIU = AII/THR2 AJJU = AJJ/THR2 ZEROJ = .FALSE. IF(AJJ.LT.DIFFER) ZEROJ = .TRUE. NOFF = 0 DO 250 JEMT = NVIRST,N DO 250 IOCC = 1,NOCC ABSAIJ = ABS(A(IOCC,JEMT)) IF(ABSAIJ.LT.OFFTST) GO TO 250 AIII = A(IOCC,IOCC) AJJJ = A(JEMT,JEMT) IF((AIII.LT.AIIL).OR.(AIII.GT.AIIU)) GO TO 250 SKIP TEST OF DIAG. ELEM. IF SMALL (.LT.DIFFER): IF(ZEROJ) GO TO 240 IF((AJJJ.LT.AJJL).OR.(AJJJ.GT.AJJU)) GO TO 250 240 NOFF = NOFF + 1 IOFF(NOFF) = IOCC JOFF(NOFF) = JEMT 250 CONTINUE IF(NOFF.LT.NOFFMX) GO TO 260 WRITE(LFNPR,2500) NOFF,NOFFMX 2500 FORMAT(//1X,'NOFF = ',I5,' IS GREATER THAN NOFFMX =',I5, * /5X,' MUST ABORT NLMO PROCEDURE') IALARM = 1 RETURN 260 CONTINUE S = AJJ - AII ABSS = ABS(S) IF THE ROTATION IS VERY CLOSE TO 45 DEGREES, SET SIN AND COS TO 1/(ROOT 2) TEST=EPS*OFFTOP IF (ABSS.GT.TEST) GO TO 330 S=.707106781D0 C=S GO TO 340 CALCULATION OF SIN AND COS FOR ROTATION THAT IS NOT VERY CLOSE TO 45 DEGREES 330 T=OFFTOP/S S=0.25D0/ SQRT(0.25D0+T*T) JACOBI ROTATION ANGLE: COS=C , SIN=S C= SQRT(0.5D0+S) S=2.D0*T*S/C 340 CONTINUE PRINT STATEMENTS FOR NLMO PROCEDURE DETAILS: WRITE(LFNPR,9903) OFFTOP,S,C,NOFF 9903 FORMAT(' ****** OFFTOP,S,C,NOFF:',3F14.9,I3) WRITE(LFNPR,9901) (IOFF(I),I=1,NOFF) 9901 FORMAT(' IOFF:',20I3) WRITE(LFNPR,9902) (JOFF(I),I=1,NOFF) 9902 FORMAT(' JOFF:',20I3) SIMPLE 2 BY 2 ROTATION, NO DEGENERACY PROBLEMS: IF(NOFF.GT.1) GO TO 400 IOCC=IOFF(1) JEMT=JOFF(1) IF(A(IOCC,JEMT).LT.ZERO) S=-S ROT(1,1)=C ROT(2,2)=C ROT(1,2)=S ROT(2,1)=-S IOFF(2)=JOFF(1) CALL LIMTRN(A,IOFF,ROT,EVAL,NDIM,N,2,2,0) ROTATION COMPLETED DO 380 I=1,N T=EVEC(I,IOCC) EVEC(I,IOCC)=C*T-EVEC(I,JEMT)*S 380 EVEC(I,JEMT)=S*T+EVEC(I,JEMT)*C GO TO 800 400 CONTINUE NOFF.GT.1: COMPUTE "AVERAGED" UNITARY TRANSFORMATION SO THAT SYMMETRY IS PRESERVED CONSTRUCT UNIQUE LISTS OF ORBITALS INVOLVED: IUNIQ(L): L-TH UNIQUE OCCUPIED ORB. NIUNIQ: NO. OF UNIQUE OCC. ORBS ILIST(L): LOCATION IN THE UNIQUE LIST (IUNIQ) OF THE I VALUE OF THE L-TH OFFDIAG. ELEMENT JUNIQ, NJUNIQ, AND JLIST ARE FOR THE EMPTY ORBITALS. IUNIQ(1)=IOFF(1) ILIST(1)=1 NIUNIQ=1 DO 500 MOFF=2,NOFF I=IOFF(MOFF) IIMAX=MOFF-1 DO 490 II=1,IIMAX IF(IOFF(II).NE.I) GO TO 490 ILIST(MOFF)=ILIST(II) GO TO 500 490 CONTINUE NIUNIQ=NIUNIQ+1 ILIST(MOFF)=NIUNIQ IUNIQ(NIUNIQ)=I 500 CONTINUE JUNIQ(1)=JOFF(1) JLIST(1)=NIUNIQ+1 NJUNIQ=1 DO 540 MOFF=2,NOFF J=JOFF(MOFF) JJMAX=MOFF-1 DO 530 JJ=1,JJMAX IF(JOFF(JJ).NE.J) GO TO 530 JLIST(MOFF)=JLIST(JJ) GO TO 540 530 CONTINUE NJUNIQ=NJUNIQ+1 JLIST(MOFF)=NJUNIQ+NIUNIQ JUNIQ(NJUNIQ)=J 540 CONTINUE NROT=NIUNIQ+NJUNIQ NROT2=NROT*NROT N1=NROT2+1 N2=NROT2+N1 CONSTRUCT TSYM: CALL SYMUNI(TSYM,A,C,S,TSYM(N1),TSYM(N2),EVAL,NROT, * NIUNIQ,NJUNIQ, * ILIST,JLIST,NOFF,IOFF,JOFF,NDIM) MAKE IUNIQ INTO A COMPLETE LIST OF THE UNIQUE ORBITALS, AND TRANSFORM THE NBO TO NLMO TRANSF. (EVEC) AND THE DM (A) BY TSYM: II=NIUNIQ DO 700 I=1,NJUNIQ II=II+1 700 IUNIQ(II)=JUNIQ(I) CALL LIMTRN(EVEC,IUNIQ,TSYM,EVAL,NDIM,N,NROT,NROT,1) CALL LIMTRN(A,IUNIQ,TSYM,EVAL,NDIM,N,NROT,NROT,0) SEE HOW MUCH THE ELEMENTS WERE REDUCED: DO 750 MOFF=1,NOFF I=IOFF(MOFF) J=JOFF(MOFF) WRITE(LFNPR,9920) I,J,(A(I,J)) 9920 FORMAT(' I,J,AIJ:',2I3,F14.9) 750 CONTINUE 800 CONTINUE TOTELE=ZERO DO 810 J=1,N TOTELE=TOTELE+A(J,J) 810 CONTINUE TOT=NEL FRACT=TOTELE-TOT WRITE(LFNPR,7000) NOFF,TOTELE,FRACT GO TO 100 FINISHED: PLACE OCCUPANCIES IN EVAL AND COUNT UP ELECTRONS: 900 CONTINUE TOTELE = ZERO DO 910 J = 1,N EVAL(J) = A(J,J) TOTELE = TOTELE + EVAL(J) X = EVEC(J,J) RESON(J) = X * X * HUNDRD 910 CONTINUE TOTP = TOTELE + DIFFER NEL = TOTP TOT = NEL FRACT = ABS(TOTELE-TOT) IF(FRACT.GT.DIFFER) GO TO 990 FIND THE LARGEST OFF-DIAGONAL DENSITY MATRIX ELEMENT: AMAX = ZERO DO 960 J = 2,N JM1 = J - 1 DO 950 I = 1,JM1 IF(ABS(A(I,J)).LT.AMAX) GO TO 950 AMAX = ABS(A(I,J)) 950 CONTINUE 960 CONTINUE WRITE(LFNPR,9500) AMAX IF THIS IS A CORRELATED WAVEFUNCTION, RETURN TO THE CALLING ROUTINE: IF(CI.OR.MCSCF.OR.AUHF) RETURN FOR SCF WAVEFUNCTIONS, MAKE SURE THIS MATRIX ELEMENT IS SMALL: IF(AMAX.LT.HUNDRD*HUNDRD*DONE) RETURN WRITE(LFNPR,9550) IALARM = 1 RETURN NON-INTEGER NUMBER OF ELECTRONS: 990 WRITE(LFNPR,9900) DIFFER,TOTELE WRITE(LFNPR,9600) WRITE(LFNPR,9610) (EVAL(I),I=1,NBAS) IALARM = 1 RETURN 8000 FORMAT(/1X,'Highest occupied NBOs are not at the beginning', + ' of the NBO list;',/,1X,'The NLMO program is not ', + 'currently set up to handle this.') 8010 FORMAT(/1X,'Degeneracy between orbitals in the (a) and (b)', * ' sets detected;', * /1X,'NLMO program cannot always handle this situation.') 8390 FORMAT(//1X,'NATURAL LOCALIZED MOLECULAR ORBITAL (NLMO) ', * 'ANALYSIS:') 9500 FORMAT(/1X,'Maximum off-diagonal element of DM in NLMO basis:', * E13.5) 9550 FORMAT(/1X,'Something went wrong in the NLMO procedure; density', * ' matrix of SCF',/1X,'wave function has not been diagonalized') 9600 FORMAT(/1X,'Occupancies of NLMOs:') 9610 FORMAT(/1X,8F10.5) 9900 FORMAT(/1X,'Number of electrons (trace of DM, NLMO basis) is not', * ' within ',F10.5/' of an integer:',F10.5,' - - PROGRAM ABORT') END ***************************************************************************** SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO, * SIAB,NOCC,NAB) ***************************************************************************** Revision 1.2 88/03/03 11:29:56 reed To reduce amount of output, deleted some blank lines, commented out print of atom totals for bond orders, and the atomic contrib. to the NLMO is only printed if it is greater than 0.01%. IMPLICIT REAL*8 (A-H,O-Z) INTEGER UL LOGICAL CLOSED PRINT OUT DETAILS OF NAO TO NLMO TRANSFORMATION IN MATRIX T. REQUIRED INPUT: NDIM = DECLARED DIMENSIONALITY OF ARRAY T NBAS = NO. OF ORBITALS = ACTUAL DIMENSION OF T, NAOL NAOL = INTEGER LIST OF ORBITAL ANG. MOMENTUM TYPE NAOL(I)/100 = L = Q.N. OF ATOMIC ORBITAL I IATNO = LIST OF ATOMIC NUMBERS; IATNO(I) IS THE NUCLEAR CHARGE OF ATOM I AS AN INTEGER NATOMS = NO. OF ATOMS (NOT INCLUDING GHOSTS) IN THE MOLECULE IWHYBS = 1 IF HYBRID A.O. COEFFICIENTS ARE TO BE PRINTED, 0 OTHERWISE. LFNPR = LOGICAL FILE NUMBER FOR PRINTOUT. NAOCTR = LIST OF ATOMIC CENTERS OF OAO OR NAO BASIS ORBITALS LABEL = LIST OF BOND ORBITAL LABELS IBXM = PERMUTATION LIST OF BOND ORBITALS BNDOCC = LIST OF BOND ORBITAL OCCUPANCIES ISPIN = 0 FOR CLOSED SHELL = 2 FOR ALPHA SPIN =-2 FOR BETA SPIN PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP1(MAXBAS), + IPRIN(MAXBAS) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),OCC(NDIM),RESON(NDIM), * TS(NDIM),SIAB(NOCC,NAB),ATLMO(NOCC,NATOMS), * BORDER(NATOMS,NATOMS),OWBORD(NATOMS,NATOMS), * PCT(5),POW(5),LNAME(5),ISP(3),NAM(3),ICH(3,2) CHARACTER*80 TITLE DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/ DATA LNAME/'s','p','d','f','g'/ DATA ZERO,HUNDTH,T99,T99P/0.0D0,1.D-2,99.99D0,99.995D0/ DATA TWO,TENTH,HUNDRD,THR/2.0D0,0.1D0,100.0D0,1.0D-6/ DATA LHYP,LBLNK,L2BLNK/'-',' ',' '/ DATA BOTHR/2.0D-3/ CLOSED=.TRUE. IF(ISPIN.NE.0) CLOSED=.FALSE. IF(ISPIN.EQ.0) WRITE(LFNPR,8400) IF(ISPIN.EQ.2) WRITE(LFNPR,8410) IF(ISPIN.EQ.-2) WRITE(LFNPR,8420) WRITE(LFNPR,8000) WRITE(LFNPR,8100) (LHYP,J=1,79) LOOP OVER OCCUPIED NLMOS: DO 900 NLMO=1,NBAS IF(OCC(NLMO).LT.TENTH) GO TO 900 IB=IBXM(NLMO) LBL=LABEL(IB,1) IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR=1 IF(LBL.EQ.LBD) NCTR=2 IF(LBL.EQ.L3C) NCTR=3 DO 110 I=1,3 IA=LABEL(IB,I+3) CALL CONVRT(IA,ICH(I,1),ICH(I,2)) NAM(I)=L2BLNK IF(IA.GT.0) NAM(I)=NAMEAT(IATNO(IA)) ISP(I)=LHYP IF(I.GE.NCTR) ISP(I)=LBLNK 110 CONTINUE LOOP OVER ATOMIC CENTERS OF BOND ORBITAL NBOND DO 170 ICTR=1,NCTR ISP(ICTR)=LHYP IF(ICTR.EQ.NCTR) ISP(ICTR)=LBLNK I=LABEL(IB,ICTR+3) NEL=NAMEAT(IATNO(I)) 170 CONTINUE WRITE(LFNPR,8220) NLMO,OCC(NLMO),RESON(NLMO),(LABEL(IB,K), + K=1,3),(NAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3) IF(OCC(NLMO).LT.TENTH.AND.LBL.EQ.LRY) GO TO 900 LOOP OVER ATOMS: (J COUNTS OVER NAOS) DO 700 IAT=1,NATOMS NL=0 DO 200 L=1,5 200 PCT(L)=ZERO JLOW=LL(IAT) JHIGH=UL(IAT) DO 300 J=JLOW,JHIGH L=NAOL(J)/100+1 COEF=T(J,NLMO) PCT(L)=PCT(L)+COEF*COEF 300 CONTINUE PRINT OUT CONTRIBUTION FROM ATOM IAT (AND SAVE IN ATLMO): NL=L POL=ZERO DO 340 L=1,5 340 POL=POL+PCT(L) IF(NLMO.LE.NOCC) ATLMO(NLMO,IAT)=POL PCTPOL=POL*HUNDRD PRINT ONLY CONTRIBUTIONS GREATER THAN 0.01% IF(PCTPOL.LT.HUNDTH) GO TO 700 DO 350 L=1,5 350 PCT(L)=HUNDRD*PCT(L)/POL FIND LEADING NON-ZERO CONTRIBUTION TO DETERMINE POW(L) FOR EACH L LSTD=0 DO 460 L=1,NL IF(LSTD.GT.0) GO TO 450 POW(L)=ZERO STD=PCT(L) IF(STD.LT.HUNDTH) GO TO 460 LSTD=L 450 POW(L)=PCT(L)/STD IF(POW(L).GT.T99P) POW(L)=T99 460 CONTINUE NL1=NL NEL=NAMEAT(IATNO(IAT)) IF(NL1.GT.3) NL1=3 WRITE(LFNPR,8300) * PCTPOL,NEL,IAT,PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1) IF(NL.GT.3) WRITE(LFNPR,8310) * (LNAME(L),POW(L),PCT(L),L=4,NL) 700 CONTINUE 900 CONTINUE NOW, COMPUTE HYBRID OVERLAPS SIAB: IF(ORTHO) GOTO 2200 CALL FESNAO(S) DO 1500 NLMO=1,NOCC IAB=0 NATM1=NATOMS-1 DO 1400 IAT=1,NATM1 IALOW=LL(IAT) IAHIGH=UL(IAT) DO 1100 L=1,NBAS IF(L.GE.IALOW.AND.L.LE.IAHIGH) GO TO 1100 TS(L)=ZERO DO 1050 K=IALOW,IAHIGH 1050 TS(L)=TS(L)+T(K,NLMO)*S(K,L) 1100 CONTINUE IF(IAT.GT.2) GO TO 1130 CALL ALTOUT(TS,1,NDIM,1,NDIM) 1130 CONTINUE JAT0=IAT+1 DO 1300 JAT=JAT0,NATOMS IAB=IAB+1 OVP=ZERO JALOW=LL(JAT) JAHIGH=UL(JAT) DO 1200 L=JALOW,JAHIGH 1200 OVP=OVP+TS(L)*T(L,NLMO) ANORM=SQRT(ATLMO(NLMO,IAT)*ATLMO(NLMO,JAT)) IF(ANORM.LT.THR) GO TO 1250 SIAB(NLMO,IAB)=OVP/ANORM IF(IAT.GT.2) GO TO 1300 WRITE(LFNPR,9996) JAT,IAB,JALOW,JAHIGH,OVP,ANORM, * SIAB(NLMO,IAB) 9996 FORMAT(1X,'JAT,IAB,JALOW,JAHIGH,OVP,ANORM,SIAB:', * /5X,4I3,3F11.6) GO TO 1300 1250 SIAB(NLMO,IAB)=ZERO IF(IAT.GT.2) GO TO 1300 WRITE(LFNPR,9996) JAT,IAB,JALOW,JAHIGH,OVP,ANORM, * SIAB(NLMO,IAB) 1300 CONTINUE 1400 CONTINUE 1500 CONTINUE NOW WE ARE READY TO COMPUTE BOND ORDERS! IF(JPRINT(12).NE.0) THEN IAB=0 NATM1=NATOMS-1 WRITE(LFNPR,9000) DO 2000 IAT=1,NATM1 JAT0=IAT+1 DO 1900 JAT=JAT0,NATOMS IAB=IAB+1 SUM=ZERO OWSUM=ZERO DO 1800 NLMO=1,NOCC ALAMA2=ATLMO(NLMO,IAT) ALAMB2=ATLMO(NLMO,JAT) OVP=SIAB(NLMO,IAB) BO=ALAMA2 IF(ALAMB2.LT.ALAMA2) BO=ALAMB2 WRITE(LFNPR,8999) ALAMA2,ALAMB2,BO 8999 FORMAT(1X,'ALAMA2,ALAMB2,BO:',3F14.7) IF(CLOSED) BO=BO*TWO OWBO=BO*OVP IF(OVP.LT.ZERO) BO=-BO IF(ABS(BO).GT.BOTHR) * WRITE(LFNPR,9100) IAT,JAT,NLMO,BO,OVP SUM=SUM+BO OWSUM=OWSUM+OWBO 1800 CONTINUE WRITE(LFNPR,9110) SUM,OWSUM BORDER(IAT,JAT)=SUM BORDER(JAT,IAT)=SUM OWBORD(IAT,JAT)=OWSUM OWBORD(JAT,IAT)=OWSUM 1900 CONTINUE 2000 CONTINUE ZERO DIAGONAL ELEMENTS! DO 2020 IAT=1,NATOMS BORDER(IAT,IAT)=ZERO 2020 OWBORD(IAT,IAT)=ZERO COMPUTE TOTALS BY ATOM AND PRINT RESULTS: DO 2100 IAT=1,NATOMS SUM=ZERO DO 2050 JAT=1,NATOMS SUM=SUM+BORDER(IAT,JAT) 2050 CONTINUE TS(IAT)=SUM 2100 CONTINUE TITLE = 'Atom-Atom Net Linear NLMO/NPA Bond Orders:' CALL AOUT(BORDER,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS) TITLE = 'Linear NLMO/NPA Bond Orders, Totals by Atom:' CALL AOUT(TS,NATOMS,NATOMS,1,TITLE,0,1) END IF 2200 CONTINUE RETURN 8000 FORMAT(1X,'NLMO/Occupancy/Percent from Parent NBO/ Atomic ', + 'Hybrid Contributions') 8100 FORMAT(1X,80A1) 8220 FORMAT(1X,I3,'. (',F7.5,') ',F8.4,'% ',A2,A1,'(',I2,')', + 3(A2,3A1)) 8300 FORMAT(26X,F7.3,'% ',A2,I2,' s(',F6.2,'%)',2(A1,F5.2,'(', + F6.2,'%)')) 8310 FORMAT(50X,2(A1,F5.2,'(',F6.2,'%)')) 8400 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ', * 'in NAO Basis:') 8410 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ', * 'in NAO Basis, Alpha Spin:') 8420 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ', * 'in NAO Basis, Beta Spin:') 9000 FORMAT(/1X,'Individual LMO bond orders greater than 0.002', * ' in magnitude,'/1X, * 'with the overlap between the hybrids in the NLMO given:',//1X, * 'Atom I / Atom J / NLMO / Bond Order / Hybrid Overlap /') 9100 FORMAT(1X,I4,I8,2X,I6,F14.7,F16.7) END ***************************************************************************** SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL TEST DM -- NLMO density matrix (input) T -- AO to NLMO transformation matrix (input) C -- NBO to NLMO transformation matrix (retrieved from NBODAF) TNBO -- AO to NBO transformation (retrieved from NBODAF) DX,DY,DZ -- AO dipole matrices (retrieved from NBODAF) SCR -- NDIM*NDIM word scratch vector INDEX -- temporary indexing array PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBDXYZ/XDIP,YDIP,ZDIP,CHARGE(MAXATM) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORB(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),C(NDIM,NDIM),TNBO(NDIM,NDIM), + DX(NDIM,NDIM),DY(NDIM,NDIM),DZ(NDIM,NDIM),SCR(NDIM*NDIM), + INDEX(NDIM) DIMENSION ISTR(14),COUPLE(3) DATA TENTEN,SMALL,ZERO,TENTH,ONE,TWO/1.0D-10,1.0D-5,0.0D0,0.1D0, + 1.0D0,2.0D0/ DATA TOESU/4.803242E-10/ DATA IHYPH,IBLNK/1H-,1H / DEBYE = TOESU / TENTEN Copy the nuclear charges into CHARGE: IF(ALPHA.OR..NOT.OPEN) THEN DO 10 I = 1,NATOMS CHARGE(I) = IZNUC(I) 10 CONTINUE END IF Determine the number of occupied orbitals and make sure that the occupied NLMOs are at the beginning of the list: TOT = ZERO DO 20 I = 1,NBAS TOT = TOT + DM(I,I) SCR(I) = DM(I,I) 20 CONTINUE NEL = TOT + TENTH TOT = NEL NOCC = NEL IF(.NOT.OPEN) NOCC = NOCC/2 + MOD(NOCC,2) CALL RANK(SCR,NBAS,NDIM,INDEX) DO 30 I = 1,NOCC IF(INDEX(I).GT.NOCC) THEN WRITE(LFNPR,1000) RETURN END IF 30 CONTINUE Determine the occupancy factor: ETA = TWO IF(OPEN) ETA = ONE Compute the electronic contributions to the NBO bond dipole moments: CALL FETLMO(C) CALL FETNBO(TNBO) II = 1 CALL DIPELE(DX,C,TNBO,SCR,ETA,NOCC,II) IF(II.EQ.0) RETURN II = 2 CALL DIPELE(DY,C,TNBO,SCR,ETA,NOCC,II) IF(II.EQ.0) RETURN II = 3 CALL DIPELE(DZ,C,TNBO,SCR,ETA,NOCC,II) IF(II.EQ.0) RETURN Add the nuclear contributions to these bond dipole moments: CALL DIPNUC(DX,DY,DZ,SCR,ETA,NOCC) Convert to Debye: DO 50 I = 1,NOCC DO 40 J = 1,NBAS DX(J,I) = DX(J,I) * DEBYE DY(J,I) = DY(J,I) * DEBYE DZ(J,I) = DZ(J,I) * DEBYE 40 CONTINUE 50 CONTINUE Print dipole analysis: XNBO = ZERO YNBO = ZERO ZNBO = ZERO XNLMO = ZERO YNLMO = ZERO ZNLMO = ZERO DO 100 I = 1,NOCC IF(I.EQ.1) THEN IF(ALPHA) WRITE(LFNPR,1010) IF(BETA) WRITE(LFNPR,1020) IF(.NOT.OPEN) WRITE(LFNPR,1030) WRITE(LFNPR,1040) ABS(DTHR) ELSE WRITE(LFNPR,1050) END IF Build the label for this NBO/NLMO: IB = IBXM(I) ISTR(1) = LABEL(IB,1) ISTR(2) = LABEL(IB,2) ISTR(3) = LABEL(IB,3) DO 70 J = 1,3 J4 = 4 * J IF(LABEL(IB,J+3).EQ.0) THEN DO 60 K = J4-1,J4+2 ISTR(K) = IBLNK 60 CONTINUE ELSE IF(J.NE.1) ISTR(J4-1) = IHYPH ISTR(J4) = NAMEAT(IATNO(LABEL(IB,J+3))) CALL CONVRT(LABEL(IB,J+3),ISTR(J4+1),ISTR(J4+2)) END IF 70 CONTINUE Compute the NLMO bond dipole (the NBO bond dipoles are on the diagonal of DX,DY,DZ): X = ZERO Y = ZERO Z = ZERO DO 80 J = 1,NBAS X = X + DX(J,I) Y = Y + DY(J,I) Z = Z + DZ(J,I) 80 CONTINUE XNBO = XNBO + DX(I,I) YNBO = YNBO + DY(I,I) ZNBO = ZNBO + DZ(I,I) XNLMO = XNLMO + X YNLMO = YNLMO + Y ZNLMO = ZNLMO + Z Compute the net dipole for these orbitals: TOT = SQRT(DX(I,I)*DX(I,I) + DY(I,I)*DY(I,I) + DZ(I,I)*DZ(I,I)) TOTNLM = SQRT(X*X + Y*Y + Z*Z) WRITE(LFNPR,1060) I,(ISTR(J),J=1,14),X,Y,Z,TOTNLM, + DX(I,I),DY(I,I),DZ(I,I),TOT Print delocalization terms which are stronger than ABS(DTHR): ICNT = 0 DO 90 J = 1,NBAS IF(J.NE.I) THEN TOT = SQRT(DX(J,I)*DX(J,I) + DY(J,I)*DY(J,I) + + DZ(J,I)*DZ(J,I)) IF(TOT.GT.ABS(DTHR)) THEN ICNT = ICNT + 1 INDEX(ICNT) = J SCR(ICNT) = TOT END IF END IF 90 CONTINUE DO 95 J = 1,ICNT DO 94 K = 1,ICNT-J IF(SCR(K+1)-SCR(K).GT.SMALL) THEN ITEMP = INDEX(K) INDEX(K) = INDEX(K+1) INDEX(K+1) = ITEMP TEMP = SCR(K) SCR(K) = SCR(K+1) SCR(K+1) = TEMP END IF 94 CONTINUE 95 CONTINUE DO 96 JJ = 1,ICNT J = INDEX(JJ) WRITE(LFNPR,1070) J,DX(J,I),DY(J,I),DZ(J,I),SCR(JJ) 96 CONTINUE 100 CONTINUE Compute and print the correction for residual nuclear charges: IF(.NOT.ALPHA) THEN CALL FECOOR(SCR) X = ZERO Y = ZERO Z = ZERO TEST = .FALSE. DO 110 I = 1,NATOMS IF(ABS(CHARGE(I)).GT.SMALL) TEST = .TRUE. X = X + SCR(3*I-2) * CHARGE(I) * DEBYE Y = Y + SCR(3*I-1) * CHARGE(I) * DEBYE Z = Z + SCR(3*I) * CHARGE(I) * DEBYE 110 CONTINUE IF(TEST) THEN TOT = SQRT(X*X + Y*Y + Z*Z) WRITE(LFNPR,1080) X,Y,Z,TOT,X,Y,Z,TOT XNBO = XNBO + X YNBO = YNBO + Y ZNBO = ZNBO + Z XNLMO = XNLMO + X YNLMO = YNLMO + Y ZNLMO = ZNLMO + Z END IF END IF Print net dipole moments: TOT = SQRT(XNBO*XNBO + YNBO*YNBO + ZNBO*ZNBO) TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO) WRITE(LFNPR,1090) XNLMO,YNLMO,ZNLMO,TOTNLM,XNBO,YNBO,ZNBO,TOT Compute and print the total delocalization correction: X = XNLMO - XNBO Y = YNLMO - YNBO Z = ZNLMO - ZNBO TOT = SQRT(X*X + Y*Y + Z*Z) WRITE(LFNPR,1100) X,Y,Z,TOT Compute and print the NLMO coupling correction: TEST = .FALSE. DO 130 I = 1,NBAS IF(I.GT.NOCC.AND.ABS(DM(I,I)).GT.SMALL) TEST = .TRUE. DO 120 J = I+1,NBAS IF(ABS(DM(J,I)).GT.SMALL) TEST = .TRUE. 120 CONTINUE 130 CONTINUE IF(TEST) THEN TOT = ZERO DO 160 K = 1,3 II = K CALL FEDXYZ(DX,II) CALL SIMTRS(DX,T,SCR,NDIM,NBAS) COUPLE(K) = ZERO DO 150 I = 1,NBAS IF(I.LE.NOCC) THEN COUPLE(K) = COUPLE(K) + (ETA - DM(I,I)) * DX(I,I) ELSE COUPLE(K) = COUPLE(K) - DM(I,I) * DX(I,I) END IF DO 140 J = I+1,NBAS COUPLE(K) = COUPLE(K) - TWO * DM(J,I) * DX(J,I) 140 CONTINUE 150 CONTINUE COUPLE(K) = COUPLE(K) * DEBYE TOT = TOT + COUPLE(K) * COUPLE(K) 160 CONTINUE TOT = SQRT(TOT) WRITE(LFNPR,1110) XNLMO,YNLMO,ZNLMO,TOTNLM,XNLMO,YNLMO,ZNLMO, + TOTNLM,(COUPLE(K),K=1,3),TOT XNLMO = XNLMO + COUPLE(1) YNLMO = YNLMO + COUPLE(2) ZNLMO = ZNLMO + COUPLE(3) TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO) IF(ALPHA) WRITE(LFNPR,1120) XNLMO,YNLMO,ZNLMO,TOTNLM IF(BETA) WRITE(LFNPR,1130) XNLMO,YNLMO,ZNLMO,TOTNLM IF(.NOT.OPEN) WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM ELSE IF(ALPHA) WRITE(LFNPR,1120) XNLMO,YNLMO,ZNLMO,TOTNLM, + XNLMO,YNLMO,ZNLMO,TOTNLM IF(BETA) WRITE(LFNPR,1130) XNLMO,YNLMO,ZNLMO,TOTNLM, + XNLMO,YNLMO,ZNLMO,TOTNLM IF(.NOT.OPEN) WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM, + XNLMO,YNLMO,ZNLMO,TOTNLM END IF Save the alpha spin dipoles: IF(ALPHA) THEN XDIP = XNLMO YDIP = YNLMO ZDIP = ZNLMO END IF Print out the total dipole moment for open shell species: IF(BETA) THEN XNLMO = XNLMO + XDIP YNLMO = YNLMO + YDIP ZNLMO = ZNLMO + ZDIP TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO) WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM END IF RETURN 1000 FORMAT(/1X,'The highest occupied NBOs are not at the beginning ', + 'of the list.',/1X,'The dipole moment analysis is currently not', + ' set up to handle this.') 1010 FORMAT(//1X,'Dipole moment analysis, alpha spin:') 1020 FORMAT(//1X,'Dipole moment analysis, beta spin:') 1030 FORMAT(//1X,'Dipole moment analysis:') 1040 FORMAT(/1X,'[Print threshold: Net dipole >',F5.2,' Debye]',//1X, + ' NLMO bond dipole ', + 'NBO bond dipole',/1X,' ----------', + '--------------- ------------------------',/1X,' ', + 'Orbital x y z Total x y ', + 'z Total',/1X,79('=')) 1050 FORMAT(1X) 1060 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1,1X,4F6.2, + 3X,4F6.2) 1070 FORMAT(1X,44X,'deloc ',I3,':',4F6.2) 1080 FORMAT(/1X,' Residual nuclear charge ',4F6.2,' ',4F6.2) 1090 FORMAT(1X,' -----------------------', + '-----------------------------',/1X,' Net dipole moment', + ' ',4F6.2,' ',4F6.2) 1100 FORMAT(1X,'Delocalization correction ',24X,' ',4F6.2,/1X, + ' -----------------------------', + '-----------------------') 1110 FORMAT(1X,' Net dipole moment ',4F6.2,' ',4F6.2,/1X, + ' NLMO coupling correction ',4F6.2,/1X,' ', + ' -------------------------') 1120 FORMAT(1X,' Alpha spin dipole ',4F6.2,' ',4F6.2) 1130 FORMAT(1X,' Beta spin dipole ',4F6.2,' ',4F6.2) 1140 FORMAT(1X,' Total dipole moment ',4F6.2,' ',4F6.2) END ***************************************************************************** SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION DXYZ(NDIM,NDIM),C(NDIM,NDIM),T(NDIM,NDIM),SCR(NDIM,NDIM) Compute the electronic contribution for the x (INDEX=1), y (=2), and z (=3) components of the dipole: Get the AO dipole matrix and transform to the NBO basis: CALL FEDXYZ(DXYZ,INDEX) IF(INDEX.EQ.0) RETURN CALL SIMTRS(DXYZ,T,SCR,NDIM,NBAS) Compute the electronic contribution for doubly occupied, filled NBOs: DO 30 I = 1,NOCC SCR(I,I) = -ETA * DXYZ(I,I) 30 CONTINUE Compute delocalization contributions for each filled NBO: DO 60 I = 1,NOCC DO 50 J = 1,NBAS IF(J.NE.I) THEN SCR(J,I) = C(J,I) * DXYZ(I,I) - C(I,I) * DXYZ(J,I) DO 40 K = 1,NBAS SCR(J,I) = SCR(J,I) - C(K,I) * DXYZ(K,J) 40 CONTINUE SCR(J,I) = ETA * C(J,I) * SCR(J,I) END IF 50 CONTINUE 60 CONTINUE CALL COPY(SCR,DXYZ,NDIM,NBAS,NBAS) RETURN END ***************************************************************************** SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBDXYZ/XDIP,YDIP,ZDIP,CHARGE(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION DX(NDIM,NDIM),DY(NDIM,NDIM),DZ(NDIM,NDIM), + ATCOOR(3,NATOMS) DATA ZERO/0.0D0/ Fetch the atomic coordinates: CALL FECOOR(ATCOOR) Calculate the nuclear contributions to the dipole moment: DO 20 I = 1,NOCC NCTR = MOD(NBOTYP(I),10) X = ZERO Y = ZERO Z = ZERO DO 10 J = 1,NCTR IAT = LABEL(IBXM(I),J+3) X = X + ATCOOR(1,IAT) Y = Y + ATCOOR(2,IAT) Z = Z + ATCOOR(3,IAT) CHARGE(IAT) = CHARGE(IAT) - ETA/NCTR 10 CONTINUE X = ETA * X / NCTR Y = ETA * Y / NCTR Z = ETA * Z / NCTR DX(I,I) = DX(I,I) + X DY(I,I) = DY(I,I) + Y DZ(I,I) = DZ(I,I) + Z 20 CONTINUE RETURN END ***************************************************************************** ROUTINES CALLED BY SR NATHYB, SR CHOOSE: SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR) FUNCTION IWPRJ(NCTR) SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD) SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB) SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP) SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB) SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG) SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI) SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB) SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD) SUBROUTINE FORMT(T,Q,POL) SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT) ***************************************************************************** SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) Label core, valence, and Rydberg NAO's and deplete DM of the density of the core orbitals LOGICAL DETAIL,FIRST PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),BORB(MXBO),POL(NDIM,3), * Q(MXAO,NDIM),HYB(MXAO),BNDOCC(NDIM),ICORE(4),IVAL(4),IANG(5) DATA ZERO,ONE/0.0D0,1.0D0/ DATA IBLK,ICOR,IRYD/' ','CR','Ryd'/ DATA ICHCOR,ICHVAL/'Cor','Val'/ DATA IANG/'s','p','d','f','g'/ Label NAO's on each center: DO 10 I = 1,NBAS LTYP(I) = IRYD 10 CONTINUE IECP = 0 DO 110 NCTR = 1,NATOMS CALL CORTBL(NCTR,ICORE,IECP) CALL VALTBL(NCTR,IVAL) Loop over s,p,d,f orbitals: DO 100 L = 0,3 ITYP = IANG(L+1) LNUM = 2*L + 1 IF(ICORE(L+1).LE.0) GOTO 50 Label core orbitals: DO 40 M = 1,ICORE(L+1) DO 30 LA = 1,LNUM MORB = 0 OCC = -1.0 DO 20 N = 1,NBAS LM = NAOL(N) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(N),50) IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND. + DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND. + LA.EQ.NA) THEN MORB = N OCC = DM(N,N) END IF 20 CONTINUE IF(MORB.EQ.0) THEN WRITE(LFNPR,2500) ITYP,NAMEAT(IATNO(NCTR)),NCTR, + (ICORE(I),I=1,4),M,LA STOP END IF LTYP(MORB) = ICHCOR 30 CONTINUE 40 CONTINUE 50 CONTINUE IF(IVAL(L+1).LE.0) GOTO 90 Label valence orbitals: DO 80 M = 1,IVAL(L+1) DO 70 LA = 1,LNUM MORB = 0 OCC = -1.0 DO 60 N = 1,NBAS LM = NAOL(N) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(N),50) IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND. + DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND. + LA.EQ.NA) THEN MORB = N OCC = DM(N,N) END IF 60 CONTINUE IF(MORB.EQ.0) THEN WRITE(LFNPR,2600) ITYP,NAMEAT(IATNO(NCTR)),NCTR, + (IVAL(I),I=1,4),M,LA STOP END IF LTYP(MORB) = ICHVAL 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE 110 CONTINUE Isolate core orbitals on all atoms, removing their density from the density matrix: DO 300 IAT = 1,NATOMS NB = IUL(IAT) - ILL(IAT) + 1 IAC = 0 FIRST = .TRUE. DO 290 N = ILL(IAT),IUL(IAT) IF(LTYP(N).EQ.ICHCOR) THEN IF(DETAIL.AND.FIRST) THEN FIRST = .FALSE. WRITE(LFNPR,1000) IAT END IF IAC = IAC + 1 IBD = IBD + 1 DO 280 I = 1,NB BORB(I) = ZERO 280 CONTINUE BORB(N-ILL(IAT)+1) = ONE CALL STASH(BORB,IBD,IAT,0,0,POL,Q,HYB) LABEL(IBD,1) = ICOR LABEL(IBD,2) = IBLK LABEL(IBD,3) = IAC LABEL(IBD,4) = IAT BNDOCC(IBD) = DM(N,N) IF(DETAIL) WRITE(LFNPR,1010) IAC,BNDOCC(IBD) IF(DETAIL) WRITE(LFNPR,1020) (BORB(I),I=1,NB) IF(DETAIL) WRITE(LFNPR,1030) IBD,(LABEL(IBD,I),I=1,3) END IF 290 CONTINUE 300 CONTINUE Deplete the density matrix of CR orbitals: CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD) RETURN 1000 FORMAT(/,1X,'Search of DM block for core orbitals on atom:',I4) 1010 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':') 1020 FORMAT(11X,8F7.4) 1030 FORMAT(11X,'*** NBO accepted: Number',I3,'. Label:',A2,A1, + '(',I2,')') 2500 FORMAT(/1X,'Subroutine CORE could not find a ',A1,'-type ', + 'core orbital on atom ',A2,I2,'.',/,1X,'ICORE :',4I3, + ' M :',I3,' LA :',I3) 2600 FORMAT(/1X,'Subroutine CORE could not find a ',A1,'-type ', + 'valence orbital on atom ',A2,I2,'.',/,1X,'IVAL :',4I3, + ' M :',I3,' LA :',I3) END ***************************************************************************** FUNCTION IWPRJ(NCTR) ***************************************************************************** DATA NCTR0/0/ RETURN 0 (NO PROJECTION WANTED) IF NCTR IS UNCHANGED, 1 OTHERWISE. IWPRJ=0 IF(NCTR.EQ.NCTR0) RETURN IWPRJ=1 NCTR0=NCTR RETURN END ***************************************************************************** SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DEPLETE DENSITY MATRIX DM OF CONTRIBUTION FROM B.O.'BORB': DM ==> DM - OCC*BORB*BORB(TRANSPOSE). PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3), * BORB(MXBO),BNDOCC(NDIM) DIMENSION IAT(3) RESTORE DM FROM T DO 10 J=1,NBAS DO 10 I=1,J DM(I,J)=T(I,J) 10 DM(J,I)=DM(I,J) MAIN LOOP OVER NBD AVAILABLE BOND ORBITALS: DO 90 IBD=1,NBD OCC=BNDOCC(IBD) FIND ATOMS FOR B.O. #IBD NCTR=0 DO 20 J=1,3 IAT(J)=LABEL(IBD,J+3) IF(IAT(J).LE.0) GO TO 30 NCTR=NCTR+1 20 CONTINUE RECONSTRUCT BORB FOR B.O. #IBD 30 NELM=0 DO 40 ICTR=1,NCTR IA=IAT(ICTR) IHYB=IATHY(IBD,ICTR)+ILL(IA)-1 P=POL(IBD,ICTR) NH=NORBS(IA) DO 40 IH=1,NH NELM=NELM+1 40 BORB(NELM)=P*Q(IH,IHYB) SUBTRACT OCC*BORB*BORB(T) FROM DM NROW=0 DO 80 ICTR=1,NCTR IA=IAT(ICTR) IU=IUL(IA) IL=ILL(IA) DO 70 IROW=IL,IU NROW=NROW+1 NCOL=0 DO 60 JCTR=1,NCTR JA=IAT(JCTR) JU=IUL(JA) JL=ILL(JA) DO 50 ICOL=JL,JU NCOL=NCOL+1 50 DM(IROW,ICOL)=DM(IROW,ICOL)-OCC*BORB(NROW)*BORB(NCOL) 60 CONTINUE 70 CONTINUE 80 CONTINUE 90 CONTINUE RETURN END ***************************************************************************** SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) ZERO THE MATRIX 'BLK' AND LOAD IN ATOMIC BLOCKS OF DENSITY MATRIX 'DM' FOR THE ATOMS LISTED IN 'IAT' PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION BLK(MXBO,MXBO),DM(NDIM,NDIM),IAT(3) DATA ZERO/0.0D0/ IAT(1)=IAT1 IAT(2)=IAT2 IAT(3)=IAT3 ZERO 'BLK' DO 10 I=1,MXBO DO 10 J=1,MXBO 10 BLK(I,J)=ZERO NROW=0 NCOL=0 DO 50 I=1,3 IA=IAT(I) IF(IA.EQ.0) GO TO 50 IU=IUL(IA) IL=ILL(IA) DO 40 IROW=IL,IU NROW=NROW+1 NCOL=0 DO 30 J=1,3 JA=IAT(J) IF(JA.EQ.0) GO TO 30 JU=IUL(JA) JL=ILL(JA) DO 20 ICOL=JL,JU NCOL=NCOL+1 BLK(NROW,NCOL)=DM(IROW,ICOL) 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE NB=NROW RETURN END ***************************************************************************** SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DETERMINE HOW MUCH OF BORB IS COMPOSED OF PREVIOUSLY USED HYBRIDS. RETURN HYBEXP(I) = EXPECTATION VALUE OF HYBRID "I" IN BORB OVER THE PROJECTION OPERATOR P FOR THE ATOM OF THE HYBRID. IF NO HYBRID ON ATOM I CONTRIBUTES TO BORB, HYBEXP(I) = ZERO. PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION IAT(3),HYB(MXAO),BORB(MXBO),Q(MXAO,NDIM),P(MXAO,MXAO), * PK(MXAO,MXAO),VA(MXAO),VB(MXAO),HYBEXP(3) DATA ZERO,ONE,EPS/0.0D0,1.0D0,1.0D-5/ LOOP OVER ATOMIC HYBRIDS: IAT(1) = IAT1 IAT(2) = IAT2 IAT(3) = IAT3 KMAX = 0 DO 50 I = 1,3 HYBEXP(I) = ZERO IA = IAT(I) IF(IA.EQ.0) GO TO 50 EXTRACT THE ITH ATOMIC HYBRID FROM BORB: NU = IUL(IA) NL = ILL(IA) KMIN = KMAX + 1 KMAX = KMAX + NU - NL + 1 MJ = 0 DO 10 K = KMIN,KMAX MJ = MJ + 1 HYB(MJ) = BORB(K) 10 CONTINUE DO HYBRIDS FROM THE ITH ATOM CONTRIBUTE TO BORB? S = ZERO DO 20 J = 1,MJ S = S + HYB(J)**2 20 CONTINUE IF(S.LT.EPS) GO TO 50 DETERMINE THE PROJECTION EXPECTATION FOR THIS HYBRID: NH = INO(IA) IF(NH.EQ.0) THEN HYBEXP(I) = ONE ELSE CALL FRMPRJ(P,IA,Q,NH,PK,VA,VB) PAV = ZERO DO 40 J = 1,MJ DO 30 K = 1,MJ PAV = PAV + HYB(K) * P(K,J) * HYB(J) 30 CONTINUE 40 CONTINUE HYBEXP(I) = ABS(PAV) / S END IF 50 CONTINUE RETURN END ***************************************************************************** SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DECOMPOSE BOND ORBITAL 'BORB' AND STORE CONSTITUENT HYBRIDS IN Q PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION POL(NDIM,3),Q(MXAO,NDIM),BORB(MXBO),IAT(3),HYB(MXAO) DATA ZERO/0.0D0/ LOOP OVER CENTERS: IAT(1) = IAT1 IAT(2) = IAT2 IAT(3) = IAT3 KMAX = 0 DO 40 I = 1,3 IA = IAT(I) IF(IA.EQ.0) GO TO 40 NU = IUL(IA) NL = ILL(IA) EXTRACT HYBRID FROM BOND ORBITAL FOR ATOM IA: KMIN = KMAX + 1 KMAX = KMAX + NU - NL + 1 MJ = 0 DO 10 K = KMIN,KMAX MJ = MJ + 1 HYB(MJ) = BORB(K) 10 CONTINUE EXTRACT POLARIZATION COEFFICIENT, STORE IN 'POL': PSQ = ZERO DO 20 J = 1,MJ PSQ = PSQ + HYB(J)**2 20 CONTINUE P = SQRT(PSQ) POL(IBD,I) = P ONE MORE HYBRID FOR ATOM IA: INO(IA) = INO(IA) + 1 NCOL = ILL(IA) + INO(IA) - 1 PLACE NORMALIZED HYBRID IN APPROPRIATE BLOCK OF Q: NH = NU - NL + 1 DO 30 NROW = 1,NH IF(P.EQ.ZERO) THEN Q(NROW,NCOL) = ZERO ELSE Q(NROW,NCOL) = HYB(NROW)/P END IF 30 CONTINUE IATHY(IBD,I) = INO(IA) 40 CONTINUE RETURN END ***************************************************************************** SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SYMMETRIC ORTHOGONALIZATION OF AVAILABLE HYBRIDS IN Q: PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + ILU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION Q(MXAO,NDIM),S(MXBO,MXBO),TA(MXAO,MXAO), * EVAL(MXBO),C(MXBO,MXBO) DATA ZERO,ONE/0.0D0,1.0D0/ DATA TOOSML/1.0D-4/ TOOSML: "TOO SMALL" -- THRESHOLD FOR AN S MATRIX EIGENVALUE THAT IS TOO SMALL AND WILL CAUSE NUMERICAL PROBLEMS AND IS INDICATIVE OF NEAR-LINEAR DEPENDENCY IN THE HYBRIDS: IALARM = 0 DO 100 IA = 1,NATOMS IL = LL(IA) NH = INO(IA) IF(NH.GT.MXAO) GO TO 800 IF(NH.LE.1) GO TO 100 LOAD IA-BLOCK OF Q INTO TA: DO 10 J = 1,NH DO 5 I = 1,MXAO TA(I,J) = Q(I,IL+J-1) 5 CONTINUE 10 CONTINUE FORM OVERLAP MATRIX S = TA(TRANSP)*TA: DO 30 J = 1,NH DO 25 I = J,NH TEMP = ZERO DO 20 K = 1,MXAO TEMP = TEMP + TA(K,I) * TA(K,J) 20 CONTINUE S(I,J) = TEMP S(J,I) = TEMP 25 CONTINUE 30 CONTINUE DIAGONALIZE OVERLAP MATRIX: CALL JACOBI(NH,S,EVAL,C,MXBO,MXBO,0) FORM INVERSE SQUARE ROOT OF S, STORE IN S: (AVOID NUMERICAL PROBLEMS OF LINEAR DEPENDENCE ("TOO SMALL" EIGENVALUES) BY PRESCREENING THE EIGENVALUES) DO 40 I = 1,NH IF(EVAL(I).LT.TOOSML) GO TO 810 EVAL(I) = ONE / SQRT(EVAL(I)) 40 CONTINUE DO 60 J = 1,NH DO 55 I = J,NH TEMP = ZERO DO 50 K = 1,NH TEMP = TEMP + EVAL(K) * C(I,K) * C(J,K) 50 CONTINUE S(I,J) = TEMP S(J,I) = TEMP 55 CONTINUE 60 CONTINUE FORM NEW TAP=TA*S**(-1/2), STORE IN C: DO 80 J = 1,NH DO 75 I = 1,MXAO TEMP = ZERO DO 70 K = 1,NH TEMP = TEMP + TA(I,K) * S(K,J) 70 CONTINUE C(I,J) = TEMP 75 CONTINUE 80 CONTINUE REPLACE ORTHOGONALIZED TA IN ARRAY Q: DO 90 J = 1,NH DO 85 I = 1,MXAO Q(I,IL+J-1) = C(I,J) 85 CONTINUE 90 CONTINUE 100 CONTINUE SYMMETRIC ORTHOGONALIZATION COMPLETE: RETURN SOUND THE ALARM THAT TOO MANY HYBRIDS WERE FOUND ON THIS ATOM: 800 CONTINUE IALARM = IA IF(IFLG.EQ.0) WRITE(LFNPR,900) MXAO,IA,NH RETURN SOUND THE ALARM THAT THERE ARE TOO MANY HYBRIDS OR THAT THERE IS LINEAR DEPENDENCY IN THE HYBRIDS!! 810 CONTINUE IALARM = IA IF(IFLG.EQ.0) WRITE(LFNPR,910) IA,EVAL(I),TOOSML RETURN 900 FORMAT(/4X,'Only expected to find',I3,' hybrids on atom',I3, + ', but found',I3,'.') 910 FORMAT(/4X,'The hybrids on atom',I3,' are linearly dependent.', + ' An eigenvalue (',F10.6,')',/4X,'of the hybrid overlap ', + 'matrix is too small (<',F7.5,').') END ***************************************************************************** SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) FORM PROJECTION MATRIX P TO ANNIHILATE COMPONENTS OF NK OCCUPIED HYBRIDS FOR ATOM IA. PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION P(MXAO,MXAO),VK(MXAO),PI(MXAO),Q(MXAO,NDIM), * PK(MXAO,MXAO) DATA ZERO,ONE/0.0D0,1.0D0/ INITIALIZE P = UNIT MATRIX: NB = NORBS(IA) DO 10 J = 1,NB DO 5 I = 1,J P(I,J) = ZERO P(J,I) = ZERO IF(I.EQ.J) P(I,J) = ONE 5 CONTINUE 10 CONTINUE FORM PROJECTION MATRIX P = P1*P2*...*PK*...*PNK TO ANNIHILATE COMPONENTS OF THE NK OCCUPIED HYBRIDS VK: PK = I - VK*VK(T). LOOP OVER OCCUPIED HYBRIDS VK, K = 1,...,NK: IF(NK.LE.0) RETURN EXTRACT OCCUPIED HYBRID VK FROM ARRAY Q: DO 90 K = 1,NK ICOL = ILL(IA) + K - 1 DO 30 I = 1,NB VK(I) = Q(I,ICOL) 30 CONTINUE FORM PROJECTION MATRIX PK: DO 40 J = 1,NB DO 35 I = 1,J PK(I,J) = -VK(I) * VK(J) PK(J,I) = PK(I,J) IF(I.EQ.J) PK(I,J) = PK(I,J) + ONE 35 CONTINUE 40 CONTINUE ACCUMULATE TOTAL PROJECTOR P(K) = P(K-1)*PK: DO 80 I = 1,NB DO 60 J = 1,NB PI(J) = ZERO DO 50 L = 1,NB PI(J) = PI(J) + P(I,L) * PK(L,J) 50 CONTINUE 60 CONTINUE DO 70 J = 1,NB P(I,J) = PI(J) 70 CONTINUE 80 CONTINUE 90 CONTINUE RETURN END ***************************************************************************** SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION P(MXAO,MXAO),TA(MXAO,MXAO),DM(NDIM,NDIM),C(MXBO,MXBO), + EVAL(MXBO),BORB(MXBO),V(MXBO),BLK(MXBO,MXBO),LARC(NBAS) DATA ZERO,EPS,PT99,ONE/0.0D0,1.0D-5,0.99D0,1.0D0/ FIRST, FORM SET OF "OPTIMALLY DIAGONAL" UNIT VECTORS TO SPAN RYDBERG SPACE: NAUG = NORB - NOCC DO 10 I = 1,NORB LARC(I) = 0 10 CONTINUE SELECT PROJECTED NAO UNIT VECTOR FROM PROJECTOR IN P: DO 300 IPROJ = 1,NAUG IMAX = 0 PRJMAX = ZERO DO 80 IAO = 1,NORB IF(LARC(IAO).NE.0) GO TO 80 PROJ = ABS(P(IAO,IAO)) IF(PROJ.GT.PT99) GO TO 100 IF(PROJ.LT.PRJMAX) GO TO 80 PRJMAX = PROJ IMAX = IAO 80 CONTINUE IAO = IMAX PROJ = PRJMAX 100 CONTINUE PUT VECTOR IN BORB, NORMALIZE, AND SAVE IN C: SB = ZERO DO 120 J = 1,NORB B = P(IAO,J) SB = SB + B * B BORB(J) = B 120 CONTINUE LARC(IAO) = IPROJ RNORM = ONE / SQRT(SB) DO 130 J = 1,NORB BORB(J) = BORB(J) * RNORM 130 CONTINUE DO 140 J = 1,NORB C(J,IPROJ) = BORB(J) 140 CONTINUE IF(IPROJ.EQ.NAUG) GO TO 300 ADD BORB TO THE PROJECTOR IN P: DO 150 J = 1,NORB DO 145 I = 1,J TA(I,J) = -BORB(I) * BORB(J) TA(J,I) = TA(I,J) IF(I.EQ.J) TA(I,I) = TA(I,I) + ONE 145 CONTINUE 150 CONTINUE DO 200 I = 1,NORB DO 180 J = 1,NORB V(J) = ZERO DO 170 L = 1,NORB V(J) = V(J) + P(I,L) * TA(L,J) 170 CONTINUE 180 CONTINUE DO 190 J = 1,NORB P(I,J) = V(J) 190 CONTINUE 200 CONTINUE 300 CONTINUE PUT PROJECTED VECTORS IN TA, ORDERED ACCORDING TO THE NAO PARENT: IAUG = 0 DO 350 IAO = 1,NORB IF(LARC(IAO).EQ.0) GO TO 350 IAUG = IAUG + 1 ITCOL = LARC(IAO) DO 330 J = 1,NORB TA(J,IAUG) = C(J,ITCOL) 330 CONTINUE 350 CONTINUE LOAD DM BLOCK FOR ATOM IA IN BLK: CALL LOAD(DM,IA,0,0,BLK,NORB) FORM BLOCK OF DM IN RYDBERG BASIS IN UPPER CORNER OF BLK: DO 500 IB = 1,NORB DO 450 J = 1,NAUG SUM = ZERO DO 440 K = 1,NORB SUM = SUM + BLK(IB,K) * TA(K,J) 440 CONTINUE V(J) = SUM 450 CONTINUE DO 480 J = 1,NAUG BLK(IB,J) = V(J) 480 CONTINUE 500 CONTINUE DO 550 J = 1,NAUG DO 520 I = 1,J SUM = ZERO DO 510 K = 1,NORB SUM = SUM + TA(K,I) * BLK(K,J) 510 CONTINUE V(I) = SUM 520 CONTINUE DO 530 I = 1,NAUG BLK(I,J) = V(I) 530 CONTINUE 550 CONTINUE DO 560 J = 1,NAUG JJ = J - 1 DO 555 I = 1,JJ BLK(J,I) = BLK(I,J) 555 CONTINUE 560 CONTINUE DIAGONALIZE DM: CALL JACOBI(NAUG,BLK,EVAL,C,MXBO,MXBO,1) ORDER EIGENVECTORS BY OCCUPANCY (WITHIN EPS), FORM FINAL RYDBERG VECTORS: DO 570 I = 1,NAUG LARC(I) = I 570 CONTINUE NAUG1 = NAUG - 1 DO 620 I = 1,NAUG1 I1 = I + 1 DO 610 J = I1,NAUG DIFF = EVAL(J) - EVAL(I) IF(DIFF.LT.EPS) GO TO 610 TEMP = EVAL(I) EVAL(I) = EVAL(J) EVAL(J) = TEMP ITEMP = LARC(I) LARC(I) = LARC(J) LARC(J) = ITEMP 610 CONTINUE 620 CONTINUE DO 700 J = 1,NAUG LJ = LARC(J) DO 680 I = 1,NORB SUM = ZERO DO 670 K = 1,NAUG SUM = SUM + TA(I,K) * C(K,LJ) 670 CONTINUE BLK(I,J) = SUM 680 CONTINUE 700 CONTINUE RETURN END ***************************************************************************** SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL PRINT,FIRST DIAGONALIZE DENSITY MATRIX IN BASIS OF ORTHONORMAL HYBRIDS FOR EACH BOND ORBITAL TO FIND NEW POLARIZATION COEFFICIENTS. PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION DM(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3), * BLK(MXBO,MXBO),EVAL(MXBO),C(MXBO,MXBO) DATA ZERO,PT1,ONE,TWO/0.0D0,0.1D0,1.0D0,2.0D0/ DATA LSTAR/1H*/ FIRST, COUNT NUMBER OF BONDS AND 3C BONDS: NBOND = 0 N3CB = 0 DO 20 IB = 1,NBAS IF(LABEL(IB,2).EQ.LSTAR) GO TO 20 IF(LABEL(IB,5).EQ.0) GO TO 20 NBOND = NBOND + 1 IF(LABEL(IB,6).EQ.0) GO TO 20 N3CB = N3CB + 1 20 CONTINUE IAB+1 IS THE NUMBER OF THE FIRST ANTIBOND IN THE NBO LIST: IAB = NBAS - NBOND - N3CB PRINT = JPRINT(5).EQ.1 FIRST = .TRUE. APCOEF = ONE / SQRT(TWO) DO 200 IB = 1,NBD IF(LABEL(IB,2).EQ.LSTAR) GO TO 200 NCTR = 1 IF(LABEL(IB,5).GT.0) NCTR = 2 IF(LABEL(IB,6).GT.0) NCTR = 3 IF(NCTR.EQ.1) GO TO 200 IF(IWAPOL.EQ.0.OR.NCTR.EQ.3) THEN DO 120 I = 1,NCTR IA = LABEL(IB,I+3) NHI = NORBS(IA) DO 115 J = 1,I JA = LABEL(IB,J+3) NHJ = NORBS(JA) DIJ = ZERO DO 110 IR = 1,NHI IRP = ILL(IA)+IR-1 CRI = Q(IR,ILL(IA)+IATHY(IB,I)-1) DO 105 JS = 1,NHJ JSP = ILL(JA) + JS - 1 CSJ = Q(JS,ILL(JA)+IATHY(IB,J)-1) DIJ = DIJ+CRI*CSJ*DM(IRP,JSP) 105 CONTINUE 110 CONTINUE BLK(I,J) = DIJ BLK(J,I) = DIJ 115 CONTINUE 120 CONTINUE DIAGONALIZE 'BLK' AND EXTRACT NEW POLARIZATION COEFFICIENTS CALL JACOBI(NCTR,BLK,EVAL,C,MXBO,MXBO,0) CALL RANK(EVAL,NCTR,MXBO,LARC) MAKE SURE REPOLARIZATION IS NOT TOO DRASTIC (TAKE A LOOK AT THE BOND ORBITAL ONLY): S = ZERO DO 125 I = 1,NCTR S = S + POL(IB,I) * C(I,LARC(1)) 125 CONTINUE IF(S.LT.PT1.AND.NCTR.EQ.2) THEN IF(FIRST.AND.PRINT) WRITE(LFNPR,*) FIRST = .FALSE. IF(PRINT) WRITE(LFNPR,900) IB,S IAB = IAB + 1 POL(IAB,1) = POL(IB,2) POL(IAB,2) = -POL(IB,1) ELSE STORE THE NEW POLARIZATION COEFFICIENTS IN POL: DO 130 I = 1,NCTR POL(IB,I) = C(I,LARC(1)) 130 CONTINUE IAB = IAB + 1 DO 150 I = 1,NCTR POL(IAB,I) = C(I,LARC(2)) 150 CONTINUE IF(NCTR.NE.3) GO TO 200 IAB = IAB + 1 DO 160 I = 1,NCTR POL(IAB,I) = C(I,LARC(3)) 160 CONTINUE END IF CONSTRAIN BONDS TO BE APOLAR, IF REQUESTED (NOT SET UP TO WORK WITH 3-CENTER BONDS): ELSE POL(IB,1) = APCOEF POL(IB,2) = APCOEF IAB = IAB + 1 POL(IAB,1) = APCOEF POL(IAB,2) = -APCOEF END IF 200 CONTINUE RETURN 900 FORMAT(1X,'WARNING: significant repolarization of NBO ',I3,' (S=', + F7.4,'); REPOL disabled.') END ***************************************************************************** SUBROUTINE FORMT(T,Q,POL) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) INTEGER UL CONSTRUCTION OF FINAL TRANSFORMATION MATRIX T FROM ORTHONORMAL HYBRIDS; ROWS OF T LABELLED BY NAOS, COLUMNS BY NBOS. PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOC(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),IBX(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOCTR(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3) DATA LCR,LLP,LBD,LSTAR,LRY/'CR','LP','BD','*','RY'/ DATA ZERO/0.0D0/ REORDER OCCUPIED NBOS TO PUT LONE AND CORE PAIRS LAST: NCR = 0 NLP = 0 NBDS = 0 DO 10 NSCAN = 1,NBAS IF(LABEL(NSCAN,2).EQ.LSTAR) GO TO 10 NBDS = NBDS + 1 IF(LABEL(NSCAN,1).EQ.LLP) NLP = NLP + 1 IF(LABEL(NSCAN,1).EQ.LCR) NCR = NCR + 1 10 CONTINUE ICR = 0 ILP = 0 IBO = 0 IAB = 0 DO 40 IBD = 1,NBAS IF(LABEL(IBD,2).EQ.LSTAR) GO TO 30 IF(LABEL(IBD,1).EQ.LCR) GO TO 15 IF(LABEL(IBD,1).EQ.LLP) GO TO 20 PAIR BONDS: IBO = IBO + 1 IBX(IBD) = IBO GO TO 40 CORE PAIRS: 15 ICR = ICR + 1 IBX(IBD) = ICR + NBDS - NCR - NLP GO TO 40 LONE PAIRS AND CORE PAIRS: 20 ILP = ILP + 1 IBX(IBD) = ILP + NBDS - NLP GO TO 40 ANTIBONDS: 30 IAB = IAB + 1 IBX(IBD) = NBDS + IAB 40 CONTINUE ZERO TRANSFORMATION ARRAY: DO 60 I = 1,NBAS DO 50 J = 1,NBAS T(I,J) = ZERO 50 CONTINUE 60 CONTINUE DEPOSIT FINAL BOND ORBITALS IN MATRIX T: NBO = 0 DO 130 IBD = 1,NBAS KBD = IBD IF(LABEL(IBD,2).NE.LSTAR) GO TO 100 IF(LABEL(IBD,1).EQ.LRY) GO TO 100 IF(LABEL(IBD,1).EQ.LLP) GO TO 100 ANTIBOND ORBITALS: SEARCH OCCUPIED ORB. LIST TO GET PROPER HYBRIDS. SEARCH OCCUPIED BOND ORBS. FOR MATCH WITH ANTIBOND ATOMS: DO 90 K = 1,NBO DO 70 I = 4,6 IF(LABEL(K,I).NE.LABEL(IBD,I)) GO TO 90 IF((LABEL(K,3).LE.0).AND.(LABEL(K,1).EQ.LBD)) GO TO 90 70 CONTINUE NEGATIVE IRNK = LABEL(K,3) MEANS BOND ORBITAL WAS ALREADY USED: FOUND MATCH; SET LABEL(K,3)<0: KBD = K LABEL(KBD,3) = -LABEL(KBD,3) GO TO 100 90 CONTINUE COULDN'T FIND MATCH...EXIT: WRITE(LFNPR,9000) IBD,(LABEL(IBD,JJ),JJ=1,6) STOP DEPOSIT BOND ORBITALS IN T MATRIX: 100 CONTINUE DO 120 I = 1,3 IA = LABEL(IBD,I+3) IF(IA.EQ.0) GO TO 120 JL = LL(IA) JU = UL(IA) IROW = 0 ICOL = JL + IATHY(KBD,I) - 1 DO 110 J = JL,JU IROW = IROW + 1 JB = IBX(IBD) 110 T(J,JB) = POL(IBD,I) * Q(IROW,ICOL) 120 CONTINUE IF(IBD.EQ.KBD) NBO = IBD 130 CONTINUE RESTORE LABEL(I,3) > 0: DO 140 I = 1,NBAS IF(LABEL(I,3).LT.0) LABEL(I,3) = -LABEL(I,3) 140 CONTINUE SET ARRAY IBXM: IBXM(IB) IS THE CURRENT LOCATION OF B.O. # IB: DO 150 IB = 1,NBAS I = IBX(IB) 150 IBXM(I) = IB SET PHASE OF 1-CENTER ORBITALS SUCH THAT THE LARGEST S-TYPE NAO CONTRIBUTION IS POSITIVE: DO 200 IB = 1,NBAS NCTR = 1 DO 160 IL = 5,6 IF(LABEL(IBXM(IB),IL).NE.0) NCTR = NCTR + 1 160 CONTINUE IF(NCTR.EQ.1) THEN JMAX = 0 TMAX = -1.0D0 DO 170 IN = 1,NBAS IF(NAOA(IN).LT.100) THEN IF(ABS(T(IN,IB)).GT.TMAX) THEN JMAX = IN TMAX = ABS(T(IN,IB)) END IF END IF 170 CONTINUE IF(JMAX.NE.0) THEN IF(T(JMAX,IB).LT.-1.0D-4) THEN DO 180 IN = 1,NBAS T(IN,IB) = -T(IN,IB) 180 CONTINUE END IF END IF END IF 200 CONTINUE RETURN 9000 FORMAT(/,1X,'Can''t find bond/antibond match for NBO ', + I3,2X,A2,A1,'(',I2,')',3I4) END ***************************************************************************** SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM), + N3CTR,I3CTR(10,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION GUIDE(NATOMS,NATOMS),BNDOCC(NDIM),TOPO(NATOMS,NATOMS) SAVE JTER,DEVMIN,RHOMIN,BEST,RHO,JBADL DATA LCR,LBD,L3C,LLP,LSTAR/2HCR,2HBD,2H3C,2HLP,1H*/ DATA SMALL,ZERO,TENTH,ONE,ONEPT5,THREE,HUNDRD + /1.0D-4,0.0D0,0.1D0,1.0D0,1.5D0,3.0D0,1.0D2/ DATA DEVTHR/0.1D0/ DATA JTERMX/9/ Subroutine CYCLES controls the search for an acceptable resonance structure: Arguments: ITER : iteration counter incremented by the calling routine THRESH : occupancy threshold used in search for NBOs GUIDE : Wiberg bond index BNDOCC : array containing the NBO occupancies TOPO : bond index matrix to be compared with the Wiberg indices ICONT : control flag (see below) ITER, GUIDE, and BNDOCC are unaltered by this routine THRESH is modified by this routine, if the RESONANCE keyword is selected The TOPO matrix is constructed by this routine Control flag : (set by this routine) ICONT = 2 : an acceptable Lewis structure has been found, continue = 1 : an acceptable Lewis structure has been found, recompute the NBOs for this structure = 0 : bogus Lewis structure, terminate search for NBOs = -1 : occupancy threshold and/or atom ordering have been changed. Repeat the search for NBOs. Set atom permuting counter and minimum deviation in GUIDE-TOPO: IF(ITER.EQ.1) THEN JTER = 0 ICONT = -1 END IF JTER = JTER + 1 IF(JTER.EQ.1) DEVMIN = HUNDRD The minimum occupancy threshold is 1.5e (0.5e for open shell): THRMIN = ONEPT5 IF(ISPIN.NE.0) THRMIN = THRMIN - ONE Determine the number of low occupancy orbitals in the Lewis structure: IBADL = 0 IBADNL = 0 SUMLEW = ZERO TOTELE = ZERO DO 10 I = 1,NBAS TOTELE = TOTELE + BNDOCC(I) IF(LABEL(IBXM(I),2).NE.LSTAR) THEN SUMLEW = SUMLEW + BNDOCC(I) IF(BNDOCC(I).LT.THRESH) IBADL = IBADL + 1 ELSE IF(BNDOCC(I).GT.ABS(ACCTHR)) IBADNL = IBADNL + 1 END IF 10 CONTINUE NEL = TOTELE + TENTH TOTELE = NEL SUM = TOTELE - SUMLEW Count the ECP electrons in the Lewis structure: IF(IPSEUD.NE.0) THEN MECP = 0 DO 20 IAT = 1,NATOMS MECP = MECP + IATNO(IAT) - IZNUC(IAT) 20 CONTINUE IF(ISPIN.NE.0) MECP = MECP/2 SUMLEW = SUMLEW + FLOAT(MECP) END IF Keep track of the best Lewis structure found so far: IF(JTER.EQ.1) RHOMIN = HUNDRD IF(ITER.EQ.1.OR.SUM.LT.RHO) THEN BEST = THRESH RHO = SUM JBADL = IBADL DO 25 I = 1,NATOMS JORDER(I) = IORDER(I) 25 CONTINUE END IF Count the number of core, lone pair, and bonding orbitals in this resonance structure: MCR = 0 MBD = 0 M3C = 0 MLP = 0 DO 30 I = 1,NBAS IF(LABEL(I,1).EQ.LCR.AND.LABEL(I,2).NE.LSTAR) MCR = MCR + 1 IF(LABEL(I,1).EQ.LBD.AND.LABEL(I,2).NE.LSTAR) MBD = MBD + 1 IF(LABEL(I,1).EQ.L3C.AND.LABEL(I,2).NE.LSTAR) M3C = M3C + 1 IF(LABEL(I,1).EQ.LLP.AND.LABEL(I,2).NE.LSTAR) MLP = MLP + 1 30 CONTINUE Build the TOPO matrix from lone pairs and 2- and 3-center bonds: DO 50 I = 1,NATOMS DO 40 J = 1,NATOMS TOPO(I,J) = ZERO 40 CONTINUE 50 CONTINUE DO 60 I = 1,NBAS IB = IBXM(I) IF(LABEL(IB,1).NE.LCR.AND.LABEL(IB,2).NE.LSTAR) THEN IAT1 = LABEL(IB,4) NCTR = 1 IAT2 = LABEL(IB,5) IF(IAT2.NE.0) NCTR = 2 IAT3 = LABEL(IB,6) IF(IAT3.NE.0) NCTR = 3 IF(NCTR.EQ.1) THEN TOPO(IAT1,IAT1) = TOPO(IAT1,IAT1) + ONE ELSE IF(NCTR.EQ.2) THEN TOPO(IAT1,IAT2) = TOPO(IAT1,IAT2) + ONE TOPO(IAT2,IAT1) = TOPO(IAT2,IAT1) + ONE ELSE TOPO(IAT1,IAT2) = TOPO(IAT1,IAT2) + ONE/THREE TOPO(IAT2,IAT1) = TOPO(IAT2,IAT1) + ONE/THREE TOPO(IAT1,IAT3) = TOPO(IAT1,IAT3) + ONE/THREE TOPO(IAT3,IAT1) = TOPO(IAT3,IAT1) + ONE/THREE TOPO(IAT2,IAT3) = TOPO(IAT2,IAT3) + ONE/THREE TOPO(IAT3,IAT2) = TOPO(IAT3,IAT2) + ONE/THREE END IF END IF 60 CONTINUE Determine the largest off-diagonal element of GUIDE-TOPO: DEV = ZERO DO 80 J = 2,NATOMS DO 70 I = 1,J-1 IF(GUIDE(I,J)-TOPO(I,J).GT.DEV) THEN DEV = GUIDE(I,J) - TOPO(I,J) IAT = I JAT = J END IF 70 CONTINUE 80 CONTINUE Write info about this resonance structure: IF(JPRINT(5).EQ.1) THEN IF(ITER.EQ.1) WRITE(LFNPR,1000) WRITE(LFNPR,1010) ITER,JTER,ABS(THRESH),SUMLEW,SUM,MCR,MBD, + M3C,MLP,IBADL,IBADNL,DEV END IF Decide if this structure is acceptable: * Accept the structure if CHOOSE was employed. * Accept the structure if there is only one atom. * Accept the structure if there are no low occupancy Lewis orbitals and DEV is less than DEVTHR. * Accept the structure if the NOBOND option was selected. Good resonance structure: IF(IBADL.EQ.0.AND.DEV.LT.DEVTHR) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030) ICONT = 2 RETURN Only one atom: ELSE IF(NATOMS.EQ.1) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1035) ICONT = 2 RETURN Directed NBO search: ELSE IF(ICHOOS.EQ.1) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1040) ICONT = 2 RETURN NOBOND option selected: ELSE IF(JPRINT(10).NE.0) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1050) ICONT = 2 RETURN END IF Structure accepted due to the specification of the RESONANCE keyword or the occupancy threshold. Otherwise, accept the structure only if there are no high occupancy Lewis orbitals: IF(ICONT.EQ.1) THEN IF(THRSET.GE.ZERO) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1060) ICONT = 2 ELSE IF(JPRINT(14).NE.0) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1070) ICONT = 2 ELSE IF(IBADL.NE.0) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030) ICONT = 2 END IF RETURN END IF If DEV.EQ.DEVMIN.AND.SUM.EQ.RHOMIN or too many atoms permutations, stop atom permutations: IF((ABS(DEV-DEVMIN).LT.SMALL.AND.ABS(SUM-RHOMIN).LT.SMALL).OR. + JTER.GE.JTERMX) THEN If the occupancy threshold was set by the user, accept the best structure: IF(THRSET.GE.ZERO) THEN IF(ABS(SUM-RHO).LT.SMALL) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1060) ICONT = 2 ELSE DO 90 I = 1,NATOMS IORDER(I) = JORDER(I) 90 CONTINUE JTER = 0 ICONT = 1 END IF If the RESONANCE keyword was specified, pick the best resonance structure for this occupancy threshold, and possibly decrement the threshold and continue the search: ELSE IF(JPRINT(14).NE.0) THEN THRESH = THRESH - TENTH IF(THRMIN-THRESH.GT.SMALL) THEN THRESH = THRESH + TENTH IF(ABS(THRESH-BEST).LT.SMALL.AND.ABS(SUM-RHO).LT.SMALL) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1070) ICONT = 2 ELSE DO 100 I = 1,NATOMS IORDER(I) = JORDER(I) 100 CONTINUE THRESH = BEST JTER = 0 ICONT = 1 END IF ELSE DO 110 I = 1,NATOMS IORDER(I) = JORDER(I) 110 CONTINUE JTER = 0 ICONT = -1 END IF Otherwise, accept the best structure, but only if it had no Lewis orbitals with occupancy less than the occupancy threshold: ELSE IF(ABS(SUM-RHO).LT.SMALL.AND.IBADL.EQ.0) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030) ICONT = 2 ELSE IF(JBADL.EQ.0) THEN DO 115 I = 1,NATOMS IORDER(I) = JORDER(I) 115 CONTINUE JTER = 0 ICONT = 1 ELSE IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1080) ICONT = 0 END IF END IF RETURN Loop through atom ordering to find alternative resonance structures: ELSE IF(DEV.LT.DEVMIN) DEVMIN = DEV IF(SUM.LT.RHOMIN) RHOMIN = SUM IF(IAT.EQ.IORDER(1).AND.JAT.EQ.IORDER(2)) THEN DEV1 = ZERO DO 130 J = 2,NATOMS DO 120 I = 1,J-1 IF(GUIDE(I,J)-TOPO(I,J).GT.DEV1) THEN IF((I.NE.IORDER(1).AND.J.NE.IORDER(2)).AND. + (J.NE.IORDER(1).AND.I.NE.IORDER(2))) THEN DEV1 = GUIDE(I,J) - TOPO(I,J) IAT = I JAT = J END IF END IF 120 CONTINUE 130 CONTINUE END IF JFLG = 0 DO 140 I = NATOMS,2,-1 IF(IORDER(I).EQ.JAT) JFLG = 1 IF(JFLG.EQ.1) IORDER(I) = IORDER(I-1) 140 CONTINUE IORDER(1) = JAT IFLG = 0 DO 150 I = NATOMS,2,-1 IF(IORDER(I).EQ.IAT) IFLG = 1 IF(IFLG.EQ.1) IORDER(I) = IORDER(I-1) 150 CONTINUE IORDER(1) = IAT ICONT = -1 END IF RETURN 1000 FORMAT(/1X,' Occupancies Lewis ', + 'Structure Low High',/1X,' Occ. --------', + '----------- ----------------- occ occ',/1X,' Cycle ', + ' Thresh. Lewis Non-Lewis CR BD 3C LP (L) ', + ' (NL) Dev',/1X,77('=')) 1010 FORMAT(1X,I3,'(',I1,')',3X,F5.2,F12.5,F10.5,3X,4I4,2X,I4,3X,I4, + 3X,F5.2) 1020 FORMAT(1X,77('-')) 1030 FORMAT(/1X,'Structure accepted: No low occupancy Lewis orbitals') 1035 FORMAT(/1X,'Structure accepted: Only a single atom') 1040 FORMAT(/1X,'Structure accepted: NBOs selected via the $CHOOSE ', + 'keylist') 1050 FORMAT(/1X,'Structure accepted: Search for bonds prevented ', + 'by NOBOND keyword') 1060 FORMAT(/1X,'Structure accepted: Occupancy threshold (THRESH) ', + 'set by user') 1070 FORMAT(/1X,'Structure accepted: RESONANCE keyword permits ', + 'strongly delocalized structure') 1080 FORMAT(/1X,'Only strongly delocalized resonance structures can', + ' be found.',/1X,'The default procedure is to abort the NBO ', + 'search. Include',/1X,'the RESONANCE keyword in the $NBO ', + 'keylist to override this test.') END ***************************************************************************** ROUTINES CALLED BY SR NLMO: SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT, + NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM) SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL) ***************************************************************************** SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT, * NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION TSYM(NROT,NROT),A(NDIM,NDIM),BLK(NROT,NROT), * OVLP(NROT,NROT),EVAL(NROT) DIMENSION IOFF(NOFF),JOFF(NOFF),ILIST(NOFF),JLIST(NOFF) DATA ZERO,ONE/0.0D0,1.0D0/ DATA EPS/1.0D-6/ DO 40 I=1,NROT DO 30 J=1,NROT 30 TSYM(I,J)=ZERO 40 TSYM(I,I)=ONE DO 60 MOFF=1,NOFF IOCC=ILIST(MOFF) JEMT=JLIST(MOFF) DO 60 I=1,NROT T=TSYM(I,IOCC) U=TSYM(I,JEMT) TSYM(I,IOCC)=COS*T-SIN*U 60 TSYM(I,JEMT)=SIN*T+COS*U AVERAGE GROUPS OF THE ELEMENTS OF THE TRANSFORMATION MATRIX TSYM SO THAT THE SYMMETRY INHERENT IN THE DENSITY MATRIX A IS PRESERVED, MAKING SURE THAT THE RESULTING "AVERAGED" TRANSFORMATION IS UNITARY JST=NIUNIQ+1 NROT=JST-1+NJUNIQ AVE. DIAG. ELEM OF OCC ORBS IF(NIUNIQ.EQ.1) GO TO 140 TOT=ZERO DO 100 I=1,NIUNIQ 100 TOT=TOT+TSYM(I,I) AVE=TOT/NIUNIQ DO 110 I=1,NIUNIQ 110 TSYM(I,I)=AVE AVE. DIAG. ELEM OF EMPTY ORBS 140 IF(NJUNIQ.EQ.1) GO TO 180 TOT=ZERO DO 150 J=JST,NROT 150 TOT=TOT+TSYM(J,J) AVE=TOT/NJUNIQ DO 160 J=JST,NROT 160 TSYM(J,J)=AVE ZERO OFFDIAG ELEM BETW OCC ORBS: 180 IF(NIUNIQ.EQ.1) GO TO 240 DO 220 I=2,NIUNIQ DO 220 J=1,I IF(I.EQ.J) GO TO 220 TSYM(I,J)=ZERO TSYM(J,I)=ZERO 220 CONTINUE ZERO OFFDIAG ELEM BETW EMPTY ORBS: 240 IF(NJUNIQ.EQ.1) GO TO 280 JST2=JST+1 DO 270 I=JST2,NROT DO 270 J=JST,I IF(I.EQ.J) GO TO 270 TSYM(I,J)=ZERO TSYM(J,I)=ZERO 270 CONTINUE AVE. OFFDIAG ELEM BETW OCC AND EMPTY ORBS (PIVOTED ELEMENTS ONLY): 280 CONTINUE TOT=ZERO DO 310 MOFF=1,NOFF II=ILIST(MOFF) JJ=JLIST(MOFF) 310 TOT=TOT+ABS(TSYM(II,JJ))+ABS(TSYM(JJ,II)) NOFF2=NOFF*2 AVE=TOT/NOFF2 DO 330 MOFF=1,NOFF II=ILIST(MOFF) JJ=JLIST(MOFF) TSYM(II,JJ)=-AVE 330 TSYM(JJ,II)= AVE NOW ZERO THE NON-PIVOTED ELEMENTS: DO 450 I=1,NIUNIQ DO 440 J=JST,NROT DO 420 MOFF=1,NOFF IF(I.EQ.ILIST(MOFF).AND.J.EQ.JLIST(MOFF)) GO TO 440 420 CONTINUE TSYM(I,J)= ZERO TSYM(J,I)= ZERO 440 CONTINUE 450 CONTINUE RENORMALIZE VECTORS: DO 700 J=1,NROT TOT=ZERO DO 650 I=1,NROT 650 TOT=TOT+TSYM(I,J)*TSYM(I,J) RNORM=SQRT(TOT) IF(RNORM.GT.EPS) GO TO 680 WRITE(LFNPR,2880) NROT,TOT,EPS,RNORM 2880 FORMAT('NROT,TOT,EPS,RNORM:',I3,3F14.9) CALL ALTOUT(TSYM,NROT,NROT,NROT,NROT) STOP 680 CONTINUE DO 690 I=1,NROT 690 TSYM(I,J)=TSYM(I,J)/RNORM 700 CONTINUE NOW, MAKE SURE THE SIGNS ARE CORRECT: DO 800 MOFF=1,NOFF I=IOFF(MOFF) J=JOFF(MOFF) IF(A(I,J).GT.ZERO) GO TO 800 II=ILIST(MOFF) JJ=JLIST(MOFF) TSYM(II,JJ)=-TSYM(II,JJ) TSYM(JJ,II)=-TSYM(JJ,II) 800 CONTINUE FINALLY, THE CRUCIAL STEP OF SYMMETRICALLY ORTHOGONALIZING THE VECTORS SO THAT THE TRANSFORMATION IS UNITARY: CALL SYMORT(OVLP,TSYM,BLK,NROT,NROT,EVAL) RETURN END ***************************************************************************** SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) ****************************************************************** SYMORT: SYMMETRIC ORTHOGONALIZATION SUBROUTINE S: FULL OVERLAP MATRIX (DESTROYED!) T: VECTORS TO BE ORTHOGED. N: NUMBER OF VECTORS NOTE: BLK AND BIGBLK SHARE THE SAME STORAGE BUT ARE DIMENSIONED DIFFERENTLY. THE SAME APPLIES FOR S AND SBLK. ****************************************************************** DIMENSION S(N,N),T(NDIM,NDIM),BLK(N,N),EVAL(N) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA ZERO,ONE/0.0D0,1.0D0/ IMPORTANT CONSTANTS: DIAGTH THRESHOLD FOR MATRIX DIAGONALIZATION USED IN SUBROUTINE JACOBI. IN JACOBI, THIS CONSTANT IS CALLED "DONETH". DANGER CRITERION FOR DECIDING THAT THE JOB SHOULD BE ABORTED DUE TO NUMERICAL PROBLEMS CAUSED BY NEAR LINEAR DEPENDENCIES IN THE BASIS SET. ALL EIGENVALUES OF THE WEIGHTED OVERLAP MATRIX MUST BE GREATER THAN DIAGTH*DANGER. DATA DIAGTH,DANGER/1.0D-12,1.0D3/ FORM THE INVERSE SQRT OF THE OVERLAP MATRIX OF THE VECTORS: DO 70 I=1,N DO 70 J=1,N SIJ=ZERO DO 40 K=1,N 40 SIJ=SIJ+T(K,I)*T(K,J) 70 S(I,J)=SIJ CALL JACOBI(N,S,EVAL,BLK,N,N,0) SMLEST=ONE TOOSML=DIAGTH*DANGER DO 150 I=1,N EIGENV=EVAL(I) IF(EIGENV.LT.TOOSML) GO TO 900 EVAL(I)=ONE/SQRT(EIGENV) IF(EIGENV.LT.SMLEST) SMLEST=EIGENV 150 CONTINUE DO 170 I=1,N DO 170 J=1,I SIJ=ZERO DO 160 K=1,N 160 SIJ=SIJ+EVAL(K)*BLK(I,K)*BLK(J,K) S(I,J)=SIJ 170 S(J,I)=SIJ S NOW CONTAINS THE -0.5 POWER OF THE OVERLAP MATRIX, AND IS THE ORTHOG. TRANSFORM THAT WE WANT. NOW, FORM THE TOTAL TRANSFORMATION: DO 210 I=1,N DO 200 J=1,N EVAL(J)=ZERO DO 200 K=1,N 200 EVAL(J)=EVAL(J)+T(I,K)*S(K,J) DO 210 J=1,N 210 T(I,J)=EVAL(J) RETURN 900 WRITE(LFNPR,910) EIGENV,TOOSML 910 FORMAT(/1X,'An eigenvalue of the overlap matrix of the ', * 'symmetrized Jacobi transf. ', * 'matrix of ',E13.5,' has been found.'/1X, * 'This is lower than the allowed threshold of ',E13.5) STOP END ***************************************************************************** NBO ENERGETIC ANALYSIS ROUTINES: SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE) SUBROUTINE NBODEL(A,MEMORY,IDONE) SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE, + ISPIN) SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN) SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK) SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL) ***************************************************************************** SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE) ***************************************************************************** NBOEAN: CONTROLLER SUBROUTINE TO DO NBO ENERGETIC ANALYSIS BY FOCK MATRIX DELETION METHOD A(MEMORY) IS SCRATCH STORAGE NBOOPT(1) = 2 READ IN NEXT DELETION AND FORM NEW DM = 3 COMPUTE ENERGY CHANGE FOR THIS DELETION SET IDONE TO 1 IF NO DELETIONS ARE FOUND: ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ERROR,NEW,SEQ COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION A(MEMORY),NBOOPT(10) DATA THRNEG/-1.0D-3/ DATA ONE,AUKCAL,EVKCAL/1.0D0,627.51,23.061/ OPEN THE OLD NBO DAF: NEW = .FALSE. CALL NBOPEN(NEW,ERROR) IF(ERROR) THEN IDONE = 1 RETURN END IF CALL FEINFO(A,ISWEAN) IF NBOOPT(1) = 3, COMPUTE THE ENERGY OF DELETION: IF(NBOOPT(1).EQ.3) THEN CALL FEE0(EDEL,ETOT) ECHANG = EDEL - ETOT IF(MUNIT.EQ.0) THEN CONV = AUKCAL ELSE IF(MUNIT.EQ.1) THEN CONV = EVKCAL ELSE CONV = ONE END IF EKCAL = ECHANG * CONV IF(EKCAL.LT.THRNEG) WRITE(LFNPR,2130) IF(MUNIT.EQ.0) THEN WRITE(LFNPR,2100) EDEL,ETOT,ECHANG,EKCAL ELSE IF(MUNIT.EQ.1) THEN WRITE(LFNPR,2110) EDEL,ETOT,ECHANG,EKCAL ELSE WRITE(LFNPR,2120) EDEL,ETOT,ECHANG,EKCAL END IF IDONE = 0 SEQ = .FALSE. CALL NBCLOS(SEQ) RETURN END IF PERFORM THE NBO ENERGETIC ANALYSIS: IF ISWEAN IS SET TO 1, SEARCH FOR THE $DEL KEYLIST: IF(ISWEAN.EQ.1) THEN CALL DELINP(NBOOPT,IDONE) IF(IDONE.EQ.1) GOTO 900 ELSE IF(NBOOPT(10).GT.80) THEN CALL STRTIN(LFNIN) END IF ROHF, MCSCF, CI, AND AUHF WAVE FUNCTIONS ARE NOT ACCEPTABLE: IF(ROHF.OR.MCSCF.OR.CI.OR.AUHF) THEN IDONE = 1 GOTO 900 END IF ISPIN = 0 IF(UHF) ISPIN = 2 ALPHA = .FALSE. BETA = .FALSE. IF(UHF) ALPHA = .TRUE. CALL NBODEL(A,MEMORY,IDONE) IF(IDONE.EQ.1) GOTO 900 IF(UHF) THEN ISPIN = -2 ALPHA = .FALSE. BETA = .TRUE. CALL NBODEL(A,MEMORY,IDONE) END IF WRITE(LFNPR,3000) SEQ = .FALSE. CALL NBCLOS(SEQ) RETURN 900 CONTINUE SEQ = .FALSE. CALL NBCLOS(SEQ) RETURN 2100 FORMAT(1X,78('-'),/,3X, +'Energy of deletion : ',F20.9,/,3X, +' Total SCF energy : ',F20.9,/,3X, +' -------------------',/,3X, +' Energy change : ',F17.6,' a.u., ',F13.3,' kcal/mol'/ +1X,78('-')) 2110 FORMAT(1X,78('-'),/,3X, +'Energy of deletion : ',F20.9,/,3X, +' Total SCF energy : ',F20.9,/,3X, +' -------------------',/,3X, +' Energy change : ',F17.6,' e.V., ',F13.3,' kcal/mol'/ +1X,78('-')) 2120 FORMAT(1X,78('-'),/,3X, +'Energy of deletion : ',F13.3,/,3X, +' Total SCF energy : ',F13.3,/,3X, +' -------------------',/,3X, +' Energy change : ',F13.3,' kcal/mol, ',F13.3,' kcal/mol'/ +1X,78('-')) 2130 FORMAT(/,6X, +'***** WARNING ***** The variational principle has been',/,5X, +' violated and the above deletion energy is invalid!!',//,5X, +'Probable cause: A deletion was attempted that did not ',/,5X, +'have as high symmetry as was employed in the integral',/,5X, +'and SCF computation. REMEDY: Redo computation without',/,5X, +'symmetry if this non-symmetry-conserving deletion is still',/,5X, +'desired.') 3000 FORMAT(/1X, +'NEXT STEP: Evaluate the energy of the new density matrix',/,1X, +' that has been constructed from the deleted NBO',/,1X, +' Fock matrix by doing one SCF cycle.'/) END ***************************************************************************** SUBROUTINE NBODEL(A,MEMORY,IDONE) ***************************************************************************** NBODEL: SUBROUTINE TO DELETE BOND ORBITAL FOCK MATRIX ELEMENTS FOR A PARTICULAR SPIN CASE: ISPIN = 0 CLOSED SHELL 2 ALPHA SPIN -2 BETA SPIN IDONE IS SET EQUAL TO 1 IF THERE ARE NO MORE DELETIONS, 0 OTHERWISE. A(MEMORY) IS SCRATCH STORAGE ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL DONE DIMENSION A(MEMORY),ICH(3,2),INAM(3),ISP(3) NBO Common Blocks: PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DATA LBD/2HBD/,L3C/2H3C/,LBLNK2/2H /,LBLNK1/1H /,LHYP/1H-/ FNBO : NBO FOCK MATRIX (TRIANGULAR) TRF : TRUNCATED FOCK MATRIX (SQUARE) EIGVR : EIGENVECTORS OF FTRUNC DMNEW : NEW AO DM (FROM TRUNCATION) -- TRIANGULAR OCC : OCCUPATION VECTOR OF BOND ORBITALS OCCNEW: OCCUPATION VECTOR OF BOND ORBITALS, AFTER DELETION TNBO : AO TO NBO TRANSFORMATION MATRIX SCR : SCRATCH VECTOR SET UP STORAGE SPACE: A(N1): OCC A(N2): OCCNEW A(N3): TNBO A(N4): FNBO, EIGVR A(N5): SCR, TRF, DMNEW A(N6): SCR A(N7): IDEL NSQ = NDIM*NDIM N1 = 1 N2 = N1 + NDIM N3 = N2 + NDIM N4 = N3 + NSQ N5 = N4 + NSQ N6 = N5 + NSQ N7 = N6 + NDIM NEND = N7 + NSQ IF(NEND.GT.MEMORY) GO TO 950 CALL FENBO(A(N3),A(N1),A(N5),NELEC) CALL FEFNBO(A(N4)) DELETE REQUESTED FOCK MATRIX ELEMENTS, FORMING TRUNCATED FOCK MATRIX IN TRF IDEL : LIST OF DELETED ORBITALS, ELEMENTS, OR BLOCKS ITYPE : TYPE OF DELETION: 1 FOR ORBITALS 2 FOR INDIVIDUAL MATRIX ELEMENTS 3 FOR ZEROING INTERSECTION BETWEEN TWO SETS OF ORBITALS 4 FOR ENTIRE MATRIX BLOCKS NDEL : NUMBER OF ORBITALS, ELEMENTS OR BLOCKS TO BE DELETED CALL DELETE(A(N4),A(N5),NDIM,A(N7),NSQ,ITYPE,NDEL,NTRUNC,DONE, + ISPIN) IF NO MORE DELETIONS, EXIT PROGRAM IF(DONE) GO TO 900 DIAGONALIZE TRUNCATED FOCK MATRIX IN TRF CALL JACOBI(NTRUNC,A(N5),A(N2),A(N4),NDIM,NDIM,0) CONSTRUCT NEW DENSITY MATRIX IN DM FROM EIGENVECTORS OF TRF, IN NBO BASIS: A(N2): EIGENVALUES OF TRF (ENTERING) A(N2): NEW NBO ORBITAL OCCUPANCIES (EXITING) NMOOCC=NELEC IF(ISPIN.EQ.0) NMOOCC=NELEC/2 CALL NEWDM(A(N5),A(N4),A(N2),NDIM,A(N7),NSQ,NDEL,ITYPE,NMOOCC, + ISPIN) TAKE TRANSPOSE OF T SO THAT IT CAN TRANSFORM THE DENSITY MATRIX FROM THE NBO BASIS TO THE UNSYMMETRIZED AO BASIS: CALL TRANSP(A(N3),NDIM,NDIM) CALL SIMLTR(NDIM,NDIM,A(N5),A(N3),A(N4),A(N6),1) CALL SVNEWD(A(N5)) WRITE(LFNPR,2200) WRITE(LFNPR,2700) DO 500 IBAS=1,NDIM IB=IBXM(IBAS) LBL=LABEL(IB,1) NCTR=1 IF(LBL.EQ.LBD) NCTR=2 IF(LBL.EQ.L3C) NCTR=3 DO 350 I=1,3 IAT=LABEL(IB,I+3) CALL CONVRT(IAT,ICH(I,1),ICH(I,2)) INAM(I)=LBLNK2 IF(IAT.GT.0) INAM(I)=NAMEAT(IATNO(IAT)) ISP(I)=LHYP IF(I.GE.NCTR) ISP(I)=LBLNK1 350 CONTINUE I=N1-1+IBAS II=N2-1+IBAS OCCCHG=A(II)-A(I) WRITE(LFNPR,2800) IBAS,(LABEL(IB,K),K=1,3), * (INAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3), * A(I),A(II),OCCCHG 500 CONTINUE IDONE=0 RETURN 900 CONTINUE IDONE=1 RETURN 950 CONTINUE WRITE(LFNPR,9500) NEND,MEMORY IDONE=1 RETURN 2200 FORMAT(/1X,'Occupations of bond orbitals:') 2700 FORMAT(/7X,'Orbital',19X,'No deletions This deletion Change', + /,1X,78('-')) 2800 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',3(A2,3A1), * 9X,F7.5,8X,F7.5,3X,F8.5) 9500 FORMAT(/1X,'Insufficient memory in subroutine NBODEL:', * /5X,'Memory needed: ',I10,' Memory available: ',I10, * /1X,'Deletions halted!') END ***************************************************************************** SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE, + ISPIN) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ERROR,DONE,EQUAL LOGICAL DONOR,ACCPTR,LIST1,LIST2 DIMENSION KEYWD(6),F(1),TRF(NDIM,NDIM),IDEL(LEN) DIMENSION LORB(3),LELE(3),LBLO(3),LDEL(3),LZERO(4),LSAME(4), * LEND(3),LDESTR(6),LDELOC(5),LNOSTR(6),LATOM(4), * LNOGEM(5),LNOVIC(5),LALT(4) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA ZERO/0.0D0/,ISTAR/1H*/ DATA LDEL/1HD,1HE,1HL/,LZERO/1HZ,1HE,1HR,1HO/,LEND/1HE,1HN,1HD/ DATA LALPHA,LBETA/1HA,1HB/,LSAME/1HS,1HA,1HM,1HE/ DATA LORB,LELE,LBLO/1HO,1HR,1HB,1HE,1HL,1HE,1HB,1HL,1HO/ DATA LDES