***************************************************************************** N B O P R O G R A M (SYSTEM INDEPENDENT ROUTINES) LAST PROGRAM MODIFICATION: OCTOBER 22, 1991 !!! CRAY COMPILATION REQUIRES 64 BIT (-i64) INTEGERS !!! (SEE, IN PARTICULAR, SR JOBOPT, SR NBOPEN, AND SR DEBYTE) ***************************************************************************** MAIN SUBROUTINE: SUBROUTINE NBO(CORE,NBOOPT,MEMORY) JOB INITIALIZATION ROUTINES: (CALLED BY SR NBO) SUBROUTINE NBOSET(NBOOPT) SUBROUTINE JOBOPT(NBOOPT) SUBROUTINE NBODIM(MEMORY) NAO/NBO/NLMO FORMATION ROUTINES: (CALLED BY SR NBO) SUBROUTINE NAODRV(DM,T,A) SUBROUTINE NAOSIM(DM,T,A) SUBROUTINE DMNAO(DM,T,A) SUBROUTINE DMSIM(DM,T,A) SUBROUTINE NBODRV(DM,T,A,MEMORY) ROUTINES CALLED BY THE NAO DRIVERS: SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF) SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF) SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR) SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK) SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO) SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG) ROUTINES CALLED BY SR NAO: SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM) SUBROUTINE ATDIAG(N,A,B,EVAL,C) SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM) SUBROUTINE NEWWTS(S,T,WT) SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK) SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK) SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2, + LIST,IRPNAO) SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2, + IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO) SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT) SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO) SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,IRPNAO) ROUTINES CALLED BY THE NBO/NLMO DRIVERS: SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO) SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO) SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO,IFLG) SUBROUTINE SRTNBO(T,BNDOCC) SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR) SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB) SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN) SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB) SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR) SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB) SUBROUTINE FNDMOL(IATOMS) SUBROUTINE NBOCLA(BNDOCC,ACCTHR) SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO) SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR) SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG) SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR) SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM) SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,SIAB,NOCC,NAB) SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX) SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX) SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC) ROUTINES CALLED BY SR NATHYB, SR CHOOSE: SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR) FUNCTION IWPRJ(NCTR) SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD) SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB) SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP) SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB) SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG) SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI) SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB) SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD) SUBROUTINE FORMT(T,Q,POL) SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT) ROUTINES CALLED BY SR NLMO: SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT, + NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM) SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL) NBO ENERGETIC ANALYSIS ROUTINES: SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE) SUBROUTINE NBODEL(A,MEMORY,IDONE) SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE, + ISPIN) SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN) SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK) SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL) NBO DIRECT ACCESS FILE (DAF) ROUTINES: SUBROUTINE NBFILE(NEW,ERROR) SUBROUTINE NBOPEN(NEW,ERROR) SUBROUTINE NBWRIT(IX,NX,IDAR) SUBROUTINE NBREAD(IX,NX,IDAR) SUBROUTINE NBCLOS(SEQ) SUBROUTINE NBINQR(IDAR) SUBROUTINE FETITL(TITLE) SUBROUTINE FEE0(EDEL,ETOT) SUBROUTINE SVE0(EDEL) SUBROUTINE FECOOR(ATCOOR) SUBROUTINE FESRAW(S) SUBROUTINE FEDRAW(DM,SCR) SUBROUTINE FEFAO(F,IWFOCK) SUBROUTINE FEAOMO(T,IT) SUBROUTINE FEDXYZ(DXYZ,I) SUBROUTINE SVNBO(T,OCC,ISCR) SUBROUTINE FENBO(T,OCC,ISCR,NELEC) SUBROUTINE FETNBO(T) SUBROUTINE SVPNAO(T) SUBROUTINE FEPNAO(T) SUBROUTINE SVSNAO(S) SUBROUTINE FESNAO(S) SUBROUTINE SVTNAB(T) SUBROUTINE FETNAB(T) SUBROUTINE SVTLMO(T) SUBROUTINE FETLMO(T) SUBROUTINE SVTNHO(T) SUBROUTINE FETNHO(T) SUBROUTINE SVPPAO(DM) SUBROUTINE FEPPAO(DM) SUBROUTINE SVTNAO(T) SUBROUTINE FETNAO(T) SUBROUTINE SVNLMO(T) SUBROUTINE FENLMO(T) SUBROUTINE SVDNAO(DM) SUBROUTINE FEDNAO(DM) SUBROUTINE SVFNBO(F) SUBROUTINE FEFNBO(F) SUBROUTINE SVNEWD(DM) SUBROUTINE FENEWD(DM) SUBROUTINE FEINFO(ICORE,ISWEAN) SUBROUTINE FEBAS(NSHELL,NEXP,ISCR) FREE FORMAT INPUT ROUTINES: SUBROUTINE STRTIN(LFNIN) SUBROUTINE RDCRD SUBROUTINE IFLD(INT,ERROR) SUBROUTINE RFLD(REAL,ERROR) SUBROUTINE HFLD(KEYWD,LENG,ENDD) SUBROUTINE FNDFLD FUNCTION EQUAL(IA,IB,L) OTHER SYSTEM-INDEPENDENT I/O ROUTINES: SUBROUTINE GENINP(NEWDAF) SUBROUTINE NBOINP(NBOOPT,IDONE) SUBROUTINE CORINP(IESS,ICOR) SUBROUTINE CHSINP(IESS,ICHS) SUBROUTINE DELINP(NBOOPT,IDONE) SUBROUTINE RDCORE(JCORE) SUBROUTINE WRPPNA(T,OCC,IFLG) SUBROUTINE RDPPNA(T,OCC,IFLG) SUBROUTINE WRTNAO(T,IFLG) SUBROUTINE RDTNAO(DM,T,SCR,IFLG) SUBROUTINE WRTNAB(T,IFLG) SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG) SUBROUTINE WRTNBO(T,BNDOCC,IFLG) SUBROUTINE WRNLMO(T,DM,IFLG) SUBROUTINE WRBAS(SCR,ISCR,LFN) SUBROUTINE WRARC(SCR,ISCR,LFN) SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG) SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL) SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN) SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR) SUBROUTINE ALTOUT(A,MR,MC,NR,NC) SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR) FUNCTION IOINQR(IFLG) SUBROUTINE LBLAO SUBROUTINE LBLNAO SUBROUTINE LBLNBO SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR) GENERAL UTILITY ROUTINES: SUBROUTINE ANGLES(X,Y,Z,THETA,PHI) FUNCTION BDFIND(IAT,JAT) SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR) SUBROUTINE CONSOL(AUT,ALT,NDIM,N) SUBROUTINE CONVIN(IJ,LEN,IK,ERROR) SUBROUTINE CONVRT(N,NC1,NC2) SUBROUTINE COPY(A,B,NDIM,NR,NC) SUBROUTINE CORTBL(IAT,ICORE,IECP) SUBROUTINE DEBYTE(I,IBYTE) SUBROUTINE HALT(WORD) SUBROUTINE IDIGIT(KINT,IK,ND,MAXD) FUNCTION IHTYP(IBO,JBO) SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR) SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT) SUBROUTINE MATMLT(A,B,V,NDIM,N) SUBROUTINE MATML2(A,B,V,NDIM,N) FUNCTION NAMEAT(IZ) SUBROUTINE NORMLZ(A,S,M,N) SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK) SUBROUTINE PACK(T,NDIM,NBAS,L2) SUBROUTINE RANK(EIG,N,NDIM,ARCRNK) SUBROUTINE SIMTRN(A,T,V,NDIM,N) SUBROUTINE SIMTRS(A,S,V,NDIM,N) SUBROUTINE TRANSP(A,NDIM,N) SUBROUTINE UNPACK(T,NDIM,NBAS,L2) SUBROUTINE VALTBL(IAT,IVAL) FUNCTION VECLEN(X,N,NDIM) SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR, + IERR) SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG) SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR) SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM) ***************************************************************************** SUBROUTINE NBO(CORE,MEMORY,NBOOPT) ***************************************************************************** Input: CORE Core memory to be dynamically allocated for storage needs. MEMORY The number of REAL*8 words available in `CORE'. NBOOPT(10) List of NBO options as summarized below: NBOOPT(1) = -2 Do nothing = -1 Natural Population Analysis (NPA) only = 0 Perform NPA/NBO/NLMO analyses = 1 Perform NPA/NBO/NLMO analyses, don't read keywords = 2 Perform one Fock matrix deletion, forming new DM = 3 Evaluate and print the energy change from deletion NBOOPT(2) = 0 SCF density = 1 MP first order density = 3 MP2 density = 4 MP3 density = 5 MP4 density = 6 CI one-particle density = 7 CI density = 8 QCI/CC density = 9 Density correct to second order NBOOPT(3) = 1 Transform dipole moment matrices to NBO/NLMO bases NBOOPT(4) = 1 Allow strongly resonant Lewis Structures (Force the RESONANCE keyword) NBOOPT(5) = 1 Spin-annihilated UHF (AUHF) wavefunction NBOOPT(6-9) Unused NBOOPT(10) = 0 General version of the NBO program (GENNBO) = 1 AMPAC version = 6 GAMESS version = 7 HONDO version = 8x Gaussian 8x version ------------------------------------------------------------------------------ IMPLICIT REAL*8 (A-H,O-Z) LOGICAL NEWDAF,ERROR,SEQ NBO COMMON BLOCKS: PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION CORE(MEMORY),NBOOPT(10) IF NBOOPT(1).EQ.-2, THEN NO NBO ANALYSIS WAS REQUESTED: IF(NBOOPT(1).EQ.-2) RETURN SET DEFAULT OPTIONS: CALL NBOSET(NBOOPT) IF THIS IS THE GENERAL VERSION OF THE PROGRAM, READ THE $GENNBO KEYLIST: IF(NBOOPT(10).EQ.0) THEN CALL GENINP(NEWDAF) ELSE NEWDAF = .TRUE. END IF SEARCH THE INPUT FILE FOR THE $NBO KEYLIST: CALL NBOINP(NBOOPT,IDONE) IF(IDONE.EQ.1) RETURN READ IN JOB OPTIONS FROM THE $NBO KEYLIST: CALL JOBOPT(NBOOPT) CHECK FILENAME AND OPEN SEQUENTIAL FILES: CALL NBFILE(NEWDAF,ERROR) IF(ERROR) RETURN OPEN THE NBO DIRECT ACCESS FILE: CALL NBOPEN(NEWDAF,ERROR) IF(ERROR) THEN WRITE(LFNPR,900) RETURN END IF FETCH ATOMS, BASIS, AND WAVE FUNCTION INFORMATION: CALL FEAOIN(CORE,CORE,NBOOPT) IF(COMPLX) RETURN WRITE THE JOB TITLE TO THE OUTPUT FILE: CALL FETITL(CORE) WRITE(LFNPR,910) (CORE(I),I=1,8) SET UP DIMENSIONING INFORMATION AND DETERMINE IF ENOUGH SPACE IS AVAILABLE: CALL NBODIM(MEMORY) SET UP BASIC STORAGE: CORE(NDM) : NDIM BY NDIM MATRIX TO STORE DENSITY MATRIX CORE(NT) : NDIM BY NDIM MATRIX TO HOLD OVERLAP OR TRANSFORMATION MATRICES CORE(NSCR): SCRATCH STORAGE, DYNAMICALLY ALLOCATED ACCORDING NEEDS N2 = NDIM*NDIM NDM = 1 NT = NDM + N2 NSCR = NT + N2 MEM = MEMORY - NSCR + 1 READ IN INPUT OVERLAP AND DENSITY MATRICES, AO BASIS: ALPHA = .FALSE. BETA = .FALSE. ISPIN = 0 CALL FEDRAW(CORE(NDM),CORE(NSCR)) SIMULATE THE NATURAL POPULATION ANALYSIS IF THE INPUT BASIS IS ORTHOGONAL: IF(ORTHO) THEN CALL NAOSIM(CORE(NDM),CORE(NT),CORE(NSCR)) LOAD THE OVERLAP MATRIX INTO CORE(NT) AND PERFORM THE NATURAL POPULATION ANALYSIS: ELSE CALL FESRAW(CORE(NT)) CALL NAODRV(CORE(NDM),CORE(NT),CORE(NSCR)) END IF NOTE: CORE(NDM) NOW CONTAINS THE TOTAL DENSITY MATRIX IN THE NAO BASIS AND CORE(NT) CONTAINS THE AO TO NAO TRANSFORMATION PERFORM CLOSED SHELL NBO ANALYSIS: IF(.NOT.OPEN) THEN CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM) ELSE PERFORM OPEN SHELL NBO ANALYSIS: FIRST, ANALYZE ALPHA DENSITY MATRIX: ALPHA = .TRUE. BETA = .FALSE. ISPIN = 2 IF(ORTHO) THEN CALL DMSIM(CORE(NDM),CORE(NT),CORE(NSCR)) ELSE CALL DMNAO(CORE(NDM),CORE(NT),CORE(NSCR)) END IF CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM) NOW, ANALYZE BETA DENSITY MATRIX: ALPHA = .FALSE. BETA = .TRUE. ISPIN = -2 IF(ORTHO) THEN CALL DMSIM(CORE(NDM),CORE(NT),CORE(NSCR)) ELSE CALL DMNAO(CORE(NDM),CORE(NT),CORE(NSCR)) END IF CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM) END IF CLOSE THE NBO DIRECT ACCESS FILE AND OTHER EXTERNAL FILES: SEQ = .TRUE. CALL NBCLOS(SEQ) RETURN 900 FORMAT(/1X,'NBO direct access file could not be opened. NBO ', + 'program aborted.') 910 FORMAT(/1X,'Job title: ',8A8) END ***************************************************************************** JOB INITIALIZATION ROUTINES: (CALLED BY SR NBO) SUBROUTINE NBOSET(NBOOPT) SUBROUTINE JOBOPT(NBOOPT) SUBROUTINE NBODIM(MEMORY) ***************************************************************************** SUBROUTINE NBOSET(NBOOPT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION NBOOPT(10) PARAMETER(MAXATM = 99,MAXBAS = 500) PARAMETER(MAXFIL = 40) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBLBL/NLEW,NVAL,LBL(10,MAXBAS,4) COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) CHARACTER*80 FILENM DATA TENTH,HALF/0.1D0,0.5D0/ SET DEFAULT JOB OPTIONS: (MODIFICATIONS TO THESE DEFAULTS SHOULD NOT BE MADE HERE BUT LATER IN THIS SUBROUTINE) USE THE BOND-ORDER MATRIX, NOT THE OCCUPATION MATRIX (EXPECTATION VALUES OF THE DENSITY OPERATOR) IWDM = 1 IW3C = 0 IWAPOL = 0 IWHYBS = 0 IWPNAO = 0 IWTNAO = 0 IWTNAB = 0 IWTNBO = 0 USE THE FOCK MATRIX, IF THERE IS ONE: IWFOCK = 1 SET TO THE DESIRED PRINT LEVEL + 10: IPRINT = 12 IPSEUD = 0 IWDETL = 0 IWMULP = 0 ICHOOS = 0 KOPT = 0 JCORE = 0 IWCUBF = 0 OPEN = .FALSE. ORTHO = .FALSE. UHF = .FALSE. AUHF = .FALSE. ROHF = .FALSE. CI = .FALSE. MCSCF = .FALSE. COMPLX = .FALSE. DO 10 I = 1,60 JPRINT(I) = 0 10 CONTINUE LFNAO = 31 LFNPNA = 32 LFNNAO = 33 LFNPNH = 34 LFNNHO = 35 LFNPNB = 36 LFNNBO = 37 LFNPNL = 38 LFNNLM = 39 LFNMO = 40 LFNDM = 41 LFNNAB = 42 LFNPPA = 43 LFNARC = 47 SET POSITIVE IN ROUTINE JOBOPT IF CHOSEN BY THE USER: LFNDAF = -48 LFNDEF = 49 SETTING NVAL NEGATIVE INDICATES THAT THIS VARIABLE HAS NOT BEEN DETERMINED YET: NVAL = -1 INITIALIZE THE CHARACTER STRING USED TO CREATE FILENAMES: FILENM(1:4) = 'FILE' DO 50 I = 5,80 FILENM(I:I) = CHAR(32) 50 CONTINUE THAT SOME THRESHOLDS ARE .LT.0 INDICATES THAT THESE VARIABLES HAVE NOT BEEN SET BY THE USER: THRSET = -1.9D0 PRJSET = -0.2D0 ACCTHR = -TENTH CRTSET = 1.999 E2THR = -HALF ATHR = -1.000 PTHR = -25.000 ETHR = -0.100 DTHR = -0.020 DLTHR = -1.000 CHSTHR = -0.100 SET JOB OPTIONS ACCORDING TO NBOOPT: SKIP THE COMPUTATION OF THE NBOS? IF(NBOOPT(1).EQ.-1) JPRINT(1) = 1 TURN OFF $CHOOSE AND $CORE KEYLISTS IF $NBO KEYLIST IS NOT TO BE READ: IF(NBOOPT(1).EQ.1) ICHOOS = -1 IF(NBOOPT(1).EQ.1) JCORE = -1 FORCE DIPOLE ANALYSIS? IF(NBOOPT(3).NE.0) THEN JPRINT(46) = 1 END IF FORCE RESONANCE KEYWORD? IF(NBOOPT(4).NE.0) JPRINT(14) = 1 PROGRAM VERSION: JPRINT(2) = NBOOPT(10) RETURN END ****************************************************************************** SUBROUTINE JOBOPT(NBOOPT) ****************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ERROR,END,EQUAL,NEXTWD,READ DIMENSION NBOOPT(10),INTTMP(80) PARAMETER(KEYLEN = 9) PARAMETER(MAXFIL = 40) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) CHARACTER*80 FILENM DIMENSION KEYWD(KEYLEN),K3CBND(6),KEPERT(6),KLFNPR(5),KTHRSH(6), * KDETL(6),KMULA(5),KMULOR(6),KPRJTH(6),KNBNLM(7), * KAOPRE(6),KNLMO(4),KNAOMO(5),KNBOMO(5),KNOBND(6),KNPA(3), * KSKIPB(6),KRPNAO(5),KBNDID(6),KNLMMO(6),KRESON(5),KPPNAO(7), * KAONAO(5),KNANBO(6),KAONBO(5),KAONLM(6),KFNBO(4),KFNLMO(5), * KDMNBO(5),KDMNLM(6),KPRINT(5),KNANLM(7),KSPNAO(5),KSPNHO(5), * KSPNBO(5),KAOINF(6),KAOPNB(6),KAOMO(4),KNAONH(6),KNHNLM(7), * KAONHO(5),KFNHO(4),KAOPNH(6),KFNAO(4),KNHONB(6),KSPNLM(6), * KNRT(3),KDMNHO(5),KDMNAO(5),KPLOT(4),KAOPNL(7),KDIAO(4), * KBEND(4),KNHOMO(5),KSAO(3),KFAO(3),KDMAO(4),KBOAO(4),KDINLM(6), * KNBOSM(6),KNBO(3),KDIPOL(6),KDINAO(5),KDINHO(5),KDINBO(5), * KNBDAF(6),KARCHV(7),KFILE(4),KPOLAR(6),KNRTOP(6),KNRTRF(6), * KCHSTH(6),KNRTDT(6),KNRTTH(6) DIMENSION KALT(4),KBFGS(4),KPOWEL(6),KSAP(3) DATA K3CBND/1H3,1HC,1HB,1HO,1HN,1HD/,KLFNPR/1HL,1HF,1HN,1HP,1HR/, * KTHRSH/1HT,1HH,1HR,1HE,1HS,1HH/,KEPERT/1HE,1H2,1HP,1HE,1HR,1HT/, * KPLOT/1HP,1HL,1HO,1HT/,KDETL/1HD,1HE,1HT,1HA,1HI,1HL/, * KMULA/1HM,1HU,1HL,1HA,1HT/,KMULOR/1HM,1HU,1HL,1HO,1HR,1HB/, * KPRJTH/1HP,1HR,1HJ,1HT,1HH,1HR/,KAOPRE/1HA,1HO,1HP,1HN,1HA,1HO/, * KNLMO/1HN,1HL,1HM,1HO/,KNPA/1HN,1HP,1HA/,KNBO/1HN,1HB,1HO/, * KNAOMO/1HN,1HA,1HO,1HM,1HO/,KNBOMO/1HN,1HB,1HO,1HM,1HO/, * KNOBND/1HN,1HO,1HB,1HO,1HN,1HD/,KSKIPB/1HS,1HK,1HI,1HP,1HB,1HO/, * KRPNAO/1HR,1HP,1HN,1HA,1HO/,KBNDID/1HB,1HN,1HD,1HI,1HD,1HX/, * KNLMMO/1HN,1HL,1HM,1HO,1HM,1HO/,KRESON/1HR,1HE,1HS,1HO,1HN/, * KPPNAO/1HP,1HA,1HO,1HP,1HN,1HA,1HO/,KAONAO/1HA,1HO,1HN,1HA,1HO/, * KNANBO/1HN,1HA,1HO,1HN,1HB,1HO/,KAONBO/1HA,1HO,1HN,1HB,1HO/ DATA KAONLM/1HA,1HO,1HN,1HL,1HM,1HO/,KFNBO/1HF,1HN,1HB,1HO/, * KFNLMO/1HF,1HN,1HL,1HM,1HO/,KPRINT/1HP,1HR,1HI,1HN,1HT/, * KDMNBO/1HD,1HM,1HN,1HB,1HO/,KDMNLM/1HD,1HM,1HN,1HL,1HM,1HO/, * KNANLM/1HN,1HA,1HO,1HN,1HL,1HM,1HO/,KAOMO/1HA,1HO,1HM,1HO/, * KSPNAO/1HS,1HP,1HN,1HA,1HO/,KSPNHO/1HS,1HP,1HN,1HH,1HO/, * KSPNBO/1HS,1HP,1HN,1HB,1HO/,KFNAO/1HF,1HN,1HA,1HO/, * KAOINF/1HA,1HO,1HI,1HN,1HF,1HO/,KAOPNB/1HA,1HO,1HP,1HN,1HB,1HO/, * KAONHO/1HA,1HO,1HN,1HH,1HO/,KFNHO/1HF,1HN,1HH,1HO/, * KAOPNH/1HA,1HO,1HP,1HN,1HH,1HO/,KNRT/1HN,1HR,1HT/, * KNBNLM/1HN,1HB,1HO,1HN,1HL,1HM,1HO/,KDIAO/1HD,1HI,1HA,1HO/, * KDMNHO/1HD,1HM,1HN,1HH,1HO/,KDMNAO/1HD,1HM,1HN,1HA,1HO/, * KBEND/1HB,1HE,1HN,1HD/,KNBOSM/1HN,1HB,1HO,1HS,1HU,1HM/, * KNHOMO/1HN,1HH,1HO,1HM,1HO/,KSAO/1HS,1HA,1HO/,KFAO/1HF,1HA,1HO/ DATA KDMAO/1HD,1HM,1HA,1HO/,KBOAO/1HB,1HO,1HA,1HO/, * KDIPOL/1HD,1HI,1HP,1HO,1HL,1HE/,KNAONH/1HN,1HA,1HO,1HN,1HH,1HO/, * KNHNLM/1HN,1HH,1HO,1HN,1HL,1HM,1HO/,KDINAO/1HD,1HI,1HN,1HA,1HO/, * KNHONB/1HN,1HH,1HO,1HN,1HB,1HO/,KSPNLM/1HS,1HP,1HN,1HL,1HM,1HO/, * KAOPNL/1HA,1HO,1HP,1HN,1HL,1HM,1HO/,KDINHO/1HD,1HI,1HN,1HH,1HO/, * KDINBO/1HD,1HI,1HN,1HB,1HO/,KDINLM/1HD,1HI,1HN,1HL,1HM,1HO/, * KNBDAF/1HN,1HB,1HO,1HD,1HA,1HF/, * KARCHV/1HA,1HR,1HC,1HH,1HI,1HV,1HE/,KFILE/1HF,1HI,1HL,1HE/, * KPOLAR/1HA,1HP,1HO,1HL,1HA,1HR/,KNRTOP/1HN,1HR,1HT,1HO,1HP,1HT/, * KNRTRF/1HN,1HR,1HT,1HR,1HE,1HF/,KCHSTH/1HC,1HH,1HS,1HT,1HH,1HR/, * KNRTDT/1HN,1HR,1HT,1HD,1HT,1HL/, * KNRTTH/1HN,1HR,1HT,1HT,1HH,1HR/ DATA KALT/1H$,1HE,1HN,1HD/,KBFGS/1HB,1HF,1HG,1HS/, * KPOWEL/1HP,1HO,1HW,1HE,1HL,1HL/,KSAP/1HS,1HA,1HP/ DATA ZERO,ONE/0.0D0,1.0D0/ DATA IFULL,IVAL,ILEW/4HFULL,3HVAL,3HLEW/ DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/ DATA IA,IB,IP/1HA,1HB,1HP/ READ IN JOB OPTIONS, IN A KEYWORD DIRECTED MANNER: NUMOPT = 0 LENNM = 0 IF(NBOOPT(1).EQ.1) GOTO 4500 BEGIN LOOP TO IDENTIFY KEYWORD "KEYWD": NEXTWD = .TRUE. 100 LENG = KEYLEN IF(NEXTWD) CALL HFLD(KEYWD,LENG,END) NEXTWD = .TRUE. IF((LENG.EQ.0).OR.END) GO TO 4500 IF(EQUAL(KEYWD,KALT,4)) GO TO 4500 NUMOPT = NUMOPT + 1 KEYWORD: 3CBOND -- SEARCH FOR THREE-CENTER BONDS (DEFAULT IS TO SEARCH ONLY FOR ONE- AND TWO-CENTER NBOS) IF(.NOT.EQUAL(KEYWD,K3CBND,6)) GO TO 500 IW3C = 1 GO TO 100 KEYWORD: LFNPR -- SPECIFY OUTPUT LFN 500 IF(.NOT.EQUAL(KEYWD,KLFNPR,5)) GO TO 510 CALL IFLD(LFNPR,ERROR) IF(ERROR) CALL HALT('LFNPR') GO TO 100 KEYWORD: THRESH -- SPECIFY FIXED OCCUPANCY THRESHOLD FOR NBO SEARCH 510 IF(.NOT.EQUAL(KEYWD,KTHRSH,6)) GO TO 540 CALL RFLD(THRSET,ERROR) IF(ERROR) CALL HALT('THRESH') GO TO 100 KEYWORD: DETAIL -- PRINT DETAILS OF NBO SEARCH PROCEDURE 540 IF(.NOT.EQUAL(KEYWD,KDETL,6)) GO TO 550 IWDETL = 1 GO TO 100 KEYWORD: MULAT -- PRINT MULLIKEN POPULATIONS BY ATOM 550 IF(.NOT.EQUAL(KEYWD,KMULA,5)) GO TO 560 IWMULP = 1 GO TO 100 KEYWORD: MULORB -- PRINT MULLIKEN POPULATIONS BY ORBITAL AND ATOM 560 IF(.NOT.EQUAL(KEYWD,KMULOR,6)) GO TO 580 IWMULP = 2 GO TO 100 KEYWORD: PRJTHR -- USER SETS VALUE OF PROJECTION THRESHOLD FOR NBO SEARCH FOR REJECTING LINEARLY DEPENDENT HYBRIDS 580 IF(.NOT.EQUAL(KEYWD,KPRJTH,6)) GO TO 610 CALL RFLD(PRJSET,ERROR) IF(ERROR) CALL HALT('PRJTHR') GO TO 100 KEYWORD: FNBO -- PRINT NBO FOCK MATRIX 610 IF(.NOT.EQUAL(KEYWD,KFNBO,4)) GO TO 620 JPRINT(37) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(37),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(37).EQ.IVAL) JPRINT(37) = IFULL END IF GO TO 100 KEYWORD: AOPNAO -- OUTPUT RAW AO TO PNAO TRANSFORMATION 620 IF(.NOT.EQUAL(KEYWD,KAOPRE,6)) GO TO 640 JPRINT(44) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(44),LFNPNA,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(44).EQ.IVAL) JPRINT(44) = IFULL IF(JPRINT(44).EQ.ILEW) JPRINT(44) = IFULL END IF GO TO 100 KEYWORD: NLMOMO -- COMPUTE AND PRINT NLMO TO MO TRANSF. 640 IF(.NOT.EQUAL(KEYWD,KNLMMO,6)) GO TO 650 JPRINT(13) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(13),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. END IF GO TO 100 KEYWORD: NLMO -- COMPUTE AND PRINT NLMOS 650 IF(.NOT.EQUAL(KEYWD,KNLMO,4)) GO TO 660 IF(LENG.NE.4) GO TO 660 JPRINT(8) = 1 GO TO 100 KEYWORD: NAOMO -- COMPUTE AND PRINT NAO TO MO TRANSF. 660 IF(.NOT.EQUAL(KEYWD,KNAOMO,5)) GO TO 670 JPRINT(9) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(9),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. END IF GO TO 100 KEYWORD: NBOMO -- COMPUTE AND PRINT NBO TO MO TRANSF. 670 IF(.NOT.EQUAL(KEYWD,KNBOMO,5)) GO TO 680 JPRINT(45) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(45),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. END IF GO TO 100 KEYWORD: NOBOND -- COMPUTE ONLY ONE-CENTER NBOS 680 IF(.NOT.EQUAL(KEYWD,KNOBND,6)) GO TO 690 JPRINT(10) = 1 GO TO 100 KEYWORD: SKIPBO -- SKIP NBO PROCEDURE 690 IF(.NOT.EQUAL(KEYWD,KSKIPB,6)) GO TO 700 JPRINT(1) = 1 GO TO 100 KEYWORD: RPNAO -- COMPUTE REVISED PURE AO TO PNAO TRANSF. 700 IF(.NOT.EQUAL(KEYWD,KRPNAO,5)) GO TO 710 JPRINT(11) = 1 GO TO 100 KEYWORD: BNDIDX -- PRINT BOND INDICES 710 IF(.NOT.EQUAL(KEYWD,KBNDID,6)) GO TO 730 JPRINT(12) = 1 GO TO 100 KEYWORD: RESONANCE -- ALLOW STRONGLY "NON-LEWIS" NBO OCCUPANCIES (OVERRIDES AUTOMATIC SHUTDOWN OF NBO PROCEDURE IN STRONGLY DELOCALIZED CASES) 730 IF(.NOT.EQUAL(KEYWD,KRESON,5)) GO TO 740 JPRINT(14) = 1 GO TO 100 KEYWORD: PAOPNAO -- I/O WITH PAO TO PNAO TRANSFORMATION 740 IF(.NOT.EQUAL(KEYWD,KPPNAO,7)) GO TO 750 IWPNAO = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .TRUE. CALL KEYPAR(KEYWD,LENG,IWPNAO,LFNPPA,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(IWPNAO.EQ.IVAL) IWPNAO = IFULL IF(IWPNAO.EQ.ILEW) IWPNAO = IFULL END IF GO TO 100 KEYWORD: AONAO -- I/O WITH AO TO NAO TRANSFORMATION 750 IF(.NOT.EQUAL(KEYWD,KAONAO,5)) GO TO 760 IWTNAO = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .TRUE. CALL KEYPAR(KEYWD,LENG,IWTNAO,LFNNAO,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(IWTNAO.EQ.IVAL) IWTNAO = IFULL IF(IWTNAO.EQ.ILEW) IWTNAO = IFULL END IF GO TO 100 KEYWORD: NAONBO -- I/O WITH NAO TO NBO TRANSFORMATION 760 IF(.NOT.EQUAL(KEYWD,KNANBO,6)) GO TO 770 IWTNAB = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .TRUE. CALL KEYPAR(KEYWD,LENG,IWTNAB,LFNNAB,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(IWTNAB.EQ.IVAL) IWTNAB = IFULL END IF GO TO 100 KEYWORD: AONBO -- OUTPUT AO TO NBO TRANSF. INFORMATION 770 IF(.NOT.EQUAL(KEYWD,KAONBO,5)) GO TO 780 IWTNBO = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,IWTNBO,LFNNBO,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(IWTNBO.EQ.IVAL) IWTNBO = IFULL END IF GO TO 100 KEYWORD: FNLMO -- PRINT NLMO FOCK MATRIX 780 IF(.NOT.EQUAL(KEYWD,KFNLMO,5)) GO TO 790 JPRINT(15) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(15),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(15).EQ.IVAL) JPRINT(15) = IFULL END IF GO TO 100 KEYWORD: DMNBO -- PRINT NBO DENSITY MATRIX 790 IF(.NOT.EQUAL(KEYWD,KDMNBO,5)) GO TO 800 JPRINT(16) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(16),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(16).EQ.IVAL) JPRINT(16) = IFULL END IF GO TO 100 KEYWORD: DMNLMO -- PRINT NLMO DENSITY MATRIX 800 IF(.NOT.EQUAL(KEYWD,KDMNLM,6)) GO TO 810 JPRINT(17) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(17),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(17).EQ.IVAL) JPRINT(17) = IFULL END IF GO TO 100 KEYWORD: AONLMO -- COMPUTE AND OUTPUT AO TO NLMO TRANSF. 810 IF(.NOT.EQUAL(KEYWD,KAONLM,6)) GO TO 820 JPRINT(23) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(23),LFNNLM,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(23).EQ.IVAL) JPRINT(23) = IFULL END IF GO TO 100 KEYWORD: PRINT -- READ IN PRINT OPTION LEVEL "IPRINT" 820 IF(.NOT.EQUAL(KEYWD,KPRINT,5)) GO TO 830 CALL IFLD(IPRINT,ERROR) IF(ERROR) CALL HALT('PRINT') GO TO 100 KEYWORD: NAONLMO -- PRINT NAO TO NLMO TRANSFORMATION MATRIX 830 IF(.NOT.EQUAL(KEYWD,KNANLM,7)) GO TO 840 JPRINT(18) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(18),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(18).EQ.IVAL) JPRINT(18) = IFULL END IF GO TO 100 KEYWORD: SPNAO -- PRINT S-PNAO OVERLAP MATRIX 840 IF(.NOT.EQUAL(KEYWD,KSPNAO,5)) GO TO 850 JPRINT(19) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(19),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(19).EQ.IVAL) JPRINT(19) = IFULL IF(JPRINT(19).EQ.ILEW) JPRINT(19) = IFULL END IF GO TO 100 KEYWORD: SPNHO -- PRINT S-PNHO OVERLAP MATRIX 850 IF(.NOT.EQUAL(KEYWD,KSPNHO,5)) GO TO 860 JPRINT(20) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(20),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(20).EQ.IVAL) JPRINT(20) = IFULL IF(JPRINT(20).EQ.ILEW) JPRINT(20) = IFULL END IF GO TO 100 KEYWORD: NHONLMO -- OUTPUT THE NHO TO NLMO TRANSFORMATION 860 IF(.NOT.EQUAL(KEYWD,KNHNLM,7)) GO TO 870 JPRINT(24) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(24),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(24).EQ.IVAL) JPRINT(24) = IFULL END IF GO TO 100 KEYWORD: SPNBO -- PRINT S-PNBO OVERLAP MATRIX 870 IF(.NOT.EQUAL(KEYWD,KSPNBO,5)) GO TO 880 JPRINT(21) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(21),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(21).EQ.IVAL) JPRINT(21) = IFULL END IF GO TO 100 KEYWORD: AOINFO -- WRITE BASIS SET INFO 880 IF(.NOT.EQUAL(KEYWD,KAOINF,6)) GO TO 910 JPRINT(22) = LFNAO CALL IFLD(ITEMP,ERROR) IF(.NOT.ERROR) JPRINT(22) = ABS(ITEMP) GO TO 100 KEYWORD: AOPNBO -- WRITE AO TO PNBO TRANSFORMATION 910 IF(.NOT.EQUAL(KEYWD,KAOPNB,6)) GO TO 920 JPRINT(25) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(25),LFNPNB,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(25).EQ.IVAL) JPRINT(25) = IFULL END IF GO TO 100 KEYWORD: AOMO -- WRITE AO TO MO TRANSFORMATION 920 IF(.NOT.EQUAL(KEYWD,KAOMO,4)) GO TO 930 JPRINT(26) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(26),LFNMO,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. END IF GO TO 100 KEYWORD: DMAO -- WRITE AO DENSITY MATRIX 930 IF(.NOT.EQUAL(KEYWD,KDMAO,4)) GO TO 940 JPRINT(27) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(27),LFNDM,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(27).EQ.IVAL) JPRINT(27) = IFULL IF(JPRINT(27).EQ.ILEW) JPRINT(27) = IFULL END IF GO TO 100 KEYWORD: AONHO -- WRITE AO TO NHO TRANSFORMATION 940 IF(.NOT.EQUAL(KEYWD,KAONHO,5)) GO TO 950 JPRINT(28) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(28),LFNNHO,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(28).EQ.IVAL) JPRINT(28) = IFULL IF(JPRINT(28).EQ.ILEW) JPRINT(28) = IFULL END IF GO TO 100 KEYWORD: FNHO -- PRINT NHO FOCK MATRIX 950 IF(.NOT.EQUAL(KEYWD,KFNHO,4)) GO TO 960 JPRINT(29) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(29),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(29).EQ.IVAL) JPRINT(29) = IFULL IF(JPRINT(29).EQ.ILEW) JPRINT(29) = IFULL END IF GO TO 100 KEYWORD: AOPNHO -- WRITE AO TO PNHO TRANSFORMATION 960 IF(.NOT.EQUAL(KEYWD,KAOPNH,6)) GO TO 970 JPRINT(30) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(30),LFNPNH,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(30).EQ.IVAL) JPRINT(30) = IFULL IF(JPRINT(30).EQ.ILEW) JPRINT(30) = IFULL END IF GO TO 100 KEYWORD: FNAO -- PRINT NAO FOCK MATRIX 970 IF(.NOT.EQUAL(KEYWD,KFNAO,4)) GO TO 990 JPRINT(31) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(31),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(31).EQ.IVAL) JPRINT(31) = IFULL IF(JPRINT(31).EQ.ILEW) JPRINT(31) = IFULL END IF GO TO 100 KEYWORD: NAONHO -- OUTPUT THE NAO TO NHO TRANSFORMATION 990 IF(.NOT.EQUAL(KEYWD,KNAONH,6)) GO TO 1010 JPRINT(33) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(33),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(33).EQ.IVAL) JPRINT(33) = IFULL IF(JPRINT(33).EQ.ILEW) JPRINT(33) = IFULL END IF GO TO 100 KEYWORD: DMNHO -- PRINT NHO DENSITY MATRIX 1010 IF(.NOT.EQUAL(KEYWD,KDMNHO,5)) GO TO 1020 JPRINT(34) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(34),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(34).EQ.IVAL) JPRINT(34) = IFULL IF(JPRINT(34).EQ.ILEW) JPRINT(34) = IFULL END IF GO TO 100 KEYWORD: DMNAO -- PRINT NAO DENSITY MATRIX 1020 IF(.NOT.EQUAL(KEYWD,KDMNAO,5)) GO TO 1040 JPRINT(35) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(35),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(35).EQ.IVAL) JPRINT(35) = IFULL IF(JPRINT(35).EQ.ILEW) JPRINT(35) = IFULL END IF GO TO 100 KEYWORD: BEND -- PRINT NHO DIRECTIONALITY AND BOND BENDING INFO 1040 IF(.NOT.EQUAL(KEYWD,KBEND,4)) GO TO 1050 JPRINT(36) = 1 CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 ATHR = ABS(TEMP) CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 PTHR = ABS(TEMP) IF(PTHR.LT.ONE) PTHR = ONE CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 ETHR = ABS(TEMP) GO TO 100 KEYWORD: NHOMO -- COMPUTE AND PRINT NHO TO MO TRANSF. 1050 IF(.NOT.EQUAL(KEYWD,KNHOMO,5)) GO TO 1060 JPRINT(38) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(38),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. END IF GO TO 100 KEYWORD: SAO -- PRINT AO OVERLAP MATRIX 1060 IF(.NOT.EQUAL(KEYWD,KSAO,3)) GO TO 1070 JPRINT(39) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(39),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(39).EQ.IVAL) JPRINT(39) = IFULL IF(JPRINT(39).EQ.ILEW) JPRINT(39) = IFULL END IF GO TO 100 KEYWORD: FAO -- PRINT AO FOCK MATRIX 1070 IF(.NOT.EQUAL(KEYWD,KFAO,3)) GO TO 1080 JPRINT(40) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(40),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(40).EQ.IVAL) JPRINT(40) = IFULL IF(JPRINT(40).EQ.ILEW) JPRINT(40) = IFULL END IF GO TO 100 KEYWORD: NHONBO -- OUTPUT NHO TO NBO TRANSFORMATION 1080 IF(.NOT.EQUAL(KEYWD,KNHONB,6)) GO TO 1090 JPRINT(41) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(41),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(41).EQ.IVAL) JPRINT(41) = IFULL END IF GO TO 100 KEYWORD: BOAO -- PRINT AO BOND-ORDER MATRIX 1090 IF(.NOT.EQUAL(KEYWD,KBOAO,4)) GO TO 1100 JPRINT(42) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(42),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(42).EQ.IVAL) JPRINT(42) = IFULL IF(JPRINT(42).EQ.ILEW) JPRINT(42) = IFULL END IF GO TO 100 KEYWORD: E2PERT -- 2ND-ORDER PERTURBATIVE ANALYSIS OF THE NBO FOCK MATRIX 1100 IF(.NOT.EQUAL(KEYWD,KEPERT,6)) GO TO 1110 JPRINT(3) = 1 CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 E2THR = ABS(TEMP) GO TO 100 KEYWORD: PLOT -- WRITE AO BASIS, DENSITY, AND TRANSFORMS FOR PLOTTING 1110 IF(.NOT.EQUAL(KEYWD,KPLOT,4)) GO TO 1120 JPRINT(43) = 1 GO TO 100 KEYWORD: NPA -- PRINT THE NATURAL POPULATION ANALYSIS 1120 IF(.NOT.EQUAL(KEYWD,KNPA,3)) GO TO 1130 JPRINT(4) = 1 GO TO 100 KEYWORD: NBOSUM -- PRINT THE NBO SUMMARY 1130 IF(.NOT.EQUAL(KEYWD,KNBOSM,6)) GO TO 1140 JPRINT(6) = 1 GO TO 100 KEYWORD: NBO -- PRINT THE NBO ANALYSIS 1140 IF(.NOT.EQUAL(KEYWD,KNBO,3)) GO TO 1150 IF(LENG.NE.3) GO TO 1150 JPRINT(5) = 1 GO TO 100 KEYWORD: DIPOLE -- PRINT NBO/NLMO DIPOLE ANALYSIS: 1150 IF(.NOT.EQUAL(KEYWD,KDIPOL,6)) GO TO 1160 JPRINT(46) = 1 CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 DTHR = ABS(TEMP) GO TO 100 KEYWORD: NBONLMO -- PRINT NBO TO NLMO TRANSFORMATION MATRIX 1160 IF(.NOT.EQUAL(KEYWD,KNBNLM,7)) GO TO 1170 JPRINT(47) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(47),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(47).EQ.IVAL) JPRINT(47) = IFULL END IF GO TO 100 KEYWORD: SPNLMO -- OUTPUT THE PNLMO OVERLAP MATRIX 1170 IF(.NOT.EQUAL(KEYWD,KSPNLM,6)) GO TO 1180 JPRINT(48) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(48),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(48).EQ.IVAL) JPRINT(48) = IFULL END IF GO TO 100 KEYWORD: AOPNLMO -- OUTPUT THE AO-PNLMO TRANSFORMATION MATRIX 1180 IF(.NOT.EQUAL(KEYWD,KAOPNL,7)) GO TO 1190 JPRINT(49) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(49),LFNPNL,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(49).EQ.IVAL) JPRINT(49) = IFULL END IF GO TO 100 KEYWORD: DIAO -- OUTPUT THE AO DIPOLE INTEGRALS 1190 IF(.NOT.EQUAL(KEYWD,KDIAO,4)) GO TO 1200 JPRINT(50) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(50),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(50).EQ.IVAL) JPRINT(50) = IFULL IF(JPRINT(50).EQ.ILEW) JPRINT(50) = IFULL END IF GO TO 100 KEYWORD: DINAO -- OUTPUT THE NAO DIPOLE INTEGRALS 1200 IF(.NOT.EQUAL(KEYWD,KDINAO,5)) GO TO 1210 JPRINT(51) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(51),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(51).EQ.IVAL) JPRINT(51) = IFULL IF(JPRINT(51).EQ.ILEW) JPRINT(51) = IFULL END IF GO TO 100 KEYWORD: DINHO -- OUTPUT THE NHO DIPOLE INTEGRALS 1210 IF(.NOT.EQUAL(KEYWD,KDINHO,5)) GO TO 1220 JPRINT(52) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(52),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(52).EQ.IVAL) JPRINT(52) = IFULL IF(JPRINT(52).EQ.ILEW) JPRINT(52) = IFULL END IF GO TO 100 KEYWORD: DINBO -- OUTPUT THE NBO DIPOLE INTEGRALS 1220 IF(.NOT.EQUAL(KEYWD,KDINBO,5)) GO TO 1230 JPRINT(53) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(53),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(53).EQ.IVAL) JPRINT(53) = IFULL END IF GO TO 100 KEYWORD: DINLMO -- OUTPUT THE NLMO DIPOLE INTEGRALS 1230 IF(.NOT.EQUAL(KEYWD,KDINLM,6)) GO TO 1240 JPRINT(54) = IFULL LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN READ = .FALSE. CALL KEYPAR(KEYWD,LENG,JPRINT(54),LFNDEF,READ,ERROR) IF(ERROR) NEXTWD = .FALSE. IF(JPRINT(54).EQ.IVAL) JPRINT(54) = IFULL END IF GO TO 100 KEYWORD: NBODAF -- CHOOSE AN ALTERNATE DAF 1240 IF(.NOT.EQUAL(KEYWD,KNBDAF,6)) GO TO 1250 LFNDAF = ABS(LFNDAF) CALL IFLD(ITEMP,ERROR) IF(.NOT.ERROR) LFNDAF = ABS(ITEMP) GO TO 100 KEYWORD: ARCHIVE -- WRITE THE ARCHIVE FILE 1250 IF(.NOT.EQUAL(KEYWD,KARCHV,7)) GO TO 1260 JPRINT(7) = LFNARC CALL IFLD(ITEMP,ERROR) IF(.NOT.ERROR) JPRINT(7) = ABS(ITEMP) GO TO 100 KEYWORD: FILE -- SELECT ALTERNATE FILENAME 1260 IF(.NOT.EQUAL(KEYWD,KFILE,4)) GO TO 1270 LENG = 80 CALL HFLD(INTTMP,LENG,END) IF(.NOT.END) LENNM = LENG GO TO 100 KEYWORD: APOLAR -- ENFORCE APOLAR BONDS: 1270 IF(.NOT.EQUAL(KEYWD,KPOLAR,6)) GO TO 1290 IWAPOL = 1 GO TO 100 KEYWORD: NRTOPT -- OPTIMIZE NRT WEIGHTS: 1290 IF(.NOT.EQUAL(KEYWD,KNRTOP,6)) GO TO 1300 IF(JPRINT(14).EQ.0) JPRINT(14) = 1 IF(JPRINT(32).EQ.0) JPRINT(32) = 1 JPRINT(55) = IB LENG = KEYLEN CALL HFLD(KEYWD,LENG,END) IF(.NOT.END) THEN IF(EQUAL(KEYWD,KBFGS,4)) THEN JPRINT(55) = IB ELSE IF(EQUAL(KEYWD,KPOWEL,6)) THEN JPRINT(55) = IP ELSE IF(EQUAL(KEYWD,KSAP,3)) THEN JPRINT(55) = 1234567 IF(LENG.GT.3) CALL CONVIN(KEYWD(4),LENG-3,JPRINT(55),ERROR) IF(ERROR) CALL HALT('NRTOPT') JPRINT(55) = ABS(JPRINT(55)) ELSE IF(EQUAL(KEYWD,KSAP,2)) THEN JPRINT(55) = -1234567 IF(LENG.GT.2) CALL CONVIN(KEYWD(3),LENG-2,JPRINT(55),ERROR) IF(ERROR) CALL HALT('NRTOPT') JPRINT(55) = -ABS(JPRINT(55)) ELSE NEXTWD = .FALSE. END IF END IF GO TO 100 KEYWORD: NRTREF -- NUMBER OF REFERENCE STRUCTURES IN NRT ANALYSIS 1300 IF(.NOT.EQUAL(KEYWD,KNRTRF,6)) GO TO 1310 IF(JPRINT(14).EQ.0) JPRINT(14) = 1 IF(JPRINT(32).EQ.0) JPRINT(32) = 1 CALL IFLD(ITEMP,ERROR) IF(ERROR) GO TO 100 JPRINT(56) = MAX(1,ABS(ITEMP)) GO TO 100 KEYWORD: CHSTHR -- SET THE OCCUPANCY THRESHOLD IN CHOOSE 1310 IF(.NOT.EQUAL(KEYWD,KCHSTH,6)) GO TO 1320 CHSTHR = ABS(CHSTHR) CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 CHSTHR = ABS(TEMP) GO TO 100 KEYWORD: NRTDTL -- DETAIL NRT ANALYSIS 1320 IF(.NOT.EQUAL(KEYWD,KNRTDT,6)) GO TO 1340 IF(JPRINT(14).EQ.0) JPRINT(14) = 1 IF(JPRINT(32).EQ.0) JPRINT(32) = 1 JPRINT(57) = 1 CALL IFLD(ITEMP,ERROR) IF(ERROR) GO TO 100 JPRINT(57) = MAX(1,ABS(ITEMP)) GO TO 100 KEYWORD: NRTTHR -- SET THRESHOLD FOR DELOCALIZATION LIST 1340 IF(.NOT.EQUAL(KEYWD,KNRTTH,6)) GO TO 1360 IF(JPRINT(14).EQ.0) JPRINT(14) = 1 IF(JPRINT(32).EQ.0) JPRINT(32) = 1 DLTHR = ABS(DLTHR) CALL RFLD(TEMP,ERROR) IF(ERROR) GO TO 100 DLTHR = ABS(TEMP) GO TO 100 KEYWORD: NRT -- PERFORM NATURAL RESONANCE THEORY ANALYSIS: (NOTE THAT WE SHOULD CHECK THIS KEYWORD AFTER WE CHECK THE OTHER `NRT' KEYWORDS, LIKE `NRTOPT'. OTHERWISE, KEYWORD CONFLICTS CAN OCCUR.) 1360 IF(.NOT.EQUAL(KEYWD,KNRT,3)) GO TO 1370 JPRINT(14) = 1 JPRINT(32) = 1 CALL IFLD(ITEMP,ERROR) IF(.NOT.ERROR) JPRINT(32) = ITEMP GO TO 100 1370 GO TO 4800 ------------------------------------------------------------------------------ 4500 CONTINUE IF OPTION `FILE' WAS SELECTED, EXTRACT THE FILENAME FROM HOLLERITH ARRAY INTTMP: IF(LENNM.NE.0) THEN IDIV = IB - IA DO 4510 I = 1,LENNM FILENM(I:I) = CHAR(MOD((INTTMP(I)-IA)/IDIV,256) + 65) 4510 CONTINUE DO 4520 I = LENNM+1,80 FILENM(I:I) = CHAR(32) 4520 CONTINUE END IF ------------------------------------------------------------------------------ IF THE PRINT LEVEL IS SET TO ZERO AND NO OTHER OPTIONS WERE ENTERED, COMPLETELY SHUT OFF PROGRAM PRINTING: IF(NUMOPT.EQ.1.AND.IPRINT.EQ.0) IPRINT = -1 CHECK FOR JOB OPTIONS THAT ARE CURRENTLY INCOMPATABLE: IF((IWDM.EQ.0).AND.(IWMULP.NE.0)) GO TO 4900 CHECK FOR JOB OPTIONS THAT ARE STRICTLY INCOMPATIBLE: IF(ORTHO) THEN IWTNAO = 0 JPRINT(9) = 0 JPRINT(11) = 0 JPRINT(18) = 0 JPRINT(19) = 0 JPRINT(20) = 0 JPRINT(21) = 0 JPRINT(25) = 0 JPRINT(30) = 0 JPRINT(31) = 0 JPRINT(33) = 0 JPRINT(35) = 0 JPRINT(39) = 0 JPRINT(44) = 0 JPRINT(48) = 0 JPRINT(49) = 0 JPRINT(51) = 0 END IF ------------------------------------------------------------------------------ START PRINTING NBO OUTPUT: IF(IPRINT.GE.0) THEN WRITE(LFNPR,6000) IF(NUMOPT.GT.0) WRITE(LFNPR,6010) ------------------------------------------------------------------------------ 6000 FORMAT(/1X,79('*')/,13X, * 'N A T U R A L A T O M I C O R B I T A L A N D'/, * 10X,'N A T U R A L B O N D O R B I T A L ', * 'A N A L Y S I S',/1X,79('*')) 6010 FORMAT(1X) ------------------------------------------------------------------------------ JOB CONTROL KEYWORDS: IF(JPRINT(4).NE.0) WRITE(LFNPR,6020) IF(JPRINT(5).NE.0) WRITE(LFNPR,6030) IF(JPRINT(6).NE.0) WRITE(LFNPR,6040) IF(JPRINT(14).NE.0) WRITE(LFNPR,6050) IF(JPRINT(10).NE.0) WRITE(LFNPR,6060) IF(IW3C.NE.0) WRITE(LFNPR,6070) IF(JPRINT(1).NE.0) WRITE(LFNPR,6080) IF(JPRINT(8).NE.0) WRITE(LFNPR,6090) IF(JPRINT(32).NE.0) WRITE(LFNPR,6100) IF(JPRINT(55).EQ.IB) THEN WRITE(LFNPR,6110) ELSE IF(JPRINT(55).EQ.IP) THEN WRITE(LFNPR,6111) ELSE IF(JPRINT(55).LT.0) THEN WRITE(LFNPR,6112) ELSE IF(JPRINT(55).GT.0) THEN WRITE(LFNPR,6113) END IF IF(JPRINT(56).NE.0) WRITE(LFNPR,6120) JPRINT(56) IF(DLTHR.GE.ZERO) WRITE(LFNPR,6160) DLTHR IF(JPRINT(57).NE.0) WRITE(LFNPR,6170) JPRINT(57) ------------------------------------------------------------------------------ 6020 FORMAT(1X,' /NPA / : Print Natural Population Analysis') 6030 FORMAT(1X,' /NBO / : Print Natural Bond Orbital Analysis') 6040 FORMAT(1X,' /NBOSUM / : Print summary of the NBO analysis') 6050 FORMAT(1X,' /RESON / : Allow strongly delocalized NBO ', * 'set') 6060 FORMAT(1X,' /NOBOND / : No two-center NBO search') 6070 FORMAT(1X,' /3CBOND / : Search for 3-center bonds') 6080 FORMAT(1X,' /SKIPBO / : Skip NBO transformation step') 6090 FORMAT(1X,' /NLMO / : Form Natural Localized Molecular', * ' Orbitals') 6100 FORMAT(1X,' /NRT / : Perform Natural Resonance Theory ', * 'Analysis') 6110 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ', * 'BFGS method') 6111 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ', * 'POWELL method') 6112 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ', * 'ANNEAL method') 6113 FORMAT(1X,' /NRTOPT / : Optimize resonance weights with ', * 'ANNEAL method + penalty') 6120 FORMAT(1X,' /NRTREF / : Number of reference structures set', * ' to',I3) 6160 FORMAT(1X,' /NRTTHR / : Set to ',F5.2) 6170 FORMAT(1X,' /NRTDTL / : Set to ',I2) ------------------------------------------------------------------------------ JOB THRESHOLD KEYWORDS: IF(JPRINT(36).NE.0) WRITE(LFNPR,6500) IF(ATHR.GE.ZERO.OR.PTHR.GE.ZERO.OR.ETHR.GE.ZERO) + WRITE(LFNPR,6510) ABS(ATHR),ABS(PTHR),ABS(ETHR) IF(JPRINT(3).NE.0) WRITE(LFNPR,6520) IF(E2THR.GT.ZERO) WRITE(LFNPR,6530) E2THR IF(JPRINT(46).NE.0) WRITE(LFNPR,6540) IF(DTHR.GE.ZERO) WRITE(LFNPR,6550) ABS(DTHR) IF(THRSET.GT.ZERO) WRITE(LFNPR,6560) THRSET IF(PRJSET.GT.ZERO) WRITE(LFNPR,6570) PRJSET IF(CHSTHR.GT.ZERO) WRITE(LFNPR,6580) CHSTHR ------------------------------------------------------------------------------ 6500 FORMAT(1X,' /BEND / : Print NHO directionality table') 6510 FORMAT(1X,' Print thresholds set to (',F4.1, * ',',F5.1,',',F5.2,')') 6520 FORMAT(1X,' /E2PERT / : Analyze NBO Fock matrix') 6530 FORMAT(1X,' Print threshold set to ',F5.2) 6540 FORMAT(1X,' /DIPOLE / : Print NBO/NLMO dipole moment ', * 'analysis') 6550 FORMAT(1X,' Print threshold set to ',F5.2) 6560 FORMAT(1X,' /THRESH / : Set to ',F5.2) 6570 FORMAT(1X,' /PRJTHR / : Set to ',F5.2) 6580 FORMAT(1X,' /CHSTHR / : Set to ',F5.2) ------------------------------------------------------------------------------ MATRIX OUTPUT KEYWORDS: IF(JPRINT(44).EQ.IFULL) THEN WRITE(LFNPR,7000) ELSE IF(IOINQR(JPRINT(44)).EQ.IPRNT) THEN WRITE(LFNPR,7002) JPRINT(44) ELSE IF(IOINQR(JPRINT(44)).EQ.IWRIT) THEN WRITE(LFNPR,7004) ABS(JPRINT(44)) END IF IF(IWTNAO.EQ.IFULL) THEN WRITE(LFNPR,7010) ELSE IF(IOINQR(IWTNAO).EQ.IPRNT) THEN WRITE(LFNPR,7012) IWTNAO ELSE IF(IOINQR(IWTNAO).EQ.IWRIT) THEN WRITE(LFNPR,7014) ABS(IWTNAO) ELSE IF(IOINQR(IWTNAO).EQ.IREAD) THEN WRITE(LFNPR,7016) ABS(IWTNAO/1000) END IF IF(JPRINT(30).EQ.IFULL) THEN WRITE(LFNPR,7020) ELSE IF(IOINQR(JPRINT(30)).EQ.IPRNT) THEN WRITE(LFNPR,7022) JPRINT(30) ELSE IF(IOINQR(JPRINT(30)).EQ.IWRIT) THEN WRITE(LFNPR,7024) ABS(JPRINT(30)) END IF IF(JPRINT(28).EQ.IFULL) THEN WRITE(LFNPR,7030) ELSE IF(IOINQR(JPRINT(28)).EQ.IPRNT) THEN WRITE(LFNPR,7032) JPRINT(28) ELSE IF(IOINQR(JPRINT(28)).EQ.IWRIT) THEN WRITE(LFNPR,7034) ABS(JPRINT(28)) END IF IF(JPRINT(25).EQ.IFULL) THEN WRITE(LFNPR,7040) ELSE IF(JPRINT(25).EQ.ILEW) THEN WRITE(LFNPR,7042) ELSE IF(IOINQR(JPRINT(25)).EQ.IPRNT) THEN WRITE(LFNPR,7044) JPRINT(25) ELSE IF(IOINQR(JPRINT(25)).EQ.IWRIT) THEN WRITE(LFNPR,7046) ABS(JPRINT(25)) END IF IF(IWTNBO.EQ.IFULL) THEN WRITE(LFNPR,7050) ELSE IF(IWTNBO.EQ.ILEW) THEN WRITE(LFNPR,7052) ELSE IF(IOINQR(IWTNBO).EQ.IPRNT) THEN WRITE(LFNPR,7054) IWTNBO ELSE IF(IOINQR(IWTNBO).EQ.IWRIT) THEN WRITE(LFNPR,7056) ABS(IWTNBO) END IF IF(JPRINT(49).EQ.IFULL) THEN WRITE(LFNPR,7060) ELSE IF(JPRINT(49).EQ.ILEW) THEN WRITE(LFNPR,7062) ELSE IF(IOINQR(JPRINT(49)).EQ.IPRNT) THEN WRITE(LFNPR,7064) JPRINT(49) ELSE IF(IOINQR(JPRINT(49)).EQ.IWRIT) THEN WRITE(LFNPR,7066) ABS(JPRINT(49)) END IF IF(JPRINT(23).EQ.IFULL) THEN WRITE(LFNPR,7070) ELSE IF(JPRINT(23).EQ.ILEW) THEN WRITE(LFNPR,7072) ELSE IF(IOINQR(JPRINT(23)).EQ.IPRNT) THEN WRITE(LFNPR,7074) JPRINT(23) ELSE IF(IOINQR(JPRINT(23)).EQ.IWRIT) THEN WRITE(LFNPR,7076) ABS(JPRINT(23)) END IF IF(JPRINT(26).EQ.IFULL) THEN WRITE(LFNPR,7080) ELSE IF(JPRINT(26).EQ.IVAL) THEN WRITE(LFNPR,7082) ELSE IF(JPRINT(26).EQ.ILEW) THEN WRITE(LFNPR,7084) ELSE IF(IOINQR(JPRINT(26)).EQ.IPRNT) THEN WRITE(LFNPR,7086) JPRINT(26) ELSE IF(IOINQR(JPRINT(26)).EQ.IWRIT) THEN WRITE(LFNPR,7088) ABS(JPRINT(26)) END IF IF(IWPNAO.EQ.IFULL) THEN WRITE(LFNPR,7090) ELSE IF(IOINQR(IWPNAO).EQ.IPRNT) THEN WRITE(LFNPR,7092) IWPNAO ELSE IF(IOINQR(IWPNAO).EQ.IWRIT) THEN WRITE(LFNPR,7094) ABS(IWPNAO) ELSE IF(IOINQR(IWPNAO).EQ.IREAD) THEN WRITE(LFNPR,7096) ABS(IWPNAO/1000) END IF IF(JPRINT(33).EQ.IFULL) THEN WRITE(LFNPR,7100) ELSE IF(IOINQR(JPRINT(33)).EQ.IPRNT) THEN WRITE(LFNPR,7102) JPRINT(33) ELSE IF(IOINQR(JPRINT(33)).EQ.IWRIT) THEN WRITE(LFNPR,7104) ABS(JPRINT(33)) END IF IF(IWTNAB.EQ.IFULL) THEN WRITE(LFNPR,7110) ELSE IF(IWTNAB.EQ.ILEW) THEN WRITE(LFNPR,7112) ELSE IF(IOINQR(IWTNAB).EQ.IPRNT) THEN WRITE(LFNPR,7114) IWTNAB ELSE IF(IOINQR(IWTNAB).EQ.IWRIT) THEN WRITE(LFNPR,7116) ABS(IWTNAB) ELSE IF(IOINQR(IWTNAB).EQ.IREAD) THEN WRITE(LFNPR,7118) ABS(IWTNAB/1000) END IF IF(JPRINT(18).EQ.IFULL) THEN WRITE(LFNPR,7120) ELSE IF(JPRINT(18).EQ.ILEW) THEN WRITE(LFNPR,7122) ELSE IF(IOINQR(JPRINT(18)).EQ.IPRNT) THEN WRITE(LFNPR,7124) JPRINT(18) ELSE IF(IOINQR(JPRINT(18)).EQ.IWRIT) THEN WRITE(LFNPR,7126) ABS(JPRINT(18)) END IF IF(JPRINT(9).EQ.IFULL) THEN WRITE(LFNPR,7130) ELSE IF(JPRINT(9).EQ.IVAL) THEN WRITE(LFNPR,7132) ELSE IF(JPRINT(9).EQ.ILEW) THEN WRITE(LFNPR,7134) ELSE IF(IOINQR(JPRINT(9)).EQ.IPRNT) THEN WRITE(LFNPR,7136) JPRINT(9) ELSE IF(IOINQR(JPRINT(9)).EQ.IWRIT) THEN WRITE(LFNPR,7138) ABS(JPRINT(9)) END IF IF(JPRINT(41).EQ.IFULL) THEN WRITE(LFNPR,7140) ELSE IF(JPRINT(41).EQ.ILEW) THEN WRITE(LFNPR,7142) ELSE IF(IOINQR(JPRINT(41)).EQ.IPRNT) THEN WRITE(LFNPR,7144) JPRINT(41) ELSE IF(IOINQR(JPRINT(41)).EQ.IWRIT) THEN WRITE(LFNPR,7146) ABS(JPRINT(41)) END IF IF(JPRINT(24).EQ.IFULL) THEN WRITE(LFNPR,7150) ELSE IF(JPRINT(24).EQ.ILEW) THEN WRITE(LFNPR,7152) ELSE IF(IOINQR(JPRINT(24)).EQ.IPRNT) THEN WRITE(LFNPR,7154) JPRINT(24) ELSE IF(IOINQR(JPRINT(24)).EQ.IWRIT) THEN WRITE(LFNPR,7156) ABS(JPRINT(24)) END IF IF(JPRINT(38).EQ.IFULL) THEN WRITE(LFNPR,7160) ELSE IF(JPRINT(38).EQ.IVAL) THEN WRITE(LFNPR,7162) ELSE IF(JPRINT(38).EQ.ILEW) THEN WRITE(LFNPR,7164) ELSE IF(IOINQR(JPRINT(38)).EQ.IPRNT) THEN WRITE(LFNPR,7166) JPRINT(38) ELSE IF(IOINQR(JPRINT(38)).EQ.IWRIT) THEN WRITE(LFNPR,7168) ABS(JPRINT(38)) END IF IF(JPRINT(47).EQ.IFULL) THEN WRITE(LFNPR,7170) ELSE IF(JPRINT(47).EQ.ILEW) THEN WRITE(LFNPR,7172) ELSE IF(IOINQR(JPRINT(47)).EQ.IPRNT) THEN WRITE(LFNPR,7174) JPRINT(47) ELSE IF(IOINQR(JPRINT(47)).EQ.IWRIT) THEN WRITE(LFNPR,7176) ABS(JPRINT(47)) END IF IF(JPRINT(45).EQ.IFULL) THEN WRITE(LFNPR,7180) ELSE IF(JPRINT(45).EQ.IVAL) THEN WRITE(LFNPR,7182) ELSE IF(JPRINT(45).EQ.ILEW) THEN WRITE(LFNPR,7184) ELSE IF(IOINQR(JPRINT(45)).EQ.IPRNT) THEN WRITE(LFNPR,7186) JPRINT(45) ELSE IF(IOINQR(JPRINT(45)).EQ.IWRIT) THEN WRITE(LFNPR,7188) ABS(JPRINT(45)) END IF IF(JPRINT(13).EQ.IFULL) THEN WRITE(LFNPR,7190) ELSE IF(JPRINT(13).EQ.IVAL) THEN WRITE(LFNPR,7192) ELSE IF(JPRINT(13).EQ.ILEW) THEN WRITE(LFNPR,7194) ELSE IF(IOINQR(JPRINT(13)).EQ.IPRNT) THEN WRITE(LFNPR,7196) JPRINT(13) ELSE IF(IOINQR(JPRINT(13)).EQ.IWRIT) THEN WRITE(LFNPR,7198) ABS(JPRINT(13)) END IF IF(JPRINT(42).EQ.IFULL) THEN WRITE(LFNPR,7200) ELSE IF(IOINQR(JPRINT(42)).EQ.IPRNT) THEN WRITE(LFNPR,7202) JPRINT(42) ELSE IF(IOINQR(JPRINT(42)).EQ.IWRIT) THEN WRITE(LFNPR,7204) ABS(JPRINT(42)) END IF IF(JPRINT(27).EQ.IFULL) THEN WRITE(LFNPR,7210) ELSE IF(IOINQR(JPRINT(27)).EQ.IPRNT) THEN WRITE(LFNPR,7212) JPRINT(27) ELSE IF(IOINQR(JPRINT(27)).EQ.IWRIT) THEN WRITE(LFNPR,7214) ABS(JPRINT(27)) END IF IF(JPRINT(35).EQ.IFULL) THEN WRITE(LFNPR,7220) ELSE IF(IOINQR(JPRINT(35)).EQ.IPRNT) THEN WRITE(LFNPR,7222) JPRINT(35) ELSE IF(IOINQR(JPRINT(35)).EQ.IWRIT) THEN WRITE(LFNPR,7224) ABS(JPRINT(35)) END IF IF(JPRINT(34).EQ.IFULL) THEN WRITE(LFNPR,7230) ELSE IF(IOINQR(JPRINT(34)).EQ.IPRNT) THEN WRITE(LFNPR,7232) JPRINT(34) ELSE IF(IOINQR(JPRINT(34)).EQ.IWRIT) THEN WRITE(LFNPR,7234) ABS(JPRINT(34)) END IF IF(JPRINT(16).EQ.IFULL) THEN WRITE(LFNPR,7240) ELSE IF(JPRINT(16).EQ.ILEW) THEN WRITE(LFNPR,7242) ELSE IF(IOINQR(JPRINT(16)).EQ.IPRNT) THEN WRITE(LFNPR,7244) JPRINT(16) ELSE IF(IOINQR(JPRINT(16)).EQ.IWRIT) THEN WRITE(LFNPR,7246) ABS(JPRINT(16)) END IF IF(JPRINT(17).EQ.IFULL) THEN WRITE(LFNPR,7250) ELSE IF(JPRINT(17).EQ.ILEW) THEN WRITE(LFNPR,7252) ELSE IF(IOINQR(JPRINT(17)).EQ.IPRNT) THEN WRITE(LFNPR,7254) JPRINT(17) ELSE IF(IOINQR(JPRINT(17)).EQ.IWRIT) THEN WRITE(LFNPR,7256) ABS(JPRINT(17)) END IF IF(JPRINT(40).EQ.IFULL) THEN WRITE(LFNPR,7260) ELSE IF(IOINQR(JPRINT(40)).EQ.IPRNT) THEN WRITE(LFNPR,7262) JPRINT(40) ELSE IF(IOINQR(JPRINT(40)).EQ.IWRIT) THEN WRITE(LFNPR,7264) ABS(JPRINT(40)) END IF IF(JPRINT(31).EQ.IFULL) THEN WRITE(LFNPR,7270) ELSE IF(IOINQR(JPRINT(31)).EQ.IPRNT) THEN WRITE(LFNPR,7272) JPRINT(31) ELSE IF(IOINQR(JPRINT(31)).EQ.IWRIT) THEN WRITE(LFNPR,7274) ABS(JPRINT(31)) END IF IF(JPRINT(29).EQ.IFULL) THEN WRITE(LFNPR,7280) ELSE IF(IOINQR(JPRINT(29)).EQ.IPRNT) THEN WRITE(LFNPR,7282) JPRINT(29) ELSE IF(IOINQR(JPRINT(29)).EQ.IWRIT) THEN WRITE(LFNPR,7284) ABS(JPRINT(29)) END IF IF(JPRINT(37).EQ.IFULL) THEN WRITE(LFNPR,7290) ELSE IF(JPRINT(37).EQ.ILEW) THEN WRITE(LFNPR,7292) ELSE IF(IOINQR(JPRINT(37)).EQ.IPRNT) THEN WRITE(LFNPR,7294) JPRINT(37) ELSE IF(IOINQR(JPRINT(37)).EQ.IWRIT) THEN WRITE(LFNPR,7296) ABS(JPRINT(37)) END IF IF(JPRINT(15).EQ.IFULL) THEN WRITE(LFNPR,7300) ELSE IF(JPRINT(15).EQ.ILEW) THEN WRITE(LFNPR,7302) ELSE IF(IOINQR(JPRINT(15)).EQ.IPRNT) THEN WRITE(LFNPR,7304) JPRINT(15) ELSE IF(IOINQR(JPRINT(15)).EQ.IWRIT) THEN WRITE(LFNPR,7306) ABS(JPRINT(15)) END IF IF(JPRINT(50).EQ.IFULL) THEN WRITE(LFNPR,7310) ELSE IF(IOINQR(JPRINT(50)).EQ.IPRNT) THEN WRITE(LFNPR,7312) JPRINT(50) ELSE IF(IOINQR(JPRINT(50)).EQ.IWRIT) THEN WRITE(LFNPR,7314) ABS(JPRINT(50)) END IF IF(JPRINT(51).EQ.IFULL) THEN WRITE(LFNPR,7320) ELSE IF(IOINQR(JPRINT(51)).EQ.IPRNT) THEN WRITE(LFNPR,7322) JPRINT(51) ELSE IF(IOINQR(JPRINT(51)).EQ.IWRIT) THEN WRITE(LFNPR,7324) ABS(JPRINT(51)) END IF IF(JPRINT(52).EQ.IFULL) THEN WRITE(LFNPR,7330) ELSE IF(IOINQR(JPRINT(52)).EQ.IPRNT) THEN WRITE(LFNPR,7332) JPRINT(52) ELSE IF(IOINQR(JPRINT(52)).EQ.IWRIT) THEN WRITE(LFNPR,7334) ABS(JPRINT(52)) END IF IF(JPRINT(53).EQ.IFULL) THEN WRITE(LFNPR,7340) ELSE IF(JPRINT(53).EQ.ILEW) THEN WRITE(LFNPR,7342) ELSE IF(IOINQR(JPRINT(53)).EQ.IPRNT) THEN WRITE(LFNPR,7344) JPRINT(53) ELSE IF(IOINQR(JPRINT(53)).EQ.IWRIT) THEN WRITE(LFNPR,7346) ABS(JPRINT(53)) END IF IF(JPRINT(54).EQ.IFULL) THEN WRITE(LFNPR,7350) ELSE IF(JPRINT(54).EQ.ILEW) THEN WRITE(LFNPR,7352) ELSE IF(IOINQR(JPRINT(54)).EQ.IPRNT) THEN WRITE(LFNPR,7354) JPRINT(54) ELSE IF(IOINQR(JPRINT(54)).EQ.IWRIT) THEN WRITE(LFNPR,7356) ABS(JPRINT(54)) END IF IF(JPRINT(39).EQ.IFULL) THEN WRITE(LFNPR,7360) ELSE IF(IOINQR(JPRINT(39)).EQ.IPRNT) THEN WRITE(LFNPR,7362) JPRINT(39) ELSE IF(IOINQR(JPRINT(39)).EQ.IWRIT) THEN WRITE(LFNPR,7364) ABS(JPRINT(39)) END IF IF(JPRINT(19).EQ.IFULL) THEN WRITE(LFNPR,7370) ELSE IF(IOINQR(JPRINT(19)).EQ.IPRNT) THEN WRITE(LFNPR,7372) JPRINT(19) ELSE IF(IOINQR(JPRINT(19)).EQ.IWRIT) THEN WRITE(LFNPR,7374) ABS(JPRINT(19)) END IF IF(JPRINT(20).EQ.IFULL) THEN WRITE(LFNPR,7380) ELSE IF(IOINQR(JPRINT(20)).EQ.IPRNT) THEN WRITE(LFNPR,7382) JPRINT(20) ELSE IF(IOINQR(JPRINT(20)).EQ.IWRIT) THEN WRITE(LFNPR,7384) ABS(JPRINT(20)) END IF IF(JPRINT(21).EQ.IFULL) THEN WRITE(LFNPR,7390) ELSE IF(JPRINT(21).EQ.ILEW) THEN WRITE(LFNPR,7392) ELSE IF(IOINQR(JPRINT(21)).EQ.IPRNT) THEN WRITE(LFNPR,7394) JPRINT(21) ELSE IF(IOINQR(JPRINT(21)).EQ.IWRIT) THEN WRITE(LFNPR,7396) ABS(JPRINT(21)) END IF IF(JPRINT(48).EQ.IFULL) THEN WRITE(LFNPR,7400) ELSE IF(JPRINT(48).EQ.ILEW) THEN WRITE(LFNPR,7402) ELSE IF(IOINQR(JPRINT(48)).EQ.IPRNT) THEN WRITE(LFNPR,7404) JPRINT(48) ELSE IF(IOINQR(JPRINT(48)).EQ.IWRIT) THEN WRITE(LFNPR,7406) ABS(JPRINT(48)) END IF ------------------------------------------------------------------------------ 7000 FORMAT(1X,' /AOPNAO / : Print the AO to PNAO transformation') 7002 FORMAT(1X,' /AOPNAO / : Print ',I3,' columns of the AO to ', * 'PNAO transformation') 7004 FORMAT(1X,' /AOPNAO / : Write the AO to PNAO transformation', * ' to LFN',I3) 7010 FORMAT(1X,' /AONAO / : Print the AO to NAO transformation') 7012 FORMAT(1X,' /AONAO / : Print ',I3,' columns of the AO ', * 'to NAO transformation') 7014 FORMAT(1X,' /AONAO / : Write the AO to NAO transformation ', * 'to LFN',I3) 7016 FORMAT(1X,' /AONAO / : Read AO to NAO transformation from ', * 'LFN',I3) 7020 FORMAT(1X,' /AOPNHO / : Print the AO to PNHO ', * 'transformation') 7022 FORMAT(1X,' /AOPNHO / : Print ',I3,' columns of the AO to ', * 'PNHO transformation') 7024 FORMAT(1X,' /AOPNHO / : Write the AO to PNHO transformation', * ' to LFN',I3) 7030 FORMAT(1X,' /AONHO / : Print the AO to NHO transformation') 7032 FORMAT(1X,' /AONHO / : Print ',I3,' columns of the AO to ', * 'NHO transformation') 7034 FORMAT(1X,' /AONHO / : Write the AO to NHO transformation ', * 'to LFN',I3) 7040 FORMAT(1X,' /AOPNBO / : Print the AO to PNBO ', * 'transformation') 7042 FORMAT(1X,' /AOPNBO / : Print the occupied PNBOs in the AO ', * 'basis') 7044 FORMAT(1X,' /AOPNBO / : Print ',I3,' columns of the AO to ', * 'PNBO transformation') 7046 FORMAT(1X,' /AOPNBO / : Write the AO to PNBO transformation', * ' to LFN',I3) 7050 FORMAT(1X,' /AONBO / : Print the AO to NBO transformation') 7052 FORMAT(1X,' /AONBO / : Print the occupied NBOs in the AO ', * 'basis') 7054 FORMAT(1X,' /AONBO / : Print ',I3,' columns of the AO ', * 'to NBO transformation') 7056 FORMAT(1X,' /AONBO / : Write the AO to NBO transformation ', * 'to LFN',I3) 7060 FORMAT(1X,' /AOPNLMO/ : Print the AO to PNLMO ', * 'transformation') 7062 FORMAT(1X,' /AOPNLMO/ : Print the occupied PNLMOs in the AO', * ' basis') 7064 FORMAT(1X,' /AOPNLMO/ : Print ',I3,' columns of the AO to ', * 'PNLMO transformation') 7066 FORMAT(1X,' /AOPNLMO/ : Write the AO to PNLMO transformatio', * 'n to LFN',I3) 7070 FORMAT(1X,' /AONLMO / : Print the AO to NLMO ', * 'transformation') 7072 FORMAT(1X,' /AONLMO / : Print the occupied NLMOs in the AO ', * 'basis') 7074 FORMAT(1X,' /AONLMO / : Print ',I3,' columns of the AO to ', * 'NLMO transformation') 7076 FORMAT(1X,' /AONLMO / : Write the AO to NLMO transformation', * ' to LFN',I3) 7080 FORMAT(1X,' /AOMO / : Print all MOs in the AO basis') 7082 FORMAT(1X,' /AOMO / : Print core and valence MOs in ', * 'the AO basis') 7084 FORMAT(1X,' /AOMO / : Print the occupied MOs in the AO ', * 'basis') 7086 FORMAT(1X,' /AOMO / : Print ',I3,' lowest energy MOs ', * 'in the AO basis') 7088 FORMAT(1X,' /AOMO / : Write the AO to MO transformation ', * 'to LFN',I3) 7090 FORMAT(1X,' /PAOPNAO/ : Print the PAO to PNAO ', * 'transformation') 7092 FORMAT(1X,' /PAOPNAO/ : Print ',I3,' columns of the PAO ', * 'to PNAO transformation') 7094 FORMAT(1X,' /PAOPNAO/ : Write the PAO to PNAO ', * 'transformation to LFN',I3) 7096 FORMAT(1X,' /PAOPNAO/ : Read PAO to PNAO transformation ', * 'from LFN',I3) 7100 FORMAT(1X,' /NAONHO / : Print the NAO to NHO transformation') 7102 FORMAT(1X,' /NAONHO / : Print ',I3,' columns of the NAO ', * 'to NHO transformation') 7104 FORMAT(1X,' /NAONHO / : Write the NAO to NHO transformation', * ' to LFN',I3) 7110 FORMAT(1X,' /NAONBO / : Print the NAO to NBO transformation') 7112 FORMAT(1X,' /NAONBO / : Print the occupied NBOs in the NAO ', * 'basis') 7114 FORMAT(1X,' /NAONBO / : Print ',I3,' columns of the NAO ', * 'to NBO transformation') 7116 FORMAT(1X,' /NAONBO / : Write the NAO to NBO transformation', * ' to LFN',I3) 7118 FORMAT(1X,' /NAONBO / : Read NAO to NBO transformation from', * ' LFN',I3) 7120 FORMAT(1X,' /NAONLMO/ : Print the NAO to NLMO ', * 'transformation') 7122 FORMAT(1X,' /NAONLMO/ : Print the occupied NLMOs in the NAO', * ' basis') 7124 FORMAT(1X,' /NAONLMO/ : Print ',I3,' columns of the NAO ', * 'to NLMO transformation') 7126 FORMAT(1X,' /NAONLMO/ : Write the NAO to NLMO ', * 'transformation to LFN',I3) 7130 FORMAT(1X,' /NAOMO / : Print all MOs in the NAO basis') 7132 FORMAT(1X,' /NAOMO / : Print core and valence MOs in ', * 'the NAO basis') 7134 FORMAT(1X,' /NAOMO / : Print the occupied MOs in the NAO ', * 'basis') 7136 FORMAT(1X,' /NAOMO / : Print ',I3,' lowest energy MOs ', * 'in the NAO basis') 7138 FORMAT(1X,' /NAOMO / : Write the NAO to MO transformation ', * 'to LFN',I3) 7140 FORMAT(1X,' /NHONBO / : Print the NHO to NBO transformation') 7142 FORMAT(1X,' /NHONBO / : Print the occupied NBOs in the NHO ', * 'basis') 7144 FORMAT(1X,' /NHONBO / : Print ',I3,' columns of the NHO ', * 'to NBO transformation') 7146 FORMAT(1X,' /NHONBO / : Write the NHO to NBO transformation', * ' to LFN',I3) 7150 FORMAT(1X,' /NHONLMO/ : Print the NHO to NLMO ', * 'transformation') 7152 FORMAT(1X,' /NHONLMO/ : Print the occupied NLMOs in the NHO', * ' basis') 7154 FORMAT(1X,' /NHONLMO/ : Print ',I3,' columns of the NHO ', * 'to NLMO transformation') 7156 FORMAT(1X,' /NHONLMO/ : Write the NHO to NLMO ', * 'transformation to LFN',I3) 7160 FORMAT(1X,' /NHOMO / : Print all MOs in the NHO basis') 7162 FORMAT(1X,' /NHOMO / : Print core and valence MOs in ', * 'the NHO basis') 7164 FORMAT(1X,' /NHOMO / : Print the occupied MOs in the NHO ', * 'basis') 7166 FORMAT(1X,' /NHOMO / : Print ',I3,' lowest energy MOs ', * 'in the NHO basis') 7168 FORMAT(1X,' /NHOMO / : Write the NHO to MO transformation ', * 'to LFN',I3) 7170 FORMAT(1X,' /NBONLMO/ : Print the NBO to NLMO ', * 'transformation') 7172 FORMAT(1X,' /NBONLMO/ : Print the occupied NLMOs in the NBO', * ' basis') 7174 FORMAT(1X,' /NBONLMO/ : Print ',I3,' columns of the NBO ', * 'to NLMO transformation') 7176 FORMAT(1X,' /NBONLMO/ : Write the NBO to NLMO ', * 'transformation to LFN',I3) 7180 FORMAT(1X,' /NBOMO / : Print all MOs in the NBO basis') 7182 FORMAT(1X,' /NBOMO / : Print core and valence MOs in ', * 'the NBO basis') 7184 FORMAT(1X,' /NBOMO / : Print the occupied MOs in the NBO ', * 'basis') 7186 FORMAT(1X,' /NBOMO / : Print ',I3,' lowest energy MOs ', * 'in the NBO basis') 7188 FORMAT(1X,' /NBOMO / : Write the NBO to MO transformation ', * 'to LFN',I3) 7190 FORMAT(1X,' /NLMOMO / : Print all MOs in the NLMO basis') 7192 FORMAT(1X,' /NLMOMO / : Print core and valence MOs in ', * 'the NLMO basis') 7194 FORMAT(1X,' /NLMOMO / : Print the occupied MOs in the NLMO ', * 'basis') 7196 FORMAT(1X,' /NLMOMO / : Print ',I3,' lowest energy MOs ', * 'in the NLMO basis') 7198 FORMAT(1X,' /NLMOMO / : Write the NLMO to MO transformation', * ' to LFN',I3) 7200 FORMAT(1X,' /BOAO / : Print the AO bond-order matrix') 7202 FORMAT(1X,' /BOAO / : Print ',I3,' columns of the AO ', * 'bond-order matrix') 7204 FORMAT(1X,' /BOAO / : Write the AO bond-order matrix to ', * 'LFN',I3) 7210 FORMAT(1X,' /DMAO / : Print the AO density matrix') 7212 FORMAT(1X,' /DMAO / : Print ',I3,' columns of the AO ', * 'density matrix') 7214 FORMAT(1X,' /DMAO / : Write the AO density matrix to ', * 'LFN',I3) 7220 FORMAT(1X,' /DMNAO / : Print the NAO density matrix') 7222 FORMAT(1X,' /DMNAO / : Print ',I3,' columns of the NAO ', * 'density matrix') 7224 FORMAT(1X,' /DMNAO / : Write the NAO density matrix to ', * 'LFN',I3) 7230 FORMAT(1X,' /DMNHO / : Print the NHO density matrix') 7232 FORMAT(1X,' /DMNHO / : Print ',I3,' columns of the NHO ', * 'density matrix') 7234 FORMAT(1X,' /DMNHO / : Write the NHO density matrix to ', * 'LFN',I3) 7240 FORMAT(1X,' /DMNBO / : Print the NBO density matrix') 7242 FORMAT(1X,' /DMNBO / : Print the density matrix elements ', * 'of the occupied NBOs') 7244 FORMAT(1X,' /DMNBO / : Print ',I3,' columns of the NBO ', * 'density matrix') 7246 FORMAT(1X,' /DMNBO / : Write the NBO density matrix to ', * 'LFN',I3) 7250 FORMAT(1X,' /DMNLMO / : Print the NLMO density matrix') 7252 FORMAT(1X,' /DMNLMO / : Print the density matrix elements ', * 'of the occupied NLMOs') 7254 FORMAT(1X,' /DMNLMO / : Print ',I3,' columns of the NLMO ', * 'density matrix') 7256 FORMAT(1X,' /DMNLMO / : Write the NLMO density matrix to ', * 'LFN',I3) 7260 FORMAT(1X,' /FAO / : Print the AO Fock matrix') 7262 FORMAT(1X,' /FAO / : Print ',I3,' columns of the AO ', * 'Fock matrix') 7264 FORMAT(1X,' /FAO / : Write the AO Fock matrix to ', * 'LFN',I3) 7270 FORMAT(1X,' /FNAO / : Print the NAO Fock matrix') 7272 FORMAT(1X,' /FNAO / : Print ',I3,' columns of the NAO ', * 'Fock matrix') 7274 FORMAT(1X,' /FNAO / : Write the NAO Fock matrix to ', * 'LFN',I3) 7280 FORMAT(1X,' /FNHO / : Print the NHO Fock matrix') 7282 FORMAT(1X,' /FNHO / : Print ',I3,' columns of the NHO ', * 'Fock matrix') 7284 FORMAT(1X,' /FNHO / : Write the NHO Fock matrix to ', * 'LFN',I3) 7290 FORMAT(1X,' /FNBO / : Print the NBO Fock matrix') 7292 FORMAT(1X,' /FNBO / : Print the Fock matrix elements of ', * 'the occupied NBOs') 7294 FORMAT(1X,' /FNBO / : Print ',I3,' columns of the NBO ', * 'Fock matrix') 7296 FORMAT(1X,' /FNBO / : Write the NBO Fock matrix to ', * 'LFN',I3) 7300 FORMAT(1X,' /FNLMO / : Print the NLMO Fock matrix') 7302 FORMAT(1X,' /FNLMO / : Print the Fock matrix elements of ', * 'the occupied NLMOs') 7304 FORMAT(1X,' /FNLMO / : Print ',I3,' columns of the NLMO ', * 'Fock matrix') 7306 FORMAT(1X,' /FNLMO / : Write the NLMO Fock matrix to ', * 'LFN',I3) 7310 FORMAT(1X,' /DIAO / : Print the AO dipole integrals') 7312 FORMAT(1X,' /DIAO / : Print ',I3,' columns of the AO ', * 'dipole matrices') 7314 FORMAT(1X,' /DIAO / : Write the AO dipole integrals', * ' to LFN',I3) 7320 FORMAT(1X,' /DINAO / : Print the NAO dipole integrals') 7322 FORMAT(1X,' /DINAO / : Print ',I3,' columns of the NAO ', * 'dipole matrices') 7324 FORMAT(1X,' /DINAO / : Write the NAO dipole integrals', * ' to LFN',I3) 7330 FORMAT(1X,' /DINHO / : Print the NHO dipole integrals') 7332 FORMAT(1X,' /DINHO / : Print ',I3,' columns of the NHO ', * 'dipole matrices') 7334 FORMAT(1X,' /DINHO / : Write the NHO dipole integrals', * ' to LFN',I3) 7340 FORMAT(1X,' /DINBO / : Print the NBO dipole integrals') 7342 FORMAT(1X,' /DINBO / : Print the dipole integrals of ', * 'occupied NBOs') 7344 FORMAT(1X,' /DINBO / : Print ',I3,' columns of the NBO ', * 'dipole matrices') 7346 FORMAT(1X,' /DINBO / : Write the NBO dipole integrals', * ' to LFN',I3) 7350 FORMAT(1X,' /DINLMO / : Print the NLMO dipole integrals') 7352 FORMAT(1X,' /DINLMO / : Print the dipole integrals of ', * 'occupied NLMOs') 7354 FORMAT(1X,' /DINLMO / : Print ',I3,' columns of the NLMO ', * 'dipole matrices') 7356 FORMAT(1X,' /DINLMO / : Write the NLMO dipole integrals', * ' to LFN',I3) 7360 FORMAT(1X,' /SAO / : Print the AO overlap matrix') 7362 FORMAT(1X,' /SAO / : Print ',I3,' columns of the AO ', * 'overlap matrix') 7364 FORMAT(1X,' /SAO / : Write the AO overlap matrix to ', * 'LFN',I3) 7370 FORMAT(1X,' /SPNAO / : Print the PNAO overlap matrix') 7372 FORMAT(1X,' /SPNAO / : Print ',I3,' columns of the PNAO ', * 'overlap matrix') 7374 FORMAT(1X,' /SPNAO / : Write the PNAO overlap matrix to ', * 'LFN',I3) 7380 FORMAT(1X,' /SPNHO / : Print the PNHO overlap matrix') 7382 FORMAT(1X,' /SPNHO / : Print ',I3,' columns of the PNHO ', * 'overlap matrix') 7384 FORMAT(1X,' /SPNHO / : Write the PNHO overlap matrix to ', * 'LFN',I3) 7390 FORMAT(1X,' /SPNBO / : Print the PNBO overlap matrix') 7392 FORMAT(1X,' /SPNBO / : Print the overlap matrix elements ', * 'of the occupied PNBOs') 7394 FORMAT(1X,' /SPNBO / : Print ',I3,' columns of the PNBO ', * 'overlap matrix') 7396 FORMAT(1X,' /SPNBO / : Write the PNBO overlap matrix to ', * 'LFN',I3) 7400 FORMAT(1X,' /SPNLMO / : Print the PNLMO overlap matrix') 7402 FORMAT(1X,' /SPNLMO / : Print the overlap matrix elements ', * 'of the occupied PNLMOs') 7404 FORMAT(1X,' /SPNLMO / : Print ',I3,' columns of the PNLMO ', * 'overlap matrix') 7406 FORMAT(1X,' /SPNLMO / : Write the PNLMO overlap matrix to ', * 'LFN',I3) ------------------------------------------------------------------------------ OTHER OUTPUT CONTROL KEYWORDS: IF(LFNPR.NE.6) WRITE(LFNPR,8000) LFNPR IF(JPRINT(43).NE.0) WRITE(LFNPR,8010) IF(IWDETL.NE.0) WRITE(LFNPR,8020) IF(JPRINT(7).NE.0) WRITE(LFNPR,8030) JPRINT(7) IF(JPRINT(12).NE.0) WRITE(LFNPR,8040) IF(LFNDAF.GE.0) WRITE(LFNPR,8050) LFNDAF IF(JPRINT(22).NE.0) WRITE(LFNPR,8060) JPRINT(22) IF(IWMULP.EQ.1) WRITE(LFNPR,8070) IF(IWMULP.EQ.2) WRITE(LFNPR,8080) IF(IWAPOL.NE.0) WRITE(LFNPR,8090) IF(JPRINT(11).NE.0) WRITE(LFNPR,8100) IF(LENNM.NE.0) WRITE(LFNPR,8110) FILENM(1:52) IF(IPRINT.LT.10) THEN WRITE(LFNPR,8500) IPRINT ELSE IPRINT = IPRINT - 10 END IF ------------------------------------------------------------------------------ 8000 FORMAT(1X,' /LFNPR / : set to',I3) 8010 FORMAT(1X,' /PLOT / : Write information for the orbital', * ' plotter') 8020 FORMAT(1X,' /DETAIL / : Write out details of NBO search') 8030 FORMAT(1X,' /ARCHIVE/ : Write the archive file to LFN',I3) 8040 FORMAT(1X,' /BNDIDX / : Print bond indices based on ', * 'the NAO density matrix') 8050 FORMAT(1X,' /NBODAF / : NBO direct access file written on', * ' LFN',I3) 8060 FORMAT(1X,' /AOINFO / : Write AO information to LFN',I3) 8070 FORMAT(1X,' /MULAT / : Print Mulliken populations', * ' by atom') 8080 FORMAT(1X,' /MULORB / : Print Mulliken populations', * ' by orbital and atom') 8090 FORMAT(1X,' /APOLAR / : Enforce apolar NBOs') 8100 FORMAT(1X,' /RPNAO / : Revise TPNAO with TRYD and TRED') 8110 FORMAT(1X,' /FILE / : Set to ',A52) 8500 FORMAT(1X,' /PRINT / : Print level set to',I3) ------------------------------------------------------------------------------ END IF SET PRINT LEVEL OPTIONS: IF(IPRINT.GT.0) THEN JPRINT(4) = 1 JPRINT(5) = 1 END IF IF(IPRINT.GT.1) THEN JPRINT(3) = 1 JPRINT(6) = 1 JPRINT(36) = 1 END IF IF(IPRINT.GT.2) THEN JPRINT(8) = 1 JPRINT(12) = 1 JPRINT(46) = 1 END IF IF(IPRINT.GT.3) THEN IF(JPRINT(7).EQ.0) JPRINT(7) = LFNARC IF(JPRINT(9).EQ.0) JPRINT(9) = IFULL IF(JPRINT(13).EQ.0) JPRINT(13) = IFULL JPRINT(14) = 1 IF(JPRINT(15).EQ.0) JPRINT(15) = IFULL IF(JPRINT(16).EQ.0) JPRINT(16) = IFULL IF(JPRINT(17).EQ.0) JPRINT(17) = IFULL IF(JPRINT(18).EQ.0) JPRINT(18) = IFULL IF(JPRINT(19).EQ.0) JPRINT(19) = IFULL IF(JPRINT(20).EQ.0) JPRINT(20) = IFULL IF(JPRINT(21).EQ.0) JPRINT(21) = IFULL IF(JPRINT(24).EQ.0) JPRINT(24) = IFULL IF(JPRINT(29).EQ.0) JPRINT(29) = IFULL IF(JPRINT(31).EQ.0) JPRINT(31) = IFULL IF(JPRINT(32).EQ.0) JPRINT(32) = 1 IF(JPRINT(33).EQ.0) JPRINT(33) = IFULL IF(JPRINT(34).EQ.0) JPRINT(34) = IFULL IF(JPRINT(35).EQ.0) JPRINT(35) = IFULL IF(JPRINT(37).EQ.0) JPRINT(37) = IFULL IF(JPRINT(38).EQ.0) JPRINT(38) = IFULL IF(JPRINT(39).EQ.0) JPRINT(39) = IFULL IF(JPRINT(40).EQ.0) JPRINT(40) = IFULL IF(JPRINT(41).EQ.0) JPRINT(41) = IFULL IF(JPRINT(42).EQ.0) JPRINT(42) = IFULL JPRINT(43) = 1 IF(JPRINT(45).EQ.0) JPRINT(45) = IFULL IF(JPRINT(47).EQ.0) JPRINT(47) = IFULL IF(JPRINT(48).EQ.0) JPRINT(48) = IFULL IF(JPRINT(50).EQ.0) JPRINT(50) = IFULL IF(JPRINT(51).EQ.0) JPRINT(51) = IFULL IF(JPRINT(52).EQ.0) JPRINT(52) = IFULL IF(JPRINT(53).EQ.0) JPRINT(53) = IFULL IF(JPRINT(54).EQ.0) JPRINT(54) = IFULL IF(JPRINT(55).EQ.0) JPRINT(55) = 1 IF(IWTNAB.EQ.0) IWTNAB = IFULL IWDETL = 1 IF(IWDM.NE.0) IWMULP = 2 END IF TURN ON THE NLMO ANALYSIS IF REQUIRED: IF(JPRINT(13).NE.0) JPRINT(8) = 1 IF(JPRINT(15).NE.0) JPRINT(8) = 1 IF(JPRINT(17).NE.0) JPRINT(8) = 1 IF(JPRINT(18).NE.0) JPRINT(8) = 1 IF(JPRINT(23).NE.0) JPRINT(8) = 1 IF(JPRINT(46).NE.0) JPRINT(8) = 1 IF(JPRINT(47).NE.0) JPRINT(8) = 1 IF(JPRINT(48).NE.0) JPRINT(8) = 1 IF(JPRINT(49).NE.0) JPRINT(8) = 1 IF(JPRINT(54).NE.0) JPRINT(8) = 1 TAKE CARE OF THE PLOT OPTION: IF(JPRINT(43).NE.0) THEN JPRINT(8) = 1 IF(JPRINT(22).EQ.0) JPRINT(22) = LFNAO IF(IWTNAO.EQ.0) IWTNAO = -LFNNAO IF(JPRINT(28).EQ.0) JPRINT(28) = -LFNNHO IF(IWTNBO.EQ.0) IWTNBO = -LFNNBO IF(JPRINT(23).EQ.0) JPRINT(23) = -LFNNLM IF(JPRINT(26).EQ.0) JPRINT(26) = -LFNMO IF(JPRINT(27).EQ.0) JPRINT(27) = -LFNDM IF(JPRINT(44).EQ.0) JPRINT(44) = -LFNPNA IF(JPRINT(30).EQ.0) JPRINT(30) = -LFNPNH IF(JPRINT(25).EQ.0) JPRINT(25) = -LFNPNB IF(JPRINT(49).EQ.0) JPRINT(49) = -LFNPNL END IF PRINT HYBRIDS IF THE NBO OUTPUT IS REQUESTED: IWHYBS = JPRINT(5) RETURN ABORT PROGRAM: UNRECOGNIZABLE KEYWORD ENCOUNTERED 4800 WRITE(LFNPR,9800) (KEYWD(I),I=1,6) STOP INCOMPATIBLE JOB OPTIONS HAVE BEEN REQUESTED: 4900 CONTINUE WRITE(LFNPR,9900) STOP 9800 FORMAT(1X,'Error: Unrecognizable keyword >>',6A1,'<<',/,1X, * 'Program must halt.') 9900 FORMAT(1X,'The NBO program must stop because the options /MULAT/', + ' and /MULORB/',/1X,'currently require the AO bond order matrix', + ', rather than the AO density',/1X,'matrix. The program could ', + 'be modified to permit this.') END ***************************************************************************** SUBROUTINE NBODIM(MEMORY) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DIMENSION NSPDFG(5,2) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBBAS/LABEL(MAXBAS,6),LVAL(MAXBAS),IMVAL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) DATA IREAD/4HREAD/ NBODIM: SET UP DIMENSIONING INFORMATION, LISTS IN COMMON/NBATOM/, AND COMPARE STORAGE NEEDS WITH AMOUNT OF STORAGE AVAILABLE FIND: MXAOLM, THE MAXIMUM NUMBER OF ATOMIC ORBITALS OF THE SAME SYMMETRY ON A SINGLE ATOM MXAO, THE MAXIMUM NUMBER OF ATOMIC ORBITALS PER ATOM MXBO, THE MAXIMUM NUMBER OF ATOMIC ORBITALS PER TWO-CENTER OR THREE-CENTER BOND DO 300 I = 1,NBAS LM = LANG(I) LVAL(I) = LM/100 IM = LM - LVAL(I)*100 IF(IM.GT.50) IM = IM - 50 IMVAL(I) = IM 300 CONTINUE MXAO = 0 MXAO2 = 0 MXAO3 = 0 MXAOLM = 0 LLU = 0 DO 500 I = 1,NATOMS N = 0 DO 400 IL = 1,5 DO 400 ITYP = 1,2 400 NSPDFG(IL,ITYP) = 0 DO 410 J = 1,NBAS IF(LCTR(J).NE.I) GO TO 410 LM = LANG(J) L = LM/100 IM = LM - L*100 IF IM.NE.1 (THAT IS, IF THIS IS NOT THE FIRST COMPONENT OF THE ANG. MOM. L FUNCTIONS ON THE ATOM), DON'T COUNT IT IN NSPDFG: IF(IM.NE.1) GO TO 410 ITYP=1 FOR CARTESIAN FUNCTION, =2 FOR TRUE SPHERICAL HARMONIC: ITYP = 1 IF(IM.GT.50) ITYP = 2 IL = L + 1 NSPDFG(IL,ITYP) = NSPDFG(IL,ITYP)+1 410 IF(LCTR(J).EQ.I) N = N + 1 NUMBER OF S ORBITALS= NO. S ORBS INPUT + NO. CARTESIAN D AND G ORBS: NSPDFG(1,1) = NSPDFG(1,1) + NSPDFG(1,2) + NSPDFG(3,1) + + NSPDFG(5,1) NUMBER OF P ORBITALS= NO. P ORBS INPUT + NO. CARTESIAN F ORBS: NSPDFG(2,1) = NSPDFG(2,1) + NSPDFG(2,2) + NSPDFG(4,1) NUMBER OF D ORBITALS= NO. D ORBS INPUT + NO. CARTESIAN G ORBS: NSPDFG(3,1) = NSPDFG(3,1) + NSPDFG(3,2) + NSPDFG(5,1) NUMBER OF F ORBITALS: NSPDFG(4,1) = NSPDFG(4,1) + NSPDFG(4,2) NUMBER OF G ORBITALS: NSPDFG(5,1) = NSPDFG(5,1) + NSPDFG(5,2) DO 430 IL = 1,5 IF(NSPDFG(IL,1).LE.MXAOLM) GO TO 430 MXAOLM = NSPDFG(IL,1) 430 CONTINUE NORBS(I) = N LL(I) = LLU + 1 LU(I) = LL(I) + N - 1 LLU = LU(I) IF(N.LE.MXAO) GO TO 460 MXAO3 = MXAO2 MXAO2 = MXAO MXAO = N GO TO 500 460 IF(N.LE.MXAO2) GO TO 480 MXAO3 = MXAO2 MXAO2 = N GO TO 500 480 IF(N.LE.MXAO3) GO TO 500 MXAO3 = N 500 CONTINUE MXBO = MXAO + MXAO2 IF(IW3C.EQ.1) MXBO = MXBO + MXAO3 COMPUTE STORAGE REQUIREMENTS AND COMPARE WITH AVAILABLE CORE SPACE: STORAGE FOR DENSITY MATRIX (DM) AND TRANSFORMATIONS (T): NEED0 = 2*NDIM*NDIM COMPUTE STORAGE FOR NATURAL POPULATION ANALYSIS: NEED1 = 0 IO = IOINQR(IWTNAO) IF(IO.NE.IREAD.AND..NOT.ORTHO) THEN NEED = NDIM + NDIM + NDIM*NDIM + MXAOLM*MXAOLM + NDIM + + MXAOLM*MXAOLM + MXAOLM*MXAOLM + NDIM + 9*MXAOLM NEED1 = MAX(NEED1,NEED) END IF NEED = NATOMS*NATOMS + NATOMS + NATOMS*NATOMS + NATOMS*NATOMS + + NDIM*NDIM + NDIM NEED1 = MAX(NEED1,NEED) NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM NEED1 = MAX(NEED1,NEED) IF(JPRINT(9).NE.0) THEN NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM*NDIM + NDIM*(NDIM+5) NEED1 = MAX(NEED1,NEED) END IF NEED1 = NEED1 + NEED0 COMPUTE STORAGE FOR NATURAL BOND ORBITAL ANALYSIS: NEED2 = 0 IF(JPRINT(1).EQ.0) THEN IF(IOINQR(IWTNAB).NE.IREAD) THEN NEED = NATOMS*NATOMS + NDIM + 3*NDIM + MXAO*NDIM + NDIM + + MXBO*MXBO + MXBO*MXBO + MXBO + MXBO + MXAO*MXAO + + MXAO*MXAO + MXAO + MXAO + MXAO + NATOMS*NATOMS ELSE NEED = NATOMS*NATOMS + NDIM + 3*NDIM END IF NEED2 = MAX(NEED2,NEED) IF(.NOT.ORTHO) THEN NEED = NATOMS*NATOMS + 4*NDIM*NDIM + MXAO + 3*NDIM NEED2 = MAX(NEED2,NEED) END IF NEED = NATOMS*NATOMS + NDIM + MXAO + NDIM*NDIM + NDIM*NDIM + + NDIM + NDIM NEED2 = MAX(NEED2,NEED) NEED = NATOMS*NATOMS + NDIM + NDIM + NDIM + NDIM*NDIM NEED2 = MAX(NEED2,NEED) IF(JPRINT(36).NE.0) THEN NEED = NATOMS*NATOMS + NDIM + 3*NATOMS + NDIM*NDIM + + NDIM*NDIM + NDIM NEED2 = MAX(NEED2,NEED) END IF NEED = NATOMS*NATOMS + NDIM + NDIM*NDIM + NDIM*NDIM + + NDIM*(NDIM+5) NEED2 = MAX(NEED2,NEED) IF(JPRINT(6).NE.0) THEN NEED = NATOMS*NATOMS + NDIM + NDIM*NDIM + NDIM + NATOMS + + NDIM NEED2 = MAX(NEED2,NEED) END IF COMPUTE STORAGE FOR NATURAL LOCALIZED MOLECULAR ORBITAL ANALYSIS: NEED3 = 0 IF(JPRINT(8).NE.0) THEN NEED = NATOMS*NATOMS + NDIM + NDIM + NDIM*NDIM + NDIM*NDIM NEED3 = MAX(NEED3,NEED) NEED = NDIM + NDIM + NDIM + NATOMS*NATOMS + 2*NATOMS*NATOMS + + NDIM*NATOMS + NDIM*NATOMS*(NATOMS-1)/2 + NDIM*NDIM NEED3 = MAX(NEED3,NEED) NEED = NATOMS*NATOMS + NDIM*NDIM + NDIM*NDIM + NDIM*(NDIM+5) NEED3 = MAX(NEED3,NEED) IF(JPRINT(46).NE.0) THEN NEED = NDIM*NDIM + NDIM*NDIM + NDIM*NDIM + NDIM*NDIM + + NDIM*NDIM + NDIM*NDIM + NDIM + NATOMS*NATOMS NEED3 = MAX(NEED3,NEED) END IF END IF END IF PRINT SCRATCH STORAGE REQUIREMENTS: IF(IPRINT.GE.0) THEN IF(JPRINT(1).EQ.0) THEN IF(JPRINT(8).NE.0) THEN WRITE(LFNPR,3300) NEED1,NEED2,NEED3,MEMORY ELSE NEED3 = 0 WRITE(LFNPR,3200) NEED1,NEED2,MEMORY END IF ELSE NEED2 = 0 NEED3 = 0 WRITE(LFNPR,3100) NEED1,MEMORY END IF END IF IF(NEED1.GT.MEMORY.OR.NEED2.GT.MEMORY.OR.NEED3.GT.MEMORY) GOTO 990 RETURN 990 WRITE(LFNPR,9900) STOP 3100 FORMAT(/1X,'Storage needed:',I6,' in NPA (',I7,' available)') 3200 FORMAT(/1X,'Storage needed:',I6,' in NPA,',I6,' in NBO (',I7, + ' available)') 3300 FORMAT(/1X,'Storage needed:',I6,' in NPA,',I6,' in NBO,',I6, + ' in NLMO (',I7,' available)') 9900 FORMAT(/1X,'*** Not enough core storage is available ***'/) END ************************************************************************** NAO/NBO/NLMO FORMATION ROUTINES: (CALLED BY SR NBO) SUBROUTINE NAODRV(DM,T,A) SUBROUTINE NAOSIM(DM,T,A) SUBROUTINE DMNAO(DM,T,A) SUBROUTINE DMSIM(DM,T,A) SUBROUTINE NBODRV(DM,T,A,MEMORY) ************************************************************************** SUBROUTINE NAODRV(DM,T,A) ************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DRIVER SUBROUTINE TO CALCULATE NATURAL ATOMIC ORBITALS (NAOS) GIVEN 1-PARTICLE DENSITY MATRIX IN AN ARBITRARY ATOM-CENTERED ATOMIC ORBITAL BASIS SET. T = OVERLAP MATRIX FOR THE PRIMITIVE AO BASIS (ON RETURN, THIS IS THE AO TO NAO TRANSFORMATION MATRIX) DM = DENSITY MATRIX IN THE PRIMITIVE AO BASIS (OR BOND-ORDER MATRIX, IF IWDM = 1) THE SPIN NATURE OF DM IS INDICATED BY: ISPIN = 0: SPINLESS (CLOSED SHELL) ISPIN = +2: ALPHA SPIN ISPIN = -2: SPIN (ISPIN IS THE RECIPROCAL OF THE S(Z) QUANTUM NO.) A = SCRATCH STORAGE FROM THE MAIN PROGRAM. THE LOCATION OF A(1) IS IN THE COMMON BLOCK /SCM/ IN THE MAIN PROGRAM, AFTER THE STORAGE FOR THE MATRICES 'S','DM' ('A' IS THE VECTOR WHICH IS PARTITIONED ACCORDING TO THE STORAGE NEEDS OF EACH PROGRAM RUN) ATOM, BASIS, OPTION, NBINFO: COMMON BLOCKS WITH DATA TRANSFERED FROM FROM THE INPUT PROGRAMS. ----------------------------------------------------------------------------- PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(1) CHARACTER*80 TITLE DATA ONE/1.0D0/ DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/ FORM LABELS FOR THE RAW AO BASIS SET: CALL LBLAO COPY THE AO CENTERS AND LABELS FROM /NBAO/ TO /NBBAS/: DO 5 I = 1,NBAS LBL(I) = LCTR(I) LORBC(I) = LANG(I) 5 CONTINUE WRITE OUT THE AO BASIS SET INFORMATION: IF(JPRINT(22).GT.0) THEN CALL WRBAS(A,A,JPRINT(22)) END IF WRITE OUT THE ARCHIVE FILE: IF(JPRINT(7).NE.0) THEN CALL WRARC(A,A,JPRINT(7)) END IF OUTPUT THE AO OVERLAP MATRIX: IO = IOINQR(JPRINT(39)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'AO overlap matrix:' CALL AOUT(T,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(39)) END IF OUTPUT THE AO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(26)) IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN CALL FEAOMO(A,IT) IF(IT.NE.0) THEN TITLE = 'MOs in the AO basis:' CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26)) END IF END IF OUTPUT THE AO FOCK MATRIX: IO = IOINQR(JPRINT(40)) IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN CALL FEFAO(A,IWFOCK) IF(IWFOCK.NE.0) THEN TITLE = 'AO Fock matrix:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40)) END IF END IF OUTPUT THE AO BOND-ORDER MATRIX: IO = IOINQR(JPRINT(42)) IF(IWDM.EQ.1.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN TITLE = 'Spinless AO bond-order matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(42)) END IF CONVERT THE BOND-ORDER MATRIX TO THE DENSITY MATRIX: IF(IWDM.NE.0) CALL SIMTRM(DM,T,A,NDIM,NBAS,IWMULP,IWCUBF) OUTPUT THE AO DENSITY MATRIX: IO = IOINQR(JPRINT(27)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'Spinless AO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27)) END IF OUTPUT THE AO DIPOLE MATRICES: IO = IOINQR(JPRINT(50)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO x dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF IX = 2 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO y dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF IX = 3 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO z dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF END IF ALLOCATE SCRATCH COMMON FOR NAO ROUTINES: A(I1) = V(NDIM) (ALSO USED FOR GUIDE(NATOMS,NATOMS)) A(I2) = RENORM(NDIM) A(I3) = BLK(NDIM,NDIM) A(I4) = SBLK(MXAOLM,MXAOLM) A(I5) = EVAL(NDIM) A(I6) = C(MXAOLM,MXAOLM) A(I7) = EVECT(MXAOLM,MXAOLM) A(I8) = EVAL2(NDIM) LEAVE THIS LAST IN THE LIST SINCE THESE ARE INTEGERS: A(I9) = LISTAO(MXAOLM,9) NBLOCK = MXAOLM*MXAOLM I1 = 1 I2 = I1 + NDIM I3 = I2 + NDIM I4 = I3 + NDIM*NDIM I5 = I4 + NBLOCK I6 = I5 + NDIM I7 = I6 + NBLOCK I8 = I7 + NBLOCK I9 = I8 + NDIM IEND = I9 + 9*MXAOLM READ IN T-NAO, NAO LABELS, THE PNAO OVERLAP MATRIX, AND COMPUTE THE NAO DENSITY MATRIX: (NOTE THAT T CONTAINS THE PNAO OVERLAP MATRIX AFTER RDTNAO IS CALLED) IF(IOINQR(IWTNAO).EQ.IREAD) THEN CALL RDTNAO(DM,T,A(I1),IWTNAO) GO TO 580 END IF TRANSFORM ALL SETS OF CARTESIAN D,F,G ORBITALS, AND RELABEL ALL ORBITALS: CALL DFGORB(A(I2),DM,T,ICTRAN,IWCUBF,0,LFNPR) STORE PURE AO DENSITY MATRIX IN SCRATCH STORAGE: CALL SVPPAO(DM) CONSOLIDATE DENSITY MATRIX AND OVERLAP MATRIX IN DM: CALL CONSOL(DM,T,NDIM,NBAS) FIND NATURAL ATOMIC ORBITAL BASIS SET TRANSFORMATION T FROM DM: (UPON RETURN, DM CONTAINS THE FULL NAO DENSITY MATRIX) CALL NAO(T,DM,A(I1),A(I3),A(I4),A(I5),A(I6),A(I7),A(I8),A(I9), * NBLOCK) IF D ORBITALS WERE TRANSFORMED, TRANSFORM THE NAO TRANSFORMATION T SO THAT T IS THE TRANSFORM FROM THE ORIGINAL AO'S TO THE NAO'S: IF(ICTRAN.NE.0) CALL DFGORB(A(I2),DM,T,IDTRAN,IWCUBF,1,LFNPR) SAVE TNAO FOR LATER USE: CALL SVTNAO(T) IF D ORBITALS WERE TRANSFORMED, TRANSFORM THE PNAO TRANSFORMATION SO THAT IT IS THE TRANSFORM FROM THE ORIGINAL AO'S TO THE PNAO'S: CALL FEPNAO(A(I3)) FOR CASE THAT RPNAOS ARE WRITTEN TO DISK, SET OCCUPANCY WEIGHTS TO -1 AS A SIGNAL THAT THEY SHOULD BE RECOMPUTED: DO 260 I = 0,NBAS-1 260 A(I4+I) = -ONE IF(ICTRAN.NE.0) CALL DFGORB(A(I2),DM,A(I3),IDTRAN,IWCUBF,1,LFNPR) COMPUTE NON-ORTHOGONAL NAO OVERLAP MATRIX, SPNAO: CALL FESRAW(T) CALL SIMTRS(T,A(I3),A(I4),NDIM,NBAS) CALL SVSNAO(T) WRITE T-NAO, NAO LABELS, AND THE PNAO OVERLAP MATRIX: IF(IOINQR(IWTNAO).EQ.IWRIT) CALL WRTNAO(T,IWTNAO) DM IS NOW THE DENSITY MATRIX IN THE NAO BASIS T IS THE NON-ORTHOGONAL PNAO OVERLAP MATRIX (!!!) 580 CONTINUE I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NATOMS I4 = I3 + NATOMS*NATOMS I5 = I4 + NATOMS*NATOMS I6 = I5 + NDIM*NDIM IEND = I6 + NDIM CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6)) DO NOT DESTROY THE MATRIX AT A(I1). THIS HOLDS THE WIBERG BOND INDEX WHICH NEEDS TO BE PASSED TO THE NBO ROUTINES. SAVE THE NAO DENSITY MATRIX: CALL SVDNAO(DM) FORM THE NAO LABELS: CALL LBLNAO REORGANIZE THE SCRATCH VECTOR: I1 = 1 I2 = I1 + NATOMS*NATOMS IEND = I2 + NDIM*NDIM OUTPUT THE AO-PNAO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(44)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEPNAO(T) TITLE = 'PNAOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(44)) END IF OUTPUT THE PNAO OVERLAP MATRIX: IO = IOINQR(JPRINT(19)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FESNAO(A(I2)) TITLE = 'PNAO overlap matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(19)) END IF FETCH THE AO-NAO TRANSFORMATION FROM THE NBO DAF: CALL FETNAO(T) PRINT THE AO-NAO TRANSFORMATION MATRIX: IF(IOINQR(IWTNAO).EQ.IPRNT) THEN TITLE = 'NAOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IWTNAO) END IF OUTPUT THE NAO DIPOLE MATRICES: IO = IOINQR(JPRINT(51)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO x dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51)) END IF IX = 2 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO y dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51)) END IF IX = 3 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO z dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51)) END IF END IF IF THIS IS AN OPEN SHELL WAVEFUNCTION, DON'T DO ANYTHING MORE: IF(OPEN) RETURN OUTPUT THE NAO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(9)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9)) END IF REORGANIZE THE SCRATCH VECTOR: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM IEND = I3 + NDIM OUTPUT THE NAO FOCK MATRIX: IO = IOINQR(JPRINT(31)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31)) END IF END IF OUTPUT THE NAO DENSITY MATRIX: IO = IOINQR(JPRINT(35)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NAO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35)) END IF RETURN END ***************************************************************************** SUBROUTINE NAOSIM(DM,T,A) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1) CHARACTER*80 TITLE DATA ZERO,ONE/0.0D0,1.0D0/ DATA IPRNT,IWRIT/4HPRNT,4HWRIT/ THIS ROUTINE SIMULATES THE ACTION OF THE NAO SUBPROGRAM: FORM LABELS FOR THE RAW AO BASIS SET: CALL LBLAO COPY THE AO CENTERS AND LABELS FROM /NBAO/ TO /NBBAS/: DO 5 I = 1,NBAS LBL(I) = LCTR(I) LORBC(I) = LANG(I) 5 CONTINUE WRITE OUT THE AO BASIS SET INFORMATION: IF(JPRINT(22).GT.0) THEN CALL WRBAS(A,A,JPRINT(22)) END IF WRITE OUT THE ARCHIVE FILE: IF(JPRINT(7).NE.0) THEN CALL WRARC(A,A,JPRINT(7)) END IF OUTPUT THE AO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(26)) IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN CALL FEAOMO(A,IT) IF(IT.NE.0) THEN TITLE = 'MOs in the AO basis:' CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26)) END IF END IF OUTPUT THE AO FOCK MATRIX: IO = IOINQR(JPRINT(40)) IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN CALL FEFAO(A,IWFOCK) IF(IWFOCK.NE.0) THEN TITLE = 'AO Fock matrix:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40)) END IF END IF OUTPUT THE AO DENSITY MATRIX: IO = IOINQR(JPRINT(27)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'Spinless AO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27)) END IF OUTPUT THE AO DIPOLE MATRICES: IO = IOINQR(JPRINT(50)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO x dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF IX = 2 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO y dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF IX = 3 CALL FEDXYZ(A,IX) IF(IX.NE.0) THEN TITLE = 'AO z dipole integrals:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50)) END IF END IF INITIALIZE THE AO TO NAO TRANSFORMATION MATRIX (UNIT MATRIX): DO 20 J = 1,NBAS DO 10 I = 1,NBAS T(I,J) = ZERO 10 CONTINUE T(J,J) = ONE 20 CONTINUE SAVE TNAO FOR LATER USE: CALL SVTNAO(T) FILL ATOMIC ORBITAL INFORMATION LISTS: DO 30 I = 1,NBAS NAOCTR(I) = LCTR(I) NAOL(I) = LANG(I) LSTOCC(I) = 1 30 CONTINUE PERFORM THE NATURAL POPULATION ANALYSIS: (NOTE THAT ROUTINE NAOANL EXPECTS TO FIND THE OVERLAP MATRIX IN T, WHICH IS THE UNIT MATRIX FOR ORTHOGONAL BASIS SETS. UPON RETURN FROM NAOANL, T IS THE AO TO NAO TRANSFORMATION, WHICH IS STILL A UNIT MATRIX): I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NATOMS I4 = I3 + NATOMS*NATOMS I5 = I4 + NATOMS*NATOMS I6 = I5 + NDIM*NDIM IEND = I6 + NDIM CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6)) DO NOT DESTROY THE MATRIX AT A(I1). THIS HOLDS THE WIBERG BOND INDEX WHICH NEEDS TO BE PASSED TO THE NBO ROUTINES. SAVE THE NAO DENSITY MATRIX: CALL SVDNAO(DM) FORM THE NAO LABELS: CALL LBLNAO IF THIS IS AN OPEN SHELL WAVEFUNCTION, DON'T DO ANYTHING MORE: IF(OPEN) RETURN OUTPUT THE NAO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(9)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9)) END IF REORGANIZE THE SCRATCH VECTOR: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM IEND = I3 + NDIM OUTPUT THE NAO FOCK MATRIX: IO = IOINQR(JPRINT(31)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31)) END IF END IF OUTPUT THE NAO DENSITY MATRIX: IO = IOINQR(JPRINT(35)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NAO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35)) END IF RETURN END ************************************************************************** SUBROUTINE DMNAO(DM,T,A) ************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1) CHARACTER*80 TITLE DATA IPRNT,IWRIT/4HPRNT,4HWRIT/ PLACE ALPHA OR BETA OCCUPATION MATRIX IN DM AND TRANSFORM FROM THE AO TO NAO BASIS: IF(ALPHA) THEN IF(JPRINT(4).NE.0) WRITE(LFNPR,2100) ELSE DO 70 I = 1,NBAS NAOCTR(I) = NAOC(I) NAOL(I) = NAOA(I) LBL(I) = LCTR(I) LORBC(I) = LANG(I) 70 CONTINUE CALL FETNAO(T) IF(JPRINT(4).NE.0) WRITE(LFNPR,2200) END IF OUTPUT THE AO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(26)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEAOMO(A,IT) IF(IT.NE.0) THEN TITLE = 'MOs in the AO basis:' CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26)) END IF END IF OUTPUT THE AO FOCK MATRIX: IO = IOINQR(JPRINT(40)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A,IWFOCK) IF(IWFOCK.NE.0) THEN TITLE = 'AO Fock matrix:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40)) END IF END IF FETCH ALPHA OR BETA DM (ACCORDING TO WHETHER ALPHA OR BETA IS TRUE): CALL FEDRAW(DM,A) OUTPUT THE AO BOND-ORDER MATRIX: IO = IOINQR(JPRINT(42)) IF(IWDM.NE.0.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN TITLE = 'AO bond-order matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(42)) END IF CONVERT THE BOND-ORDER MATRIX TO THE DENSITY MATRIX: IF(IWDM.NE.0) THEN I1 = 1 I2 = I1 + NDIM*NDIM IEND = I2 + NDIM*NDIM CALL FESRAW(A(I1)) CALL SIMTRM(DM,A(I1),A(I2),NDIM,NBAS,IWMULP,IWCUBF) END IF OUTPUT THE AO DENSITY MATRIX: IO = IOINQR(JPRINT(27)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'AO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27)) END IF TRANSFORM DM TO THE NAO BASIS: CALL SIMTRS(DM,T,A,NDIM,NBAS) SAVE THE NAO DENSITY MATRIX IN SCRATCH STORAGE: CALL SVDNAO(DM) PRINT THE NATURAL POPULATION ANALYSIS FOR THIS SPIN CASE: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NATOMS I4 = I3 + NATOMS*NATOMS I5 = I4 + NATOMS*NATOMS I6 = I5 + NDIM*NDIM IEND = I6 + NDIM CALL FESNAO(T) CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6)) NOTE: DO NOT DESTROY THE WIBERG BOND INDEX WHICH IS STORED IN THE FIRST NATOMS*NATOMS ELEMENTS OF THE SCRATCH VECTOR A. THIS IS MATRIX IS REQUIRED FOR THE NBO ANALYSIS: NOTE THAT T IS NOW T-AO-NAO: FORM THE NAO LABELS: CALL LBLNAO OUTPUT THE NAO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(9)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9)) END IF REORGANIZE THE SCRATCH VECTOR: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM IEND = I3 + NDIM OUTPUT THE NAO FOCK MATRIX: IO = IOINQR(JPRINT(31)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31)) END IF END IF OUTPUT THE NAO DENSITY MATRIX: IO = IOINQR(JPRINT(35)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NAO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35)) END IF RETURN 2100 FORMAT(//1X, * '***************************************************',/1X, * '******* Alpha spin orbitals *******',/1X, * '***************************************************') 2200 FORMAT(//1X, * '***************************************************',/1X, * '******* Beta spin orbitals *******',/1X, * '***************************************************') END ************************************************************************** SUBROUTINE DMSIM(DM,T,A) ************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1) CHARACTER*80 TITLE DATA IPRNT,IWRIT/4HPRNT,4HWRIT/ SIMULATE THE ALPHA/BETA NAO SUBPROGRAM: IF(ALPHA) THEN IF(JPRINT(4).NE.0) WRITE(LFNPR,2100) ELSE DO 70 I = 1,NBAS NAOCTR(I) = NAOC(I) NAOL(I) = NAOA(I) LBL(I) = LCTR(I) LORBC(I) = LANG(I) 70 CONTINUE CALL FETNAO(T) IF(JPRINT(4).NE.0) WRITE(LFNPR,2200) END IF OUTPUT THE AO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(26)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEAOMO(A,IT) IF(IT.NE.0) THEN TITLE = 'MOs in the AO basis:' CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26)) END IF END IF OUTPUT THE AO FOCK MATRIX: IO = IOINQR(JPRINT(40)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A,IWFOCK) IF(IWFOCK.NE.0) THEN TITLE = 'AO Fock matrix:' CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40)) END IF END IF FETCH ALPHA OR BETA DM (ACCORDING TO WHETHER ALPHA OR BETA IS TRUE): CALL FEDRAW(DM,A) OUTPUT THE AO DENSITY MATRIX: IO = IOINQR(JPRINT(27)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'AO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27)) END IF SAVE THE NAO DENSITY MATRIX IN SCRATCH STORAGE: CALL SVDNAO(DM) PRINT THE NATURAL POPULATION ANALYSIS FOR THIS SPIN CASE: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NATOMS I4 = I3 + NATOMS*NATOMS I5 = I4 + NATOMS*NATOMS I6 = I5 + NDIM*NDIM IEND = I6 + NDIM CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6)) NOTE: DO NOT DESTROY THE WIBERG BOND INDEX WHICH IS STORED IN THE FIRST NATOMS*NATOMS ELEMENTS OF THE SCRATCH VECTOR A. THIS IS MATRIX IS REQUIRED FOR THE NBO ANALYSIS: FORM THE NAO LABELS: CALL LBLNAO OUTPUT THE NAO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(9)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9)) END IF REORGANIZE THE SCRATCH VECTOR: I1 = 1 I2 = I1 + NATOMS*NATOMS I3 = I2 + NDIM*NDIM IEND = I3 + NDIM OUTPUT THE NAO FOCK MATRIX: IO = IOINQR(JPRINT(31)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NAO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31)) END IF END IF PRINT THE NAO DENSITY MATRIX: IO = IOINQR(JPRINT(35)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NAO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35)) END IF RETURN 2100 FORMAT(//1X, * '***************************************************',/1X, * '******* Alpha spin orbitals *******',/1X, * '***************************************************') 2200 FORMAT(//1X, * '***************************************************',/1X, * '******* Beta spin orbitals *******',/1X, * '***************************************************') END ************************************************************************** SUBROUTINE NBODRV(DM,T,A,MEMORY) ************************************************************************** DRIVER SUBROUTINE TO CALCULATE NATURAL HYBRID ORBITALS (NHOS) AND NATURAL BOND ORBITALS (NBOS) FROM THE DENSITY MATRIX IN THE NAO BASIS T = SCRATCH STORAGE DM = NAO DENSITY MATRIX THE SPIN NATURE OF DM IS INDICATED BY: ISPIN = 0: SPINLESS (CLOSED SHELL) ISPIN = +2: ALPHA SPIN ISPIN = -2: SPIN (ISPIN IS THE RECIPROCAL OF THE S(Z) QUANTUM NO.) A = SCRATCH STORAGE FROM THE MAIN PROGRAM. THE LOCATION OF A(1) IS IN THE COMMON BLOCK /SCM/ IN THE MAIN PROGRAM, AFTER THE STORAGE FOR THE MATRICES 'S','DM' ('A' IS THE VECTOR WHICH IS PARTITIONED ACCORDING TO THE STORAGE NEEDS OF EACH PROGRAM RUN) ATOM, BASIS, OPTION, NBINFO: COMMON BLOCKS WITH DATA TRANSFERED FROM FROM THE INPUT PROGRAMS. ----------------------------------------------------------------------------- IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*80 TITLE PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM), + NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM) COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(1) DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/ DATA ZERO/0.0D0/ SKIP NBO TRANSFORMATION IF REQUESTED: IF(JPRINT(1).GT.0) THEN WRITE(LFNPR,2000) RETURN END IF ORGANIZE SCRATCH STORAGE VECTOR A. WARNING: THIS IS REDEFINED SEVERAL TIMES AFTER THE NBOS ARE FORMED A(I0) = GUIDE(NATOMS,NATOMS) A(I1) = BNDOCC(NDIM) A(I2) = POL(NDIM,3) A(I3) = Q(MXAO,NDIM) A(I4) = V(NDIM) A(I5) = BLK(MXBO,MXBO) A(I6) = C(MXBO,MXBO) A(I7) = EVAL(MXBO) A(I8) = BORB(MXBO) A(I9) = P(MXAO,MXAO) A(I10) = PK(MXAO,MXAO) A(I11) = HYB(MXAO) A(I12) = VA(MXAO) A(I13) = VB(MXAO) I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + 3*NDIM I4 = I3 + MXAO*NDIM I5 = I4 + NDIM I6 = I5 + MXBO*MXBO I7 = I6 + MXBO*MXBO I8 = I7 + MXBO I9 = I8 + MXBO I10 = I9 + MXAO*MXAO I11 = I10 + MXAO*MXAO I12 = I11 + MXAO I13 = I12 + MXAO I14 = I13 + MXAO IEND = I14 + NATOMS*NATOMS IF(JPRINT(5).NE.0.AND.ISPIN.EQ.0) WRITE(LFNPR,1400) IF(JPRINT(5).NE.0.AND.ISPIN.EQ.2) WRITE(LFNPR,1410) IF(JPRINT(5).NE.0.AND.ISPIN.EQ.-2) WRITE(LFNPR,1420) READ IN T-NAB, LABEL, IBXM, TRANSFORM DM, AND FIND BNDOCC IF IWTNAB=IREAD: IF(IOINQR(IWTNAB).EQ.IREAD) THEN CALL RDTNAB(T,DM,A(I1),A(I2),IWTNAB) ELSE SEARCH INPUT FILE FOR $CORE INPUT: IF(.NOT.BETA) THEN CALL CORINP(JPRINT(2),JCORE) CALL RDCORE(JCORE) END IF SEARCH INPUT FILE FOR $CHOOSE INPUT: IF(.NOT.BETA) THEN CALL CHSINP(JPRINT(2),ICHOOS) IF(OPEN.AND.ICHOOS.EQ.1.AND.JPRINT(32).NE.0) THEN WRITE(LFNPR,1390) ICHOOS = 0 END IF END IF CALCULATE NATURAL HYBRID ORBITALS AND BOND ORBITALS: IF(ICHOOS.NE.1) CALL NATHYB(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4), + A(I5),A(I6),A(I7),A(I8),A(I9),A(I10), + A(I11),A(I12),A(I13),A(I14)) IF(ICHOOS.EQ.1) CALL CHSDRV(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4), + A(I5),A(I6),A(I7),A(I8),A(I9),A(I10), + A(I11),A(I12),A(I13),A(I14)) IF NBO SEARCH WAS ABANDONED, DON'T TRY TO DO ANYTHING FURTHER: IF(JPRINT(1).LT.0) RETURN SORT THE NBOS BY ATOM: CALL SRTNBO(T,A(I1)) FORM THE NBO DENSITY MATRIX: CALL SIMTRS(DM,T,A(I2),NDIM,NBAS) CHECK NHO OVERLAPS TO SEE IF BOND ORBITALS SHOULD BE RELABELLED: IF(.NOT.ORTHO) THEN I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + MXAO I4 = I3 + NDIM*NDIM I5 = I4 + NDIM*NDIM I6 = I5 + NDIM IEND = I6 + NDIM CALL XCITED(DM,T,A(I2),A(I3),A(I4),A(I5),A(I6),A(I6)) END IF END IF T NOW CONTAINS THE NAO-NBO TRANSFORMATION MATRIX DM NOW CONTAINS THE NBO DENSITY MATRIX A(I0) CONTAINS THE WIBERG BOND INDEX MATRIX ! DON'T DESTROY THIS A(I1) CONTAINS THE NBO OCCUPANCIES ! DON'T DESTROY THIS A(I2) IS SCRATCH SPACE SAVE THE NAO-NBO TRANSFORMATION ON THE NBO DAF: CALL SVTNAB(T) FORM THE NBO LABELS: CALL LBLNBO WRITE OUT THE ANALYSIS OF BOND ORBITALS: I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + NDIM I4 = I3 + NDIM IEND = I4 + NDIM*NDIM CALL ANLYZE(T,A(I1),A(I2),A(I3),A(I4)) WRITE OUT HYBRID DIRECTIONALITY AND BOND BENDING INFO: IF(JPRINT(36).NE.0) THEN I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + 3*NATOMS I4 = I3 + NDIM*NDIM I5 = I4 + NDIM*NDIM IEND = I5 + NDIM CALL HYBDIR(A(I1),A(I2),A(I3),A(I4),A(I5)) END IF FIND MOLECULAR UNITS: CALL FNDMOL(A(I2)) CLASSIFY ALL THE NBOS ACCORDING TO DONOR/ACCEPTOR TYPE: CALL NBOCLA(A(I1),ACCTHR) OUTPUT TRANSFORMATION MATRICES FOR THE PNHO AND NHO BASIS SETS, AND THE NHO DENSITY MATRIX, NHO FOCK MATRIX, AND NHO DIPOLE MATRICES: THE SECTION OF THE CODE MAKES USE OF T AND DM. THESE MATRICES WILL BE RESTORED LATER: [NOTE: DO NOT DESTROY INFO ALREADY STORED IN A(I0) AND A(I1)] REORGANIZE THE SCRATCH VECTOR: I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) OUTPUT THE AO-PNHO TRANSFORMATION AND THE PNHO OVERLAP MATRIX: IO = IOINQR(JPRINT(20)) JO = IOINQR(JPRINT(30)) IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR. + (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN CALL FEPNAO(T) CALL FETNHO(A(I2)) CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS) CALL FESRAW(A(I2)) CALL NORMLZ(T,A(I2),NDIM,NBAS) IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN TITLE = 'PNHOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(30)) END IF IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'PNHO overlap matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(20)) END IF ENDIF FORM THE AO-NHO TRANSFORMATION MATRIX: CALL FETNAO(T) CALL FETNHO(A(I2)) CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS) OUTPUT THE AO-NHO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(28)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NHOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(28)) END IF OUTPUT THE NAO-NHO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(33)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FETNHO(A(I2)) TITLE = 'NHOs in the NAO basis:' CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,2,JPRINT(33)) END IF OUTPUT THE NHO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(38)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FRMTMO(T,A(I2),A(I3),A(I4),3,JPRINT(38)) END IF OUTPUT THE NHO DENSITY MATRIX: IO = IOINQR(JPRINT(34)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEDRAW(DM,A(I2)) IF(IWDM.EQ.1) THEN CALL FESRAW(A(I2)) CALL SIMTRS(DM,A(I2),A(I3),NDIM,NBAS) END IF CALL SIMTRS(DM,T,A(I2),NDIM,NBAS) TITLE = 'NHO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,3,JPRINT(34)) END IF OUTPUT THE NHO FOCK MATRIX: IO = IOINQR(JPRINT(29)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NHO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(29)) END IF END IF OUTPUT THE NHO DIPOLE MATRICES: IO = IOINQR(JPRINT(52)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NHO x dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52)) END IF IX = 2 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NHO y dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52)) END IF IX = 3 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NHO z dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52)) END IF END IF OUTPUT TRANSFORMATION MATRICES FOR THE PNBO AND NBO BASIS SETS, AND THE NBO DENSITY MATRIX, NBO FOCK MATRIX, AND NBO DIPOLE MATRICES: [NOTE: DO NOT DESTROY INFO ALREADY STORED IN A(I0) AND A(I1)] REORGANIZE THE SCRATCH VECTOR: I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM IEND = I4 + NDIM*(NDIM+5) OUTPUT THE AO-PNBO TRANSFORMATION AND THE PNBO OVERLAP MATRIX: IO = IOINQR(JPRINT(21)) JO = IOINQR(JPRINT(25)) IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR. + (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN CALL FEPNAO(T) CALL FETNAB(A(I2)) CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS) CALL FESRAW(A(I2)) CALL NORMLZ(T,A(I2),NDIM,NBAS) IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN TITLE = 'PNBOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(25)) END IF IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'PNBO overlap matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(21)) END IF END IF FORM THE AO-NBO TRANSFORMATION MATRIX: CALL FETNAO(T) CALL FETNAB(A(I2)) CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS) SAVE THE AO-NBO TRANSFORMATION, NBO OCCS, AND NBO LABELS ON NBO DAF: CALL SVNBO(T,A(I1),A(I2)) WRITE THE AO-NBO TRANSFORMATION WITH NBO LABELS AND OCCUPANCIES: IF(IOINQR(IWTNBO).EQ.IWRIT) CALL WRTNBO(T,A(I1),IWTNBO) PRINT THE AO-NBO TRANSFORMATION MATRIX: IF(IOINQR(IWTNBO).EQ.IPRNT) THEN TITLE = 'NBOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IWTNBO) END IF WRITE THE NAO-NBO TRANSFORMATION MATRIX: IF(IOINQR(IWTNAB).EQ.IWRIT) THEN CALL FETNAB(A(I2)) CALL WRTNAB(A(I2),IWTNAB) END IF PRINT THE NAO-NBO TRANSFORMATION TO THE OUTPUT FILE: IF(IOINQR(IWTNAB).EQ.IPRNT) THEN CALL FETNAB(A(I2)) TITLE = 'NBOs in the NAO basis:' CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,2,IWTNAB) END IF OUTPUT THE NHO-NBO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(41)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FETNHO(A(I2)) CALL TRANSP(A(I2),NDIM,NBAS) CALL FETNAB(A(I3)) CALL MATMLT(A(I2),A(I3),A(I4),NDIM,NBAS) TITLE = 'NBOs in the NHO basis:' CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,3,JPRINT(41)) END IF OUTPUT THE NBO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(45)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FRMTMO(T,A(I2),A(I3),A(I4),4,JPRINT(45)) END IF FORM THE NBO DENSITY MATRIX: CALL FEDRAW(DM,A(I2)) IF(IWDM.EQ.1.AND..NOT.ORTHO) THEN CALL FESRAW(A(I2)) CALL SIMTRS(DM,A(I2),A(I3),NDIM,NBAS) END IF CALL SIMTRS(DM,T,A(I2),NDIM,NBAS) OUTPUT THE NBO DENSITY MATRIX: IO = IOINQR(JPRINT(16)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NBO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,4,JPRINT(16)) END IF OUTPUT THE NBO FOCK MATRIX: CALL FEFAO(A(I2),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) CALL SVFNBO(A(I2)) IO = IOINQR(JPRINT(37)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NBO Fock matrix:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(37)) END IF END IF OUTPUT THE NBO DIPOLE MATRICES: IO = IOINQR(JPRINT(53)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NBO x dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53)) END IF IX = 2 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NBO y dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53)) END IF IX = 3 CALL FEDXYZ(A(I2),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS) TITLE = 'NBO z dipole integrals:' CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53)) END IF END IF PERFORM PERTURBATIVE ANALYSIS OF THE NBO FOCK MATRIX: IF(JPRINT(3).EQ.1.AND.IWFOCK.NE.0) CALL FNBOAN(A(I1),A(I2),A(I3)) PRINT THE NBO SUMMARY: IF(JPRINT(6).EQ.1) THEN I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + NDIM I3 = I2 + NDIM*NDIM I4 = I3 + NDIM I5 = I4 + NATOMS IEND = I5 + NDIM CALL NBOSUM(A(I2),A(I1),A(I3),A(I4),A(I5)) END IF CONTINUE WITH THE CONSTRUCTION OF THE NLMOS: IF(JPRINT(8).NE.0) THEN STORE IN A(I0) THE VECTOR RESON(NDIM), THE SQUARES OF THE DIAGONAL ELEMENTS OF THE NBO TO NLMO TRANSFORMATION MATRIX. IALARM SOUNDS THE ALARM THAT THE NLMO STEP IS TO BE SKIPPED: DM : NBO DENSITY ! TRANSFORMED TO NLMO BASIS ON RETURN A(I0): RESON(NDIM) ! PERCENTAGES OF PARENT NBO A(I1): LMOOCC(NDIM) ! NLMO OCCUPANCIES A(I2): TNLMO(NDIM,NDIM) ! NBO-NLMO TRANSFORM A(I3): TSYM ! SCRATCH (DO NOT DESTROY THE WIBERG BOND INDEX!) I0 = 1 + NATOMS*NATOMS I1 = I0 + NDIM I2 = I1 + NDIM I3 = I2 + NDIM*NDIM IEND = I3 + NDIM*NDIM CALL NLMO(NBAS,DM,A(I1),A(I2),A(I3),A(I0),NOCC,IALARM) IF(IALARM.NE.0) RETURN SAVE THE NBO TO NLMO TRANSFORMATION MATRIX ON THE NBO DAF: CALL SVTLMO(A(I2)) FORM THE NAO TO NLMO TRANSFORMATION IN T: CALL FETNAB(T) CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS) SET UP STORAGE FOR LMOANL: A(I0): RESON(NDIM) A(I1): LMOOCC(NDIM) A(I2): TS(NDIM) A(I3): BORDER(NATOMS,NATOMS) A(I4): OWBORD(NATOMS,NATOMS) A(I5): ATLMO(NOCC,NATOMS) A(I6): SIAB(NOCC,NAB) (DO NOT DESTROY THE WIBERG BOND INDEX!) NAB = NATOMS*(NATOMS-1)/2 IF(NATOMS.EQ.1) NAB = 1 I0 = 1 + NATOMS*NATOMS I1 = I0 + NDIM I2 = I1 + NDIM I3 = I2 + NDIM I4 = I3 + NATOMS*NATOMS I5 = I4 + NATOMS*NATOMS I6 = I5 + NOCC*NATOMS I7 = I6 + NOCC*NAB IEND = I7 + NDIM*NDIM CALL COPY(DM,A(I7),NDIM,NBAS,NBAS) CALL LMOANL(T,A(I7),A(I0),A(I1),A(I2),A(I3),A(I4),A(I5), + A(I6),NOCC,NAB) OUTPUT TRANSFORMATION MATRICES FOR THE PNLMO AND NLMO BASIS SETS, AND THE NLMO DENSITY MATRIX, NLMO FOCK MATRIX, AND NLMO DIPOLE MATRICES: REORGANIZE THE SCRATCH VECTOR: (DO NOT DESTROY THE WIBERG BOND INDEX!) I0 = 1 + NATOMS*NATOMS I1 = I0 + NDIM*NDIM I2 = I1 + NDIM*NDIM IEND = I2 + NDIM*(NDIM+5) OUTPUT THE AO-PNLMO TRANSFORMATION AND THE PNLMO OVERLAP MATRIX: IO = IOINQR(JPRINT(48)) JO = IOINQR(JPRINT(49)) IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR. + (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN CALL FEPNAO(T) CALL FETNAB(A(I0)) CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS) CALL FETLMO(A(I0)) CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS) CALL FESRAW(A(I0)) CALL NORMLZ(T,A(I0),NDIM,NBAS) IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN TITLE = 'PNLMOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(49)) END IF IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS) TITLE = 'PNLMO overlap matrix:' CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(48)) END IF END IF FORM THE AO-NLMO TRANSFORMATION MATRIX: CALL FETNAO(T) CALL FETNAB(A(I0)) CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS) CALL FETLMO(A(I0)) CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS) SAVE THE AO-NLMO TRANSFORMATION ON NBO DAF: CALL SVNLMO(T) WRITE OUT THE AO-NLMO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(23)) IF(IO.EQ.IWRIT) CALL WRNLMO(T,DM,JPRINT(23)) PRINT THE AO-NLMO TRANSFORMATION MATRIX: IF(IO.EQ.IPRNT) THEN TITLE = 'NLMOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(23)) END IF OUTPUT THE NAO-NLMO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(18)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FETNAB(A(I0)) CALL FETLMO(A(I1)) CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS) TITLE = 'NLMOs in the NAO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,2,JPRINT(18)) END IF OUTPUT THE NHO-NLMO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(24)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FETNHO(A(I0)) CALL TRANSP(A(I0),NDIM,NBAS) CALL FETNAB(A(I1)) CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS) CALL FETLMO(A(I1)) CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS) TITLE = 'NLMOs in the NHO basis:' CALL AOUT(A(I0),NDIM,NBAS,NBAS,TITLE,3,JPRINT(24)) END IF OUTPUT THE NBO-NLMO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(47)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FETLMO(A(I0)) TITLE = 'NLMOs in the NBO basis:' CALL AOUT(A(I0),NDIM,NBAS,NBAS,TITLE,4,JPRINT(47)) END IF OUTPUT THE NLMO-MO TRANSFORMATION MATRIX: IO = IOINQR(JPRINT(13)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FRMTMO(T,A(I0),A(I1),A(I2),5,JPRINT(13)) END IF OUTPUT THE NLMO DENSITY MATRIX: IO = IOINQR(JPRINT(17)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN TITLE = 'NLMO density matrix:' CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,5,JPRINT(17)) END IF OUTPUT THE NLMO FOCK MATRIX: IO = IOINQR(JPRINT(15)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN CALL FEFAO(A(I0),IWFOCK) IF(IWFOCK.NE.0) THEN CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS) TITLE = 'NLMO Fock matrix:' CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(15)) END IF END IF OUTPUT THE NLMO DIPOLE MATRICES: IO = IOINQR(JPRINT(54)) IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN IX = 1 CALL FEDXYZ(A(I0),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS) TITLE = 'NLMO x dipole integrals:' CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54)) END IF IX = 2 CALL FEDXYZ(A(I0),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS) TITLE = 'NLMO y dipole integrals:' CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54)) END IF IX = 3 CALL FEDXYZ(A(I0),IX) IF(IX.NE.0) THEN CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS) TITLE = 'NLMO z dipole integrals:' CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54)) END IF END IF PERFORM THE NBO/NLMO DIPOLE MOMENT ANALYSIS: DM : NLMO DENSITY MATRIX T : AO-NLMO TRANSFORMATION MATRIX A(I1): C(NDIM,NDIM) A(I2): TNBO(NDIM,NDIM) A(I3): DX(NDIM,NDIM) A(I4): DY(NDIM,NDIM) A(I5): DZ(NDIM,NDIM) A(I6): SCR(NDIM,NDIM) A(I7): INDEX(NDIM) (DO NOT DESTROY THE WIBERG BOND INDEX!) IF(JPRINT(46).NE.0) THEN I1 = 1 + NATOMS*NATOMS I2 = I1 + NDIM*NDIM I3 = I2 + NDIM*NDIM I4 = I3 + NDIM*NDIM I5 = I4 + NDIM*NDIM I6 = I5 + NDIM*NDIM I7 = I6 + NDIM*NDIM IEND = I7 + NDIM CALL DIPANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6),A(I7)) END IF END IF PERFORM NATURAL RESONANCE THEORY ANALYSIS: IF(JPRINT(32).NE.0) THEN CAREFULLY DETERMINE THE MAXIMUM NUMBER OF RESONANCE STRUCTURES (MAXRES) THAT THE SCRATCH VECTOR CAN ACCOMODATE. ASSUME THAT THERE WILL BE ROUGHLY 6(=NEL) ELEMENTS REQUIRED PER ATOM TO STORE THE TOPO MATRICES FOR EACH RESONANCE STRUCTURE: (1 FOR NUMBER OF BONDS, 1 FOR NUMBER OF LONE PAIRS, AND 4 BONDED ATOMS -- SEE SR TOPSTR) NEL = 6 TOT = ZERO DO 80 IBAS = 1,NBAS TOT = TOT + DM(IBAS,IBAS) 80 CONTINUE NELEC = NINT(TOT) NLOW = NATOMS*(NATOMS-1)/2 MAXREF = MAX(JPRINT(56),1) CAREFULLY DETERMINE THE MAXIMUM NUMBER OF RESONANCE STRUCTURES (MAXRES) WHICH THE SCRATCH VECTOR CAN ACCOMODATE. ASSUME NDIM IS LARGER THAN MAXRES (THIS IS NOT USUALLY THE CASE): IC = NDIM*NDIM + 4*NDIM + MXAO*NDIM + NDIM + MXBO*MXBO + + MXBO*MXBO + MXBO + MXBO + MXAO*MXAO + MXAO*MXAO + + MXAO + MXAO + MXAO + NATOMS*NATOMS + NDIM*MAXREF + + NDIM*NDIM + MAXREF + MAXREF + NDIM*MAXREF + NDIM + + NDIM*NDIM + NDIM*NDIM + NDIM*NDIM + NATOMS*NATOMS + + MAXREF - MEMORY IB = NDIM*MAXREF + 6*MAXREF + NLOW*MAXREF + 9 + NATOMS*NEL IA = 0 MAXRES = INT(-IC / IB) CHECK THIS ASSUMPTION: IF(MAXRES.GT.NDIM) THEN IC = IC - NDIM*NDIM - NDIM*NDIM IA = 2 DET = SQRT(REAL(IB * IB - 4 * IA * IC)) MAXRES = INT((-REAL(IB) + DET) / REAL(2 * IA)) END IF IF(MAXRES.GT.NDIM*NDIM) THEN IC = IC - NDIM*NDIM IB = IB + 1 IA = 2 DET = SQRT(REAL(IB * IB - 4 * IA * IC)) MAXRES = INT((-REAL(IB) + DET) / REAL(2 * IA)) END IF LEN = NEL * NATOMS * MAXRES PARTITION THE SCRATCH VECTOR: I0 = 1 I1 = I0 + NATOMS*NATOMS I2 = I1 + MAXRES*MAXREF I3 = I2 + MAXRES*MAXREF I4 = I3 + MAXREF MEM = MEMORY - I4 + 1 CALL NRTDRV(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4),MAXRES,MAXREF, + NLOW,LEN,NELEC,MEM) END IF RETURN 1390 FORMAT(/1X,'WARNING: The $CHOOSE keylist is incompatible with ', + 'the NRT analysis for open',/1X,' shell NBO analyses.', + ' Program execution will continue, ignoring the',/1X,' ', + ' $CHOOSE keylist.') 1400 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS:') 1410 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS,', * ' alpha spin orbitals:') 1420 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS,', * ' beta spin orbitals:') 2000 FORMAT(//1X,'NBO analysis skipped by request.') END ***************************************************************************** ROUTINES CALLED BY THE NAO DRIVERS: SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF) SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF) SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR) SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK) SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO) SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG) ***************************************************************************** SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SIMILARITY TRANSFORM A ==> S(TRANSPOSE)*A*S, USING SCRATCH VECTOR V. WRITE THE DIAGONAL ELEMENTS OF A*S BY CALLING SUBROUTINE MULANA IF IWMULP.NE.0 (THESE ARE THE MULLIKEN POPULATIONS IF S= OVERLAP MATRIX AND A= BOND-ORDER MATRIX) DIMENSION A(NDIM,NDIM),S(NDIM,NDIM),V(1) CALL MATMLT(A,S,V,NDIM,N) I1=NDIM+1 IF(IWMULP.NE.0) CALL MULANA(A,V(1),V(I1),IWMULP,IWCUBF) CALL MATML2(S,A,V,NDIM,N) RETURN END ***************************************************************************** SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PERFORM MAYER-MULLIKEN BOND ORDER ANALYSIS PRINT OUT DIAGONAL ELEMENTS OF BS=B*S, WHERE B= BOND-ORDER MATRIX, S= OVERLAP MATRIX, BOTH IN ORIGINAL AO BASIS THIS CONSTITUTES A MULLIKEN POPULATION ANALYSIS. PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION BS(NDIM,NDIM),VMAYER(NATOMS),BMAYER(NATOMS,NATOMS), * IANG(5),ANGL(60),LANG(60),CUBICF(7) CHARACTER*80 TITLE DATA IANG/'s','p','d','f','g'/ DATA LANG/ 51,151,152,153,251,252,253,254,255, * 351,352,353,354,355,356,357, * 451,452,453,454,455,456,457,458,459, * 1,101,102,103,201,202,203,204,205,206, * 301,302,303,304,305,306,307,308,309,310, * 401,402,403,404,405,406,407,408,409,410, * 411,412,413,414,415/ DATA ANGL/4H ,4Hx ,4Hy ,4Hz ,4Hxy ,4Hxz ,4Hyz , * 4Hx2y2,4Hz2 ,4H(0) ,4H(c1),4H(s1),4H(c2),4H(s2),4H(c3), * 4H(s3),4H(0) ,4H(c1),4H(s1),4H(c2),4H(s2),4H(c3),4H(s3), * 4H(c4),4H(s4), * 4H ,4Hx ,4Hy ,4Hz ,4Hxx ,4Hxy ,4Hxz , * 4Hyy ,4Hyz ,4Hzz ,4Hxxx ,4Hxxy ,4Hxxz ,4Hxyy ,4Hxyz , * 4Hxzz ,4Hyyy ,4Hyyz ,4Hyzz ,4Hzzz ,4Hxxxx,4Hxxxy,4Hxxxz, * 4Hxxyy,4Hxxyz,4Hxxzz,4Hxyyy,4Hxyyz,4Hxyzz,4Hxzzz,4Hyyyy, * 4Hyyyz,4Hyyzz,4Hyzzz,4Hzzzz/ DATA CUBICF/4H(d1),4H(d2),4H(d3),4H(b) ,4H(e1),4H(e2),4H(e3)/ DATA ZERO/0.0D0/ IF(IWCUBF.EQ.0) GO TO 20 IF THE F FUNCTIONS ARE A CUBIC SET, INSERT THE PROPER LABELS: DO 10 I=1,7 II=I+9 10 ANGL(II)=CUBICF(I) 20 CONTINUE IF(IWMULP.EQ.1) WRITE(LFNPR,1000) IF(IWMULP.EQ.2) WRITE(LFNPR,1100) IF(IWMULP.EQ.2) WRITE(LFNPR,1200) SUMT=ZERO DO 100 I=1,NATOMS VMAYER(I)=ZERO DO 100 J=1,NATOMS 100 BMAYER(I,J)=ZERO DO 300 IAT=1,NATOMS IZ=IATNO(IAT) NAM=NAMEAT(IZ) SUMAT=ZERO DO 200 I=1,NBAS IF(LBL(I).NE.IAT) GO TO 200 LM=LORBC(I) L=LM/100 IL=IANG(L+1) DO 130 ILM=1,60 IF(LM.EQ.LANG(ILM)) GO TO 140 130 CONTINUE STOP 140 CONTINUE OCC=BS(I,I) SUMAT=SUMAT+OCC IF(IWMULP.EQ.2) WRITE(LFNPR,1300) I,NAM,IAT,IL,ANGL(ILM),OCC DO 180 J=1,NBAS JAT=LBL(J) IF(JAT.EQ.IAT) GO TO 180 BMAYER(IAT,JAT)=BMAYER(IAT,JAT)+BS(I,J)*BS(J,I) 180 CONTINUE 200 CONTINUE IF(IWMULP.EQ.1) WRITE(LFNPR,1800) NAM,IAT,SUMAT IF(IWMULP.EQ.2) WRITE(LFNPR,1900) NAM,IAT,SUMAT 300 SUMT=SUMT+SUMAT IF(IWMULP.NE.0) WRITE(LFNPR,1600) SUMT TITLE = 'Mayer-Mulliken atom-atom bond order matrix:' CALL AOUT(BMAYER,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS) DO 310 I=1,NATOMS DO 310 J=1,NATOMS 310 VMAYER(I)=VMAYER(I)+BMAYER(I,J) TITLE = 'Mayer-Mulliken valencies by atom:' CALL AOUT(VMAYER,NATOMS,NATOMS,1,TITLE,0,1) RETURN 1000 FORMAT(//1X,'Total gross Mulliken populations by atom:', * //4X,'Atom #',7X,'Total') 1100 FORMAT(//1X,'Input atomic orbitals, gross Mulliken populations:', +//1X,' AO',2X,'Atom #',2X,'lang',2X,'Mulliken Population', +4X,'Atom #',7X,'Total') 1200 FORMAT(1X,79('-')) 1300 FORMAT(1X,I3,3X,A2,I3,2X,A1,A4,F13.7) 1600 FORMAT(/1X,'Total number of electrons: ',F11.6) 1800 FORMAT(5X,A2,I3,F15.7) 1900 FORMAT(44X,A2,I3,F15.7) END ***************************************************************************** SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LIST(6,MAXBAS),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(6,6),B(6),M(6), * RENORM(NDIM), * LF(3,3),LFCUB(3,3),LFT(3,3),LFCUBT(3,3),LG(3,3),LGT(3,3) DATA LF /301,304,306,302,307,309,303,308,310/ DATA LFCUB /306,304,301,309,302,307,303,308,310/ DATA LFT /151,356,352,152,357,353,153,354,351/ DATA LFCUBT/151,355,351,152,356,352,153,357,353/ DATA LG /402,407,409,403,408,410,405,412,414/ DATA LGT /251,455,459,252,452,456,253,453,457/ DATA ZERO,ONE,TWO,THREE,FOUR,SIX,EIGHT * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,6.0D0,8.0D0/ ********************************************************************** SUBROUTINE TO TRANSFORM THE OVERLAP AND DENSITY MATRICES IF D, F, G ORBITALS ARE PRESENT, OR TRANSFORM A TRANSFORMATION MATRIX SO THAT IT STARTS FROM THE RAW AO INSTEAD OF THE PURE AO BASIS THIS TRANSFORMATION WILL NOT WORK IF DM IS THE BOND-ORDER MATRIX. LIST(6,MAXBAS): THE LIST OF FUNCTIONS TO BE TRANSFORMED LIST(1,I),LIST(2,I),LIST(3,I) ARE CORRESPONDING SETS OF D,F, OR G FUNCTIONS. IT IS ASSUMED THAT, FOR EXAMPLE, THE THIRD DX2 FUNCTION FOUND IN THE ANGULAR MOMENTA LIST "LORB" CORRESPONDS TO THE THIRD DY2 AND THE THIRD DZ2 FUNCTIONS IN THE LIST OF BASIS FUNCTIONS! ITRAN=IDTRAN+IFTRAN+IGTRAN IDTRAN: THE NUMBER OF SETS OF CARTESIAN D ORBITALS FOUND IFTRAN: THE NUMBER OF SETS OF CARTESIAN F ORBITALS FOUND IGTRAN: THE NUMBER OF SETS OF CARTESIAN G ORBITALS FOUND A : THE TRANSFORMATION MATRIX ITOPT : IF ZERO, TRANSFORM DM AND S (IN T) FROM RAW AO TO PURE AO BASIS IF ONE, PRE-MULTIPLY T BY THE AO TO PURE AO TRANSF. --- THIS CONVERTS A TRANSF. THAT STARTS FROM PURE AOS TO A TRANSF. THAT STARTS FROM THE RAW AOS RENORM: RENORMALIZATION VECTOR FOR CARTESIAN TO PURE TRANSFORM. (PRODUCED IF ITOPT=0, USED AS INPUT IF ITOPT=1) ********************************************************************** DO 10 I=1,NBAS 10 LORB(I)=0 IDTRAN=0 N1=0 N2=0 N3=0 N4=0 N5=0 N6=0 ...CONSTRUCT LIST: DO 70 IBAS=1,NBAS DX2: IF(LORBC(IBAS).NE.201) GO TO 20 N1=N1+1 LIST(1,N1)=IBAS GO TO 70 DY2: 20 IF(LORBC(IBAS).NE.204) GO TO 30 N2=N2+1 LIST(2,N2)=IBAS GO TO 70 DZ2: 30 IF(LORBC(IBAS).NE.206) GO TO 40 N3=N3+1 LIST(3,N3)=IBAS GO TO 70 LABEL DXY: 40 IF(LORBC(IBAS).NE.202) GO TO 50 N4=N4+1 LORB(IBAS)=251 GO TO 70 LABEL DXZ: 50 IF(LORBC(IBAS).NE.203) GO TO 60 N5 =N5+1 LORB(IBAS)=252 GO TO 70 LABEL DYZ: 60 IF(LORBC(IBAS).NE.205) GO TO 70 N6=N6+1 LORB(IBAS)=253 70 CONTINUE IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1950 IF(N1.NE.N4.OR.N1.NE.N5.OR.N1.NE.N6) GO TO 1950 IDTRAN=N1 IF(IDTRAN.EQ.0) GO TO 160 SET UP TRANSFORM. COEFF: S=R2=X2+Y2+Z2: A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE D(X2-Y2): A(1,2)= ONE A(2,2)=-ONE A(3,2)= ZERO D(3Z2-R2)=-X2-Y2+2Z2: A(1,3)=-ONE A(2,3)=-ONE A(3,3)= TWO IF(ITOPT.EQ.0) GO TO 110 DO 90 J=1,3 RENOR=RENORM(LIST(J,1)) DO 90 I=1,3 90 A(I,J)=A(I,J)*RENOR CALL TRANSP(A,6,3) 110 CONTINUE ...LOOP OVER D SETS IN DLIST: DO 150 ID=1,IDTRAN M(1)=LIST(1,ID) M(2)=LIST(2,ID) M(3)=LIST(3,ID) ...TRANSFORM S AND DM: IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1) IF(ITOPT.NE.0) GO TO 150 CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0) CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0) ...SET THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED: LORB(M(1))=51 LORB(M(2))=254 LORB(M(3))=255 150 CONTINUE ********************************************************************** 160 CONTINUE F ORBITALS IFTRAN=0 DO 400 IFBLK=1,3 N1=0 N2=0 N3=0 IF(IWCUBF.NE.0) GO TO 190 LF1=LF(1,IFBLK) LF2=LF(2,IFBLK) LF3=LF(3,IFBLK) GO TO 200 190 CONTINUE LF1=LFCUB(1,IFBLK) LF2=LFCUB(2,IFBLK) LF3=LFCUB(3,IFBLK) 200 CONTINUE ...CONSTRUCT THE LIST: DO 260 IBAS=1,NBAS IF(LORBC(IBAS).NE.LF1) GO TO 220 N1=N1+1 LIST(1,N1)=IBAS GO TO 260 220 IF(LORBC(IBAS).NE.LF2) GO TO 230 N2=N2+1 LIST(2,N2)=IBAS GO TO 260 230 IF(LORBC(IBAS).NE.LF3) GO TO 260 N3=N3+1 LIST(3,N3)=IBAS GO TO 260 260 CONTINUE IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1960 IF(IFBLK.EQ.1) IFTRAN=N1 IF((IFBLK.NE.1).AND.(IFTRAN.NE.N1)) GO TO 1960 IF(IFTRAN.EQ.0) GO TO 500 IF(IWCUBF.EQ.0) GO TO 270 SET UP TRANSFORM. COEFF, CUBIC F ORBITALS PX=X*R2, PY=Y*R2, PZ=Z*Z2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE FX(Z2-Y2), FY(Z2-X2), FZ(X2-Y2) A(1,2)= ONE A(2,2)=-ONE A(3,2)= ZERO FX(5Z2-3R2), FY(5Y2-3R2), FZ(5Z2-3R2) A(1,3)=-THREE A(2,3)=-THREE A(3,3)= TWO GO TO 310 270 IF(IFBLK.GT.1) GO TO 280 SET UP TRANSFORM. COEFF, FOR FIRST F BLOCK PX=X*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE FX(X2-3Y2) A(1,2)= ONE A(2,2)=-THREE A(3,2)= ZERO FX(5Z2-R2) A(1,3)=-ONE A(2,3)=-ONE A(3,3)= FOUR GO TO 310 280 IF(IFBLK.EQ.3) GO TO 290 SET UP TRANSFORM. COEFF, FOR SECOND F BLOCK PY=Y*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE FY(3X2-Y2) A(1,2)= THREE A(2,2)=-ONE A(3,2)= ZERO FY(5Z2-R2) A(1,3)=-ONE A(2,3)=-ONE A(3,3)= FOUR GO TO 310 290 CONTINUE SET UP TRANSFORM. COEFF, FOR THIRD F BLOCK PZ Z*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE FZ(X2-Y2) A(1,2)= ONE A(2,2)=-ONE A(3,2)= ZERO FZ(5Z2-3R2) A(1,3)=-THREE A(2,3)=-THREE A(3,3)= TWO 310 CONTINUE IF(ITOPT.EQ.0) GO TO 330 DO 320 J=1,3 RENOR=RENORM(LIST(J,1)) DO 320 I=1,3 320 A(I,J)=A(I,J)*RENOR CALL TRANSP(A,6,3) 330 CONTINUE ...LOOP OVER F SETS IN LIST: DO 390 IT=1,IFTRAN M(1)=LIST(1,IT) M(2)=LIST(2,IT) M(3)=LIST(3,IT) ...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0) IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1) IF(ITOPT.NE.0) GO TO 340 CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0) CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0) ...FIX THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED: 340 CONTINUE IF(IWCUBF.NE.0) GO TO 350 LORB(M(1))=LFT(1,IFBLK) LORB(M(2))=LFT(2,IFBLK) LORB(M(3))=LFT(3,IFBLK) GO TO 390 350 CONTINUE LORB(M(1))=LFCUBT(1,IFBLK) LORB(M(2))=LFCUBT(2,IFBLK) LORB(M(3))=LFCUBT(3,IFBLK) 390 CONTINUE 400 CONTINUE SEARCH FOR FXYZ AND RELABEL: LF1=305 LF1T=355 IF(IWCUBF.NE.0) LF1T=354 N1=0 DO 420 IBAS=1,NBAS IF(LORBC(IBAS).NE.LF1) GO TO 420 N1=N1+1 LORB(IBAS)=LF1T 420 CONTINUE IF(IFTRAN.NE.N1) GO TO 1960 500 CONTINUE G ORBITALS IGTRAN=0 DO 800 IGBLK=1,3 N1=0 N2=0 N3=0 LG1=LG(1,IGBLK) LG2=LG(2,IGBLK) LG3=LG(3,IGBLK) ...CONSTRUCT THE LIST: DO 560 IBAS=1,NBAS LANG=LORBC(IBAS) IF(LANG.NE.LG1) GO TO 520 N1=N1+1 LIST(1,N1)=IBAS GO TO 560 520 IF(LANG.NE.LG2) GO TO 530 N2=N2+1 LIST(2,N2)=IBAS GO TO 560 530 IF(LANG.NE.LG3) GO TO 560 N3=N3+1 LIST(3,N3)=IBAS GO TO 560 560 CONTINUE IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1970 IF(IGBLK.EQ.1) IGTRAN=N1 IF((IGBLK.NE.1).AND.(IGTRAN.NE.N1)) GO TO 1970 IF(IGTRAN.EQ.0) GO TO 1000 IF(IGBLK.GT.1) GO TO 580 SET UP TRANSFORM. COEFF, FOR FIRST G BLOCK DXY=XY*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE G(2S) A(1,2)= ONE A(2,2)=-ONE A(3,2)= SIX G(4S) A(1,3)= ONE A(2,3)=-ONE A(3,3)= ZERO GO TO 610 580 IF(IGBLK.EQ.3) GO TO 590 SET UP TRANSFORM. COEFF, FOR SECOND G BLOCK DXZ=XZ*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE G(1C) A(1,2)=-THREE A(2,2)=-THREE A(3,2)= FOUR G(3C) A(1,3)= ONE A(2,3)=-THREE A(3,3)= ZERO GO TO 610 590 CONTINUE SET UP TRANSFORM. COEFF, FOR THIRD G BLOCK DYZ=YZ*R2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE G(1S) A(1,2)=-THREE A(2,2)=-THREE A(3,2)= FOUR G(3S) A(1,3)= THREE A(2,3)=-ONE A(3,3)= ZERO 610 CONTINUE IF(ITOPT.EQ.0) GO TO 630 DO 620 J=1,3 RENOR=RENORM(LIST(J,1)) DO 620 I=1,3 620 A(I,J)=A(I,J)*RENOR CALL TRANSP(A,6,3) 630 CONTINUE ...LOOP OVER G SETS IN LIST: DO 690 IT=1,IGTRAN M(1)=LIST(1,IT) M(2)=LIST(2,IT) M(3)=LIST(3,IT) ...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0) IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1) IF(ITOPT.NE.0) GO TO 660 CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0) CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0) ...FIX THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED: 660 CONTINUE LORB(M(1))=LGT(1,IGBLK) LORB(M(2))=LGT(2,IGBLK) LORB(M(3))=LGT(3,IGBLK) 690 CONTINUE 800 CONTINUE G ORBITALS --- FOURTH (6X6) BLOCK N1=0 N2=0 N3=0 N4=0 N5=0 N6=0 ...CONSTRUCT THE LIST: DO 870 IBAS=1,NBAS LANG=LORBC(IBAS) IF(LANG.NE.401) GO TO 820 N1=N1+1 LIST(1,N1)=IBAS GO TO 870 820 IF(LANG.NE.411) GO TO 830 N2=N2+1 LIST(2,N2)=IBAS GO TO 870 830 IF(LANG.NE.415) GO TO 840 N3=N3+1 LIST(3,N3)=IBAS GO TO 870 840 IF(LANG.NE.404) GO TO 850 N4=N4+1 LIST(1,N4)=IBAS GO TO 870 850 IF(LANG.NE.406) GO TO 860 N5=N5+1 LIST(2,N5)=IBAS GO TO 870 860 IF(LANG.NE.413) GO TO 870 N6=N6+1 LIST(3,N6)=IBAS GO TO 870 870 CONTINUE IF(IGTRAN.NE.N1.OR.N1.NE.N2.OR.N1.NE.N3) GO TO 1970 IF(N1.NE.N4.OR.N1.NE.N5.OR.N1.NE.N6) GO TO 1970 SET UP TRANSFORM. COEFF, FOR FOURTH G BLOCK S=(R2)2 A(1,1)= ONE A(2,1)= ONE A(3,1)= ONE A(4,1)= TWO A(5,1)= TWO A(6,1)= TWO D(3Z2-R2) A(1,2)=-ONE A(2,2)=-ONE A(3,2)= TWO A(4,2)=-TWO A(5,2)= ONE A(6,2)= ONE D(X2-Y2) A(1,3)= ONE A(2,3)=-ONE A(3,3)= ZERO A(4,3)= ZERO A(5,3)= ONE A(6,3)=-ONE G(0) A(1,4)= THREE A(2,4)= THREE A(3,4)= EIGHT A(4,4)= SIX A(5,4)=-SIX*FOUR A(6,4)=-SIX*FOUR G(2C) A(1,5)=-ONE A(2,5)=-ONE A(3,5)= ZERO A(4,5)= SIX A(5,5)=-SIX A(6,5)= ZERO G(4C) A(1,6)= ONE A(2,6)= ONE A(3,6)= ZERO A(4,6)=-SIX A(5,6)= ZERO A(6,6)= ZERO IF(ITOPT.EQ.0) GO TO 930 DO 920 J=1,6 RENOR=RENORM(LIST(J,1)) DO 920 I=1,6 920 A(I,J)=A(I,J)*RENOR CALL TRANSP(A,6,6) 930 CONTINUE IF(ITOPT.NE.0) CALL TRANSP(A,6,6) ...LOOP OVER G SETS IN LIST: DO 960 IT=1,IGTRAN M(1)=LIST(1,IT) M(2)=LIST(2,IT) M(3)=LIST(3,IT) M(4)=LIST(4,IT) M(5)=LIST(5,IT) M(6)=LIST(6,IT) ...TRANSFORM S AND DM: ...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0) IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,6,-1) IF(ITOPT.NE.0) GO TO 950 CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,6,0) CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,6,0) ...CHANGE THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED: 950 CONTINUE LORB(M(1))=51 LORB(M(2))=254 LORB(M(3))=255 LORB(M(4))=451 LORB(M(5))=454 LORB(M(6))=458 960 CONTINUE RENORMALIZATION, ITOPT=0 : 1000 CONTINUE ITRAN=IDTRAN+IFTRAN+IGTRAN IF(ITOPT.NE.0) RETURN IF(ITRAN.EQ.0) GO TO 1200 DO 1020 I=1,NBAS X=T(I,I) 1020 RENORM(I)=ONE/SQRT(X) DO 1040 I=1,NBAS DO 1040 J=1,NBAS RIJ=RENORM(I)*RENORM(J) T(I,J)=T(I,J)*RIJ 1040 DM(I,J)=DM(I,J)*RIJ RELABELLING OF NON-TRANSFORMED ORBITALS: 1200 CONTINUE DO 1230 I=1,NBAS IF(LORB(I).NE.0) GO TO 1230 LANG=LORBC(I) LORB(I)=LANG L=LANG/100 IDIF=LANG-L*100 IF(IDIF.GT.50) GO TO 1230 LORB(I)=LORB(I)+50 1230 CONTINUE RETURN ERROR MESSAGES: 1950 WRITE(LFNPR,1951) 1951 FORMAT(' Unequal numbers of d function components were', +' found in the input.',/,' These cannot be properly transformed-', +'-perhaps they were improperly labelled.') STOP 1960 WRITE(LFNPR,1961) 1961 FORMAT(' Unequal numbers of f function components were', +' found in the input.',/,' These cannot be properly transformed-', +'-perhaps they were improperly labelled.') STOP 1970 WRITE(LFNPR,1971) 1971 FORMAT(' Unequal numbers of g function components were', +' found in the input.',/,' These cannot be properly transformed-', +'-perhaps they were improperly labelled.') STOP END ***************************************************************************** SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) ******************************************************************** MAIN SUBROUTINE 'NAO' FOR NATURAL ATOMIC ORBITAL BASIS SET. INPUT REQUIRED: S = OVERLAP MATRIX ELEMENTS IN LOWER TRIANGLE (BELOW DIAGONAL) = DENSITY MATRIX ELEMENTS IN UPPER TRIANGLE (INCLUDING DIAG.) (INPUT AO'S MUST(!) BE NORMALIZED. ON RETURN, S IS THE FULL DENSITY MATRIX. OVERLAP MATRIX ELEMENTS ARE LOST.) LBL = LIST OF ATOMIC CENTERS; LBL(I) = N IF ORBITAL I IS ON CENTER N LORB = LIST OF ANGULAR MOMENTUM TYPE FOR EACH ORBITAL; LORB(I) = N IF ORBITAL I IS OF 'TYPE' N. N = ( 51,151,152,153) = (S,PX,PY,PZ) = (251,252,253,254,255) = (DXY,DXZ,DYZ,D(X2-Y2),D(3Z2-R2)) = (351-357 FOR THE 7 TYPES OF F ORBITALS) = (451-459 FOR THE 9 TYPES OF G ORBITALS) OUTPUT: T = TRANSFORMATION MATRIX FROM INPUT AO'S TO NAO'S (ROWS ARE LABELLED BY PRIMITIVE AO'S, COLUMNS BY NAO'S) NAOCTR = LIST OF ATOMIC CENTERS FOR NAO'S; NAOCTR(I) = N IF NAO # I IS ON CENTER #N. NAOL = LIST OF ANGULAR MOMENTUM TYPE FOR EACH NAO, SAME FORMAT AS "LORB" BEFORE RETURN: LSTOCC = LIST OF NATURAL MINIMAL BASIS ('OCCUPIED') ORBITALS; LSTOCC(I)=N (I=1,...,NOCC) MEANS THAT NAO #N BELONGS TO THE NMB SET. LSTEMT = LIST OF NATURAL RYDBERG BASIS ('EMPTY') ORBITALS; LSTEMT(I)=N (I=1,...,NEMT) MEANS THAT NAO #N BELONGS TO THE NRB SET. AFTER RETURN: LSTOCC(I) = 1 ONLY IF NAO #I BELONGS TO THE NMB SET. ******************************************************************** PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),OCC(NDIM),BLK(NDIM,NDIM), + SBLK(MXAOLM,MXAOLM),EVAL(NBAS),EVAL2(NBAS), + LISTAO(MXAOLM,9),C(NBLOCK),EVECT(MXAOLM,MXAOLM) CHARACTER*80 TITLE DATA ZERO,ONE/0.0D0,1.0D0/ DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/ SKIP T-NAO FORMATION IF IOINQR(IWPNAO).EQ.IREAD: IF(IOINQR(IWPNAO).EQ.IREAD) GO TO 200 ZERO TRANSFORMATION MATRIX T: DO 10 J = 1,NBAS LSTOCC(J) = 0 LSTEMT(J) = 0 DO 10 I = 1,NBAS 10 T(I,J) = ZERO NF COUNTS THE ACCUMULATED ORBITALS: NF = 0 NOCC COUNTS THE ACCUMULATED 'OCCUPIED' ORBITALS: NEMT COUNTS THE ACCUMULATED 'EMPTY' ORBITALS: NOCC = 0 NEMT = 0 BEGIN MAIN NAO LOOP OVER ATOMIC CENTERS: DO 140 ICNTR = 1,NATOMS LOOP OVER ANGULAR MOMENTUM BLOCKS (S,P,D,F,G). NL COUNTS THE NUMBER OF ORBITALS IN EACH "M" COMPONENT OF THE "L" BLOCK: DO 130 IL = 1,5 IF(NF.GT.NBAS) GO TO 130 L = IL - 1 M = 2*L + 1 SCAN ORBITAL LABELS TO GATHER 'LISTAO' OF ORBITALS BELONGING TO PROPER ATOM AND ANGULAR MOMENTUM SYMMETRY: DO 20 IM = 1,M LANG = 100*L + IM + 50 NL = 0 DO 20 I = 1,NBAS IF((LBL(I).NE.ICNTR).OR.(LORB(I).NE.LANG)) GO TO 20 NL = NL + 1 LISTAO(NL,IM) = I 20 CONTINUE IF(NL.EQ.0) GO TO 140 LOAD THIS LIST OF ORBITALS INTO BLK AND SBLK (DENSITY MATRIX AND OVERLAP ELEMENTS, RESP.), AND AVERAGE THE DENSITY MATRIX ELEMENTS OVER THE M COMPONENTS OF L FOR THE ATOM: CALL LOADAV(LISTAO,NL,M,S,NDIM,BLK,SBLK,MXAOLM) SOLVE THE GENERALIZED EIGENVALUE PROBLEM: CALL ATDIAG(NL,BLK,SBLK,EVAL,C) ORDER THE EIGENVECTORS BY OCCUPANCY EIGENVALUE: CALL RANK(EVAL,NL,NL,LARC) LOOP OVER THE 2*L+1 COMPONENTS TO STORE T-NAO DATA: DO 120 IM = 1,M PARTITION ORBITALS INTO 'OCCUPIED' AND 'EMPTY' SETS: CALL SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,ICNTR,L,NL,NF,NDIM) STORE THE ORDERED EIGENVECTORS IN T: DO 120 J = 1,NL JR = LARC(J) NF = NF + 1 OCC(NF) = EVAL(J) DO 110 I = 1,NL IAO = LISTAO(I,IM) IJR = I + NL*(JR-1) T(IAO,NF) = C(IJR) 110 CONTINUE MAKE UP NAO ORBITAL LABELS: NAOCTR(NF) = ICNTR NAOL(NF) = L*100 + IM + 50 120 CONTINUE 130 CONTINUE 140 CONTINUE 200 CONTINUE READ IN PRE-ORTHOGONAL T-NAO DATA: IF(IOINQR(IWPNAO).NE.IREAD) GO TO 300 CALL RDPPNA(T,OCC) RECOMPUTE AND SYMMETRY-AVERAGE WEIGHTS, REORGANIZE LSTOCC IF THE INPUT PNAOS ARE RPNAOS: IF(OCC(1).LT.ZERO) CALL NEWWTS(S,T,OCC) NOCC = 0 NEMT = 0 LANG = 0 ILBL = 1 NLANG = 0 DO 280 I = 1,NBAS IF(LSTOCC(I).GT.0) NOCC = NOCC + 1 IF((NAOCTR(I).NE.ILBL).OR.(NAOL(I).NE.LANG)) GO TO 240 NLANG = NLANG + 1 GO TO 250 240 IF(NLANG.GT.MXAOLM) MXAOLM = NLANG NLANG = 1 ILBL = NAOCTR(I) LANG = NAOL(I) 250 CONTINUE DO 260 J = 1,NBAS 260 IF(LSTOCC(J).EQ.I) GO TO 280 NEMT = NEMT + 1 LSTEMT(NEMT) = I 280 CONTINUE 300 CONTINUE WRITE PREORTHOGONAL T-NAO DATA TO LFNPPA: IF(IOINQR(IWPNAO).EQ.IWRIT) CALL WRPPNA(T,OCC,IWPNAO) SAVE T-PNAO FOR LATER USE IN COMPUTING THE NON-ORTHOGONAL OVERLAPS BETWEEN NAOS OR NBOS: CALL SVPNAO(T) IF(IOINQR(IWPNAO).EQ.IPRNT) THEN TITLE = 'PNAOs in the PAO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,-1,IWPNAO) END IF FINAL ORTHOGONALIZATION: DO 450 I = 1,NBAS DO 440 J = 1,I 440 S(J,I) = S(I,J) 450 S(I,I) = ONE CALL WORTH(S,T,BLK,LSTOCC,NDIM,NBAS,NOCC,OCC,EVAL,BLK) IF(NEMT.EQ.0) GO TO 700 CALL SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,BLK) PUT P-PAO IN UPPER TRIANGLE OF S (AND DIAGONAL): CALL FEPPAO(BLK) DO 460 J = 1,NBAS DO 460 I = 1,J 460 S(I,J) = BLK(I,J) CALL NEWRYD(T,S,BLK,C,SBLK,EVECT,OCC,EVAL,EVAL2,LISTAO, * JPRINT(11)) SELECT THE SIGNIFICANT RYDBERGS, PUT IN "LARC". PUT THE LIST OF THE REST OF THE RYDBERGS INTO "LISTAO", AND SET THE WEIGHTINGS OF THESE LOW OCCUPANCY ORBITALS TO ONE. THEN, DO A WEIGHTED ORTHOG. AMONG THE SIGNIFICANT RYDBERGS, SCHMIDT ORTHOG. THE LOW OCC. RYDS TO THESE, AND FINALLY DO A LOWDIN ORTHOG. AMONG THE LOW OCC. RYDS.: CALL RYDSEL(LSTEMT,NEMT,NSEL1,LARC,NSEL2,LISTAO,OCC) IF(NSEL1.EQ.0) GO TO 690 CALL WORTH(S,T,BLK,LARC,NDIM,NBAS,NSEL1,OCC,EVAL,BLK) IF(NSEL2.EQ.0) GO TO 700 690 CONTINUE IF(NSEL1.NE.0) * CALL SHMDT(T,S,NDIM,NBAS,NSEL1,LARC,NSEL2,LISTAO,BLK) CALL WORTH(S,T,BLK,LISTAO,NDIM,NBAS,NSEL2,OCC,EVAL,BLK) 700 CONTINUE CALL FEPPAO(S) CALL SIMTRS(S,T,OCC,NDIM,NBAS) CALL REDIAG(S,T,BLK,OCC,SBLK,C,LISTAO,JPRINT(11)) RETURN OCCUPIED LIST 'LSTOCC' OF 1'S OR 0'S: DO 820 I = 1,NBAS 820 LSTOCC(I) = 1 DO 840 I = 1,NEMT 840 LSTOCC(LSTEMT(I)) = 0 RETURN END ***************************************************************************** SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*80 TITLE LOGICAL FIRST,CORE,ALLZER LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO Perform the Natural Population Analysis PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBLBL/NLEW,NVAL,LBLS(10,MAXBAS,4) DIMENSION DM(NDIM,NDIM),SPNAO(NDIM,NDIM),BINDEX(NATOMS,NATOMS), * BINDT(NATOMS),OVPOP(NATOMS,NATOMS),F(NDIM,NDIM),ENAO(NDIM), * JPRIN(MAXBAS),ICORE(4),IVAL(4),NWARN(MAXATM),LABEC(20,2), * OCCEC(20),BMO(NATOMS,NATOMS) DIMENSION IANG(5),ANGL(25),LANG(25),CUBICF(7) DATA IRYD/'Ryd'/ DATA IANG/'s','p','d','f','g'/ DATA LANG/ 51,151,152,153,251,252,253,254,255, * 351,352,353,354,355,356,357, * 451,452,453,454,455,456,457,458,459/ DATA ANGL/4H ,4Hx ,4Hy ,4Hz ,4Hxy ,4Hxz ,4Hyz , * 4Hx2y2,4Hz2 ,4H(0) ,4H(C1),4H(S1),4H(C2),4H(S2),4H(C3), * 4H(S3),4H(0) ,4H(C1),4H(S1),4H(C2),4H(S2),4H(C3),4H(S3), * 4H(C4),4H(S4)/ DATA CUBICF/4H(D1),4H(D2),4H(D3),4H(B) ,4H(E1),4H(E2),4H(E3)/ DATA ZERO,TENTH,TWO/0.0D0,0.1D0,2.0D0/ TEST, TEST2, ALLOW, and ALLOW2 are numbers used in determining if the density matrix trace is close to being an integer. TEST2 (ALLOW2) must be slightly greater than twice TEST (ALLOW): DATA TEST,TEST2/1.0D-5,2.1D-5/ DATA ALLOW,ALLOW2/1.0D-3,2.1D-3/ DATA ICHCOR,ICHVAL,ICHRYD/'Cor','Val','Ryd'/ If the f functions are a cubic set, insert the proper labels: IF(IWCUBF.EQ.0) GOTO 20 DO 10 I = 1,7 II = I+9 10 ANGL(II) = CUBICF(I) 20 CONTINUE Update the NAO atom-atom valency matrix: DO 30 J = 1,NATOMS DO 30 I = 1,NATOMS OVPOP(I,J) = ZERO BMO(I,J) = ZERO 30 BINDEX(I,J) = ZERO DO 50 I = 1,NBAS IAT = NAOCTR(I) DO 40 J = 1,NBAS JAT = NAOCTR(J) IF(JAT.NE.IAT) THEN SIJ = SPNAO(I,J) DMIJ = DM(I,J) DMIJ2 = DMIJ*DMIJ DMSIJ = DMIJ*SIJ BINDEX(JAT,IAT) = BINDEX(JAT,IAT) + DMIJ2 BMO(JAT,IAT) = BMO(JAT,IAT) + DMIJ OVPOP(JAT,IAT) = OVPOP(JAT,IAT) + DMSIJ END IF 40 CONTINUE 50 CONTINUE Determine the NAO orbital energies if a Fock matrix exists. Use SPNAO to store TNAO: CALL FETNAO(SPNAO) IFOCK = IWFOCK IF(OPEN.AND..NOT.(ALPHA.OR.BETA)) IFOCK = 0 IF(IFOCK.EQ.1) THEN CALL FEFAO(F,IWFOCK) IF(IWFOCK.NE.0) THEN DO 80 I = 1,NBAS ENRG = ZERO DO 70 J = 1,NBAS DO 60 K = 1,NBAS ENRG = ENRG + SPNAO(J,I)*F(J,K)*SPNAO(K,I) 60 CONTINUE 70 CONTINUE ENAO(I) = ENRG 80 CONTINUE END IF END IF Label NAO's as either 'Cor', 'Val', or 'Ryd': DO 200 I = 1,NBAS LTYP(I) = IRYD 200 CONTINUE IECP = 0 DO 300 NCTR = 1,NATOMS CALL CORTBL(NCTR,ICORE,IECP) CALL VALTBL(NCTR,IVAL) Loop over s,p,d,f orbitals: DO 290 L = 0,3 ITYP = IANG(L+1) LNUM = 2*L + 1 IF(ICORE(L+1).LE.0) GOTO 240 Label core orbitals: DO 230 M = 1,ICORE(L+1) DO 220 LA = 1,LNUM MORB = 0 OCC = -1.0 DO 210 N = 1,NBAS LM = NAOL(N) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(N),50) IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND. + DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND. + LA.EQ.NA) THEN MORB = N OCC = DM(N,N) END IF 210 CONTINUE IF(MORB.EQ.0) THEN WRITE(LFNPR,2500) ITYP,NAMEAT(IATNO(NCTR)),NCTR, + (ICORE(I),I=1,4),M,LA STOP END IF LTYP(MORB) = ICHCOR 220 CONTINUE 230 CONTINUE 240 CONTINUE IF(IVAL(L+1).LE.0) GOTO 280 Label valence orbitals: DO 270 M = 1,IVAL(L+1) DO 260 LA = 1,LNUM MORB = 0 OCC = -1.0 DO 250 N = 1,NBAS LM = NAOL(N) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(N),50) IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND. + DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND. + LA.EQ.NA) THEN MORB = N OCC = DM(N,N) END IF 250 CONTINUE IF(MORB.EQ.0) THEN WRITE(LFNPR,2600) ITYP,NAMEAT(IATNO(NCTR)),NCTR, + (IVAL(I),I=1,4),M,LA STOP END IF LTYP(MORB) = ICHVAL 260 CONTINUE 270 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE Assign `principal' quantum numbers using the NAO occupancies: DO 390 I = 1,NBAS IPRIN(I) = 0 390 CONTINUE DO 450 NCTR = 1,NATOMS IECP = 1 CALL CORTBL(NCTR,IVAL,IECP) IECP = 0 CALL CORTBL(NCTR,ICORE,IECP) DO 440 L = 0,4 ITYP = IANG(L+1) MMAX = 2*L + 1 DO 430 M = 1,MMAX IF(L.EQ.4) THEN N = 3 ELSE N = IVAL(L+1) - ICORE(L+1) + L END IF 400 CONTINUE MORB = 0 OCC = -1.0 DO 410 J = 1,NBAS LM = NAOL(J) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(J),50) IF(NAOCTR(J).EQ.NCTR.AND.IL.EQ.ITYP.AND. + DM(J,J).GT.OCC.AND.IPRIN(J).EQ.0.AND. + M.EQ.NA) THEN MORB = J OCC = DM(J,J) END IF 410 CONTINUE IF(MORB.EQ.0) GOTO 420 N = N + 1 IPRIN(MORB) = N GOTO 400 420 CONTINUE 430 CONTINUE 440 CONTINUE 450 CONTINUE Assign `principal' quantum numbers using the NAO Fock matrix elements: IF(IFOCK.EQ.0) GOTO 580 DO 490 I = 1,NBAS JPRIN(I) = 0 490 CONTINUE DO 550 NCTR = 1,NATOMS IECP = 1 CALL CORTBL(NCTR,IVAL,IECP) IECP = 0 CALL CORTBL(NCTR,ICORE,IECP) DO 540 L = 0,4 ITYP = IANG(L+1) MMAX = 2*L + 1 DO 530 M = 1,MMAX IF(L.EQ.4) THEN N = 3 ELSE N = IVAL(L+1) - ICORE(L+1) + L END IF 500 CONTINUE MORB = 0 ENRG = 1.0D6 DO 510 J = 1,NBAS LM = NAOL(J) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(J),50) IF(NAOCTR(J).EQ.NCTR.AND.IL.EQ.ITYP.AND. + ENAO(J).LT.ENRG.AND.JPRIN(J).EQ.0.AND. + M.EQ.NA) THEN MORB = J ENRG = ENAO(J) END IF 510 CONTINUE IF(MORB.EQ.0) GOTO 520 N = N + 1 JPRIN(MORB) = N GOTO 500 520 CONTINUE 530 CONTINUE 540 CONTINUE 550 CONTINUE 580 CONTINUE Count the total number of electrons: TOT = ZERO DO 600 INAO = 1,NBAS TOT = TOT + DM(INAO,INAO) 600 CONTINUE NEL = TOT + TENTH Store NEL for use by the output routines: NLEW = NEL Check to see if the total number of electrons found is an integer: IF(TOT.GE.ZERO) THEN SUMTT = TOT + TEST SUMTI = AINT(SUMTT) SUMTF = SUMTT - SUMTI IF(SUMTF.GT.TEST2) THEN SUMTT = TOT + ALLOW SUMTI = AINT(SUMTT) SUMTF = SUMTT - SUMTI IF(SUMTF.GT.ALLOW2) THEN WRITE(LFNPR,955) JPRINT(4) = -1 ELSE WRITE(LFNPR,956) END IF END IF ELSE WRITE(LFNPR,955) JPRINT(4) = -1 END IF Write out Natural Population analysis: IF(JPRINT(4).NE.0) THEN IF(IFOCK.EQ.1) THEN WRITE(LFNPR,900) ELSE WRITE(LFNPR,910) END IF JCTR = 1 DO 700 I = 1,NBAS NCTR = NAOCTR(I) IF(NCTR.NE.JCTR) THEN WRITE(LFNPR,*) JCTR = NCTR END IF IAT = IATNO(NCTR) NAM = NAMEAT(IAT) LM = NAOL(I) L = LM/100 IL = IANG(L+1) DO 680 ILM = 1,25 IF(LM.EQ.LANG(ILM)) GOTO 690 680 CONTINUE 690 CONTINUE OCC = DM(I,I) IF(OCC.LT.ZERO) OCC = ZERO IF(IFOCK.EQ.1) THEN WRITE(LFNPR,920) I,NAM,NCTR,IL,ANGL(ILM),LTYP(I), + JPRIN(I),IL,OCC,ENAO(I) ELSE WRITE(LFNPR,920) I,NAM,NCTR,IL,ANGL(ILM),LTYP(I), + IPRIN(I),IL,OCC END IF 700 CONTINUE Add note about effective core potentials if used: IECP = 0 DO 710 I = 1,NATOMS IECP = IECP + IATNO(I) - IZNUC(I) 710 CONTINUE IF(IPSEUD.NE.0) THEN IF(ALPHA.OR.BETA) IECP = IECP/2 WRITE(LFNPR,930) IECP END IF Write out warnings for low occupancy core orbitals: CRTHRS = CRTSET IF(ALPHA.OR.BETA) CRTHRS = CRTHRS - 1.0 DO 715 N = 1,NATOMS NWARN(N) = 0 715 CONTINUE DO 720 I = 1,NBAS ICTR = NAOCTR(I) IF(LTYP(I).EQ.ICHCOR.AND.DM(I,I).LT.CRTHRS) + NWARN(ICTR) = NWARN(ICTR) + 1 720 CONTINUE FIRST = .TRUE. DO 725 N = 1,NATOMS NAM = NAMEAT(IATNO(N)) IF(NWARN(N).EQ.1) THEN IF(FIRST) THEN WRITE(LFNPR,931) CRTHRS,NAM,N FIRST = .FALSE. ELSE WRITE(LFNPR,932) CRTHRS,NAM,N END IF ELSE IF(NWARN(N).GT.1) THEN IF(FIRST) THEN WRITE(LFNPR,933) NWARN(N),CRTHRS,NAM,N FIRST = .FALSE. ELSE WRITE(LFNPR,934) NWARN(N),CRTHRS,NAM,N END IF END IF 725 CONTINUE Write out warnings for population inversions: IF(IFOCK.EQ.1) THEN DO 730 N = 1,NATOMS NWARN(N) = 0 730 CONTINUE DO 735 I = 1,NBAS ICTR = NAOCTR(I) IF(IPRIN(I).NE.JPRIN(I)) NWARN(ICTR) = 1 IPRIN(I) = JPRIN(I) 735 CONTINUE FIRST = .TRUE. DO 738 N = 1,NATOMS NAM = NAMEAT(IATNO(N)) IF(NWARN(N).GT.0) THEN IF(FIRST) THEN WRITE(LFNPR,936) NAM,N FIRST = .FALSE. ELSE WRITE(LFNPR,937) NAM,N END IF END IF 738 CONTINUE END IF Summarize the Natural Population Analysis: WRITE(LFNPR,939) SUMAC = ZERO SUMAV = ZERO SUMAR = ZERO NOMAC = 0 DO 750 I = 1,NATOMS SUMC = ZERO SUMV = ZERO SUMR = ZERO NAM = NAMEAT(IATNO(I)) DO 740 J = 1,NBAS IF(NAOCTR(J).EQ.I) THEN OCC = DM(J,J) IF(OCC.LT.ZERO) OCC = ZERO IF(LTYP(J).EQ.ICHCOR) SUMC = SUMC + OCC IF(LTYP(J).EQ.ICHVAL) SUMV = SUMV + OCC IF(LTYP(J).EQ.ICHRYD) SUMR = SUMR + OCC IF(LTYP(J).EQ.ICHCOR) NOMAC = NOMAC + 2 END IF 740 CONTINUE TOT = SUMC + SUMV + SUMR IF(ALPHA.OR.BETA) THEN CHG = IZNUC(I)/2.0 - TOT ELSE CHG = IZNUC(I) - TOT END IF ECP = FLOAT(IATNO(I) - IZNUC(I)) IF(ALPHA.OR.BETA) ECP = ECP/TWO WRITE(LFNPR,940) NAM,I,CHG,SUMC+ECP,SUMV,SUMR,TOT+ECP SUMAC = SUMAC + SUMC SUMAV = SUMAV + SUMV SUMAR = SUMAR + SUMR 750 CONTINUE TOT = SUMAC + SUMAV + SUMAR CHG = -1.0 * TOT IF(ALPHA.OR.BETA) THEN NOMAC = NOMAC/2 DO 760 I = 1,NATOMS CHG = CHG + IZNUC(I)/2.0 760 CONTINUE ELSE DO 770 I = 1,NATOMS CHG = CHG + IZNUC(I) 770 CONTINUE END IF WRITE(LFNPR,950) CHG,SUMAC+FLOAT(IECP),SUMAV,SUMAR, + TOT+FLOAT(IECP) Write out NMB and NRB populations and percentage occupancies: WRITE(LFNPR,960) NOMA = NEL NOMAV = NOMA - NOMAC SUMA = SUMAC + SUMAV IF(IPSEUD.NE.0) THEN ECP = IECP SUMA = SUMA + ECP NOMA = NOMA + IECP WRITE(LFNPR,970) ECP END IF IF(NOMAC.NE.0) THEN PCENT = SUMAC/NOMAC * 100.0 WRITE(LFNPR,980) SUMAC,PCENT,NOMAC ELSE IF(SUMAC.NE.ZERO) THEN PCENT = ZERO WRITE(LFNPR,980) SUMAC,PCENT,NOMAC END IF IF(NOMAV.NE.0) THEN PCENT = SUMAV/NOMAV * 100.0 WRITE(LFNPR,990) SUMAV,PCENT,NOMAV ELSE IF(SUMAV.NE.ZERO) THEN PCENT = ZERO WRITE(LFNPR,990) SUMAV,PCENT,NOMAV END IF IF(NOMA.NE.0) THEN PCENT = SUMA/NOMA * 100.0 ELSE PCENT = ZERO END IF WRITE(LFNPR,1000) SUMA,PCENT,NOMA IF(NOMA.NE.0) THEN PCENT = SUMAR/NOMA * 100.0 WRITE(LFNPR,1010) SUMAR,PCENT,NOMA ELSE IF(SUMAR.NE.ZERO) THEN PCENT = 0 WRITE(LFNPR,1010) SUMAR,PCENT,NOMA END IF Write out Natural Electron Configuration: WRITE(LFNPR,1040) DO 899 NCTR = 1,NATOMS ICT = 0 IECP = 1 CALL CORTBL(NCTR,ICORE,IECP) DO 870 NPL = 1,8 DO 860 N = 1,NPL L = NPL - N IF(L.GE.0.AND.L.LT.N) THEN IF(N.GT.ICORE(L+1)+L) THEN ICT = ICT + 1 LABEC(ICT,1) = N LABEC(ICT,2) = IANG(L+1) OCCEC(ICT) = ZERO END IF END IF 860 CONTINUE 870 CONTINUE DO 890 I = 1,NBAS ICTR = NAOCTR(I) IF(ICTR.EQ.NCTR.AND.LTYP(I).NE.ICHCOR) THEN NORB = NAOL(I)/100 IL = IANG(NORB+1) DO 880 J = 1,ICT IF(IPRIN(I).EQ.LABEC(J,1).AND. + IL.EQ.LABEC(J,2)) THEN OCCEC(J) = OCCEC(J) + DM(I,I) GOTO 890 END IF 880 CONTINUE END IF 890 CONTINUE IF(LABEC(1,1).NE.1) THEN CORE = .TRUE. ELSE CORE = .FALSE. END IF THOLD = 5.0D-3 JMAX = ICT Remove low occupancy subshells: DO 893 JCT = 1,ICT 891 CONTINUE IF(OCCEC(JCT).LT.THOLD) THEN ALLZER = .TRUE. DO 892 KCT = JCT,ICT-1 LABEC(KCT,1) = LABEC(KCT+1,1) LABEC(KCT,2) = LABEC(KCT+1,2) OCCEC(KCT) = OCCEC(KCT+1) IF(OCCEC(KCT).GE.THOLD) ALLZER = .FALSE. 892 CONTINUE OCCEC(ICT) = ZERO IF(ALLZER) THEN JMAX = JCT - 1 GOTO 895 END IF GOTO 891 END IF 893 CONTINUE 895 CONTINUE NAM = NAMEAT(IATNO(NCTR)) IF(JMAX.EQ.0) THEN IF(.NOT.CORE) THEN WRITE(LFNPR,1050) NAM,NCTR ELSE WRITE(LFNPR,1060) NAM,NCTR END IF ELSE IF(.NOT.CORE) THEN WRITE(LFNPR,1050) NAM,NCTR,((LABEC(K,J),J=1,2),OCCEC(K), + K=1,JMAX) ELSE WRITE(LFNPR,1060) NAM,NCTR,((LABEC(K,J),J=1,2),OCCEC(K), + K=1,JMAX) END IF END IF 899 CONTINUE END IF IF(JPRINT(4).LT.0) STOP Write out Wiberg Bond Index Matrix if requested: IF(JPRINT(12).NE.0) THEN TITLE = 'Wiberg bond index matrix in the NAO basis:' CALL AOUT(BINDEX,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS) DO 3010 IAT = 1,NATOMS BINDT(IAT) = ZERO DO 3000 JAT = 1,NATOMS IF(IAT.EQ.JAT) GOTO 3000 BINDT(IAT) = BINDT(IAT) + BINDEX(JAT,IAT) 3000 CONTINUE 3010 CONTINUE TITLE = 'Wiberg bond index, Totals by atom:' CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1) Write out overlap-weighted bond populations: TITLE = 'Atom-atom overlap-weighted NAO bond order:' CALL AOUT(OVPOP,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS) DO 3030 IAT = 1,NATOMS BINDT(IAT) = ZERO DO 3020 JAT = 1,NATOMS IF(IAT.EQ.JAT) GOTO 3020 BINDT(IAT) = BINDT(IAT) + OVPOP(JAT,IAT) 3020 CONTINUE 3030 CONTINUE TITLE(1:43) = 'Atom-atom overlap-weighted NAO bond order, ' TITLE(44:58) = 'Totals by atom:' CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1) Write out MO bond orders: TITLE = 'MO bond order:' CALL AOUT(BMO,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS) DO 3050 IAT = 1,NATOMS BINDT(IAT) = ZERO DO 3040 JAT = 1,NATOMS IF(IAT.EQ.JAT) GOTO 3040 BINDT(IAT) = BINDT(IAT) + BMO(JAT,IAT) 3040 CONTINUE 3050 CONTINUE TITLE = 'MO atomic valencies:' CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1) END IF Save NAO info in COMMON/NBNAO/: DO 888 I = 1,NBAS NAOC(I) = NAOCTR(I) NAOA(I) = NAOL(I) 888 CONTINUE RETURN 900 FORMAT(//,1X, +'NATURAL POPULATIONS: Natural atomic orbital occupancies ',/,1X, +' ',/,1X, +' NAO Atom # lang Type(AO) Occupancy Energy ',/,1X, +'---------------------------------------------------------') 910 FORMAT(//,1X, +'NATURAL POPULATIONS: Natural atomic orbital occupancies ',/,1X, +' ',/,1X, +' NAO Atom # lang Type(AO) Occupancy ',/,1X, +'------------------------------------------- ') 920 FORMAT(1X,I3,3X,A2,I3,2X,A1,A4,2X,A3,'(',I2,A1,')',4X, + F8.5,4X,F10.5) 930 FORMAT(/,1X, +'[',I3,' electrons found in the effective core potential]') 931 FORMAT(/,1X, +'WARNING: 1 low occupancy (<',F6.4,'e) core orbital found ', +'on ',A2,I2) 932 FORMAT(1X, +' 1 low occupancy (<',F6.4,'e) core orbital found ', +'on ',A2,I2) 933 FORMAT(/,1X, +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals found', +' on ',A2,I2) 934 FORMAT(1X, +' ',I3,' low occupancy (<',F6.4,'e) core orbitals found', +' on ',A2,I2) 936 FORMAT(/,1X, +'WARNING: Population inversion found on atom ',A2,I2) 937 FORMAT(1X, +' Population inversion found on atom ',A2,I2) 939 FORMAT(//,1X, +'Summary of Natural Population Analysis: ',/,1X, +' ',/,1X, +' Natural Population ',/,1X, +' Natural ',47('-'),/,1X,3X,'Atom #',5X, +'Charge',8X,'Core',6X,'Valence',4X,'Rydberg',6X,'Total',/,1X, +71('-')) 940 FORMAT(1X,4X,A2,I3,2X,F9.5,4X,F9.5,3X,F9.5,2X,F9.5,3X,F9.5) 950 FORMAT(1X,71('='),/,1X,' * Total *',F9.5,4X,F9.5,3X,F9.5,2X, + F9.5,3X,F9.5) 955 FORMAT(/1X, +'Number of electrons is not an integer! Please check your ', +'data.',/) 956 FORMAT(/1X, +'WARNING: Number of electrons is not within 1.0D-5 of an', +' integer.'/) 960 FORMAT(/,1X, +' Natural Population ',/,1X, +'--------------------------------------------------------') 970 FORMAT(1X,' Effective Core ',F10.5) 980 FORMAT(1X,' Core ',F10.5,' (',F8.4, +'% of ',I3,')') 990 FORMAT(1X,' Valence ',F10.5,' (',F8.4, +'% of ',I3,')') 1000 FORMAT(1X,' Natural Minimal Basis ',F10.5,' (',F8.4, +'% of ',I3,')') 1010 FORMAT(1X,' Natural Rydberg Basis ',F10.5,' (',F8.4, +'% of ',I3,')',/,1X, +'--------------------------------------------------------') 1040 FORMAT(/1X, +' Atom # Natural Electron Configuration',/,1X, + 76('-')) 1050 FORMAT(1X,4X,A2,I3,6X,6X,(13(I1,A1,'(',F5.2,')'))) 1060 FORMAT(1X,4X,A2,I3,6X,'[core]',(13(I1,A1,'(',F5.2,')'))) 2500 FORMAT(/1X,'Subroutine NAOANL could not find a ',A1,'-type ', + 'core orbital on atom ',A2,I2,'.',/,1X,'ICORE :',4I3, + ' M :',I3,' LA :',I3) 2600 FORMAT(/1X,'Subroutine NAOANL could not find a ',A1,'-type ', + 'valence orbital on atom ',A2,I2,'.',/,1X,'IVAL :',4I3, + ' M :',I3,' LA :',I3) END ***************************************************************************** SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*80 TITLE PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),TMO(NDIM,NDIM),C(NDIM,NDIM), + SCR(NDIM*(NDIM+5)) DIMENSION BASIS(4) DATA BASIS/' NAO',' NHO',' NBO','NLMO'/ DATA ZERO/0.0D0/ Input: T -- transformation from AO basis to currect basis INDEX -- current basis = 2,3,4,5 (NAO,NHO,NBO,NLMO) IFLG -- number of columns of TMO to print or external LFN to write to Fetch the AO to MO transformation matrix: CALL FEAOMO(C,IT) IF(IT.EQ.0) RETURN Find the MO transformation matrix: ZERTOL = 1.0E-8 EPS = 1.0E-8 MAXIT = 10 LFN0 = 0 CALL LINEQ(T,TMO,C,SCR,NBAS,NBAS,NDIM,NDIM,ZERTOL,EPS,MAXIT, + LFN0,IERR) IF(IERR.NE.0) THEN WRITE(LFNPR,910) BASIS(INDEX-1) IF(IERR.EQ.1) WRITE(LFNPR,920) BASIS(INDEX-1) STOP END IF Make sure the largest coefficient in each column is positive: DO 30 KCOL = 1,NBAS TMAX = ZERO DO 10 JROW = 1,NBAS IF(ABS(TMO(JROW,KCOL)).GT.ABS(TMAX)) TMAX = TMO(JROW,KCOL) 10 CONTINUE IF(TMAX.LT.ZERO) THEN DO 20 JROW = 1,NBAS TMO(JROW,KCOL) = -TMO(JROW,KCOL) 20 CONTINUE END IF 30 CONTINUE Write or print the MO transformation matrix: IF(INDEX.EQ.2) TITLE = 'MOs in the NAO basis:' IF(INDEX.EQ.3) TITLE = 'MOs in the NHO basis:' IF(INDEX.EQ.4) TITLE = 'MOs in the NBO basis:' IF(INDEX.EQ.5) TITLE = 'MOs in the NLMO basis:' CALL AOUT(TMO,NDIM,NBAS,NBAS,TITLE,INDEX,IFLG) RETURN 910 FORMAT(/1X,'Error calculating the ',A4,' to MO transformation') 920 FORMAT(1X,'The AO to ',A4,' transformation is not invertible') END **************************************************************************** ROUTINES CALLED BY SR NAO: SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM) SUBROUTINE ATDIAG(N,A,B,EVAL,C) SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM) SUBROUTINE NEWWTS(S,T,WT) SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK) SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK) SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2, + LIST,IRPNAO) SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2, + IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO) SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT) SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO) SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,IRPNAO) ***************************************************************************** SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION S(NDIM,NDIM),LISTAO(MXAOLM,9),A(NL,NL),B(NL,NL) DATA ONE,ZERO/1.0D0,0.0D0/ AVERAGE THE AO DENSITY MATRIX ELEMENTS OVER THE M=2*L+1 COMPONENTS OF L FOR A PARTICULAR ATOM. LOAD DENSITY MATRIX ELEMENTS (UPPER TRIANGLE OF S, INCL. DIAGONAL) INTO A, OVERLAP MATRIX ELEMENTS (LOWER TRIANGLE OF S) INTO B, FOR ORBITALS OF 'LIST' DO 30 J=1,NL DO 20 I=1,J FIND AVERAGE DM ELEMENT OVER THE VALUES OF IM: SUM=ZERO DO 10 IM=1,M IAO=LISTAO(I,IM) JAO=LISTAO(J,IM) 10 SUM=SUM+S(IAO,JAO) AVE=SUM/M DENSITY MATRIX ELEMENTS INTO A: A(I,J)=AVE A(J,I)=AVE OVERLAP MATRIX ELEMENTS INTO B: B(I,J)=S(JAO,IAO) 20 B(J,I)=B(I,J) 30 B(J,J)=ONE RETURN END ***************************************************************************** SUBROUTINE ATDIAG(N,A,B,EVAL,C) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SOLVE GENERALIZED EIGENVALUE PROBLEM (A-EVAL*B)*C = 0. USE JACOBI TO DIAGONALIZE B**(-1/2)*A*B**(-1/2); A AND B ARE DESTROYED. DIMENSION A(N,N),B(N,N),EVAL(N),C(N,N) DATA ZERO,ONE/0.0D0,1.0D0/ FIRST FORM B**(-1/2) AND STORE IT IN B: CALL JACOBI(N,B,EVAL,C,N,N,0) DO 10 I=1,N 10 EVAL(I)=ONE/SQRT(EVAL(I)) DO 30 I=1,N DO 30 J=1,I TEMP=ZERO DO 20 K=1,N 20 TEMP=TEMP+EVAL(K)*C(I,K)*C(J,K) B(I,J)=TEMP 30 B(J,I)=TEMP NOW SIMILARITY TRANSFORM A WITH B: CALL SIMTRS(A,B,EVAL,N,N) DIAGONALIZE A: CALL JACOBI(N,A,EVAL,C,N,N,1) MULTIPLY B*C TO GET EIGENVECTORS FOR ORIGINAL PROBLEM, STORE IN A: DO 50 I=1,N DO 50 J=1,N TEMP=ZERO DO 40 K=1,N 40 TEMP=TEMP+B(I,K)*C(K,J) 50 A(I,J)=TEMP MOVE FINAL EIGENVECTORS TO C: CALL COPY(A,C,N,N,N) RETURN END ***************************************************************************** SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM) ***************************************************************************** Select the set of natural minimal basis (NMB) orbitals for a particular atom and angular symmetry type: (up to atomic number 105) ------------------------------------------------------------------------------ IMPLICIT REAL*8 (A-H,O-Z) DIMENSION LSTOCC(NDIM),LSTEMT(NDIM) DIMENSION ICORE(4),IVAL(4) If g orbitals or orbitals of even higher angular symmetry are selected, there are none in the NMB: IF(L.GE.4) GOTO 100 Find core and valence orbitals for this atom: IECP = 0 CALL CORTBL(IAT,ICORE,IECP) CALL VALTBL(IAT,IVAL) Determine the number of shells with angular symmetry L in the NMB. If there are a negative number of core orbitals, ignore them: NSHELL = MAX0(ICORE(L+1),0) + IVAL(L+1) IF(NSHELL.EQ.0) GOTO 100 Select sets of occupied and empty NAO's: DO 10 J = 1,NSHELL NOCC = NOCC + 1 LSTOCC(NOCC) = NF + J 10 CONTINUE LEFT = NL - NSHELL IF(LEFT.EQ.0) RETURN DO 20 J = 1,LEFT NEMT = NEMT + 1 LSTEMT(NEMT) = NF + NSHELL + J 20 CONTINUE RETURN No NMB `L'-type orbitals found for this atom: 100 CONTINUE DO 110 J = 1,NL NEMT = NEMT + 1 LSTEMT(NEMT) = NF + J 110 CONTINUE RETURN END ***************************************************************************** SUBROUTINE NEWWTS(S,T,WT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),WT(NDIM) CHARACTER*80 TITLE DATA ZERO/0.0D0/ RECOMPUTE OCCUPANCY WEIGHTS NOCC=0 DO 20 I=1,NBAS SUM=ZERO DO 10 J=1,NBAS DO 10 K=1,NBAS SJK=S(J,K) IF(J.GT.K) SJK=S(K,J) 10 SUM=SUM+T(J,I)*SJK*T(K,I) WT(I)=SUM REFORMAT LIST LSTOCC: IF(LSTOCC(I).EQ.0) GO TO 20 NOCC=NOCC+1 LSTOCC(NOCC)=I 20 CONTINUE NSTART=NOCC+1 DO 40 I=NSTART,NDIM 40 LSTOCC(I)=0 SYMMETRY-AVERAGE WEIGHTS: NL=1 IORB=0 100 IORB=IORB+NL IF(IORB.GT.NBAS) GO TO 600 NL=1 ILBL=NAOCTR(IORB) IL=NAOL(IORB)/100 NM=IL*2+1 IMAX=NBAS-IORB DO 130 IADD=1,IMAX JORB=IORB+IADD JORBL=NAOL(JORB)/100 IF(NAOCTR(JORB).NE.ILBL.OR.JORBL.NE.IL) GO TO 140 130 NL=NL+1 140 NC=NL/NM DO 500 I=1,NC SUM=ZERO DO 300 M=1,NM INAO=IORB+(I-1)+(M-1)*NC 300 SUM=SUM+WT(INAO) AV=SUM/NM DO 400 M=1,NM INAO=IORB+(I-1)+(M-1)*NC 400 WT(INAO)=AV 500 CONTINUE GO TO 100 600 CONTINUE TITLE = 'New symmetry-averaged occupancy weights:' CALL AOUT(WT,NBAS,NBAS,1,TITLE,-1,1) RETURN END ***************************************************************************** SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) ****************************************************************** WORTH: OCCUPANCY WEIGHTED ORTHOGONALIZATION SUBROUTINE S: FULL OVERLAP MATRIX (PURE AO BASIS) (NOTE: UPPER TRIANGLE USED FOR SCRATCH, BUT RESTORED AGAIN) T: PURE AO TO PRE-NAO TRANSFORMATION LIST: LIST OF ORBITALS TO BE ORTHOGONALIZED N: NUMBER OF ORBITALS IN LIST OCC: LIST OF SYMMETRY AVERAGED OCCUPANCY WEIGHTINGS NOTE: BLK AND BIGBLK SHARE THE SAME STORAGE BUT ARE DIMENSIONED DIFFERENTLY. ****************************************************************** DIMENSION S(NDIM,NDIM),T(NDIM,NDIM),BLK(N,N) DIMENSION OCC(NDIM),LIST(NDIM),EVAL(NDIM),BIGBLK(NDIM,NDIM) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA ZERO,ONE/0.0D0,1.0D0/ DATA NTIME/0/ IMPORTANT CONSTANTS: WTTHR ALL WEIGHTING FACTORS SMALLER THAN WTTHR ARE SET TO THE VALUE OF WTTHR. DIAGTH THRESHOLD FOR MATRIX DIAGONALIZATION USED IN SUBROUTINE JACOBI. IN JACOBI, THIS CONSTANT IS CALLED "DONETH". DANGER CRITERION FOR DECIDING THAT THE JOB SHOULD BE ABORTED DUE TO NUMERICAL PROBLEMS CAUSED BY NEAR LINEAR DEPENDENCIES IN THE BASIS SET. ALL EIGENVALUES OF THE WEIGHTED OVERLAP MATRIX MUST BE GREATER THAN DIAGTH*DANGER. DATA WTTHR,DIAGTH,DANGER/1.0D-3,1.0D-12,1.0D3/ NTIME=NTIME+1 MULTIPLY THE WEIGHT BY A CONSTANT SO THAT THE MAXIMUM WEIGHT IS ONE, AND SET ANY RESULTING WEIGHT THAT IS LESS THAN WTTHR TO THE VALUE OF WTTHR: WTMAX=ZERO DO 10 I=1,N IP=LIST(I) IF(OCC(IP).GT.WTMAX) WTMAX=OCC(IP) 10 CONTINUE DO 20 I=1,N IP=LIST(I) EVAL(IP)=OCC(IP)/WTMAX IF(EVAL(IP).LT.WTTHR) EVAL(IP)=WTTHR 20 CONTINUE FORM THE WEIGHTED PRE-NAO VECTORS: DO 30 J=1,N JP=LIST(J) DO 30 I=1,NBAS 30 T(I,JP)=T(I,JP)*EVAL(JP) FORM THE WEIGHTED OVERLAP MATRIX OF THE VECTORS IN THE UPPER TRIANGLE OF S: DO 70 I=1,N IP=LIST(I) DO 70 J=1,NBAS SIJ=ZERO DO 40 K=1,NBAS TKI=T(K,IP) IF(TKI.EQ.ZERO) GO TO 40 SIJ=SIJ+TKI*S(K,J) 40 CONTINUE 70 BIGBLK(J,I)=SIJ DO 100 I=1,N DO 100 J=1,I JP=LIST(J) SIJ=ZERO DO 90 K=1,NBAS TKJ=T(K,JP) IF(TKJ.EQ.ZERO) GO TO 90 SIJ=SIJ+BIGBLK(K,I)*TKJ 90 CONTINUE 100 S(J,I)=SIJ DIAGONALIZE S-TILDE (THE WEIGHTED OVERLAP MATRIX): CALL JACOBI(N,S,EVAL,BLK,NDIM,N,0) FORM THE INVERSE SQRT OF THE OVERLAP MATRIX OF THESE WEIGHTED VECTORS: SMLEST=ONE TOOSML=DIAGTH*DANGER DO 150 I=1,N EIGENV=EVAL(I) IF(EIGENV.LT.TOOSML) GO TO 900 EVAL(I)=ONE/SQRT(EIGENV) IF(EIGENV.LT.SMLEST) SMLEST=EIGENV 150 CONTINUE DO 170 I=1,N DO 170 J=1,I SIJ=ZERO DO 160 K=1,N 160 SIJ=SIJ+EVAL(K)*BLK(I,K)*BLK(J,K) 170 S(J,I)=SIJ THE UPPER TRIANGLE OF S (INCLUDING THE DIAGONAL) NOW CONTAINS THE -0.5 POWER OF THE WEIGHTED OVERLAP MATRIX, AND IS THE WEIGHTED ORTHOG. TRANSFORM THAT WE WANT. NOW, FORM THE TOTAL TRANSFORMATION: DO 300 I=1,NBAS DO 260 J=1,N EVAL(J)=ZERO DO 220 K=1,J KP=LIST(K) TIK=T(I,KP) IF(TIK.EQ.ZERO) GO TO 220 EVAL(J)=EVAL(J)+TIK*S(K,J) 220 CONTINUE JP1=J+1 DO 240 K=JP1,N KP=LIST(K) TIK=T(I,KP) IF(TIK.EQ.ZERO) GO TO 240 EVAL(J)=EVAL(J)+TIK*S(J,K) 240 CONTINUE 260 CONTINUE DO 280 J=1,N JP=LIST(J) 280 T(I,JP)=EVAL(J) 300 CONTINUE RESTORE FULL OVERLAP MATRIX S: DO 400 I=1,NBAS IM1=I-1 DO 380 J=1,IM1 380 S(J,I)=S(I,J) 400 S(I,I)=ONE RETURN 900 WRITE(LFNPR,1000) EIGENV,TOOSML STOP 1000 FORMAT(//1X,'An eigenvalue of the weighted PRE-NAO overlap', +' matrix of ',F10.5,' has been',/,1X,'found, which is lower than', +' the allowed threshold of ',F10.5,'. This is',/,1X,'probably', +' caused by either an error in the data given to the analysis', +' program',/,1X,'or by numerical problems caused by near linear', +' dependencies among the basis',/,1X,'functions.') END ***************************************************************************** SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SCHMIDT ORTHOGONALIZATION OF COLUMN VECTORS IN T SCHMIDT ORTHOGONALIZE EACH EMPTY ORBITAL (SPECIFIED IN 'LSTEMT') TO THE ORTHONORMAL OCCUPIED (LSTOCC) ORBITALS; DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),LSTOCC(NDIM),LSTEMT(NDIM), * SBLK(NDIM,NDIM) DATA ZERO/0.0D0/ DO 30 I=1,NBAS DO 30 J=1,NOCC JP=LSTOCC(J) SJI=ZERO DO 10 K=1,NBAS 10 SJI=SJI+T(K,JP)*S(K,I) 30 SBLK(I,J)=SJI SCHMIDT ORTHOGONALIZE EACH UNOCCUPIED /UI> TO EACH /VJ>: ...LOOP OVER UNOCCUPIED /UI>'S, DO 120 I=1,NEMT IP=LSTEMT(I) ...LOOP OVER OCCUPIED /VJ>'S, DO 60 J=1,NOCC JP=LSTOCC(J) ...CALCULATE SJI = , SJI=ZERO DO 40 K=1,NBAS 40 SJI=SJI+SBLK(K,J)*T(K,IP) ...AND REPLACE EACH /UI> = /UI> - SJI*/VJ>. DO 50 K=1,NBAS 50 T(K,IP)=T(K,IP)-SJI*T(K,JP) 60 CONTINUE 120 CONTINUE RETURN END ***************************************************************************** SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2, * LIST,IRPNAO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),TPNAO(NDIM,NDIM),OCC(NDIM), + DMBLK(MXAOLM,MXAOLM),SBLK(MXAOLM,MXAOLM),EVAL(NBAS), + EVECT(MXAOLM,MXAOLM),EVAL2(NBAS),LIST(MXAOLM) DATA ONE/1.0D0/ COMPUTE NEW RYDBERG NAOS AFTER THE SCHMIDT ORTHOGONALIZATION TO THE MINIMAL NAO SET HAS BEEN DONE: IF REQUESTED (IRPNAO=JPRINT(11)=1), UPDATE PNAO TRANSFORMATION WITH TRYD: IF(IRPNAO.EQ.1) CALL FEPNAO(TPNAO) NL=1 IORB=0 100 IORB=IORB+NL IF(IORB.GT.NBAS) GO TO 300 NL=1 ILBL=NAOCTR(IORB) IL=NAOL(IORB)/100 NM=IL*2+1 IMAX=NBAS-IORB DO 130 IADD=1,IMAX JORB=IORB+IADD JORBL=NAOL(JORB)/100 IF(NAOCTR(JORB).NE.ILBL.OR.JORBL.NE.IL) GO TO 140 130 NL=NL+1 140 NC=NL/NM NSKIP=0 IMAX=IORB-1+NC DO 150 I=1,NBAS INAO=LSTOCC(I) IF(INAO.LT.IORB.OR.INAO.GT.IMAX) GO TO 150 NSKIP=NSKIP+1 150 CONTINUE IF(NSKIP.EQ.NC) GO TO 100 NSTART=NSKIP+1 NRYDC=NC-NSKIP CALL RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2, * IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO) END OF LOOP STARTING AT 100 GO TO 100 300 CONTINUE RESTORE S: DO 350 I=1,NBAS IM1=I-1 DO 340 J=1,IM1 340 S(J,I)=S(I,J) 350 S(I,I)=ONE SAVE UPDATED T-PNAO TRANSFORMATION: IF(IRPNAO.EQ.1) CALL SVPNAO(TPNAO) RETURN END ***************************************************************************** SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2, * IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),TPNAO(NDIM,NDIM),OCC(NBAS), * DMBLK(NRYDC,NRYDC),SBLK(NRYDC,NRYDC),EVAL(NBAS), * EVECT(NRYDC,NRYDC),LARC(NRYDC),LIST(NRYDC),EVAL2(NBAS) DATA ZERO/0.0D0/ DIAGONALIZE ONE RYDBERG BLOCK, UPDATE T-NAO (IN T) AND, IF IRPNAO.EQ.1, UPDATE TPNAO: II=0 DO 20 I=1,NRYDC DO 20 J=1,NRYDC DMBLK(I,J)=ZERO SBLK(I,J)=ZERO 20 CONTINUE DO 500 I=NSTART,NC II=II+1 DO 300 M=1,NM INAO=IORB+(I-1)+(M-1)*NC DO 140 K=1,NBAS DMSUM=ZERO SSUM=ZERO KM1=K-1 DO 100 L=1,KM1 TLI=T(L,INAO) DMSUM=DMSUM+TLI*S(L,K) 100 SSUM=SSUM+TLI*S(K,L) TKI=T(K,INAO) DMSUM=DMSUM+TKI*S(K,K) SSUM=SSUM+TKI KP1=K+1 DO 120 L=KP1,NBAS TLI=T(L,INAO) DMSUM=DMSUM+TLI*S(K,L) 120 SSUM=SSUM+TLI*S(L,K) EVAL(K)=DMSUM EVAL2(K)=SSUM 140 CONTINUE JJ=0 DO 240 J=NSTART,I JJ=JJ+1 JNAO=IORB+(J-1)+(M-1)*NC DMSUM=ZERO SSUM=ZERO DO 200 K=1,NBAS TKJ=T(K,JNAO) DMSUM=DMSUM+EVAL(K)*TKJ 200 SSUM=SSUM+EVAL2(K)*TKJ DMBLK(II,JJ)=DMBLK(II,JJ)+DMSUM SBLK(II,JJ)=SBLK(II,JJ)+SSUM 240 CONTINUE 300 CONTINUE DO 350 JJ=1,II DMBLK(II,JJ)=DMBLK(II,JJ)/NM DMBLK(JJ,II)=DMBLK(II,JJ) SBLK(II,JJ)=SBLK(II,JJ)/NM 350 SBLK(JJ,II)=SBLK(II,JJ) 500 CONTINUE CALL ATDIAG(NRYDC,DMBLK,SBLK,EVAL,EVECT) CALL RANK(EVAL,NRYDC,NRYDC,LARC) DO 600 J=1,NRYDC JC=LARC(J) DO 600 I=1,NRYDC 600 SBLK(I,J)=EVECT(I,JC) DO 700 M=1,NM JJ=0 DO 680 J=NSTART,NC JJ=JJ+1 JNAO=IORB+(J-1)+(M-1)*NC OCC(JNAO)=EVAL(JJ) LIST(JJ)=JNAO 680 CONTINUE USE LIMTRN TO UPDATE T: CALL LIMTRN(T,LIST,SBLK,DMBLK,NDIM,NBAS,NRYDC,NRYDC,1) 700 CONTINUE IF(IRPNAO.EQ.0) RETURN UPDATE TPNAO, BUT DO THIS IN SUCH A WAY THAT THE INTRA-ATOMIC BLOCKS OF THE OVERLAP MATRIX IN THE REVISED PNAO MATRIX REMAIN DIAGONAL AND THAT THE PNAOS REMAIN NORMALIZED. IN ORDER TO ACCOMPLISH THIS, WE MUST LOWDIN-ORTHOGONALIZE THE RYDBERG TRANSFORMATION IN "SBLK": CALL SYMORT(EVECT,SBLK,DMBLK,NRYDC,NRYDC,EVAL) DO 800 M=1,NM JJ=0 DO 780 J=NSTART,NC JJ=JJ+1 LIST(JJ)=IORB+(J-1)+(M-1)*NC 780 CONTINUE CALL LIMTRN(TPNAO,LIST,SBLK,DMBLK,NDIM,NBAS,NRYDC,NRYDC,1) 800 CONTINUE RETURN END ***************************************************************************** SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION WT(NDIM),LIST1(NBAS),LIST2(NBAS),LSTEMT(NBAS) DATA ONE,WTTHR/1.0D0,1.0D-4/ DIVIDE THE RYDBERG ORBITALS INTO 2 GROUPS: LIST1: RYDBERGS OF SIGNIFICANT OCCUPANCY ( .GT.WTTHR ) LIST2: RYDBERGS OF VERY LOW OCCUPANCY ( .LT.WTTHR ) WTTHR IS SET TO 0.0001 SET THE WEIGHTINGS OF THE RYDBERGS IN LIST2 TO ONE SO THAT THE WEIGHTED ORTHOGONALIZATION THAT WILL LATER BE DONE AMONG THESE ORBITALS WILL BE IN FACT A LOWDIN ORTHOG. NSEL1=0 NSEL2=0 DO 100 I=1,NEMT IRYD=LSTEMT(I) IF(WT(IRYD).LT.WTTHR) GO TO 50 NSEL1=NSEL1+1 LIST1(NSEL1)=IRYD GO TO 100 50 CONTINUE NSEL2=NSEL2+1 LIST2(NSEL2)=IRYD WT(IRYD)=ONE 100 CONTINUE RETURN END ***************************************************************************** SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LDEG(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),TPNAO(NDIM,NDIM), + C(MXAOLM,MXAOLM),EVAL(NDIM),BLK(MXAOLM,MXAOLM),IRANK(NBAS) REDIAGONALIZE THE SYMMETRY AVERAGED DM SUBBLOCKS FOR EACH ANGULAR SYMMETRY ON EACH ATOM: READ IN OLD T-PNAO INTO TPNAO SO THAT IT CAN BE UPDATED (IF IRPNAO.EQ.1): IF(IRPNAO.EQ.1) CALL FEPNAO(TPNAO) NF = 0 IORB = 0 NL = 1 10 IORB = IORB + NL IF(IORB.GT.NBAS) GO TO 100 NL = 1 ILBL = NAOCTR(IORB) IL = NAOL(IORB)/100 NM = IL*2 + 1 IMAX = NBAS - IORB DO 30 IADD = 1,IMAX JORB = IORB + IADD JORBL = NAOL(JORB)/100 IF((NAOCTR(JORB).NE.ILBL).OR.(JORBL.NE.IL)) GO TO 40 30 NL = NL + 1 40 NC = NL/NM IF(NC.EQ.1) GO TO 80 CALL REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK, * IRPNAO) GO TO 10 80 DO 90 M = 1,NM NF = NF + 1 90 CONTINUE GO TO 10 100 CONTINUE IF(IRPNAO.EQ.0) RETURN SAVE NEW T-PNAO FROM TPNAO: CALL SVPNAO(TPNAO) RETURN END ***************************************************************************** SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK, * IRPNAO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LDEG(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION DM(NDIM,NDIM),BLK(NC,NC),C(NC,NC),EVAL(NDIM), + T(NDIM,NDIM),TPNAO(NDIM,NDIM),IRANK(NBAS) DATA ZERO/0.0D0/ FIND THE REDIAGONALIZATION TRANSFORMATION FOR THE DM SUBBLOCK FOR THE ANGULAR MOMENTUM "IL" ON AN ATOM, PUT IN T2: NM = IL*2 + 1 DO 30 J = 1,NC DO 30 I = 1,J SUM = ZERO DO 10 M = 1,NM INAO = IORB + I-1 + (M-1)*NC JNAO = IORB + J-1 + (M-1)*NC 10 SUM = SUM + DM(INAO,JNAO) AVE = SUM/NM BLK(I,J) = AVE 30 BLK(J,I) = AVE CALL JACOBI(NC,BLK,EVAL,C,NC,NC,1) CALL RANK(EVAL,NC,NC,LARC) DO 80 J = 1,NC JC = LARC(J) DO 80 I = 1,NC 80 BLK(I,J) = C(I,JC) DO 110 M = 1,NM DO 100 J = 1,NC NF = NF + 1 100 IRANK(J) = NF CALL LIMTRN(T,IRANK,BLK,C,NDIM,NBAS,NC,NC,1) CALL LIMTRN(DM,IRANK,BLK,C,NDIM,NBAS,NC,NC,0) IF(IRPNAO.EQ.1) CALL LIMTRN(TPNAO,IRANK,BLK,C,NDIM,NBAS,NC,NC,1) 110 CONTINUE RETURN END **************************************************************************** ROUTINES CALLED BY THE NBO/NLMO DRIVERS: SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO) SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO) SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, + P,TA,HYB,VA,VB,TOPO,IFLG) SUBROUTINE SRTNBO(T,BNDOCC) SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR) SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB) SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN) SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB) SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR) SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB) SUBROUTINE FNDMOL(IATOMS) SUBROUTINE NBOCLA(BNDOCC,ACCTHR) SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO) SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR) SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG) SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR) SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM) SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,SIAB,NOCC,NAB) SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX) SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX) SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC) **************************************************************************** SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, * P,TA,HYB,VA,VB,TOPO) **************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) Construct orthogonal matrix T for transformation from AO's to Natural Hybrid Bond Orbitals using input density matrix DM. REQUIRED INPUT INCLUDES: DM = DENSITY MATRIX IN ORTHONORMAL ATOMIC ORBITAL BASIS; REAL(1,NDIM;1,NDIM) NBAS = NO. OF ORBITALS = ACTUAL DIMENSION OF DM,S,T,NAOL,DMT NATOMS = NO. OF ATOMS (NOT INCLUDING GHOSTS) IN THE MOLECULE IATNO = LIST OF ATOMIC NUMBERS NAOCTR = ORBITAL LABEL LIST. NAOCTR(I)=IAT IF NAO # I IS ON ATOM IAT INTEGER(1,NDIM). NAOS OF GIVEN ATOM GROUPED TOGETHER. IW3C = 1 IF PROGRAM IS TO SEARCH FOR 3-CENTER BONDS, = 0 OTHERWISE GUIDE = WIBERG ATOM-ATOM BOND INDEX MATRIX, USED AS GUIDE FOR NBO SEARCH OUTPUT: T = BOND ORBITAL TRANSFORMATION MATRIX (NDIM,NDIM). ROWS ARE LABELLED BY NAOS, COLUMNS BY NBOS. LABEL = LIST OF BOND ORBITAL LABELS IBXM = PERMUTATION LIST OF BOND ORBITAL LABELS (VERY IMPORTANT!) LOGICAL DETAIL,NOBOND,FIRST LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO INTEGER UL PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM), + N3CTR,I3CTR(10,3) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),V(NDIM),BORB(MXBO), * POL(NDIM,3),BNDOCC(NDIM),NAME(3),HYBEXP(3), * Q(MXAO,NDIM),BLK(MXBO,MXBO),EVAL(MXBO),C(MXBO,MXBO), * P(MXAO,MXAO),TA(MXAO,MXAO),HYB(MXAO),VA(MXAO),VB(MXAO), * GUIDE(NATOMS,NATOMS),TOPO(NATOMS*NATOMS) DATA GTHRSH/1.5D-1/ DATA ISTAR,IBLNK/'*',' '/ DATA NAME/'LP','BD','3C'/ DATA LRY,LCR/'RY','CR'/ DATA ZERO,ZEROP,TENTH,ONE,TWO,FOUR * /0.D0,1.D-6,0.1D0,1.0D0,2.0D0,4.0D0/ DATA TWOP/2.0001D0/ DATA PT8,PT99/0.8D0,0.99D0/ PRJINC, the amount to increase PRJTHR by if problems with linear dependency between the hybrids arise. DATA PRJINC/0.05D0/ NOPVAL(I) = NORBS(I) - INO(I) DETAIL = .FALSE. IF(IWDETL.NE.0) DETAIL = .TRUE. NOBOND = .FALSE. IF(JPRINT(10).NE.0) NOBOND = .TRUE. Initial iteration loop: If no satisfactory Lewis structure (all antibond occupancies < 0.1) for THRESH = 1.90, THRESH is decremented up to 4 times by 0.1 in search of a better structure. If the DM is not spinless, THRESH is set to 0.90 and is decremented as above. PRJTHR = ABS(PRJSET) THRESH = ABS(THRSET) IF(ISPIN.NE.0) THRESH = THRESH - ONE IF(NOBOND) THRESH = ONE IF(NOBOND.AND.(ISPIN.NE.0)) THRESH = ONE/TWO IF(ISPIN.NE.0) GTHRSH = GTHRSH/FOUR Determine the atom ordering for the initial search for bonds: IF(NATOMS.EQ.1) THEN IORDER(1) = 1 GOTO 45 END IF Find the two atoms which have the largest bond index: GMAX = ZERO DO 10 J = 2,NATOMS DO 5 I = 1,J-1 IF(GUIDE(I,J).GT.GMAX) THEN GMAX = GUIDE(I,J) IAT = I END IF 5 CONTINUE 10 CONTINUE IORDER(1) = IAT Add atoms to IORDER according to these connectivities: ICNT = 1 INXT = ICNT JCNT = ICNT 15 IPTR = INXT I1ST = 1 DO 20 I = 1,NATOMS TOPO(I) = GUIDE(I,IORDER(IPTR)) 20 CONTINUE CALL RANK(TOPO,NATOMS,NATOMS,JORDER) JPTR = 1 25 IF(TOPO(JPTR).GT.PT8) THEN IFLG = 1 DO 30 I = 1,ICNT IF(IORDER(I).EQ.JORDER(JPTR)) IFLG = 0 30 CONTINUE IF(IFLG.EQ.1) THEN ICNT = ICNT + 1 IORDER(ICNT) = JORDER(JPTR) IF(I1ST.EQ.1) THEN I1ST = 0 INXT = ICNT END IF END IF ELSE GOTO 35 END IF JPTR = JPTR + 1 GOTO 25 35 CONTINUE IF(I1ST.EQ.1) THEN JCNT = JCNT + 1 INXT = JCNT IF(INXT.GT.NATOMS) GOTO 45 IF(INXT.GT.ICNT) THEN KPTR = 0 40 KPTR = KPTR + 1 KFLG = 1 DO 41 I = 1,ICNT IF(IORDER(I).EQ.KPTR) KFLG = 0 41 CONTINUE IF(KFLG.EQ.0) GOTO 40 ICNT = ICNT + 1 IORDER(ICNT) = KPTR END IF END IF GOTO 15 45 CONTINUE ITER = 0 IALARM = 0 50 IF(IALARM.EQ.0) ITER = ITER + 1 Store density matrix in upper triangle of T: DO 60 J = 1,NBAS DO 60 I = 1,J 60 T(I,J) = DM(I,J) Zero arrays Q, POL, IATHY, INO, and LABEL: DO 100 I = 1,NBAS DO 70 K = 1,2 70 LABEL(I,K) = IBLNK DO 80 K = 3,6 80 LABEL(I,K) = 0 DO 90 K = 1,3 POL(I,K) = ZERO 90 IATHY(I,K) = 0 DO 100 K = 1,MXAO 100 Q(K,I) = ZERO DO 110 I = 1,NATOMS 110 INO(I) = 0 Remove core orbitals from the density matrix: IBD = 0 CALL CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR) Main NHO loops -------------- Doubly occupied (IOCC=1) or singly occupied (IOCC=2) NHO's If ISPIN.NE.0, search is only for singly occupied nbos (IOCC=1): OCCMX = THRESH Main NHO loops over singles, doubles, and triples of atoms: NA1 = NATOMS + 1 DO 310 IA1 = 1,NA1 IA = IA1 - 1 IF((IA.GT.0).AND.(NOPVAL(IORDER(IA)).LE.0)) GO TO 310 DO 300 IB1 = 1,NA1 IB = IB1 - 1 IF((IB.GT.0).AND.(NOPVAL(IORDER(IB)).LE.0)) GO TO 300 DO 290 IC1 = 2,NA1 IC = IC1 - 1 IF((IC.GT.0).AND.(NOPVAL(IORDER(IC)).LE.0)) GO TO 290 IF(IA.NE.0) GO TO 130 IF(IB.NE.0) GO TO 120 Lone pairs: NCTR = 1 IAT1 = IORDER(IC) IAT2 = 0 IAT3 = 0 GO TO 140 Bond pairs: 120 CONTINUE IF(NOBOND) GO TO 290 NCTR = 2 IAT1 = IORDER(IB) IAT2 = IORDER(IC) IAT3 = 0 IF(IAT1.GE.IAT2) GO TO 290 IF(GUIDE(IAT1,IAT2).LT.GTHRSH) GO TO 290 GO TO 140 3-center bonds: 130 CONTINUE IF(IW3C.NE.1) GO TO 320 NCTR = 3 IAT1 = IORDER(IA) IAT2 = IORDER(IB) IAT3 = IORDER(IC) IF(IAT1.GE.IAT2) GO TO 300 IF(IAT2.GE.IAT3) GO TO 290 IF(GUIDE(IAT1,IAT2).GT.GTHRSH) GO TO 140 IF(GUIDE(IAT1,IAT3).GT.GTHRSH) GO TO 140 IF(GUIDE(IAT2,IAT3).GT.GTHRSH) GO TO 140 GO TO 290 140 CONTINUE Deplete DM of one(two) center orbitals if search for two(three) center orbitals is beginning: IF(IWPRJ(NCTR).NE.0) * CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD) Load proper atomic blocks of DM into BLK: CALL LOAD(DM,IAT1,IAT2,IAT3,BLK,NB) Diagonalize BLK: CALL JACOBI(NB,BLK,EVAL,C,MXBO,MXBO,1) Rank eigenvectors by occupancy eigenvalue: CALL RANK(EVAL,NB,MXBO,LARC) IF(DETAIL) WRITE(LFNPR,1400) IAT1,IAT2,IAT3 IF(DETAIL) WRITE(LFNPR,1403) THRESH IF(DETAIL) WRITE(LFNPR,1405) (EVAL(IRNK),IRNK=1,NB) IACCEP = 0 DO 250 IRNK = 1,NB IR = LARC(IRNK) OCC = EVAL(IRNK) DO 200 I = 1,NB 200 BORB(I) = C(I,IR) IF(DETAIL) WRITE(LFNPR,1410) IRNK,OCC IF(DETAIL) WRITE(LFNPR,1420) (BORB(I),I=1,NB) Throw out orbital if occupancy is less than the threshhold "OCCMX": IF(OCC.LT.OCCMX) GO TO 280 Check to see that bond orbital "BORB" doesn't contain previously used hybrids: IF(NCTR.EQ.1) GO TO 240 CALL PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,TA,HYB,VA,VB,HYBEXP) IF(.NOT.DETAIL) GO TO 220 DO 210 IHYB = 1,NCTR 210 WRITE(LFNPR,1500) IHYB,HYBEXP(IHYB) 220 CONTINUE DO 230 IHYB = 1,NCTR 230 IF(HYBEXP(IHYB).LT.PRJTHR) GO TO 250 240 CONTINUE IBD = IBD + 1 IACCEP = IACCEP + 1 Decompose "BORB" into its constituent atomic hybrids and store in Q: CALL STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB) Construct bond orbital labels: LABEL(IBD,1) = NAME(NCTR) LABEL(IBD,2) = IBLNK LABEL(IBD,3) = IACCEP LABEL(IBD,4) = IAT1 LABEL(IBD,5) = IAT2 LABEL(IBD,6) = IAT3 BNDOCC(IBD) = OCC IF(DETAIL) WRITE(LFNPR,1600) IBD,(LABEL(IBD,I),I=1,3) 250 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE 310 CONTINUE 320 CONTINUE Symmetric orthogonalization of principal hybrids: CALL ORTHYB(Q,BLK,TA,EVAL,C,IALARM,0) IALARM sounds the alarm that there is linear dependency between some of the hybrids. The remedy is to increase prjthr and repeat the NBO search. IALARM is equal to the number of the violating atom. IF(IALARM.NE.0) THEN OLDPRJ = PRJTHR PRJTHR = OLDPRJ + PRJINC IF(JPRINT(5).NE.0) WRITE(LFNPR,1800) OLDPRJ,PRJTHR IF(PRJTHR.GE.PT99) THEN WRITE(LFNPR,1810) IALARM JPRINT(1) = -1 RETURN END IF GOTO 700 END IF Augment open-valence atoms with non-arbitrary hybrids orthogonal to those found previously: DO 580 IA = 1,NATOMS IF(NOPVAL(IA).LE.0) GO TO 580 IULA: upper limit of NAOs on atom. Find NMB, the number of natural minimal basis functions on the atom: LLA = LL(IA) IULA = UL(IA) NMB = 0 DO 470 I = LLA,IULA IF(LSTOCC(I).EQ.1) NMB = NMB + 1 470 CONTINUE Find the number of bond, core, and lone pair hybrids on the atom, IOCC: Also find IOCCLP, number of lone pair orbitals already found on IA, for use in labelling the extra lone pairs below: IOCC = 0 IOCCLP = 0 DO 480 IB = 1,IBD IF((LABEL(IB,4).NE.IA).AND.(LABEL(IB,5).NE.IA).AND. * (LABEL(IB,6).NE.IA)) GO TO 480 IOCC = IOCC + 1 IF(LABEL(IB,1).EQ.NAME(1)) IOCCLP = IOCCLP + 1 480 CONTINUE NEXLP: number of extra (low occupancy) LP orbitals on atom IAT. (This is the number of low occupancy orbitals with valence shell character) Set NEXLP to zero if (NMB-IOCC) is less than zero in order that the orbitals are not miscounted!! NEXLP = NMB - IOCC IF(NEXLP.LT.0) NEXLP = 0 NOCC = INO(IA) CALL FRMPRJ(P,IA,Q,NOCC,TA,VA,VB) NORB = NORBS(IA) NAUGM = NORB - NOCC CALL AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB) Stash and label extra lone pairs that AUGMNT put in BLK: (These ar taken to be the highest occupied orbitals, which AUGMNT places first) DO 510 IAUGM = 1,NEXLP DO 500 J = 1,NORB 500 BORB(J) = BLK(J,IAUGM) IBD = IBD + 1 CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB) LABEL(IBD,1) = NAME(1) LABEL(IBD,2) = IBLNK LABEL(IBD,3) = IAUGM + IOCCLP LABEL(IBD,4) = IA LABEL(IBD,5) = 0 LABEL(IBD,6) = 0 510 CONTINUE Stash and label the Rydberg orbitals that AUGMNT put in BLK: IRYD = 0 NSTART = NEXLP + 1 DO 540 IAUGM = NSTART,NAUGM DO 530 J = 1,NORB 530 BORB(J) = BLK(J,IAUGM) IBD = IBD + 1 IRYD = IRYD + 1 CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB) LABEL(IBD,1) = LRY LABEL(IBD,2) = ISTAR LABEL(IBD,3) = IRYD LABEL(IBD,4) = IA LABEL(IBD,5) = 0 LABEL(IBD,6) = 0 540 CONTINUE 580 CONTINUE Include antibond labels: IBO = IBD DO 660 I = 1,IBO Exit loop if LABEL(I,1) is 'LP', 'RY', or 'CR': IF(LABEL(I,1).EQ.NAME(1)) GO TO 660 IF(LABEL(I,1).EQ.LRY) GO TO 660 IF(LABEL(I,1).EQ.LCR) GO TO 660 NAB = 1 IF(LABEL(I,1).EQ.NAME(3)) NAB = 2 DO 650 IAB = 1,NAB IBD = IBD + 1 DO 640 J = 1,6 640 LABEL(IBD,J) = LABEL(I,J) LABEL(IBD,2) = ISTAR 650 CONTINUE 660 CONTINUE Replace density matrix DM from T: 700 CONTINUE DO 740 J=1,NBAS DO 740 I=1,J DM(I,J)=T(I,J) DM(J,I)=DM(I,J) T(J,I)=ZERO 740 T(I,J)=ZERO Remember the alarm! IF(IALARM.NE.0) GO TO 50 Miscounted bond orbitals...exit for open shell: IF(IBD.NE.NBAS) THEN WRITE(LFNPR,1200) THRESH,IBD,NBAS WRITE(LFNPR,1210) (I,(LABEL(I,J),J=1,6),I=1,IBD) STOP END IF Find new polarization parameters for orthonormal hybrids: CALL REPOL(DM,Q,POL,BLK,EVAL,C,IBD) Form final T-NAB (NAO to NBO transformation) from orthonormal hybrids: CALL FORMT(T,Q,POL) Find occupancies, find total number of electrons and occupied orbitals: TOTELE = ZERO DO 800 I = 1,NBAS OCCI = ZERO DO 790 J = 1,NBAS DO 790 K = 1,NBAS 790 OCCI = OCCI + T(J,I) * DM(J,K) * T(K,I) IF(ABS(OCCI).LT.ZEROP) OCCI = ZERO IF(OCCI.GT.TWOP) GO TO 960 ZEROPM = -ZEROP IF(OCCI.LT.ZEROPM) GO TO 960 BNDOCC(I) = OCCI V(I) = OCCI TOTELE = TOTELE + BNDOCC(I) 800 CONTINUE NEL = TOTELE + TENTH IF(ABS(TOTELE-NEL).GT.5E-4) GO TO 970 TOTELE = NEL NOCC = NEL IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2) Make sure all but the NOCC highest occupied NBOs are starred: CALL RANK(V,NBAS,NDIM,LARC) DO 804 I = 1,NOCC IR = LARC(I) LABEL(IBXM(IR),2) = IBLNK 804 CONTINUE DO 805 I = NOCC+1,NBAS IR = LARC(I) LABEL(IBXM(IR),2) = ISTAR 805 CONTINUE Determine whether this is a good resonance structure: CALL CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT) IF(ICONT.EQ.0) THEN JPRINT(1) = -1 RETURN END IF IF(ICONT.EQ.-1) GO TO 50 IF(ICONT.EQ.1) GO TO 50 Before final return, write out info about core orbitals which were isolated in subroutine CORE: CRTHRS = CRTSET IF(ISPIN.NE.0) CRTHRS = CRTHRS - ONE FIRST = .TRUE. DO 952 IAT = 1,NATOMS ILOW = 0 DO 951 I = 1,NBAS IF(LABEL(IBXM(I),1).EQ.LCR.AND.LABEL(IBXM(I),4).EQ.IAT + .AND.BNDOCC(I).LT.CRTHRS) ILOW = ILOW + 1 951 CONTINUE IF(ILOW.NE.0) THEN IF(FIRST) THEN FIRST = .FALSE. NAM = NAMEAT(IATNO(IAT)) IF(ILOW.NE.1) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,3010) ILOW,CRTHRS,NAM,IAT ELSE IF(JPRINT(5).EQ.1) WRITE(LFNPR,3011) ILOW,CRTHRS,NAM,IAT END IF ELSE NAM = NAMEAT(IATNO(IAT)) IF(ILOW.NE.1) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,3020) ILOW,CRTHRS,NAM,IAT ELSE IF(JPRINT(5).EQ.1) WRITE(LFNPR,3021) ILOW,CRTHRS,NAM,IAT END IF END IF END IF 952 CONTINUE RETURN Problems with a bond orbital occupancy: 960 WRITE(LFNPR,1300) OCCI JPRINT(1) = -1 RETURN Total number of electrons is not an integer: 970 WRITE(LFNPR,1310) TOTELE JPRINT(1) = -1 RETURN 1200 FORMAT(/,1X,'For an occupancy threshold of ',F4.2,' the search', + ' for NBOs found',/,1X,I3,' orbitals orbitals rather than ',I4) 1210 FORMAT(3X,'Label ',I3,':',A3,A1,I2,3I3) 1300 FORMAT(/,1X,'A bond orbital with an occupancy of ',F8.5, + ' electrons was found!',/,1X,'Please check you input data.') 1310 FORMAT(/,1X,'The total number of electron is not an integer:', + F10.5,/,1X,'Please check your input data.') 1400 FORMAT(/,1X,'Search of DM block between the following atoms:', + 3I4) 1403 FORMAT(6X,'Select orbitals with eigenvalue > ',F9.6) 1405 FORMAT(6X,8F9.6) 1410 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':') 1420 FORMAT(11X,8F7.4) 1500 FORMAT(11X,'Hybrid ',I1,' in eigenvector has a projection ', + 'expectation of ',F6.3) 1600 FORMAT(11X,'*** NBO accepted: Number',I3,'. Label:',A2,A1, + '(',I2,')') 1800 FORMAT(/4X,'PRJTHR will be raised from ',F6.3,' to',F6.3, + ' and the NBO search repeated.',/) 1810 FORMAT(//,1X,'Linearly independent hybrids for atom',I3, +' cannot be found.',/,1X,'The NBO program must abort.') 3010 FORMAT(/,1X, +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals ', +'found on ',A2,I2) 3011 FORMAT(/,1X, +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbital ', +'found on ',A2,I2) 3020 FORMAT(1X, +' ',I3,' low occupancy (<',F6.4,'e) core orbitals ', +'found on ',A2,I2) 3021 FORMAT(1X, +' ',I3,' low occupancy (<',F6.4,'e) core orbital ', +'found on ',A2,I2) END ***************************************************************************** SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, * P,TA,HYB,VA,VB,TOPO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL END,ERROR,EQUAL PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM), + N3CTR,I3CTR(10,3) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),GUIDE(NATOMS,NATOMS), * BNDOCC(NDIM),POL(NDIM,3),Q(MXAO,NDIM),V(NDIM),BLK(MXBO,MXBO), * C(MXBO,MXBO),EVAL(MXBO),BORB(MXBO),P(MXAO,MXAO),TA(MXAO,MXAO), * HYB(MXAO),VA(MXAO),VB(MXAO),TOPO(NATOMS,NATOMS) DIMENSION KEYWD(6),KLONE(4),KBOND(4),K3CBON(6),KALPHA(5), * KBETA(4),IVAL(4),KALT(4) DATA KLONE/1HL,1HO,1HN,1HE/, * KBOND/1HB,1HO,1HN,1HD/, * K3CBON/1H3,1HC,1HB,1HO,1HN,1HD/, * KALPHA/1HA,1HL,1HP,1HH,1HA/, * KBETA/1HB,1HE,1HT,1HA/, * KS/1HS/,KD/1HD/,KT/1HT/,KQ/1HQ/, * KALT/1H$,1HE,1HN,1HD/ Search for `ALPHA' or `BETA' character string in case of alpha or beta spin density matrices: IF(ISPIN.EQ.2) THEN 20 LENG = 5 CALL HFLD(KEYWD,LENG,END) IF(END.AND.LENG.EQ.0) GOTO 810 IF(.NOT.EQUAL(KEYWD,KALPHA,5)) GOTO 20 CONTINUE ELSE IF(ISPIN.EQ.-2) THEN 30 LENG = 5 CALL HFLD(KEYWD,LENG,END) IF(END.AND.LENG.EQ.0) GOTO 820 IF(.NOT.EQUAL(KEYWD,KBETA,4)) GOTO 30 CONTINUE END IF Fill diagonal elements of the TOPO matrix with nominal numbers of lone pairs to be found on each atom: DO 50 IAT = 1,NATOMS NLP = 0 CALL VALTBL(IAT,IVAL) DO 40 L = 0,3 NLP = NLP + IVAL(L+1)*(2*L + 1) 40 CONTINUE NTOPO(IAT,IAT) = 100 + NLP 50 CONTINUE Read in chosen lone pairs, bonds, and 3-center bonds: NCTR = 0 N3CTR = 0 60 CONTINUE LENG = 6 CALL HFLD(KEYWD,LENG,END) IF(END.OR.EQUAL(KEYWD,KALT,4)) GOTO 300 NCTRO = NCTR NCTR = 0 IF(EQUAL(KEYWD,KLONE,4)) NCTR = 1 IF(EQUAL(KEYWD,KBOND,4)) NCTR = 2 IF(EQUAL(KEYWD,K3CBON,6)) NCTR = 3 IF(NCTR.EQ.0) GO TO 1010 IF(NCTR.LT.NCTRO) GO TO 1020 GOTO (100,150,200), NCTR Read in lone pairs: 100 CONTINUE CALL IFLD(IAT,ERROR) IF(ERROR) THEN LENG = 6 CALL HFLD(KEYWD,LENG,END) GO TO 60 END IF CALL IFLD(NUM,ERROR) IF(ERROR) GOTO 830 NTOPO(IAT,IAT) = NUM GOTO 100 Read in bonds: 150 CONTINUE LENG = 1 CALL HFLD(KEYWD,LENG,END) IF(END) GOTO 60 NUM = 0 IF(EQUAL(KEYWD,KS,1)) NUM = 1 IF(EQUAL(KEYWD,KD,1)) NUM = 2 IF(EQUAL(KEYWD,KT,1)) NUM = 3 IF(EQUAL(KEYWD,KQ,1)) NUM = 4 IF(NUM.EQ.0) GOTO 840 CALL IFLD(IAT1,ERROR) IF(ERROR) GOTO 840 CALL IFLD(IAT2,ERROR) IF(ERROR) GOTO 840 IAT = MAX0(IAT1,IAT2) JAT = MIN0(IAT1,IAT2) NTOPO(IAT,JAT) = NUM NTOPO(JAT,IAT) = NUM GOTO 150 Read in 3-center bonds: 200 CONTINUE IF(IW3C.NE.1) IW3C = 1 LENG = 1 CALL HFLD(KEYWD,LENG,END) IF(END) GOTO 60 NUM = 0 IF(EQUAL(KEYWD,KS,1)) NUM = 1 IF(EQUAL(KEYWD,KD,1)) NUM = 2 IF(EQUAL(KEYWD,KT,1)) NUM = 3 IF(EQUAL(KEYWD,KQ,1)) NUM = 4 IF(NUM.EQ.0) GOTO 860 CALL IFLD(IAT1,ERROR) IF(ERROR) GOTO 860 CALL IFLD(IAT2,ERROR) IF(ERROR) GOTO 860 CALL IFLD(IAT3,ERROR) IF(ERROR) GOTO 860 N3CTR = N3CTR + 1 IF(N3CTR.GT.10) GOTO 870 I3CTR(N3CTR,1) = IAT1 I3CTR(N3CTR,2) = IAT2 I3CTR(N3CTR,3) = IAT3 GOTO 200 Modify nominal sets of lone pairs by number of bonds and 3-center bonds. 300 CONTINUE DO 330 IAT = 1,NATOMS NLP = NTOPO(IAT,IAT) IF(NLP.LT.100) GOTO 330 NLP = MOD(NLP,100) NBD = 0 DO 310 JAT = 1,NATOMS IF(IAT.NE.JAT.AND.NTOPO(JAT,IAT).NE.0) THEN NBD = NBD + NTOPO(JAT,IAT) END IF 310 CONTINUE DO 320 KAT = 1,3 DO 315 JAT = 1,N3CTR IF(I3CTR(JAT,KAT).EQ.IAT) NBD = NBD + 1 315 CONTINUE 320 CONTINUE NLP = NLP - NBD IF(NLP.LT.0) NLP = 0 NTOPO(IAT,IAT) = NLP 330 CONTINUE Use CHOOSE to find bond orbitals using NTOPO and I3CTR: IFLG = 0 CALL CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,P,TA,HYB, + VA,VB,TOPO,IFLG) RETURN 810 WRITE(LFNPR,1180) JPRINT(1) = -1 RETURN 820 WRITE(LFNPR,1190) JPRINT(1) = -1 RETURN 830 WRITE(LFNPR,1130) JPRINT(1) = -1 RETURN 840 WRITE(LFNPR,1140) JPRINT(1) = -1 RETURN 860 WRITE(LFNPR,1160) JPRINT(1) = -1 RETURN 870 WRITE(LFNPR,1170) JPRINT(1) = -1 RETURN 1010 WRITE(LFNPR,1110) (KEYWD(I),I=1,6) JPRINT(1) = -1 RETURN 1020 WRITE(LFNPR,1120) JPRINT(1) = -1 RETURN 1110 FORMAT(/1X,'Error in input of bond orbitals:',/,1X, * 'Keyword for orbital type is not LONE, BOND, or 3CBOND (read `', * 6A1,''')') 1120 FORMAT(/1X,'Error in input of bond orbitals:',/,1X, * 'Orbital types should be in the order: LONE, BOND, 3CBOND') 1130 FORMAT(/1X,'Error in input of bond orbitals:',/,1X, * 'Unrecognizable characters in input of lone orbitals') 1140 FORMAT(/1X,'Error in input of bond orbitals:',/,1X, * 'Unrecognizable characters in input of two center orbitals') 1160 FORMAT(/1X,'Error in input of bond orbitals:',/,1X, * 'Unrecognizable characters in input of three center orbitals') 1170 FORMAT(/1X,'Too many three center bonds:', * ' Increase parameter MAX3C') 1180 FORMAT(/1X,'End of file encountered before the word ALPHA was ', * 'found') 1190 FORMAT(/1X,'End of file encountered before the word BETA was ', * 'found') END ***************************************************************************** SUBROUTINES CALLED BY NATHYB AND CHSDRV FOR FORMING NBOS ***************************************************************************** SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB, * P,TA,HYB,VA,VB,TOPO,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) Construct orthogonal matrix T for transformation from AO's to Natural Hybrid Bond Orbitals using input density matrix DM with the chosen bonding pattern read from LFNIN LOGICAL DETAIL,FIRST,PRINT,LEFT INTEGER UL PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM), + N3CTR,I3CTR(10,3) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),GUIDE(NATOMS,NATOMS), * BNDOCC(NDIM),POL(NDIM,3),Q(MXAO,NDIM),V(NDIM),BLK(MXBO,MXBO), * C(MXBO,MXBO),EVAL(MXBO),BORB(MXBO),P(MXAO,MXAO),TA(MXAO,MXAO), * HYB(MXAO),VA(MXAO),VB(MXAO),TOPO(NATOMS,NATOMS) DIMENSION NAME(3),HYBEXP(3),KTOPO(MAXATM,MAXATM),KFLG(10) DIMENSION SCR(MAXATM*(MAXATM-1)/2),IPT(MAXATM*(MAXATM-1)/2) DATA ISTAR,IBLNK,NAME,LRY,LCR/'*',' ','LP','BD','3C','RY','CR'/ DATA ZERO,ZEROP,TENTH,PT99,ONE,TWO,TWOP + /0.0D0,1.0D-6,0.1D0,0.99D0,1.0D0,2.0D0,2.0001D0/ IFLG is a print flag on entering CHOOSE. If set to 0(1), CHOOSE will(not) print some output to LFNPR. On exit, if IFLG is set to -1, there was an error in finding the requested structure: PRJINC, the amount to increase PRJTHR by if problems with linear dependency between the hybrids arise. DATA PRJINC/0.05D0/ NOPVAL(I) = NORBS(I) - INO(I) PRINT = .FALSE. IF(IFLG.EQ.0) PRINT = .TRUE. IF(JPRINT(5).EQ.0) PRINT = .FALSE. DETAIL = .FALSE. IF(IWDETL.NE.0) DETAIL = .TRUE. PRJTHR = ABS(PRJSET) ITER = 0 Initialize KTOPO and KFLG arrays: (KFLG is set to 1 if the 3-center bond has not been fund yet.) DO 10 I = 1,NATOMS DO 5 J = 1,I KTOPO(I,J) = NTOPO(I,J) KTOPO(J,I) = NTOPO(J,I) 5 CONTINUE 10 CONTINUE DO 15 I = 1,N3CTR KFLG(I) = 1 15 CONTINUE Determine the atom ordering for the search for bond orbitals: IF(NATOMS.EQ.1) THEN IORDER(1) = 1 ELSE II = 0 DO 20 JAT = 2,NATOMS DO 19 IAT = 1,JAT-1 II = II + 1 SCR(II) = KTOPO(IAT,JAT) - GUIDE(IAT,JAT) 19 CONTINUE 20 CONTINUE NN = NATOMS * (NATOMS - 1) / 2 CALL RANK(SCR,NN,NN,IPT) Begin search for bond orbitals where the formal bond order is much greater than the corresponding Wiberg bond index: IPOS = 0 JPOS = 0 21 CONTINUE JPOS = JPOS + 1 IF(JPOS.GT.NN) STOP 'Problems with atom permutation list' IAT = IPT(JPOS) JAT = 2 22 CONTINUE IF(JAT.GT.IAT) GOTO 23 IAT = IAT - JAT + 1 JAT = JAT + 1 GOTO 22 23 CONTINUE Add IAT and JAT to the atom permutation list IORDER: MFLG = 0 DO 24 I = 1,IPOS IF(IORDER(I).EQ.IAT) MFLG = 1 24 CONTINUE IF(MFLG.EQ.0) THEN IPOS = IPOS + 1 IORDER(IPOS) = IAT END IF MFLG = 0 DO 25 I = 1,IPOS IF(IORDER(I).EQ.JAT) MFLG = 1 25 CONTINUE IF(MFLG.EQ.0) THEN IPOS = IPOS + 1 IORDER(IPOS) = JAT END IF IF(IPOS.LT.NATOMS) GOTO 21 END IF Return to here if it should prove necessary to raise PRJTHR: 35 CONTINUE ITER = ITER + 1 OCCTHR = ABS(THRSET) IF(ISPIN.NE.0) OCCTHR = OCCTHR - ONE OCCTHR = OCCTHR + TENTH Store density matrix in upper triangle of T: DO 50 J = 1,NBAS DO 40 I = 1,J T(I,J) = DM(I,J) 40 CONTINUE 50 CONTINUE Zero arrays Q,POL,IATHY,INO,LABEL: DO 100 I = 1,NBAS DO 60 K = 1,2 LABEL(I,K) = IBLNK 60 CONTINUE DO 70 K = 3,6 LABEL(I,K) = 0 70 CONTINUE DO 80 K = 1,3 POL(I,K) = ZERO IATHY(I,K) = 0 80 CONTINUE DO 90 K = 1,MXAO Q(K,I) = ZERO 90 CONTINUE 100 CONTINUE DO 110 I = 1,NATOMS INO(I) = 0 110 CONTINUE Remove core orbitals from the density matrix: IBD = 0 CALL CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR) Return here if there are still more lone pairs or bonds to be found. Lower the occupancy threshold for acceptance by a tenth: 115 CONTINUE OCCTHR = OCCTHR - TENTH LEFT = .FALSE. ******** START DIRECTED NBO SEARCH ********* Loop over numbers of centers, removing lone pairs and 2- and 3-center bonds from the density matrix according to KTOPO and I3CTR: NCTR = 0 120 NCTR = NCTR + 1 Deplete DM of one(two) center orbitals if search for two(three) center orbitals is beginning: IF(NCTR.NE.1) CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD) ICNTR = 0 Return here for 3-c bonds and lone pairs: 130 ICNTR = ICNTR + 1 IF(NCTR.EQ.1) THEN IF(ICNTR.GT.NATOMS) GOTO 120 NUM = KTOPO(IORDER(ICNTR),IORDER(ICNTR)) IF(NUM.LE.0) GOTO 130 IAT1 = IORDER(ICNTR) IAT2 = 0 IAT3 = 0 GOTO 200 ELSE IF(NCTR.EQ.2) THEN IF(ICNTR.GT.NATOMS) GOTO 120 JCNTR = ICNTR Return here for 2-c bonds: 150 JCNTR = JCNTR + 1 IF(JCNTR.GT.NATOMS) GOTO 130 NUM = KTOPO(IORDER(JCNTR),IORDER(ICNTR)) IF(NUM.EQ.0) GOTO 150 IAT1 = MIN(IORDER(ICNTR),IORDER(JCNTR)) IAT2 = MAX(IORDER(ICNTR),IORDER(JCNTR)) IAT3 = 0 GOTO 200 ELSE IF(NCTR.EQ.3) THEN IF(ICNTR.GT.N3CTR) GOTO 120 IF(KFLG(ICNTR).EQ.0) GOTO 130 NUM = 1 IAT1 = MIN(I3CTR(ICNTR,1),I3CTR(ICNTR,2),I3CTR(ICNTR,3)) IAT3 = MAX(I3CTR(ICNTR,1),I3CTR(ICNTR,2),I3CTR(ICNTR,3)) IAT2 = I3CTR(ICNTR,1) IF(IAT2.EQ.IAT1.OR.IAT2.EQ.IAT3) IAT2 = I3CTR(ICNTR,2) IF(IAT2.EQ.IAT1.OR.IAT2.EQ.IAT3) IAT2 = I3CTR(ICNTR,3) GOTO 200 ELSE GOTO 300 END IF Load proper atomic blocks of DM into BLK, and diagonalize BLK: 200 CONTINUE CALL LOAD(DM,IAT1,IAT2,IAT3,BLK,NB) CALL JACOBI(NB,BLK,EVAL,C,MXBO,MXBO,1) Rank eigenvectors by occupancy eigenvalue: CALL RANK(EVAL,NB,MXBO,LARC) IF(DETAIL) WRITE(LFNPR,1400) IAT1,IAT2,IAT3 IF(DETAIL) WRITE(LFNPR,1402) NUM,OCCTHR IF(DETAIL) WRITE(LFNPR,1405) (EVAL(IRNK),IRNK=1,NB) Loop over eigenvalues selecting the NUM highest occupied: IACCEP = 0 DO 250 IRNK = 1,NB IR = LARC(IRNK) OCC = EVAL(IRNK) DO 210 I = 1,NB 210 BORB(I) = C(I,IR) IF(DETAIL) WRITE(LFNPR,1410) IRNK,OCC IF(DETAIL) WRITE(LFNPR,1420) (BORB(I),I=1,NB) If this is a low occupancy orbital, skip the rest of these and can come back to them later: IF(OCC.LT.OCCTHR) THEN IF(NCTR.EQ.1) THEN KTOPO(IAT1,IAT1) = NUM - IACCEP IF(DETAIL) WRITE(LFNPR,1610) KTOPO(IAT1,IAT1) ELSE IF(NCTR.EQ.2) THEN KTOPO(IAT1,IAT2) = NUM - IACCEP KTOPO(IAT2,IAT1) = KTOPO(IAT1,IAT2) IF(DETAIL) WRITE(LFNPR,1610) KTOPO(IAT1,IAT2) ELSE IONE = 1 IF(DETAIL) WRITE(LFNPR,1610) IONE END IF IF(LEFT) THEN IF(OCCMAX.LT.OCC) OCCMAX = OCC ELSE LEFT = .TRUE. OCCMAX = OCC END IF GOTO 280 END IF Check to see if bond orbital "BORB" contains previously used hybrids: IF(NCTR.NE.1) THEN CALL PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,TA,HYB,VA,VB,HYBEXP) IF(DETAIL) THEN DO 220 IHYB = 1,NCTR WRITE(LFNPR,1500) IHYB,HYBEXP(IHYB) 220 CONTINUE END IF DO 230 IHYB = 1,NCTR IF(HYBEXP(IHYB).LT.PRJTHR) GOTO 250 230 CONTINUE END IF IBD = IBD + 1 IACCEP = IACCEP + 1 Decompose "BORB" into its constituent atomic hybrids and store in Q: CALL STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB) Construct bond orbital labels: IF(NCTR.EQ.1) THEN ISHIFT = NTOPO(IAT1,IAT1) - KTOPO(IAT1,IAT1) ELSE IF(NCTR.EQ.2) THEN ISHIFT = NTOPO(IAT1,IAT2) - KTOPO(IAT1,IAT2) ELSE ISHIFT = 0 END IF LABEL(IBD,1) = NAME(NCTR) LABEL(IBD,2) = IBLNK LABEL(IBD,3) = IACCEP + ISHIFT LABEL(IBD,4) = IAT1 LABEL(IBD,5) = IAT2 LABEL(IBD,6) = IAT3 BNDOCC(IBD) = OCC IF(DETAIL) WRITE(LFNPR,1600) IBD,(LABEL(IBD,I),I=1,3) IF(IACCEP.EQ.NUM) THEN IF(NCTR.EQ.1) THEN KTOPO(IAT1,IAT1) = 0 ELSE IF(NCTR.EQ.2) THEN KTOPO(IAT1,IAT2) = 0 KTOPO(IAT2,IAT1) = 0 ELSE KFLG(ICNTR) = 0 END IF GOTO 280 END IF 250 CONTINUE IF(IACCEP.NE.NUM.AND.NCTR.EQ.2.AND.PRINT) * WRITE(LFNPR,2000) PRJTHR,IACCEP,NUM,IAT1,IAT2 IF(IACCEP.NE.NUM.AND.NCTR.EQ.3.AND.PRINT) * WRITE(LFNPR,2100) PRJTHR,IACCEP,NUM,IAT1,IAT2,IAT3 IFLG = -1 280 IF(NCTR.EQ.1.OR.NCTR.EQ.3) THEN GOTO 130 ELSE 290 JCNTR=JCNTR+1 IF(JCNTR.GT.NATOMS) GOTO 130 NUM=KTOPO(IORDER(JCNTR),IORDER(ICNTR)) IF(NUM.EQ.0) GOTO 290 IAT1=IORDER(ICNTR) IAT2=IORDER(JCNTR) IAT3=0 GOTO 200 END IF ******** END OF LOOP FOR DIRECTED NBO SEARCH ********* 300 CONTINUE If some orbitals were left behind, go back and fetch them: IF(LEFT) THEN OCCTHR = OCCMAX GOTO 115 END IF Symmetrically orthogonalize principal hybrids: CALL ORTHYB(Q,BLK,TA,EVAL,C,IALARM,IFLG) IALARM sounds the alarm that there is linear dependency between some of the hybrids. IALARM is equal to the number of the violating atom. Replenish DM from T and repeat the NBO search: IF(IALARM.NE.0) THEN OLDPRJ = PRJTHR PRJTHR = OLDPRJ + PRJINC IF(PRINT) WRITE(LFNPR,1800) OLDPRJ,PRJTHR IF(PRJTHR.GE.PT99) THEN IF(PRINT) WRITE(LFNPR,1810) IALARM IFLG = -1 JPRINT(1) = -1 RETURN END IF GOTO 700 END IF Augment open-valence atoms with non-arbitrary hybrids orthogonal to those found previously: DO 580 IA = 1,NATOMS IF(NOPVAL(IA).LE.0) GOTO 580 Find NMB, the number of natural minimal basis functions on this atom: LLA = LL(IA) IULA = UL(IA) NMB = 0 DO 470 I = LLA,IULA IF(LSTOCC(I).EQ.1) NMB = NMB + 1 470 CONTINUE Find the number of bond, core, and lone pair hybrids on this atom, IOCC. Also find IOCCLP, the number of lone pair orbitals already found on atom IA for use in labelling the extra lone pairs below: IOCC = 0 IOCCLP = 0 DO 480 IB = 1,IBD IF((LABEL(IB,4).NE.IA).AND.(LABEL(IB,5).NE.IA).AND. * (LABEL(IB,6).NE.IA)) GOTO 480 IOCC = IOCC + 1 IF(LABEL(IB,1).EQ.NAME(1)) THEN IOCCLP = IOCCLP + 1 END IF 480 CONTINUE NEXLP, the number of extra (low occupancy) LP orbitals on atom IAT. (This is the number of low occupancy orbitals with valence shell character) Set NEXLP to zero if (NMB-IOCC) is less than zero!! NEXLP = NMB - IOCC IF(NEXLP.LT.0) NEXLP = 0 NOCC = INO(IA) CALL FRMPRJ(P,IA,Q,NOCC,TA,VA,VB) NORB = NORBS(IA) NAUGM = NORB - NOCC CALL AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB) Stash and label extra lone pairs that AUGMNT put in BLK: (These are taken to be the highest occupied orbitals, which AUGMNT places first) DO 510 IAUGM = 1,NEXLP DO 500 J = 1,NORB 500 BORB(J) = BLK(J,IAUGM) IBD = IBD + 1 CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB) LABEL(IBD,1) = NAME(1) LABEL(IBD,2) = ISTAR LABEL(IBD,3) = IAUGM+IOCCLP LABEL(IBD,4) = IA LABEL(IBD,5) = 0 LABEL(IBD,6) = 0 510 CONTINUE Stash and label the Rydberg orbitals that AUGMNT put in BLK: IRYD = 0 NSTART = NEXLP + 1 DO 540 IAUGM = NSTART,NAUGM DO 530 J = 1,NORB 530 BORB(J) = BLK(J,IAUGM) IBD = IBD + 1 IRYD = IRYD + 1 CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB) LABEL(IBD,1) = LRY LABEL(IBD,2) = ISTAR LABEL(IBD,3) = IRYD LABEL(IBD,4) = IA LABEL(IBD,5) = 0 LABEL(IBD,6) = 0 540 CONTINUE 580 CONTINUE Include antibond labels: IBO = IBD DO 660 I = 1,IBO Exit loop if LABEL(I,1) is 'LP', 'RY', OR 'CR': IF(LABEL(I,1).EQ.NAME(1)) GOTO 660 IF(LABEL(I,1).EQ.LRY) GOTO 660 IF(LABEL(I,1).EQ.LCR) GOTO 660 NAB = 1 IF(LABEL(I,1).EQ.NAME(3)) NAB = 2 DO 650 IAB = 1,NAB IBD = IBD + 1 DO 640 J = 1,6 640 LABEL(IBD,J) = LABEL(I,J) LABEL(IBD,2) = ISTAR 650 CONTINUE 660 CONTINUE IF(IBD.EQ.NBAS) GOTO 670 WRITE(LFNPR,2200) STOP 670 CONTINUE Replace density matrix DM from T: 700 CONTINUE DO 750 J = 1,NBAS DO 740 I = 1,J DM(I,J) = T(I,J) DM(J,I) = DM(I,J) T(J,I) = ZERO T(I,J) = ZERO 740 CONTINUE 750 CONTINUE If the alarm sounded, repeat directed NBO search: IF(IALARM.NE.0) GOTO 35 Find new polarization parameters for orthonormal hybrids: CALL REPOL(DM,Q,POL,BLK,EVAL,C,IBD) Form final T-NAB (NAO to NBO transformation) from orthonormal hybrids: CALL FORMT(T,Q,POL) Find occupancies, find total number of electrons and occupied orbitals: TOTELE = ZERO DO 800 I = 1,NBAS OCCI = ZERO DO 790 J = 1,NBAS DO 790 K = 1,NBAS 790 OCCI = OCCI + T(J,I) * DM(J,K) * T(K,I) IF(ABS(OCCI).LT.ZEROP) OCCI = ZERO IF(OCCI.GT.TWOP) GO TO 960 ZEROPM = -ZEROP IF(OCCI.LT.ZEROPM) GO TO 960 BNDOCC(I) = OCCI V(I) = OCCI TOTELE = TOTELE + BNDOCC(I) 800 CONTINUE NEL = TOTELE + TENTH IF(ABS(TOTELE-NEL).GT.5E-4) GO TO 965 TOTELE = NEL NOCC = NEL IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2) If the number of unstarred orbitals is not equal to the number of occupied MOs, then simply rank the orbitals by occupancy, and ``unstarr'' the NOCC highest occupied: (This can be dangerous! However, many of the subsequent routines assume the only NOCC orbitals are starred, and therefore, this mismatch must be corrected.) NOSTR = 0 DO 801 I = 1,NBAS IF(LABEL(IBXM(I),2).NE.ISTAR) NOSTR = NOSTR + 1 801 CONTINUE IF(NOSTR.NE.NOCC) THEN CALL RANK(V,NBAS,NDIM,LARC) DO 804 I = 1,NOCC IR = LARC(I) LABEL(IBXM(IR),2) = IBLNK 804 CONTINUE DO 805 I = NOCC+1,NBAS IR = LARC(I) LABEL(IBXM(IR),2) = ISTAR 805 CONTINUE END IF Determine whether this is a good resonance structure: CALL CYCLES(ITER,ABS(THRSET),GUIDE,BNDOCC,TOPO,ICONT) Write out info about core orbitals which were isolated in subroutine CORE: IF(.NOT.PRINT) GOTO 953 CRTHRS = CRTSET IF(ISPIN.NE.0) CRTHRS = CRTHRS - ONE FIRST = .TRUE. DO 952 IAT = 1,NATOMS ILOW = 0 DO 951 I = 1,NBAS IF(LABEL(IBXM(I),1).EQ.LCR.AND.LABEL(IBXM(I),4).EQ.IAT + .AND.BNDOCC(I).LT.CRTHRS) ILOW = ILOW + 1 951 CONTINUE IF(ILOW.NE.0) THEN IF(FIRST) THEN FIRST = .FALSE. NAM = NAMEAT(IATNO(IAT)) IF(ILOW.NE.1) THEN WRITE(LFNPR,3010) ILOW,CRTHRS,NAM,IAT ELSE WRITE(LFNPR,3011) ILOW,CRTHRS,NAM,IAT END IF ELSE NAM = NAMEAT(IATNO(IAT)) IF(ILOW.NE.1) THEN WRITE(LFNPR,3020) ILOW,CRTHRS,NAM,IAT ELSE WRITE(LFNPR,3021) ILOW,CRTHRS,NAM,IAT END IF END IF END IF 952 CONTINUE 953 CONTINUE RETURN Bad orbital occupancy: 960 IF(PRINT) WRITE(LFNPR,1300) OCCI IFLG = -1 JPRINT(1) = -1 RETURN Total number of electrons is not an integer: 965 WRITE(LFNPR,1310) TOTELE IFLG = -1 JPRINT(1) = -1 RETURN 1300 FORMAT(/,1X,'A bond orbital with an occupancy of ',F8.5, + ' electrons was found!',/,1X,'Please check you input data.') 1310 FORMAT(/,1X,'The total number of electron is not an integer:', + F10.5,/,1X,'Please check your input data.') 1400 FORMAT(/,1X,'Search of DM block between the following atoms:', + 3I4) 1402 FORMAT(6X,'Select ',I2,' orbital(s) with eigenvalue > ',F9.6) 1405 FORMAT(6X,8F9.6) 1410 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':') 1420 FORMAT(11X,8F7.4) 1500 FORMAT(11X,'Hybrid ',I1,' in eigenvector has a projection ', + 'expectation of ',F6.3) 1600 FORMAT(11X,'*** NBO accepted: Number',I3,'. Label:',A2,A1, + '(',I2,')') 1610 FORMAT(1X,'Still need to find',I2,' more orbital(s)') 1800 FORMAT(/4X,'PRJTHR will be raised from ',F6.3,' to',F6.3, + ' and the NBO search repeated.',/) 1810 FORMAT(//,1X,'Linearly independent hybrids for atom',I3, +' cannot be found.',/,1X,'The NBO program must abort.') 2000 FORMAT(/,1X,'At a projection threshold of',F6.3,', only ',I1, + ' of the ',I1,' requested bonds',/,1X,'between atoms ',I2, + ' and ',I2,' can be constructed. The NBO analysis will',/, + 1X,'continue, augmenting the NBO set with extra lone pairs ', + 'on the atoms',/,1X,'as necessary.') 2100 FORMAT(/,1X,'At a projection threshold of',F6.3,', only ',I1, + ' of the ',I1,' requested bonds',/,1X,'between atoms ',I2,', ', + I2,', and ',I2,' can be constructed. The NBO analysis',/,1X, + 'will continue, augmenting the NBO set with extra lone pairs ', + 'on the',/,1X,'atoms as necessary.') 2200 FORMAT(/,1X,'Miscounted orbitals, program must abort') 3010 FORMAT(/,1X, +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals ', +'found on ',A2,I2) 3011 FORMAT(/,1X, +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbital ', +'found on ',A2,I2) 3020 FORMAT(1X, +' ',I3,' low occupancy (<',F6.4,'e) core orbitals ', +'found on ',A2,I2) 3021 FORMAT(1X, +' ',I3,' low occupancy (<',F6.4,'e) core orbital ', +'found on ',A2,I2) END ***************************************************************************** SUBROUTINE SRTNBO(T,BNDOCC) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL PERMUT PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) DIMENSION T(NDIM,NDIM),BNDOCC(NDIM) DIMENSION NAME(3) DATA LBD,L3C,NAME,LSTAR/'BD','3C','CR','LP','RY','*'/ Reorder the NBOs according to bond type and constituent atomic centers: Fix atom ordering in the NBO labels: DO 100 I = 1,NBAS NCTR = 0 DO 10 J = 4,6 IF(LABEL(I,J).NE.0) THEN NCTR = NCTR + 1 LARC(NCTR) = LABEL(I,J) END IF 10 CONTINUE DO 30 J = 1,NCTR-1 DO 20 K = 1,NCTR-J IF(LARC(K).GT.LARC(K+1)) THEN ITEMP = LARC(K) LARC(K) = LARC(K+1) LARC(K+1) = ITEMP END IF 20 CONTINUE 30 CONTINUE DO 40 J = 1,NCTR LABEL(I,J+3) = LARC(J) 40 CONTINUE DO 50 J = NCTR+1,3 LABEL(I,J+3) = 0 50 CONTINUE 100 CONTINUE Place the 2- and 3-center bonds first in the list of NBOs: (No bonds if the NOBOND keyword was specified) ICNT = 0 IF(JPRINT(10).EQ.0) THEN DO 200 I = 1,NATOMS-1 DO 190 J = I+1,NATOMS IF(I.NE.J) THEN K = -1 110 K = K + 1 DO 180 L = ICNT+1,NBAS LBL1 = LABEL(IBXM(L),1) LBL2 = LABEL(IBXM(L),2) LBL3 = LABEL(IBXM(L),3) LBL4 = LABEL(IBXM(L),4) LBL5 = LABEL(IBXM(L),5) LBL6 = LABEL(IBXM(L),6) IF((LBL1.EQ.LBD.OR.LBL1.EQ.L3C).AND.LBL2.NE.LSTAR) THEN IF(LBL4.EQ.I.AND.LBL5.EQ.J.AND.LBL6.EQ.K) THEN ICNT = ICNT + 1 LABEL(IBXM(L),1) = LABEL(IBXM(ICNT),1) LABEL(IBXM(L),2) = LABEL(IBXM(ICNT),2) LABEL(IBXM(L),3) = LABEL(IBXM(ICNT),3) LABEL(IBXM(L),4) = LABEL(IBXM(ICNT),4) LABEL(IBXM(L),5) = LABEL(IBXM(ICNT),5) LABEL(IBXM(L),6) = LABEL(IBXM(ICNT),6) LABEL(IBXM(ICNT),1) = LBL1 LABEL(IBXM(ICNT),2) = LBL2 LABEL(IBXM(ICNT),3) = LBL3 LABEL(IBXM(ICNT),4) = LBL4 LABEL(IBXM(ICNT),5) = LBL5 LABEL(IBXM(ICNT),6) = LBL6 TEMP = BNDOCC(L) BNDOCC(L) = BNDOCC(ICNT) BNDOCC(ICNT) = TEMP DO 170 M = 1,NBAS TEMP = T(M,L) T(M,L) = T(M,ICNT) T(M,ICNT) = TEMP 170 CONTINUE END IF END IF 180 CONTINUE IF(IW3C.NE.0.AND.K.EQ.0) K = J IF(K.GT.0.AND.K.LT.NATOMS) GOTO 110 END IF 190 CONTINUE 200 CONTINUE END IF Next add any core, lone pair, and Rydberg orbitals: DO 300 II = 1,3 DO 290 I = 1,NATOMS DO 280 J = ICNT+1,NBAS LBL1 = LABEL(IBXM(J),1) LBL4 = LABEL(IBXM(J),4) IF(LBL1.EQ.NAME(II).AND.LBL4.EQ.I) THEN ICNT = ICNT + 1 DO 260 K = 1,6 ITEMP = LABEL(IBXM(J),K) LABEL(IBXM(J),K) = LABEL(IBXM(ICNT),K) LABEL(IBXM(ICNT),K) = ITEMP 260 CONTINUE TEMP = BNDOCC(J) BNDOCC(J) = BNDOCC(ICNT) BNDOCC(ICNT) = TEMP DO 270 K = 1,NBAS TEMP = T(K,J) T(K,J) = T(K,ICNT) T(K,ICNT) = TEMP 270 CONTINUE END IF 280 CONTINUE 290 CONTINUE 300 CONTINUE Add in any antibonds: IF(JPRINT(10).EQ.0) THEN DO 400 I = 1,NATOMS-1 DO 390 J = I+1,NATOMS IF(I.NE.J) THEN K = -1 IF(IW3C.NE.0) K = J 310 K = K + 1 DO 380 L = ICNT+1,NBAS LBL1 = LABEL(IBXM(L),1) LBL2 = LABEL(IBXM(L),2) LBL3 = LABEL(IBXM(L),3) LBL4 = LABEL(IBXM(L),4) LBL5 = LABEL(IBXM(L),5) LBL6 = LABEL(IBXM(L),6) IF((LBL1.EQ.LBD.OR.LBL1.EQ.L3C).AND.LBL2.EQ.LSTAR) THEN IF(LBL4.EQ.I.AND.LBL5.EQ.J.AND.LBL6.EQ.K) THEN ICNT = ICNT + 1 LABEL(IBXM(L),1) = LABEL(IBXM(ICNT),1) LABEL(IBXM(L),2) = LABEL(IBXM(ICNT),2) LABEL(IBXM(L),3) = LABEL(IBXM(ICNT),3) LABEL(IBXM(L),4) = LABEL(IBXM(ICNT),4) LABEL(IBXM(L),5) = LABEL(IBXM(ICNT),5) LABEL(IBXM(L),6) = LABEL(IBXM(ICNT),6) LABEL(IBXM(ICNT),1) = LBL1 LABEL(IBXM(ICNT),2) = LBL2 LABEL(IBXM(ICNT),3) = LBL3 LABEL(IBXM(ICNT),4) = LBL4 LABEL(IBXM(ICNT),5) = LBL5 LABEL(IBXM(ICNT),6) = LBL6 TEMP = BNDOCC(L) BNDOCC(L) = BNDOCC(ICNT) BNDOCC(ICNT) = TEMP DO 370 M = 1,NBAS TEMP = T(M,L) T(M,L) = T(M,ICNT) T(M,ICNT) = TEMP 370 CONTINUE END IF END IF 380 CONTINUE IF(K.GT.0.AND.K.LT.NATOMS) GOTO 310 END IF 390 CONTINUE 400 CONTINUE END IF Lastly, make sure orbitals are ordered by serial number: 410 PERMUT = .FALSE. DO 500 I = 1,NBAS-1 IF(LABEL(IBXM(I),1).EQ.LABEL(IBXM(I+1),1)) THEN IF(LABEL(IBXM(I),2).EQ.LABEL(IBXM(I+1),2)) THEN IF(LABEL(IBXM(I),4).EQ.LABEL(IBXM(I+1),4)) THEN IF(LABEL(IBXM(I),5).EQ.LABEL(IBXM(I+1),5)) THEN IF(LABEL(IBXM(I),6).EQ.LABEL(IBXM(I+1),6)) THEN IF(LABEL(IBXM(I),3).GT.LABEL(IBXM(I+1),3)) THEN PERMUT = .TRUE. LBL3 = LABEL(IBXM(I),3) LABEL(IBXM(I),3) = LABEL(IBXM(I+1),3) LABEL(IBXM(I+1),3) = LBL3 TEMP = BNDOCC(I) BNDOCC(I) = BNDOCC(I+1) BNDOCC(I+1) = TEMP DO 490 J = 1,NBAS TEMP = T(J,I) T(J,I) = T(J,I+1) T(J,I+1) = TEMP 490 CONTINUE END IF END IF END IF END IF END IF END IF 500 CONTINUE IF(PERMUT) GOTO 410 RETURN END ***************************************************************************** SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL FIRST PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),HYB(MXAO),THYB(NDIM,NDIM), + S(NDIM,NDIM),OCC(NDIM),SCR(NDIM),ISCR(NDIM) DIMENSION PCT(5),IAT(3) DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/ DATA ZERO,TENTH,ONE,THRESH/0.0D0,0.1D0,1.0D0,1.0D-4/ DATA LSTAR,LBLNK/'*',' '/ Form a temporary NAO to NHO transformation matrix. Check hybrid overlap to make sure the NBO's were properly labelled as Lewis and non-Lewis orbitals: Count number of hybrids as they are written out: NHYB = 0 Main loop over bond orbitals: DO 200 NBOND = 1,NBAS IB = IBXM(NBOND) LBL = LABEL(IB,1) IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR = 1 IF(LBL.EQ.LBD) NCTR = 2 IF(LBL.EQ.L3C) NCTR = 3 Loop over atomic centers of bond orbital NBOND: DO 190 ICTR = 1,NCTR I = LABEL(IB,ICTR+3) KL = LL(I) KU = LU(I) DO 120 K = 1,MXAO LTYP(K) = 0 120 HYB(K) = ZERO Choose sign for polarization coefficients: ISGN = 1 IF(LABEL(IB,2).NE.LSTAR) GO TO 130 IF(ICTR.LT.2) GO TO 130 IF(ICTR.EQ.3) IPAR3C = -IPAR3C IF(ICTR.EQ.3.AND.IPAR3C.GT.0) GO TO 130 ISGN = -ISGN 130 CONTINUE Extract hybrid (HYB) from transformation matrix T; LTYP(I) is the orbital angular momentum quantum no. of A.O. # I: KH = 0 DO 140 K = KL,KU KH = KH + 1 HYB(KH) = T(K,NBOND) 140 LTYP(KH) = NAOA(K)/100 CALL HTYPE(HYB,LTYP,MXAO,KH,COEF,PCT,NL,ISGN) IF(ABS(COEF).LT.THRESH) GO TO 190 Check to see if this orbital has been found before: DO 160 IHYB = 1,NHYB TEMP = ZERO IH = 0 DO 150 K = KL,KU IH = IH + 1 TEMP = TEMP + HYB(IH)*THYB(K,IHYB) 150 CONTINUE IF(ABS(ABS(TEMP)-ONE).LT.THRESH) GO TO 190 IF(ABS(TEMP).GT.THRESH) THEN WRITE(LFNPR,900) NHYB+1,NBOND,ICTR,TEMP,IHYB STOP END IF 160 CONTINUE Add this hybrid to the temporary THYB: NHYB = NHYB + 1 IF(NHYB.GT.NBAS) STOP 'Too many hybrids' DO 170 K = 1,NBAS THYB(K,NHYB) = ZERO 170 CONTINUE IH = 0 DO 180 K = KL,KU IH = IH + 1 THYB(K,NHYB) = HYB(IH) 180 CONTINUE 190 CONTINUE 200 CONTINUE IF(NHYB.LT.NBAS) STOP 'Missing hybrids' THYB now contains the temporary NAO to NHO transformation matrix. Form the non-orthogonal PNHO overlap and NHO to NBO transformation matrices: CALL FESNAO(S) CALL SIMTRS(S,THYB,SCR,NDIM,NBAS) CALL TRANSP(THYB,NDIM,NBAS) CALL MATMLT(THYB,T,SCR,NDIM,NBAS) Check to see that the bonds and antibonds have the correct hybrid overlap. Fix the labels if there is a problem: FIRST = .TRUE. DO 300 NBOND = 1,NBAS IB = IBXM(NBOND) LBL1 = LABEL(IB,1) IF(LBL1.EQ.LLP.OR.LBL1.EQ.LCR.OR.LBL1.EQ.LRY) ICTR = 1 IF(LBL1.EQ.LBD) ICTR = 2 IF(LBL1.EQ.L3C) ICTR = 3 NCTR = 0 DO 210 IHYB = 1,NHYB IF(ABS(THYB(IHYB,NBOND)).GT.THRESH) THEN NCTR = NCTR + 1 IF(NCTR.GT.3) THEN WRITE(LFNPR,910) NBOND STOP END IF IAT(NCTR) = IHYB END IF 210 CONTINUE IF(NCTR.GT.ICTR) THEN WRITE(LFNPR,920) ICTR,NBOND,NCTR STOP END IF IF(NCTR.GT.1) THEN ISGN = 1 DO 230 JCTR = 1,NCTR-1 DO 220 KCTR = JCTR+1,NCTR JHYB = IAT(JCTR) KHYB = IAT(KCTR) TEMP = S(JHYB,KHYB)*THYB(JHYB,NBOND)*THYB(KHYB,NBOND) IF(TEMP.LT.ZERO) ISGN = -1 220 CONTINUE 230 CONTINUE LBL2 = LABEL(IB,2) IF(LBL2.EQ.LBLNK.AND.ISGN.EQ.-1) THEN IF(FIRST.AND.JPRINT(5).NE.0) WRITE(LFNPR,930) FIRST = .FALSE. LABEL(IB,2) = LSTAR IF(JPRINT(5).NE.0) WRITE(LFNPR,940) NBOND,LBL1,LSTAR ELSE IF(LBL2.EQ.LSTAR.AND.ISGN.EQ.1) THEN IF(FIRST.AND.JPRINT(5).NE.0) WRITE(LFNPR,930) FIRST = .FALSE. LABEL(IB,2) = LBLNK IF(JPRINT(5).NE.0) WRITE(LFNPR,940) NBOND,LBL1,LBLNK END IF END IF 300 CONTINUE Determine the number of occupied orbitals: TOT = ZERO DO 310 I = 1,NBAS TOT = TOT + DM(I,I) 310 CONTINUE NOCC = TOT + TENTH IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2) Count the number of unstarred orbitals: ICNT = 0 DO 320 I = 1,NBAS IF(LABEL(IBXM(I),2).NE.LSTAR) ICNT = ICNT + 1 320 CONTINUE If the number of unstarred orbitals is not equal to the number of occupied orbitals, fix the orbital labels: IF(ICNT.NE.NOCC) THEN DO 330 I = 1,NBAS OCC(I) = DM(I,I) 330 CONTINUE CALL RANK(OCC,NBAS,NDIM,ISCR) If there are more unstarred orbitals than occupied, add stars to the least occupied lone pairs: IF(ICNT.GT.NOCC) THEN IDIFF = ICNT - NOCC DO 350 I = 1,IDIFF IP = 0 DO 340 J = 1,NBAS JP = IBXM(ISCR(J)) IF(LABEL(JP,1).EQ.LLP.AND.LABEL(JP,2).NE.LSTAR) IP = J 340 CONTINUE IF(IP.EQ.0) THEN WRITE(LFNPR,950) ICNT,NOCC STOP END IF LABEL(IBXM(ISCR(IP)),2) = LSTAR IF(JPRINT(5).NE.0) WRITE(LFNPR,940) ISCR(IP), + LABEL(IBXM(ISCR(IP)),1),LSTAR 350 CONTINUE Remove stars from the highest occupied lone pairs/Rydbergs if there are too few starred orbitals: ELSE IDIFF = NOCC - ICNT DO 370 I = 1,IDIFF IP = 0 DO 360 J = NBAS,1,-1 JP = IBXM(ISCR(J)) IF((LABEL(JP,1).EQ.LLP.OR.LABEL(JP,1).EQ.LRY) + .AND.LABEL(JP,2).EQ.LSTAR) IP = J 360 CONTINUE IF(IP.EQ.0) THEN WRITE(LFNPR,950) ICNT,NOCC STOP END IF LABEL(IBXM(ISCR(IP)),2) = LBLNK IF(JPRINT(5).NE.0) WRITE(LFNPR,940) ISCR(IP), + LABEL(IBXM(ISCR(IP)),1),LBLNK 370 CONTINUE END IF END IF RETURN 900 FORMAT(/1X,'Hybrid ',I3,' (NBO ',I3,', Center ',I2,') has a ', + 'non-negligible overlap of ',F8.5,/,1X,'with hybrid ',I3,'.') 910 FORMAT(/1X,'NBO ',I3,' has hybrid contributions from more than ', + '3 atomic centers.') 920 FORMAT(/1X,'Error: the ',I1,'-center NBO ',I3,' has ', + 'contributions from ',I2,' atomic centers.') 930 FORMAT(/1X,' --- Apparent excited state configuration ', + '---',/1X,'The following "inverted" NBO labels reflect the ', + 'actual hybrid overlap:') 940 FORMAT(1X,' NBO ',I3,' has been relabelled ',A2,A1) 950 FORMAT(/1X,'Unable to label the NBOs properly: ',I3,' unstarred ', + 'orbitals',/1X,' ',I3, + ' occupied orbitals') END ***************************************************************************** SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) INTEGER UL Print out details of bond-orbital transformation from matrix T. Required input: T = Transformation matrix from S.R. NATHYB; REAL (1,NDIM;1,NDIM) NDIM = Declared dimensionality of array T NBAS = No. of orbitals = actual dimension of T, NAOL NAOL = Integer list of orbital angular momentum type NAOL(I)/100 = l = Q.N. of atomic orbital I IATNO = List of atomic numbers; IATNO(I) is the atomic number of atom I as an integer NATOMS = No. of atoms (not including ghosts) in the molecule IWHYBS = 1 if hybrid A.O. coefficients are to be printed, 0 otherwise LFNPR = Logical file number for printout. NAOCTR = List of atomic centers of OAO or NAO basis orbitals LABEL = List of bond orbital labels IBXM = Permutation list of bond orbitals BNDOCC = List of bond orbital occupancies ISPIN = 0 for spinless NBOs = 2 for alpha spin NBOs =-2 for beta spin NBOs PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR DIMENSION T(NDIM,NDIM),HYB(MXAO),BNDOCC(NDIM),THYB(NDIM,NDIM), * PCT(5),POW(5),LNAME(5),ISP(3),NAM(3),ICH(3,2),HYCOEF(NDIM) DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/ DATA LNAME/'s','p','d','f','g'/ DATA ZERO,THRESH,T99,T99P/0.0D0,1.D-2,99.99D0,99.995D0/ DATA TENTH,HUNDRD,TTHOTH/0.1D0,100.0D0,0.0001D0/ DATA LHYP,LBLNK,LSTAR,L2BLNK/'-',' ','*',' '/ Count the number of electrons: TOTELE = ZERO DO 20 I = 1,NBAS TOTELE = TOTELE + BNDOCC(I) 20 CONTINUE TOTELE = TOTELE + TENTH NEL = TOTELE TOTELE = NEL Count the number of core orbitals and the occupancies of the core, valence Lewis, valence non-Lewis, and extra-valence Rydberg orbitals. (Also count the number of electrons in the ECP, if employed) MCR = 0 OCCCR = ZERO OCCVL = ZERO OCCVNL = ZERO DO 50 I = 1,NBAS IF(LABEL(IBXM(I),2).NE.LSTAR) THEN IF(LABEL(IBXM(I),1).EQ.LCR) THEN MCR = MCR + 1 OCCCR = OCCCR + BNDOCC(I) ELSE OCCVL = OCCVL + BNDOCC(I) END IF ELSE IF(LABEL(IBXM(I),1).NE.LRY) THEN OCCVNL = OCCVNL + BNDOCC(I) END IF END IF 50 CONTINUE OCCEVR = TOTELE - OCCCR - OCCVL - OCCVNL IF(ISPIN.EQ.0) THEN MCR = 2 * MCR END IF MVL = NEL - MCR MECP = 0 IF(IPSEUD.NE.0) THEN DO 60 I = 1,NATOMS MECP = MECP + IATNO(I) - IZNUC(I) 60 CONTINUE IF(ISPIN.NE.0) MECP = MECP/2 END IF MLEW = MCR + MVL + MECP OCCLEW = OCCCR + OCCVL + MECP OCCNON = OCCVNL + OCCEVR Write summary of NBO occupancies: IF(JPRINT(5).EQ.1.AND.NEL.NE.0) THEN WRITE(LFNPR,2000) IF(IPSEUD.NE.0) WRITE(LFNPR,2010) FLOAT(MECP) IF(MCR.NE.0) THEN PCENT = OCCCR/MCR * HUNDRD WRITE(LFNPR,2020) OCCCR,PCENT,MCR END IF IF(MVL.NE.0) THEN PCENT = OCCVL/MVL * HUNDRD WRITE(LFNPR,2030) OCCVL,PCENT,MVL END IF WRITE(LFNPR,2040) PCENT = OCCLEW/MLEW * HUNDRD WRITE(LFNPR,2050) OCCLEW,PCENT,MLEW WRITE(LFNPR,2060) PCENT = OCCVNL/MLEW * HUNDRD WRITE(LFNPR,2070) OCCVNL,PCENT,MLEW PCENT = OCCEVR/MLEW * HUNDRD WRITE(LFNPR,2080) OCCEVR,PCENT,MLEW WRITE(LFNPR,2040) PCENT = OCCNON/MLEW * HUNDRD WRITE(LFNPR,2090) OCCNON,PCENT,MLEW WRITE(LFNPR,2100) END IF Write out NBOs: IF(JPRINT(5).EQ.1) THEN WRITE(LFNPR,1000) WRITE(LFNPR,1100) (LHYP,J=1,79) END IF Main loop over bond orbitals: NHYB = 0 MHYB = 0 IPAR3C = 1 DO 180 NBOND = 1,NBAS IB = IBXM(NBOND) LBL = LABEL(IB,1) IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR = 1 IF(LBL.EQ.LBD) NCTR = 2 IF(LBL.EQ.L3C) NCTR = 3 DO 110 I = 1,3 IA = LABEL(IB,I+3) CALL CONVRT(IA,ICH(I,1),ICH(I,2)) NAM(I) = L2BLNK IF(IA.GT.0) NAM(I) = NAMEAT(IATNO(IA)) ISP(I) = LHYP IF(I.GE.NCTR) ISP(I) = LBLNK 110 CONTINUE Loop over atomic centers of bond orbital NBOND: DO 170 ICTR = 1,NCTR I = LABEL(IB,ICTR+3) NEL = NAMEAT(IATNO(I)) KL = LL(I) KU = UL(I) DO 120 K = 1,MXAO LTYP(K) = 0 120 HYB(K) = ZERO Choose sign for polarization coefficients: ISGN = 1 IF(LABEL(IB,2).NE.LSTAR) GO TO 130 IF(ICTR.LT.2) GO TO 130 IF(ICTR.EQ.3) IPAR3C = -IPAR3C IF(ICTR.EQ.3.AND.IPAR3C.GT.0) GO TO 130 ISGN = -ISGN 130 CONTINUE Extract hybrid (HYB) from transformation matrix T; LTYP(I) is the orbital angular momentum quantum no. of A.O. # I: KH = 0 DO 140 K = KL,KU KH = KH + 1 HYB(KH) = T(K,NBOND) 140 LTYP(KH) = NAOA(K)/100 CALL HTYPE(HYB,LTYP,MXAO,KH,COEF,PCT,NL,ISGN) Find leading non-zero contribution to determine POW(L) for each L: LSTD = 0 DO 160 L = 1,NL IF(LSTD.GT.0) GO TO 150 POW(L) = ZERO STD = PCT(L) IF(STD.LT.THRESH) GO TO 160 LSTD = L 150 POW(L) = PCT(L)/STD IF(POW(L).GT.T99P) POW(L) = T99 160 CONTINUE Write out NHO for center ICTR: COEFSQ = COEF * COEF * HUNDRD NL1 = NL IF(NL1.GT.3) NL1 = 3 IF(ICTR.EQ.1.AND.NCTR.EQ.1.AND.JPRINT(5).EQ.1) + WRITE(LFNPR,1210) NBOND,BNDOCC(NBOND), + (LABEL(IB,K),K=1,3),NAM(1),ICH(1,1),ICH(1,2), + PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1) IF(ICTR.EQ.1.AND.NCTR.GT.1.AND.JPRINT(5).EQ.1) + WRITE(LFNPR,1220) NBOND,BNDOCC(NBOND), + (LABEL(IB,K),K=1,3), + (NAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3) IF(NCTR.NE.1.AND.JPRINT(5).EQ.1) WRITE(LFNPR,1300) COEFSQ, + COEF,NEL,I,PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1) IF(NL.GT.3.AND.JPRINT(5).EQ.1) WRITE(LFNPR,1310) + (LNAME(L),POW(L),PCT(L),L=4,NL) IF(IWHYBS.NE.0.AND.BNDOCC(NBOND).GT.TTHOTH.AND.JPRINT(5).EQ.1) + WRITE(LFNPR,1500) (HYB(K),K=1,KH) CALL FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB) If this is a new hybrid, form its label: IF(MHYB.NE.NHYB) THEN MHYB = NHYB CALL LBLNHO(NHYB,NBOND,ICTR,NCTR) END IF 170 CONTINUE 180 CONTINUE RETURN 1000 FORMAT(//,1X,' (Occupancy) Bond orbital/ Coefficients/ ', + 'Hybrids') 1100 FORMAT(1X,80A1) 1210 FORMAT(1X,I3,'. (',F7.5,') ',A2,A1,'(',I2,')',A2,2A1,12X, + ' s(',F6.2,'%)',2(A1,F5.2,'(',F6.2,'%)')) 1220 FORMAT(1X,I3,'. (',F7.5,') ',A2,A1,'(',I2,')',3(A2,3A1)) 1300 FORMAT(16X,'(',F6.2,'%)',2X, + F7.4,'*',A2,I2,' s(',F6.2,'%)',2(A1,F5.2,'(',F6.2,'%)')) 1310 FORMAT(50X,2(A1,F5.2,'(',F6.2,'%)')) 1500 FORMAT(39X,5F8.4) 2000 FORMAT(/,1X,56('-')) 2010 FORMAT(1X,' Effective Core ',F9.5) 2020 FORMAT(1X,' Core ',F9.5,' (',F7.3,'% of ', + I3,')') 2030 FORMAT(1X,' Valence Lewis ',F9.5,' (',F7.3,'% of ', + I3,')') 2040 FORMAT(2X,18('='),7X,28('=')) 2050 FORMAT(1X,' Total Lewis ',F9.5,' (',F7.3,'% of ', + I3,')') 2060 FORMAT(2X,53('-')) 2070 FORMAT(1X,' Valence non-Lewis ',F9.5,' (',F7.3,'% of ', + I3,')') 2080 FORMAT(1X,' Rydberg non-Lewis ',F9.5,' (',F7.3,'% of ', + I3,')') 2090 FORMAT(1X,' Total non-Lewis ',F9.5,' (',F7.3,'% of ', + I3,')') 2100 FORMAT(1X,56('-')) END ***************************************************************************** SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION HYB(MXAO),LTYP(MXAO),PCT(5) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF ANALYZE INPUT HYBRID 'HYB' FOR POLARIZATION COEFFICIENT 'COEF' AND PERCENTAGES OF EACH ANGULAR MOMENTUM COMPONENT. DATA ZERO,THRESH,HUNDRD/0.0D0,1.D-4,100.0D0/ NL = 0 ZERO PERCENTAGES AND POLARIZATION COEFFICIENT: DO 10 L1 = 1,5 10 PCT(L1) = ZERO COEF = ZERO LOOP OVER ATOMIC CONTRIBUTIONS TO HYBRID, COMPUTING PERCENTAGES AND POLARIZATION COEFFICIENT: DO 20 I = 1,NH L1 = LTYP(I) + 1 IF(L1.GT.5) GO TO 800 PCT(L1) = PCT(L1) + HYB(I)**2 20 COEF = COEF + HYB(I)**2 IF(ABS(COEF).LT.THRESH) RETURN CALCULATE PERCENTAGE CONTRIBUTION FOR EACH ANGULAR SYMMETRY: DO 30 L1 = 1,5 30 PCT(L1) = PCT(L1)/COEF*HUNDRD COEF = SQRT(COEF) SWITCH THE SIGN OF THE COEFFICIENT IF ISGN IS NEGATIVE: IF(ISGN.LT.0) COEF = -COEF NORMALIZE THE HYBRID: DO 50 I = 1,NH 50 HYB(I) = HYB(I)/COEF FIND THE MAXIMUM NUMBER OF ANGULAR MOMENTUM TYPES (NL): DO 60 I = 1,NH IF(ABS(HYB(I)).LT.THRESH) GO TO 60 IF(LTYP(I).LE.NL) GO TO 60 NL = LTYP(I) 60 CONTINUE NL = NL + 1 RETURN 800 CONTINUE WRITE(LFNPR,900) L1-1 STOP 900 FORMAT(/1X,'AO with unknown angular symmetry, l = ',I3) END ***************************************************************************** SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION HYB(1),THYB(NDIM,NDIM),HYCOEF(NDIM) DATA ZERO,ONE,THRESH/0.0D0,1.0D0,1.0D-4/ FORM FULL NAO TO NHO TRANFORMATION IN THYB, ADDING ONE HYBRID WITH EACH CALL. PUT POLARIZATION COEF IN HYCOEF FOR EACH HYBRID. MAKE SURE THIS HYBRID ISN'T ALREADY IN THE LIST: IF(ABS(COEF).LT.THRESH) RETURN DO 20 IHYB = 1,NHYB TEMP = ZERO IH = 0 DO 10 K = KL,KU IH = IH + 1 TEMP = TEMP + HYB(IH)*THYB(K,IHYB) 10 CONTINUE IF(ABS(ABS(TEMP)-ONE).LT.THRESH) RETURN IF(ABS(TEMP).GT.THRESH) THEN WRITE(LFNPR,900) NHYB+1,TEMP,IHYB STOP END IF 20 CONTINUE ADD THIS HYBRID TO THE LIST: NHYB = NHYB + 1 IF(NHYB.GT.NBAS) STOP 'Too many hybrids' DO 50 I = 1,NBAS THYB(I,NHYB) = ZERO 50 CONTINUE IH = 0 DO 70 I = KL,KU IH = IH + 1 THYB(I,NHYB) = HYB(IH) 70 CONTINUE HYCOEF(NHYB) = COEF IF(NHYB.NE.NBAS) RETURN CALL SVTNHO(THYB) RETURN 900 FORMAT(/1X,'Hybrid ',I3,' has a ', + 'non-negligible overlap of ',F8.5,' with hybrid ',I3,'.') END ***************************************************************************** SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS), + IPRIN(MAXBAS) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION BNDOCC(NDIM),ATCOOR(NATOMS*3),THYB(NDIM,NDIM), + TBND(NDIM,NDIM),SCR(NDIM) DIMENSION ISTR(8),PHYB(3),XYZ(3,2),KHYB(3),AZI(2),POL(2),DEV(2) DIMENSION ISKIP(2) DATA LCR,LLP,LRY,LBD,L3C/'CR','LP','RY','BD','3C'/ DATA LHYP/'-'/ DATA ZERO,ONE,THRESH,CUTOFF/0.0D0,1.0D0,1.0D-4,1.0D-8/ Compute hybrid directionality and bond bending for selected NBO's: Thresholds: ATHR -- Angular deviation threshold PTHR -- Percentage p-character threshold ETHR -- Occupancy threshold CONV = 180.0/(4.0*ATAN(ONE)) WRITE(LFNPR,900) ABS(ATHR),ABS(PTHR),ABS(ETHR) Get atomic centers, NAO to NHO trans., and NAO to NBO trans.: CALL FECOOR(ATCOOR) CALL FETNHO(THYB) CALL FETNAB(TBND) CALL TRANSP(TBND,NDIM,NBAS) CALL MATMLT(TBND,THYB,SCR,NDIM,NBAS) Loop over NBOs: ICNT = 0 DO 100 IBAS = 1,NBAS IB = IBXM(IBAS) LBL1 = LABEL(IB,1) LBL2 = LABEL(IB,2) LBL3 = LABEL(IB,3) IF(LBL1.EQ.LLP.OR.LBL1.EQ.LRY) NCTR = 1 IF(LBL1.EQ.LBD) NCTR = 2 Skip 3-center orbitals, core orbitals, low occupancy orbitals: IF(LBL1.EQ.L3C) GO TO 100 IF(LBL1.EQ.LCR) GO TO 100 IF(BNDOCC(IBAS).LT.ABS(ETHR)) GO TO 100 Find the hybrids which contribute to this NBO: ICTR = 0 DO 10 IHYB = 1,NBAS IF(ABS(TBND(IBAS,IHYB)).GT.THRESH) THEN ICTR = ICTR + 1 KHYB(ICTR) = IHYB END IF 10 CONTINUE IF(ICTR.NE.NCTR) THEN WRITE(LFNPR,910) NCTR,IBAS,ICTR STOP END IF Make sure the hybrids are on the proper nuclear centers and compute the percentage p-character in the hybrid: DO 30 ICTR = 1,NCTR IHYB = KHYB(ICTR) JCTR = LABEL(IB,ICTR+3) CALL HYBCMP(XYZ(1,ICTR),PHYB(ICTR),IHYB,JCTR,THYB(1,IHYB)) 30 CONTINUE If these hybrids have low p-character, skip them: ISKIP(1) = 0 ISKIP(2) = 0 IF(NCTR.EQ.1.AND.PHYB(1).LT.ABS(PTHR)) GO TO 100 IF(NCTR.EQ.2) THEN IF(PHYB(1).LT.ABS(PTHR)) ISKIP(1) = 1 IF(PHYB(2).LT.ABS(PTHR)) ISKIP(2) = 1 IF(ISKIP(1).EQ.1.AND.ISKIP(2).EQ.1) GO TO 100 END IF Compute the polar and azimuthal angles of each hybrid: DO 70 ICTR = 1,NCTR IF(ISKIP(ICTR).EQ.1) GO TO 70 CALL ANGLES(XYZ(1,ICTR),XYZ(2,ICTR),XYZ(3,ICTR),POL(ICTR), + AZI(ICTR)) 70 CONTINUE Compute the deviation from the line of nuclear centers for 2-center orbitals: IF(NCTR.EQ.2) THEN ICTR = LABEL(IB,4) JCTR = LABEL(IB,5) X = ATCOOR(JCTR*3-2) - ATCOOR(ICTR*3-2) Y = ATCOOR(JCTR*3-1) - ATCOOR(ICTR*3-1) Z = ATCOOR(JCTR*3) - ATCOOR(ICTR*3) IF(ABS(X).LT.CUTOFF) X = ZERO IF(ABS(Y).LT.CUTOFF) Y = ZERO IF(ABS(Z).LT.CUTOFF) Z = ZERO R = SQRT(X*X + Y*Y + Z*Z) X = X / R Y = Y / R Z = Z / R CALL ANGLES(X,Y,Z,THETA,PHI) PROJ = XYZ(1,1)*X + XYZ(2,1)*Y + XYZ(3,1)*Z IF(ABS(PROJ-ONE).LT.CUTOFF) THEN DEV(1) = ZERO ELSE IF(ABS(PROJ+ONE).LT.CUTOFF) THEN DEV(1) = 180.0 ELSE IF(PROJ.LT.ONE.AND.PROJ.GT.-ONE) THEN DEV(1) = ACOS(PROJ) * CONV DEV(1) = ABS(DEV(1)) ELSE STOP 'ArcCosine out of bounds in SR HYBDIR' END IF PROJ = XYZ(1,2)*X + XYZ(2,2)*Y + XYZ(3,2)*Z IF(ABS(PROJ-ONE).LT.CUTOFF) THEN DEV(2) = 180.0 ELSE IF(ABS(PROJ+ONE).LT.CUTOFF) THEN DEV(2) = ZERO ELSE IF(PROJ.LT.ONE.AND.PROJ.GT.-ONE) THEN DEV(2) = ACOS(PROJ) * CONV DEV(2) = ABS(ABS(DEV(2)) - 180.0) ELSE STOP 'ArcCosine out of bounds in SR HYBDIR' END IF IF(DEV(1).LT.ABS(ATHR)) ISKIP(1) = 1 IF(DEV(2).LT.ABS(ATHR)) ISKIP(2) = 1 IF(ISKIP(1).EQ.1.AND.ISKIP(2).EQ.1) GO TO 100 END IF Write out directionality info: ICNT = ICNT + 1 ISTR(1) = LBL1 ISTR(2) = LBL2 ISTR(3) = LBL3 ISTR(4) = NAMEAT(IATNO(LABEL(IB,4))) ISTR(5) = LABEL(IB,4) IF(NCTR.EQ.2) THEN ISTR(6) = LHYP ISTR(7) = NAMEAT(IATNO(LABEL(IB,5))) ISTR(8) = LABEL(IB,5) IF(ISKIP(1).EQ.1) THEN WRITE(LFNPR,940) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(2), + AZI(2),DEV(2) ELSE IF(ISKIP(2).EQ.1) THEN WRITE(LFNPR,950) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(1), + AZI(1),DEV(1) ELSE WRITE(LFNPR,960) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(1), + AZI(1),DEV(1),POL(2),AZI(2),DEV(2) END IF ELSE WRITE(LFNPR,970) IBAS,(ISTR(I),I=1,5),POL(1),AZI(1) END IF 100 CONTINUE IF(ICNT.EQ.0) WRITE(LFNPR,980) RETURN 900 FORMAT(//1X,'NHO Directionality and "Bond Bending" (deviations ', + 'from line of nuclear centers)',//1X,' [Thresholds for ', + 'printing: angular deviation > ',F4.1,' degree]',/1X, + ' hybrid p-character > ',F4.1, + '%',/1X,' orbital occupancy ', + '> ',F4.2,'e',//1X,' Line of Centers ', + ' Hybrid 1 Hybrid 2',/1X,' ', + '--------------- ------------------- ------------------',/1X, + ' NBO Theta Phi Theta Phi Dev ', + 'Theta Phi Dev',/1X,'=====================================', + '==========================================') 910 FORMAT(/1X,'Error: the ',I1,'-center NBO ',I3,' has ', + 'contributions from ',I2,' atomic centers.') 940 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1, + ' -- -- -- ',F5.1,2X,F5.1,1X,F5.1) 950 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1, + 3X,F5.1,2X,F5.1,1X,F5.1,' -- -- --') 960 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1, + 3X,F5.1,2X,F5.1,1X,F5.1,4X,F5.1,2X,F5.1,1X,F5.1) 970 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,' -- --',4X, + F5.1,2X,F5.1,' -- -- -- --') 980 FORMAT(1X,' None exceeding thresholds') END ***************************************************************************** SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION XYZ(3),HYB(1) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA ZERO,THRESH,CUTOFF/0.0D0,1.0D-4,1.0D-8/ Add the px,py,pz components of this hybrid vectorially and determine its percentage p-character: XYZ(1) = ZERO XYZ(2) = ZERO XYZ(3) = ZERO PCENT = ZERO HNORM = ZERO Make sure this hybrid is situated on the correct atom, JCTR: JMAX = 1 TMAX = ABS(HYB(1)) DO 10 INAO = 2,NBAS IF(ABS(HYB(INAO)).GT.TMAX) THEN JMAX = INAO TMAX = ABS(HYB(INAO)) END IF 10 CONTINUE IF(NAOC(JMAX).NE.JCTR) THEN WRITE(LFNPR,920) IHYB,JCTR,NAOC(JMAX) STOP END IF Find the sign of the largest s-component of this hybrid: JMAX = 0 TMAX = ZERO DO 20 INAO = 1,NBAS L = NAOA(INAO)/100 IF(L.EQ.0.AND.ABS(HYB(INAO)).GT.TMAX) THEN JMAX = INAO TMAX = ABS(HYB(INAO)) END IF 20 CONTINUE If the sign of the largest s-component is negative, change the phase of this hybrid: IF(JMAX.NE.0.AND.HYB(JMAX).LT.-THRESH) THEN DO 30 INAO = 1,NBAS HYB(INAO) = -HYB(INAO) 30 CONTINUE ENDIF Sum the px,py,pz components of this hybrid, determine the percent p-character: DO 40 INAO = 1,NBAS IF(NAOC(INAO).EQ.JCTR) THEN L = NAOA(INAO)/100 IF(L.EQ.1) THEN PCENT = PCENT + HYB(INAO)*HYB(INAO) M = MOD(NAOA(INAO),50) XYZ(M) = XYZ(M) + HYB(INAO) END IF HNORM = HNORM + HYB(INAO)*HYB(INAO) END IF 40 CONTINUE IF(HNORM.LT.THRESH) THEN WRITE(LFNPR,930) JCTR,IHYB STOP END IF PCENT = PCENT/HNORM * 100.0 Normalize the px,py,pz vector: HNORM = ZERO DO 50 IX = 1,3 IF(ABS(XYZ(IX)).LT.CUTOFF) XYZ(IX) = ZERO HNORM = HNORM + XYZ(IX)*XYZ(IX) 50 CONTINUE HNORM = SQRT(HNORM) IF(ABS(HNORM).LT.CUTOFF) THEN PCENT = ZERO ELSE DO 60 IX = 1,3 XYZ(IX) = XYZ(IX)/HNORM 60 CONTINUE END IF RETURN 920 FORMAT(/1X,'Expected to find hybrid ',I3,' on nuclear center ', + I2,' rather than center ',I2,'.') 930 FORMAT(/1X,'The atomic orbitals on nuclear center ',I2,' do not ', + 'contribute to hybrid ',I3,'.') END ***************************************************************************** SUBROUTINE FNDMOL(IATOMS) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM), + NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION IATOMS(NATOMS) LOGICAL BDFIND FIND MOLECULAR UNITS : Modified algorithm replacing original which had problems with determining molecular units for odd numberings of atoms. (E. Glendening 3/12/88) NMOLEC = 0 DO 20 I = 1,NATOMS MOLAT(I) = 0 DO 10 J = 1,NATOMS MOLEC(I,J) = 0 10 CONTINUE 20 CONTINUE DO 30 I = 1,NATOMS IATOMS(I) = I 30 CONTINUE LATOMS = NATOMS 40 CONTINUE NMOLEC = NMOLEC+1 MOLAT(NMOLEC) = 1 MOLEC(NMOLEC,1) = IATOMS(1) LATOMS = LATOMS-1 IF(LATOMS.NE.0) THEN DO 50 I = 1,LATOMS IATOMS(I) = IATOMS(I+1) 50 CONTINUE IAT = 1 60 CONTINUE I = 1 70 CONTINUE IF(BDFIND(MOLEC(NMOLEC,IAT),IATOMS(I))) THEN MOLAT(NMOLEC) = MOLAT(NMOLEC)+1 MOLEC(NMOLEC,MOLAT(NMOLEC)) = IATOMS(I) LATOMS = LATOMS-1 IF(I.LE.LATOMS) THEN DO 80 J = I,LATOMS IATOMS(J) = IATOMS(J+1) 80 CONTINUE END IF ELSE I = I+1 END IF IF(I.LE.LATOMS) GOTO 70 IAT = IAT+1 IF(IAT.LE.MOLAT(NMOLEC).AND.LATOMS.NE.0) GOTO 60 END IF IF(LATOMS.GT.0) GOTO 40 SORT ATOMS IN MOLECULAR UNITS: DO 110 I = 1,NMOLEC DO 100 J = 1,MOLAT(I)-1 DO 90 K = 1,MOLAT(I)-J IF(MOLEC(I,K).GT.MOLEC(I,K+1)) THEN ITEMP = MOLEC(I,K) MOLEC(I,K) = MOLEC(I,K+1) MOLEC(I,K+1) = ITEMP END IF 90 CONTINUE 100 CONTINUE 110 CONTINUE ALPHA SPIN: SAVE BONDING INFO IN NMOLA,MOLATA,MOLECA: IF(ISPIN.EQ.2) THEN NMOLA = NMOLEC DO 610 IMOL = 1,NMOLEC MOLATA(IMOL) = MOLAT(IMOL) IMOLAT = MOLAT(IMOL) DO 600 IATMOL = 1,IMOLAT MOLECA(IMOL,IATMOL) = MOLEC(IMOL,IATMOL) 600 CONTINUE 610 CONTINUE BETA SPIN: MAKE SURE THAT BETA MOLECULAR UNITS ARE THE SAME AS ALPHA: ELSE IF(ISPIN.EQ.-2) THEN IF(NMOLA.NE.NMOLEC) GO TO 800 DO 730 IMOL = 1,NMOLEC IMOLAT = MOLAT(IMOL) IF(IMOLAT.NE.MOLATA(IMOL)) GO TO 800 DO 720 IATMOL = 1,IMOLAT IF(MOLECA(IMOL,IATMOL).NE.MOLEC(IMOL,IATMOL)) GO TO 800 720 CONTINUE 730 CONTINUE END IF RETURN 800 WRITE(LFNPR,1800) NMOLA = -NMOLA RETURN 1800 FORMAT(/1X,'The molecular units found in the alpha and beta ', + 'manifolds are inequivalent.',/1X,'For labelling purposes, ', + 'the molecular units of the beta system will be used.') END ***************************************************************************** SUBROUTINE NBOCLA(BNDOCC,ACCTHR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),MOLLST(MAXBAS),IATHY(MAXBAS,3) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM), + NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM) DIMENSION BNDOCC(NBAS) DATA LBD,L3C,LSTAR/2HBD,2H3C,1H*/ DATA THRESH,ONE,ZERO,TWO/1.50D0,1.0D0,0.0D0,2.0D0/ DATA DONTHR/1.0D-1/ CLASSIFY NBOS ACCORDING TO DONOR/ACCEPTOR TYPE: IF(ACCTHR.LE.ZERO) THEN ACCTHR = THRESH IF(ISPIN.NE.0) ACCTHR = ACCTHR - ONE END IF IF(ISPIN.NE.0) DONTHR = DONTHR / TWO MAKE UP LIST MOLLST OF WHICH "MOLECULE" EACH ATOM IS IN: DO 80 IAT = 1,NATOMS DO 60 IMOL = 1,NMOLEC IMOLAT = MOLAT(IMOL) DO 50 IATMOL = 1,IMOLAT IF(MOLEC(IMOL,IATMOL).EQ.IAT) GO TO 70 50 CONTINUE 60 CONTINUE STOP 'ROUTINE NBOCLA' 70 MOLLST(IAT) = IMOL 80 CONTINUE MAKE UP LISTS OF NBO ORBITALS: NBOUNI(IBAS) = MOLECULAR UNIT NBOTYP(IBAS) = NUMBER OF CENTERS (+10 IF A LOW OCCUPANCY LONE PAIR) (+20 IF AN ANTIBOND/RYDBERG) DO 200 IBAS = 1,NBAS IB = IBXM(IBAS) IAT = LABEL(IB,4) IMOL = MOLLST(IAT) NBOUNI(IBAS) = IMOL LAB = LABEL(IB,1) NCTR = 1 IF(LAB.EQ.LBD) NCTR = 2 IF(LAB.EQ.L3C) NCTR = 3 NBOTYP(IBAS) = NCTR IF(LABEL(IB,2).EQ.LSTAR) GO TO 180 IF(BNDOCC(IBAS).GT.ACCTHR) GO TO 200 LOW OCCUPANCY VALENCE ORBITAL NBOTYP(IBAS) = NCTR + 10 GO TO 200 ANTIBOND/RYDBERG 180 NBOTYP(IBAS) = NCTR + 20 HIGH OCCUPANCY RY* OR BD* ORBITAL IF(BNDOCC(IBAS).GT.DONTHR) NBOTYP(IBAS) = NCTR + 10 200 CONTINUE RETURN END ***************************************************************************** SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),MOLLST(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM), + NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR DIMENSION BNDOCC(NBAS),F(NDIM,NDIM),MOLNBO(2,NBAS,NMOLEC) DIMENSION INAM(3),JNAM(3),ICH(3,2),JCH(3,2),ISP(3),JSP(3) DATA LBD/2HBD/,L3C/2H3C/,LBLNK1/1H /,LBLNK2/2H /,LHYP/1H-/ DATA HUNDTH/0.01D0/ DATA AUKCAL/627.51D0/,EVKCAL/23.060D0/ DATA ZERO,ONE,TWO,TEN/0.0D0,1.0D0,2.0D0,1.0D1/ PERFORM 2ND ORDER ANALYSIS OF THE FOCK MATRIX: ETHR1 IS THE THRESHOLD FOR PRINTING THE INTRAMOLECULAR PERTURBATIONAL ENERGIES (0.5 KCAL/MOL FOR CLOSED SHELL, 0.25 KCAL/MOL FOR OPEN SHELL) SIMILARLY, ETHR2 IS THE INTERMOLECULAR THRESHOLD, (0.05 KCAL/MOL). ETHR1 = ABS(E2THR) IF(ISPIN.NE.0.AND.E2THR.LT.ZERO) ETHR1 = ETHR1/TWO ETHR2 = ABS(E2THR)/TEN IF(ISPIN.NE.0.AND.E2THR.LT.ZERO) ETHR2 = ETHR2/TWO FETCH THE NBO FOCK MATRIX: NTRI = NDIM * (NDIM+1)/2 CALL FEFNBO(F) CALL UNPACK(F,NDIM,NBAS,NTRI) ANALYZE FOCK MATRIX: MAKE UP LIST MOLNBO(1,IBAS,IMOL) OF CORE/LP/BOND NBOS IN MOLEC. UNIT IMOL MOLNBO(2,IBAS,IMOL) OF RYDBERG/ANTIBOND NBOS IN MOLEC. IMOL DO 200 IMOL = 1,NMOLEC NOCC = 0 NSTAR = 0 DO 110 IBAS = 1,NBAS DO 100 I = 1,2 MOLNBO(I,IBAS,IMOL) = 0 100 CONTINUE 110 CONTINUE DO 150 IBAS = 1,NBAS IF(IMOL.NE.NBOUNI(IBAS)) GO TO 150 IF(NBOTYP(IBAS).GT.20) GO TO 130 NOCC = NOCC + 1 MOLNBO(1,NOCC,IMOL) = IBAS IF(NBOTYP(IBAS).LT.10) GO TO 150 130 CONTINUE NSTAR = NSTAR + 1 MOLNBO(2,NSTAR,IMOL) = IBAS 150 CONTINUE 200 CONTINUE DETERMINE THE CONVERSION FROM INPUT ENERGY UNITS TO KCAL: IF(MUNIT.EQ.0) THEN CONV = AUKCAL ELSE IF(MUNIT.EQ.1) THEN CONV = EVKCAL ELSE CONV = ONE END IF LOOP OVER PAIRS OF UNITS: WRITE(LFNPR,2700) ETHR1 IF(NMOLEC.GT.1) WRITE(LFNPR,2710) ETHR2 IF(MUNIT.EQ.0) THEN WRITE(LFNPR,2720) ELSE IF(MUNIT.EQ.1) THEN WRITE(LFNPR,2730) ELSE WRITE(LFNPR,2740) END IF DO 400 IMOL = 1,NMOLEC DO 400 JMOL = 1,NMOLEC IF(IMOL.EQ.JMOL) WRITE(LFNPR,2300) IMOL IF(IMOL.NE.JMOL) WRITE(LFNPR,2400) IMOL,JMOL ETHRSH = ETHR1 IF(IMOL.NE.JMOL) ETHRSH = ETHR2 NELE = 0 DO 305 IOCC = 1,NBAS IBAS = MOLNBO(1,IOCC,IMOL) IF(IBAS.EQ.0) GO TO 305 IB = IBXM(IBAS) LBL = LABEL(IB,1) NCTR = 1 IF(LBL.EQ.LBD) NCTR = 2 IF(LBL.EQ.L3C) NCTR = 3 DO 250 I = 1,3 IA = LABEL(IB,I+3) CALL CONVRT(IA,ICH(I,1),ICH(I,2)) INAM(I) = LBLNK2 IF(IA.GT.0) INAM(I) = NAMEAT(IATNO(IA)) ISP(I) = LHYP IF(I.GE.NCTR) ISP(I) = LBLNK1 250 CONTINUE DO 300 JSTAR = 1,NBAS JBAS = MOLNBO(2,JSTAR,JMOL) IF(JBAS.EQ.0) GO TO 300 IF(IBAS.EQ.JBAS) GO TO 300 DE = F(JBAS,JBAS) - F(IBAS,IBAS) IF(DE.LT.HUNDTH) GO TO 300 ABSFIJ = ABS(F(IBAS,JBAS)) EPERT = (ABSFIJ**2)/DE COMPUTE OCCUPANCY FACTOR TO MULTIPLY BY: TOTOCC = BNDOCC(IBAS)+BNDOCC(JBAS) FULLOC = TWO IF(ISPIN.NE.0) FULLOC = ONE OCCFAC = TOTOCC IF(TOTOCC.GT.FULLOC) OCCFAC = TWO * FULLOC - TOTOCC MULTIPLY EPERT BY SUM OF OCCUPANCIES OF NBOS IBAS AND JBAS: EPERT = EPERT * OCCFAC EKCAL = EPERT * CONV IF(EKCAL.LT.ETHRSH) GO TO 300 NELE = NELE + 1 JB = IBXM(JBAS) LBL = LABEL(JB,1) NCTR = 1 IF(LBL.EQ.LBD) NCTR = 2 IF(LBL.EQ.L3C) NCTR = 3 DO 260 J = 1,3 JA = LABEL(JB,J+3) CALL CONVRT(JA,JCH(J,1),JCH(J,2)) JNAM(J) = LBLNK2 IF(JA.GT.0) JNAM(J) = NAMEAT(IATNO(JA)) JSP(J) = LHYP IF(J.GE.NCTR) JSP(J) = LBLNK1 260 CONTINUE WRITE(LFNPR,2800) IBAS,(LABEL(IB,K),K=1,3), * (INAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,2), * INAM(3),ICH(3,1),ICH(3,2), * JBAS,(LABEL(JB,K),K=1,3), * (JNAM(K),JCH(K,1),JCH(K,2),JSP(K),K=1,2), * JNAM(3),JCH(3,1),JCH(3,2), * EKCAL,DE,ABSFIJ 300 CONTINUE 305 CONTINUE IF(NELE.EQ.0) WRITE(LFNPR,2500) 400 CONTINUE RETURN 2300 FORMAT(/1X,'within unit ',I2) 2400 FORMAT(/1X,'from unit ',I2,' to unit ',I2) 2500 FORMAT(1X,' None above threshold') 2700 FORMAT(//,1X,'Second Order Perturbation Theory Analysis ', * 'of Fock Matrix in NBO Basis'//,1X, * ' Threshold for printing: ',F5.2,' kcal/mol') 2710 FORMAT(1X,' (Intermolecular threshold:',F5.2,' kcal/mol)') 2720 FORMAT(56X,' E(2) E(j)-E(i) F(i,j)'/ * 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X, * 'kcal/mol a.u. a.u. ',/1X,79('=')) 2730 FORMAT(56X,' E(2) E(j)-E(i) F(i,j)'/ * 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X, * 'kcal/mol e.V. e.V. ',/1X,79('=')) 2740 FORMAT(56X,' E(2) E(j)-E(i) F(i,j)'/ * 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X, * 'kcal/mol kcal kcal ',/1X,79('=')) 2800 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1, * '/',I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1, * F8.2,F8.2,F9.3) END ***************************************************************************** SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL FIRST PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM), + NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM) COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION F(NDIM,NDIM),BNDOCC(NDIM),LIST(NDIM),LISTA(NATOMS,2), + SCR(1) DIMENSION ISTR(80),ILAB(9) DATA ZERO,EPS,TWO,TEN,HUNDRD/0.0D0,5.0D-6,2.0D0,1.0D1,1.0D2/ DATA TENTH/1.0D-1/ DATA LSTAR,LRY/'*','RY'/ Set flag to zero -- Determine strong delocalizations from perturbative analysis of the NBO Fock matrix: IFLG = 0 Threshold for printing delocalizations: THR1 = ABS(E2THR) IF(ISPIN.NE.0) THR = THR/TWO THR2 = THR1 / TEN Get Fock matrix if there is one: IF(IWFOCK.NE.0) THEN NTRI = NDIM * (NDIM+1)/2 CALL FEFNBO(F) CALL UNPACK(F,NDIM,NBAS,NTRI) END IF Print summary heading, then loop over molecules: IF(IWFOCK.NE.0) THEN WRITE(LFNPR,900) ELSE WRITE(LFNPR,910) END IF DO 200 IMOL = 1,NMOLEC Determine the molecular formula, the nuclear charge, and the number of ECP electrons of this molecular unit: NAT = 0 MECP = 0 CHARGE = ZERO DO 20 IAT = 1,MOLAT(IMOL) KAT = IATNO(MOLEC(IMOL,IAT)) MECP = MECP + FLOAT(KAT - IZNUC(MOLEC(IMOL,IAT))) CHARGE = CHARGE + FLOAT(KAT) DO 10 JAT = 1,NAT IF(LISTA(JAT,1).EQ.KAT) THEN LISTA(JAT,2) = LISTA(JAT,2) + 1 GO TO 20 END IF 10 CONTINUE NAT = NAT + 1 LISTA(NAT,1) = KAT LISTA(NAT,2) = 1 20 CONTINUE IF(ISPIN.NE.0) MECP = MECP/2 IF(ISPIN.NE.0) CHARGE = CHARGE/TWO CALL CHEM(NAT,NATOMS,LISTA,NL,ISTR) WRITE(LFNPR,920) IMOL,(ISTR(I),I=1,NL) Loop over NBO's on this molecular unit: OCCLEW = FLOAT(MECP) OCCNON = ZERO OCCRYD = ZERO DO 190 IBAS = 1,NBAS IF(NBOUNI(IBAS).EQ.IMOL) THEN IB = IBXM(IBAS) ILAB(1) = LABEL(IB,1) ILAB(2) = LABEL(IB,2) ILAB(3) = LABEL(IB,3) IPTR = 3 NCTR = MOD(NBOTYP(IBAS),10) DO 30 ICTR = 1,NCTR IPTR = IPTR + 2 ILAB(IPTR) = LABEL(IB,ICTR+3) ILAB(IPTR-1) = NAMEAT(IATNO(ILAB(IPTR))) 30 CONTINUE OCC = BNDOCC(IBAS) IF(ILAB(1).EQ.LRY) THEN OCCRYD = OCCRYD + OCC ELSE IF(ILAB(2).EQ.LSTAR) THEN OCCNON = OCCNON + OCC ELSE OCCLEW = OCCLEW + OCC END IF If there is a Fock matrix, find the orbital energy and principal delocalizations: IF(IWFOCK.NE.0) THEN ENRG = F(IBAS,IBAS) CALL GETDEL(IBAS,OCC,THR1,THR2,NL,LIST,SCR,F,IFLG) FIRST = .TRUE. IL = 0 40 CALL DLCSTR(IBAS,IL,NL,LIST,ML,ISTR) IF(FIRST) THEN IF(NCTR.EQ.1) THEN WRITE(LFNPR,930) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG, + (ISTR(J),J=1,ML) ELSE IF(NCTR.EQ.2) THEN WRITE(LFNPR,940) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG, + (ISTR(J),J=1,ML) ELSE WRITE(LFNPR,950) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG, + (ISTR(J),J=1,ML) END IF FIRST = .FALSE. ELSE WRITE(LFNPR,960) (ISTR(J),J=1,ML) END IF IF(IL.LT.NL) GO TO 40 Otherwise only write out orbital labels and occupancy: ELSE IF(NCTR.EQ.1) THEN WRITE(LFNPR,930) IBAS,(ILAB(I),I=1,IPTR),OCC ELSE IF(NCTR.EQ.2) THEN WRITE(LFNPR,940) IBAS,(ILAB(I),I=1,IPTR),OCC ELSE WRITE(LFNPR,950) IBAS,(ILAB(I),I=1,IPTR),OCC END IF END IF END IF 190 CONTINUE WRITE(LFNPR,970) TOTAL = OCCLEW + OCCNON + OCCRYD Make sure the total number of electrons is an integer if there is only one molecular unit: IF(NMOLEC.EQ.1) THEN TOTAL = TOTAL + TENTH NEL = TOTAL TOTAL = NEL OCCRYD = TOTAL - OCCLEW - OCCNON END IF Write a summary of the electron population on this molecular unit: IF(ABS(TOTAL-FLOAT(NINT(TOTAL))).LT.1.0D-5) + TOTAL = FLOAT(NINT(TOTAL)) CHARGE = CHARGE - TOTAL IF(TOTAL.GT.EPS) THEN PLEW = OCCLEW/TOTAL*HUNDRD PNON = OCCNON/TOTAL*HUNDRD PRYD = OCCRYD/TOTAL*HUNDRD ELSE PLEW = ZERO PNON = ZERO PRYD = ZERO END IF WRITE(LFNPR,980) OCCLEW,PLEW WRITE(LFNPR,990) OCCNON,PNON WRITE(LFNPR,1000) OCCRYD,PRYD WRITE(LFNPR,970) WRITE(LFNPR,1010) IMOL,TOTAL,HUNDRD WRITE(LFNPR,1020) IMOL,CHARGE IF(IMOL.LT.NMOLEC) WRITE(LFNPR,*) 200 CONTINUE RETURN 900 FORMAT(//1X,'Natural Bond Orbitals (Summary):',//53X,'Principal ', + 'Delocalizations',/1X,' NBO Occupancy ', + ' Energy (geminal,vicinal,remote)',/1X,79('=')) 910 FORMAT(//1X,'Natural Bond Orbitals (Summary):',//1X,' ', + 'NBO Occupancy ',/1X,40('-')) 920 FORMAT(1X,'Molecular unit ',I2,' ',60A1) 930 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,10X,F9.5,F12.5,4X,28A1) 940 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,'-',A2,I2,5X,F9.5,F12.5, + 4X,28A1) 950 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,'-',A2,I2,'-',A2,I2,F9.5, + F12.5,4X,28A1) 960 FORMAT(52X,28A1) 970 FORMAT(1X,' -------------------------------') 980 FORMAT(1X,' Total Lewis',F11.5,' (',F8.4,'%)') 990 FORMAT(1X,' Valence non-Lewis',F11.5,' (',F8.4,'%)') 1000 FORMAT(1X,' Rydberg non-Lewis',F11.5,' (',F8.4,'%)') 1010 FORMAT(1X,' Total unit ',I2,F11.5,' (',F8.4,'%)') 1020 FORMAT(1X,' Charge unit ',I2,F11.5) END ***************************************************************************** SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) DIMENSION LIST(NDIM),DEL(NDIM),DELOC(NDIM,NDIM) DATA ZERO,ONE,CUTOFF,TENTH/0.0D0,1.0D0,1.0D-4,0.1D0/ DATA AUKCAL,EVKCAL/627.51,23.060/ Determine the conversion factor to kcal: IF(MUNIT.EQ.0) THEN CONV = AUKCAL ELSE IF(MUNIT.EQ.1) THEN CONV = EVKCAL ELSE CONV = ONE END IF Determine the strength of each delocalization: DO 10 JBO = 1,NBAS LIST(JBO) = 0 DEL(JBO) = ZERO 10 CONTINUE NL = 0 IF(OCC.LT.TENTH) RETURN DO 20 JBO = 1,NBAS IF(IBO.NE.JBO) THEN IF(NBOTYP(JBO).GE.10) THEN DEL(JBO) = DELOC(IBO,JBO)*DELOC(IBO,JBO) IF(IFLG.EQ.0) THEN DIV = ABS(DELOC(IBO,IBO)-DELOC(JBO,JBO)) IF(DIV.NE.ZERO) THEN DEL(JBO) = OCC * DEL(JBO)/DIV * CONV ELSE DEL(JBO) = ZERO END IF END IF END IF IF(DEL(JBO).GT.THR2.AND.NBOUNI(IBO).NE.NBOUNI(JBO)) THEN NL = NL + 1 LIST(NL) = JBO ELSE IF(DEL(JBO).GT.THR1) THEN NL = NL + 1 LIST(NL) = JBO END IF END IF 20 CONTINUE Sort delocalizations: DO 100 I = 1,NL DO 90 J = 1,NL-1 KBO = LIST(J) LBO = LIST(J+1) IF(DEL(LBO)-DEL(KBO).GT.CUTOFF) THEN LIST(J) = LBO LIST(J+1) = KBO END IF 90 CONTINUE 100 CONTINUE RETURN END ***************************************************************************** SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (MAXCHR = 28, MAXD = 4) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION LIST(NDIM),ISTR(80) INTEGER IK(MAXD) DATA ICOMMA,ILEFT,IRIGHT/',','(',')'/ Build a character string (for the NBO summary table) which contains the delocalization information for NBO # IBO: ML = 0 10 IL = IL + 1 IF(IL.GT.NL) GO TO 30 CALL IDIGIT(LIST(IL),IK,ND,MAXD) IF(ML+ND+4.GT.MAXCHR) GO TO 30 IF(ML.NE.0) THEN ML = ML + 1 ISTR(ML) = ICOMMA END IF DO 20 I = 1,ND ML = ML + 1 ISTR(ML) = IK(I) 20 CONTINUE ML = ML + 1 ISTR(ML) = ILEFT ML = ML + 1 ISTR(ML) = IHTYP(IBO,LIST(IL)) ML = ML + 1 ISTR(ML) = IRIGHT GO TO 10 30 IL = IL - 1 RETURN END ***************************************************************************** SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) FORM NATURAL LOCALIZED MOLECULAR ORBITALS FROM DENSITY MATRIX A. N: ACTUAL DIMENSION OF A,EVEC NDIM: DECLARED DIMENSION OF A,EVEC TSYM: SCRATCH RESON: SQUARES OF DIAGONAL ELEMENTS OF NBO TO NLMO TRANSF, TIMES 100% IALARM: ALARM THAT THE ORBITAL OCCUPANCIES ARE OUT OF ORDER AND THAT THE LMO STEP SHOULD BE AVOIDED THESE VALUES ARE SET: DIFFER = 1.0D-5 DONE = 1.0D-10 (THIS IS THE PARAMETER FOR CONVERGENCE OF THE OFF- DIAGONAL MATRIX ELEMENTS.) EPS = 1.0D-11 (THIS PARAMETER HAS TO DO WITH THE MACHINE PRECISION AND SHOULD BE SET TO A VALUE BETWEEN "DONE" AND THE MACHINE PRECISION.) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ZEROJ COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DIMENSION A(NDIM,NDIM),EVEC(NDIM,1),EVAL(1),TSYM(1),RESON(NDIM) DIMENSION ROT(2,2) DIMENSION ILIST(100),JLIST(100),IOFF(100),JOFF(100),IUNIQ(100), + JUNIQ(100) IMPORTANT PARAMETERS: DATA DIFFER,DONE,EPS/1.0D-5,1.0D-10,1.0D-11/ NOFFMX IS SET TO THE DIMENSION OF VECTORS ILIST,JLIST,IOFF,JOFF,IUNIQ,JUNIQ: DATA DEGTHR,NOFFMX/1.0D-3,100/ DATA ZERO,ONE,TEN,HUNDRD/0.0D0,1.0D0,10.0D0,100.0D0/ WRITE(LFNPR,8390) THR1 = ONE - DEGTHR THR2 = ONE - DEGTHR*5 NTIME = 0 IF THERE IS ONLY ONE BASIS FUNCTION, SOLVE THIS TRIVIAL CASE AND RETURN: IF(N.GT.1) GO TO 10 EVEC(1,1) = ONE EVAL(1) = A(1,1) RETURN 10 CONTINUE DO 30 J = 1,N DO 20 I = 1,N 20 EVEC(I,J) = ZERO 30 EVEC(J,J) = ONE COUNT THE NUMBER OF ELECTRONS AND OCCUPIED ORBITALS: TOTELE = ZERO DO 50 I = 1,N 50 TOTELE = TOTELE + A(I,I) TOTELE = TOTELE + DIFFER NOCC = TOTELE IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2) NVIRST = NOCC + 1 CHECK IF OCCUPANCIES ARE IN ORDER: IALARM = 0 VIRMAX = ZERO DO 60 J = NVIRST,N IF(A(J,J).LT.VIRMAX) GO TO 60 VIRMAX = A(J,J) 60 CONTINUE OCCMIN = HUNDRD DO 70 I = 1,NOCC IF(A(I,I).GT.OCCMIN) GO TO 70 OCCMIN = A(I,I) 70 CONTINUE X = OCCMIN - VIRMAX 21 OCT 1987. THE FOLLOWING FEATURE OF THE PROGRAM HAS BEEN TURNED OFF BECAUSE SOMETIMES IT IS NOT POSSIBLE TO DIAGONALIZE THE NBO DENSITY MATRIX WHEN ONE OF THE ``A'' NBOS IS DEGENERATE IN OCCUPANCY WITH ONE OR MORE ``B'' NBOS: THE "ABS(X).LT.DIFFER" PART OF THE NEXT LINE IS INCLUDED SO THAT NLMOS CAN BE COMPUTED WHEN A NUMBER OF ORBITALS ARE NEARLY DEGENERATE IN OCCUPANCY, AS FOR INSTANCE IN CLI6, WHERE SIX LITHIUM LONE PAIRS ARE DEGENERATE BUT ONLY ONE OF THEM CAN BE PLACED IN THE "OCCUPIED" SET OF NLMOS. IF(X.GT.ZERO.OR.ABS(X).LT.DIFFER) GO TO 100 THE ABOVE STATEMENT IS REPLACED BY: IF(X.GT.DIFFER) GO TO 100 OCCUPANCIES OUT OF ORDER: IALARM = 1 IF(ABS(X).GT.DIFFER) GO TO 80 WRITE(LFNPR,8010) GO TO 90 80 WRITE(LFNPR,8000) 90 CONTINUE RETURN START LOOP: 100 CONTINUE NTIME = NTIME + 1 FIRST, FIND ELEMENT A(IOCC,JEMT) OF LARGEST MAGNITUDE, OFFTOP: OFFTOP = ZERO DO 200 JEMT = NVIRST,N DO 200 IOCC = 1,NOCC ABSAIJ = ABS(A(IOCC,JEMT)) IF(ABSAIJ.LT.OFFTOP) GO TO 200 OFFTOP = ABSAIJ AII = A(IOCC,IOCC) AJJ = A(JEMT,JEMT) 200 CONTINUE RETURN IF CONVERGENCE HAS BEEN ACHIEVED: IF(OFFTOP.LT.DONE) GO TO 900 FIND ALL ELEMENTS DEGENERATE WITH LARGEST ONE, OFFTOP: (CHECK CORRESPONDING DIAGONAL ELEMENTS ALSO) NOFF: NUMBER OF DEGENERATE ELEMENTS IOFF(K),JOFF(K): KTH DEGENERATE ELEMENT OFFTST = OFFTOP * THR1 AIIL = AII*THR2 AJJL = AJJ*THR2 AIIU = AII/THR2 AJJU = AJJ/THR2 ZEROJ = .FALSE. IF(AJJ.LT.DIFFER) ZEROJ = .TRUE. NOFF = 0 DO 250 JEMT = NVIRST,N DO 250 IOCC = 1,NOCC ABSAIJ = ABS(A(IOCC,JEMT)) IF(ABSAIJ.LT.OFFTST) GO TO 250 AIII = A(IOCC,IOCC) AJJJ = A(JEMT,JEMT) IF((AIII.LT.AIIL).OR.(AIII.GT.AIIU)) GO TO 250 SKIP TEST OF DIAG. ELEM. IF SMALL (.LT.DIFFER): IF(ZEROJ) GO TO 240 IF((AJJJ.LT.AJJL).OR.(AJJJ.GT.AJJU)) GO TO 250 240 NOFF = NOFF + 1 IOFF(NOFF) = IOCC JOFF(NOFF) = JEMT 250 CONTINUE IF(NOFF.LT.NOFFMX) GO TO 260 WRITE(LFNPR,2500) NOFF,NOFFMX 2500 FORMAT(//1X,'NOFF = ',I5,' IS GREATER THAN NOFFMX =',I5, * /5X,' MUST ABORT NLMO PROCEDURE') IALARM = 1 RETURN 260 CONTINUE S = AJJ - AII ABSS = ABS(S) IF THE ROTATION IS VERY CLOSE TO 45 DEGREES, SET SIN AND COS TO 1/(ROOT 2) TEST=EPS*OFFTOP IF (ABSS.GT.TEST) GO TO 330 S=.707106781D0 C=S GO TO 340 CALCULATION OF SIN AND COS FOR ROTATION THAT IS NOT VERY CLOSE TO 45 DEGREES 330 T=OFFTOP/S S=0.25D0/ SQRT(0.25D0+T*T) JACOBI ROTATION ANGLE: COS=C , SIN=S C= SQRT(0.5D0+S) S=2.D0*T*S/C 340 CONTINUE PRINT STATEMENTS FOR NLMO PROCEDURE DETAILS: WRITE(LFNPR,9903) OFFTOP,S,C,NOFF 9903 FORMAT(' ****** OFFTOP,S,C,NOFF:',3F14.9,I3) WRITE(LFNPR,9901) (IOFF(I),I=1,NOFF) 9901 FORMAT(' IOFF:',20I3) WRITE(LFNPR,9902) (JOFF(I),I=1,NOFF) 9902 FORMAT(' JOFF:',20I3) SIMPLE 2 BY 2 ROTATION, NO DEGENERACY PROBLEMS: IF(NOFF.GT.1) GO TO 400 IOCC=IOFF(1) JEMT=JOFF(1) IF(A(IOCC,JEMT).LT.ZERO) S=-S ROT(1,1)=C ROT(2,2)=C ROT(1,2)=S ROT(2,1)=-S IOFF(2)=JOFF(1) CALL LIMTRN(A,IOFF,ROT,EVAL,NDIM,N,2,2,0) ROTATION COMPLETED DO 380 I=1,N T=EVEC(I,IOCC) EVEC(I,IOCC)=C*T-EVEC(I,JEMT)*S 380 EVEC(I,JEMT)=S*T+EVEC(I,JEMT)*C GO TO 800 400 CONTINUE NOFF.GT.1: COMPUTE "AVERAGED" UNITARY TRANSFORMATION SO THAT SYMMETRY IS PRESERVED CONSTRUCT UNIQUE LISTS OF ORBITALS INVOLVED: IUNIQ(L): L-TH UNIQUE OCCUPIED ORB. NIUNIQ: NO. OF UNIQUE OCC. ORBS ILIST(L): LOCATION IN THE UNIQUE LIST (IUNIQ) OF THE I VALUE OF THE L-TH OFFDIAG. ELEMENT JUNIQ, NJUNIQ, AND JLIST ARE FOR THE EMPTY ORBITALS. IUNIQ(1)=IOFF(1) ILIST(1)=1 NIUNIQ=1 DO 500 MOFF=2,NOFF I=IOFF(MOFF) IIMAX=MOFF-1 DO 490 II=1,IIMAX IF(IOFF(II).NE.I) GO TO 490 ILIST(MOFF)=ILIST(II) GO TO 500 490 CONTINUE NIUNIQ=NIUNIQ+1 ILIST(MOFF)=NIUNIQ IUNIQ(NIUNIQ)=I 500 CONTINUE JUNIQ(1)=JOFF(1) JLIST(1)=NIUNIQ+1 NJUNIQ=1 DO 540 MOFF=2,NOFF J=JOFF(MOFF) JJMAX=MOFF-1 DO 530 JJ=1,JJMAX IF(JOFF(JJ).NE.J) GO TO 530 JLIST(MOFF)=JLIST(JJ) GO TO 540 530 CONTINUE NJUNIQ=NJUNIQ+1 JLIST(MOFF)=NJUNIQ+NIUNIQ JUNIQ(NJUNIQ)=J 540 CONTINUE NROT=NIUNIQ+NJUNIQ NROT2=NROT*NROT N1=NROT2+1 N2=NROT2+N1 CONSTRUCT TSYM: CALL SYMUNI(TSYM,A,C,S,TSYM(N1),TSYM(N2),EVAL,NROT, * NIUNIQ,NJUNIQ, * ILIST,JLIST,NOFF,IOFF,JOFF,NDIM) MAKE IUNIQ INTO A COMPLETE LIST OF THE UNIQUE ORBITALS, AND TRANSFORM THE NBO TO NLMO TRANSF. (EVEC) AND THE DM (A) BY TSYM: II=NIUNIQ DO 700 I=1,NJUNIQ II=II+1 700 IUNIQ(II)=JUNIQ(I) CALL LIMTRN(EVEC,IUNIQ,TSYM,EVAL,NDIM,N,NROT,NROT,1) CALL LIMTRN(A,IUNIQ,TSYM,EVAL,NDIM,N,NROT,NROT,0) SEE HOW MUCH THE ELEMENTS WERE REDUCED: DO 750 MOFF=1,NOFF I=IOFF(MOFF) J=JOFF(MOFF) WRITE(LFNPR,9920) I,J,(A(I,J)) 9920 FORMAT(' I,J,AIJ:',2I3,F14.9) 750 CONTINUE 800 CONTINUE TOTELE=ZERO DO 810 J=1,N TOTELE=TOTELE+A(J,J) 810 CONTINUE TOT=NEL FRACT=TOTELE-TOT WRITE(LFNPR,7000) NOFF,TOTELE,FRACT GO TO 100 FINISHED: PLACE OCCUPANCIES IN EVAL AND COUNT UP ELECTRONS: 900 CONTINUE TOTELE = ZERO DO 910 J = 1,N EVAL(J) = A(J,J) TOTELE = TOTELE + EVAL(J) X = EVEC(J,J) RESON(J) = X * X * HUNDRD 910 CONTINUE TOTP = TOTELE + DIFFER NEL = TOTP TOT = NEL FRACT = ABS(TOTELE-TOT) IF(FRACT.GT.DIFFER) GO TO 990 FIND THE LARGEST OFF-DIAGONAL DENSITY MATRIX ELEMENT: AMAX = ZERO DO 960 J = 2,N JM1 = J - 1 DO 950 I = 1,JM1 IF(ABS(A(I,J)).LT.AMAX) GO TO 950 AMAX = ABS(A(I,J)) 950 CONTINUE 960 CONTINUE WRITE(LFNPR,9500) AMAX IF THIS IS A CORRELATED WAVEFUNCTION, RETURN TO THE CALLING ROUTINE: IF(CI.OR.MCSCF.OR.AUHF) RETURN FOR SCF WAVEFUNCTIONS, MAKE SURE THIS MATRIX ELEMENT IS SMALL: IF(AMAX.LT.HUNDRD*HUNDRD*DONE) RETURN WRITE(LFNPR,9550) IALARM = 1 RETURN NON-INTEGER NUMBER OF ELECTRONS: 990 WRITE(LFNPR,9900) DIFFER,TOTELE WRITE(LFNPR,9600) WRITE(LFNPR,9610) (EVAL(I),I=1,NBAS) IALARM = 1 RETURN 8000 FORMAT(/1X,'Highest occupied NBOs are not at the beginning', + ' of the NBO list;',/,1X,'The NLMO program is not ', + 'currently set up to handle this.') 8010 FORMAT(/1X,'Degeneracy between orbitals in the (a) and (b)', * ' sets detected;', * /1X,'NLMO program cannot always handle this situation.') 8390 FORMAT(//1X,'NATURAL LOCALIZED MOLECULAR ORBITAL (NLMO) ', * 'ANALYSIS:') 9500 FORMAT(/1X,'Maximum off-diagonal element of DM in NLMO basis:', * E13.5) 9550 FORMAT(/1X,'Something went wrong in the NLMO procedure; density', * ' matrix of SCF',/1X,'wave function has not been diagonalized') 9600 FORMAT(/1X,'Occupancies of NLMOs:') 9610 FORMAT(/1X,8F10.5) 9900 FORMAT(/1X,'Number of electrons (trace of DM, NLMO basis) is not', * ' within ',F10.5/' of an integer:',F10.5,' - - PROGRAM ABORT') END ***************************************************************************** SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO, * SIAB,NOCC,NAB) ***************************************************************************** Revision 1.2 88/03/03 11:29:56 reed To reduce amount of output, deleted some blank lines, commented out print of atom totals for bond orders, and the atomic contrib. to the NLMO is only printed if it is greater than 0.01%. IMPLICIT REAL*8 (A-H,O-Z) INTEGER UL LOGICAL CLOSED PRINT OUT DETAILS OF NAO TO NLMO TRANSFORMATION IN MATRIX T. REQUIRED INPUT: NDIM = DECLARED DIMENSIONALITY OF ARRAY T NBAS = NO. OF ORBITALS = ACTUAL DIMENSION OF T, NAOL NAOL = INTEGER LIST OF ORBITAL ANG. MOMENTUM TYPE NAOL(I)/100 = L = Q.N. OF ATOMIC ORBITAL I IATNO = LIST OF ATOMIC NUMBERS; IATNO(I) IS THE NUCLEAR CHARGE OF ATOM I AS AN INTEGER NATOMS = NO. OF ATOMS (NOT INCLUDING GHOSTS) IN THE MOLECULE IWHYBS = 1 IF HYBRID A.O. COEFFICIENTS ARE TO BE PRINTED, 0 OTHERWISE. LFNPR = LOGICAL FILE NUMBER FOR PRINTOUT. NAOCTR = LIST OF ATOMIC CENTERS OF OAO OR NAO BASIS ORBITALS LABEL = LIST OF BOND ORBITAL LABELS IBXM = PERMUTATION LIST OF BOND ORBITALS BNDOCC = LIST OF BOND ORBITAL OCCUPANCIES ISPIN = 0 FOR CLOSED SHELL = 2 FOR ALPHA SPIN =-2 FOR BETA SPIN PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP1(MAXBAS), + IPRIN(MAXBAS) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),OCC(NDIM),RESON(NDIM), * TS(NDIM),SIAB(NOCC,NAB),ATLMO(NOCC,NATOMS), * BORDER(NATOMS,NATOMS),OWBORD(NATOMS,NATOMS), * PCT(5),POW(5),LNAME(5),ISP(3),NAM(3),ICH(3,2) CHARACTER*80 TITLE DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/ DATA LNAME/'s','p','d','f','g'/ DATA ZERO,HUNDTH,T99,T99P/0.0D0,1.D-2,99.99D0,99.995D0/ DATA TWO,TENTH,HUNDRD,THR/2.0D0,0.1D0,100.0D0,1.0D-6/ DATA LHYP,LBLNK,L2BLNK/'-',' ',' '/ DATA BOTHR/2.0D-3/ CLOSED=.TRUE. IF(ISPIN.NE.0) CLOSED=.FALSE. IF(ISPIN.EQ.0) WRITE(LFNPR,8400) IF(ISPIN.EQ.2) WRITE(LFNPR,8410) IF(ISPIN.EQ.-2) WRITE(LFNPR,8420) WRITE(LFNPR,8000) WRITE(LFNPR,8100) (LHYP,J=1,79) LOOP OVER OCCUPIED NLMOS: DO 900 NLMO=1,NBAS IF(OCC(NLMO).LT.TENTH) GO TO 900 IB=IBXM(NLMO) LBL=LABEL(IB,1) IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR=1 IF(LBL.EQ.LBD) NCTR=2 IF(LBL.EQ.L3C) NCTR=3 DO 110 I=1,3 IA=LABEL(IB,I+3) CALL CONVRT(IA,ICH(I,1),ICH(I,2)) NAM(I)=L2BLNK IF(IA.GT.0) NAM(I)=NAMEAT(IATNO(IA)) ISP(I)=LHYP IF(I.GE.NCTR) ISP(I)=LBLNK 110 CONTINUE LOOP OVER ATOMIC CENTERS OF BOND ORBITAL NBOND DO 170 ICTR=1,NCTR ISP(ICTR)=LHYP IF(ICTR.EQ.NCTR) ISP(ICTR)=LBLNK I=LABEL(IB,ICTR+3) NEL=NAMEAT(IATNO(I)) 170 CONTINUE WRITE(LFNPR,8220) NLMO,OCC(NLMO),RESON(NLMO),(LABEL(IB,K), + K=1,3),(NAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3) IF(OCC(NLMO).LT.TENTH.AND.LBL.EQ.LRY) GO TO 900 LOOP OVER ATOMS: (J COUNTS OVER NAOS) DO 700 IAT=1,NATOMS NL=0 DO 200 L=1,5 200 PCT(L)=ZERO JLOW=LL(IAT) JHIGH=UL(IAT) DO 300 J=JLOW,JHIGH L=NAOL(J)/100+1 COEF=T(J,NLMO) PCT(L)=PCT(L)+COEF*COEF 300 CONTINUE PRINT OUT CONTRIBUTION FROM ATOM IAT (AND SAVE IN ATLMO): NL=L POL=ZERO DO 340 L=1,5 340 POL=POL+PCT(L) IF(NLMO.LE.NOCC) ATLMO(NLMO,IAT)=POL PCTPOL=POL*HUNDRD PRINT ONLY CONTRIBUTIONS GREATER THAN 0.01% IF(PCTPOL.LT.HUNDTH) GO TO 700 DO 350 L=1,5 350 PCT(L)=HUNDRD*PCT(L)/POL FIND LEADING NON-ZERO CONTRIBUTION TO DETERMINE POW(L) FOR EACH L LSTD=0 DO 460 L=1,NL IF(LSTD.GT.0) GO TO 450 POW(L)=ZERO STD=PCT(L) IF(STD.LT.HUNDTH) GO TO 460 LSTD=L 450 POW(L)=PCT(L)/STD IF(POW(L).GT.T99P) POW(L)=T99 460 CONTINUE NL1=NL NEL=NAMEAT(IATNO(IAT)) IF(NL1.GT.3) NL1=3 WRITE(LFNPR,8300) * PCTPOL,NEL,IAT,PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1) IF(NL.GT.3) WRITE(LFNPR,8310) * (LNAME(L),POW(L),PCT(L),L=4,NL) 700 CONTINUE 900 CONTINUE NOW, COMPUTE HYBRID OVERLAPS SIAB: IF(ORTHO) GOTO 2200 CALL FESNAO(S) DO 1500 NLMO=1,NOCC IAB=0 NATM1=NATOMS-1 DO 1400 IAT=1,NATM1 IALOW=LL(IAT) IAHIGH=UL(IAT) DO 1100 L=1,NBAS IF(L.GE.IALOW.AND.L.LE.IAHIGH) GO TO 1100 TS(L)=ZERO DO 1050 K=IALOW,IAHIGH 1050 TS(L)=TS(L)+T(K,NLMO)*S(K,L) 1100 CONTINUE IF(IAT.GT.2) GO TO 1130 CALL ALTOUT(TS,1,NDIM,1,NDIM) 1130 CONTINUE JAT0=IAT+1 DO 1300 JAT=JAT0,NATOMS IAB=IAB+1 OVP=ZERO JALOW=LL(JAT) JAHIGH=UL(JAT) DO 1200 L=JALOW,JAHIGH 1200 OVP=OVP+TS(L)*T(L,NLMO) ANORM=SQRT(ATLMO(NLMO,IAT)*ATLMO(NLMO,JAT)) IF(ANORM.LT.THR) GO TO 1250 SIAB(NLMO,IAB)=OVP/ANORM IF(IAT.GT.2) GO TO 1300 WRITE(LFNPR,9996) JAT,IAB,JALOW,JAHIGH,OVP,ANORM, * SIAB(NLMO,IAB) 9996 FORMAT(1X,'JAT,IAB,JALOW,JAHIGH,OVP,ANORM,SIAB:', * /5X,4I3,3F11.6) GO TO 1300 1250 SIAB(NLMO,IAB)=ZERO IF(IAT.GT.2) GO TO 1300 WRITE(LFNPR,9996) JAT,IAB,JALOW,JAHIGH,OVP,ANORM, * SIAB(NLMO,IAB) 1300 CONTINUE 1400 CONTINUE 1500 CONTINUE NOW WE ARE READY TO COMPUTE BOND ORDERS! IF(JPRINT(12).NE.0) THEN IAB=0 NATM1=NATOMS-1 WRITE(LFNPR,9000) DO 2000 IAT=1,NATM1 JAT0=IAT+1 DO 1900 JAT=JAT0,NATOMS IAB=IAB+1 SUM=ZERO OWSUM=ZERO DO 1800 NLMO=1,NOCC ALAMA2=ATLMO(NLMO,IAT) ALAMB2=ATLMO(NLMO,JAT) OVP=SIAB(NLMO,IAB) BO=ALAMA2 IF(ALAMB2.LT.ALAMA2) BO=ALAMB2 WRITE(LFNPR,8999) ALAMA2,ALAMB2,BO 8999 FORMAT(1X,'ALAMA2,ALAMB2,BO:',3F14.7) IF(CLOSED) BO=BO*TWO OWBO=BO*OVP IF(OVP.LT.ZERO) BO=-BO IF(ABS(BO).GT.BOTHR) * WRITE(LFNPR,9100) IAT,JAT,NLMO,BO,OVP SUM=SUM+BO OWSUM=OWSUM+OWBO 1800 CONTINUE WRITE(LFNPR,9110) SUM,OWSUM BORDER(IAT,JAT)=SUM BORDER(JAT,IAT)=SUM OWBORD(IAT,JAT)=OWSUM OWBORD(JAT,IAT)=OWSUM 1900 CONTINUE 2000 CONTINUE ZERO DIAGONAL ELEMENTS! DO 2020 IAT=1,NATOMS BORDER(IAT,IAT)=ZERO 2020 OWBORD(IAT,IAT)=ZERO COMPUTE TOTALS BY ATOM AND PRINT RESULTS: DO 2100 IAT=1,NATOMS SUM=ZERO DO 2050 JAT=1,NATOMS SUM=SUM+BORDER(IAT,JAT) 2050 CONTINUE TS(IAT)=SUM 2100 CONTINUE TITLE = 'Atom-Atom Net Linear NLMO/NPA Bond Orders:' CALL AOUT(BORDER,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS) TITLE = 'Linear NLMO/NPA Bond Orders, Totals by Atom:' CALL AOUT(TS,NATOMS,NATOMS,1,TITLE,0,1) END IF 2200 CONTINUE RETURN 8000 FORMAT(1X,'NLMO/Occupancy/Percent from Parent NBO/ Atomic ', + 'Hybrid Contributions') 8100 FORMAT(1X,80A1) 8220 FORMAT(1X,I3,'. (',F7.5,') ',F8.4,'% ',A2,A1,'(',I2,')', + 3(A2,3A1)) 8300 FORMAT(26X,F7.3,'% ',A2,I2,' s(',F6.2,'%)',2(A1,F5.2,'(', + F6.2,'%)')) 8310 FORMAT(50X,2(A1,F5.2,'(',F6.2,'%)')) 8400 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ', * 'in NAO Basis:') 8410 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ', * 'in NAO Basis, Alpha Spin:') 8420 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ', * 'in NAO Basis, Beta Spin:') 9000 FORMAT(/1X,'Individual LMO bond orders greater than 0.002', * ' in magnitude,'/1X, * 'with the overlap between the hybrids in the NLMO given:',//1X, * 'Atom I / Atom J / NLMO / Bond Order / Hybrid Overlap /') 9100 FORMAT(1X,I4,I8,2X,I6,F14.7,F16.7) END ***************************************************************************** SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL TEST DM -- NLMO density matrix (input) T -- AO to NLMO transformation matrix (input) C -- NBO to NLMO transformation matrix (retrieved from NBODAF) TNBO -- AO to NBO transformation (retrieved from NBODAF) DX,DY,DZ -- AO dipole matrices (retrieved from NBODAF) SCR -- NDIM*NDIM word scratch vector INDEX -- temporary indexing array PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBDXYZ/XDIP,YDIP,ZDIP,CHARGE(MAXATM) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORB(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),C(NDIM,NDIM),TNBO(NDIM,NDIM), + DX(NDIM,NDIM),DY(NDIM,NDIM),DZ(NDIM,NDIM),SCR(NDIM*NDIM), + INDEX(NDIM) DIMENSION ISTR(14),COUPLE(3) DATA TENTEN,SMALL,ZERO,TENTH,ONE,TWO/1.0D-10,1.0D-5,0.0D0,0.1D0, + 1.0D0,2.0D0/ DATA TOESU/4.803242E-10/ DATA IHYPH,IBLNK/1H-,1H / DEBYE = TOESU / TENTEN Copy the nuclear charges into CHARGE: IF(ALPHA.OR..NOT.OPEN) THEN DO 10 I = 1,NATOMS CHARGE(I) = IZNUC(I) 10 CONTINUE END IF Determine the number of occupied orbitals and make sure that the occupied NLMOs are at the beginning of the list: TOT = ZERO DO 20 I = 1,NBAS TOT = TOT + DM(I,I) SCR(I) = DM(I,I) 20 CONTINUE NEL = TOT + TENTH TOT = NEL NOCC = NEL IF(.NOT.OPEN) NOCC = NOCC/2 + MOD(NOCC,2) CALL RANK(SCR,NBAS,NDIM,INDEX) DO 30 I = 1,NOCC IF(INDEX(I).GT.NOCC) THEN WRITE(LFNPR,1000) RETURN END IF 30 CONTINUE Determine the occupancy factor: ETA = TWO IF(OPEN) ETA = ONE Compute the electronic contributions to the NBO bond dipole moments: CALL FETLMO(C) CALL FETNBO(TNBO) II = 1 CALL DIPELE(DX,C,TNBO,SCR,ETA,NOCC,II) IF(II.EQ.0) RETURN II = 2 CALL DIPELE(DY,C,TNBO,SCR,ETA,NOCC,II) IF(II.EQ.0) RETURN II = 3 CALL DIPELE(DZ,C,TNBO,SCR,ETA,NOCC,II) IF(II.EQ.0) RETURN Add the nuclear contributions to these bond dipole moments: CALL DIPNUC(DX,DY,DZ,SCR,ETA,NOCC) Convert to Debye: DO 50 I = 1,NOCC DO 40 J = 1,NBAS DX(J,I) = DX(J,I) * DEBYE DY(J,I) = DY(J,I) * DEBYE DZ(J,I) = DZ(J,I) * DEBYE 40 CONTINUE 50 CONTINUE Print dipole analysis: XNBO = ZERO YNBO = ZERO ZNBO = ZERO XNLMO = ZERO YNLMO = ZERO ZNLMO = ZERO DO 100 I = 1,NOCC IF(I.EQ.1) THEN IF(ALPHA) WRITE(LFNPR,1010) IF(BETA) WRITE(LFNPR,1020) IF(.NOT.OPEN) WRITE(LFNPR,1030) WRITE(LFNPR,1040) ABS(DTHR) ELSE WRITE(LFNPR,1050) END IF Build the label for this NBO/NLMO: IB = IBXM(I) ISTR(1) = LABEL(IB,1) ISTR(2) = LABEL(IB,2) ISTR(3) = LABEL(IB,3) DO 70 J = 1,3 J4 = 4 * J IF(LABEL(IB,J+3).EQ.0) THEN DO 60 K = J4-1,J4+2 ISTR(K) = IBLNK 60 CONTINUE ELSE IF(J.NE.1) ISTR(J4-1) = IHYPH ISTR(J4) = NAMEAT(IATNO(LABEL(IB,J+3))) CALL CONVRT(LABEL(IB,J+3),ISTR(J4+1),ISTR(J4+2)) END IF 70 CONTINUE Compute the NLMO bond dipole (the NBO bond dipoles are on the diagonal of DX,DY,DZ): X = ZERO Y = ZERO Z = ZERO DO 80 J = 1,NBAS X = X + DX(J,I) Y = Y + DY(J,I) Z = Z + DZ(J,I) 80 CONTINUE XNBO = XNBO + DX(I,I) YNBO = YNBO + DY(I,I) ZNBO = ZNBO + DZ(I,I) XNLMO = XNLMO + X YNLMO = YNLMO + Y ZNLMO = ZNLMO + Z Compute the net dipole for these orbitals: TOT = SQRT(DX(I,I)*DX(I,I) + DY(I,I)*DY(I,I) + DZ(I,I)*DZ(I,I)) TOTNLM = SQRT(X*X + Y*Y + Z*Z) WRITE(LFNPR,1060) I,(ISTR(J),J=1,14),X,Y,Z,TOTNLM, + DX(I,I),DY(I,I),DZ(I,I),TOT Print delocalization terms which are stronger than ABS(DTHR): ICNT = 0 DO 90 J = 1,NBAS IF(J.NE.I) THEN TOT = SQRT(DX(J,I)*DX(J,I) + DY(J,I)*DY(J,I) + + DZ(J,I)*DZ(J,I)) IF(TOT.GT.ABS(DTHR)) THEN ICNT = ICNT + 1 INDEX(ICNT) = J SCR(ICNT) = TOT END IF END IF 90 CONTINUE DO 95 J = 1,ICNT DO 94 K = 1,ICNT-J IF(SCR(K+1)-SCR(K).GT.SMALL) THEN ITEMP = INDEX(K) INDEX(K) = INDEX(K+1) INDEX(K+1) = ITEMP TEMP = SCR(K) SCR(K) = SCR(K+1) SCR(K+1) = TEMP END IF 94 CONTINUE 95 CONTINUE DO 96 JJ = 1,ICNT J = INDEX(JJ) WRITE(LFNPR,1070) J,DX(J,I),DY(J,I),DZ(J,I),SCR(JJ) 96 CONTINUE 100 CONTINUE Compute and print the correction for residual nuclear charges: IF(.NOT.ALPHA) THEN CALL FECOOR(SCR) X = ZERO Y = ZERO Z = ZERO TEST = .FALSE. DO 110 I = 1,NATOMS IF(ABS(CHARGE(I)).GT.SMALL) TEST = .TRUE. X = X + SCR(3*I-2) * CHARGE(I) * DEBYE Y = Y + SCR(3*I-1) * CHARGE(I) * DEBYE Z = Z + SCR(3*I) * CHARGE(I) * DEBYE 110 CONTINUE IF(TEST) THEN TOT = SQRT(X*X + Y*Y + Z*Z) WRITE(LFNPR,1080) X,Y,Z,TOT,X,Y,Z,TOT XNBO = XNBO + X YNBO = YNBO + Y ZNBO = ZNBO + Z XNLMO = XNLMO + X YNLMO = YNLMO + Y ZNLMO = ZNLMO + Z END IF END IF Print net dipole moments: TOT = SQRT(XNBO*XNBO + YNBO*YNBO + ZNBO*ZNBO) TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO) WRITE(LFNPR,1090) XNLMO,YNLMO,ZNLMO,TOTNLM,XNBO,YNBO,ZNBO,TOT Compute and print the total delocalization correction: X = XNLMO - XNBO Y = YNLMO - YNBO Z = ZNLMO - ZNBO TOT = SQRT(X*X + Y*Y + Z*Z) WRITE(LFNPR,1100) X,Y,Z,TOT Compute and print the NLMO coupling correction: TEST = .FALSE. DO 130 I = 1,NBAS IF(I.GT.NOCC.AND.ABS(DM(I,I)).GT.SMALL) TEST = .TRUE. DO 120 J = I+1,NBAS IF(ABS(DM(J,I)).GT.SMALL) TEST = .TRUE. 120 CONTINUE 130 CONTINUE IF(TEST) THEN TOT = ZERO DO 160 K = 1,3 II = K CALL FEDXYZ(DX,II) CALL SIMTRS(DX,T,SCR,NDIM,NBAS) COUPLE(K) = ZERO DO 150 I = 1,NBAS IF(I.LE.NOCC) THEN COUPLE(K) = COUPLE(K) + (ETA - DM(I,I)) * DX(I,I) ELSE COUPLE(K) = COUPLE(K) - DM(I,I) * DX(I,I) END IF DO 140 J = I+1,NBAS COUPLE(K) = COUPLE(K) - TWO * DM(J,I) * DX(J,I) 140 CONTINUE 150 CONTINUE COUPLE(K) = COUPLE(K) * DEBYE TOT = TOT + COUPLE(K) * COUPLE(K) 160 CONTINUE TOT = SQRT(TOT) WRITE(LFNPR,1110) XNLMO,YNLMO,ZNLMO,TOTNLM,XNLMO,YNLMO,ZNLMO, + TOTNLM,(COUPLE(K),K=1,3),TOT XNLMO = XNLMO + COUPLE(1) YNLMO = YNLMO + COUPLE(2) ZNLMO = ZNLMO + COUPLE(3) TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO) IF(ALPHA) WRITE(LFNPR,1120) XNLMO,YNLMO,ZNLMO,TOTNLM IF(BETA) WRITE(LFNPR,1130) XNLMO,YNLMO,ZNLMO,TOTNLM IF(.NOT.OPEN) WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM ELSE IF(ALPHA) WRITE(LFNPR,1120) XNLMO,YNLMO,ZNLMO,TOTNLM, + XNLMO,YNLMO,ZNLMO,TOTNLM IF(BETA) WRITE(LFNPR,1130) XNLMO,YNLMO,ZNLMO,TOTNLM, + XNLMO,YNLMO,ZNLMO,TOTNLM IF(.NOT.OPEN) WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM, + XNLMO,YNLMO,ZNLMO,TOTNLM END IF Save the alpha spin dipoles: IF(ALPHA) THEN XDIP = XNLMO YDIP = YNLMO ZDIP = ZNLMO END IF Print out the total dipole moment for open shell species: IF(BETA) THEN XNLMO = XNLMO + XDIP YNLMO = YNLMO + YDIP ZNLMO = ZNLMO + ZDIP TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO) WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM END IF RETURN 1000 FORMAT(/1X,'The highest occupied NBOs are not at the beginning ', + 'of the list.',/1X,'The dipole moment analysis is currently not', + ' set up to handle this.') 1010 FORMAT(//1X,'Dipole moment analysis, alpha spin:') 1020 FORMAT(//1X,'Dipole moment analysis, beta spin:') 1030 FORMAT(//1X,'Dipole moment analysis:') 1040 FORMAT(/1X,'[Print threshold: Net dipole >',F5.2,' Debye]',//1X, + ' NLMO bond dipole ', + 'NBO bond dipole',/1X,' ----------', + '--------------- ------------------------',/1X,' ', + 'Orbital x y z Total x y ', + 'z Total',/1X,79('=')) 1050 FORMAT(1X) 1060 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1,1X,4F6.2, + 3X,4F6.2) 1070 FORMAT(1X,44X,'deloc ',I3,':',4F6.2) 1080 FORMAT(/1X,' Residual nuclear charge ',4F6.2,' ',4F6.2) 1090 FORMAT(1X,' -----------------------', + '-----------------------------',/1X,' Net dipole moment', + ' ',4F6.2,' ',4F6.2) 1100 FORMAT(1X,'Delocalization correction ',24X,' ',4F6.2,/1X, + ' -----------------------------', + '-----------------------') 1110 FORMAT(1X,' Net dipole moment ',4F6.2,' ',4F6.2,/1X, + ' NLMO coupling correction ',4F6.2,/1X,' ', + ' -------------------------') 1120 FORMAT(1X,' Alpha spin dipole ',4F6.2,' ',4F6.2) 1130 FORMAT(1X,' Beta spin dipole ',4F6.2,' ',4F6.2) 1140 FORMAT(1X,' Total dipole moment ',4F6.2,' ',4F6.2) END ***************************************************************************** SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION DXYZ(NDIM,NDIM),C(NDIM,NDIM),T(NDIM,NDIM),SCR(NDIM,NDIM) Compute the electronic contribution for the x (INDEX=1), y (=2), and z (=3) components of the dipole: Get the AO dipole matrix and transform to the NBO basis: CALL FEDXYZ(DXYZ,INDEX) IF(INDEX.EQ.0) RETURN CALL SIMTRS(DXYZ,T,SCR,NDIM,NBAS) Compute the electronic contribution for doubly occupied, filled NBOs: DO 30 I = 1,NOCC SCR(I,I) = -ETA * DXYZ(I,I) 30 CONTINUE Compute delocalization contributions for each filled NBO: DO 60 I = 1,NOCC DO 50 J = 1,NBAS IF(J.NE.I) THEN SCR(J,I) = C(J,I) * DXYZ(I,I) - C(I,I) * DXYZ(J,I) DO 40 K = 1,NBAS SCR(J,I) = SCR(J,I) - C(K,I) * DXYZ(K,J) 40 CONTINUE SCR(J,I) = ETA * C(J,I) * SCR(J,I) END IF 50 CONTINUE 60 CONTINUE CALL COPY(SCR,DXYZ,NDIM,NBAS,NBAS) RETURN END ***************************************************************************** SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBDXYZ/XDIP,YDIP,ZDIP,CHARGE(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION DX(NDIM,NDIM),DY(NDIM,NDIM),DZ(NDIM,NDIM), + ATCOOR(3,NATOMS) DATA ZERO/0.0D0/ Fetch the atomic coordinates: CALL FECOOR(ATCOOR) Calculate the nuclear contributions to the dipole moment: DO 20 I = 1,NOCC NCTR = MOD(NBOTYP(I),10) X = ZERO Y = ZERO Z = ZERO DO 10 J = 1,NCTR IAT = LABEL(IBXM(I),J+3) X = X + ATCOOR(1,IAT) Y = Y + ATCOOR(2,IAT) Z = Z + ATCOOR(3,IAT) CHARGE(IAT) = CHARGE(IAT) - ETA/NCTR 10 CONTINUE X = ETA * X / NCTR Y = ETA * Y / NCTR Z = ETA * Z / NCTR DX(I,I) = DX(I,I) + X DY(I,I) = DY(I,I) + Y DZ(I,I) = DZ(I,I) + Z 20 CONTINUE RETURN END ***************************************************************************** ROUTINES CALLED BY SR NATHYB, SR CHOOSE: SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR) FUNCTION IWPRJ(NCTR) SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD) SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB) SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP) SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB) SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG) SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI) SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB) SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD) SUBROUTINE FORMT(T,Q,POL) SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT) ***************************************************************************** SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) Label core, valence, and Rydberg NAO's and deplete DM of the density of the core orbitals LOGICAL DETAIL,FIRST PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),BORB(MXBO),POL(NDIM,3), * Q(MXAO,NDIM),HYB(MXAO),BNDOCC(NDIM),ICORE(4),IVAL(4),IANG(5) DATA ZERO,ONE/0.0D0,1.0D0/ DATA IBLK,ICOR,IRYD/' ','CR','Ryd'/ DATA ICHCOR,ICHVAL/'Cor','Val'/ DATA IANG/'s','p','d','f','g'/ Label NAO's on each center: DO 10 I = 1,NBAS LTYP(I) = IRYD 10 CONTINUE IECP = 0 DO 110 NCTR = 1,NATOMS CALL CORTBL(NCTR,ICORE,IECP) CALL VALTBL(NCTR,IVAL) Loop over s,p,d,f orbitals: DO 100 L = 0,3 ITYP = IANG(L+1) LNUM = 2*L + 1 IF(ICORE(L+1).LE.0) GOTO 50 Label core orbitals: DO 40 M = 1,ICORE(L+1) DO 30 LA = 1,LNUM MORB = 0 OCC = -1.0 DO 20 N = 1,NBAS LM = NAOL(N) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(N),50) IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND. + DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND. + LA.EQ.NA) THEN MORB = N OCC = DM(N,N) END IF 20 CONTINUE IF(MORB.EQ.0) THEN WRITE(LFNPR,2500) ITYP,NAMEAT(IATNO(NCTR)),NCTR, + (ICORE(I),I=1,4),M,LA STOP END IF LTYP(MORB) = ICHCOR 30 CONTINUE 40 CONTINUE 50 CONTINUE IF(IVAL(L+1).LE.0) GOTO 90 Label valence orbitals: DO 80 M = 1,IVAL(L+1) DO 70 LA = 1,LNUM MORB = 0 OCC = -1.0 DO 60 N = 1,NBAS LM = NAOL(N) NORB = LM/100 IL = IANG(NORB+1) NA = MOD(NAOL(N),50) IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND. + DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND. + LA.EQ.NA) THEN MORB = N OCC = DM(N,N) END IF 60 CONTINUE IF(MORB.EQ.0) THEN WRITE(LFNPR,2600) ITYP,NAMEAT(IATNO(NCTR)),NCTR, + (IVAL(I),I=1,4),M,LA STOP END IF LTYP(MORB) = ICHVAL 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE 110 CONTINUE Isolate core orbitals on all atoms, removing their density from the density matrix: DO 300 IAT = 1,NATOMS NB = IUL(IAT) - ILL(IAT) + 1 IAC = 0 FIRST = .TRUE. DO 290 N = ILL(IAT),IUL(IAT) IF(LTYP(N).EQ.ICHCOR) THEN IF(DETAIL.AND.FIRST) THEN FIRST = .FALSE. WRITE(LFNPR,1000) IAT END IF IAC = IAC + 1 IBD = IBD + 1 DO 280 I = 1,NB BORB(I) = ZERO 280 CONTINUE BORB(N-ILL(IAT)+1) = ONE CALL STASH(BORB,IBD,IAT,0,0,POL,Q,HYB) LABEL(IBD,1) = ICOR LABEL(IBD,2) = IBLK LABEL(IBD,3) = IAC LABEL(IBD,4) = IAT BNDOCC(IBD) = DM(N,N) IF(DETAIL) WRITE(LFNPR,1010) IAC,BNDOCC(IBD) IF(DETAIL) WRITE(LFNPR,1020) (BORB(I),I=1,NB) IF(DETAIL) WRITE(LFNPR,1030) IBD,(LABEL(IBD,I),I=1,3) END IF 290 CONTINUE 300 CONTINUE Deplete the density matrix of CR orbitals: CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD) RETURN 1000 FORMAT(/,1X,'Search of DM block for core orbitals on atom:',I4) 1010 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':') 1020 FORMAT(11X,8F7.4) 1030 FORMAT(11X,'*** NBO accepted: Number',I3,'. Label:',A2,A1, + '(',I2,')') 2500 FORMAT(/1X,'Subroutine CORE could not find a ',A1,'-type ', + 'core orbital on atom ',A2,I2,'.',/,1X,'ICORE :',4I3, + ' M :',I3,' LA :',I3) 2600 FORMAT(/1X,'Subroutine CORE could not find a ',A1,'-type ', + 'valence orbital on atom ',A2,I2,'.',/,1X,'IVAL :',4I3, + ' M :',I3,' LA :',I3) END ***************************************************************************** FUNCTION IWPRJ(NCTR) ***************************************************************************** DATA NCTR0/0/ RETURN 0 (NO PROJECTION WANTED) IF NCTR IS UNCHANGED, 1 OTHERWISE. IWPRJ=0 IF(NCTR.EQ.NCTR0) RETURN IWPRJ=1 NCTR0=NCTR RETURN END ***************************************************************************** SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DEPLETE DENSITY MATRIX DM OF CONTRIBUTION FROM B.O.'BORB': DM ==> DM - OCC*BORB*BORB(TRANSPOSE). PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3), * BORB(MXBO),BNDOCC(NDIM) DIMENSION IAT(3) RESTORE DM FROM T DO 10 J=1,NBAS DO 10 I=1,J DM(I,J)=T(I,J) 10 DM(J,I)=DM(I,J) MAIN LOOP OVER NBD AVAILABLE BOND ORBITALS: DO 90 IBD=1,NBD OCC=BNDOCC(IBD) FIND ATOMS FOR B.O. #IBD NCTR=0 DO 20 J=1,3 IAT(J)=LABEL(IBD,J+3) IF(IAT(J).LE.0) GO TO 30 NCTR=NCTR+1 20 CONTINUE RECONSTRUCT BORB FOR B.O. #IBD 30 NELM=0 DO 40 ICTR=1,NCTR IA=IAT(ICTR) IHYB=IATHY(IBD,ICTR)+ILL(IA)-1 P=POL(IBD,ICTR) NH=NORBS(IA) DO 40 IH=1,NH NELM=NELM+1 40 BORB(NELM)=P*Q(IH,IHYB) SUBTRACT OCC*BORB*BORB(T) FROM DM NROW=0 DO 80 ICTR=1,NCTR IA=IAT(ICTR) IU=IUL(IA) IL=ILL(IA) DO 70 IROW=IL,IU NROW=NROW+1 NCOL=0 DO 60 JCTR=1,NCTR JA=IAT(JCTR) JU=IUL(JA) JL=ILL(JA) DO 50 ICOL=JL,JU NCOL=NCOL+1 50 DM(IROW,ICOL)=DM(IROW,ICOL)-OCC*BORB(NROW)*BORB(NCOL) 60 CONTINUE 70 CONTINUE 80 CONTINUE 90 CONTINUE RETURN END ***************************************************************************** SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) ZERO THE MATRIX 'BLK' AND LOAD IN ATOMIC BLOCKS OF DENSITY MATRIX 'DM' FOR THE ATOMS LISTED IN 'IAT' PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION BLK(MXBO,MXBO),DM(NDIM,NDIM),IAT(3) DATA ZERO/0.0D0/ IAT(1)=IAT1 IAT(2)=IAT2 IAT(3)=IAT3 ZERO 'BLK' DO 10 I=1,MXBO DO 10 J=1,MXBO 10 BLK(I,J)=ZERO NROW=0 NCOL=0 DO 50 I=1,3 IA=IAT(I) IF(IA.EQ.0) GO TO 50 IU=IUL(IA) IL=ILL(IA) DO 40 IROW=IL,IU NROW=NROW+1 NCOL=0 DO 30 J=1,3 JA=IAT(J) IF(JA.EQ.0) GO TO 30 JU=IUL(JA) JL=ILL(JA) DO 20 ICOL=JL,JU NCOL=NCOL+1 BLK(NROW,NCOL)=DM(IROW,ICOL) 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE NB=NROW RETURN END ***************************************************************************** SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DETERMINE HOW MUCH OF BORB IS COMPOSED OF PREVIOUSLY USED HYBRIDS. RETURN HYBEXP(I) = EXPECTATION VALUE OF HYBRID "I" IN BORB OVER THE PROJECTION OPERATOR P FOR THE ATOM OF THE HYBRID. IF NO HYBRID ON ATOM I CONTRIBUTES TO BORB, HYBEXP(I) = ZERO. PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION IAT(3),HYB(MXAO),BORB(MXBO),Q(MXAO,NDIM),P(MXAO,MXAO), * PK(MXAO,MXAO),VA(MXAO),VB(MXAO),HYBEXP(3) DATA ZERO,ONE,EPS/0.0D0,1.0D0,1.0D-5/ LOOP OVER ATOMIC HYBRIDS: IAT(1) = IAT1 IAT(2) = IAT2 IAT(3) = IAT3 KMAX = 0 DO 50 I = 1,3 HYBEXP(I) = ZERO IA = IAT(I) IF(IA.EQ.0) GO TO 50 EXTRACT THE ITH ATOMIC HYBRID FROM BORB: NU = IUL(IA) NL = ILL(IA) KMIN = KMAX + 1 KMAX = KMAX + NU - NL + 1 MJ = 0 DO 10 K = KMIN,KMAX MJ = MJ + 1 HYB(MJ) = BORB(K) 10 CONTINUE DO HYBRIDS FROM THE ITH ATOM CONTRIBUTE TO BORB? S = ZERO DO 20 J = 1,MJ S = S + HYB(J)**2 20 CONTINUE IF(S.LT.EPS) GO TO 50 DETERMINE THE PROJECTION EXPECTATION FOR THIS HYBRID: NH = INO(IA) IF(NH.EQ.0) THEN HYBEXP(I) = ONE ELSE CALL FRMPRJ(P,IA,Q,NH,PK,VA,VB) PAV = ZERO DO 40 J = 1,MJ DO 30 K = 1,MJ PAV = PAV + HYB(K) * P(K,J) * HYB(J) 30 CONTINUE 40 CONTINUE HYBEXP(I) = ABS(PAV) / S END IF 50 CONTINUE RETURN END ***************************************************************************** SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DECOMPOSE BOND ORBITAL 'BORB' AND STORE CONSTITUENT HYBRIDS IN Q PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION POL(NDIM,3),Q(MXAO,NDIM),BORB(MXBO),IAT(3),HYB(MXAO) DATA ZERO/0.0D0/ LOOP OVER CENTERS: IAT(1) = IAT1 IAT(2) = IAT2 IAT(3) = IAT3 KMAX = 0 DO 40 I = 1,3 IA = IAT(I) IF(IA.EQ.0) GO TO 40 NU = IUL(IA) NL = ILL(IA) EXTRACT HYBRID FROM BOND ORBITAL FOR ATOM IA: KMIN = KMAX + 1 KMAX = KMAX + NU - NL + 1 MJ = 0 DO 10 K = KMIN,KMAX MJ = MJ + 1 HYB(MJ) = BORB(K) 10 CONTINUE EXTRACT POLARIZATION COEFFICIENT, STORE IN 'POL': PSQ = ZERO DO 20 J = 1,MJ PSQ = PSQ + HYB(J)**2 20 CONTINUE P = SQRT(PSQ) POL(IBD,I) = P ONE MORE HYBRID FOR ATOM IA: INO(IA) = INO(IA) + 1 NCOL = ILL(IA) + INO(IA) - 1 PLACE NORMALIZED HYBRID IN APPROPRIATE BLOCK OF Q: NH = NU - NL + 1 DO 30 NROW = 1,NH IF(P.EQ.ZERO) THEN Q(NROW,NCOL) = ZERO ELSE Q(NROW,NCOL) = HYB(NROW)/P END IF 30 CONTINUE IATHY(IBD,I) = INO(IA) 40 CONTINUE RETURN END ***************************************************************************** SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SYMMETRIC ORTHOGONALIZATION OF AVAILABLE HYBRIDS IN Q: PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + ILU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION Q(MXAO,NDIM),S(MXBO,MXBO),TA(MXAO,MXAO), * EVAL(MXBO),C(MXBO,MXBO) DATA ZERO,ONE/0.0D0,1.0D0/ DATA TOOSML/1.0D-4/ TOOSML: "TOO SMALL" -- THRESHOLD FOR AN S MATRIX EIGENVALUE THAT IS TOO SMALL AND WILL CAUSE NUMERICAL PROBLEMS AND IS INDICATIVE OF NEAR-LINEAR DEPENDENCY IN THE HYBRIDS: IALARM = 0 DO 100 IA = 1,NATOMS IL = LL(IA) NH = INO(IA) IF(NH.GT.MXAO) GO TO 800 IF(NH.LE.1) GO TO 100 LOAD IA-BLOCK OF Q INTO TA: DO 10 J = 1,NH DO 5 I = 1,MXAO TA(I,J) = Q(I,IL+J-1) 5 CONTINUE 10 CONTINUE FORM OVERLAP MATRIX S = TA(TRANSP)*TA: DO 30 J = 1,NH DO 25 I = J,NH TEMP = ZERO DO 20 K = 1,MXAO TEMP = TEMP + TA(K,I) * TA(K,J) 20 CONTINUE S(I,J) = TEMP S(J,I) = TEMP 25 CONTINUE 30 CONTINUE DIAGONALIZE OVERLAP MATRIX: CALL JACOBI(NH,S,EVAL,C,MXBO,MXBO,0) FORM INVERSE SQUARE ROOT OF S, STORE IN S: (AVOID NUMERICAL PROBLEMS OF LINEAR DEPENDENCE ("TOO SMALL" EIGENVALUES) BY PRESCREENING THE EIGENVALUES) DO 40 I = 1,NH IF(EVAL(I).LT.TOOSML) GO TO 810 EVAL(I) = ONE / SQRT(EVAL(I)) 40 CONTINUE DO 60 J = 1,NH DO 55 I = J,NH TEMP = ZERO DO 50 K = 1,NH TEMP = TEMP + EVAL(K) * C(I,K) * C(J,K) 50 CONTINUE S(I,J) = TEMP S(J,I) = TEMP 55 CONTINUE 60 CONTINUE FORM NEW TAP=TA*S**(-1/2), STORE IN C: DO 80 J = 1,NH DO 75 I = 1,MXAO TEMP = ZERO DO 70 K = 1,NH TEMP = TEMP + TA(I,K) * S(K,J) 70 CONTINUE C(I,J) = TEMP 75 CONTINUE 80 CONTINUE REPLACE ORTHOGONALIZED TA IN ARRAY Q: DO 90 J = 1,NH DO 85 I = 1,MXAO Q(I,IL+J-1) = C(I,J) 85 CONTINUE 90 CONTINUE 100 CONTINUE SYMMETRIC ORTHOGONALIZATION COMPLETE: RETURN SOUND THE ALARM THAT TOO MANY HYBRIDS WERE FOUND ON THIS ATOM: 800 CONTINUE IALARM = IA IF(IFLG.EQ.0) WRITE(LFNPR,900) MXAO,IA,NH RETURN SOUND THE ALARM THAT THERE ARE TOO MANY HYBRIDS OR THAT THERE IS LINEAR DEPENDENCY IN THE HYBRIDS!! 810 CONTINUE IALARM = IA IF(IFLG.EQ.0) WRITE(LFNPR,910) IA,EVAL(I),TOOSML RETURN 900 FORMAT(/4X,'Only expected to find',I3,' hybrids on atom',I3, + ', but found',I3,'.') 910 FORMAT(/4X,'The hybrids on atom',I3,' are linearly dependent.', + ' An eigenvalue (',F10.6,')',/4X,'of the hybrid overlap ', + 'matrix is too small (<',F7.5,').') END ***************************************************************************** SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) FORM PROJECTION MATRIX P TO ANNIHILATE COMPONENTS OF NK OCCUPIED HYBRIDS FOR ATOM IA. PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION P(MXAO,MXAO),VK(MXAO),PI(MXAO),Q(MXAO,NDIM), * PK(MXAO,MXAO) DATA ZERO,ONE/0.0D0,1.0D0/ INITIALIZE P = UNIT MATRIX: NB = NORBS(IA) DO 10 J = 1,NB DO 5 I = 1,J P(I,J) = ZERO P(J,I) = ZERO IF(I.EQ.J) P(I,J) = ONE 5 CONTINUE 10 CONTINUE FORM PROJECTION MATRIX P = P1*P2*...*PK*...*PNK TO ANNIHILATE COMPONENTS OF THE NK OCCUPIED HYBRIDS VK: PK = I - VK*VK(T). LOOP OVER OCCUPIED HYBRIDS VK, K = 1,...,NK: IF(NK.LE.0) RETURN EXTRACT OCCUPIED HYBRID VK FROM ARRAY Q: DO 90 K = 1,NK ICOL = ILL(IA) + K - 1 DO 30 I = 1,NB VK(I) = Q(I,ICOL) 30 CONTINUE FORM PROJECTION MATRIX PK: DO 40 J = 1,NB DO 35 I = 1,J PK(I,J) = -VK(I) * VK(J) PK(J,I) = PK(I,J) IF(I.EQ.J) PK(I,J) = PK(I,J) + ONE 35 CONTINUE 40 CONTINUE ACCUMULATE TOTAL PROJECTOR P(K) = P(K-1)*PK: DO 80 I = 1,NB DO 60 J = 1,NB PI(J) = ZERO DO 50 L = 1,NB PI(J) = PI(J) + P(I,L) * PK(L,J) 50 CONTINUE 60 CONTINUE DO 70 J = 1,NB P(I,J) = PI(J) 70 CONTINUE 80 CONTINUE 90 CONTINUE RETURN END ***************************************************************************** SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION P(MXAO,MXAO),TA(MXAO,MXAO),DM(NDIM,NDIM),C(MXBO,MXBO), + EVAL(MXBO),BORB(MXBO),V(MXBO),BLK(MXBO,MXBO),LARC(NBAS) DATA ZERO,EPS,PT99,ONE/0.0D0,1.0D-5,0.99D0,1.0D0/ FIRST, FORM SET OF "OPTIMALLY DIAGONAL" UNIT VECTORS TO SPAN RYDBERG SPACE: NAUG = NORB - NOCC DO 10 I = 1,NORB LARC(I) = 0 10 CONTINUE SELECT PROJECTED NAO UNIT VECTOR FROM PROJECTOR IN P: DO 300 IPROJ = 1,NAUG IMAX = 0 PRJMAX = ZERO DO 80 IAO = 1,NORB IF(LARC(IAO).NE.0) GO TO 80 PROJ = ABS(P(IAO,IAO)) IF(PROJ.GT.PT99) GO TO 100 IF(PROJ.LT.PRJMAX) GO TO 80 PRJMAX = PROJ IMAX = IAO 80 CONTINUE IAO = IMAX PROJ = PRJMAX 100 CONTINUE PUT VECTOR IN BORB, NORMALIZE, AND SAVE IN C: SB = ZERO DO 120 J = 1,NORB B = P(IAO,J) SB = SB + B * B BORB(J) = B 120 CONTINUE LARC(IAO) = IPROJ RNORM = ONE / SQRT(SB) DO 130 J = 1,NORB BORB(J) = BORB(J) * RNORM 130 CONTINUE DO 140 J = 1,NORB C(J,IPROJ) = BORB(J) 140 CONTINUE IF(IPROJ.EQ.NAUG) GO TO 300 ADD BORB TO THE PROJECTOR IN P: DO 150 J = 1,NORB DO 145 I = 1,J TA(I,J) = -BORB(I) * BORB(J) TA(J,I) = TA(I,J) IF(I.EQ.J) TA(I,I) = TA(I,I) + ONE 145 CONTINUE 150 CONTINUE DO 200 I = 1,NORB DO 180 J = 1,NORB V(J) = ZERO DO 170 L = 1,NORB V(J) = V(J) + P(I,L) * TA(L,J) 170 CONTINUE 180 CONTINUE DO 190 J = 1,NORB P(I,J) = V(J) 190 CONTINUE 200 CONTINUE 300 CONTINUE PUT PROJECTED VECTORS IN TA, ORDERED ACCORDING TO THE NAO PARENT: IAUG = 0 DO 350 IAO = 1,NORB IF(LARC(IAO).EQ.0) GO TO 350 IAUG = IAUG + 1 ITCOL = LARC(IAO) DO 330 J = 1,NORB TA(J,IAUG) = C(J,ITCOL) 330 CONTINUE 350 CONTINUE LOAD DM BLOCK FOR ATOM IA IN BLK: CALL LOAD(DM,IA,0,0,BLK,NORB) FORM BLOCK OF DM IN RYDBERG BASIS IN UPPER CORNER OF BLK: DO 500 IB = 1,NORB DO 450 J = 1,NAUG SUM = ZERO DO 440 K = 1,NORB SUM = SUM + BLK(IB,K) * TA(K,J) 440 CONTINUE V(J) = SUM 450 CONTINUE DO 480 J = 1,NAUG BLK(IB,J) = V(J) 480 CONTINUE 500 CONTINUE DO 550 J = 1,NAUG DO 520 I = 1,J SUM = ZERO DO 510 K = 1,NORB SUM = SUM + TA(K,I) * BLK(K,J) 510 CONTINUE V(I) = SUM 520 CONTINUE DO 530 I = 1,NAUG BLK(I,J) = V(I) 530 CONTINUE 550 CONTINUE DO 560 J = 1,NAUG JJ = J - 1 DO 555 I = 1,JJ BLK(J,I) = BLK(I,J) 555 CONTINUE 560 CONTINUE DIAGONALIZE DM: CALL JACOBI(NAUG,BLK,EVAL,C,MXBO,MXBO,1) ORDER EIGENVECTORS BY OCCUPANCY (WITHIN EPS), FORM FINAL RYDBERG VECTORS: DO 570 I = 1,NAUG LARC(I) = I 570 CONTINUE NAUG1 = NAUG - 1 DO 620 I = 1,NAUG1 I1 = I + 1 DO 610 J = I1,NAUG DIFF = EVAL(J) - EVAL(I) IF(DIFF.LT.EPS) GO TO 610 TEMP = EVAL(I) EVAL(I) = EVAL(J) EVAL(J) = TEMP ITEMP = LARC(I) LARC(I) = LARC(J) LARC(J) = ITEMP 610 CONTINUE 620 CONTINUE DO 700 J = 1,NAUG LJ = LARC(J) DO 680 I = 1,NORB SUM = ZERO DO 670 K = 1,NAUG SUM = SUM + TA(I,K) * C(K,LJ) 670 CONTINUE BLK(I,J) = SUM 680 CONTINUE 700 CONTINUE RETURN END ***************************************************************************** SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL PRINT,FIRST DIAGONALIZE DENSITY MATRIX IN BASIS OF ORTHONORMAL HYBRIDS FOR EACH BOND ORBITAL TO FIND NEW POLARIZATION COEFFICIENTS. PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM), + IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION DM(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3), * BLK(MXBO,MXBO),EVAL(MXBO),C(MXBO,MXBO) DATA ZERO,PT1,ONE,TWO/0.0D0,0.1D0,1.0D0,2.0D0/ DATA LSTAR/1H*/ FIRST, COUNT NUMBER OF BONDS AND 3C BONDS: NBOND = 0 N3CB = 0 DO 20 IB = 1,NBAS IF(LABEL(IB,2).EQ.LSTAR) GO TO 20 IF(LABEL(IB,5).EQ.0) GO TO 20 NBOND = NBOND + 1 IF(LABEL(IB,6).EQ.0) GO TO 20 N3CB = N3CB + 1 20 CONTINUE IAB+1 IS THE NUMBER OF THE FIRST ANTIBOND IN THE NBO LIST: IAB = NBAS - NBOND - N3CB PRINT = JPRINT(5).EQ.1 FIRST = .TRUE. APCOEF = ONE / SQRT(TWO) DO 200 IB = 1,NBD IF(LABEL(IB,2).EQ.LSTAR) GO TO 200 NCTR = 1 IF(LABEL(IB,5).GT.0) NCTR = 2 IF(LABEL(IB,6).GT.0) NCTR = 3 IF(NCTR.EQ.1) GO TO 200 IF(IWAPOL.EQ.0.OR.NCTR.EQ.3) THEN DO 120 I = 1,NCTR IA = LABEL(IB,I+3) NHI = NORBS(IA) DO 115 J = 1,I JA = LABEL(IB,J+3) NHJ = NORBS(JA) DIJ = ZERO DO 110 IR = 1,NHI IRP = ILL(IA)+IR-1 CRI = Q(IR,ILL(IA)+IATHY(IB,I)-1) DO 105 JS = 1,NHJ JSP = ILL(JA) + JS - 1 CSJ = Q(JS,ILL(JA)+IATHY(IB,J)-1) DIJ = DIJ+CRI*CSJ*DM(IRP,JSP) 105 CONTINUE 110 CONTINUE BLK(I,J) = DIJ BLK(J,I) = DIJ 115 CONTINUE 120 CONTINUE DIAGONALIZE 'BLK' AND EXTRACT NEW POLARIZATION COEFFICIENTS CALL JACOBI(NCTR,BLK,EVAL,C,MXBO,MXBO,0) CALL RANK(EVAL,NCTR,MXBO,LARC) MAKE SURE REPOLARIZATION IS NOT TOO DRASTIC (TAKE A LOOK AT THE BOND ORBITAL ONLY): S = ZERO DO 125 I = 1,NCTR S = S + POL(IB,I) * C(I,LARC(1)) 125 CONTINUE IF(S.LT.PT1.AND.NCTR.EQ.2) THEN IF(FIRST.AND.PRINT) WRITE(LFNPR,*) FIRST = .FALSE. IF(PRINT) WRITE(LFNPR,900) IB,S IAB = IAB + 1 POL(IAB,1) = POL(IB,2) POL(IAB,2) = -POL(IB,1) ELSE STORE THE NEW POLARIZATION COEFFICIENTS IN POL: DO 130 I = 1,NCTR POL(IB,I) = C(I,LARC(1)) 130 CONTINUE IAB = IAB + 1 DO 150 I = 1,NCTR POL(IAB,I) = C(I,LARC(2)) 150 CONTINUE IF(NCTR.NE.3) GO TO 200 IAB = IAB + 1 DO 160 I = 1,NCTR POL(IAB,I) = C(I,LARC(3)) 160 CONTINUE END IF CONSTRAIN BONDS TO BE APOLAR, IF REQUESTED (NOT SET UP TO WORK WITH 3-CENTER BONDS): ELSE POL(IB,1) = APCOEF POL(IB,2) = APCOEF IAB = IAB + 1 POL(IAB,1) = APCOEF POL(IAB,2) = -APCOEF END IF 200 CONTINUE RETURN 900 FORMAT(1X,'WARNING: significant repolarization of NBO ',I3,' (S=', + F7.4,'); REPOL disabled.') END ***************************************************************************** SUBROUTINE FORMT(T,Q,POL) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) INTEGER UL CONSTRUCTION OF FINAL TRANSFORMATION MATRIX T FROM ORTHONORMAL HYBRIDS; ROWS OF T LABELLED BY NAOS, COLUMNS BY NBOS. PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOC(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),IBX(MAXBAS),IATHY(MAXBAS,3) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOCTR(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3) DATA LCR,LLP,LBD,LSTAR,LRY/'CR','LP','BD','*','RY'/ DATA ZERO/0.0D0/ REORDER OCCUPIED NBOS TO PUT LONE AND CORE PAIRS LAST: NCR = 0 NLP = 0 NBDS = 0 DO 10 NSCAN = 1,NBAS IF(LABEL(NSCAN,2).EQ.LSTAR) GO TO 10 NBDS = NBDS + 1 IF(LABEL(NSCAN,1).EQ.LLP) NLP = NLP + 1 IF(LABEL(NSCAN,1).EQ.LCR) NCR = NCR + 1 10 CONTINUE ICR = 0 ILP = 0 IBO = 0 IAB = 0 DO 40 IBD = 1,NBAS IF(LABEL(IBD,2).EQ.LSTAR) GO TO 30 IF(LABEL(IBD,1).EQ.LCR) GO TO 15 IF(LABEL(IBD,1).EQ.LLP) GO TO 20 PAIR BONDS: IBO = IBO + 1 IBX(IBD) = IBO GO TO 40 CORE PAIRS: 15 ICR = ICR + 1 IBX(IBD) = ICR + NBDS - NCR - NLP GO TO 40 LONE PAIRS AND CORE PAIRS: 20 ILP = ILP + 1 IBX(IBD) = ILP + NBDS - NLP GO TO 40 ANTIBONDS: 30 IAB = IAB + 1 IBX(IBD) = NBDS + IAB 40 CONTINUE ZERO TRANSFORMATION ARRAY: DO 60 I = 1,NBAS DO 50 J = 1,NBAS T(I,J) = ZERO 50 CONTINUE 60 CONTINUE DEPOSIT FINAL BOND ORBITALS IN MATRIX T: NBO = 0 DO 130 IBD = 1,NBAS KBD = IBD IF(LABEL(IBD,2).NE.LSTAR) GO TO 100 IF(LABEL(IBD,1).EQ.LRY) GO TO 100 IF(LABEL(IBD,1).EQ.LLP) GO TO 100 ANTIBOND ORBITALS: SEARCH OCCUPIED ORB. LIST TO GET PROPER HYBRIDS. SEARCH OCCUPIED BOND ORBS. FOR MATCH WITH ANTIBOND ATOMS: DO 90 K = 1,NBO DO 70 I = 4,6 IF(LABEL(K,I).NE.LABEL(IBD,I)) GO TO 90 IF((LABEL(K,3).LE.0).AND.(LABEL(K,1).EQ.LBD)) GO TO 90 70 CONTINUE NEGATIVE IRNK = LABEL(K,3) MEANS BOND ORBITAL WAS ALREADY USED: FOUND MATCH; SET LABEL(K,3)<0: KBD = K LABEL(KBD,3) = -LABEL(KBD,3) GO TO 100 90 CONTINUE COULDN'T FIND MATCH...EXIT: WRITE(LFNPR,9000) IBD,(LABEL(IBD,JJ),JJ=1,6) STOP DEPOSIT BOND ORBITALS IN T MATRIX: 100 CONTINUE DO 120 I = 1,3 IA = LABEL(IBD,I+3) IF(IA.EQ.0) GO TO 120 JL = LL(IA) JU = UL(IA) IROW = 0 ICOL = JL + IATHY(KBD,I) - 1 DO 110 J = JL,JU IROW = IROW + 1 JB = IBX(IBD) 110 T(J,JB) = POL(IBD,I) * Q(IROW,ICOL) 120 CONTINUE IF(IBD.EQ.KBD) NBO = IBD 130 CONTINUE RESTORE LABEL(I,3) > 0: DO 140 I = 1,NBAS IF(LABEL(I,3).LT.0) LABEL(I,3) = -LABEL(I,3) 140 CONTINUE SET ARRAY IBXM: IBXM(IB) IS THE CURRENT LOCATION OF B.O. # IB: DO 150 IB = 1,NBAS I = IBX(IB) 150 IBXM(I) = IB SET PHASE OF 1-CENTER ORBITALS SUCH THAT THE LARGEST S-TYPE NAO CONTRIBUTION IS POSITIVE: DO 200 IB = 1,NBAS NCTR = 1 DO 160 IL = 5,6 IF(LABEL(IBXM(IB),IL).NE.0) NCTR = NCTR + 1 160 CONTINUE IF(NCTR.EQ.1) THEN JMAX = 0 TMAX = -1.0D0 DO 170 IN = 1,NBAS IF(NAOA(IN).LT.100) THEN IF(ABS(T(IN,IB)).GT.TMAX) THEN JMAX = IN TMAX = ABS(T(IN,IB)) END IF END IF 170 CONTINUE IF(JMAX.NE.0) THEN IF(T(JMAX,IB).LT.-1.0D-4) THEN DO 180 IN = 1,NBAS T(IN,IB) = -T(IN,IB) 180 CONTINUE END IF END IF END IF 200 CONTINUE RETURN 9000 FORMAT(/,1X,'Can''t find bond/antibond match for NBO ', + I3,2X,A2,A1,'(',I2,')',3I4) END ***************************************************************************** SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR, + DTHR,DLTHR,CHSTHR COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM), + N3CTR,I3CTR(10,3) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION GUIDE(NATOMS,NATOMS),BNDOCC(NDIM),TOPO(NATOMS,NATOMS) SAVE JTER,DEVMIN,RHOMIN,BEST,RHO,JBADL DATA LCR,LBD,L3C,LLP,LSTAR/2HCR,2HBD,2H3C,2HLP,1H*/ DATA SMALL,ZERO,TENTH,ONE,ONEPT5,THREE,HUNDRD + /1.0D-4,0.0D0,0.1D0,1.0D0,1.5D0,3.0D0,1.0D2/ DATA DEVTHR/0.1D0/ DATA JTERMX/9/ Subroutine CYCLES controls the search for an acceptable resonance structure: Arguments: ITER : iteration counter incremented by the calling routine THRESH : occupancy threshold used in search for NBOs GUIDE : Wiberg bond index BNDOCC : array containing the NBO occupancies TOPO : bond index matrix to be compared with the Wiberg indices ICONT : control flag (see below) ITER, GUIDE, and BNDOCC are unaltered by this routine THRESH is modified by this routine, if the RESONANCE keyword is selected The TOPO matrix is constructed by this routine Control flag : (set by this routine) ICONT = 2 : an acceptable Lewis structure has been found, continue = 1 : an acceptable Lewis structure has been found, recompute the NBOs for this structure = 0 : bogus Lewis structure, terminate search for NBOs = -1 : occupancy threshold and/or atom ordering have been changed. Repeat the search for NBOs. Set atom permuting counter and minimum deviation in GUIDE-TOPO: IF(ITER.EQ.1) THEN JTER = 0 ICONT = -1 END IF JTER = JTER + 1 IF(JTER.EQ.1) DEVMIN = HUNDRD The minimum occupancy threshold is 1.5e (0.5e for open shell): THRMIN = ONEPT5 IF(ISPIN.NE.0) THRMIN = THRMIN - ONE Determine the number of low occupancy orbitals in the Lewis structure: IBADL = 0 IBADNL = 0 SUMLEW = ZERO TOTELE = ZERO DO 10 I = 1,NBAS TOTELE = TOTELE + BNDOCC(I) IF(LABEL(IBXM(I),2).NE.LSTAR) THEN SUMLEW = SUMLEW + BNDOCC(I) IF(BNDOCC(I).LT.THRESH) IBADL = IBADL + 1 ELSE IF(BNDOCC(I).GT.ABS(ACCTHR)) IBADNL = IBADNL + 1 END IF 10 CONTINUE NEL = TOTELE + TENTH TOTELE = NEL SUM = TOTELE - SUMLEW Count the ECP electrons in the Lewis structure: IF(IPSEUD.NE.0) THEN MECP = 0 DO 20 IAT = 1,NATOMS MECP = MECP + IATNO(IAT) - IZNUC(IAT) 20 CONTINUE IF(ISPIN.NE.0) MECP = MECP/2 SUMLEW = SUMLEW + FLOAT(MECP) END IF Keep track of the best Lewis structure found so far: IF(JTER.EQ.1) RHOMIN = HUNDRD IF(ITER.EQ.1.OR.SUM.LT.RHO) THEN BEST = THRESH RHO = SUM JBADL = IBADL DO 25 I = 1,NATOMS JORDER(I) = IORDER(I) 25 CONTINUE END IF Count the number of core, lone pair, and bonding orbitals in this resonance structure: MCR = 0 MBD = 0 M3C = 0 MLP = 0 DO 30 I = 1,NBAS IF(LABEL(I,1).EQ.LCR.AND.LABEL(I,2).NE.LSTAR) MCR = MCR + 1 IF(LABEL(I,1).EQ.LBD.AND.LABEL(I,2).NE.LSTAR) MBD = MBD + 1 IF(LABEL(I,1).EQ.L3C.AND.LABEL(I,2).NE.LSTAR) M3C = M3C + 1 IF(LABEL(I,1).EQ.LLP.AND.LABEL(I,2).NE.LSTAR) MLP = MLP + 1 30 CONTINUE Build the TOPO matrix from lone pairs and 2- and 3-center bonds: DO 50 I = 1,NATOMS DO 40 J = 1,NATOMS TOPO(I,J) = ZERO 40 CONTINUE 50 CONTINUE DO 60 I = 1,NBAS IB = IBXM(I) IF(LABEL(IB,1).NE.LCR.AND.LABEL(IB,2).NE.LSTAR) THEN IAT1 = LABEL(IB,4) NCTR = 1 IAT2 = LABEL(IB,5) IF(IAT2.NE.0) NCTR = 2 IAT3 = LABEL(IB,6) IF(IAT3.NE.0) NCTR = 3 IF(NCTR.EQ.1) THEN TOPO(IAT1,IAT1) = TOPO(IAT1,IAT1) + ONE ELSE IF(NCTR.EQ.2) THEN TOPO(IAT1,IAT2) = TOPO(IAT1,IAT2) + ONE TOPO(IAT2,IAT1) = TOPO(IAT2,IAT1) + ONE ELSE TOPO(IAT1,IAT2) = TOPO(IAT1,IAT2) + ONE/THREE TOPO(IAT2,IAT1) = TOPO(IAT2,IAT1) + ONE/THREE TOPO(IAT1,IAT3) = TOPO(IAT1,IAT3) + ONE/THREE TOPO(IAT3,IAT1) = TOPO(IAT3,IAT1) + ONE/THREE TOPO(IAT2,IAT3) = TOPO(IAT2,IAT3) + ONE/THREE TOPO(IAT3,IAT2) = TOPO(IAT3,IAT2) + ONE/THREE END IF END IF 60 CONTINUE Determine the largest off-diagonal element of GUIDE-TOPO: DEV = ZERO DO 80 J = 2,NATOMS DO 70 I = 1,J-1 IF(GUIDE(I,J)-TOPO(I,J).GT.DEV) THEN DEV = GUIDE(I,J) - TOPO(I,J) IAT = I JAT = J END IF 70 CONTINUE 80 CONTINUE Write info about this resonance structure: IF(JPRINT(5).EQ.1) THEN IF(ITER.EQ.1) WRITE(LFNPR,1000) WRITE(LFNPR,1010) ITER,JTER,ABS(THRESH),SUMLEW,SUM,MCR,MBD, + M3C,MLP,IBADL,IBADNL,DEV END IF Decide if this structure is acceptable: * Accept the structure if CHOOSE was employed. * Accept the structure if there is only one atom. * Accept the structure if there are no low occupancy Lewis orbitals and DEV is less than DEVTHR. * Accept the structure if the NOBOND option was selected. Good resonance structure: IF(IBADL.EQ.0.AND.DEV.LT.DEVTHR) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030) ICONT = 2 RETURN Only one atom: ELSE IF(NATOMS.EQ.1) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1035) ICONT = 2 RETURN Directed NBO search: ELSE IF(ICHOOS.EQ.1) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1040) ICONT = 2 RETURN NOBOND option selected: ELSE IF(JPRINT(10).NE.0) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1050) ICONT = 2 RETURN END IF Structure accepted due to the specification of the RESONANCE keyword or the occupancy threshold. Otherwise, accept the structure only if there are no high occupancy Lewis orbitals: IF(ICONT.EQ.1) THEN IF(THRSET.GE.ZERO) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1060) ICONT = 2 ELSE IF(JPRINT(14).NE.0) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1070) ICONT = 2 ELSE IF(IBADL.NE.0) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030) ICONT = 2 END IF RETURN END IF If DEV.EQ.DEVMIN.AND.SUM.EQ.RHOMIN or too many atoms permutations, stop atom permutations: IF((ABS(DEV-DEVMIN).LT.SMALL.AND.ABS(SUM-RHOMIN).LT.SMALL).OR. + JTER.GE.JTERMX) THEN If the occupancy threshold was set by the user, accept the best structure: IF(THRSET.GE.ZERO) THEN IF(ABS(SUM-RHO).LT.SMALL) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1060) ICONT = 2 ELSE DO 90 I = 1,NATOMS IORDER(I) = JORDER(I) 90 CONTINUE JTER = 0 ICONT = 1 END IF If the RESONANCE keyword was specified, pick the best resonance structure for this occupancy threshold, and possibly decrement the threshold and continue the search: ELSE IF(JPRINT(14).NE.0) THEN THRESH = THRESH - TENTH IF(THRMIN-THRESH.GT.SMALL) THEN THRESH = THRESH + TENTH IF(ABS(THRESH-BEST).LT.SMALL.AND.ABS(SUM-RHO).LT.SMALL) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1070) ICONT = 2 ELSE DO 100 I = 1,NATOMS IORDER(I) = JORDER(I) 100 CONTINUE THRESH = BEST JTER = 0 ICONT = 1 END IF ELSE DO 110 I = 1,NATOMS IORDER(I) = JORDER(I) 110 CONTINUE JTER = 0 ICONT = -1 END IF Otherwise, accept the best structure, but only if it had no Lewis orbitals with occupancy less than the occupancy threshold: ELSE IF(ABS(SUM-RHO).LT.SMALL.AND.IBADL.EQ.0) THEN IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030) ICONT = 2 ELSE IF(JBADL.EQ.0) THEN DO 115 I = 1,NATOMS IORDER(I) = JORDER(I) 115 CONTINUE JTER = 0 ICONT = 1 ELSE IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020) IF(JPRINT(5).EQ.1) WRITE(LFNPR,1080) ICONT = 0 END IF END IF RETURN Loop through atom ordering to find alternative resonance structures: ELSE IF(DEV.LT.DEVMIN) DEVMIN = DEV IF(SUM.LT.RHOMIN) RHOMIN = SUM IF(IAT.EQ.IORDER(1).AND.JAT.EQ.IORDER(2)) THEN DEV1 = ZERO DO 130 J = 2,NATOMS DO 120 I = 1,J-1 IF(GUIDE(I,J)-TOPO(I,J).GT.DEV1) THEN IF((I.NE.IORDER(1).AND.J.NE.IORDER(2)).AND. + (J.NE.IORDER(1).AND.I.NE.IORDER(2))) THEN DEV1 = GUIDE(I,J) - TOPO(I,J) IAT = I JAT = J END IF END IF 120 CONTINUE 130 CONTINUE END IF JFLG = 0 DO 140 I = NATOMS,2,-1 IF(IORDER(I).EQ.JAT) JFLG = 1 IF(JFLG.EQ.1) IORDER(I) = IORDER(I-1) 140 CONTINUE IORDER(1) = JAT IFLG = 0 DO 150 I = NATOMS,2,-1 IF(IORDER(I).EQ.IAT) IFLG = 1 IF(IFLG.EQ.1) IORDER(I) = IORDER(I-1) 150 CONTINUE IORDER(1) = IAT ICONT = -1 END IF RETURN 1000 FORMAT(/1X,' Occupancies Lewis ', + 'Structure Low High',/1X,' Occ. --------', + '----------- ----------------- occ occ',/1X,' Cycle ', + ' Thresh. Lewis Non-Lewis CR BD 3C LP (L) ', + ' (NL) Dev',/1X,77('=')) 1010 FORMAT(1X,I3,'(',I1,')',3X,F5.2,F12.5,F10.5,3X,4I4,2X,I4,3X,I4, + 3X,F5.2) 1020 FORMAT(1X,77('-')) 1030 FORMAT(/1X,'Structure accepted: No low occupancy Lewis orbitals') 1035 FORMAT(/1X,'Structure accepted: Only a single atom') 1040 FORMAT(/1X,'Structure accepted: NBOs selected via the $CHOOSE ', + 'keylist') 1050 FORMAT(/1X,'Structure accepted: Search for bonds prevented ', + 'by NOBOND keyword') 1060 FORMAT(/1X,'Structure accepted: Occupancy threshold (THRESH) ', + 'set by user') 1070 FORMAT(/1X,'Structure accepted: RESONANCE keyword permits ', + 'strongly delocalized structure') 1080 FORMAT(/1X,'Only strongly delocalized resonance structures can', + ' be found.',/1X,'The default procedure is to abort the NBO ', + 'search. Include',/1X,'the RESONANCE keyword in the $NBO ', + 'keylist to override this test.') END ***************************************************************************** ROUTINES CALLED BY SR NLMO: SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT, + NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM) SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL) ***************************************************************************** SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT, * NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION TSYM(NROT,NROT),A(NDIM,NDIM),BLK(NROT,NROT), * OVLP(NROT,NROT),EVAL(NROT) DIMENSION IOFF(NOFF),JOFF(NOFF),ILIST(NOFF),JLIST(NOFF) DATA ZERO,ONE/0.0D0,1.0D0/ DATA EPS/1.0D-6/ DO 40 I=1,NROT DO 30 J=1,NROT 30 TSYM(I,J)=ZERO 40 TSYM(I,I)=ONE DO 60 MOFF=1,NOFF IOCC=ILIST(MOFF) JEMT=JLIST(MOFF) DO 60 I=1,NROT T=TSYM(I,IOCC) U=TSYM(I,JEMT) TSYM(I,IOCC)=COS*T-SIN*U 60 TSYM(I,JEMT)=SIN*T+COS*U AVERAGE GROUPS OF THE ELEMENTS OF THE TRANSFORMATION MATRIX TSYM SO THAT THE SYMMETRY INHERENT IN THE DENSITY MATRIX A IS PRESERVED, MAKING SURE THAT THE RESULTING "AVERAGED" TRANSFORMATION IS UNITARY JST=NIUNIQ+1 NROT=JST-1+NJUNIQ AVE. DIAG. ELEM OF OCC ORBS IF(NIUNIQ.EQ.1) GO TO 140 TOT=ZERO DO 100 I=1,NIUNIQ 100 TOT=TOT+TSYM(I,I) AVE=TOT/NIUNIQ DO 110 I=1,NIUNIQ 110 TSYM(I,I)=AVE AVE. DIAG. ELEM OF EMPTY ORBS 140 IF(NJUNIQ.EQ.1) GO TO 180 TOT=ZERO DO 150 J=JST,NROT 150 TOT=TOT+TSYM(J,J) AVE=TOT/NJUNIQ DO 160 J=JST,NROT 160 TSYM(J,J)=AVE ZERO OFFDIAG ELEM BETW OCC ORBS: 180 IF(NIUNIQ.EQ.1) GO TO 240 DO 220 I=2,NIUNIQ DO 220 J=1,I IF(I.EQ.J) GO TO 220 TSYM(I,J)=ZERO TSYM(J,I)=ZERO 220 CONTINUE ZERO OFFDIAG ELEM BETW EMPTY ORBS: 240 IF(NJUNIQ.EQ.1) GO TO 280 JST2=JST+1 DO 270 I=JST2,NROT DO 270 J=JST,I IF(I.EQ.J) GO TO 270 TSYM(I,J)=ZERO TSYM(J,I)=ZERO 270 CONTINUE AVE. OFFDIAG ELEM BETW OCC AND EMPTY ORBS (PIVOTED ELEMENTS ONLY): 280 CONTINUE TOT=ZERO DO 310 MOFF=1,NOFF II=ILIST(MOFF) JJ=JLIST(MOFF) 310 TOT=TOT+ABS(TSYM(II,JJ))+ABS(TSYM(JJ,II)) NOFF2=NOFF*2 AVE=TOT/NOFF2 DO 330 MOFF=1,NOFF II=ILIST(MOFF) JJ=JLIST(MOFF) TSYM(II,JJ)=-AVE 330 TSYM(JJ,II)= AVE NOW ZERO THE NON-PIVOTED ELEMENTS: DO 450 I=1,NIUNIQ DO 440 J=JST,NROT DO 420 MOFF=1,NOFF IF(I.EQ.ILIST(MOFF).AND.J.EQ.JLIST(MOFF)) GO TO 440 420 CONTINUE TSYM(I,J)= ZERO TSYM(J,I)= ZERO 440 CONTINUE 450 CONTINUE RENORMALIZE VECTORS: DO 700 J=1,NROT TOT=ZERO DO 650 I=1,NROT 650 TOT=TOT+TSYM(I,J)*TSYM(I,J) RNORM=SQRT(TOT) IF(RNORM.GT.EPS) GO TO 680 WRITE(LFNPR,2880) NROT,TOT,EPS,RNORM 2880 FORMAT('NROT,TOT,EPS,RNORM:',I3,3F14.9) CALL ALTOUT(TSYM,NROT,NROT,NROT,NROT) STOP 680 CONTINUE DO 690 I=1,NROT 690 TSYM(I,J)=TSYM(I,J)/RNORM 700 CONTINUE NOW, MAKE SURE THE SIGNS ARE CORRECT: DO 800 MOFF=1,NOFF I=IOFF(MOFF) J=JOFF(MOFF) IF(A(I,J).GT.ZERO) GO TO 800 II=ILIST(MOFF) JJ=JLIST(MOFF) TSYM(II,JJ)=-TSYM(II,JJ) TSYM(JJ,II)=-TSYM(JJ,II) 800 CONTINUE FINALLY, THE CRUCIAL STEP OF SYMMETRICALLY ORTHOGONALIZING THE VECTORS SO THAT THE TRANSFORMATION IS UNITARY: CALL SYMORT(OVLP,TSYM,BLK,NROT,NROT,EVAL) RETURN END ***************************************************************************** SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) ****************************************************************** SYMORT: SYMMETRIC ORTHOGONALIZATION SUBROUTINE S: FULL OVERLAP MATRIX (DESTROYED!) T: VECTORS TO BE ORTHOGED. N: NUMBER OF VECTORS NOTE: BLK AND BIGBLK SHARE THE SAME STORAGE BUT ARE DIMENSIONED DIFFERENTLY. THE SAME APPLIES FOR S AND SBLK. ****************************************************************** DIMENSION S(N,N),T(NDIM,NDIM),BLK(N,N),EVAL(N) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA ZERO,ONE/0.0D0,1.0D0/ IMPORTANT CONSTANTS: DIAGTH THRESHOLD FOR MATRIX DIAGONALIZATION USED IN SUBROUTINE JACOBI. IN JACOBI, THIS CONSTANT IS CALLED "DONETH". DANGER CRITERION FOR DECIDING THAT THE JOB SHOULD BE ABORTED DUE TO NUMERICAL PROBLEMS CAUSED BY NEAR LINEAR DEPENDENCIES IN THE BASIS SET. ALL EIGENVALUES OF THE WEIGHTED OVERLAP MATRIX MUST BE GREATER THAN DIAGTH*DANGER. DATA DIAGTH,DANGER/1.0D-12,1.0D3/ FORM THE INVERSE SQRT OF THE OVERLAP MATRIX OF THE VECTORS: DO 70 I=1,N DO 70 J=1,N SIJ=ZERO DO 40 K=1,N 40 SIJ=SIJ+T(K,I)*T(K,J) 70 S(I,J)=SIJ CALL JACOBI(N,S,EVAL,BLK,N,N,0) SMLEST=ONE TOOSML=DIAGTH*DANGER DO 150 I=1,N EIGENV=EVAL(I) IF(EIGENV.LT.TOOSML) GO TO 900 EVAL(I)=ONE/SQRT(EIGENV) IF(EIGENV.LT.SMLEST) SMLEST=EIGENV 150 CONTINUE DO 170 I=1,N DO 170 J=1,I SIJ=ZERO DO 160 K=1,N 160 SIJ=SIJ+EVAL(K)*BLK(I,K)*BLK(J,K) S(I,J)=SIJ 170 S(J,I)=SIJ S NOW CONTAINS THE -0.5 POWER OF THE OVERLAP MATRIX, AND IS THE ORTHOG. TRANSFORM THAT WE WANT. NOW, FORM THE TOTAL TRANSFORMATION: DO 210 I=1,N DO 200 J=1,N EVAL(J)=ZERO DO 200 K=1,N 200 EVAL(J)=EVAL(J)+T(I,K)*S(K,J) DO 210 J=1,N 210 T(I,J)=EVAL(J) RETURN 900 WRITE(LFNPR,910) EIGENV,TOOSML 910 FORMAT(/1X,'An eigenvalue of the overlap matrix of the ', * 'symmetrized Jacobi transf. ', * 'matrix of ',E13.5,' has been found.'/1X, * 'This is lower than the allowed threshold of ',E13.5) STOP END ***************************************************************************** NBO ENERGETIC ANALYSIS ROUTINES: SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE) SUBROUTINE NBODEL(A,MEMORY,IDONE) SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE, + ISPIN) SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN) SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK) SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL) ***************************************************************************** SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE) ***************************************************************************** NBOEAN: CONTROLLER SUBROUTINE TO DO NBO ENERGETIC ANALYSIS BY FOCK MATRIX DELETION METHOD A(MEMORY) IS SCRATCH STORAGE NBOOPT(1) = 2 READ IN NEXT DELETION AND FORM NEW DM = 3 COMPUTE ENERGY CHANGE FOR THIS DELETION SET IDONE TO 1 IF NO DELETIONS ARE FOUND: ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ERROR,NEW,SEQ COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION A(MEMORY),NBOOPT(10) DATA THRNEG/-1.0D-3/ DATA ONE,AUKCAL,EVKCAL/1.0D0,627.51,23.061/ OPEN THE OLD NBO DAF: NEW = .FALSE. CALL NBOPEN(NEW,ERROR) IF(ERROR) THEN IDONE = 1 RETURN END IF CALL FEINFO(A,ISWEAN) IF NBOOPT(1) = 3, COMPUTE THE ENERGY OF DELETION: IF(NBOOPT(1).EQ.3) THEN CALL FEE0(EDEL,ETOT) ECHANG = EDEL - ETOT IF(MUNIT.EQ.0) THEN CONV = AUKCAL ELSE IF(MUNIT.EQ.1) THEN CONV = EVKCAL ELSE CONV = ONE END IF EKCAL = ECHANG * CONV IF(EKCAL.LT.THRNEG) WRITE(LFNPR,2130) IF(MUNIT.EQ.0) THEN WRITE(LFNPR,2100) EDEL,ETOT,ECHANG,EKCAL ELSE IF(MUNIT.EQ.1) THEN WRITE(LFNPR,2110) EDEL,ETOT,ECHANG,EKCAL ELSE WRITE(LFNPR,2120) EDEL,ETOT,ECHANG,EKCAL END IF IDONE = 0 SEQ = .FALSE. CALL NBCLOS(SEQ) RETURN END IF PERFORM THE NBO ENERGETIC ANALYSIS: IF ISWEAN IS SET TO 1, SEARCH FOR THE $DEL KEYLIST: IF(ISWEAN.EQ.1) THEN CALL DELINP(NBOOPT,IDONE) IF(IDONE.EQ.1) GOTO 900 ELSE IF(NBOOPT(10).GT.80) THEN CALL STRTIN(LFNIN) END IF ROHF, MCSCF, CI, AND AUHF WAVE FUNCTIONS ARE NOT ACCEPTABLE: IF(ROHF.OR.MCSCF.OR.CI.OR.AUHF) THEN IDONE = 1 GOTO 900 END IF ISPIN = 0 IF(UHF) ISPIN = 2 ALPHA = .FALSE. BETA = .FALSE. IF(UHF) ALPHA = .TRUE. CALL NBODEL(A,MEMORY,IDONE) IF(IDONE.EQ.1) GOTO 900 IF(UHF) THEN ISPIN = -2 ALPHA = .FALSE. BETA = .TRUE. CALL NBODEL(A,MEMORY,IDONE) END IF WRITE(LFNPR,3000) SEQ = .FALSE. CALL NBCLOS(SEQ) RETURN 900 CONTINUE SEQ = .FALSE. CALL NBCLOS(SEQ) RETURN 2100 FORMAT(1X,78('-'),/,3X, +'Energy of deletion : ',F20.9,/,3X, +' Total SCF energy : ',F20.9,/,3X, +' -------------------',/,3X, +' Energy change : ',F17.6,' a.u., ',F13.3,' kcal/mol'/ +1X,78('-')) 2110 FORMAT(1X,78('-'),/,3X, +'Energy of deletion : ',F20.9,/,3X, +' Total SCF energy : ',F20.9,/,3X, +' -------------------',/,3X, +' Energy change : ',F17.6,' e.V., ',F13.3,' kcal/mol'/ +1X,78('-')) 2120 FORMAT(1X,78('-'),/,3X, +'Energy of deletion : ',F13.3,/,3X, +' Total SCF energy : ',F13.3,/,3X, +' -------------------',/,3X, +' Energy change : ',F13.3,' kcal/mol, ',F13.3,' kcal/mol'/ +1X,78('-')) 2130 FORMAT(/,6X, +'***** WARNING ***** The variational principle has been',/,5X, +' violated and the above deletion energy is invalid!!',//,5X, +'Probable cause: A deletion was attempted that did not ',/,5X, +'have as high symmetry as was employed in the integral',/,5X, +'and SCF computation. REMEDY: Redo computation without',/,5X, +'symmetry if this non-symmetry-conserving deletion is still',/,5X, +'desired.') 3000 FORMAT(/1X, +'NEXT STEP: Evaluate the energy of the new density matrix',/,1X, +' that has been constructed from the deleted NBO',/,1X, +' Fock matrix by doing one SCF cycle.'/) END ***************************************************************************** SUBROUTINE NBODEL(A,MEMORY,IDONE) ***************************************************************************** NBODEL: SUBROUTINE TO DELETE BOND ORBITAL FOCK MATRIX ELEMENTS FOR A PARTICULAR SPIN CASE: ISPIN = 0 CLOSED SHELL 2 ALPHA SPIN -2 BETA SPIN IDONE IS SET EQUAL TO 1 IF THERE ARE NO MORE DELETIONS, 0 OTHERWISE. A(MEMORY) IS SCRATCH STORAGE ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL DONE DIMENSION A(MEMORY),ICH(3,2),INAM(3),ISP(3) NBO Common Blocks: PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DATA LBD/2HBD/,L3C/2H3C/,LBLNK2/2H /,LBLNK1/1H /,LHYP/1H-/ FNBO : NBO FOCK MATRIX (TRIANGULAR) TRF : TRUNCATED FOCK MATRIX (SQUARE) EIGVR : EIGENVECTORS OF FTRUNC DMNEW : NEW AO DM (FROM TRUNCATION) -- TRIANGULAR OCC : OCCUPATION VECTOR OF BOND ORBITALS OCCNEW: OCCUPATION VECTOR OF BOND ORBITALS, AFTER DELETION TNBO : AO TO NBO TRANSFORMATION MATRIX SCR : SCRATCH VECTOR SET UP STORAGE SPACE: A(N1): OCC A(N2): OCCNEW A(N3): TNBO A(N4): FNBO, EIGVR A(N5): SCR, TRF, DMNEW A(N6): SCR A(N7): IDEL NSQ = NDIM*NDIM N1 = 1 N2 = N1 + NDIM N3 = N2 + NDIM N4 = N3 + NSQ N5 = N4 + NSQ N6 = N5 + NSQ N7 = N6 + NDIM NEND = N7 + NSQ IF(NEND.GT.MEMORY) GO TO 950 CALL FENBO(A(N3),A(N1),A(N5),NELEC) CALL FEFNBO(A(N4)) DELETE REQUESTED FOCK MATRIX ELEMENTS, FORMING TRUNCATED FOCK MATRIX IN TRF IDEL : LIST OF DELETED ORBITALS, ELEMENTS, OR BLOCKS ITYPE : TYPE OF DELETION: 1 FOR ORBITALS 2 FOR INDIVIDUAL MATRIX ELEMENTS 3 FOR ZEROING INTERSECTION BETWEEN TWO SETS OF ORBITALS 4 FOR ENTIRE MATRIX BLOCKS NDEL : NUMBER OF ORBITALS, ELEMENTS OR BLOCKS TO BE DELETED CALL DELETE(A(N4),A(N5),NDIM,A(N7),NSQ,ITYPE,NDEL,NTRUNC,DONE, + ISPIN) IF NO MORE DELETIONS, EXIT PROGRAM IF(DONE) GO TO 900 DIAGONALIZE TRUNCATED FOCK MATRIX IN TRF CALL JACOBI(NTRUNC,A(N5),A(N2),A(N4),NDIM,NDIM,0) CONSTRUCT NEW DENSITY MATRIX IN DM FROM EIGENVECTORS OF TRF, IN NBO BASIS: A(N2): EIGENVALUES OF TRF (ENTERING) A(N2): NEW NBO ORBITAL OCCUPANCIES (EXITING) NMOOCC=NELEC IF(ISPIN.EQ.0) NMOOCC=NELEC/2 CALL NEWDM(A(N5),A(N4),A(N2),NDIM,A(N7),NSQ,NDEL,ITYPE,NMOOCC, + ISPIN) TAKE TRANSPOSE OF T SO THAT IT CAN TRANSFORM THE DENSITY MATRIX FROM THE NBO BASIS TO THE UNSYMMETRIZED AO BASIS: CALL TRANSP(A(N3),NDIM,NDIM) CALL SIMLTR(NDIM,NDIM,A(N5),A(N3),A(N4),A(N6),1) CALL SVNEWD(A(N5)) WRITE(LFNPR,2200) WRITE(LFNPR,2700) DO 500 IBAS=1,NDIM IB=IBXM(IBAS) LBL=LABEL(IB,1) NCTR=1 IF(LBL.EQ.LBD) NCTR=2 IF(LBL.EQ.L3C) NCTR=3 DO 350 I=1,3 IAT=LABEL(IB,I+3) CALL CONVRT(IAT,ICH(I,1),ICH(I,2)) INAM(I)=LBLNK2 IF(IAT.GT.0) INAM(I)=NAMEAT(IATNO(IAT)) ISP(I)=LHYP IF(I.GE.NCTR) ISP(I)=LBLNK1 350 CONTINUE I=N1-1+IBAS II=N2-1+IBAS OCCCHG=A(II)-A(I) WRITE(LFNPR,2800) IBAS,(LABEL(IB,K),K=1,3), * (INAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3), * A(I),A(II),OCCCHG 500 CONTINUE IDONE=0 RETURN 900 CONTINUE IDONE=1 RETURN 950 CONTINUE WRITE(LFNPR,9500) NEND,MEMORY IDONE=1 RETURN 2200 FORMAT(/1X,'Occupations of bond orbitals:') 2700 FORMAT(/7X,'Orbital',19X,'No deletions This deletion Change', + /,1X,78('-')) 2800 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',3(A2,3A1), * 9X,F7.5,8X,F7.5,3X,F8.5) 9500 FORMAT(/1X,'Insufficient memory in subroutine NBODEL:', * /5X,'Memory needed: ',I10,' Memory available: ',I10, * /1X,'Deletions halted!') END ***************************************************************************** SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE, + ISPIN) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ERROR,DONE,EQUAL LOGICAL DONOR,ACCPTR,LIST1,LIST2 DIMENSION KEYWD(6),F(1),TRF(NDIM,NDIM),IDEL(LEN) DIMENSION LORB(3),LELE(3),LBLO(3),LDEL(3),LZERO(4),LSAME(4), * LEND(3),LDESTR(6),LDELOC(5),LNOSTR(6),LATOM(4), * LNOGEM(5),LNOVIC(5),LALT(4) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA ZERO/0.0D0/,ISTAR/1H*/ DATA LDEL/1HD,1HE,1HL/,LZERO/1HZ,1HE,1HR,1HO/,LEND/1HE,1HN,1HD/ DATA LALPHA,LBETA/1HA,1HB/,LSAME/1HS,1HA,1HM,1HE/ DATA LORB,LELE,LBLO/1HO,1HR,1HB,1HE,1HL,1HE,1HB,1HL,1HO/ DATA LDESTR/1HD,1HE,1HS,1HT,1HA,1HR/ DATA LNOSTR/1HN,1HO,1HS,1HT,1HA,1HR/ DATA LDELOC/1HD,1HE,1HL,1HO,1HC/,LATOM/1HA,1HT,1HO,1HM/ DATA LNOVIC/1HN,1HO,1HV,1HI,1HC/,LNOGEM/1HN,1HO,1HG,1HE,1HM/ DATA LALT/1H$,1HE,1HN,1HD/ DATA LG,LV/'g','v'/ THIS SUBROUTINE IS CALLED AT THE START OF EACH DELETION AND READS IN FROM LFNIN THE INSTRUCTIONS FOR THIS DELETION NTRUNC= DIMENSION OF FOCK MATRIX AFTER DELETIONS: NTRUNC=NDIM WRITE(LFNPR,8700) COUNT UP NUMBER OF MOLECULAR UNITS, NCHEMU: NCHEMU=0 DO 1 I=1,NDIM NUNIT=NBOUNI(I) IF(NUNIT.GT.NCHEMU) NCHEMU=NUNIT 1 CONTINUE IF(ISPIN.EQ.0) GO TO 10 IF OPEN SHELL, LOOK FOR FIRST LETTER OF "ALPHA" OR "BETA" KEYWORD: LENG=3 CALL HFLD(KEYWD,LENG,DONE) IF(EQUAL(KEYWD,LEND,3)) DONE=.TRUE. IF(EQUAL(KEYWD,LALT,3)) DONE=.TRUE. IF(DONE) RETURN IF((ISPIN.EQ.2).AND.(KEYWD(1).NE.LALPHA)) GO TO 9300 IF((ISPIN.EQ.-2).AND.(KEYWD(1).NE.LBETA)) GO TO 9400 IF(ISPIN.EQ.2) WRITE(LFNPR,8100) IF(ISPIN.EQ.-2) WRITE(LFNPR,8200) SEARCH FOR FIRST 3 LETTERS OF "DELETE", "ZERO", "SAME", "DESTAR", "NOSTAR", "NOGEM", "NOVIC", OR AN END MARK '**': 10 CONTINUE LENG=3 CALL HFLD(KEYWD,LENG,DONE) IF(EQUAL(KEYWD,LEND,3)) DONE=.TRUE. IF(EQUAL(KEYWD,LALT,3)) DONE=.TRUE. IF(DONE) RETURN IF BETA DELETIONS ARE THE SAME AS THE ALPHA DELETIONS ALREADY READ IN, SKIP TO 100: IF((ISPIN.EQ.-2).AND.EQUAL(KEYWD,LSAME,3)) GO TO 100 IF(EQUAL(KEYWD,LZERO,3)) GO TO 600 IF(EQUAL(KEYWD,LNOVIC,3)) GO TO 3000 IF(EQUAL(KEYWD,LNOGEM,3)) GO TO 3010 IF(EQUAL(KEYWD,LDESTR,3)) GO TO 5000 IF(EQUAL(KEYWD,LNOSTR,3)) GO TO 5500 IF(.NOT.EQUAL(KEYWD,LDEL,3)) GO TO 9000 READ IN NUMBER OF ITEMS TO DELETE, NDEL: CALL IFLD(NDEL,ERROR) IF(ERROR) GO TO 9100 READ IN TYPE OF DELETION AND DETERMINE IF IT IS ORBITAL, ELEMENT, OR BLOCK: (ITYPE STORES THE DELETION TYPE) CALL HFLD(KEYWD,LENG,DONE) IF(LENG.LT.3) GO TO 9200 IF(.NOT.EQUAL(KEYWD,LORB,3)) GO TO 20 ITYPE=1 GO TO 80 20 IF(.NOT.EQUAL(KEYWD,LELE,3)) GO TO 30 ITYPE=2 GO TO 80 30 IF(.NOT.EQUAL(KEYWD,LBLO,3)) GO TO 9200 ITYPE=4 80 CONTINUE NREAD=NUMBER OF NUMBERS THAT MUST BE READ NREAD=NDEL*ITYPE READ IN ORBITALS,ELEMENTS, OR BLOCKS: DO 90 I=1,NREAD CALL IFLD(IDEL(I),ERROR) IF(ERROR) GO TO 9500 90 CONTINUE 100 CONTINUE IF(ITYPE.NE.1) GO TO 200 DELETE NDEL ORBITALS, ADJUSTING NTRUNC ACCORDINGLY: NTRUNC=NDIM-NDEL ORDER THE ORBITAL NUMBERS: CALL ORDER(ISCR1,IDEL,NDEL,NDIM,ISCR2) WRITE(LFNPR,8610) (IDEL(I),I=1,NDEL) FILL TRF WITH TRUNCATED FOCK MATRIX, DELETING REQUESTED ORBITALS: IFF=0 IOUT=1 II=0 DO 140 I=1,NDIM IF(IOUT.GT.NDEL) GO TO 110 IF(I.NE.IDEL(IOUT)) GO TO 110 IFF=IFF+I IOUT=IOUT+1 GO TO 140 110 CONTINUE II=II+1 JOUT=1 JJ=0 DO 130 J=1,I IF(JOUT.GT.NDEL) GO TO 120 IF(J.NE.IDEL(JOUT)) GO TO 120 IFF=IFF+1 JOUT=JOUT+1 GO TO 130 120 CONTINUE JJ=JJ+1 IFF=IFF+1 TRF(II,JJ)=F(IFF) TRF(JJ,II)=F(IFF) 130 CONTINUE 140 CONTINUE RETURN 200 CONTINUE ELEMENT OR BLOCK DELETIONS: START BY FILLING TRF WITH FULL NBO FOCK MATRIX: II=0 DO 210 I=1,NDIM DO 210 J=1,I II=II+1 TRF(I,J)=F(II) TRF(J,I)=F(II) 210 CONTINUE IF(ITYPE.NE.2) GO TO 300 ZERO REQUESTED MATRIX ELEMENTS: NDEL2=NDEL*2 WRITE(LFNPR,8620) (IDEL(I),I=1,NDEL2) DO 240 I=1,NDEL I2=2*I ID=IDEL(I2-1) JD=IDEL(I2) TRF(ID,JD)=ZERO TRF(JD,ID)=ZERO 240 CONTINUE RETURN 300 CONTINUE IF(ITYPE.NE.4) STOP ZERO REQUESTED MATRIX BLOCKS: DO 400 ID=1,NDEL IDST=(ID-1)*4 J1=IDEL(IDST+1) J2=IDEL(IDST+2) I1=IDEL(IDST+3) I2=IDEL(IDST+4) IF(J1.LE.J2) GO TO 320 IDEL(IDST+2)=J1 IDEL(IDST+1)=J2 J1=IDEL(IDST+1) J2=IDEL(IDST+2) 320 IF(I1.LE.I2) GO TO 330 IDEL(IDST+4)=I1 IDEL(IDST+3)=I2 I1=IDEL(IDST+3) I2=IDEL(IDST+4) 330 DO 380 I=I1,I2 DO 380 J=J1,J2 SKIP DIAGONAL ELEMENTS: IF(I.EQ.J) GO TO 380 TRF(I,J)=ZERO TRF(J,I)=ZERO 380 CONTINUE 400 CONTINUE NDEL4=NDEL*4 WRITE(LFNPR,8640) (IDEL(I),I=1,NDEL4) RETURN DELETE INTERSECTION IN FOCK MATRIX BETWEEN PAIRS OF SETS OF ORBITALS: 600 ITYPE=3 START BY FILLING TRF WITH FULL NBO FOCK MATRIX: II=0 DO 610 I=1,NDIM DO 610 J=1,I II=II+1 TRF(I,J)=F(II) TRF(J,I)=F(II) 610 CONTINUE READ IN NUMBER OF PAIRS OF SETS OF ORBITALS, NDEL: CALL IFLD(NDEL,ERROR) IF(ERROR) GO TO 9500 LENG=5 CHECK THE NEXT WORD TO SEE IF IT IS "DELOCALIZATION" INSTEAD OF "BLOCK": (IF SO, THE BLOCK WILL BE SPECIFIED BY MOLECULAR UNITS INSTEAD OF BY BLOCKS) CALL HFLD(KEYWD,LENG,DONE) IF(EQUAL(KEYWD,LDELOC,5)) GO TO 1000 CHECK THE WORD TO SEE IF IT IS "ATOM" INSTEAD OF "BLOCK": (IF SO, THE BLOCK WILL BE SPECIFIED BY ORBITALS ON GROUPS OF ATOMS) IF(EQUAL(KEYWD,LATOM,4)) GO TO 1200 NSTART=0 DO 800 K=1,NDEL READ IN THE NUMBER OF ORBITALS IN EACH SET OF THE PAIR, NSET1 AND NSET2: (SKIP THE 'BY' BETWEEN NSET1 AND NSET2) CALL IFLD(NSET1,ERROR) IF(ERROR) GO TO 9500 CALL HFLD(KEYWD,LENG,DONE) CALL IFLD(NSET2,ERROR) IF(ERROR) GO TO 9500 NSTART=NSTART+2 IDEL(NSTART-1)=NSET1 IDEL(NSTART)=NSET2 READ IN THE ORBITALS OF BOTH SETS NTOT=NSET1+NSET2 DO 620 I=1,NTOT CALL IFLD(IDEL(NSTART+I),ERROR) IF(ERROR) GO TO 9500 620 CONTINUE NOW, ZERO ALL INTERSECTING ELEMENTS BETWEEN THE TWO SETS: NSTRT2=NSTART+NSET1 DO 700 I=1,NSET1 ID=IDEL(NSTART+I) DO 700 J=1,NSET2 JD=IDEL(NSTRT2+J) IF(ID.EQ.JD) GO TO 700 TRF(ID,JD)=ZERO TRF(JD,ID)=ZERO 700 CONTINUE NSTART=NSTART+NTOT 800 CONTINUE GO TO 4000 ZEROING OF DELOCALIZATION WITHIN OR BETWEEN MOLECULAR UNITS. USE THE NBO MOLECULAR UNIT (NBOUNI) AND NBO TYPE (NBOTYP) LISTS. 1000 CONTINUE NSTART=0 DO 1100 K=1,NDEL SKIP THE NEXT WORD ("FROM"): CALL HFLD(KEYWD,LENG,DONE) READ IN THE NUMBER OF THE FIRST MOLECULAR UNIT, IUNIT1: CALL IFLD(IUNIT1,ERROR) IF(ERROR) GO TO 9500 SKIP THE "TO" AND READ IN IUNIT2: CALL HFLD(KEYWD,LENG,DONE) CALL IFLD(IUNIT2,ERROR) IF(ERROR) GO TO 9500 WRITE(LFNPR,8300) IUNIT1,IUNIT2 NSTART=NSTART+2 FIND ALL OF THE NONSTAR (CORE/"LONE PAIR"/BOND) NBOS ON UNIT IUNIT1: NSET1=0 DO 1020 IBAS=1,NDIM IF(NBOUNI(IBAS).NE.IUNIT1) GO TO 1020 IF(NBOTYP(IBAS).GT.20) GO TO 1020 NSET1=NSET1+1 IDEL(NSTART+NSET1)=IBAS 1020 CONTINUE IDEL(NSTART-1)=NSET1 FIND ALL OF THE STAR (RYDBERG/ANTIBOND) NBOS ON UNIT IUNIT2: NSET2=0 NSTRT2=NSTART+NSET1 DO 1040 IBAS=1,NDIM IF(NBOUNI(IBAS).NE.IUNIT2) GO TO 1040 IF(NBOTYP(IBAS).LT.10) GO TO 1040 NSET2=NSET2+1 IDEL(NSTRT2+NSET2)=IBAS 1040 CONTINUE IDEL(NSTART)=NSET2 NTOT=NSET1+NSET2 NOW, ZERO ALL INTERSECTING ELEMENTS BETWEEN THE TWO SETS: DO 1060 I=1,NSET1 ID=IDEL(NSTART+I) DO 1060 J=1,NSET2 JD=IDEL(NSTRT2+J) IF(ID.EQ.JD) GO TO 1060 TRF(ID,JD)=ZERO TRF(JD,ID)=ZERO 1060 CONTINUE NSTART=NSTART+NTOT 1100 CONTINUE GO TO 4000 ZEROING OF DELOCALIZATION BETWEEN GROUPS OF ATOMS USE THE NBO TYPE (NBOTYP) AND NBO LABEL (LABEL) LISTS. 1200 CONTINUE MSTART=0 NSTART=0 SKIP THE 'BLOCKS' BEFORE NSET1: CALL HFLD(KEYWD,LENG,DONE) DO 1400 K=1,NDEL READ IN THE NUMBER OF ATOMS IN EACH SET OF THE PAIR, NSET1 AND NSET2: (SKIP THE 'BY' BETWEEN NSET1 AND NSET2) CALL IFLD(MSET1,ERROR) IF(ERROR) GO TO 9500 CALL HFLD(KEYWD,LENG,DONE) CALL IFLD(MSET2,ERROR) IF(ERROR) GO TO 9500 MSTART=MSTART+2 ISCR1(MSTART-1)=MSET1 ISCR1(MSTART)=MSET2 READ IN THE ATOMS OF BOTH SETS: MTOT=MSET1+MSET2 DO 1220 I=1,MTOT CALL IFLD(ISCR1(MSTART+I),ERROR) IF(ERROR) GO TO 9500 1220 CONTINUE MSTRT2=MSTART+MSET1 WRITE(LFNPR,8350) WRITE(LFNPR,8631) (ISCR1(MSTART+I),I=1,MSET1) WRITE(LFNPR,8360) WRITE(LFNPR,8631) (ISCR1(MSTRT2+I),I=1,MSET2) WRITE(LFNPR,8370) CONSTRUCT THE LIST OF THE TWO SETS OF ORBITALS FROM THE ATOM LISTS, PLACING THE ORBITAL LIST IN IDEL IN THE STANDARD MANNER FOR ITYPE=3: NSTART=NSTART+2 NSET1=0 NSET2=0 DO 1300 JBAS=1,NDIM DONOR=.FALSE. ACCPTR=.FALSE. IF(NBOTYP(JBAS).LT.20) DONOR=.TRUE. IF(NBOTYP(JBAS).GE.10) ACCPTR=.TRUE. LIST1=.FALSE. LIST2=.FALSE. REMEMBER TO CONSULT IBXM BEFORE GETTING INFO FROM LABEL! JB=IBXM(JBAS) DO 1240 J=4,6 JAT=LABEL(JB,J) IF(JAT.EQ.0) GO TO 1240 DO 1230 I=1,MSET1 IAT=ISCR1(MSTART+I) IF(IAT.NE.JAT) GO TO 1230 GO TO 1240 1230 CONTINUE GO TO 1250 1240 CONTINUE LIST1=.TRUE. 1250 CONTINUE DO 1270 J=4,6 JAT=LABEL(JB,J) IF(JAT.EQ.0) GO TO 1270 DO 1260 I=1,MSET2 IAT=ISCR1(MSTRT2+I) IF(IAT.NE.JAT) GO TO 1260 GO TO 1270 1260 CONTINUE GO TO 1280 1270 CONTINUE LIST2=.TRUE. 1280 CONTINUE IF(LIST1.AND.LIST2) GO TO 1300 IF(.NOT.LIST1.AND..NOT.LIST2) GO TO 1300 IF(LIST1.AND..NOT.DONOR) GO TO 1300 IF(LIST2.AND..NOT.ACCPTR) GO TO 1300 IF(LIST2) GO TO 1290 LIST1.AND.DONOR=.TRUE. CASE: NSET1=NSET1+1 IDEL(NSTART+NSET1)=JBAS GO TO 1300 LIST2.AND.ACCPTR=.TRUE. CASE: 1290 CONTINUE NSET2=NSET2+1 ISCR2(NSET2)=JBAS 1300 CONTINUE IDEL(NSTART-1)=NSET1 IDEL(NSTART)=NSET2 NTOT=NSET1+NSET2 PLACE ORBITAL SET 2 IN IDEL: NSTRT2=NSTART+NSET1 DO 1320 I=1,NSET2 1320 IDEL(NSTRT2+I)=ISCR2(I) NOW, ZERO ALL INTERSECTING ELEMENTS BETWEEN THE TWO SETS OF ORBITALS: DO 1340 I=1,NSET1 ID=IDEL(NSTART+I) DO 1340 J=1,NSET2 JD=IDEL(NSTRT2+J) TRF(ID,JD)=ZERO 1340 TRF(JD,ID)=ZERO MSTART=MSTART+NTOT NSTART=NSTART+NTOT 1400 CONTINUE GO TO 4000 DELETE ALL VICINAL OR GEMINAL DELOCALIZATIONS: 3000 IVIC=1 WRITE(LFNPR,8550) GOTO 3020 3010 IVIC=0 WRITE(LFNPR,8560) 3020 CONTINUE ITYPE=3 START BY FILLING TRF WITH FULL NBO FOCK MATRIX: II=0 DO 3025 I=1,NDIM DO 3025 J=1,I II=II+1 TRF(I,J)=F(II) TRF(J,I)=F(II) 3025 CONTINUE FIND THE TOTAL NUMBER OF BLOCKS OF THE FOCK MATRIX TO DELETE: NDEL=0 NSTART=0 DO 3070 IBAS=1,NDIM IB=IBXM(IBAS) IF(LABEL(IB,2).NE.ISTAR) THEN NACC=0 DO 3060 JBAS=1,NDIM JB=IBXM(JBAS) IF(LABEL(JB,2).EQ.ISTAR) THEN ITMP = IHTYP(IBAS,JBAS) VICINAL DELOCALIZATION: IF(IVIC.EQ.1.AND.ITMP.EQ.LV) THEN NACC=NACC+1 IDEL(NSTART+NACC+3)=JBAS GEMINAL DELOCALIZATION: ELSE IF(IVIC.EQ.0.AND.ITMP.EQ.LG) THEN NACC=NACC+1 IDEL(NSTART+NACC+3)=JBAS END IF END IF 3060 CONTINUE IF(NACC.GT.0) THEN NDEL=NDEL+1 IDEL(NSTART+1)=1 IDEL(NSTART+2)=NACC IDEL(NSTART+3)=IBAS DO 3065 JB=1,NACC JBAS=IDEL(NSTART+JB+3) IF(JBAS.NE.IBAS) THEN TRF(IBAS,JBAS)=ZERO TRF(JBAS,IBAS)=ZERO END IF 3065 CONTINUE NSTART=NSTART+NACC+3 IF(NSTART.GT.LEN) STOP 'INCREASE DIMENSION OF ARRAY IDEL' END IF END IF 3070 CONTINUE GOTO 4000 WRITE OUT INFORMATION FROM DELETION, FOR ITYPE=3: 4000 CONTINUE INDX=0 DO 4050 K=1,NDEL NSET1=IDEL(INDX+1) NSET2=IDEL(INDX+2) INDX=INDX+2 NL=INDX+1 NU=INDX+NSET1 WRITE(LFNPR,8630) WRITE(LFNPR,8631) (IDEL(I),I=NL,NU) WRITE(LFNPR,8632) NL=INDX+NSET1+1 NU=INDX+NSET1+NSET2 WRITE(LFNPR,8631) (IDEL(I),I=NL,NU) INDX=NU 4050 CONTINUE RETURN DELETE ALL THE "STAR" NBOS ON ONE OR MORE MOLECULES: (SET ITYPE=1 FOR ORBITAL DELETIONS) 5000 CONTINUE ITYPE=1 READ IN THE NUMBER OF MOLECULAR UNITS TO "DESTAR": CALL IFLD(NUNITS,ERROR) IF(ERROR) GO TO 9500 SKIP THE KEYWORD "UNITS": LENG=3 CALL HFLD(KEYWD,LENG,DONE) READ IN THE NUMBERS OF THE UNITS TO DESTAR, FINDING THE STAR ORBITALS FROM THE LISTS NBOUNI AND NBOTYP: NDEL=0 DO 5100 I=1,NUNITS CALL IFLD(IUNIT,ERROR) IF(ERROR) GO TO 9500 WRITE(LFNPR,8400) IUNIT DO 5050 IBAS=1,NDIM IF(NBOUNI(IBAS).NE.IUNIT) GO TO 5050 IF(LABEL(IBAS,2).NE.ISTAR) GO TO 5050 NDEL=NDEL+1 IDEL(NDEL)=IBAS 5050 CONTINUE 5100 CONTINUE GO AND DO THE DELETIONS OF THE NDEL ORBITALS THAT ARE NOW IN IDEL: GO TO 100 DELETE ALL STAR NBOS: 5500 CONTINUE ITYPE=1 NDEL=0 WRITE(LFNPR,8500) DO 5600 IBAS=1,NDIM IF(LABEL(IBAS,2).NE.ISTAR) GO TO 5600 NDEL=NDEL+1 IDEL(NDEL)=IBAS 5600 CONTINUE GO AND DO THE DELETIONS OF THE NDEL ORBITALS THAT ARE NOW IN IDEL: GO TO 100 8100 FORMAT(1X,' ----------- Alpha spin NBO deletions ----------- '/) 8200 FORMAT(1X,' ----------- Beta spin NBO deletions ----------- '/) 8300 FORMAT(1X,'Zero delocalization from unit ',I2,' to unit ',I2) 8350 FORMAT(1X,'Zero delocalization from NBOs localized on atoms:') 8360 FORMAT(1X,'to NBOs localized on atoms:') 8370 FORMAT(1X,' (NBOs in common to the two groups of atoms ', * 'left out)') 8400 FORMAT(1X,'DESTAR unit ',I2,': Delete all Rydberg/antibond', * ' NBOs from this unit') 8500 FORMAT(1X,'NOSTAR: Delete all Rydberg/antibond NBOs') 8550 FORMAT(1X,'NOVIC: Delete all vicinal delocalizations') 8560 FORMAT(1X,'NOGEM: Delete all geminal delocalizations') 8610 FORMAT(1X,'Deletion of the following orbitals ', * 'from the NBO Fock matrix:',(/1X,20I4)) 8620 FORMAT(1X,'Deletion of the following NBO Fock matrix ', * 'elements:',/(7(2X,'(',I3,',',I3,')'))) 8630 FORMAT(1X,'Deletion of the NBO Fock matrix elements ', * 'between orbitals:') 8631 FORMAT(1X,20I4) 8632 FORMAT(1X,'and orbitals:') 8640 FORMAT(1X,'Deletion of the following NBO Fock matrix ', * 'blocks:',/(2(2X,'(',I3,'-',I3,'/',I3,'-',I3,')'))) 8700 FORMAT(/) ERROR MESSAGES: 9000 WRITE(LFNPR,9010) (KEYWD(I),I=1,3) 9010 FORMAT(1X,'First character string does not have the', * ' first three letters of DELETE or ZERO:',/1X,3A1) STOP 9100 WRITE(LFNPR,9110) 9110 FORMAT(1X,'Non-integer was input for number of items to delete.') STOP 9200 WRITE(LFNPR,9210) (KEYWD(I),I=1,3) 9210 FORMAT(1X,'No match with first three letters of the keywords ', * 'for deletion type'/' (ORBITAL,ELEMENT,BLOCK) found:', * 3A1) STOP 9300 WRITE(LFNPR,9310) 9310 FORMAT(1X,'Keyword ALPHA (or A) not found to start alpha NBO', * ' deletion input.') STOP 9400 WRITE(LFNPR,9410) 9410 FORMAT(1X,'Keyword BETA (or B) not found to start beta NBO', * ' deletion input.') 9500 WRITE(LFNPR,9510) 9510 FORMAT(' There is an error in the input of deletions.') STOP END ***************************************************************************** SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + IATNO(MAXBAS),IBXM(MAXBAS),NRANK(2*MAXBAS),LOCC(2*MAXBAS) DIMENSION DM(1),U(NDIM,NDIM),EIG(NDIM),IDEL(LEN) DATA ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/ ONETWO: ONE IF OPEN SHELL (ISPIN.NE.0), TWO IF CLOSED SHELL (DOUBLY OCC MOS) ONETWO=TWO IF(ISPIN.NE.0) ONETWO=ONE NTRUNC: DIMENSION OF TRUNCATED FOCK MATRIX NTRUNC=NDIM IF(ITYPE.EQ.1) NTRUNC=NDIM-NDEL RANK THE EIGENVALUES 'EIG' FROM THE TRUNCATED FOCK MATRIX FROM LOWEST TO HIGHEST IN 'NRANK': CALL RNKEIG(NRANK,EIG,NTRUNC,NDIM,LOCC) PUT IN 'LOCC' THE LOCATIONS OF THE 'NMOOCC' LOWEST EIGENVALUES: (THESE CORRESPOND TO THE DOUBLY OCCUPIED MOS) NOCC=0 DO 20 I=1,NTRUNC IF(NRANK(I).GT.NMOOCC) GO TO 20 NOCC=NOCC+1 LOCC(NOCC)=I 20 CONTINUE NDELOR: NUMBER OF DELETED ORBITALS NDELOR=NDIM-NTRUNC CONSTRUCT THE NEW NBO DENSITY MATRIX: LOOP OVER ROWS: II=0 IJ=0 IOUT=1 DO 105 I=1,NDIM IF(IOUT.GT.NDELOR) GO TO 40 IF(I.NE.IDEL(IOUT)) GO TO 40 ZERO ROWS OF THE NEW NBO DENSITY MATRIX THAT WERE ZEROED IN THE TRUNCATION, ALSO ZEROING THE ORBITAL OCCPANCY, EIG(I): IOUT=IOUT+1 EIG(I)=ZERO DO 30 J=1,I IJ=IJ+1 30 DM(IJ)=ZERO GO TO 105 40 CONTINUE II=II+1 LOOP OVER COLUMNS: JOUT=1 JJ=0 DO 100 J=1,I IF(JOUT.GT.NDELOR) GO TO 50 IF(J.NE.IDEL(JOUT)) GO TO 50 ZERO COLUMNS OF THE NEW NBO DENSITY MATRIX THAT WERE ZEROED IN THE TRUNCATION OF THE NBO FOCK MATRIX: JOUT=JOUT+1 IJ=IJ+1 DM(IJ)=ZERO GO TO 100 50 CONTINUE FIND DM(IJ) FROM THE EIGENVECTORS OF THE TRUNCATED NBO FOCK MATRIX IN 'U', SUMMING OVER THE OCCUPIED MOS, AND MULTIPLYING BY TWO FOR DOUBLE OCCUPANCY: JJ=JJ+1 SUM=ZERO DO 80 K=1,NMOOCC 80 SUM=SUM+U(II,LOCC(K))*U(JJ,LOCC(K)) IJ=IJ+1 DM(IJ)=SUM*ONETWO IF(I.EQ.J) EIG(I)=SUM*ONETWO 100 CONTINUE 105 CONTINUE RETURN END ***************************************************************************** SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) RANK EIGENVALUES IN 'EIG', LOWEST VALUES FIRST, IN 'RANK': INTEGER RANK,ARCRNK DIMENSION RANK(NDIM),EIG(NDIM),ARCRNK(NDIM) DO 10 I=1,N 10 ARCRNK(I)=I DO 40 I=1,N IF(I.EQ.N) GO TO 30 I1=I+1 DO 20 J=I1,N IF(EIG(J).GE.EIG(I)) GO TO 20 TEMP=EIG(I) EIG(I)=EIG(J) EIG(J)=TEMP ITEMP=ARCRNK(I) ARCRNK(I)=ARCRNK(J) ARCRNK(J)=ITEMP 20 CONTINUE 30 RANK(ARCRNK(I))=I 40 CONTINUE RETURN END ***************************************************************************** SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION F(1),U(NDIM,1),S(1),R(1) TAKE U(TRANSPOSE)*F*U: F MATRIX TO BE TRANSFORMED (PACKED UPPER TRIANGULAR) U IS THE TRANSFORMATION MATRIX R IS THE MATRIX IN WHICH THE RESULT WILL BE RETURNED S IS A SCRATCH MATRIX OF DIMENSION N KNTROL....=0 RESULT RETURNED ONLY IN R =1 RESULT COPIED INTO F IN=0 DO 50 I=1,N JN=0 DO 20 J=1,N SUM=0. KN=0 DO 10 K=1,N JK=JN+K IF(J.LT.K) JK=KN+J SUM=SUM+F(JK)*U(K,I) 10 KN=KN+K S(J)=SUM 20 JN=JN+J DO 40 J=1,I SUM=0. DO 30 K=1,N 30 SUM=SUM+S(K)*U(K,J) IJ=IN+J 40 R(IJ)=SUM 50 IN=IN+I IF(KNTROL.EQ.0) RETURN NT=N*(N+1)/2 DO 60 I=1,NT 60 F(I)=R(I) RETURN END ***************************************************************************** NBO DIRECT ACCESS FILE (DAF) ROUTINES: SUBROUTINE NBFILE(NEW,ERROR) SUBROUTINE NBOPEN(NEW,ERROR) SUBROUTINE NBWRIT(IX,NX,IDAR) SUBROUTINE NBREAD(IX,NX,IDAR) SUBROUTINE NBCLOS(SEQ) SUBROUTINE NBINQR(IDAR) SUBROUTINE FETITL(TITLE) SUBROUTINE FEE0(EDEL,ETOT) SUBROUTINE SVE0(EDEL) SUBROUTINE FECOOR(ATCOOR) SUBROUTINE FESRAW(S) SUBROUTINE FEDRAW(DM,SCR) SUBROUTINE FEFAO(F,IWFOCK) SUBROUTINE FEAOMO(T,IT) SUBROUTINE FEDXYZ(DXYZ,I) SUBROUTINE SVNBO(T,OCC,ISCR) SUBROUTINE FENBO(T,OCC,ISCR,NELEC) SUBROUTINE FETNBO(T) SUBROUTINE SVPNAO(T) SUBROUTINE FEPNAO(T) SUBROUTINE SVSNAO(S) SUBROUTINE FESNAO(S) SUBROUTINE SVTNAB(T) SUBROUTINE FETNAB(T) SUBROUTINE SVTLMO(T) SUBROUTINE FETLMO(T) SUBROUTINE SVTNHO(T) SUBROUTINE FETNHO(T) SUBROUTINE SVPPAO(DM) SUBROUTINE FEPPAO(DM) SUBROUTINE SVTNAO(T) SUBROUTINE FETNAO(T) SUBROUTINE SVNLMO(T) SUBROUTINE FENLMO(T) SUBROUTINE SVDNAO(DM) SUBROUTINE FEDNAO(DM) SUBROUTINE SVFNBO(F) SUBROUTINE FEFNBO(F) SUBROUTINE SVNEWD(DM) SUBROUTINE FENEWD(DM) SUBROUTINE FEINFO(ICORE,ISWEAN) SUBROUTINE FEBAS(NSHELL,NEXP,ISCR) ***************************************************************************** SUBROUTINE NBFILE(NEW,ERROR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL NEW,ERROR,NEED,THERE CHARACTER*80 TEMP PARAMETER (MAXFIL = 40) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) CHARACTER*80 FILENM DATA IWRIT,IREAD/4HWRIT,4HREAD/ Create a list IFILE of external LFNs. First find the files that will be written: ERROR = .FALSE. NFILE = 0 DO 10 I = 1,999 NEED = .FALSE. IF(IWPNAO.EQ.-I) NEED = .TRUE. IF(IWTNAO.EQ.-I) NEED = .TRUE. IF(IWTNAB.EQ.-I) NEED = .TRUE. IF(IWTNBO.EQ.-I) NEED = .TRUE. IF(JPRINT(7).EQ. I) NEED = .TRUE. IF(JPRINT(9).EQ.-I) NEED = .TRUE. IF(JPRINT(13).EQ.-I) NEED = .TRUE. IF(JPRINT(15).EQ.-I) NEED = .TRUE. IF(JPRINT(16).EQ.-I) NEED = .TRUE. IF(JPRINT(17).EQ.-I) NEED = .TRUE. IF(JPRINT(18).EQ.-I) NEED = .TRUE. IF(JPRINT(19).EQ.-I) NEED = .TRUE. IF(JPRINT(20).EQ.-I) NEED = .TRUE. IF(JPRINT(21).EQ.-I) NEED = .TRUE. IF(JPRINT(22).EQ. I) NEED = .TRUE. IF(JPRINT(23).EQ.-I) NEED = .TRUE. IF(JPRINT(24).EQ.-I) NEED = .TRUE. IF(JPRINT(25).EQ.-I) NEED = .TRUE. IF(JPRINT(26).EQ.-I) NEED = .TRUE. IF(JPRINT(27).EQ.-I) NEED = .TRUE. IF(JPRINT(28).EQ.-I) NEED = .TRUE. IF(JPRINT(29).EQ.-I) NEED = .TRUE. IF(JPRINT(30).EQ.-I) NEED = .TRUE. IF(JPRINT(31).EQ.-I) NEED = .TRUE. IF(JPRINT(33).EQ.-I) NEED = .TRUE. IF(JPRINT(34).EQ.-I) NEED = .TRUE. IF(JPRINT(35).EQ.-I) NEED = .TRUE. IF(JPRINT(37).EQ.-I) NEED = .TRUE. IF(JPRINT(38).EQ.-I) NEED = .TRUE. IF(JPRINT(39).EQ.-I) NEED = .TRUE. IF(JPRINT(40).EQ.-I) NEED = .TRUE. IF(JPRINT(41).EQ.-I) NEED = .TRUE. IF(JPRINT(42).EQ.-I) NEED = .TRUE. IF(JPRINT(44).EQ.-I) NEED = .TRUE. IF(JPRINT(45).EQ.-I) NEED = .TRUE. IF(JPRINT(47).EQ.-I) NEED = .TRUE. IF(JPRINT(48).EQ.-I) NEED = .TRUE. IF(JPRINT(49).EQ.-I) NEED = .TRUE. IF(JPRINT(50).EQ.-I) NEED = .TRUE. IF(JPRINT(51).EQ.-I) NEED = .TRUE. IF(JPRINT(52).EQ.-I) NEED = .TRUE. IF(JPRINT(53).EQ.-I) NEED = .TRUE. IF(JPRINT(54).EQ.-I) NEED = .TRUE. IF(NEED) THEN NFILE = NFILE + 1 IF(NFILE.GT.MAXFIL) THEN WRITE(LFNPR,890) MAXFIL ERROR = .TRUE. RETURN END IF IFILE(NFILE) = I END IF 10 CONTINUE Add files that may be read: MFILE = NFILE IF(IOINQR(IWPNAO).EQ.IREAD) THEN MFILE = MFILE + 1 IF(MFILE.GT.MAXFIL) THEN WRITE(LFNPR,890) MAXFIL ERROR = .TRUE. RETURN END IF IFILE(MFILE) = IWPNAO/1000 END IF IF(IOINQR(IWTNAO).EQ.IREAD) THEN MFILE = MFILE + 1 IF(MFILE.GT.MAXFIL) THEN WRITE(LFNPR,890) MAXFIL ERROR = .TRUE. RETURN END IF IFILE(MFILE) = IWTNAO/1000 END IF IF(IOINQR(IWTNAB).EQ.IREAD) THEN MFILE = MFILE + 1 IF(MFILE.GT.MAXFIL) THEN WRITE(LFNPR,890) MAXFIL ERROR = .TRUE. RETURN END IF IFILE(MFILE) = IWTNAB/1000 END IF Make sure that no files are both written and read: DO 30 I = NFILE+1,MFILE DO 20 J = 1,NFILE IF(ABS(IFILE(I)).EQ.IFILE(J)) THEN WRITE(LFNPR,900) IFILE(J) ERROR = .TRUE. RETURN END IF 20 CONTINUE 30 CONTINUE NFILE = MFILE Also check that the NBO DAF has its own LFN: DO 40 I = 1,NFILE IF(ABS(IFILE(I)).EQ.ABS(LFNDAF)) THEN WRITE(LFNPR,900) IFILE(I) ERROR = .TRUE. RETURN END IF 40 CONTINUE Select an alternate filename if this one is not acceptable: TEMP = FILENM DO 50 I = 1,80 IF(TEMP(I:I).EQ.CHAR(32)) THEN LENGTH = I - 1 GO TO 60 END IF 50 CONTINUE LENGTH = 76 60 CONTINUE IO = IOINQR(IWPNAO) JO = IOINQR(IWTNAO) KO = IOINQR(IWTNAB) IF(NEW.AND.IO.NE.IREAD.AND.JO.NE.IREAD.AND.KO.NE.IREAD) THEN DO 100 I = 0,999 LEN = LENGTH IF(I.NE.0) THEN II = I 65 LEN = LEN + 1 TEMP(LEN:LEN) = CHAR(MOD(II,10) + 48) II = II / 10 IF(II.NE.0) GOTO 65 IF(LEN.EQ.LENGTH+2) THEN TEMP(LEN+1:LEN+1) = TEMP(LEN:LEN) TEMP(LEN:LEN) = TEMP(LEN-1:LEN-1) TEMP(LEN-1:LEN-1) = TEMP(LEN+1:LEN+1) ELSE IF(LEN.EQ.LENGTH+3) THEN TEMP(LEN+1:LEN+1) = TEMP(LEN:LEN) TEMP(LEN:LEN) = TEMP(LEN-2:LEN-2) TEMP(LEN-2:LEN-2) = TEMP(LEN+1:LEN+1) END IF END IF TEMP(LEN+1:LEN+1) = '.' First check the DAF: K = ABS(LFNDAF) IF(ABS(LFNDAF).LT.100) K = K * 10 TEMP(LEN+2:LEN+2) = CHAR(K/100 + 48) TEMP(LEN+3:LEN+3) = CHAR(MOD(K/10,10) + 48) IF(ABS(LFNDAF).LT.100) THEN TEMP(LEN+4:LEN+4) = CHAR(32) ELSE TEMP(LEN+4:LEN+4) = CHAR(MOD(K,10) + 48) END IF INQUIRE(FILE=TEMP,EXIST=THERE) IF(THERE) GO TO 100 Now check the rest: DO 70 J = 1,NFILE K = ABS(IFILE(J)) IF(ABS(IFILE(J)).LT.100) K = K * 10 TEMP(LEN+2:LEN+2) = CHAR(K/100 + 48) TEMP(LEN+3:LEN+3) = CHAR(MOD(K/10,10) + 48) IF(ABS(IFILE(J)).LT.100) THEN TEMP(LEN+4:LEN+4) = CHAR(32) ELSE TEMP(LEN+4:LEN+4) = CHAR(MOD(K,10) + 48) END IF INQUIRE(FILE=TEMP, EXIST=THERE) IF(THERE) GO TO 100 70 CONTINUE GO TO 200 100 CONTINUE WRITE(LFNPR,910) ERROR = .TRUE. RETURN This is a good one!! If the filename has changed, write a warning: 200 CONTINUE IF(FILENM(1:LEN).NE.TEMP(1:LEN)) THEN FILENM(1:LEN) = TEMP(1:LEN) DO 210 I = LEN+1,80 FILENM(I:I) = CHAR(32) 210 CONTINUE WRITE(LFNPR,920) FILENM(1:52) END IF LENGTH = LEN END IF Open external files: TEMP = FILENM TEMP(LENGTH+1:LENGTH+1) = '.' DO 300 I = 1,NFILE K = ABS(IFILE(I)) IF(ABS(IFILE(I)).LT.100) K = K * 10 TEMP(LENGTH+2:LENGTH+2) = CHAR(K/100 + 48) TEMP(LENGTH+3:LENGTH+3) = CHAR(MOD(K/10,10) + 48) IF(ABS(IFILE(I)).LT.100) THEN TEMP(LENGTH+4:LENGTH+4) = CHAR(32) ELSE TEMP(LENGTH+4:LENGTH+4) = CHAR(MOD(K,10) + 48) END IF IF(IFILE(I).GT.0) THEN OPEN(UNIT=IFILE(I), FILE=TEMP, STATUS='NEW') ELSE OPEN(UNIT=ABS(IFILE(I)), FILE=TEMP, STATUS='OLD') END IF 300 CONTINUE RETURN 890 FORMAT(/1X,'I/O is limited to ',I2,' files. Program abort.') 900 FORMAT(/1X,'Illegal request for input and output with LFN',I3) 910 FORMAT(/1X,'The search for an acceptable filename has failed.') 920 FORMAT(/1X,'Filename: Changed to ',A52) END ***************************************************************************** SUBROUTINE NBOPEN(NEW,ERROR) ***************************************************************************** The following records of the NBO direct access file (DAF) are used: 1 --- NBODAF common block 2 --- Job title 3 --- NATOMS,NDIM,NBAS,MUNIT,wavefunction flags,ISWEAN 4 --- IATNO,IZNUC,LCTR,LANG 5 --- AO basis set information 8 --- Deletion energy, total energy 9 --- Atomic coordinates 10 --- AO overlap matrix 11 --- PNAO overlap matrix 20 --- AO density matrix (alpha) 21 --- AO density matrix (beta) 22 --- Pure AO density matrix 23 --- NAO density matrix (alpha) 24 --- NAO density matrix (beta) 25 --- AO density matrix with NBO deletions (alpha) 26 --- AO density matrix with NBO deletions (beta) 27 --- NBO occupancies (alpha) 28 --- NBO occupancies (beta) 30 --- AO Fock matrix (alpha) 31 --- AO Fock matrix (beta) 32 --- NAO Fock matrix (alpha) 33 --- NAO Fock matrix (beta) 34 --- NBO Fock matrix (alpha) 35 --- NBO Fock matrix (beta) 40 --- AO to MO transformation matrix (alpha) 41 --- AO to MO transformation matrix (beta) 42 --- AO to PNAO transformation matrix 43 --- AO to NAO transformation matrix 44 --- AO to NBO transformation matrix (alpha) 45 --- AO to NBO transformation matrix (beta) 46 --- AO to NLMO transformation matrix 47 --- NAO to NHO transformation matrix 48 --- NAO to NBO transformation matrix 49 --- NBO to NLMO transformation matrix 50 --- X dipole integrals 51 --- Y dipole integrals 52 --- Z dipole integrals 60 --- NBO labels (alpha) 61 --- NBO labels (beta) ----------------------------------------------------------------------------- IMPLICIT REAL*8 (A-H,O-Z) LOGICAL NEW,ERROR CHARACTER*80 TEMP Note that ISINGL is no longer a parameter (6/7/90): PARAMETER (LENGTH = 256) PARAMETER (NBDAR = 100) PARAMETER (MAXFIL = 40) COMMON/NBODAF/INBO,NAV,IONBO(NBDAR) COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) CHARACTER*80 FILENM DIMENSION IX(NBDAR+2),IXSNBO(LENGTH/2) EQUIVALENCE (IXSNBO(1),IXDNBO(1)) EQUIVALENCE (IX(1),INBO) SAVE ISW,LENREC DATA IBLNK/1H / DATA ISW/0/ INBO : Fortran file number IONBO : Indexing array mapping the logical records of the NBO DAF onto the physical records of the disk file NAV : Number of physical records currently on the DAF NBDAR : Maximum number of logical records on the DAF INBO = ABS(LFNDAF) Are we working on a 32 (ISINGL=2) or 64 (ISINGL=1) bit machine? IF(ISW.EQ.0) THEN DO 10 I = 1,4 IBLNK = IBLNK / 256 10 CONTINUE IF(IBLNK.EQ.0) THEN ISINGL = 2 ELSE ISINGL = 1 END IF Determine an appropriate record length for the NBO DAF: LREC = LENGTH / 4 LENREC = 0 DO 30 I = 1,6 LREC = LREC * 2 OPEN(UNIT=INBO, FILE='nb$temp.dat', STATUS='NEW', + ACCESS='DIRECT', RECL=LREC, FORM='UNFORMATTED', + ERR=40) WRITE(INBO,REC=1,ERR=20) IXDNBO If I.EQ.1 at this point, ERR did not work properly in the preceding statement (this appears to be the case for the XL FORTRAN compiler running on an IBM RISC station/6000): IF(I.EQ.1) LREC = LENGTH * 8 / ISINGL IF(ISINGL.EQ.1) LENREC = LREC / 2 IF(ISINGL.EQ.2) LENREC = LREC 20 CLOSE(UNIT=INBO, STATUS='DELETE') IF(LENREC.NE.0) GO TO 50 30 CONTINUE Problems... 40 CONTINUE WRITE(LFNPR,900) ERROR = .TRUE. RETURN 50 CONTINUE ISW = 1 END IF Open the NBO direct access file (DAF) -- typically assigned to LFN48: TEMP = FILENM DO 60 I = 1,80 IF(TEMP(I:I).EQ.CHAR(32)) THEN LEN = I - 1 GO TO 70 END IF 60 CONTINUE LEN = 76 70 CONTINUE K = INBO IF(INBO.LT.100) K = K * 10 TEMP(LEN+1:LEN+1) = '.' TEMP(LEN+2:LEN+2) = CHAR(K/100 + 48) TEMP(LEN+3:LEN+3) = CHAR(MOD(K/10,10) + 48) IF(INBO.LT.100) THEN TEMP(LEN+4:LEN+4) = CHAR(32) ELSE TEMP(LEN+4:LEN+4) = CHAR(MOD(K,10) + 48) END IF If this is a new NBO DAF, write COMMON/NBODAF/ on the first record: IF(NEW) THEN OPEN(UNIT=INBO, FILE=TEMP, STATUS='NEW', ACCESS='DIRECT', + RECL=LENREC, FORM='UNFORMATTED', ERR=110) NAV = 1 NBNAV = 1 DO 80 I = 1,NBDAR IONBO(I) = 0 80 CONTINUE NF = 1 NX = (NBDAR + 2) / ISINGL CALL NBWRIT(IX,NX,NF) Otherwise, open the old file and read in COMMON/NBODAF/ from the first record: ELSE OPEN(UNIT=INBO, FILE=TEMP, STATUS='OLD', ACCESS='DIRECT', + RECL=LENREC, FORM='UNFORMATTED', ERR=110) NBNAV = 1 MAXIX = LENGTH * ISINGL/2 LDAR = NBDAR + 2 MAX = 0 90 MIN = MAX + 1 MAX = MAX + MAXIX IF(MAX.GT.LDAR) MAX = LDAR IF(ISINGL.EQ.1) READ(INBO,REC=NBNAV) IXSNBO IF(ISINGL.EQ.2) READ(INBO,REC=NBNAV) IXDNBO DO 100 I = MIN,MAX IX(I) = IXDNBO(I-MIN+1) 100 CONTINUE NBNAV = NBNAV + 1 IF(MAX.LT.LDAR) GO TO 90 INBO = ABS(LFNDAF) END IF ERROR = .FALSE. RETURN Error encountered while opening this file: 110 ERROR = .TRUE. RETURN 900 FORMAT(/1X,'Routine NBOPEN could not determine an appropriate ', + 'record length.') END ***************************************************************************** SUBROUTINE NBWRIT(IX,NX,IDAR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (LENGTH = 256) PARAMETER (NBDAR = 100) COMMON/NBODAF/INBO,NAV,IONBO(NBDAR) COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL DIMENSION IX(1),IXSNBO(LENGTH/2) EQUIVALENCE (IXSNBO(1),IXDNBO(1)) MAXIX = LENGTH * ISINGL / 2 LDAR = NX * ISINGL IF(IONBO(IDAR).NE.0) GO TO 100 If this is the first write to the NBO DAF: IONBO(IDAR) = NAV NBNAV = NAV MAX = 0 10 MIN = MAX + 1 MAX = MAX + MAXIX IF(MAX.GT.LDAR) MAX = LDAR DO 20 I = MIN,MAX 20 IXDNBO(I-MIN+1) = IX(I) IF(ISINGL.EQ.1) WRITE(INBO,REC=NBNAV) IXSNBO IF(ISINGL.EQ.2) WRITE(INBO,REC=NBNAV) IXDNBO NBNAV = NBNAV + 1 IF(MAX.LT.LDAR) GO TO 10 NAV = NBNAV RETURN Or if this is a rewrite: 100 CONTINUE NBNAV = IONBO(IDAR) MAX = 0 110 MIN = MAX + 1 MAX = MAX + MAXIX IF(MAX.GT.LDAR) MAX = LDAR DO 120 I = MIN,MAX 120 IXDNBO(I-MIN+1) = IX(I) IF(ISINGL.EQ.1) WRITE(INBO,REC=NBNAV) IXSNBO IF(ISINGL.EQ.2) WRITE(INBO,REC=NBNAV) IXDNBO NBNAV = NBNAV + 1 IF(MAX.LT.LDAR) GO TO 110 RETURN END ***************************************************************************** SUBROUTINE NBREAD(IX,NX,IDAR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (LENGTH = 256) PARAMETER (NBDAR = 100) COMMON/NBODAF/INBO,NAV,IONBO(NBDAR) COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL DIMENSION IX(1),IXSNBO(LENGTH/2) EQUIVALENCE (IXSNBO(1),IXDNBO(1)) NBNAV = IONBO(IDAR) MAXIX = LENGTH * ISINGL / 2 LDAR = NX * ISINGL MAX = 0 10 MIN = MAX + 1 MAX = MAX + MAXIX IF(MAX.GT.LDAR) MAX = LDAR IF(ISINGL.EQ.1) READ(INBO,REC=NBNAV) IXSNBO IF(ISINGL.EQ.2) READ(INBO,REC=NBNAV) IXDNBO DO 20 I = MIN,MAX 20 IX(I) = IXDNBO(I-MIN+1) NBNAV = NBNAV + 1 IF(MAX.LT.LDAR) GO TO 10 RETURN END ***************************************************************************** SUBROUTINE NBCLOS(SEQ) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL SEQ PARAMETER (LENGTH = 256) PARAMETER (NBDAR = 100) PARAMETER (MAXFIL = 40) COMMON/NBODAF/INBO,NAV,IONBO(NBDAR) COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) CHARACTER*80 FILENM DIMENSION IX(NBDAR+2) EQUIVALENCE (IX(1),INBO) First close the NBO direct access file, remembering to write COMMON/NBODAF/ to the first logical record: NF = 1 NX = (NBDAR + 2) / ISINGL CALL NBWRIT(IX,NX,NF) CLOSE(UNIT=INBO, STATUS='KEEP') Then close the remainder of the files used by the NBO program: DO 10 I = 1,NFILE CLOSE(UNIT=ABS(IFILE(I)), STATUS='KEEP') 10 CONTINUE RETURN END ***************************************************************************** SUBROUTINE NBINQR(IDAR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (NBDAR = 100) COMMON/NBODAF/INBO,NAV,IONBO(NBDAR) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF IF(IDAR.LT.1.OR.IDAR.GT.NBDAR) THEN WRITE(LFNPR,900) IDAR,NBDAR STOP END IF IF(IONBO(IDAR).EQ.0) IDAR = 0 RETURN 900 FORMAT(/1X,'NBO DAF record out of range: IDAR = ',I4, + ' NBDAR = ',I4) END ***************************************************************************** SUBROUTINE FETITL(TITLE) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION TITLE(10) FETITL: FETCHES THE JOB TITLE FROM THE NBODAF: NFILE = 2 CALL NBREAD(TITLE,10,NFILE) RETURN END ***************************************************************************** SUBROUTINE FEE0(EDEL,ETOT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION X(2) FEE0: FETCHES THE DELETION AND TOTAL SCF ENERGY NFILE = 8 CALL NBREAD(X,2,NFILE) EDEL = X(1) ETOT = X(2) RETURN END ***************************************************************************** SUBROUTINE SVE0(EDEL) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION X(2) SVE0: SAVES THE DELETION ENERGY NFILE = 8 CALL NBREAD(X,2,NFILE) X(1) = EDEL CALL NBWRIT(X,2,NFILE) RETURN END ***************************************************************************** SUBROUTINE FECOOR(ATCOOR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION ATCOOR(3*NATOMS) FECOOR: FETCH THE ATOMIC CARTESIAN COORDINATES IN ANGSTROMS. NFILE = 9 CALL NBREAD(ATCOOR,3*NATOMS,NFILE) RETURN END ***************************************************************************** SUBROUTINE FEBAS(NSHELL,NEXP,ISCR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION ISCR(1) FEBAS: FETCHES THE BASIS SET INFO NFILE = 5 CALL NBINQR(NFILE) IF(NFILE.GT.0) THEN CALL NBREAD(ISCR,2,NFILE) II = 0 II = II + 1 NSHELL = ISCR(II) II = II + 1 NEXP = ISCR(II) LEN = 2 + 3*NSHELL + 5*NEXP CALL NBREAD(ISCR,LEN,NFILE) ELSE NSHELL = 0 END IF RETURN END ***************************************************************************** SUBROUTINE FESRAW(S) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION S(NDIM,NDIM) FESRAW: FETCHES THE OVERLAP MATRIX (RAW AO. BASIS) INTO S(NDIM,NDIM) A FULL SQUARE MATRIX. NFILE = 10 L2 = NDIM*(NDIM+1)/2 CALL NBREAD(S,L2,NFILE) CALL UNPACK(S,NDIM,NBAS,L2) RETURN END ***************************************************************************** SUBROUTINE FEDRAW(DM,SCR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DM(1),SCR(1) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DATA NFILEA,NFILEB/20,21/ FEDRAW: FETCHES THE DENSITY MATRIX (RAW A.O. BASIS) IN DM(NDIM,NDIM) IF ALPHA =.TRUE. FETCH ALPHA MATRIX IF BETA =.TRUE FETCH BETA MATRIX. IF OPEN .AND. .NOT.(ALPHA .OR. BETA) =.TRUE FETCH THE TOTAL D.M. L2 = NDIM*(NDIM+1)/2 NFILE = NFILEA IF(BETA) NFILE = NFILEB CALL NBREAD(DM,L2,NFILE) IF(.NOT.OPEN) GOTO 300 IF(ALPHA.OR.BETA) GOTO 300 CALL NBREAD(SCR,L2,NFILEB) FORM THE TOTAL DENSITY MATRIX: DO 100 I = 1,L2 DM(I) = DM(I) + SCR(I) 100 CONTINUE 300 CALL UNPACK(DM,NDIM,NBAS,L2) RETURN END ***************************************************************************** SUBROUTINE FEFAO(F,IWFOCK) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION F(1) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DATA NFILEA,NFILEB/30,31/ FEFAO: FETCHES THE AO FOCK MATRIX IF ALPHA .EQ. .TRUE. WE WANT THE ALPHA FOCK MATRIX IF BETA .EQ. .TRUE. WE WANT THE BETA FOCK MATRIX. IF THE REQUESTED MATRIX DOES NOT EXIST THEN IWFOCK = 0 L2 = NDIM*(NDIM+1)/2 NFILE = NFILEA IF(BETA) NFILE = NFILEB CALL NBINQR(NFILE) IF(NFILE.GT.0) THEN CALL NBREAD(F,L2,NFILE) CALL UNPACK(F,NDIM,NBAS,L2) ELSE IWFOCK = 0 END IF RETURN END ***************************************************************************** SUBROUTINE FEAOMO(T,IT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION T(1) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DATA NFILEA,NFILEB/40,41/ FEAOMO: FETCH THE AO TO MO TRANSFORMATION MATRIX: (IT = 1, AO TO MO TRANSFORM IS ON NBO DAF) (IT = 0, AO TO MO TRANSFORM IS NOT ON NBO DAF) NFILE = NFILEA IF (BETA) NFILE = NFILEB CALL NBINQR(NFILE) IF(NFILE.GT.0) THEN IT = 1 L3 = NDIM*NDIM CALL NBREAD(T,L3,NFILE) ELSE IT = 0 END IF RETURN END ***************************************************************************** SUBROUTINE FEDXYZ(DXYZ,I) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DXYZ(1) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DATA NFILEX,NFILEY,NFILEZ/50,51,52/ FEDXYZ: FETCH THE AO DIPOLE MOMENT MATRICES (IN ANGSTROMS) I=1: X I=2: Y I=3: Z IF(I.EQ.1) NFILE = NFILEX IF(I.EQ.2) NFILE = NFILEY IF(I.EQ.3) NFILE = NFILEZ CALL NBINQR(NFILE) IF(NFILE.GT.0) THEN L2 = NDIM*(NDIM+1)/2 CALL NBREAD(DXYZ,L2,NFILE) CALL UNPACK(DXYZ,NDIM,NBAS,L2) ELSE I = 0 END IF RETURN END ***************************************************************************** SUBROUTINE SVNBO(T,OCC,ISCR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORB(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DIMENSION T(NDIM,NDIM),OCC(NDIM),ISCR(1) SVNBO: SAVES NBO INFORMATION (TRANSFORMATION, OCCUPANCIES, LABELS, ETC.) IF ALPHA .EQ. .TRUE. SAVE THE ALPHA INFORMATION IF BETA .EQ. .TRUE. SAVE THE BETA INFORMATION. SAVE THE AO TO NBO TRANSFORMATION MATRIX: L1 = NDIM L3 = NDIM*NDIM L4 = 10*NDIM NFILE = 44 IF (BETA) NFILE = 45 CALL NBWRIT(T,L3,NFILE) SAVE NBO ORBITAL OCCUPANCIES: NFILE = 27 IF (BETA) NFILE = 28 CALL NBWRIT(OCC,L1,NFILE) SAVE THE LISTS OF NBO INFORMATION FOR LATER USE IN THE DELETIONS. PACK THE INFORMATION INTO ISCR(10*NDIM): II = 0 DO 40 K = 1,6 DO 30 I = 1,NBAS II = II + 1 ISCR(II) = LABEL(I,K) 30 CONTINUE 40 CONTINUE DO 50 I = 1,NBAS II = II + 1 ISCR(II) = IBXM(I) 50 CONTINUE DO 60 I = 1,NATOMS II = II + 1 ISCR(II) = IATNO(I) 60 CONTINUE DO 70 I = 1,NBAS II = II + 1 ISCR(II) = NBOUNI(I) 70 CONTINUE DO 80 I = 1,NBAS II = II + 1 ISCR(II) = NBOTYP(I) 80 CONTINUE NFILE = 60 IF (BETA) NFILE = 61 CALL NBWRIT(ISCR,L4,NFILE) RETURN END ***************************************************************************** SUBROUTINE FENBO(T,OCC,ISCR,NELEC) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS) DIMENSION T(NDIM,NDIM),OCC(NDIM),ISCR(1) DATA ZERO,TENTH /0.0D0,1.0D-1/ FENBO: FETCHES NBO INFORMATION (TRANSFORMATION, OCCUPANCIES, LABELS, ETC.) IF ALPHA .EQ. .TRUE. FETCH THE ALPHA INFORMATION IF BETA .EQ. .TRUE. FETCH THE BETA INFORMATION. FETCH THE AO TO NBO TRANSFORMATION MATRIX: L1 = NDIM L3 = NDIM*NDIM L4 = NDIM*10 NFILE = 44 IF (BETA) NFILE = 45 CALL NBREAD(T,L3,NFILE) FETCH NBO ORBITAL OCCUPANCIES: NFILE = 27 IF (BETA) NFILE = 28 CALL NBREAD(OCC,L1,NFILE) COUNT UP THE TOTAL NUMBER OF ELECTRONS AS AN INTEGER NELEC: ELE = ZERO DO 10 I = 1,NBAS ELE = ELE + OCC(I) 10 CONTINUE ELE = ELE + TENTH NELEC = ELE FETCH THE VARIOUS LISTS OF NBO INFORMATION FOR USE IN THE DELETIONS. UNPACK THE INFORMATION INTO LABEL(MAXBAS,6),IBXM(MAXBAS),IATNO(MAXBAS), NBOUNI(MAXBAS) AND NBOTYP(MAXBAS) FROM ISCR(10*NDIM): NFILE = 60 IF (BETA) NFILE = 61 CALL NBREAD(ISCR,L4,NFILE) II = 0 DO 40 K = 1,6 DO 30 I = 1,NBAS II = II + 1 LABEL(I,K) = ISCR(II) 30 CONTINUE 40 CONTINUE DO 50 I = 1,NBAS II = II + 1 IBXM(I) = ISCR(II) 50 CONTINUE DO 60 I = 1,NATOMS II = II + 1 IATNO(I) = ISCR(II) 60 CONTINUE DO 70 I = 1,NBAS II = II + 1 NBOUNI(I) = ISCR(II) 70 CONTINUE DO 80 I = 1,NBAS II = II + 1 NBOTYP(I) = ISCR(II) 80 CONTINUE RETURN END ***************************************************************************** SUBROUTINE FETNBO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION T(1) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT FETNBO: FETCH THE AO TO NBO TRANSFORMATION MATRIX L3 = NDIM*NDIM NFILE = 44 IF (BETA) NFILE = 45 CALL NBREAD(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE SVPNAO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION T(1) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT SVPNAO: SAVES THE AO TO PNAO TRANSFORMATION MATRIX. NFILE = 42 L3 = NDIM*NDIM CALL NBWRIT(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE FEPNAO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION T(1) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT FEPNAO: FETCHES THE AO TO PNAO TRANSFORMATION MATRIX. NFILE = 42 L3 = NDIM*NDIM CALL NBREAD(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE SVSNAO(S) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION S(NDIM,NDIM) SVSNAO: SAVE THE OVERLAP MATRIX IN THE PNAO OR RPNAO BASIS SET. NFILE = 11 L2 = NDIM*(NDIM+1)/2 CALL PACK(S,NDIM,NBAS,L2) CALL NBWRIT(S,L2,NFILE) CALL UNPACK(S,NDIM,NBAS,L2) RETURN END ***************************************************************************** SUBROUTINE FESNAO(S) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION S(NDIM,NDIM) FESNAO: FETCH THE OVERLAP MATRIX IN THE PNAO OR RPNAO BASIS SET. NFILE = 11 L2 = NDIM*(NDIM+1)/2 CALL NBREAD(S,L2,NFILE) CALL UNPACK(S,NDIM,NBAS,L2) RETURN END ***************************************************************************** SUBROUTINE SVTNAB(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) SVTNAB: SAVE THE NAO TO NBO TRANSFORMATION MATRIX. NFILE = 48 L3 = NDIM*NDIM CALL NBWRIT(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE FETNAB(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) FETNAB: FETCH THE NAO TO NBO TRANSFORMATION MATRIX NFILE = 48 L3 = NDIM*NDIM CALL NBREAD(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE SVTLMO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) SVTLMO: SAVE THE NBO TO NLMO TRANSFORMATION MATRIX. NFILE = 49 L3 = NDIM*NDIM CALL NBWRIT(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE FETLMO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) FETLMO: FETCH THE NBO TO NLMO TRANSFORMATION MATRIX NFILE = 49 L3 = NDIM*NDIM CALL NBREAD(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE SVTNHO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) SVTNHO: TEMPORARILY SAVE THE NAO TO NHO TRANSFORMATION NFILE = 47 L3 = NDIM*NDIM CALL NBWRIT(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE FETNHO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) FETNHO: FETCH THE NAO TO NHO TRANSFORMATION NFILE = 47 L3 = NDIM*NDIM CALL NBREAD(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE SVPPAO(DM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION DM(NDIM,NDIM) SVPPAO: TEMPORARILY SAVES THE PURE AO (PAO) DENSITY MATRIX. (THIS IS NOT THE RAW AO BASIS, BUT THE BASIS AFTER THE TRANSFORMATION FROM CARTESIAN TO PURE D,F,G FUNCTIONS). NFILE = 22 L2 = NDIM*(NDIM+1)/2 CALL PACK(DM,NDIM,NBAS,L2) CALL NBWRIT(DM,L2,NFILE) CALL UNPACK(DM,NDIM,NBAS,L2) RETURN END ***************************************************************************** SUBROUTINE FEPPAO(DM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION DM(NDIM,NDIM) FEPPAO: FETCHES THE PURE AO (PAO) DENSITY MATRIX. (THIS IS NOT THE RAW AO BASIS, BUT THE BASIS AFTER THE TRANSFORMATION FROM CARTESIAN TO PURE D,F,G FUNCTIONS). NFILE = 22 L2 = NDIM*(NDIM+1)/2 CALL NBREAD(DM,L2,NFILE) CALL UNPACK(DM,NDIM,NBAS,L2) RETURN END ***************************************************************************** SUBROUTINE SVTNAO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) SVTNAO: SAVE THE AO TO NAO TRANSFORMATION MATRIX. IF(.NOT.ORTHO) THEN NFILE = 43 L3 = NDIM*NDIM CALL NBWRIT(T,L3,NFILE) END IF RETURN END ***************************************************************************** SUBROUTINE FETNAO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) DATA ZERO,ONE/0.0D0,1.0D0/ FETNAO: FETCHES THE AO TO NAO TRANSFORMATION MATRIX. IF(ORTHO) THEN DO 20 J = 1,NDIM DO 10 I = 1,NDIM T(I,J) = ZERO 10 CONTINUE T(J,J) = ONE 20 CONTINUE ELSE NFILE = 43 L3 = NDIM*NDIM CALL NBREAD(T,L3,NFILE) END IF RETURN END ***************************************************************************** SUBROUTINE SVNLMO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) SVNLMO: SAVE THE AO TO NLMO TRANSFORMATION MATRIX NFILE = 46 L3 = NDIM*NDIM CALL NBWRIT(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE FENLMO(T) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) FENLMO: FETCH THE AO TO NLMO TRANSFORMATION MATRIX NFILE = 46 L3 = NDIM*NDIM CALL NBREAD(T,L3,NFILE) RETURN END ***************************************************************************** SUBROUTINE SVDNAO(DM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION DM(NDIM,NDIM) SVDNAO: SAVE THE NAO DENSITY MATRIX IF(.NOT.ORTHO) THEN NFILE = 23 IF(BETA) NFILE = 24 L2 = NDIM*(NDIM+1)/2 CALL PACK(DM,NDIM,NBAS,L2) CALL NBWRIT(DM,L2,NFILE) CALL UNPACK(DM,NDIM,NBAS,L2) END IF RETURN END ***************************************************************************** SUBROUTINE FEDNAO(DM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION DM(NDIM,NDIM) FEDNAO: FETCHES THE NAO DENSITY MATRIX (AO DM FOR ORTHOGONAL BASIS SETS) IF(ORTHO) THEN CALL FEDRAW(DM,DM) ELSE NFILE = 23 IF(BETA) NFILE = 24 L2 = NDIM*(NDIM+1)/2 CALL NBREAD(DM,L2,NFILE) CALL UNPACK(DM,NDIM,NBAS,L2) END IF RETURN END ***************************************************************************** SUBROUTINE SVFNBO(F) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DIMENSION F(NDIM,NDIM) SVFNBO: SAVES THE NBO FOCK MATRIX NFILE = 34 IF (BETA) NFILE = 35 L2 = NDIM*(NDIM+1)/2 CALL PACK(F,NDIM,NBAS,L2) CALL NBWRIT(F,L2,NFILE) CALL UNPACK(F,NDIM,NBAS,L2) RETURN END ***************************************************************************** SUBROUTINE FEFNBO(F) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DIMENSION F(1) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT FEFNBO: FETCHES THE NBO FOCK MATRIX, LEAVING IT IN TRIANGULAR FORM!! IF ALPHA.EQ.TRUE. WE WANT THE ALPHA FOCK MATRIX IF BETA.EQ.TRUE. WE WANT THE BETA FOCK MATRIX. NFILE = 34 IF (BETA) NFILE = 35 L2 = NDIM*(NDIM+1)/2 CALL NBREAD(F,L2,NFILE) RETURN END ***************************************************************************** SUBROUTINE SVNEWD(DM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DIMENSION DM(1) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT SVNEWD: SAVE THE NEW DENSITY MATRIX (RAW AO BASIS) FROM NBO DELETION NFILE = 25 IF (BETA) NFILE = 26 L2 = NDIM*(NDIM+1)/2 CALL NBWRIT(DM,L2,NFILE) RETURN END ***************************************************************************** SUBROUTINE FENEWD(DM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DIMENSION DM(1) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT FENEWD: FETCH THE NEW DENSITY MATRIX (RAW AO BASIS) NFILE = 25 IF (BETA) NFILE = 26 L2 = NDIM*(NDIM+1)/2 CALL NBREAD(DM,L2,NFILE) RETURN END ***************************************************************************** SUBROUTINE FEINFO(ICORE,ISWEAN) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DIMENSION ICORE(12) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBBAS/LABEL(MAXBAS,6),LVAL(MAXBAS),IMVAL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF Restore wavefunction information from the NBO DAF: Restore NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: NFILE = 3 CALL NBREAD(ICORE,12,NFILE) NATOMS = ICORE(1) NDIM = ICORE(2) NBAS = ICORE(3) MUNIT = ICORE(4) ROHF = .FALSE. IF(ICORE(5).EQ.1) ROHF = .TRUE. UHF = .FALSE. IF(ICORE(6).EQ.1) UHF = .TRUE. CI = .FALSE. IF(ICORE(7).EQ.1) CI = .TRUE. OPEN = .FALSE. IF(ICORE(8).EQ.1) OPEN = .TRUE. MCSCF = .FALSE. IF(ICORE(9).EQ.1) MCSCF = .TRUE. AUHF = .FALSE. IF(ICORE(10).EQ.1) AUHF = .TRUE. ORTHO = .FALSE. IF(ICORE(11).EQ.1) ORTHO = .TRUE. ISWEAN = ICORE(12) IF ISWEAN IS 1, SET ICORE(12) TO 0 AND WRITE TO NBO DAF. NOTE, ISWEAN IS SET TO 1 BY THE FEAOIN DRIVER ROUTINE. THIS TELLS THE ENERGETIC ANALYSIS ROUTINES TO SEARCH FOR THE $DEL KEYLIST. ISWEAN IS RESET TO 0 HERE SO THAT MULTIPLE DELETIONS CAN BE READ FROM A SINGLE $DEL KEYLIST: IF(ISWEAN.EQ.1) THEN ICORE(12) = 0 CALL NBWRIT(ICORE,12,NFILE) END IF RETURN END ***************************************************************************** FREE FORMAT INPUT ROUTINES: SUBROUTINE STRTIN(LFNIN) SUBROUTINE RDCRD SUBROUTINE IFLD(INT,ERROR) SUBROUTINE RFLD(REAL,ERROR) SUBROUTINE HFLD(KEYWD,LENG,ENDD) SUBROUTINE FNDFLD FUNCTION EQUAL(IA,IB,L) ***************************************************************************** USER INSTRUCTIONS: 1. THE CHARACTER STRING "END" IS THE FIELD TERMINATING MARK: 2. COMMAS AND EQUAL SIGNS ARE TREATED AS EQUIVALENT TO BLANKS. COMMAS, EQUAL SIGNS, AND BLANKS DELIMIT INPUT ITEMS. 3. ALL CHARACTERS TO THE RIGHT OF AN EXCLAMATION MARK ! ARE TREATED AS COMMENTS, AND THE NEXT CARD IS READ IN WHEN THESE ARE ENCOUNTERED. 4. UPPER AND LOWER CASE CHARACTERS CAN BE READ BY THESE ROUTINES. HOWEVER, LOWER CASE CHARACTERS ARE CONVERTED TO UPPER CASE WHEN ENCOUNTERED. 5. TO READ IN DATA FOR THE FIRST TIME FROM LFN "LFNIN" (PERHAPS AFTER USING THESE SUBROUTINES TO READ IN DATA FROM ANOTHER LFN), OR TO CONTINUE READING IN DATA FROM LFNIN AFTER ENCOUNTERING A FIELD TERMINATING MARK, CALL STRTIN(LFNIN) (START INPUT) 6. TO FETCH THE NEXT NON-BLANK STRING OF CHARACTERS FROM LFN LFNIN, CALL HFLD(KEYWD,LENGTH,END), WHERE KEYWD IS A VECTOR OF DIMENSION "LENGTH" OR LONGER, LENGTH IS THE MAXIMUM NUMBER OF CHARACTERS TO FETCH, END MUST BE A DECLARED LOGICAL VARIABLE. UPON RETURN, END=.TRUE. IF A FIELD TERMINATING MARK WAS FOUND TO BE THE NEXT NON-BLANK CHARACTER STRING. OTHERWISE, END=.FALSE. END=.TRUE. AND LENGTH=0 MEANS THE END-OF-FILE WAS FOUND. LENGTH IS CHANGED TO THE ACTUAL NUMBER OF CHARACTERS IN STRING IF THIS IS LESS THAN THE VALUE OF LENGTH SET BY THE CALLING PROGRAM. KEYWD(1) THROUGH KEYWD(LENGTH) CONTAIN THE CHARACTER STRING, ONE CHARACTER PER ELEMENT OF KEYWD. 7. TO FETCH THE INTEGER VALUE OF THE NEXT CHARACTER STRING, CALL IFLD(INT,ERROR), WHERE INT IS THE VARIABLE TO BE READ, ERROR MUST BE A DECLARED LOGICAL VARIABLE. UPON RETURN, IF ERROR=.FALSE., AN INTEGER WAS FOUND AND PLACED IN "INT". IF ERROR=.TRUE. AND INT.GT.0, A FIELD TERMINATING MARK WAS FOUND AS THE NEXT CHARACTER STRING. IF ERROR=.TRUE. AND INT.LT.0, THE NEXT CHARACTER STRING FOUND WAS NEITHER AN INTEGER NOR A FIELD TERMINATING MARK. 8. TO FETCH THE REAL VALUE OF THE NEXT CHARACTER STRING, (AN EXPONENT IS ALLOWED, WITH OR WITHOUT AN "E" OR "F". IF NO LETTER IS PRESENT TO SIGNIFY THE EXPONENT FIELD, A + OR - SIGN MUST START THE EXPONENT. IF NO MANTISSA IS PRESENT, THE EXPONENT FIELD MUST START WITH A LETTER, AND THE MANTISSA IS SET TO ONE.) CALL RFLD(REAL,ERROR), WHERE REAL IS THE VARIABLE TO BE READ, ERROR MUST BE A DECLARED LOGICAL VARIABLE. UPON RETURN, IF ERROR=.FALSE., A REAL NUMBER WAS FOUND AND PLACED IN "REAL". IF ERROR=.TRUE. AND REAL.GT.1, A FIELD TERMINATING MARK WAS FOUND AS THE NEXT CHARACTER STRING. IF ERROR=.TRUE. AND REAL.LT.-1, THE NEXT CHARACTER STRING FOUND WAS NEITHER A REAL NUMBER NOR A FIELD TERMINATING MARK. 9. TO COMPARE THE CORRESPONDING FIRST L ELEMENTS OF EACH OF TWO VECTORS IA(L) AND IB(L) TO SEE IF THE VECTORS ARE EQUIVALENT, USE THE FUNCTION EQUAL(IA,IB,L). EQUAL MUST BE DECLARED LOGICAL IN THE CALLING PROGRAM, AND THE FUNCTION VALUE (.TRUE. OR .FALSE.) WILL TELL IF THE VECTORS IA AND IB ARE EQUAL UP TO ELEMENT L. NOTE: THIS FUNCTION IS USEFUL FOR DETERMINING IF A CHARACTER STRING READ BY A CALL TO HFLD MATCHES A CERTAIN KEYWORD WHICH IS STORED IN A VECTOR, ONE CHARACTER PER ELEMENT. ***************************************************************************** SUBROUTINE STRTIN(LFNIN) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP COMMON/NBCRD2/POINT,END,NEXT,EXP LOGICAL POINT,END,NEXT,EXP INITIALIZE INPUT FROM LFN LFNIN: LFN = LFNIN END = .FALSE. NEXT = .TRUE. CALL RDCRD RETURN END ***************************************************************************** SUBROUTINE RDCRD ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SUBROUTINE NAME CHANGED FROM RDCARD, DUE TO CONFLICT WITH GAMESS: COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP COMMON/NBCRD2/POINT,END,NEXT,EXP LOGICAL POINT,END,NEXT,EXP DATA IA,ICHARA,ICHARZ/1HA,1Ha,1Hz/ DATA IBLNK,IQ,II/1H ,1H`,1HI/ READ IN THE NEXT CARD AT LFN: READ(LFN,1000,END=800,ERR=800) ICD CHANGE ALL LOWER CASE CHARACTERS TO UPPER CASE: DO 10 I = 1,80 IF(ICD(I).GE.ICHARA.AND.ICD(I).LE.ICHARZ) THEN ICD(I) = ICD(I) - ICHARA + IA END IF 10 CONTINUE TREAT TABS AS SPACES: ITAB = IBLNK + II - IQ DO 20 I = 1,80 IF(ICD(I).EQ.ITAB) ICD(I) = IBLNK 20 CONTINUE RESET COLUMN POINTER, IPT: IPT = 1 RETURN END OF FILE ENCOUNTERED 800 CONTINUE END = .TRUE. RETURN 1000 FORMAT(80A1) END ***************************************************************************** SUBROUTINE IFLD(INT,ERROR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ERROR COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP COMMON/NBCRD2/POINT,END,NEXT,EXP LOGICAL POINT,END,NEXT,EXP DATA ZERO,ONE,SMALL/0.0D0,1.0D0,1.0D-3/ SEARCH LFN FOR THE NEXT STRING OF NON-BLANK CHARACTERS, SEE IF THEY FORM AN INTEGER (IF NOT, ERROR=.TRUE.) AND, IF SO, PLACE ITS NUMERICAL VALUE IN "INT": INT = 0 CALL RFLD(REAL,ERROR) IF DECIMAL POINT OR AN EXPONENT.LT.0, ERROR = .TRUE.: IF(EXP) GO TO 100 IF(POINT) GO TO 100 IF(NEXP.LT.0) GO TO 100 IF(LENGTH.EQ.0) GO TO 100 SIGN = ONE IF(REAL.LT.ZERO) SIGN = -ONE REAL = REAL + SMALL * SIGN INT = REAL RETURN 100 ERROR = .TRUE. NEXT = .FALSE. RETURN END ***************************************************************************** SUBROUTINE RFLD(REAL,ERROR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ERROR,EXPSGN,MANTIS COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP COMMON/NBCRD2/POINT,END,NEXT,EXP LOGICAL POINT,END,NEXT,EXP DIMENSION NCHAR(15) DATA NCHAR/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H.,1H+,1H-, + 1HD,1HE/ DATA ZERO,ONE,TEN/0.0D0,1.0D0,10.0D0/ SEARCH LFN FOR THE NEXT STRING OF NON-BLANK CHARACTERS, SEE IF THEY FORM A REAL NUMBER (EXPONENT IS OPTIONAL) (IF NOT, ERROR=.TRUE.) AND, IF SO, PLACE ITS NUMERICAL VALUE IN "REAL": REAL = ZERO SIGN = ONE NDEC = 0 ISEXP = 1 NEXP = 0 EXPSGN = .FALSE. EXP = .FALSE. POINT = .FALSE. ERROR = .FALSE. MANTIS = .FALSE. END = .FALSE. FIND THE NEXT STRING OF NON-BLANK CHARACTERS, "LOOK", OF LENGTH "LENGTH": IF(NEXT) CALL FNDFLD IF(END) GO TO 300 IF(LENGTH.EQ.0) GO TO 300 FIND THE NUMERICAL VALUE OF THE CHARACTERS IN "LOOK": DO 200 J = 1,LENGTH LK = LOOK(J) DO 20 I = 1,15 IF(LK.EQ.NCHAR(I)) GO TO 40 20 CONTINUE GO TO 300 40 K = I - 11 IF(K) 60,80,100 THIS CHARACTER IS A NUMBER: 60 CONTINUE IF(EXP) GO TO 70 ADD DIGIT TO MANTISSA: MANTIS = .TRUE. REAL = REAL * TEN + FLOAT(I - 1) IF WE ARE TO THE RIGHT OF A DECIMAL POINT, INCREMENT THE DECIMAL COUNTER: IF(POINT) NDEC = NDEC + 1 GO TO 200 ADD DIGIT TO EXPONENT: 70 NEXP = NEXP * 10 + (I - 1) GO TO 200 DECIMAL POINT: 80 IF(POINT) GO TO 300 POINT = .TRUE. GO TO 200 EXPONENT (+,-,D,E): 100 CONTINUE GO TO (110,130,150,150), K PLUS SIGN: IF NOT FIRST CHARACTER, COUNT AS PART OF EXPONENT: 110 IF(J.EQ.1) GO TO 200 IF(EXPSGN) GO TO 200 EXPSGN = .TRUE. EXP = .TRUE. GO TO 200 MINUS SIGN: IF NOT FIRST CHARACTER, COUNT AS PART OF EXPONENT: 130 IF(J.NE.1) GO TO 140 SIGN = -ONE GO TO 200 140 ISEXP = -1 IF(EXPSGN) GO TO 200 EXPSGN = .TRUE. EXP = .TRUE. GO TO 200 D OR E: START OF EXPONENT: 150 IF(EXP) GO TO 300 EXP = .TRUE. 200 CONTINUE SET FINAL VALUE OF REAL (IF NO MANTISSA, BUT EXPONENT PRESENT, SET MANTISSA TO ONE): IF(EXP.AND..NOT.MANTIS) REAL = ONE REAL = REAL * SIGN * (TEN**(-NDEC+ISEXP*NEXP)) NEXT = .TRUE. RETURN NO REAL NUMBER FOUND, OR FIELD TERMINATING MARK: 300 CONTINUE ERROR = .TRUE. REAL = -TEN IF(END) REAL = TEN RETURN END ***************************************************************************** SUBROUTINE HFLD(KEYWD,LENG,ENDD) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ENDD,EQUAL COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP COMMON/NBCRD2/POINT,END,NEXT,EXP LOGICAL POINT,END,NEXT,EXP DIMENSION KEYWD(LENG),KEND(3) DATA NBLA/1H / DATA KEND/1HE,1HN,1HD/ SEARCH LFN AND FIND NEXT NON-BLANK STRING OF CHARACTERS AND PLACE IN THE VECTOR "KEYWD". LENG, FROM THE CALLING PROGRAM, IS MAXIMUM LENGTH OF STRING TO PUT IN THE VECTOR KEYWD. IF "LENGTH" IS LESS THAN "LENG", LENG IS SET TO LENGTH UPON RETURN: IF(NEXT) CALL FNDFLD ENDD = END LENG1 = LENG LENG = MIN0(LENGTH,LENG) PLACE LENG CHARACTERS INTO KEYWD: DO 10 I = 1,LENG KEYWD(I) = LOOK(I) 10 CONTINUE FILL THE REST OF KEYWD WITH BLANKS: DO 20 I = LENG+1,LENG1 KEYWD(I) = NBLA 20 CONTINUE NEXT = .TRUE. CHECK FOR END OF INPUT: IF(EQUAL(LOOK,KEND,3)) ENDD = .TRUE. RETURN END ***************************************************************************** SUBROUTINE FNDFLD ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP COMMON/NBCRD2/POINT,END,NEXT,EXP LOGICAL POINT,END,NEXT,EXP DATA NBLA/1H /,NCOM/1H,/,NEXC/1H!/,NEQ/1H=/ FIND NEXT NON-BLANK STRING OF CHARACTERS IN LFN. READ IN ANOTHER LINE OF LFN UNTIL NON-BLANK CHARACTERS ARE FOUND AND PLACE THEM IN "LOOK", OF LENGTH "LENGTH": IF(END) GO TO 35 IF(IPT.GE.80) CALL RDCRD IF(END) GO TO 35 LOOK FOR START OF FIELD. SKIP TO NEXT CARD IF "!" IS ENCOUNTERED (COMMENT FIELD): 10 CONTINUE DO 20 NCOL = IPT,80 ICARD = ICD(NCOL) IF(ICARD.EQ.NEXC) GO TO 30 IF(ICARD.NE.NBLA.AND.ICARD.NE.NCOM.AND.ICARD.NE.NEQ) GO TO 40 20 CONTINUE NOTHING ADDITIONAL FOUND ON THIS CARD, CONTINUE WITH THE NEXT CARD: 30 CALL RDCRD IF(.NOT.END) GO TO 10 END OF FILE FOUND: 35 LENGTH = 0 RETURN LOOK FOR THE END OF THIS FIELD, COUNTING CHARACTERS AS WE GO AND STORING THESE CHARACTER IN LOOK: 40 M = 0 DO 80 MCOL = NCOL,80 ICHAR = ICD(MCOL) IF(ICHAR.EQ.NBLA.OR.ICHAR.EQ.NCOM.OR.ICHAR.EQ.NEQ) GO TO 100 M = M + 1 LOOK(M) = ICHAR 80 CONTINUE SET LENGTH TO THE LENGTH OF THE NEW STRING IN LOOK AND RESET IPT TO THE NEXT SPACE AFTER THIS STRING: 100 LENGTH = M IPT = MCOL NEXT = .FALSE. RETURN END ***************************************************************************** FUNCTION EQUAL(IA,IB,L) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL EQUAL DIMENSION IA(L),IB(L) TEST IF THE FIRST L ELEMENTS OF VECTORS IA AND IB ARE EQUAL: EQUAL = .FALSE. DO 10 I = 1,L IF(IA(I).NE.IB(I)) GO TO 20 10 CONTINUE EQUAL = .TRUE. 20 RETURN END ***************************************************************************** OTHER SYSTEM-INDEPENDENT I/O ROUTINES: SUBROUTINE GENINP(NEWDAF) SUBROUTINE NBOINP(NBOOPT,IDONE) SUBROUTINE CORINP(IESS,ICOR) SUBROUTINE CHSINP(IESS,ICHS) SUBROUTINE DELINP(NBOOPT,IDONE) SUBROUTINE RDCORE(JCORE) SUBROUTINE WRPPNA(T,OCC,IFLG) SUBROUTINE RDPPNA(T,OCC,IFLG) SUBROUTINE WRTNAO(T,IFLG) SUBROUTINE RDTNAO(DM,T,SCR,IFLG) SUBROUTINE WRTNAB(T,IFLG) SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG) SUBROUTINE WRTNBO(T,BNDOCC,IFLG) SUBROUTINE WRNLMO(T,DM,IFLG) SUBROUTINE WRBAS(SCR,ISCR,LFN) SUBROUTINE WRARC(SCR,ISCR,LFN) SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG) SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL) SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN) SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR) SUBROUTINE ALTOUT(A,MR,MC,NR,NC) SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR) FUNCTION IOINQR(IFLG) SUBROUTINE LBLAO SUBROUTINE LBLNAO SUBROUTINE LBLNBO SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR) ***************************************************************************** SUBROUTINE GENINP(NEWDAF) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL NEWDAF,END,ERROR,EQUAL DIMENSION KEYWD(6),KGEN(4),KEND(4),KREUSE(5),KNBAS(4),KNATOM(6), + KUPPER(5),KOPEN(4),KORTHO(5),KBOHR(4),KBODM(4),KEV(2), + KCUBF(6) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBGEN/REUSE,UPPER,BOHR,DENOP LOGICAL REUSE,UPPER,BOHR,DENOP DATA KGEN/1H$,1HG,1HE,1HN/,KEND/1H$,1HE,1HN,1HD/, + KREUSE/1HR,1HE,1HU,1HS,1HE/,KNBAS/1HN,1HB,1HA,1HS/, + KNATOM/1HN,1HA,1HT,1HO,1HM,1HS/,KUPPER/1HU,1HP,1HP,1HE,1HR/, + KOPEN/1HO,1HP,1HE,1HN/,KORTHO/1HO,1HR,1HT,1HH,1HO/, + KBOHR/1HB,1HO,1HH,1HR/,KBODM/1HB,1HO,1HD,1HM/, + KEV/1HE,1HV/KCUBF/1HC,1HU,1HB,1HI,1HC,1HF/ Initialize variables: NBAS = 0 NATOMS = 0 MUNIT = 0 REUSE = .FALSE. UPPER = .FALSE. BOHR = .FALSE. DENOP = .TRUE. Search LFNIN for $GEN: REWIND(LFNIN) 10 CALL STRTIN(LFNIN) LEN = 6 CALL HFLD(KEYWD,LEN,END) IF(LEN.EQ.0.AND.END) STOP 'No $GEN keylist in the input file' IF(.NOT.EQUAL(KEYWD,KGEN,4)) GOTO 10 $GEN has been found, now read keywords: 20 LEN = 6 CALL HFLD(KEYWD,LEN,END) IF(EQUAL(KEYWD,KEND,4)) GOTO 700 Keyword REUSE -- reuse data already stored on the NBO DAF: IF(EQUAL(KEYWD,KREUSE,5)) THEN REUSE = .TRUE. GOTO 20 END IF Keyword NBAS -- Specify the number of basis functions: IF(EQUAL(KEYWD,KNBAS,4)) THEN CALL IFLD(NBAS,ERROR) IF(ERROR) STOP 'Error reading in number of basis functions NBAS' GOTO 20 END IF Keyword NATOMS -- Specify the number of atoms: IF(EQUAL(KEYWD,KNATOM,4)) THEN CALL IFLD(NATOMS,ERROR) IF(ERROR) STOP 'Error reading in number of atoms NATOMS' GOTO 20 END IF Keyword UPPER -- Read only upper triangular portions of matrices: IF(EQUAL(KEYWD,KUPPER,5)) THEN UPPER = .TRUE. GOTO 20 END IF Keyword OPEN -- Open shell species (alpha and beta matrices read): IF(EQUAL(KEYWD,KOPEN,4)) THEN OPEN = .TRUE. GOTO 20 END IF Keyword ORTHO -- Orthogonal basis set (Skip NAO analysis): IF(EQUAL(KEYWD,KORTHO,5)) THEN ORTHO = .TRUE. GOTO 20 END IF Keyword BOHR -- Atomic coordinates, dipole integrals in bohr: IF(EQUAL(KEYWD,KBOHR,4)) THEN BOHR = .TRUE. GOTO 20 END IF Keyword BODM -- Input bond order matrix: IF(EQUAL(KEYWD,KBODM,4)) THEN DENOP = .FALSE. GOTO 20 END IF Keyword EV -- Expectation values of the Fock operator are in eV: IF(EQUAL(KEYWD,KEV,2)) THEN MUNIT = 1 GOTO 20 END IF Keyword CUBICF -- Use set of cubic f functions: IF(EQUAL(KEYWD,KCUBF,6)) THEN IWCUBF = 1 GOTO 20 END IF Unknown keyword -- halt program: WRITE(LFNPR,900) KEYWD STOP End of $GEN input encountered, make sure GENNBO has all info needed: 700 CONTINUE IF(REUSE) THEN NEWDAF = .FALSE. RETURN ELSE NEWDAF = .TRUE. ENDIF NDIM = NBAS IF(NBAS.LE.0) STOP 'NBAS must be specified in $GEN keylist' IF(NBAS.GT.MAXBAS) STOP 'Increase parameter MAXBAS' IF(NATOMS.LE.0) STOP 'NATOMS must be specified in $GEN keylist' IF(NATOMS.GT.MAXATM) STOP 'Increase parameter MAXATM' RETURN 900 FORMAT(1X,'Unrecognized keyword >',6A1,'<') END ***************************************************************************** SUBROUTINE NBOINP(NBOOPT,IDONE) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL END,EQUAL DIMENSION NBOOPT(10) DIMENSION KEYWD(6),KNBO(4) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA KNBO/1H$,1HN,1HB,1HO/ If NBOOPT(1) = 1, don't search for keywords, just continue with default options: IF(NBOOPT(1).EQ.1) THEN IDONE = 0 RETURN END IF If this is the GAMESS, HONDO, or general version of the NBO program, rewind the input file before searching for $NBO: IREP = 1 IF(NBOOPT(10).EQ.0) IREP = 0 IF(NBOOPT(10).EQ.6) IREP = 0 IF(NBOOPT(10).EQ.7) IREP = 0 IF(IREP.EQ.0) REWIND(LFNIN) Search input file for $NBO: 10 CALL STRTIN(LFNIN) LEN = 6 CALL HFLD(KEYWD,LEN,END) IF(EQUAL(KEYWD,KNBO,4)) GOTO 50 IF(LEN.EQ.0.AND.END) GOTO 60 GOTO 10 $NBO found -- continue with the NBO analysis: 50 CONTINUE IDONE = 0 RETURN End of file encountered -- Stop NBO analysis, except for the general version of the program (set NBOOPT(1) so keywords are not read): 60 CONTINUE IF(IREP.EQ.1) THEN REWIND(LFNIN) IREP = IREP + 1 GOTO 10 ELSE IF(NBOOPT(10).EQ.0) THEN NBOOPT(1) = 1 IDONE = 0 ELSE IDONE = 1 END IF RETURN END ***************************************************************************** SUBROUTINE CORINP(IESS,ICOR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL END,EQUAL COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION KEYWD(6),KCOR(4),KCHS(4),KDEL(4),KNBO(4),KNRT(4) DATA KCOR/1H$,1HC,1HO,1HR/,KCHS/1H$,1HC,1HH,1HO/, + KDEL/1H$,1HD,1HE,1HL/,KNBO/1H$,1HN,1HB,1HO/, + KNRT/1H$,1HN,1HR,1HT/ If ICOR is set to -1, do not read in the $CORE keylist: IF(ICOR.EQ.-1) RETURN If this is the GAMESS, HONDO, or general version of the NBO program, rewind the input file before searching for $CORE: IREP = 1 IF(IESS.EQ.0) IREP = 0 IF(IESS.EQ.6) IREP = 0 IF(IESS.EQ.7) IREP = 0 IF(IREP.EQ.0) REWIND(LFNIN) Search input file for $CORE: 10 CALL STRTIN(LFNIN) LEN = 6 CALL HFLD(KEYWD,LEN,END) IF(EQUAL(KEYWD,KCOR,4)) GOTO 50 IF(EQUAL(KEYWD,KNBO,4)) GOTO 60 IF(EQUAL(KEYWD,KCHS,4)) GOTO 60 IF(EQUAL(KEYWD,KDEL,4)) GOTO 60 IF(EQUAL(KEYWD,KNRT,4)) GOTO 60 IF(LEN.EQ.0.AND.END) GOTO 70 GOTO 10 $CORE found: 50 CONTINUE ICOR = 1 RETURN $NBO, $CHOOSE, $DEL -- discontinue the search for $CORE (GAUSSIAN, AMPAC) or $NRT continue searching for $CORE (GENNBO, GAMESS, HONDO) 60 CONTINUE IF(IREP.EQ.0) GOTO 10 BACKSPACE(LFNIN) ICOR = 0 RETURN End of file encountered: 70 CONTINUE ICOR = 0 RETURN END ***************************************************************************** SUBROUTINE CHSINP(IESS,ICHS) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL END,EQUAL COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION KEYWD(6),KCHS(4),KDEL(4),KNBO(4),KNRT(4) DATA KCHS/1H$,1HC,1HH,1HO/,KDEL/1H$,1HD,1HE,1HL/, + KNBO/1H$,1HN,1HB,1HO/,KNRT/1H$,1HN,1HR,1HT/ If ICHS is set to -1, do not search for the $CHOOSE keylist: IF(ICHS.EQ.-1) RETURN If this is the GAMESS, HONDO, or general version of the NBO program, rewind the input file before searching for $CHOOSE: IREP = 1 IF(IESS.EQ.0) IREP = 0 IF(IESS.EQ.6) IREP = 0 IF(IESS.EQ.7) IREP = 0 IF(IREP.EQ.0) REWIND(LFNIN) Search input file for $CHOOSE: 10 CALL STRTIN(LFNIN) LEN = 6 CALL HFLD(KEYWD,LEN,END) IF(EQUAL(KEYWD,KCHS,4)) GOTO 50 IF(EQUAL(KEYWD,KNBO,4)) GOTO 60 IF(EQUAL(KEYWD,KDEL,4)) GOTO 60 IF(EQUAL(KEYWD,KNRT,4)) GOTO 60 IF(LEN.EQ.0.AND.END) GOTO 70 GOTO 10 $CHOOSE found: 50 CONTINUE ICHS = 1 RETURN $NBO, $DEL found -- discontinue the search for $CHOOSE (GAUSSIAN, AMPAC) or $NRT continue searching for $CHOOSE (GENNBO, GAMESS, HONDO) 60 CONTINUE IF(IREP.EQ.0) GOTO 10 BACKSPACE(LFNIN) ICHS = 0 RETURN End of file encountered: 70 CONTINUE ICHS = 0 RETURN END ***************************************************************************** SUBROUTINE DELINP(NBOOPT,IDONE) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL END,EQUAL DIMENSION NBOOPT(10) DIMENSION KEYWD(6),KDEL(4),KNBO(4) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA KDEL/1H$,1HD,1HE,1HL/,KNBO/1H$,1HN,1HB,1HO/ If this is the GAMESS, HONDO, or general version of the NBO program, rewind the input file before searching for $DEL: IREP = 1 IF(NBOOPT(10).EQ.0) IREP = 0 IF(NBOOPT(10).EQ.6) IREP = 0 IF(NBOOPT(10).EQ.7) IREP = 0 IF(IREP.EQ.0) REWIND(LFNIN) Search input file for $DEL: 10 CALL STRTIN(LFNIN) LEN = 6 CALL HFLD(KEYWD,LEN,END) IF(EQUAL(KEYWD,KDEL,4)) GOTO 50 IF(EQUAL(KEYWD,KNBO,4)) GOTO 60 IF(LEN.EQ.0.AND.END) GOTO 70 GOTO 10 $DEL found -- continue with the NBO energetic analysis: 50 CONTINUE IDONE = 0 RETURN $NBO found -- discontinue the search for $DEL (GAUSSIAN, AMPAC) continue searching for $DEL (GENNBO, GAMESS, HONDO) 60 CONTINUE IF(IREP.EQ.0) GOTO 10 BACKSPACE(LFNIN) IDONE = 1 RETURN End of file encountered -- Stop NBO energetic analysis 70 CONTINUE IF(IREP.EQ.1) THEN REWIND(LFNIN) IREP = IREP + 1 GOTO 10 ELSE IDONE = 1 END IF RETURN END ***************************************************************************** SUBROUTINE RDCORE(JCORE) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL ERROR PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF Initialize the atomic core array: DO 10 I = 1,NATOMS IATCR(I) = -1 10 CONTINUE Read in modifications to the nominal core table: IF(JCORE.EQ.1) THEN WRITE(LFNPR,900) 30 CALL IFLD(II,ERROR) IF(ERROR) GOTO 40 IF(II.LT.1.OR.II.GT.NATOMS) GOTO 810 CALL IFLD(JJ,ERROR) IF(ERROR) GOTO 820 IF(JJ.LT.0) GOTO 830 IATCR(II) = JJ GOTO 30 END IF 40 CONTINUE RETURN 810 WRITE(LFNPR,910) II STOP 820 WRITE(LFNPR,920) II STOP 830 WRITE(LFNPR,930) JJ,II STOP 900 FORMAT(/1X,'Modified core list read from the $CORE keylist') 910 FORMAT(/1X,'ATOM ',I4,' not found on this molecule') 920 FORMAT(/1X,'No core orbitals selected for atom ',I4) 930 FORMAT(/1X,I4,' core orbitals on atom ',I4,' does not make sense') END ***************************************************************************** SUBROUTINE WRPPNA(T,OCC,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) DIMENSION T(NDIM,NDIM),OCC(NDIM) CHARACTER*80 TITLE Write the PNAO information to the external file ABS(IFLG): NOTE: This is the pure-AO to PNAO transformation, not the raw AO to PNAO transform. TITLE = 'PNAOs in the PAO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,-1,IFLG) Write the NAO orbital labels to the external file: LFN = ABS(IFLG) WRITE(LFN,900) (NAOCTR(J),J=1,NBAS) WRITE(LFN,900) (NAOL(J),J=1,NBAS) WRITE(LFN,900) (LSTOCC(J),J=1,NBAS) Write the PNAO orbital occupancies: WRITE(LFN,910) (OCC(J),J=1,NBAS) RETURN 900 FORMAT(1X,20I4) 910 FORMAT(1X,5F15.9) END ***************************************************************************** SUBROUTINE RDPPNA(T,OCC,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),OCC(NDIM) DIMENSION JOB(20) LOGICAL ERROR Read the PNAO information from the external file ABS(IFLG/1000) NOTE: This is the pure-AO to PNAO transformation, not the raw AO to PNAO transform. LFN = ABS(IFLG/1000) WRITE(LFNPR,900) IF(ISPIN.GE.0) REWIND(LFN) CALL AREAD(T,NDIM,NBAS,NBAS,JOB,LFN,ERROR) IF(ERROR) GOTO 800 IF(ISPIN.GE.0) WRITE(LFNPR,910) JOB IF(ISPIN.LT.0) WRITE(LFNPR,920) Read in orbital labels from LFN: READ(LFN,1000,END=810) (NAOCTR(J),J=1,NBAS) READ(LFN,1000,END=810) (NAOL(J),J=1,NBAS) READ(LFN,1000,END=810) (LSTOCC(J),J=1,NBAS) Read orbital occupancies: READ(LFN,1010,END=820) (OCC(J),J=1,NBAS) RETURN 800 WRITE(LFNPR,950) LFN STOP 810 WRITE(LFNPR,960) LFN STOP 820 WRITE(LFNPR,970) LFN STOP 900 FORMAT(/1X,'PNAO basis set from a previous calculation used:') 910 FORMAT(1X,20A4) 920 FORMAT(/1X,'See alpha NBO output for title of the transformation') 950 FORMAT(/1X,'Error reading PAO to PNAO transformation from LFN',I3) 960 FORMAT(/1X,'Error reading PNAO orbital labels from LFN',I3) 970 FORMAT(/1X,'Error reading PNAO orbital occupancies from LFN',I3) 1000 FORMAT(1X,20I4) 1010 FORMAT(1X,5F15.9) END ***************************************************************************** SUBROUTINE WRTNAO(T,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DIMENSION T(NDIM,NDIM) CHARACTER*80 TITLE NOTE: T is the PNAO overlap matrix on return to the calling routine Fetch the AO to NAO transformation from the NBO DAF, and write it to the external file ABS(IFLG): CALL FETNAO(T) TITLE = 'NAOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG) Write the NAO orbital labels to the external file: LFN = ABS(IFLG) WRITE(LFN,900) (NAOCTR(J),J=1,NBAS) WRITE(LFN,900) (NAOL(J),J=1,NBAS) WRITE(LFN,900) (LSTOCC(J),J=1,NBAS) Fetch the PNAO overlap matrix from the NBO DAF, and store only the upper triangular portion on the external file: CALL FESNAO(T) TITLE = 'PNAO overlap matrix:' CALL AOUT(T,NDIM,-NBAS,NBAS,TITLE,2,IFLG) RETURN 900 FORMAT(1X,20I4) END ***************************************************************************** SUBROUTINE RDTNAO(DM,T,SCR,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),SCR(NDIM) DIMENSION JOB(20) LOGICAL ERROR NOTE: T is the PNAO overlap matrix on return to the calling routine DM is the NAO density matrix on return Read in AO to NAO transformation from the external file ABS(IFLG/1000), and store it on the NBO DAF: LFN = ABS(IFLG/1000) WRITE(LFNPR,900) REWIND(LFN) CALL AREAD(T,NDIM,NBAS,NBAS,JOB,LFN,ERROR) IF(ERROR) GOTO 800 WRITE(LFNPR,910) JOB CALL SVTNAO(T) Transform the AO density matrix, presently in DM, to the NAO basis: CALL SIMTRS(DM,T,SCR,NDIM,NBAS) Read in orbital labels from LFN: READ(LFN,1000,END=810) (NAOCTR(J),J=1,NBAS) READ(LFN,1000,END=810) (NAOL(J),J=1,NBAS) READ(LFN,1000,END=810) (LSTOCC(J),J=1,NBAS) Read the PNAO overlap from LFN, and save this matrix on the NBO DAF: CALL AREAD(T,NDIM,-NBAS,NBAS,JOB,LFN,ERROR) IF(ERROR) GOTO 820 CALL SVSNAO(T) RETURN 800 WRITE(LFNPR,950) LFN STOP 810 WRITE(LFNPR,960) LFN STOP 820 WRITE(LFNPR,970) LFN STOP 900 FORMAT(/1X,'NAO basis set from a previous calculation used:') 910 FORMAT(1X,20A4) 950 FORMAT(/1X,'Error reading AO to NAO transformation from LFN',I3) 960 FORMAT(/1X,'Error reading NAO orbital labels from LFN',I3) 970 FORMAT(/1X,'Error reading PNAO overlap matrix from LFN',I3) 1000 FORMAT(1X,20I4) END ***************************************************************************** SUBROUTINE WRTNAB(T,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) DIMENSION T(NDIM,NDIM) CHARACTER*80 TITLE Write the NAO to NBO transformation and NBO info to external file ABS(IFLG): TITLE = 'NBOs in the NAO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,2,IFLG) Write the NBO labels: LFN = ABS(IFLG) DO 10 I = 1,NBAS WRITE(LFN,900) (LABEL(I,J),J=1,6),IBXM(I) 10 CONTINUE RETURN 900 FORMAT(1X,A2,A1,4I3,3X,I3) END ***************************************************************************** SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),BNDOCC(NDIM),SCR(NDIM) DIMENSION JOB(20) LOGICAL ERROR Read the NAO to NBO transformation matrix from the external file ABS(IFLG/1000). Also read the NBO labels, the NBO occupancies, and transform the input NAO density matrix to the NBO basis: LFN = ABS(IFLG/1000) WRITE(LFNPR,900) IF(ISPIN.GE.0) REWIND(LFN) CALL AREAD(T,NDIM,NBAS,NBAS,JOB,LFN,ERROR) IF(ERROR) GOTO 800 IF(ISPIN.GE.0) WRITE(LFNPR,910) JOB IF(ISPIN.LT.0) WRITE(LFNPR,920) Read the NBO labels: DO 10 I = 1,NBAS READ(LFN,1000,END=810) (LABEL(I,J),J=1,6),IBXM(I) 10 CONTINUE Transform the NAO density matrix, DM, to the NBO basis, and store the NBO occupancies in BNDOCC: CALL SIMTRS(DM,T,SCR,NDIM,NBAS) DO 20 I = 1,NBAS BNDOCC(I) = DM(I,I) 20 CONTINUE RETURN 800 WRITE(LFNPR,950) LFN STOP 810 WRITE(LFNPR,960) LFN STOP 900 FORMAT(/1X,'NAO to NBO transformation from a previous ', + 'calculation will be used:') 910 FORMAT(1X,20A4) 920 FORMAT(/1X,'See alpha NBO output for title of the transformation') 950 FORMAT(/1X,'Error reading NAO to NBO transformation from LFN',I3) 960 FORMAT(/1X,'Error reading NBO orbital labels from LFN',I3) 1000 FORMAT(1X,A2,A1,4I3,3X,I3) END ***************************************************************************** SUBROUTINE WRTNBO(T,BNDOCC,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),BNDOCC(1) CHARACTER*80 TITLE Write the AO to NBO transformation matrix and NBO info to the external file ABS(IFLG): TITLE = 'NBOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG) Write out the NBO occupancies: LFN = ABS(IFLG) WRITE(LFN,900) (BNDOCC(J),J=1,NBAS) Write out NBOUNI, NBOTYP, LABEL, IBXM, and IATNO: WRITE(LFN,910) (NBOUNI(J),J=1,NBAS) WRITE(LFN,910) (NBOTYP(J),J=1,NBAS) WRITE(LFN,920) (LABEL(J,1),J=1,NBAS) WRITE(LFN,920) (LABEL(J,2),J=1,NBAS) WRITE(LFN,910) (LABEL(J,3),J=1,NBAS) WRITE(LFN,910) (LABEL(J,4),J=1,NBAS) WRITE(LFN,910) (LABEL(J,5),J=1,NBAS) WRITE(LFN,910) (LABEL(J,6),J=1,NBAS) WRITE(LFN,910) (IBXM(J),J=1,NBAS) WRITE(LFN,910) (IATNO(J),J=1,NATOMS) RETURN 900 FORMAT(1X,5F15.9) 910 FORMAT(1X,20I3) 920 FORMAT(1X,20A3) END ***************************************************************************** SUBROUTINE WRNLMO(T,DM,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM) CHARACTER*80 TITLE Write the AO to NLMO transformation matrix and NLMO info to the external file ABS(IFLG): TITLE = 'NLMOs in the AO basis:' CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG) Write out the NLMO occupancies: LFN = ABS(IFLG) WRITE(LFN,900) (DM(J,J),J=1,NBAS) Write out NBOUNI, NBOTYP, LABEL, IBXM, and IATNO: WRITE(LFN,910) (NBOUNI(J),J=1,NBAS) WRITE(LFN,910) (NBOTYP(J),J=1,NBAS) WRITE(LFN,920) (LABEL(J,1),J=1,NBAS) WRITE(LFN,920) (LABEL(J,2),J=1,NBAS) WRITE(LFN,910) (LABEL(J,3),J=1,NBAS) WRITE(LFN,910) (LABEL(J,4),J=1,NBAS) WRITE(LFN,910) (LABEL(J,5),J=1,NBAS) WRITE(LFN,910) (LABEL(J,6),J=1,NBAS) WRITE(LFN,910) (IBXM(J),J=1,NBAS) WRITE(LFN,910) (IATNO(J),J=1,NATOMS) RETURN 900 FORMAT(1X,5F15.9) 910 FORMAT(1X,20I3) 920 FORMAT(1X,20A3) END ***************************************************************************** SUBROUTINE WRBAS(SCR,ISCR,LFN) ***************************************************************************** Save the AO basis set information on an external file: ----------------------------------------------------------------------------- IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION SCR(1),ISCR(1) Fetch the number of shells NSHELL, the number of exponents NEXP, the NCOMP, NPRIM, and NPTR arrays, and the orbital exponents and coefficients from the NBO DAF: CALL FEBAS(NSHELL,NEXP,ISCR) If NSHELL is zero, then no basis set info has been stored in the DAF: IF(NSHELL.EQ.0) THEN WRITE(LFNPR,900) RETURN END IF Partition the scratch arrays: (Note that SCR and ISCR occupy the same space in memory) ISCR: (integer) NSHELL NEXP NCOMP NPRIM NPTR +------+------+-------+-------+-------+----------------------------------- I1 I2 I3 SCR: (real) ATCOOR EXP CS CP CD CF TITLE ---------------------------------------+-----+----+----+----+----+-------- I4 I5 I6 I7 I8 I9 ISCR(I1) : NCOMP(1..NSHELL) ISCR(I2) : NPRIM(1..NSHELL) ISCR(I3) : NPTR(1..NSHELL) SCR(I4) : EXP(1..NEXP) SCR(I5) : CS(1..NEXP) SCR(I6) : CP(1..NEXP) SCR(I7) : CD(1..NEXP) SCR(I8) : CF(1..NEXP) SCR(I9) : TITLE(10) or ATCOOR(3*NATOMS) I1 = 3 I2 = I1 + NSHELL I3 = I2 + NSHELL I4 = I3 + NSHELL I5 = I4 + NEXP I6 = I5 + NEXP I7 = I6 + NEXP I8 = I7 + NEXP I9 = I8 + NEXP IEND = I9 + MAX0(3*NATOMS,10) Fetch job title and write it to the AOINFO external file: CALL FETITL(SCR(I9)) Begin writing to the AOINFO external file: WRITE(LFN,910) (SCR(I9+I),I=0,9) WRITE(LFN,920) NATOMS,NSHELL,NEXP Fetch the atomic coordinates: CALL FECOOR(SCR(I9)) Write atomic numbers and coordinates to external file: J = 0 DO 10 I = 1,NATOMS WRITE(LFN,930) IATNO(I),(SCR(I9+J+K),K=0,2) J = J + 3 10 CONTINUE WRITE(LFN,940) Write out information about each shell in the basis set: NCTR(I) -- atomic center of the Ith shell NCOMP(I) -- number of components in the Ith shell NPTR(I) -- pointer for the Ith shell into the primitive parameters of EXP, CS, CP, CD, and CF NPRIM(I) -- number of primitive functions in the Ith shell LABEL(1..NCOMP(I)) -- symmetry labels for the orbitals of this shell J1 = 1 J2 = I1 J3 = I3 J4 = I2 DO 20 I = 1,NSHELL NCOMP = ISCR(J2) NPRIM = ISCR(J3) NPTR = ISCR(J4) WRITE(LFN,950) LCTR(J1),NCOMP,NPRIM,NPTR WRITE(LFN,950) ((LANG(J1+J)),J=0,NCOMP-1) J1 = J1 + NCOMP J2 = J2 + 1 J3 = J3 + 1 J4 = J4 + 1 20 CONTINUE WRITE(LFN,940) Write out the primitive parameters: WRITE(LFN,960) (SCR(I4+I),I=0,NEXP-1) WRITE(LFN,970) WRITE(LFN,960) (SCR(I5+I),I=0,NEXP-1) WRITE(LFN,970) WRITE(LFN,960) (SCR(I6+I),I=0,NEXP-1) WRITE(LFN,970) WRITE(LFN,960) (SCR(I7+I),I=0,NEXP-1) WRITE(LFN,970) WRITE(LFN,960) (SCR(I8+I),I=0,NEXP-1) RETURN 900 FORMAT(/1X,'No basis set information is stored on the NBO direct', + ' access file.',/1X,'Thus, no `AOINFO'' file can be written.') 910 FORMAT(1X,9A8,A7,/1X,'Basis set information needed for plotting ', + 'orbitals',/1X,75('-')) 920 FORMAT(1X,3I6,/1X,75('-')) 930 FORMAT(1X,I4,3(2X,F12.9)) 940 FORMAT(1X,75('-')) 950 FORMAT(1X,10I6) 960 FORMAT(2X,4E18.9) 970 FORMAT(1X) END ***************************************************************************** SUBROUTINE WRARC(SCR,ISCR,LFN) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (MAXD = 4) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) DIMENSION SCR(1),ISCR(1),IK(MAXD) DIMENSION KGEN(7),KNAT(6),KBAS(4),KOPEN(4),KORTHO(5),KUPPER(5), + KBODM(4),KEV(2),KCUBF(6),KEND(4),KCAL(4) DATA KGEN/1H$,1HG,1HE,1HN,1HN,1HB,1HO/,KBAS/1HN,1HB,1HA,1HS/, + KNAT/1HN,1HA,1HT,1HO,1HM,1HS/,KOPEN/1HO,1HP,1HE,1HN/, + KORTHO/1HO,1HR,1HT,1HH,1HO/,KUPPER/1HU,1HP,1HP,1HE,1HR/, + KBODM/1HB,1HO,1HD,1HM/,KEV/1HE,1HV/,KEND/1H$,1HE,1HN,1HD/, + KCUBF/1HC,1HU,1HB,1HI,1HC,1HF/,KCAL/1HK,1HC,1HA,1HL/ DATA KBLNK,KEQ/1H ,1H=/ DATA ABLNKS,ACENTR,ALABEL/8H ,8HCENTER =,8H LABEL =/ DATA ANSHLL,ANEXP ,ANCOMP/8HNSHELL =,8H NEXP =,8H NCOMP =/ DATA ANPRIM,ANPTR ,AEXP /8H NPRIM =,8H NPTR =,8H EXP =/ DATA ACS,ACP,ACD,ACF/8H CS =,8H CP =,8H CD =,8H CF =/ DATA ZERO/0.0D0/ Write the ARCHIVE file to LFN: This routine has been written assuming NBAS = NDIM. Skip if this condition is not satisfied: IF(NBAS.NE.NDIM) THEN WRITE(LFNPR,890) RETURN END IF Form the $GENNBO keylist in ISCR: NC = 0 DO 10 I = 1,7 NC = NC + 1 ISCR(NC) = KGEN(I) 10 CONTINUE NC = NC + 1 ISCR(NC) = KBLNK NC = NC + 1 ISCR(NC) = KBLNK Add the number of atoms and basis functions: DO 20 I = 1,6 NC = NC + 1 ISCR(NC) = KNAT(I) 20 CONTINUE NC = NC + 1 ISCR(NC) = KEQ CALL IDIGIT(NATOMS,IK,ND,MAXD) DO 30 I = 1,ND NC = NC + 1 ISCR(NC) = IK(I) 30 CONTINUE NC = NC + 1 ISCR(NC) = KBLNK NC = NC + 1 ISCR(NC) = KBLNK DO 40 I = 1,4 NC = NC + 1 ISCR(NC) = KBAS(I) 40 CONTINUE NC = NC + 1 ISCR(NC) = KEQ CALL IDIGIT(NBAS,IK,ND,MAXD) DO 50 I = 1,ND NC = NC + 1 ISCR(NC) = IK(I) 50 CONTINUE NC = NC + 1 ISCR(NC) = KBLNK NC = NC + 1 ISCR(NC) = KBLNK If OPEN shell, add the OPEN keyword: IF(OPEN) THEN DO 60 I = 1,4 NC = NC + 1 ISCR(NC) = KOPEN(I) 60 CONTINUE NC = NC + 1 ISCR(NC) = KBLNK NC = NC + 1 ISCR(NC) = KBLNK END IF If the AO basis is orthogonal, add the ORTHO keyword: IF(ORTHO) THEN DO 70 I = 1,5 NC = NC + 1 ISCR(NC) = KORTHO(I) 70 CONTINUE NC = NC + 1 ISCR(NC) = KBLNK NC = NC + 1 ISCR(NC) = KBLNK END IF Only UPPER triangular portions of symmetric matrices will be given: DO 80 I = 1,5 NC = NC + 1 ISCR(NC) = KUPPER(I) 80 CONTINUE NC = NC + 1 ISCR(NC) = KBLNK NC = NC + 1 ISCR(NC) = KBLNK Enter the bond-order matrix, BODM, if possible: IF(IWDM.EQ.1) THEN DO 90 I = 1,4 NC = NC + 1 ISCR(NC) = KBODM(I) 90 CONTINUE NC = NC + 1 ISCR(NC) = KBLNK NC = NC + 1 ISCR(NC) = KBLNK END IF Add EV if the energy units are in electron volts: IF(MUNIT.EQ.1) THEN NC = NC + 1 ISCR(NC) = KEV(1) NC = NC + 1 ISCR(NC) = KEV(2) NC = NC + 1 ISCR(NC) = KBLNK NC = NC + 1 ISCR(NC) = KBLNK END IF Add KCAL if the energy units are in kcal/mol: IF(MUNIT.EQ.1) THEN NC = NC + 1 ISCR(NC) = KCAL(1) NC = NC + 1 ISCR(NC) = KCAL(2) NC = NC + 1 ISCR(NC) = KCAL(3) NC = NC + 1 ISCR(NC) = KCAL(4) NC = NC + 1 ISCR(NC) = KBLNK NC = NC + 1 ISCR(NC) = KBLNK END IF Add CUBICF if these types of orbitals are being used: IF(IWCUBF.NE.0) THEN DO 100 I = 1,6 NC = NC + 1 ISCR(NC) = KCUBF(I) 100 CONTINUE NC = NC + 1 ISCR(NC) = KBLNK NC = NC + 1 ISCR(NC) = KBLNK END IF Add $END: DO 110 I = 1,4 NC = NC + 1 ISCR(NC) = KEND(I) 110 CONTINUE Write the $GENNBO keylist to the archive file: WRITE(LFN,900) (ISCR(I),I=1,NC) Write the $NBO keylist to the archive file: WRITE(LFN,910) Write the $COORD data list to the archive file: WRITE(LFN,920) CALL FETITL(SCR) WRITE(LFN,930) (SCR(I),I=1,10) CALL FECOOR(SCR) J = 1 DO 120 I = 1,NATOMS WRITE(LFN,940) IATNO(I),IZNUC(I),SCR(J),SCR(J+1),SCR(J+2) J = J + 3 120 CONTINUE WRITE(LFN,950) Write the $BASIS datalist to the archive file (info from /NBAO/): WRITE(LFN,960) NINT = 17 STR = ACENTR DO 130 I = 1,(NBAS-1)/NINT+1 NL = (I - 1) * NINT + 1 NU = MIN0(NL+NINT-1,NBAS) WRITE(LFN,970) STR,(LCTR(J),J=NL,NU) STR = ABLNKS 130 CONTINUE STR = ALABEL DO 140 I = 1,(NBAS-1)/NINT+1 NL = (I - 1) * NINT + 1 NU = MIN0(NL+NINT-1,NBAS) WRITE(LFN,970) STR,(LANG(J),J=NL,NU) STR = ABLNKS 140 CONTINUE WRITE(LFN,950) Write the $CONTRACT datalist to the archive file: Fetch the basis set info from the NBO DAF: CALL FEBAS(NSHELL,NEXP,ISCR) Partition the scratch vector: ISCR(I1) : NCOMP(1..NSHELL) ISCR(I2) : NPRIM(1..NSHELL) ISCR(I3) : NPTR(1..NSHELL) SCR(I4) : EXP(1..NEXP) SCR(I5) : CS(1..NEXP) SCR(I6) : CP(1..NEXP) SCR(I7) : CD(1..NEXP) SCR(I8) : CF(1..NEXP) I1 = 3 I2 = I1 + NSHELL I3 = I2 + NSHELL I4 = I3 + NSHELL I5 = I4 + NEXP I6 = I5 + NEXP I7 = I6 + NEXP I8 = I7 + NEXP IEND = I8 + NEXP If NSHELL is zero, then no basis set info was ever stored on the DAF: IF(NSHELL.GT.0) THEN Write out numbers of shells and orbital exponents: WRITE(LFN,980) WRITE(LFN,970) ANSHLL,NSHELL WRITE(LFN,970) ANEXP,NEXP Write out the number of components in each shell: NINT = 17 STR = ANCOMP DO 150 I = 1,(NSHELL-1)/NINT+1 NL = (I - 1) * NINT + 1 NU = MIN0(NL+NINT-1,NSHELL) WRITE(LFN,970) STR,(ISCR(J),J=I1+NL-1,I1+NU-1) STR = ABLNKS 150 CONTINUE Write out the number of primitives in each shell: STR = ANPRIM DO 160 I = 1,(NSHELL-1)/NINT+1 NL = (I - 1) * NINT + 1 NU = MIN0(NL+NINT-1,NSHELL) WRITE(LFN,970) STR,(ISCR(J),J=I2+NL-1,I2+NU-1) STR = ABLNKS 160 CONTINUE Write out pointer array which maps orbital exponents and coefficients onto each shell: STR = ANPTR DO 170 I = 1,(NSHELL-1)/NINT+1 NL = (I - 1) * NINT + 1 NU = MIN0(NL+NINT-1,NSHELL) WRITE(LFN,970) STR,(ISCR(J),J=I3+NL-1,I3+NU-1) STR = ABLNKS 170 CONTINUE Write out orbital exponents: NREAL = 4 STR = AEXP DO 180 I = 1,(NEXP-1)/NREAL+1 NL = (I - 1) * NREAL + 1 NU = MIN0(NL+NREAL-1,NEXP) WRITE(LFN,990) STR,(SCR(J),J=I4+NL-1,I4+NU-1) STR = ABLNKS 180 CONTINUE Write out the orbital coefficients for each angular symmetry type unless there are no basis functions of that type: DO 210 I = 1,4 IF(I.EQ.1) THEN STR = ACS II = I5 ELSE IF(I.EQ.2) THEN STR = ACP II = I6 ELSE IF(I.EQ.3) THEN STR = ACD II = I7 ELSE IF(I.EQ.4) THEN STR = ACF II = I8 END IF IFLG = 0 DO 190 J = II,II+NEXP-1 IF(SCR(J).NE.ZERO) IFLG = 1 190 CONTINUE IF(IFLG.EQ.1) THEN DO 200 J = 1,(NEXP-1)/NREAL+1 NL = (J - 1) * NREAL + 1 NU = MIN0(NL+NREAL-1,NEXP) WRITE(LFN,990) STR,(SCR(K),K=II+NL-1,II+NU-1) STR = ABLNKS 200 CONTINUE END IF 210 CONTINUE WRITE(LFN,950) END IF Write the $OVERLAP datalist unless the AO basis is orthogonal: L2 = NDIM * (NDIM + 1) / 2 IF(.NOT.ORTHO) THEN WRITE(LFN,1000) CALL FESRAW(SCR) L2 = NDIM * (NDIM + 1) / 2 CALL PACK(SCR,NDIM,NBAS,L2) WRITE(LFN,1010) (SCR(I),I=1,L2) WRITE(LFN,950) END IF Write the $DENSITY datalist: WRITE(LFN,1020) IF(OPEN) THEN ALPHA = .TRUE. BETA = .FALSE. CALL FEDRAW(SCR,SCR) CALL PACK(SCR,NDIM,NBAS,L2) WRITE(LFN,1010) (SCR(I),I=1,L2) ALPHA = .FALSE. BETA = .TRUE. CALL FEDRAW(SCR,SCR) CALL PACK(SCR,NDIM,NBAS,L2) WRITE(LFN,1010) (SCR(I),I=1,L2) ELSE ALPHA = .FALSE. BETA = .FALSE. CALL FEDRAW(SCR,SCR) CALL PACK(SCR,NDIM,NBAS,L2) WRITE(LFN,1010) (SCR(I),I=1,L2) END IF WRITE(LFN,950) Write the $FOCK datalist: IF(OPEN) THEN ALPHA = .TRUE. BETA = .FALSE. IWFOCK = 1 CALL FEFAO(SCR,IWFOCK) IF(IWFOCK.NE.0) THEN WRITE(LFN,1030) CALL PACK(SCR,NDIM,NBAS,L2) WRITE(LFN,1010) (SCR(I),I=1,L2) ALPHA = .FALSE. BETA = .TRUE. CALL FEFAO(SCR,IWFOCK) CALL PACK(SCR,NDIM,NBAS,L2) WRITE(LFN,1010) (SCR(I),I=1,L2) WRITE(LFN,950) END IF ELSE ALPHA = .FALSE. BETA = .FALSE. IWFOCK = 1 CALL FEFAO(SCR,IWFOCK) IF(IWFOCK.NE.0) THEN WRITE(LFN,1030) CALL PACK(SCR,NDIM,NBAS,L2) WRITE(LFN,1010) (SCR(I),I=1,L2) WRITE(LFN,950) END IF END IF Write the $LCAOMO datalist: IF(OPEN) THEN ALPHA = .TRUE. BETA = .FALSE. CALL FEAOMO(SCR,IAOMO) IF(IAOMO.EQ.1) THEN WRITE(LFN,1040) WRITE(LFN,1010) (SCR(I),I=1,NDIM*NDIM) ALPHA = .FALSE. BETA = .TRUE. CALL FEAOMO(SCR,IAOMO) WRITE(LFN,1010) (SCR(I),I=1,NDIM*NDIM) WRITE(LFN,950) END IF ELSE ALPHA = .FALSE. BETA = .FALSE. CALL FEAOMO(SCR,IAOMO) IF(IAOMO.EQ.1) THEN WRITE(LFN,1040) WRITE(LFN,1010) (SCR(I),I=1,NDIM*NDIM) WRITE(LFN,950) END IF END IF Write the $DIPOLE datalist: IDIP = 1 CALL FEDXYZ(SCR,IDIP) IF(IDIP.NE.0) THEN WRITE(LFN,1050) CALL PACK(SCR,NDIM,NBAS,L2) WRITE(LFN,1010) (SCR(I),I=1,L2) IDIP = 2 CALL FEDXYZ(SCR,IDIP) CALL PACK(SCR,NDIM,NBAS,L2) WRITE(LFN,1010) (SCR(I),I=1,L2) IDIP = 3 CALL FEDXYZ(SCR,IDIP) CALL PACK(SCR,NDIM,NBAS,L2) WRITE(LFN,1010) (SCR(I),I=1,L2) WRITE(LFN,950) END IF Reset logicals ALPHA and BETA: ALPHA = ISPIN.EQ.2 BETA = ISPIN.EQ.-2 RETURN 890 FORMAT(/1X,'The routine which writes the ARCHIVE file assumes ', + 'NBAS = NDIM. Since',/1X,'this condition is not satisfied, ', + 'the ARCHIVE file will not be written.') 900 FORMAT(1X,78A1) 910 FORMAT(1X,'$NBO $END') 920 FORMAT(1X,'$COORD') 930 FORMAT(1X,9A8,A6) 940 FORMAT(1X,2I5,3F15.6) 950 FORMAT(1X,'$END') 960 FORMAT(1X,'$BASIS') 970 FORMAT(1X,1X,A8,1X,17(I3,1X)) 980 FORMAT(1X,'$CONTRACT') 990 FORMAT(1X,1X,A8,1X,4(E15.7,1X)) 1000 FORMAT(1X,'$OVERLAP') 1010 FORMAT(1X,1X,5E15.7) 1020 FORMAT(1X,'$DENSITY') 1030 FORMAT(1X,'$FOCK') 1040 FORMAT(1X,'$LCAOMO') 1050 FORMAT(1X,'$DIPOLE') END ***************************************************************************** SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(MR,1) CHARACTER*80 TITLE DIMENSION ISHELL(4) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBLBL/NLEW,NVAL,LBL(10,MAXBAS,4) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/ Either write A to an external file, or print it in the output file: Input: A -- matrix to be printed or written out MR -- row dimension of matrix A in calling routine NR -- ABS(NR) is the actual number of rows to be output [if NR is negative, IFLG is negative (write), and ABS(NR).EQ.NC (square matrix), only the upper triangular portion is written out] NC -- actual number of columns in matrix A [used to determine if A is square, and as an upper limit on IFLG] TITLE -- CHARACTER*80 variable containing a matrix title INDEX -- Index selecting appropriate output labels 0 : Atom labels 1 : AO labels 2 : NAO labels 3 : NHO labels 4 : NBO labels 5 : NLMO labels IFLG -- print/write flag negative : write to LFN ABS(IFLG) positive : print IFLG columns of A 'FULL' : print the full matrix 'VAL' : print N columns of A, where N is the number of core + valence orbitals and is determined by this routine 'LEW' : print N columns of A, where N is the number of occupied orbitals and is determined by this routine JFLG = IFLG IF(JFLG.EQ.0) RETURN If JFLG is FULL, then output the total number of columns: IF(JFLG.EQ.KFULL) JFLG = ABS(NC) If JFLG = VAL, output only the valence orbitals, determined from the core and valence tables: IF(JFLG.EQ.KVAL) THEN IF(NVAL.LT.0) THEN IECP = 0 JFLG = 0 DO 30 IAT = 1,NATOMS CALL CORTBL(IAT,ISHELL,IECP) DO 10 I = 1,4 MULT = 2 * (I-1) + 1 JFLG = JFLG + ISHELL(I)*MULT 10 CONTINUE CALL VALTBL(IAT,ISHELL) DO 20 I = 1,4 MULT = 2 * (I-1) + 1 JFLG = JFLG + ISHELL(I)*MULT 20 CONTINUE 30 CONTINUE ELSE JFLG = NVAL END IF END IF If JFLG is LEW, only output the occupied orbitals: IF(JFLG.EQ.KLEW) JFLG = NLEW If JFLG is positive, print the matrix A in the output file: IF(JFLG.GT.0) CALL APRINT(A,MR,NR,NC,TITLE,INDEX,JFLG) If JFLG is negative but greater than -1000, write matrix A to the external file ABS(JFLG): IF(JFLG.LT.0.AND.JFLG.GT.-1000) CALL AWRITE(A,MR,NR,NC,TITLE,JFLG) RETURN END ***************************************************************************** SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(MR,1) CHARACTER*80 TITLE DIMENSION BASIS(5) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBLBL/NLEW,NVAL,LBL(10,MAXBAS,4) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA BASIS/4H AO ,4H NAO,4H NHO,4H NBO,4HNLMO/ DATA ATOM,DASHES/4HAtom,8H--------/ DATA TENTH/0.1D0/ Determine the number of columns of matrix A to print in the output file: NCOL = MCOL IF(NCOL.GT.ABS(NC)) NCOL = ABS(NC) NN = ABS(NR) ILABEL = INDEX IF(ILABEL.EQ.5) ILABEL = 4 TMAX = ABS(A(1,1)) DO 20 J = 1,NCOL DO 10 I = 1,NN IF(ABS(A(I,J)).GT.TMAX) TMAX = ABS(A(I,J)) 10 CONTINUE 20 CONTINUE IF(TMAX.LT.TENTH) THEN ND = 1 ELSE ND = INT(LOG10(TMAX)) + 1 END IF Print the matrix title: WRITE(LFNPR,1000) TITLE(1:78) Print the matrix A: (basis function labels) IF(ILABEL.GE.1.AND.ILABEL.LE.4) THEN MAXCOL = MIN(10-ND,8) IF(MAXCOL.LT.6) THEN CALL ALTOUT(A,MR,NCOL,NN,NCOL) ELSE NCL = 1 NCU = MAXCOL NLOOPS = (NCOL - 1) / MAXCOL + 1 DO 60 L = 1,NLOOPS IF(NCU.GT.NCOL) NCU = NCOL IF(MAXCOL.EQ.8) THEN WRITE(LFNPR,900) BASIS(INDEX),(J,J=NCL,NCU) WRITE(LFNPR,910) (DASHES,J=NCL,NCU) DO 30 I = 1,NN WRITE(LFNPR,920) I,(LBL(J,I,ILABEL),J=1,10), + (A(I,K),K=NCL,NCU) 30 CONTINUE ELSE IF(MAXCOL.EQ.7) THEN WRITE(LFNPR,901) BASIS(INDEX),(J,J=NCL,NCU) WRITE(LFNPR,911) (DASHES,J=NCL,NCU) DO 40 I = 1,NN WRITE(LFNPR,921) I,(LBL(J,I,ILABEL),J=1,10), + (A(I,K),K=NCL,NCU) 40 CONTINUE ELSE WRITE(LFNPR,902) BASIS(INDEX),(J,J=NCL,NCU) WRITE(LFNPR,912) (DASHES,DASHES,J=NCL,NCU) DO 50 I = 1,NN WRITE(LFNPR,922) I,(LBL(J,I,ILABEL),J=1,10), + (A(I,K),K=NCL,NCU) 50 CONTINUE END IF NCL = NCU + 1 NCU = NCU + MAXCOL 60 CONTINUE END IF Print the matrix A: (atom labels) ELSE IF(ILABEL.EQ.0) THEN MAXCOL = MIN(10-ND,9) IF(MAXCOL.LT.7) THEN CALL ALTOUT(A,MR,NCOL,N,NCOL) ELSE NCL = 1 NCU = MAXCOL NLOOPS = (NCOL - 1) / MAXCOL + 1 DO 160 L = 1,NLOOPS IF(NCU.GT.NCOL) NCU = NCOL IF(MAXCOL.EQ.9) THEN WRITE(LFNPR,1900) ATOM,(J,J=NCL,NCU) WRITE(LFNPR,1910) (DASHES,J=NCL,NCU) DO 130 I = 1,NN WRITE(LFNPR,1920) I,NAMEAT(IATNO(I)), + (A(I,K),K=NCL,NCU) 130 CONTINUE ELSE IF(MAXCOL.EQ.8) THEN WRITE(LFNPR,1901) ATOM,(J,J=NCL,NCU) WRITE(LFNPR,1911) (DASHES,J=NCL,NCU) DO 140 I = 1,NN WRITE(LFNPR,1921) I,NAMEAT(IATNO(I)), + (A(I,K),K=NCL,NCU) 140 CONTINUE ELSE WRITE(LFNPR,1902) ATOM,(J,J=NCL,NCU) WRITE(LFNPR,1912) (DASHES,J=NCL,NCU) DO 150 I = 1,NN WRITE(LFNPR,1922) I,NAMEAT(IATNO(I)), + (A(I,K),K=NCL,NCU) 150 CONTINUE END IF NCL = NCU + 1 NCU = NCU + MAXCOL 160 CONTINUE END IF Print the matrix A: (no labels) ELSE CALL ALTOUT(A,MR,NCOL,NN,NCOL) END IF RETURN 900 FORMAT(/9X,A4,3X,8(3X,I3,2X)) 901 FORMAT(/9X,A4,3X,7(4X,I3,2X)) 902 FORMAT(/9X,A4,3X,6(4X,I3,3X)) 910 FORMAT(6X,'----------',8(1X,A7)) 911 FORMAT(6X,'----------',7(1X,A8)) 912 FORMAT(6X,'----------',6(1X,A8,A1)) 920 FORMAT(1X,I3,'. ',10A1,8F8.4) 921 FORMAT(1X,I3,'. ',10A1,7F9.4) 922 FORMAT(1X,I3,'. ',10A1,6F10.4) 1000 FORMAT(//1X,A78) 1900 FORMAT(/5X,A4,9(2X,I3,3X)) 1901 FORMAT(/5X,A4,8(3X,I3,3X)) 1902 FORMAT(/5X,A4,7(3X,I3,4X)) 1910 FORMAT(5X,'----',1X,9(A6,2X)) 1911 FORMAT(5X,'----',1X,8(A7,2X)) 1912 FORMAT(5X,'----',1X,7(A8,2X)) 1920 FORMAT(1X,I3,'. ',A2,9F8.4) 1921 FORMAT(1X,I3,'. ',A2,8F9.4) 1922 FORMAT(1X,I3,'. ',A2,7F10.4) END ***************************************************************************** SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(MR,1) CHARACTER*80 TITLE DIMENSION XJOB(10) COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF Write the matrix A to the external file ABS(LFN). Include job title, matrix title, and specify the spin in needed: LFNOUT = ABS(LFN) IF(LFNOUT.EQ.LFNPR) WRITE(LFNOUT,890) IF(ALPHA.OR..NOT.OPEN.OR.LFNOUT.EQ.LFNPR) THEN CALL FETITL(XJOB) WRITE(LFNOUT,900) XJOB WRITE(LFNOUT,910) TITLE(1:79) END IF IF(ALPHA) WRITE(LFNOUT,920) IF(BETA) WRITE(LFNOUT,930) If this is a square matrix and NR is negative, only write the upper triangular portion. Otherwise, write out the full matrix: IF(ABS(NR).EQ.ABS(NC).AND.NR.LT.0) THEN WRITE(LFNOUT,1000) ((A(I,J),I=1,J),J=1,ABS(NR)) ELSE DO 10 J = 1,ABS(NC) WRITE(LFNOUT,1000) (A(I,J),I=1,ABS(NR)) 10 CONTINUE END IF RETURN 890 FORMAT(/1X) 900 FORMAT(1X,9A8,A7) 910 FORMAT(1X,A79,/1X,79('-')) 920 FORMAT(1X,'ALPHA SPIN') 930 FORMAT(1X,'BETA SPIN') 1000 FORMAT(1X,5F15.9) END ***************************************************************************** SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(MR,1),JOB(20) DIMENSION ITEMP(20) LOGICAL ERROR COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO DATA IDASH,IALFA,IBETA/4H----,4HALPH,4HBETA/ Read the matrix A to the external file LFN: Input: MR -- row dimension of matrix A in calling routine NR -- ABS(NR) is the actual number of rows to be read [if NR is negative and ABS(NR).EQ.NC (square matrix), only the upper triangular portion is stored in the input file. This routine will read the upper triangular portion and unpack it.] NC -- actual number of columns in matrix A [used to determine if A is square] LFN -- input file Output: JOB -- INTEGER array containing the job title [closed shell or alpha spin only] ERROR -- set to .true. if the end-of-file was encountered while reading IF(ALPHA.OR..NOT.OPEN) READ(LFN,1000,END=800) JOB IF(.NOT.OPEN) ISTR = IDASH IF(ALPHA) ISTR = IALFA IF(BETA) ISTR = IBETA 10 READ(LFN,1000,END=800) ITEMP IF(ITEMP(1).NE.ISTR) GOTO 10 If this is a square matrix and NR is negative, only read the upper triangular portion. Otherwise, read the full matrix: IF(ABS(NR).EQ.ABS(NC).AND.NR.LT.0) THEN READ(LFN,900,END=800) ((A(I,J),I=1,J),J=1,ABS(NR)) DO 30 J = 1,ABS(NR)-1 DO 20 I = J+1,ABS(NR) A(I,J) = A(J,I) 20 CONTINUE 30 CONTINUE ELSE DO 40 J = 1,ABS(NC) READ(LFN,900,END=800) (A(I,J),I=1,ABS(NR)) 40 CONTINUE END IF ERROR = .FALSE. RETURN 800 ERROR = .TRUE. RETURN 900 FORMAT(1X,5F15.9) 1000 FORMAT(1X,20A4) END ***************************************************************************** SUBROUTINE ALTOUT(A,MR,MC,NR,NC) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DIMENSION A(MR,MC) FOR 80 COLUMN OUTPUT: LIST ELEMENTS OF ARRAY A (MATRIX OR VECTOR). MR,MC DECLARED ROW AND COLUMN DIMENSIONALITY, NR,NC ACTUAL ROW AND COLUMN DIMENSIONALITY, NCL=1 NCU=6 NLOOPS=NC/6+1 DO 20 L=1,NLOOPS IF(NCU.GT.NC) NCU=NC WRITE(LFNPR,1100) (J,J=NCL,NCU) DO 10 I=1,NR 10 WRITE(LFNPR,1200) I,(A(I,J),J=NCL,NCU) IF(NCU.GE.NC) RETURN NCL=NCU+1 20 NCU=NCU+6 RETURN 1100 FORMAT(/11X,10(I3,9X)) 1200 FORMAT(1X,I3,10F12.5) END ***************************************************************************** SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) INTEGER STRING(LEN) LOGICAL READ,ERROR COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA IW,IR,IP,IC,IV,IL/1HW,1HR,1HP,1HC,1HV,1HL/ DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/ Interpret the KEYword PARameter STRING, storing the result in IFLG. (The default IFLG should be passed to this routine through IFLG) The following STRINGs are acceptable: STRING = Wnnn means write to the external file nnn (IFLG = -nnn) (if nnn is omitted, IFLG = -LFN) STRING = Rnnn means read from the external file nnn (IFLG = -nnn*1000) (if nnn is omitted, IFLG = -LFN) (READ must be true to allow reading) STRING = PnnnC means print nnn columns to the output file (IFLG = nnn) (if nnn is omitted, print full matrix, IFLG = 'FULL') (the C is optional, it means columns) STRING = PVAL means print val columns to output file (IFLG = 'VAL') (val is the number of core + valence orbitals) (only the V is necessary) STRING = PLEW means print lew columns to output file (IFLG = 'LEW' (lew is the number of occupied orbitals) (only the L is necessary) STRING = other IFLG is left untouched ERROR = .FALSE. Process STRING = W..: IF(STRING(1).EQ.IW) THEN IF(LEN.EQ.1) THEN IFLG = -LFN RETURN END IF IF(LEN.GT.1) THEN CALL CONVIN(STRING(2),LEN-1,IFLG,ERROR) IF(ERROR) RETURN IF(IFLG.GT.1000) THEN WRITE(LFNPR,900) WRITE(LFNPR,910) IFLG STOP END IF IFLG = -IFLG END IF Process STRING = R..: ELSE IF(STRING(1).EQ.IR) THEN IF(.NOT.READ) THEN ERROR = .TRUE. RETURN END IF IF(LEN.EQ.1) THEN IFLG = -LFN * 1000 RETURN END IF IF(LEN.GT.1) THEN CALL CONVIN(STRING(2),LEN-1,IFLG,ERROR) IF(ERROR) RETURN IF(IFLG.GT.1000) THEN WRITE(LFNPR,900) WRITE(LFNPR,920) IFLG STOP END IF IFLG = -IFLG * 1000 END IF Process STRING = P..: ELSE IF(STRING(1).EQ.IP) THEN IF(STRING(2).EQ.IV) THEN IFLG = KVAL RETURN END IF IF(STRING(2).EQ.IL) THEN IFLG = KLEW RETURN END IF IF(LEN.EQ.1) THEN IFLG = KFULL RETURN END IF IF(LEN.GT.1) THEN IF(STRING(LEN).NE.IC) THEN CALL CONVIN(STRING(2),LEN-1,IFLG,ERROR) ELSE CALL CONVIN(STRING(2),LEN-2,IFLG,ERROR) END IF END IF ELSE ERROR = .TRUE. END IF RETURN 900 FORMAT(/1X,'The NBO program will only communicate with external ', + 'files 0 thru 999.') 910 FORMAT(1X,'You''re attempting to write to file ',I6,'.') 920 FORMAT(1X,'You''re attempting to read from file ',I6,'.') END ***************************************************************************** FUNCTION IOINQR(IFLG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/ DATA KBLNK,KPRNT,KWRIT,KREAD/4H ,4HPRNT,4HWRIT,4HREAD/ Interpret IFLG, determining whether the corresponding matrix should be printed, written out, or read: IF(IFLG.EQ.KFULL) THEN IOINQR = KPRNT ELSE IF(IFLG.EQ.KVAL) THEN IOINQR = KPRNT ELSE IF(IFLG.EQ.KLEW) THEN IOINQR = KPRNT ELSE IF(IFLG.GT.0) THEN IOINQR = KPRNT ELSE IF(IFLG.LT.0.AND.IFLG.GT.-1000) THEN IOINQR = KWRIT ELSE IF(IFLG.LT.0) THEN IOINQR = KREAD ELSE IOINQR = KBLNK END IF RETURN END ***************************************************************************** SUBROUTINE LBLAO ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXD = 2) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS), + NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS) DIMENSION ISTR(MAXD),IANG(5),IXYZ(3),IBYTE(4),NUM(10) DATA IBLNK/' '/ DATA IANG/'s','p','d','f','g'/ DATA IXYZ/'x','y','z'/ DATA ILEFT,IRIGHT/'(',')'/ DATA NUM/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ DO 20 IAO = 1,NBAS DO 10 I = 1,10 IAOLBL(I,IAO) = IBLNK 10 CONTINUE LBL = NAMEAT(IATNO(LCTR(IAO))) CALL DEBYTE(LBL,IBYTE) IAOLBL(1,IAO) = IBYTE(1) IAOLBL(2,IAO) = IBYTE(2) CALL IDIGIT(LCTR(IAO),ISTR,ND,MAXD) IF(ND.EQ.1) THEN IAOLBL(4,IAO) = ISTR(1) ELSE IAOLBL(3,IAO) = ISTR(1) IAOLBL(4,IAO) = ISTR(2) END IF IAOLBL(6,IAO) = ILEFT L = LANG(IAO)/100 IAOLBL(7,IAO) = IANG(L+1) IF(L.EQ.0) THEN IAOLBL(8,IAO) = IRIGHT ELSE IF(L.EQ.1) THEN M = MOD(LANG(IAO),10) IAOLBL(8,IAO) = IXYZ(M) IAOLBL(9,IAO) = IRIGHT ELSE IF(L.EQ.2.OR.L.EQ.3) THEN IAOLBL(8,IAO) = NUM(MOD(LANG(IAO),10)+1) IAOLBL(9,IAO) = IRIGHT END IF 20 CONTINUE RETURN END ***************************************************************************** SUBROUTINE LBLNAO ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXD = 2) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS), + IPRIN(MAXBAS) COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS), + NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS) DIMENSION ISTR(MAXD),IANG(5),IXYZ(3),IBYTE(4),NUM(10) DATA IBLNK/' '/ DATA IANG/'s','p','d','f','g'/ DATA IXYZ/'x','y','z'/ DATA ILEFT,IRIGHT/'(',')'/ DATA NUM/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ DO 20 INAO = 1,NBAS DO 10 I = 1,10 NAOLBL(I,INAO) = IBLNK 10 CONTINUE LBL = NAMEAT(IATNO(NAOCTR(INAO))) CALL DEBYTE(LBL,IBYTE) NAOLBL(1,INAO) = IBYTE(1) NAOLBL(2,INAO) = IBYTE(2) CALL IDIGIT(NAOCTR(INAO),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NAOLBL(4,INAO) = ISTR(1) ELSE NAOLBL(3,INAO) = ISTR(1) NAOLBL(4,INAO) = ISTR(2) END IF NAOLBL(5,INAO) = ILEFT CALL IDIGIT(IPRIN(INAO),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NAOLBL(7,INAO) = ISTR(1) ELSE NAOLBL(6,INAO) = ISTR(1) NAOLBL(7,INAO) = ISTR(2) END IF L = NAOL(INAO)/100 NAOLBL(8,INAO) = IANG(L+1) IF(L.EQ.1) THEN M = MOD(NAOL(INAO),10) NAOLBL(9,INAO) = IXYZ(M) ELSE IF(L.EQ.2.OR.L.EQ.3) THEN NAOLBL(9,INAO) = NUM(MOD(NAOL(INAO),10)+1) END IF NAOLBL(10,INAO) = IRIGHT 20 CONTINUE RETURN END ***************************************************************************** SUBROUTINE LBLNBO ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXD = 2) INTEGER ISTR(MAXD),IBYTE(4) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL1(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS), + NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS) DATA IBLNK,IC,IL,IP,IR,IY,ISTAR,IHYP/' ','c','l','p','r','y','*', + '-'/ DATA ICR,ILP/'CR','LP'/ DATA ILEFT,IRIGHT/'(',')'/ DO 20 INBO = 1,NBAS DO 10 I = 1,10 NBOLBL(I,INBO) = IBLNK 10 CONTINUE IB = IBXM(INBO) NCTR = 1 IF(LABEL(IB,5).NE.0) NCTR = 2 IF(LABEL(IB,6).NE.0) NCTR = 3 One-center labels: IF(NCTR.EQ.1) THEN LBL = NAMEAT(IATNO(LABEL(IB,4))) CALL DEBYTE(LBL,IBYTE) NBOLBL(1,INBO) = IBYTE(1) NBOLBL(2,INBO) = IBYTE(2) CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NBOLBL(4,INBO) = ISTR(1) ELSE NBOLBL(3,INBO) = ISTR(1) NBOLBL(4,INBO) = ISTR(2) END IF NBOLBL(5,INBO) = ILEFT IF(LABEL(IB,1).EQ.ICR) THEN NBOLBL(6,INBO) = IC NBOLBL(7,INBO) = IR NBOLBL(8,INBO) = IRIGHT ELSE IF(LABEL(IB,1).EQ.ILP) THEN NBOLBL(6,INBO) = IL NBOLBL(7,INBO) = IP IF(LABEL(IB,2).EQ.ISTAR) THEN NBOLBL(8,INBO) = ISTAR NBOLBL(9,INBO) = IRIGHT ELSE NBOLBL(8,INBO) = IRIGHT END IF ELSE NBOLBL(6,INBO) = IR NBOLBL(7,INBO) = IY NBOLBL(8,INBO) = ISTAR NBOLBL(9,INBO) = IRIGHT END IF Two-center labels: ELSE IF(NCTR.EQ.2) THEN LBL = NAMEAT(IATNO(LABEL(IB,4))) CALL DEBYTE(LBL,IBYTE) NBOLBL(1,INBO) = IBYTE(1) NBOLBL(2,INBO) = IBYTE(2) CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NBOLBL(4,INBO) = ISTR(1) ELSE NBOLBL(3,INBO) = ISTR(1) NBOLBL(4,INBO) = ISTR(2) END IF NBOLBL(5,INBO) = IHYP LBL = NAMEAT(IATNO(LABEL(IB,5))) CALL DEBYTE(LBL,IBYTE) NBOLBL(6,INBO) = IBYTE(1) NBOLBL(7,INBO) = IBYTE(2) CALL IDIGIT(LABEL(IB,5),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NBOLBL(9,INBO) = ISTR(1) ELSE NBOLBL(8,INBO) = ISTR(1) NBOLBL(9,INBO) = ISTR(2) END IF NBOLBL(10,INBO) = LABEL(IB,2) Three-center labels: ELSE CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NBOLBL(2,INBO) = ISTR(1) ELSE NBOLBL(1,INBO) = ISTR(1) NBOLBL(2,INBO) = ISTR(2) END IF NBOLBL(3,INBO) = IHYP CALL IDIGIT(LABEL(IB,5),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NBOLBL(5,INBO) = ISTR(1) ELSE NBOLBL(4,INBO) = ISTR(1) NBOLBL(5,INBO) = ISTR(2) END IF NBOLBL(6,INBO) = IHYP CALL IDIGIT(LABEL(IB,6),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NBOLBL(8,INBO) = ISTR(1) ELSE NBOLBL(7,INBO) = ISTR(1) NBOLBL(8,INBO) = ISTR(2) END IF NBOLBL(9,INBO) = LABEL(IB,2) END IF 20 CONTINUE RETURN END ***************************************************************************** SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MAXD = 2) INTEGER ISTR(MAXD),IBYTE(4) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL1(MAXBAS), + LORBC(MAXBAS),LORB(MAXBAS) COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS), + NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS) DATA IBLNK,IC,IL,IP,IR,IY,I3,ISTAR,IHYP/' ','c','l','p','r','y', + '3','*','-'/ DATA ICR,ILP/'CR','LP'/ DATA ILEFT,IRIGHT/'(',')'/ DO 10 I = 1,10 NHOLBL(I,INHO) = IBLNK 10 CONTINUE IB = IBXM(INBO) One-center labels: IF(NCTR.EQ.1) THEN LBL = NAMEAT(IATNO(LABEL(IB,4))) CALL DEBYTE(LBL,IBYTE) NHOLBL(1,INHO) = IBYTE(1) NHOLBL(2,INHO) = IBYTE(2) CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NHOLBL(4,INHO) = ISTR(1) ELSE NHOLBL(3,INHO) = ISTR(1) NHOLBL(4,INHO) = ISTR(2) END IF NHOLBL(5,INHO) = ILEFT IF(LABEL(IB,1).EQ.ICR) THEN NHOLBL(6,INHO) = IC NHOLBL(7,INHO) = IR NHOLBL(8,INHO) = IRIGHT ELSE IF(LABEL(IB,1).EQ.ILP) THEN NHOLBL(6,INHO) = IL NHOLBL(7,INHO) = IP IF(LABEL(IB,2).EQ.ISTAR) THEN NHOLBL(8,INHO) = ISTAR NHOLBL(9,INHO) = IRIGHT ELSE NHOLBL(8,INHO) = IRIGHT END IF ELSE NHOLBL(6,INHO) = IR NHOLBL(7,INHO) = IY NHOLBL(8,INHO) = ISTAR NHOLBL(9,INHO) = IRIGHT END IF Two-center and three-center labels: ELSE LBL = NAMEAT(IATNO(LABEL(IB,3+ICTR))) CALL DEBYTE(LBL,IBYTE) NHOLBL(1,INHO) = IBYTE(1) NHOLBL(2,INHO) = IBYTE(2) CALL IDIGIT(LABEL(IB,3+ICTR),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NHOLBL(4,INHO) = ISTR(1) ELSE NHOLBL(3,INHO) = ISTR(1) NHOLBL(4,INHO) = ISTR(2) END IF NHOLBL(5,INHO) = ILEFT IF(NCTR.EQ.2) THEN LBL = NAMEAT(IATNO(LABEL(IB,6-ICTR))) CALL DEBYTE(LBL,IBYTE) NHOLBL(6,INHO) = IBYTE(1) NHOLBL(7,INHO) = IBYTE(2) CALL IDIGIT(LABEL(IB,6-ICTR),ISTR,ND,MAXD) IF(ND.EQ.1) THEN NHOLBL(9,INHO) = ISTR(1) ELSE NHOLBL(8,INHO) = ISTR(1) NHOLBL(9,INHO) = ISTR(2) END IF NHOLBL(10,INHO) = IRIGHT ELSE NHOLBL(6,INHO) = I3 NHOLBL(7,INHO) = IHYP NHOLBL(8,INHO) = IC NHOLBL(9,INHO) = IRIGHT END IF END IF RETURN END ***************************************************************************** GENERAL UTILITY ROUTINES: SUBROUTINE ANGLES(X,Y,Z,THETA,PHI) FUNCTION BDFIND(IAT,JAT) SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR) SUBROUTINE CONSOL(AUT,ALT,NDIM,N) SUBROUTINE CONVIN(IJ,LEN,IK,ERROR) SUBROUTINE CONVRT(N,NC1,NC2) SUBROUTINE COPY(A,B,NDIM,NR,NC) SUBROUTINE CORTBL(IAT,ICORE,IECP) SUBROUTINE DEBYTE(I,IBYTE) SUBROUTINE HALT(WORD) SUBROUTINE IDIGIT(KINT,IK,ND,MAXD) FUNCTION IHTYP(IBO,JBO) SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR) SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT) SUBROUTINE MATMLT(A,B,V,NDIM,N) SUBROUTINE MATML2(A,B,V,NDIM,N) FUNCTION NAMEAT(IZ) SUBROUTINE NORMLZ(A,S,M,N) SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK) SUBROUTINE PACK(T,NDIM,NBAS,L2) SUBROUTINE RANK(EIG,N,NDIM,ARCRNK) SUBROUTINE SIMTRN(A,T,V,NDIM,N) SUBROUTINE SIMTRS(A,S,V,NDIM,N) SUBROUTINE TRANSP(A,NDIM,N) SUBROUTINE UNPACK(T,NDIM,NBAS,L2) SUBROUTINE VALTBL(IAT,IVAL) FUNCTION VECLEN(X,N,NDIM) SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR, + IERR) SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG) SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR) SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM) ***************************************************************************** SUBROUTINE ANGLES(X,Y,Z,THETA,PHI) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DATA ZERO,CUTOFF,ONE/0.0D0,1.0D-8,1.0D0/ CONV = 180.0/(4.0*ATAN(ONE)) IF(X.EQ.ZERO.AND.Y.EQ.ZERO) THEN IF(Z.GE.ZERO) THEN THETA = ZERO ELSE THETA = 180.0 END IF PHI = ZERO ELSE IF(ABS(Z-ONE).LT.CUTOFF) THEN THETA = ZERO ELSE IF(ABS(Z+ONE).LT.CUTOFF) THEN THETA = 180.0 ELSE IF(Z.LT.ONE.AND.Z.GT.-ONE) THEN THETA = ACOS(Z) * CONV IF(THETA.GT.180.0) THETA = 360.0 - THETA ELSE STOP 'ArcCosine out of bounds in SR ANGLES' END IF PHI = ATAN2(Y,X) * CONV IF(PHI.LT.ZERO) PHI = PHI + 360.0 IF(ABS(PHI-360.0).LT.0.05) PHI = ZERO IF(ABS(THETA).LT.0.05) PHI = ZERO IF(ABS(THETA-180.0).LT.0.05) PHI = ZERO END IF RETURN END ***************************************************************************** FUNCTION BDFIND(IAT,JAT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL BDFIND,IFOUND,JFOUND PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT DATA LSTAR/1H*/ SET BDFIND=.TRUE. IF THERE IS AT LEAST ONE BOND BETWEEN ATOMS IAT AND JAT DO 100 IBAS = 1,NBAS IB = IBXM(IBAS) IF(LABEL(IB,2).EQ.LSTAR) GO TO 100 IF(LABEL(IB,3).NE.1) GO TO 100 IFOUND = .FALSE. JFOUND = .FALSE. DO 50 K = 4,6 IF(LABEL(IB,K).EQ.IAT) IFOUND = .TRUE. IF(LABEL(IB,K).EQ.JAT) JFOUND = .TRUE. 50 CONTINUE IF(IFOUND.AND.JFOUND) GO TO 200 100 CONTINUE BDFIND = .FALSE. RETURN 200 BDFIND = .TRUE. RETURN END ***************************************************************************** SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION LISTA(NATOMS,2),ISTR(80) PARAMETER (MAXD = 4) DIMENSION INUM(MAXD),IBYTE(4) DATA IC,IH,IBLNK,ILEFT,IRIGHT/'C','H',' ','(',')'/ Build the chemical formula from the list of atoms in LISTA: Get chemical symbols: DO 10 IAT = 1,NAT LISTA(IAT,1) = NAMEAT(LISTA(IAT,1)) 10 CONTINUE Alphabetize these symbols: DO 30 IAT = 1,NAT-1 DO 20 JAT = 1,NAT-IAT IF(LISTA(JAT,1).GT.LISTA(JAT+1,1)) THEN ITEMP = LISTA(JAT,1) LISTA(JAT,1) = LISTA(JAT+1,1) LISTA(JAT+1,1) = ITEMP ITEMP = LISTA(JAT,2) LISTA(JAT,2) = LISTA(JAT+1,2) LISTA(JAT+1,2) = ITEMP END IF 20 CONTINUE 30 CONTINUE Build chemical formula in ISTR: First carbon... NL = 1 ISTR(NL) = ILEFT DO 50 IAT = 1,NAT CALL DEBYTE(LISTA(IAT,1),IBYTE) IF(IBYTE(1).EQ.IBLNK.AND.IBYTE(2).EQ.IC) THEN NL = NL + 1 ISTR(NL) = IC IF(LISTA(IAT,2).NE.1) THEN CALL IDIGIT(LISTA(IAT,2),INUM,ND,MAXD) DO 40 IL = 1,ND NL = NL + 1 ISTR(NL) = INUM(IL) 40 CONTINUE END IF LISTA(IAT,2) = 0 END IF 50 CONTINUE then hydrogen... DO 70 IAT = 1,NAT CALL DEBYTE(LISTA(IAT,1),IBYTE) IF(IBYTE(1).EQ.IBLNK.AND.IBYTE(2).EQ.IH) THEN NL = NL + 1 ISTR(NL) = IH IF(LISTA(IAT,2).NE.1) THEN CALL IDIGIT(LISTA(IAT,2),INUM,ND,MAXD) DO 60 IL = 1,ND NL = NL + 1 ISTR(NL) = INUM(IL) 60 CONTINUE END IF LISTA(IAT,2) = 0 END IF 70 CONTINUE and now the rest... DO 90 IAT = 1,NAT IF(LISTA(IAT,2).NE.0) THEN CALL DEBYTE(LISTA(IAT,1),IBYTE) IF(IBYTE(1).NE.IBLNK) THEN NL = NL + 1 ISTR(NL) = IBYTE(1) END IF IF(IBYTE(2).NE.IBLNK) THEN NL = NL + 1 ISTR(NL) = IBYTE(2) END IF IF(LISTA(IAT,2).NE.1) THEN CALL IDIGIT(LISTA(IAT,2),INUM,ND,MAXD) DO 80 IL = 1,ND NL = NL + 1 ISTR(NL) = INUM(IL) 80 CONTINUE END IF LISTA(IAT,2) = 0 END IF 90 CONTINUE NL = NL + 1 ISTR(NL) = IRIGHT RETURN END ***************************************************************************** SUBROUTINE CONSOL(AUT,ALT,NDIM,N) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) CONSOLIDATE AUT, ALT TO A SINGLE MATRIX, WITH AUT AS UPPER TRIANGLE (INCLUDING DIAGONAL) AND ALT AS LOWER TRIANGLE. STORE RESULT IN AUT. DIMENSION AUT(NDIM,NDIM),ALT(NDIM,NDIM) NM1=N-1 DO 10 J=1,NM1 JP1=J+1 DO 10 I=JP1,N 10 AUT(I,J)=ALT(I,J) RETURN END ***************************************************************************** SUBROUTINE CONVIN(IJ,LEN,IK,ERROR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION IJ(1) DIMENSION INT(10) LOGICAL ERROR DATA INT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ Convert the array IJ(LEN) into an integer IK: ERROR = .FALSE. IF(LEN.LE.0) THEN ERROR = .TRUE. RETURN END IF Make sure all elements of IJ are integers: IL = 0 MULT = 1 DO 30 I = LEN,1,-1 DO 10 J = 1,10 JJ = J - 1 IF(IJ(I).EQ.INT(J)) GOTO 20 10 CONTINUE ERROR = .TRUE. RETURN 20 IL = IL + JJ * MULT MULT = MULT * 10 30 CONTINUE IK = IL RETURN END ***************************************************************************** SUBROUTINE CONVRT(N,NC1,NC2) ***************************************************************************** CONVERT 2-DIGIT INTEGER 'N' TO TWO LITERAL CHARACTERS 'NC1','NC2'. DIMENSION INT(10) DATA ISP,INT/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0/ NC1=ISP NC2=ISP IF(N.LE.0) RETURN IF(N.GE.10) GO TO 10 NC2=INT(N) RETURN 10 N1=N/10 IF(N1.GT.9) STOP 'ROUTINE CONVRT' NC1=INT(N1) N2=N-N1*10 IF(N2.EQ.0) N2=10 NC2=INT(N2) RETURN END ***************************************************************************** SUBROUTINE COPY(A,B,NDIM,NR,NC) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(NDIM,1),B(NDIM,1) COPY A TO B: DO 20 J = 1,NC DO 10 I = 1,NR B(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE RETURN END ***************************************************************************** SUBROUTINE CORTBL(IAT,ICORE,IECP) ***************************************************************************** CORE TABLE: Determine the number of subshells of core orbitals of each angular symmetry for atom number IAT. ICORE is an integer array LMAX+1 long which returns the number of subshells to the calling subroutine: the number of `s' subshells in ICORE(1), the number of `p' subshells in ICORE(2), etc... If the CORE option has been used, the core orbitals stored in the array IATCR are used rather than the core orbitals of the nominal core table. If IECP = 0 return the number of subshells, excluding subshells of an effective core potential. IF IECP = 1 return the number of subshells, including subshells of an effective core potential. Note: It is possible for a negative number of core orbitals be found if effective core potentials are employed. This happens when the number of core electrons in the effective core potential is either greater than the nominal number of core electrons or is greater than the number of core electrons requested when using the CORE option. ------------------------------------------------------------------------------ IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (LMAX = 3) INTEGER CORE(57),ICORE(4),ITEMP(4),IORD(16),JORD(20),KORD(20) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) DATA IORD/1,1,3,1,3,5,1,3,5,1,3,7,5,1,3,7/ DATA JORD/1,1,3,1,3,1,5,3,1,5,3,1,7,5,3,1,7,5,3,1/ DATA KORD/1,2,1,3,2,4,1,3,5,2,4,6,1,3,5,7,2,4,6,8/ DATA CORE/2,0,8,1,1,8,2,2,1,12,2,3,2,6,3,3,2,1,12,3,4,3,1,6,3,4,3, + 2,16,3,5,4,2,10,4,5,4,2,1,6,4,5,4,3,1,16,4,6,5,3,1,10,4,6,5,3,2/ Initialize arrays. If there is no nuclear charge at this center, return to calling routine: DO 10 L = 0,LMAX ICORE(L+1) = 0 ITEMP(L+1) = 0 10 CONTINUE IF(IATNO(IAT).LE.0) RETURN If the CORE option has not been used for this atom, use the nominal set of core orbitals: IF(JCORE.NE.1.OR.IATCR(IAT).LT.0) THEN JAT = IATNO(IAT) II = 0 20 II = II + 1 JAT = JAT - CORE(II) II = II + 1 IF(JAT.LE.0) THEN DO 30 L = 1,CORE(II) ICORE(L) = CORE(II+L) 30 CONTINUE ELSE II = II + CORE(II) END IF IF(JAT.GT.0) GOTO 20 ELSE If the CORE option has been used, determine the number of core orbitals on this atom: II = IATCR(IAT) IF(II.GT.0) THEN ICT = 0 40 ICT = ICT + 1 L = IORD(ICT)/2 ICORE(L+1) = ICORE(L+1) + 1 II = II - IORD(ICT) IF(II.GT.0) GOTO 40 END IF END IF If effective core potentials were used and IECP = 0, remove the core orbitals of the ECP: IF(IPSEUD.NE.0.AND.IECP.EQ.0) THEN II = IATNO(IAT) ICT = 0 50 ICT = ICT + 1 II = II - 2 * JORD(ICT) IF(II.GT.0) GOTO 50 II = IZNUC(IAT) - II IF(II.LE.0) STOP 'Zero or negative IZNUC entry?' ICT = ICT + 1 60 ICT = ICT - 1 IF(ICT.LE.0) STOP 'Error in SR CORTBL' II = II - 2 * JORD(ICT) IF(II.GE.0) THEN L = JORD(ICT)/2 IF(ICORE(L+1).GE.KORD(ICT)) ITEMP(L+1) = ITEMP(L+1) + 1 ELSE II = II + 2 * JORD(ICT) END IF IF(II.NE.0) GOTO 60 DO 70 L = 0,LMAX ICORE(L+1) = ITEMP(L+1) 70 CONTINUE END IF RETURN END ***************************************************************************** SUBROUTINE DEBYTE(I,IBYTE) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION IBYTE(4),KB(4) SAVE KB,KPAD,KSW DATA KSW/0/ DATA KTMP/4HABCD/ Extract four Hollerith characters from I, store in IBTYE: If this is the first time that this routine is called, determine in which bytes of an integer word the Hollerith characters reside: IF(KSW.EQ.0) THEN KSW = 1 DO 10 K = 1,4 KB(K) = 0 10 CONTINUE KBYTE = 0 20 KBYTE = KBYTE + 1 IF(KBYTE.GT.8) STOP 'Routine DEBYTE is limited to INTEGER*8' KTEST = MOD(KTMP,256) IF(KTEST.EQ.65) KB(1) = KBYTE IF(KTEST.EQ.66) KB(2) = KBYTE IF(KTEST.EQ.67) KB(3) = KBYTE IF(KTEST.EQ.68) KB(4) = KBYTE KTMP = KTMP/256 IF(KTMP.NE.0) GOTO 20 DO 30 K = 1,4 IF(KB(K).EQ.0) STOP 'Error in routine DEBYTE' 30 CONTINUE Determine the bit padding: KPAD = 0 KMLT = 1 DO 40 K = 1,KBYTE IF(K.NE.KB(1)) KPAD = KPAD + 32 * KMLT IF(K.NE.KBYTE) KMLT = KMLT * 256 40 CONTINUE DO 60 K = 1,4 KMAX = KB(K) - 1 KB(K) = 1 DO 50 L = 1,KMAX KB(K) = KB(K) * 256 50 CONTINUE 60 CONTINUE END IF Extract four Hollerith characters from I: DO 100 K = 1,4 IBYTE(K) = MOD(I/KB(K),256)*KB(1) + KPAD 100 CONTINUE RETURN END ***************************************************************************** SUBROUTINE HALT(WORD) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, + LFNDAF,LFNDEF DATA BLANK/1H / IF(WORD.EQ.BLANK) RETURN WRITE(LFNPR,1000) WORD STOP 1000 FORMAT(' Non-integer encountered when trying to read variable ', + '/',A6,'/') END ***************************************************************************** SUBROUTINE IDIGIT(KINT,IK,ND,MAXD) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION IK(MAXD),INT(10) DATA IBLNK,INT/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0/ CONVERTS THE INTEGER KINT INTO THE FIRST ND ELEMENTS OF HOLLERITH ARRAY IK(MAXD): JINT = KINT ND = MAXD DO 10 ID = MAXD,1,-1 II = MOD(JINT,10) IF(II.EQ.0) II = 10 IK(ID) = INT(II) IF(II.NE.10) ND = ID JINT = JINT/10 10 CONTINUE ND = MAXD - ND + 1 SHIFT INTEGER REP IN IK SO THAT THE NUMBER OCCUPIES THE FIRST ND ELEMENTS: DO 20 ID = 1,ND IK(ID) = IK(ID+MAXD-ND) 20 CONTINUE DO 30 ID = ND+1,MAXD IK(ID) = IBLNK 30 CONTINUE RETURN END ***************************************************************************** FUNCTION IHTYP(IBO,JBO) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) LOGICAL BDFIND PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS), + LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3) DATA IV,IG,IR/'v','g','r'/ Determine whether the IBO->JBO delocalization is vicinal (IHTYP='v'), geminal (IHTYP='g'), or remote (IHTYP='r'): IHTYP = IR IF(NBOUNI(IBO).EQ.NBOUNI(JBO)) THEN ICTR = MOD(NBOTYP(IBO),10) IB = IBXM(IBO) JCTR = MOD(NBOTYP(JBO),10) JB = IBXM(JBO) DO 20 I = 1,ICTR IAT = LABEL(IB,I+3) DO 10 J = 1,JCTR JAT = LABEL(JB,J+3) IF(IAT.EQ.JAT) THEN IHTYP = IG RETURN ELSE IF(BDFIND(IAT,JAT)) THEN IHTYP = IV END IF 10 CONTINUE 20 CONTINUE END IF RETURN END ***************************************************************************** SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIAGONALIZE REAL SYMMETRIC MATRIX A BY JACOBI ROTATIONS: N: ACTUAL DIMENSION OF A,EIVR NDIM: DECLARED DIMENSION OF A,EIVR ICONTR: CONTROL OPTION ******** MODIFIED VERSION, MARCH 1986 ************* ICONTR = 0: REDUCE ALL OFF-DIAGONAL ELEMENTS TO "DONE" OR SMALLER -- THIS SETS FULMIX=.TRUE. ICONTR = 1: DO THE SAME AS FOR ICONTR=0 EXCEPT DO NOT MIX ORBITALS THAT ARE DEGENERATE TO WITHIN "DIFFER" IF THE OFFDIAGONAL ELEMENT CONNECTING THEM IS LESS THAN "DIFFER". -- THIS SETS FULMIX=.FALSE. FOR THE PURPOSES OF THE NAO AND NBO PROGRAMS, THESE VALUES ARE SET: DIFFER = 1.0D-5 THRESHOLD FOR CONSIDERING TWO VECTORS NONDEGENERATE IF ICONTR=1 DONE = 1.0D-13 THIS IS THE PARAMETER FOR CONVERGENCE OF THE OFF-DIAGONAL MATRIX ELEMENTS. (ABSOLUTE) --- Reduced from 1.0D-10 on 8/31/88. A more converged Fock matrix was required for the NBO deletions with symmetry to work properly (EDG) --- EPS = 0.5D-13 THIS PARAMETER HAS TO DO WITH THE MACHINE PRECISION AND SHOULD BE SET TO A VALUE BETWEEN "DONE" AND THE MACHINE PRECISION. --- Reduced from 1.0D-11. 8/31/88 (EDG) --- LOGICAL FULMIX DIMENSION A(NDIM,1),EIVR(NVDIM,1),EIVU(1) IMPORTANT PARAMETERS: DATA DIFFER,DONE,EPS,PT99/1.0D-5,1.0D-13,0.5D-13,0.99D0/ DATA ZERO,ONE,FIVE/0.0D0,1.0D0,5.0D0/ FULMIX=.TRUE. IF(ICONTR.EQ.1) FULMIX=.FALSE. IF(N.GT.1) GO TO 10 EIVR(1,1)=ONE EIVU(1)=A(1,1) RETURN 10 CONTINUE DO 30 J=1,N DO 20 I=1,N 20 EIVR(I,J)=ZERO 30 EIVR(J,J)=ONE FIND THE ABSOLUTELY LARGEST ELEMENT OF A FIRST CHECK THE OFF-DIAGONAL ELEMENTS: ATOP=ZERO DO 50 J=2,N JM1=J-1 DO 50 I=1,JM1 IF(ATOP.GT.ABS(A(I,J))) GO TO 50 ATOP= ABS(A(I,J)) 50 CONTINUE OFFTOP=ATOP NOW CHECK THE DIAGONAL ELEMENTS: DO 60 J=1,N IF(ATOP.GT.ABS(A(J,J))) GO TO 60 ATOP= ABS(A(J,J)) 60 CONTINUE IF MATRIX IS ALREADY EFFECTIVELY DIAGONAL, PUT DIAGONAL ELEMENTS IN EIVU AND RETURN IF(ATOP.LT.DONE) GO TO 260 IF(OFFTOP.LT.DONE) GO TO 260 CALCULATE THE STOPPING CRITERION -- DSTOP AVGF= FLOAT(N*(N-1)/2) D=0.0D0 DO 80 JJ=2,N DO 80 II=2,JJ S=A(II-1,JJ)/ATOP 80 D=S*S+D DSTOP=(1.D-7)*D CALCULATE THE THRESHOLD, THRSH THRSH= SQRT(D/AVGF)*ATOP TO MAKE THRSH DIFFERENT THAN ANY MATRIX ELEMENT OF A, MULTIPLY BY 0.99 THRSH=THRSH*PT99 IF(THRSH.LT.DONE) THRSH=DONE START A SWEEP 90 IFLAG=0 DO 250 JCOL=2,N JCOL1=JCOL-1 DO 250 IROW=1,JCOL1 AIJ=A(IROW,JCOL) COMPARE THE OFF-DIAGONAL ELEMENT WITH THRSH ABSAIJ=ABS(AIJ) IF (ABSAIJ.LT.THRSH) GO TO 250 AII=A(IROW,IROW) AJJ=A(JCOL,JCOL) S=AJJ-AII ABSS=ABS(S) DON'T ROTATE THE VECTORS IROW AND JCOL IF IROW AND JCOL WOULD STILL BE DEGENERATE WITHIN "DIFFER": IF(FULMIX) GO TO 100 IF((ABSS.LT.DIFFER).AND.(ABSAIJ.LT.DIFFER)) GO TO 250 100 CONTINUE CHECK TO SEE IF THE CHOSEN ROTATION IS LESS THAN THE ROUNDING ERROR IF SO , THEN DO NOT ROTATE. TEST=EPS*ABSS IF (ABSAIJ.LT.TEST) GO TO 250 IFLAG=1 IF THE ROTATION IS VERY CLOSE TO 45 DEGREES, SET SIN AND COS TO 1/(ROOT 2). TEST=EPS*ABSAIJ IF (ABSS.GT.TEST) GO TO 130 S=.707106781D0 C=S GO TO 140 CALCULATION OF SIN AND COS FOR ROTATION THAT IS NOT VERY CLOSE TO 45 DEGREES 130 T=AIJ/S S=0.25D0/ SQRT(0.25D0+T*T) COS=C , SIN=S C= SQRT(0.5D0+S) S=2.D0*T*S/C CALCULATION OF THE NEW ELEMENTS OF MATRIX A 140 DO 150 I=1,IROW T=A(I,IROW) U=A(I,JCOL) A(I,IROW)=C*T-S*U 150 A(I,JCOL)=S*T+C*U I2=IROW+2 IF (I2.GT.JCOL) GO TO 180 DO 170 I=I2,JCOL T=A(I-1,JCOL) U=A(IROW,I-1) A(I-1,JCOL)=S*U+C*T 170 A(IROW,I-1)=C*U-S*T 180 A(JCOL,JCOL)=S*AIJ+C*AJJ A(IROW,IROW)=C*A(IROW,IROW)-S*(C*AIJ-S*AJJ) DO 190 J=JCOL,N T=A(IROW,J) U=A(JCOL,J) A(IROW,J)=C*T-S*U 190 A(JCOL,J)=S*T+C*U ROTATION COMPLETED DO 210 I=1,N T=EIVR(I,IROW) EIVR(I,IROW)=C*T-EIVR(I,JCOL)*S 210 EIVR(I,JCOL)=S*T+EIVR(I,JCOL)*C CALCULATE THE NEW NORM D AND COMPARE WITH DSTOP S=AIJ/ATOP D=D-S*S IF (D.GT.DSTOP) GO TO 240 RECALCULATE DSTOP AND THRSH TO DISCARD ROUNDING ERRORS D=ZERO DO 230 JJ=2,N DO 230 II=2,JJ S=A(II-1,JJ)/ATOP 230 D=S*S+D DSTOP=(1.D-7)*D 240 CONTINUE OLDTHR=THRSH THRSH= SQRT(D/AVGF)*ATOP*PT99 IF(THRSH.LT.DONE) THRSH=DONE*PT99 IF(THRSH.GT.OLDTHR) THRSH=OLDTHR 250 CONTINUE IF(THRSH.LT.DONE) GO TO 260 IF(IFLAG.EQ.1) GO TO 90 THRSH=THRSH/FIVE GO TO 90 PLACE EIGENVALUES IN EIVU 260 CONTINUE DO 270 J=1,N EIVU(J)=A(J,J) 270 CONTINUE RETURN END ***************************************************************************** SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION T(NDIM,NDIM),M(NCDIM),A(NCDIM,NCDIM),B(NCDIM) ...DO A LIMITED TRANSFORMATION OF T, INCLUDING ONLY THE "NC" ROWS AND COLUMNS SPECIFIED IN THE VECTOR "M": IOPT= 1 : TAKE T=T*A IOPT= 0 : TAKE T=A(TRANSPOSE)*T*A IOPT=-1 : TAKE T=A(TRANSPOSE)*T IF(IOPT.EQ.1) GO TO 100 FIRST, TAKE T=A(TRANSPOSE)*T, WHERE T=S,DM DO 30 J=1,NBAS DO 10 K=1,NC 10 B(K)=T(M(K),J) DO 30 I=1,NC SUM=0.0D0 DO 20 K=1,NC 20 SUM=SUM+A(K,I)*B(K) 30 T(M(I),J)=SUM IF(IOPT.EQ.-1) RETURN NOW, TAKE T=T*A 100 CONTINUE DO 160 I=1,NBAS DO 140 K=1,NC 140 B(K)=T(I,M(K)) DO 160 J=1,NC SUM=0.0D0 DO 150 K=1,NC 150 SUM=SUM+B(K)*A(K,J) 160 T(I,M(J))=SUM RETURN END ***************************************************************************** SUBROUTINE MATMLT(A,B,V,NDIM,N) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(1),B(1),V(NDIM) DATA ZERO/0.0D0/ MULTIPLY A*B (USING SCRATCH VECTOR V), STORE RESULT IN A: NDIF=NDIM-N DO 30 I=1,N KJ=0 IKK=I-NDIM DO 20 J=1,N IK=IKK TEMP=ZERO DO 10 K=1,N IK=IK+NDIM KJ=KJ+1 10 TEMP=TEMP+A(IK)*B(KJ) KJ=KJ+NDIF 20 V(J)=TEMP IJ=I-NDIM DO 30 J=1,N IJ=IJ+NDIM 30 A(IJ)=V(J) RETURN END ***************************************************************************** SUBROUTINE MATML2(A,B,V,NDIM,N) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(1),B(1),V(NDIM) DATA ZERO/0.0D0/ B=A(TRANSPOSE)*B MULTIPLY A(TRANSPOSE)*B (USING SCRATCH VECTOR V), STORE RESULT IN B: ASSUME A*B IS A SYMMETRIC MATRIX, SO ALMOST HALF THE WORK IS SAVED. THIS CAN BE THE SECOND STEP IN A SIMILARITY TRANSFORMATION OF B BY A. IJ=0 IJJ=-NDIM KJJ=-NDIM DO 50 J=1,N KII=-NDIM KJJ=KJJ+NDIM DO 20 I=1,J KII=KII+NDIM KI=KII KJ=KJJ TEMP=ZERO DO 10 K=1,N KI=KI+1 KJ=KJ+1 10 TEMP=TEMP+A(KI)*B(KJ) 20 V(I)=TEMP IJJ=IJJ+NDIM IJ=IJJ JI=J-NDIM JM1=J-1 DO 30 I=1,JM1 IJ=IJ+1 JI=JI+NDIM VV=V(I) B(IJ)=VV 30 B(JI)=VV IJ=IJ+1 50 B(IJ)=V(J) RETURN END ***************************************************************************** FUNCTION NAMEAT(IZ) ***************************************************************************** RETURN ATOMIC SYMBOL FOR NUCLEAR CHARGE IZ (.LE. 103): DIMENSION NAME(103) DATA IGHOST/'gh'/IBLANK/' '/ DATA NAME/' H','He','Li','Be',' B',' C',' N',' O',' F','Ne', + 'Na','Mg','Al','Si',' P',' S','Cl','Ar',' K','Ca','Sc','Ti', + ' V','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As', + 'Se','Br','Kr','Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru', + 'Rh','Pd','Ag','Cd','In','Sn','Sb','Te',' I','Xe','Cs', + 'Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy', + 'Ho','Er','Tm','Yb','Lu','Hf','Ta',' W','Re','Os','Ir', + 'Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn','Fr','Ra', + 'Ac','Th','Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es', + 'Fm','Md','No','Lr'/ IF(IZ.LT.0.OR.IZ.GT.103) NAMEAT = IBLANK IF(IZ.GT.0) NAMEAT = NAME(IZ) IF(IZ.EQ.0) NAMEAT = IGHOST RETURN END ***************************************************************************** SUBROUTINE NORMLZ(A,S,M,N) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(M,M),S(M,M) DATA ZERO,ONE /0.0D0,1.0D0/ NORMALIZE COLUMNS OF A DO 40 I = 1,N TEMP = ZERO DO 20 J = 1,N DO 10 K = 1,N TEMP = TEMP + A(J,I)*A(K,I)*S(J,K) 10 CONTINUE 20 CONTINUE FACTOR = ONE/SQRT(TEMP) DO 30 J = 1,N A(J,I) = FACTOR * A(J,I) 30 CONTINUE 40 CONTINUE RETURN END ***************************************************************************** SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) RANK POSITIVE ELEMENTS OF INTEGER 'LIST', LOWEST VALUES FIRST. INTEGER RANK,ARCRNK,TEMP DIMENSION RANK(NDIM),LIST(NDIM),ARCRNK(NDIM) DO 10 I=1,N 10 ARCRNK(I)=I DO 40 I=1,N IF(I.EQ.N)GO TO 30 I1=I+1 DO 20 J=I1,N IF(LIST(J).GE.LIST(I))GO TO 20 TEMP=LIST(I) LIST(I)=LIST(J) LIST(J)=TEMP TEMP=ARCRNK(I) ARCRNK(I)=ARCRNK(J) ARCRNK(J)=TEMP 20 CONTINUE 30 RANK(ARCRNK(I))=I IF(LIST(I).LE.0) GO TO 50 40 CONTINUE RETURN 50 DO 60 K=I,N RANK(ARCRNK(K))=0 60 CONTINUE RETURN END ***************************************************************************** SUBROUTINE PACK(T,NDIM,NBAS,L2) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION T(1) DATA ZERO/0.0D0/ PACK: PACKS A SYMMETRIC MATRIX T INTO AN UPPER TRIANGULAR MATRIX. T SHOULD BE DIMENSIONED (NDIM,NDIM) IN THE CALLING ROUTINE: IF(NBAS.GT.NDIM) STOP 'NBAS IS GREATER THAN NDIM' II = 0 DO 200 J = 1,NBAS JPTR = (J-1) * NDIM DO 100 I = 1,J IPTR = JPTR + I II = II + 1 T(II) = T(IPTR) 100 CONTINUE 200 CONTINUE IF(II.NE.L2) STOP 'ERROR IN ROUTINE PACK' DO 300 I = II+1,NDIM*NDIM T(I) = ZERO 300 CONTINUE RETURN END ***************************************************************************** SUBROUTINE RANK(EIG,N,NDIM,ARCRNK) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) ORDER NUMBERS IN 'EIG', HIGHEST VALUES FIRST, AND CONSTRUCT 'ARCRNK': ARCRNK(I) IS THE OLD LOCATION OF THE I-TH HIGHEST VALUE IN EIG NOTE: UPON RETURN, EIG(I) IS THE I-TH HIGHEST VALUE IN EIG IMPORTANT: NUMBERS IN EIG ARE NOT SWITCHED UNLESS THEY DIFFER BY MORE THAN "DIFFER": 5.0D-8 INTEGER ARCRNK DIMENSION ARCRNK(NDIM),EIG(NDIM) DATA DIFFER/5.0D-8/ DO 10 I=1,N 10 ARCRNK(I)=I DO 40 I=1,N IF(I.EQ.N)GO TO 40 I1=I+1 DO 20 J=I1,N IF((EIG(J)-EIG(I)).LT.DIFFER) GO TO 20 TEMP=EIG(I) EIG(I)=EIG(J) EIG(J)=TEMP ITEMP=ARCRNK(I) ARCRNK(I)=ARCRNK(J) ARCRNK(J)=ITEMP 20 CONTINUE 40 CONTINUE RETURN END ***************************************************************************** SUBROUTINE SIMTRN(A,T,V,NDIM,N) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SIMILARITY TRANSFORM A ==> T(TRANSPOSE)*A*T, USING SCRATCH VECTOR V. DIMENSION A(NDIM,NDIM),T(NDIM,NDIM),V(NDIM) CALL MATMLT(A,T,V,NDIM,N) CALL TRANSP(A,NDIM,N) CALL MATMLT(A,T,V,NDIM,N) CALL TRANSP(A,NDIM,N) RETURN END ***************************************************************************** SUBROUTINE SIMTRS(A,S,V,NDIM,N) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) SIMILARITY TRANSFORM A ==> S(TRANSPOSE)*A*S, USING SCRATCH VECTOR V. FAST VERSION --- ASSUMES RESULT IS A SYMMETRIC MATRIX DIMENSION A(NDIM,NDIM),S(NDIM,NDIM),V(NDIM) CALL MATMLT(A,S,V,NDIM,N) CALL MATML2(S,A,V,NDIM,N) RETURN END ***************************************************************************** SUBROUTINE TRANSP(A,NDIM,N) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(NDIM,NDIM) TRANSPOSE MATRIX A, STORE RESULT IN A. DO 10 I=1,N DO 10 J=1,I TEMP=A(I,J) A(I,J)=A(J,I) 10 A(J,I)=TEMP RETURN END ***************************************************************************** SUBROUTINE UNPACK(T,NDIM,NBAS,L2) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION T(1) UNPACK: UNPACKS AN UPPER TRIANGULAR MATRIX (VECTOR L2 LONG) INTO A SYMMETRIC MATRIX T(NBAS,NBAS). NOTE: T SHOULD BE DIMENSIONED (NDIM,NDIM) IN THE CALLING ROUTINE. FIRST SPREAD OUT THE L2 NUMBERS INTO THE UPPER PART OF THE WHOLE ARRAY. J = 0 K = 1 IPTR = (NDIM + 1)*(NBAS - K) + 1 DO 200 I = L2,1,-1 T(IPTR-J) = T(I) IF(J.LT.NBAS-K) THEN J = J + 1 ELSE J = 0 K = K + 1 IPTR = (NDIM + 1)*(NBAS - K) + 1 END IF 200 CONTINUE NOW FILL IN THE HOLES IN THE OUTPUT ARRAY. DO 400 J = 1,NBAS-1 ICOL = (J-1)*NDIM DO 300 I = J+1,NBAS IPTR = ICOL + I JPTR = (I-1)*NDIM + J T(IPTR) = T(JPTR) 300 CONTINUE 400 CONTINUE RETURN END ***************************************************************************** SUBROUTINE VALTBL(IAT,IVAL) ***************************************************************************** VALENCE TABLE: Determine the number of sets of valence orbitals of each angular symmetry for atom number IAT. IVAL is an integer array LMAX+1 long which returns the number of sets to the calling subroutine: the number of `s' subshells in IVAL(1), the number of `p' subshells in IVAL(2), etc... ------------------------------------------------------------------------------ IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (LMAX = 3) DIMENSION IVAL(4),ICORE(4),IORD(20) PARAMETER(MAXATM = 99,MAXBAS = 500) COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, + JCORE,JPRINT(60) DATA IORD/1,1,3,1,3,1,5,3,1,5,3,1,7,5,3,1,7,5,3,1/ DO 10 L = 0,LMAX IVAL(L+1) = 0 10 CONTINUE Count the number of filled or partially filled subshells: II = IATNO(IAT) IF(II.GT.0) THEN ICT = 0 20 ICT = ICT + 1 L = IORD(ICT)/2 IVAL(L+1) = IVAL(L+1) + 1 II = II - 2*IORD(ICT) IF(II.GT.0) GOTO 20 END IF Remove the core subshells. Note: if there are more core orbitals in the effective core potential than in the nominal core table or from the CORE option, remove these extra core orbitals from the set of valence orbitals: IECP = 1 CALL CORTBL(IAT,ICORE,IECP) DO 50 L = 0,LMAX IVAL(L+1) = IVAL(L+1) - ICORE(L+1) 50 CONTINUE IECP = 0 CALL CORTBL(IAT,ICORE,IECP) DO 60 L = 0,LMAX IF(ICORE(L+1).LT.0) THEN IVAL(L+1) = IVAL(L+1) + ICORE(L+1) END IF 60 CONTINUE RETURN END ***************************************************************************** FUNCTION VECLEN(X,N,NDIM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION X(NDIM) DATA ZERO/0.0D0/ SUM = ZERO DO 10 I = 1,N SUM = SUM + X(I)*X(I) 10 CONTINUE VECLEN = SQRT(SUM) RETURN END ***************************************************************************** SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR, + IERR) ***************************************************************************** Solve the system of linear equations A * X = B for matrix X ~ ~ ~ ~ Input ------- * Coefficient matrix A of dimension (N,N) with actual dimension (NDIM,NDIM). * Matrix B of dimension (N,M) with actual dimension (NDIM,MDIM) * Working space SCR dimensioned (NDIM,NDIM+5). * Zero tolerance ZERTOL. * Threshold on Euclidean norm (vector length) of the error vector relative to the norm of a column of X. * Maximum number of iterations MAXIT allowed during iterative improvement. * Logical file number LFNPR for printing during iterative improvement. Set to zero to no printing is desired. Output -------- * Solution X of dimension (N,M) with actual dimension (NDIM,MDIM). * Euclidean norm of the final error vector, EPS. * Number of iterations taken during interative improvement, MAXIT. * Error flag : IERR = -1 Iterative improvement did not converge IERR = 0 No errors encountered IERR = 1 A matrix is not invertible ------------------------------------------------------------------------------ IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(NDIM,NDIM),X(NDIM,MDIM),B(NDIM,MDIM), + SCR(NDIM*(NDIM+5)) DATA ZERO/0.0/ IF(N.LT.1) STOP 'Dimension N is not positive' Partition scratch space: I1 = 1 I2 = I1 + NDIM*NDIM I3 = I2 + NDIM I4 = I3 + NDIM I5 = I4 + NDIM I6 = I5 + NDIM Perform Gauss elimination with scaled partial pivoting: CALL FACTOR(A,SCR(I1),SCR(I2),SCR(I6),N,NDIM,ZERTOL,IFLAG) IF(IFLAG.EQ.0) THEN IERR = 1 RETURN ELSE IERR = 0 END IF Loop over columns of X and B: EPSMAX = ZERO ITSMAX = 0 DO 30 KCOL = 1,M DO 10 JROW = 1,N SCR(I4+JROW-1) = X(JROW,KCOL) SCR(I5+JROW-1) = B(JROW,KCOL) 10 CONTINUE ITS = MAXIT DEL = EPS Use back-substitution and iterative improvement to determine the solution X: CALL FNDSOL(A,SCR(I4),SCR(I5),SCR(I1),SCR(I2),SCR(I3),SCR(I6), + N,NDIM,DEL,ITS,LFNPR,IERR) IF(IERR.NE.0) RETURN Copy solution into X: DO 20 JROW = 1,N X(JROW,KCOL) = SCR(I4+JROW-1) 20 CONTINUE IF(DEL.GT.EPSMAX) EPSMAX = DEL IF(ITS.GT.ITSMAX) ITSMAX = ITS 30 CONTINUE EPS = EPSMAX MAXIT = ITSMAX RETURN END ***************************************************************************** SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(NDIM,NDIM),W(NDIM,NDIM),D(NDIM),IPIVOT(NDIM) DATA ZERO,ONE/0.0D0,1.0D0/ Initial IFLAG. If IFLAG is 1, then an even number of interchanges has been carried out. If equal to -1, then an odd number of inter- changes have taken place. If IFLAG is set to zero on return to the calling routine, then the matrix is not invertible: IFLAG = 1 Copy coefficient matrix A to W: CALL COPY(A,W,NDIM,N,N) Initialize D and IPIVOT: DO 20 I = 1,N IPIVOT(I) = I ROWMAX = ZERO DO 10 J = 1,N IF(ABS(W(I,J)).GT.ROWMAX) ROWMAX = ABS(W(I,J)) 10 CONTINUE IF(ROWMAX.LE.ZERTOL) THEN IFLAG = 0 ROWMAX = ONE END IF D(I) = ROWMAX 20 CONTINUE IF(N.EQ.1) RETURN Loop over rows, factorizing matrix W: DO 100 K = 1,N-1 Determine the pivot row ISTAR: COLMAX = ABS(W(K,K))/D(K) ISTAR = K DO 30 I = K+1,N TEMP = ABS(W(I,K))/D(K) IF(TEMP.GT.COLMAX) THEN COLMAX = TEMP ISTAR = I END IF 30 CONTINUE IF(COLMAX.EQ.ZERO) THEN IFLAG = 0 ELSE IF(ISTAR.GT.K) THEN IFLAG = -IFLAG ITEMP = IPIVOT(ISTAR) IPIVOT(ISTAR) = IPIVOT(K) IPIVOT(K) = ITEMP TEMP = D(ISTAR) D(ISTAR) = D(K) D(K) = TEMP DO 40 J = 1,N TEMP = W(ISTAR,J) W(ISTAR,J) = W(K,J) W(K,J) = TEMP 40 CONTINUE END IF Eliminate X(K) from rows K+1,...,N: DO 60 I = K+1,N W(I,K) = W(I,K)/W(K,K) DO 50 J = K+1,N W(I,J) = W(I,J) - W(I,K)*W(K,J) 50 CONTINUE 60 CONTINUE END IF 100 CONTINUE IF(ABS(W(N,N)).LE.ZERTOL) IFLAG = 0 RETURN END ***************************************************************************** SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(NDIM,NDIM),X(NDIM),B(NDIM),W(NDIM,NDIM),R(NDIM), + E(NDIM),IPIVOT(NDIM) DATA ZERO/0.0D0/ Find initial guess for X by back substitution: CALL COPY(B,E,NDIM,N,1) CALL SUBST(X,W,E,IPIVOT,N,NDIM) IF(MAXIT.EQ.0) RETURN Iterate until the vector length of the error vector relative to X is less than EPS: RELLEN = ZERO ITER = 0 10 IF(RELLEN.GT.EPS) THEN ITER = ITER + 1 DO 30 I = 1,N R(I) = B(I) DO 20 J = 1,N R(I) = R(I) - A(I,J)*X(J) 20 CONTINUE 30 CONTINUE CALL SUBST(E,W,R,IPIVOT,N,NDIM) ELEN = VECLEN(E,N,NDIM) XLEN = VECLEN(X,N,NDIM) RELLEN = ELEN/XLEN DO 40 I = 1,N X(I) = X(I) + E(I) 40 CONTINUE Print out iterative improvement info: IF(LFNPR.GT.0) THEN WRITE(LFNPR,900) ITER,RELLEN END IF If too many iterations have taken place, halt furthur iterations: IF(ITER.EQ.MAXIT) THEN IF(RELLEN.GT.EPS) IERR = -1 IF(LFNPR.GT.0) THEN IF(IERR.LT.0) THEN WRITE(LFNPR,910) ELSE WRITE(LFNPR,920) END IF END IF EPS = RELLEN RETURN END IF Error vector is converged: ELSE IF(LFNPR.GT.0) WRITE(LFNPR,920) EPS = RELLEN MAXIT = ITER RETURN END IF GOTO 10 900 FORMAT(1X,'Iter = ',I3,' relative length = ',F10.7) 910 FORMAT(1X,'No convergence within the specified number of ', + 'iterations') 920 FORMAT(1X,'The error vector is converged') END ***************************************************************************** SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM) ***************************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION X(NDIM),W(NDIM,NDIM),B(NDIM),IPIVOT(NDIM) DATA ZERO/0.0D0/ IF(N.EQ.1) THEN X(1) = B(1)/W(1,1) RETURN END IF Use multipliers stored in W and back substitution to find X: IP = IPIVOT(1) X(1) = B(IP) DO 20 I = 2,N SUM = ZERO DO 10 J = 1,I-1 SUM = W(I,J)*X(J) + SUM 10 CONTINUE IP = IPIVOT(I) X(I) = B(IP) - SUM 20 CONTINUE X(N) = X(N)/W(N,N) DO 40 I = N-1,1,-1 SUM = ZERO DO 30 J = I+1,N SUM = W(I,J)*X(J) + SUM 30 CONTINUE X(I) = (X(I) - SUM)/W(I,I) 40 CONTINUE RETURN END ***************************************************************************** E N D O F N B O P R O G R A M ***************************************************************************** ***********************************************************************GENDRV GENDRV GENDRV G E N N B O GENDRV GENDRV GENDRV GENERAL VERSION OF NBO PROGRAM GENDRV GENDRV GENDRV DRIVER ROUTINES: GENDRV GENDRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GENDRV SUBROUTINE CRDINP(TITLE,ATCOOR,BOHR) GENDRV SUBROUTINE BASINP GENDRV SUBROUTINE CONINP(CORE,ICORE) GENDRV SUBROUTINE SINP(CORE,UPPER) GENDRV SUBROUTINE DMINP(CORE,UPPER) GENDRV SUBROUTINE FINP(CORE,UPPER,END) GENDRV SUBROUTINE TINP(CORE) GENDRV SUBROUTINE DIPINP(CORE,UPPER,BOHR) GENDRV GENDRV ***********************************************************************GENDRV PROGRAM GENNBO GENDRV ***********************************************************************GENDRV IMPLICIT REAL*8 (A-H,O-Z) GENDRV GENDRV PARAMETER(MEMORY = 1000000) GENDRV DIMENSION CORE(MEMORY),NBOOPT(10) GENDRV GENDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV + LFNDAF,LFNDEF GENDRV GENDRV LFNIN = 5 GENDRV LFNPR = 6 GENDRV GENDRV Set NBO options. GENDRV GENDRV NBOOPT(1) = 0 GENDRV NBOOPT(2) = 0 GENDRV NBOOPT(3) = 0 GENDRV NBOOPT(4) = 0 GENDRV NBOOPT(5) = 0 GENDRV NBOOPT(6) = 0 GENDRV NBOOPT(7) = 0 GENDRV NBOOPT(8) = 0 GENDRV NBOOPT(9) = 0 GENDRV NBOOPT(10) = 0 GENDRV GENDRV Perform the NPA/NBO/NLMO analyses. GENDRV GENDRV CALL NBO(CORE,MEMORY,NBOOPT) GENDRV GENDRV CALL EXIT GENDRV END GENDRV ***********************************************************************GENDRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GENDRV ***********************************************************************GENDRV IMPLICIT REAL*8 (A-H,O-Z) GENDRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) GENDRV LOGICAL END GENDRV GENDRV PARAMETER(MAXATM = 99,MAXBAS = 500) GENDRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, GENDRV + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, GENDRV + JCORE,JPRINT(60) GENDRV COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) GENDRV COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), GENDRV + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) GENDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV + LFNDAF,LFNDEF GENDRV COMMON/NBGEN/REUSE,UPPER,BOHR,DENOP GENDRV LOGICAL REUSE,UPPER,BOHR,DENOP GENDRV GENDRV IF(REUSE) THEN GENDRV GENDRV Restore wavefunction information from the NBO DAF: GENDRV GENDRV Restore NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: GENDRV GENDRV NFILE = 3 GENDRV CALL NBREAD(ICORE,12,NFILE) GENDRV II = 0 GENDRV II = II + 1 GENDRV NATOMS = ICORE(II) GENDRV II = II + 1 GENDRV NDIM = ICORE(II) GENDRV II = II + 1 GENDRV NBAS = ICORE(II) GENDRV II = II + 1 GENDRV MUNIT = ICORE(II) GENDRV II = II + 1 GENDRV ROHF = .FALSE. GENDRV IF(ICORE(II).EQ.1) ROHF = .TRUE. GENDRV II = II + 1 GENDRV UHF = .FALSE. GENDRV IF(ICORE(II).EQ.1) UHF = .TRUE. GENDRV II = II + 1 GENDRV CI = .FALSE. GENDRV IF(ICORE(II).EQ.1) CI = .TRUE. GENDRV II = II + 1 GENDRV OPEN = .FALSE. GENDRV IF(ICORE(II).EQ.1) OPEN = .TRUE. GENDRV II = II + 1 GENDRV MCSCF = .FALSE. GENDRV IF(ICORE(II).EQ.1) MCSCF = .TRUE. GENDRV II = II + 1 GENDRV AUHF = .FALSE. GENDRV IF(ICORE(II).EQ.1) AUHF = .TRUE. GENDRV II = II + 1 GENDRV ORTHO = .FALSE. GENDRV IF(ICORE(II).EQ.1) ORTHO = .TRUE. GENDRV II = II + 1 GENDRV ISWEAN = ICORE(II) GENDRV GENDRV No Fock matrix from ROHF, MCSCF, or CI wave functions: GENDRV GENDRV IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 GENDRV GENDRV Restore IATNO, IZNUC, LCTR, LANG: GENDRV GENDRV NFILE = 4 GENDRV CALL NBREAD(ICORE,2*NATOMS+2*NBAS,NFILE) GENDRV II = 0 GENDRV DO 70 I = 1,NATOMS GENDRV II = II + 1 GENDRV IATNO(I) = ICORE(II) GENDRV 70 CONTINUE GENDRV DO 80 I = 1,NATOMS GENDRV II = II + 1 GENDRV IZNUC(I) = ICORE(II) GENDRV IF(IZNUC(I).NE.IATNO(I)) IPSEUD = 1 GENDRV 80 CONTINUE GENDRV DO 90 I = 1,NBAS GENDRV II = II + 1 GENDRV LCTR(I) = ICORE(II) GENDRV 90 CONTINUE GENDRV DO 95 I = 1,NBAS GENDRV II = II + 1 GENDRV LANG(I) = ICORE(II) GENDRV 95 CONTINUE GENDRV ELSE GENDRV GENDRV Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: GENDRV GENDRV II = 0 GENDRV II = II + 1 GENDRV ICORE(II) = NATOMS GENDRV II = II + 1 GENDRV ICORE(II) = NDIM GENDRV II = II + 1 GENDRV ICORE(II) = NBAS GENDRV II = II + 1 GENDRV ICORE(II) = MUNIT GENDRV II = II + 1 GENDRV ICORE(II) = 0 GENDRV IF(ROHF) ICORE(II) = 1 GENDRV II = II + 1 GENDRV ICORE(II) = 0 GENDRV IF(UHF) ICORE(II) = 1 GENDRV II = II + 1 GENDRV ICORE(II) = 0 GENDRV IF(CI) ICORE(II) = 1 GENDRV II = II + 1 GENDRV ICORE(II) = 0 GENDRV IF(OPEN) ICORE(II) = 1 GENDRV II = II + 1 GENDRV ICORE(II) = 0 GENDRV IF(MCSCF) ICORE(II) = 1 GENDRV II = II + 1 GENDRV ICORE(II) = 0 GENDRV IF(AUHF) ICORE(II) = 1 GENDRV II = II + 1 GENDRV ICORE(II) = 0 GENDRV IF(ORTHO) ICORE(II) = 1 GENDRV II = II + 1 GENDRV ICORE(II) = 1 GENDRV NFILE = 3 GENDRV CALL NBWRIT(ICORE,12,NFILE) GENDRV GENDRV Read wavefunction info, density matrix, etc. from LFNIN: GENDRV GENDRV Read in job title, atoms, nuclear charges, and coords: GENDRV GENDRV CALL CRDINP(CORE,CORE,BOHR) GENDRV GENDRV Read in the AO basis set: GENDRV GENDRV CALL CONINP(CORE,CORE) GENDRV GENDRV Read basis function labels and centers: GENDRV GENDRV CALL BASINP GENDRV GENDRV Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: GENDRV GENDRV II = 0 GENDRV DO 170 I = 1,NATOMS GENDRV II = II + 1 GENDRV ICORE(II) = IATNO(I) GENDRV 170 CONTINUE GENDRV DO 180 I = 1,NATOMS GENDRV II = II + 1 GENDRV ICORE(II) = IZNUC(I) GENDRV 180 CONTINUE GENDRV DO 190 I = 1,NBAS GENDRV II = II + 1 GENDRV ICORE(II) = LCTR(I) GENDRV 190 CONTINUE GENDRV DO 200 I = 1,NBAS GENDRV II = II + 1 GENDRV ICORE(II) = LANG(I) GENDRV 200 CONTINUE GENDRV NFILE = 4 GENDRV CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) GENDRV GENDRV Read the overlap matrix from LFNIN and store on the NBO DAF: GENDRV GENDRV IF(.NOT.ORTHO) CALL SINP(CORE,UPPER) GENDRV GENDRV Read the density matrix from LFNIN and store on the NBO DAF: GENDRV GENDRV CALL DMINP(CORE,UPPER) GENDRV IF(DENOP) IWDM = 0 GENDRV GENDRV Read the Fock matrix from LFNIN and store on the NBO DAF: GENDRV GENDRV CALL FINP(CORE,UPPER,END) GENDRV IF(END) THEN GENDRV IWFOCK = 0 GENDRV IF(OPEN) ROHF = .TRUE. GENDRV ELSE GENDRV IWFOCK = 1 GENDRV IF(OPEN) UHF = .TRUE. GENDRV END IF GENDRV GENDRV Read the AO to MO transformation matrix from LFNIN and store on the GENDRV NBO DAF: GENDRV GENDRV CALL TINP(CORE) GENDRV GENDRV Read the dipole integrals from LFNIN and store on the NBO DAF: GENDRV GENDRV CALL DIPINP(CORE,UPPER,BOHR) GENDRV END IF GENDRV RETURN GENDRV END GENDRV ***********************************************************************GENDRV SUBROUTINE CRDINP(TITLE,ATCOOR,BOHR) GENDRV ***********************************************************************GENDRV IMPLICIT REAL*8 (A-H,O-Z) GENDRV DIMENSION KEYWD(6),KCOORD(6) GENDRV LOGICAL ERROR,END,BOHR,EQUAL GENDRV GENDRV PARAMETER(MAXATM = 99,MAXBAS = 500) GENDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, GENDRV + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, GENDRV + JCORE,JPRINT(60) GENDRV COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), GENDRV + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) GENDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV + LFNDAF,LFNDEF GENDRV GENDRV DIMENSION TITLE(10),ATCOOR(3*NATOMS) GENDRV GENDRV DATA KCOORD/1H$,1HC,1HO,1HO,1HR,1HD/ GENDRV DATA TOANG/0.529177249/ GENDRV GENDRV Search LFNIN for $COORD datalist: GENDRV GENDRV REWIND(LFNIN) GENDRV 10 CALL STRTIN(LFNIN) GENDRV LEN = 6 GENDRV CALL HFLD(KEYWD,LEN,END) GENDRV IF(LEN.EQ.0.AND.END) STOP 'No $COORD datalist in the input file' GENDRV IF(.NOT.EQUAL(KEYWD,KCOORD,6)) GOTO 10 GENDRV GENDRV Read job title and store on NBO DAF: GENDRV GENDRV READ(LFNIN,1000) (TITLE(I),I=1,10) GENDRV NFILE = 2 GENDRV CALL NBWRIT(TITLE,10,NFILE) GENDRV GENDRV Loop over atoms, reading atomic number, nuclear charge, and coords: GENDRV GENDRV II = 0 GENDRV CALL STRTIN(LFNIN) GENDRV DO 100 IAT = 1,NATOMS GENDRV CALL IFLD(IATNO(IAT),ERROR) GENDRV IF(ERROR) STOP 'Error reading atomic number' GENDRV CALL IFLD(IZNUC(IAT),ERROR) GENDRV IF(ERROR) STOP 'Error reading nuclear charge' GENDRV IF(IATNO(IAT).NE.IZNUC(IAT)) IPSEUD = 1 GENDRV II = II + 1 GENDRV CALL RFLD(ATCOOR(II),ERROR) GENDRV IF(ERROR) STOP 'Error reading x coordinate' GENDRV II = II + 1 GENDRV CALL RFLD(ATCOOR(II),ERROR) GENDRV IF(ERROR) STOP 'Error reading y coordinate' GENDRV II = II + 1 GENDRV CALL RFLD(ATCOOR(II),ERROR) GENDRV IF(ERROR) STOP 'Error reading z coordinate' GENDRV 100 CONTINUE GENDRV GENDRV Convert atomic coords to angstroms if entered in bohr: GENDRV GENDRV IF(BOHR) THEN GENDRV DO 200 I = 1,3*NATOMS GENDRV ATCOOR(I) = ATCOOR(I) * TOANG GENDRV 200 CONTINUE GENDRV END IF GENDRV GENDRV Store the atomic coordinates on the NBO DAF: GENDRV GENDRV NFILE = 9 GENDRV CALL NBWRIT(ATCOOR,3*NATOMS,NFILE) GENDRV RETURN GENDRV GENDRV 1000 FORMAT(10A8) GENDRV END GENDRV ***********************************************************************GENDRV SUBROUTINE BASINP GENDRV ***********************************************************************GENDRV IMPLICIT REAL*8 (A-H,O-Z) GENDRV DIMENSION KEYWD(6),KBASIS(6),KCTR(6),KLABEL(5),KEND(4) GENDRV LOGICAL ERROR,END,EQUAL GENDRV GENDRV PARAMETER(MAXATM = 99,MAXBAS = 500) GENDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) GENDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV + LFNDAF,LFNDEF GENDRV GENDRV DATA KBASIS/1H$,1HB,1HA,1HS,1HI,1HS/,KLABEL/1HL,1HA,1HB,1HE,1HL/, GENDRV + KCTR/1HC,1HE,1HN,1HT,1HE,1HR/,KEND/1H$,1HE,1HN,1HD/ GENDRV GENDRV Search LFNIN for $BASIS datalist: GENDRV GENDRV REWIND(LFNIN) GENDRV 10 CALL STRTIN(LFNIN) GENDRV LEN = 6 GENDRV CALL HFLD(KEYWD,LEN,END) GENDRV IF(LEN.EQ.0.AND.END) STOP 'No $BASIS datalist in the input file' GENDRV IF(.NOT.EQUAL(KEYWD,KBASIS,6)) GOTO 10 GENDRV GENDRV Read in BOTH LCTR and LANG arrays: GENDRV GENDRV MCTR = 0 GENDRV MANG = 0 GENDRV 20 LEN = 6 GENDRV CALL HFLD(KEYWD,LEN,END) GENDRV IF(END) STOP 'End encountered while reading $BASIS datalist' GENDRV IF(EQUAL(KEYWD,KEND,4)) GOTO 100 GENDRV GENDRV Keyword CENTER -- basis function centers: GENDRV GENDRV IF(EQUAL(KEYWD,KCTR,6)) THEN GENDRV DO 30 I = 1,NBAS GENDRV CALL IFLD(LCTR(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading orbital centers in $BASIS' GENDRV 30 CONTINUE GENDRV MCTR = 1 GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV Keyword LABEL -- basis orbital symmetries: GENDRV GENDRV IF(EQUAL(KEYWD,KLABEL,5)) THEN GENDRV DO 40 I = 1,NBAS GENDRV CALL IFLD(LANG(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading orbital labels in $BASIS' GENDRV 40 CONTINUE GENDRV MANG = 1 GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV Unknown keyword -- halt program: GENDRV GENDRV WRITE(LFNPR,900) KEYWD GENDRV STOP GENDRV GENDRV Make sure that both the orbital centers and symmetries are read: GENDRV GENDRV 100 CONTINUE GENDRV IF(MCTR.EQ.0) STOP 'Missing orbital centers in $BASIS datalist' GENDRV IF(MANG.EQ.0) STOP 'Missing orbital labels in $BASIS datalist' GENDRV RETURN GENDRV GENDRV 900 FORMAT(1X,'Unrecognized keyword >',6A1,'<') GENDRV END GENDRV ***********************************************************************GENDRV SUBROUTINE CONINP(CORE,ICORE) GENDRV ***********************************************************************GENDRV IMPLICIT REAL*8 (A-H,O-Z) GENDRV LOGICAL ERROR,END,EQUAL GENDRV GENDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV + LFNDAF,LFNDEF GENDRV GENDRV DIMENSION CORE(1),ICORE(1) GENDRV DIMENSION KEYWD(6),KCONTR(6),KNSHLL(6),KNEXP(4),KNCOMP(5), GENDRV + KNPRIM(5),KNPTR(4),KEXP(3),KCS(2),KCP(2),KCD(2),KCF(2),KEND(4) GENDRV GENDRV DATA KCONTR/1H$,1HC,1HO,1HN,1HT,1HR/,KNEXP/1HN,1HE,1HX,1HP/, GENDRV + KNSHLL/1HN,1HS,1HH,1HE,1HL,1HL/,KNCOMP/1HN,1HC,1HO,1HM,1HP/, GENDRV + KNPRIM/1HN,1HP,1HR,1HI,1HM/,KEXP/1HE,1HX,1HP/,KCS/1HC,1HS/, GENDRV + KCP/1HC,1HP/,KCD/1HC,1HD/,KCF/1HC,1HF/,KEND/1H$,1HE,1HN,1HD/,GENDRV + KNPTR/1HN,1HP,1HT,1HR/ GENDRV DATA ZERO/0.0D0/ GENDRV GENDRV Search LFNIN for the $CONTRACT datalist: GENDRV GENDRV REWIND(LFNIN) GENDRV 10 CALL STRTIN(LFNIN) GENDRV LEN = 6 GENDRV CALL HFLD(KEYWD,LEN,END) GENDRV IF(LEN.EQ.0.AND.END) RETURN GENDRV IF(.NOT.EQUAL(KEYWD,KCONTR,6)) GOTO 10 GENDRV GENDRV MSHELL = 0 GENDRV MEXP = 0 GENDRV MCOMP = 0 GENDRV MPRIM = 0 GENDRV MPTR = 0 GENDRV MEXP = 0 GENDRV 20 LEN = 6 GENDRV CALL HFLD(KEYWD,LEN,END) GENDRV IF(END) STOP 'End encountered while reading $CONTRACT datalist' GENDRV GENDRV Keyword NSHELL -- number of shells of basis functions: GENDRV GENDRV IF(EQUAL(KEYWD,KNSHLL,6)) THEN GENDRV CALL IFLD(NSHELL,ERROR) GENDRV IF(ERROR) STOP 'Error reading number of shells in $CONTRACT' GENDRV MSHELL = 1 GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV Keyword NEXP -- number of orbital exponents in basis: GENDRV GENDRV IF(EQUAL(KEYWD,KNEXP,4)) THEN GENDRV CALL IFLD(NEXP,ERROR) GENDRV IF(ERROR) STOP 'Error reading number of exponents in $CONTRACT' GENDRV MEXP = 1 GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV If NSHELL and NEXP are not specified before the remainder of the GENDRV datalist, abort: GENDRV GENDRV IF(MSHELL.EQ.0.OR.MEXP.EQ.0) THEN GENDRV WRITE(LFNPR,900) GENDRV STOP GENDRV END IF GENDRV GENDRV If NSHELL and NEXP have been specified, partition the scratch vector:GENDRV GENDRV ICORE(I1) : NCOMP(1..NSHELL) GENDRV ICORE(I2) : NPRIM(1..NSHELL) GENDRV ICORE(I3) : NPTR(1..NSHELL) GENDRV CORE(I4) : EXP(1..NEXP) GENDRV CORE(I5) : CS(1..NEXP) GENDRV CORE(I6) : CP(1..NEXP) GENDRV CORE(I7) : CD(1..NEXP) GENDRV CORE(I8) : CF(1..NEXP) GENDRV GENDRV IF(MSHELL.EQ.1.AND.MEXP.EQ.1) THEN GENDRV I1 = 3 GENDRV I2 = I1 + NSHELL GENDRV I3 = I2 + NSHELL GENDRV I4 = I3 + NSHELL GENDRV I5 = I4 + NEXP GENDRV I6 = I5 + NEXP GENDRV I7 = I6 + NEXP GENDRV I8 = I7 + NEXP GENDRV IEND = I8 + NEXP GENDRV DO 30 I = 1,IEND-1 GENDRV CORE(I) = ZERO GENDRV 30 CONTINUE GENDRV II = 0 GENDRV II = II + 1 GENDRV ICORE(II) = NSHELL GENDRV II = II + 1 GENDRV ICORE(II) = NEXP GENDRV MSHELL = 2 GENDRV MEXP = 2 GENDRV END IF GENDRV GENDRV Keyword NCOMP -- number of components in each shell: GENDRV GENDRV IF(EQUAL(KEYWD,KNCOMP,5)) THEN GENDRV DO 40 I = I1,I1+NSHELL-1 GENDRV CALL IFLD(ICORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading components in $CONTRACT' GENDRV 40 CONTINUE GENDRV MCOMP = 1 GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV Keyword NPRIM -- number of primitives in each shell: GENDRV GENDRV IF(EQUAL(KEYWD,KNPRIM,5)) THEN GENDRV DO 50 I = I2,I2+NSHELL-1 GENDRV CALL IFLD(ICORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading primitives in $CONTRACT' GENDRV 50 CONTINUE GENDRV MPRIM = 1 GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV Keyword NPTR -- pointer array into exponents and coefficients: GENDRV GENDRV IF(EQUAL(KEYWD,KNPTR,4)) THEN GENDRV DO 60 I = I3,I3+NSHELL-1 GENDRV CALL IFLD(ICORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading pointers in $CONTRACT' GENDRV 60 CONTINUE GENDRV MPTR = 1 GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV Keyword EXP -- orbital exponents: GENDRV GENDRV IF(EQUAL(KEYWD,KEXP,3)) THEN GENDRV DO 70 I = I4,I4+NEXP-1 GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading exponents in $CONTRACT' GENDRV 70 CONTINUE GENDRV MEXP = 1 GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV Keyword CS -- s orbital coefficients: GENDRV GENDRV IF(EQUAL(KEYWD,KCS,2)) THEN GENDRV DO 80 I = I5,I5+NEXP-1 GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading s coefficients in $CONTRACT' GENDRV 80 CONTINUE GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV Keyword CP -- p orbital coefficients: GENDRV GENDRV IF(EQUAL(KEYWD,KCP,2)) THEN GENDRV DO 90 I = I6,I6+NEXP-1 GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading p coefficients in $CONTRACT' GENDRV 90 CONTINUE GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV Keyword CD -- d orbital coefficients: GENDRV GENDRV IF(EQUAL(KEYWD,KCD,2)) THEN GENDRV DO 100 I = I7,I7+NEXP-1 GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading d coefficients in $CONTRACT' GENDRV 100 CONTINUE GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV Keyword CF -- f orbital coefficients: GENDRV GENDRV IF(EQUAL(KEYWD,KCF,2)) THEN GENDRV DO 110 I = I8,I8+NEXP-1 GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading f coefficients in $CONTRACT' GENDRV 110 CONTINUE GENDRV GOTO 20 GENDRV END IF GENDRV GENDRV $END -- $CONTRACT datalist complete: GENDRV GENDRV IF(EQUAL(KEYWD,KEND,4)) THEN GENDRV IF(MCOMP.EQ.0) STOP 'Missing NCOMP array in $CONTRACT' GENDRV IF(MPRIM.EQ.0) STOP 'Missing NPRIM array in $CONTRACT' GENDRV IF(MPTR.EQ.0) STOP 'Missing NPTR array in $CONTRACT' GENDRV IF(MEXP.EQ.0) STOP 'Missing EXP array in $CONTRACT' GENDRV GENDRV Write info obtained in the datalist on the NBO DAF: GENDRV GENDRV LEN = IEND - 1 GENDRV NFILE = 5 GENDRV CALL NBWRIT(CORE,LEN,NFILE) GENDRV RETURN GENDRV END IF GENDRV GENDRV Unknown keyword -- halt program: GENDRV GENDRV WRITE(LFNPR,910) KEYWD GENDRV STOP GENDRV GENDRV 900 FORMAT(/1X,'NSHELL and NEXP should appear at the beginning of ', GENDRV + 'the $CONTRACT datalist') GENDRV 910 FORMAT(1X,'Unrecognized keyword >',6A1,'<') GENDRV END GENDRV ***********************************************************************GENDRV SUBROUTINE SINP(CORE,UPPER) GENDRV ***********************************************************************GENDRV IMPLICIT REAL*8 (A-H,O-Z) GENDRV DIMENSION CORE(1) GENDRV DIMENSION KEYWD(6),KOVER(5) GENDRV LOGICAL UPPER,ERROR,END,EQUAL GENDRV GENDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV + LFNDAF,LFNDEF GENDRV GENDRV DATA KOVER/1H$,1HO,1HV,1HE,1HR/ GENDRV GENDRV Search LFNIN for $OVERLAP datalist: GENDRV GENDRV REWIND(LFNIN) GENDRV 10 CALL STRTIN(LFNIN) GENDRV LEN = 6 GENDRV CALL HFLD(KEYWD,LEN,END) GENDRV IF(LEN.EQ.0.AND.END) STOP 'No $OVERLAP found in the input file' GENDRV IF(.NOT.EQUAL(KEYWD,KOVER,5)) GOTO 10 GENDRV GENDRV Number of elements to read in: GENDRV GENDRV NEL = NDIM*NDIM GENDRV IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV GENDRV Read in the AO overlap matrix: GENDRV GENDRV DO 20 I = 1,NEL GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading AO overlap matrix' GENDRV 20 CONTINUE GENDRV NEL = NDIM*(NDIM+1)/2 GENDRV IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV GENDRV Store the overlap matrix on the NBO DAF: GENDRV GENDRV NFILE = 10 GENDRV CALL NBWRIT(CORE,NEL,NFILE) GENDRV RETURN GENDRV END GENDRV ***********************************************************************GENDRV SUBROUTINE DMINP(CORE,UPPER) GENDRV ***********************************************************************GENDRV IMPLICIT REAL*8 (A-H,O-Z) GENDRV DIMENSION CORE(1) GENDRV DIMENSION KEYWD(6),KDENS(5) GENDRV LOGICAL UPPER,ERROR,END,EQUAL GENDRV GENDRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV + LFNDAF,LFNDEF GENDRV GENDRV DATA KDENS/1H$,1HD,1HE,1HN,1HS/ GENDRV GENDRV Search LFNIN for $DENSITY datalist: GENDRV GENDRV REWIND(LFNIN) GENDRV 10 CALL STRTIN(LFNIN) GENDRV LEN = 6 GENDRV CALL HFLD(KEYWD,LEN,END) GENDRV IF(LEN.EQ.0.AND.END) STOP 'No $DENSITY found in the input file' GENDRV IF(.NOT.EQUAL(KEYWD,KDENS,5)) GOTO 10 GENDRV GENDRV Number of elements to read in: GENDRV GENDRV NEL = NDIM*NDIM GENDRV IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV GENDRV Read in the AO density matrix: GENDRV GENDRV DO 20 I = 1,NEL GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading AO density matrix' GENDRV 20 CONTINUE GENDRV NEL = NDIM*(NDIM+1)/2 GENDRV IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV GENDRV Store the density matrix on the NBO DAF: GENDRV GENDRV NFILE = 20 GENDRV CALL NBWRIT(CORE,NEL,NFILE) GENDRV GENDRV Read in and store the beta density matrix if this is open shell: GENDRV GENDRV IF(OPEN) THEN GENDRV NEL = NDIM*NDIM GENDRV IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV DO 30 I = 1,NEL GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading beta AO density matrix' GENDRV 30 CONTINUE GENDRV NEL = NDIM*(NDIM+1)/2 GENDRV IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV NFILE = 21 GENDRV CALL NBWRIT(CORE,NEL,NFILE) GENDRV END IF GENDRV RETURN GENDRV END GENDRV ***********************************************************************GENDRV SUBROUTINE FINP(CORE,UPPER,END) GENDRV ***********************************************************************GENDRV IMPLICIT REAL*8 (A-H,O-Z) GENDRV DIMENSION CORE(1) GENDRV DIMENSION KEYWD(6),KFOCK(5) GENDRV LOGICAL UPPER,ERROR,END,EQUAL GENDRV GENDRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV + LFNDAF,LFNDEF GENDRV GENDRV DATA KFOCK/1H$,1HF,1HO,1HC,1HK/ GENDRV GENDRV Search LFNIN for $FOCK datalist: GENDRV GENDRV REWIND(LFNIN) GENDRV 10 CALL STRTIN(LFNIN) GENDRV LEN = 6 GENDRV CALL HFLD(KEYWD,LEN,END) GENDRV IF(LEN.EQ.0.AND.END) RETURN GENDRV IF(.NOT.EQUAL(KEYWD,KFOCK,5)) GOTO 10 GENDRV GENDRV Number of elements to read in: GENDRV GENDRV NEL = NDIM*NDIM GENDRV IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV GENDRV Read in the AO Fock matrix: GENDRV GENDRV DO 20 I = 1,NEL GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading AO Fock matrix' GENDRV 20 CONTINUE GENDRV NEL = NDIM*(NDIM+1)/2 GENDRV IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV GENDRV Store the Fock matrix on the NBO DAF: GENDRV GENDRV NFILE = 30 GENDRV CALL NBWRIT(CORE,NEL,NFILE) GENDRV GENDRV Read in and store the beta Fock matrix if this is open shell: GENDRV GENDRV IF(OPEN) THEN GENDRV NEL = NDIM*NDIM GENDRV IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV DO 30 I = 1,NEL GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading beta AO Fock matrix' GENDRV 30 CONTINUE GENDRV NEL = NDIM*(NDIM+1)/2 GENDRV IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV NFILE = 31 GENDRV CALL NBWRIT(CORE,NEL,NFILE) GENDRV END IF GENDRV END = .FALSE. GENDRV RETURN GENDRV END GENDRV ***********************************************************************GENDRV SUBROUTINE TINP(CORE) GENDRV ***********************************************************************GENDRV IMPLICIT REAL*8 (A-H,O-Z) GENDRV DIMENSION CORE(1) GENDRV DIMENSION KEYWD(6),KAOMO(7) GENDRV LOGICAL ERROR,END,EQUAL GENDRV GENDRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV + LFNDAF,LFNDEF GENDRV GENDRV DATA KAOMO/1H$,1HL,1HC,1HA,1HO,1HM,1HO/ GENDRV GENDRV Search LFNIN for $LCAOMO datalist: GENDRV GENDRV REWIND(LFNIN) GENDRV 10 CALL STRTIN(LFNIN) GENDRV LEN = 6 GENDRV CALL HFLD(KEYWD,LEN,END) GENDRV IF(LEN.EQ.0.AND.END) RETURN GENDRV IF(.NOT.EQUAL(KEYWD,KAOMO,6)) GOTO 10 GENDRV GENDRV Read in the AO to MO transformation matrix: GENDRV GENDRV NEL = NDIM*NDIM GENDRV DO 20 I = 1,NEL GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading AO to MO transformation matrix' GENDRV 20 CONTINUE GENDRV GENDRV Store the transformation matrix on the NBO DAF: GENDRV GENDRV NFILE = 40 GENDRV CALL NBWRIT(CORE,NEL,NFILE) GENDRV GENDRV Read in and store the beta transformation matrix if this is an open GENDRV shell wavevfunction: GENDRV GENDRV IF(OPEN) THEN GENDRV DO 30 I = 1,NEL GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading beta AO to MO trans. matrix' GENDRV 30 CONTINUE GENDRV NFILE = 41 GENDRV CALL NBWRIT(CORE,NEL,NFILE) GENDRV END IF GENDRV RETURN GENDRV END GENDRV ***********************************************************************GENDRV SUBROUTINE DIPINP(CORE,UPPER,BOHR) GENDRV ***********************************************************************GENDRV IMPLICIT REAL*8 (A-H,O-Z) GENDRV DIMENSION CORE(1) GENDRV DIMENSION KEYWD(6),KDIPOL(6) GENDRV LOGICAL UPPER,ERROR,END,EQUAL,BOHR GENDRV GENDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GENDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV + LFNDAF,LFNDEF GENDRV GENDRV DATA KDIPOL/1H$,1HD,1HI,1HP,1HO,1HL/ GENDRV DATA TOANG/0.529177249/ GENDRV GENDRV Search LFNIN for $DIPOLE datalist: GENDRV GENDRV REWIND(LFNIN) GENDRV 10 CALL STRTIN(LFNIN) GENDRV LEN = 6 GENDRV CALL HFLD(KEYWD,LEN,END) GENDRV IF(LEN.EQ.0.AND.END) RETURN GENDRV IF(.NOT.EQUAL(KEYWD,KDIPOL,6)) GOTO 10 GENDRV GENDRV Number of elements to read in: GENDRV GENDRV NEL = NDIM*NDIM GENDRV IF(UPPER) NEL = NDIM*(NDIM+1)/2 GENDRV GENDRV Read in the x dipole integral matrix: GENDRV GENDRV DO 20 I = 1,NEL GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading x dipole integral matrix' GENDRV 20 CONTINUE GENDRV IF(.NOT.UPPER) THEN GENDRV NEL = NDIM*(NDIM+1)/2 GENDRV CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV END IF GENDRV GENDRV Convert to angstroms, if necessary: GENDRV GENDRV IF(BOHR) THEN GENDRV DO 30 I = 1,NEL GENDRV CORE(I) = CORE(I) * TOANG GENDRV 30 CONTINUE GENDRV END IF GENDRV GENDRV Store the dipole integral matrix on the NBO DAF: GENDRV GENDRV NFILE = 50 GENDRV CALL NBWRIT(CORE,NEL,NFILE) GENDRV GENDRV Read in the y dipole integral matrix: GENDRV GENDRV DO 40 I = 1,NEL GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading y dipole integral matrix' GENDRV 40 CONTINUE GENDRV IF(.NOT.UPPER) THEN GENDRV NEL = NDIM*(NDIM+1)/2 GENDRV CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV END IF GENDRV GENDRV Convert to angstroms, if necessary: GENDRV GENDRV IF(BOHR) THEN GENDRV DO 50 I = 1,NEL GENDRV CORE(I) = CORE(I) * TOANG GENDRV 50 CONTINUE GENDRV END IF GENDRV GENDRV NFILE = 51 GENDRV CALL NBWRIT(CORE,NEL,NFILE) GENDRV GENDRV Read in the z dipole integral matrix: GENDRV GENDRV DO 60 I = 1,NEL GENDRV CALL RFLD(CORE(I),ERROR) GENDRV IF(ERROR) STOP 'Error reading z dipole integral matrix' GENDRV 60 CONTINUE GENDRV IF(.NOT.UPPER) THEN GENDRV NEL = NDIM*(NDIM+1)/2 GENDRV CALL PACK(CORE,NBAS,NBAS,NEL) GENDRV END IF GENDRV GENDRV Convert to angstroms, if necessary: GENDRV GENDRV IF(BOHR) THEN GENDRV DO 70 I = 1,NEL GENDRV CORE(I) = CORE(I) * TOANG GENDRV 70 CONTINUE GENDRV END IF GENDRV GENDRV NFILE = 52 GENDRV CALL NBWRIT(CORE,NEL,NFILE) GENDRV GENDRV RETURN GENDRV END GENDRV ***********************************************************************GENDRV GENDRV E N D O F G E N N B O R O U T I N E S GENDRV GENDRV ***********************************************************************GENDRV ***********************************************************************G90DRV G90DRV G90DRV G 9 0 N B O G90DRV G90DRV G90DRV GAUSSIAN 90 VERSION OF NBO PROGRAM G90DRV G90DRV G90DRV DRIVER ROUTINES: G90DRV G90DRV SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G90DRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G90DRV SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G90DRV G90DRV ***********************************************************************G90DRV SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G90DRV ***********************************************************************G90DRV IMPLICIT REAL*8 (A-H,O-Z) G90DRV G90DRV PARAMETER (MAXFIL = 40) G90DRV G90DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G90DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G90DRV + LFNDAF,LFNDEF G90DRV COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) G90DRV CHARACTER*80 FILENM G90DRV G90DRV DIMENSION CORE(MEMORY),IOP(50) G90DRV DIMENSION NBOOPT(10) G90DRV G90DRV DATA TENTH/0.1D0/ G90DRV G90DRV LFNIN = 5 G90DRV LFNPR = 6 G90DRV G90DRV Set NBO options. G90DRV G90DRV DO 10 I = 1,9 G90DRV NBOOPT(I) = IOP(I+39) G90DRV 10 CONTINUE G90DRV NBOOPT(10) = 90 G90DRV G90DRV --- G90 patch --- G90DRV G90DRV IF(NBOOPT(1).EQ.0) THEN G90DRV NBOOPT(1) = 1 G90DRV ELSE IF(NBOOPT(1).EQ.1) THEN G90DRV NBOOPT(1) = 0 G90DRV END IF G90DRV G90DRV --- NBO analysis --- G90DRV G90DRV ICONTR = 0 G90DRV IF(ABS(NBOOPT(1)).LT.2) THEN G90DRV CALL CHARPN(4HNBO ) G90DRV CALL NBO(CORE,MEMORY,NBOOPT) G90DRV G90DRV Store the name of the NBO direct access file on the RWFiles G90DRV G90DRV DO 20 I = 1,80 G90DRV CORE(I) = ICHAR(FILENM(I:I)) G90DRV 20 CONTINUE G90DRV CORE(81) = LFNDAF G90DRV CALL TWRITE(636,CORE,81,1,81,1,0) G90DRV G90DRV --- NBO energetic analysis --- G90DRV G90DRV ELSE IF(NBOOPT(1).EQ.2) THEN G90DRV G90DRV Retrieve the name of the NBO direct access file from the RWFiles G90DRV G90DRV CALL TREAD(636,CORE,81,1,81,1,0) G90DRV DO 30 I = 1,80 G90DRV FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G90DRV 30 CONTINUE G90DRV LFNDAF = INT(ABS(CORE(81)) + TENTH) G90DRV CALL CHARPN(4HDELE) G90DRV CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G90DRV IF(IDONE.NE.0) ICONTR = 1 G90DRV IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT) G90DRV G90DRV ELSE IF(NBOOPT(1).EQ.3) THEN G90DRV CALL TREAD(636,CORE,81,1,81,1,0) G90DRV DO 40 I = 1,80 G90DRV FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G90DRV 40 CONTINUE G90DRV LFNDAF = INT(ABS(CORE(81)) + TENTH) G90DRV CALL CHARPN(4HEDEL) G90DRV CALL DELSCF(CORE,CORE,NBOOPT) G90DRV CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G90DRV END IF G90DRV G90DRV RETURN G90DRV END G90DRV ***********************************************************************G90DRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G90DRV ***********************************************************************G90DRV IMPLICIT REAL*8 (A-H,O-Z) G90DRV LOGICAL GOTDEN G90DRV -----------------------------------------------------------------------G90DRV G90DRV Routine FEAOIN accesses the following records of the RWFs: G90DRV G90DRV 501 --- Total energy G90DRV 502 --- Job title G90DRV 506 --- Basis set information G90DRV 512 --- Effective core potential information G90DRV 514 --- AO overlap matrix G90DRV 518 --- AO dipole integrals G90DRV 524 --- MO coefficients (alpha) G90DRV 526 --- MO coefficients (beta) G90DRV 536 --- AO Fock matrix (alpha) G90DRV 538 --- AO Fock matrix (beta) G90DRV 603 --- AO density matrix G90DRV G90DRV ----------------------------------------------------------------------G90DRV G90DRV NBO Common blocks G90DRV G90DRV PARAMETER(MAXATM = 99,MAXBAS = 500) G90DRV G90DRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G90DRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G90DRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G90DRV COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, G90DRV + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, G90DRV + JCORE,JPRINT(60) G90DRV COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) G90DRV COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G90DRV + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) G90DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G90DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G90DRV + LFNDAF,LFNDEF G90DRV G90DRV GAUSSIAN 90 Common blocks G90DRV G90DRV COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(401), G90DRV * ATMCHG(400),C(1200) G90DRV COMMON/LP2/NLP(1600),CLP(1600),ZLP(1600),KFIRST(400,5), G90DRV * KLAST(400,5),LMAX(400),LPSKIP(400),NFroz(400) G90DRV COMMON/B/EXX(6000),C1(6000),C2(6000),C3(6000),X(2000),Y(2000), G90DRV * Z(2000),JAN(2000),SHELLA(2000),SHELLN(2000),SHELLT(2000), G90DRV * SHELLC(2000),AOS(2000),AON(2000),NSHELL,MAXTYP G90DRV INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON G90DRV DIMENSION C4(2000),SHLADF(2000) G90DRV EQUIVALENCE(C4(1),C3(2001)),(SHLADF(1),C3(4001)) G90DRV G90DRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) G90DRV DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G90DRV G90DRV Obtain the following information: G90DRV G90DRV ROHF =.TRUE. If RHF open shell wavefunction G90DRV =.FALSE. otherwise G90DRV G90DRV UHF =.TRUE. If UHF wavefunction G90DRV =.FALSE. otherwise G90DRV G90DRV AUHF =.TRUE. If spin-annihilated UHF wavefunction G90DRV =.FALSE. otherwise G90DRV G90DRV CI =.TRUE. If CI wavefunction G90DRV =.FALSE. otherwise G90DRV G90DRV OPEN =.TRUE. If open shell wavefunction G90DRV =.FALSE. otherwise G90DRV G90DRV COMPLX =.TRUE. If complex wavefunction G90DRV =.FALSE. otherwise G90DRV (Note: The program is not capable of handling this.) G90DRV G90DRV NATOMS Number of atomic centers G90DRV G90DRV NDIM Dimension of matrices (overlap and density) G90DRV G90DRV NBAS Number of basis functions (.le.NDIM) G90DRV G90DRV IPSEUD Set to one if pseudopotentials are used. G90DRV G90DRV IWCUBF This pertains only basis sets with F functions. G90DRV G90DRV If cartesian F functions are input, set IWCUBF to: G90DRV 0, if these are to be transformed to the G90DRV standard set of pure F functions G90DRV 1, if these are to be transformed to the G90DRV cubic set of pure F functions G90DRV G90DRV If pure F functions are input, set to IWCUBF to: G90DRV 0, if these are standard F functions G90DRV 1, if these are cubic F functions G90DRV G90DRV IATNO(I),I=1,NATOMS G90DRV List of atomic numbers G90DRV G90DRV LCTR(I),I=1,NBAS G90DRV List of atomic centers of the basis functions G90DRV (LCTR(3)=2 if basis function 3 is on atom 2) G90DRV G90DRV LANG(I),I=1,NBAS G90DRV List of angular symmetry information for the AO basis G90DRV G90DRV DATA LISTS/ 1/ G90DRV DATA LISTP/ 101, 102, 103/ G90DRV DATA LISTD/ 255, 252, 253, 254, 251, 0, G90DRV + 201, 204, 206, 202, 203, 205/ G90DRV DATA LISTF/ 351, 352, 353, 354, 355, 356, 357, 0, 0, 0, G90DRV + 301, 307, 310, 304, 302, 303, 306, 309, 308, 305/ G90DRV DATA ZERO/0.0D0/ G90DRV DATA TOANG/0.529177249/ G90DRV G90DRV Store job title on NBODAF: G90DRV G90DRV LEN = INTOWP(4000+100) G90DRV CALL TREAD(502,ICORE,LEN,1,LEN,1,0) G90DRV NFILE = 2 G90DRV CALL NBWRIT(ICORE(4001),10,NFILE) G90DRV G90DRV Get the number of atoms from NAT and store the atomic numbers in G90DRV IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G90DRV nuclear charges may not be equivalent if effective core potentials G90DRV (ECP) are used.) G90DRV G90DRV LEN = 0 G90DRV IEXIST = ITQRY(512) G90DRV IF(IEXIST.GT.0) THEN G90DRV LEN = 8 * 400 + 17 * INTOWP(400) G90DRV CALL TREAD(512,NLP,LEN,1,LEN,1,0) G90DRV END IF G90DRV NATOMS = NATOM G90DRV DO 20 I = 1,NATOMS G90DRV IATNO(I) = IAN(I) G90DRV IF(IEXIST.GT.0) THEN G90DRV IZNUC(I) = IATNO(I) - NFROZ(I) G90DRV IF(NFROZ(I).NE.0) IPSEUD = 1 G90DRV ELSE G90DRV IZNUC(I) = IATNO(I) G90DRV END IF G90DRV 20 CONTINUE G90DRV G90DRV Restore the basis set to COMMON/B/: G90DRV G90DRV LEN = 30000 + INTOWP(14002) G90DRV CALL TREAD(506,EXX,LEN,1,LEN,1,0) G90DRV G90DRV The Gaussian programs do not use cubic f basis functions. G90DRV Determine which set of d and f functions are being used, G90DRV Cartesian or pure): G90DRV G90DRV IWCUBF = 0 G90DRV CALL ILSW(2,2,I5D6D) G90DRV CALL ILSW(2,16,I7F10F) G90DRV G90DRV Construct the AO information lists: LCTR and LANG G90DRV G90DRV IBAS = 0 G90DRV DO 90 ISHELL = 1,2000 G90DRV IF(IBAS.EQ.NBASIS) GOTO 100 G90DRV NCTR = JAN(ISHELL) G90DRV MAXL = SHELLT(ISHELL) G90DRV ICNSTR = SHELLC(ISHELL) G90DRV G90DRV Is an s orbital in the shell? G90DRV G90DRV KS = 0 G90DRV IF(MAXL.EQ.0) KS = 1 G90DRV IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G90DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G90DRV IF(KS.EQ.0) GOTO 30 G90DRV G90DRV s orbital: G90DRV G90DRV IBAS = IBAS + 1 G90DRV LCTR(IBAS) = NCTR G90DRV LANG(IBAS) = LISTS G90DRV G90DRV Is a set of p orbitals in the shell? G90DRV G90DRV 30 CONTINUE G90DRV KP = 0 G90DRV IF(MAXL.EQ.0) GOTO 90 G90DRV IF(MAXL.EQ.1) KP = 1 G90DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G90DRV IF(KP.EQ.0) GOTO 50 G90DRV G90DRV p orbitals: G90DRV G90DRV DO 40 I = 1,3 G90DRV IBAS = IBAS + 1 G90DRV LCTR(IBAS) = NCTR G90DRV LANG(IBAS) = LISTP(I) G90DRV 40 CONTINUE G90DRV G90DRV d orbitals: G90DRV G90DRV 50 IF(MAXL.NE.2) GOTO 70 G90DRV IMAX = I5D6D + 5 G90DRV KD = I5D6D + 1 G90DRV DO 60 I = 1,IMAX G90DRV IBAS = IBAS + 1 G90DRV LCTR(IBAS) = NCTR G90DRV LANG(IBAS) = LISTD(I,KD) G90DRV 60 CONTINUE G90DRV GO TO 90 G90DRV G90DRV f orbitals: G90DRV G90DRV 70 IF(MAXL.NE.3) GOTO 90 G90DRV IMAX = 7 G90DRV IF(I7F10F.EQ.1) IMAX = 10 G90DRV KF = I7F10F + 1 G90DRV DO 80 I = 1,IMAX G90DRV IBAS = IBAS + 1 G90DRV LCTR(IBAS) = NCTR G90DRV LANG(IBAS) = LISTF(I,KF) G90DRV 80 CONTINUE G90DRV 90 CONTINUE G90DRV 100 CONTINUE G90DRV NDIM = NBASIS G90DRV NBAS = NBASIS G90DRV G90DRV Determine the type of wave function the density matrix is from: G90DRV G90DRV IF(MULTIP.GT.1) OPEN = .TRUE. G90DRV IF(NBOOPT(2).NE.0) THEN G90DRV CI = .TRUE. G90DRV ELSE G90DRV CALL ILSW(2,1,ISCF) G90DRV CALL ILSW(2,22,IROHF) G90DRV IF(ISCF.EQ.1) UHF = .TRUE. G90DRV IF(UHF) OPEN = .TRUE. G90DRV IF(IROHF.EQ.1) ROHF = .TRUE. G90DRV IF(IROHF.EQ.2) ROHF = .TRUE. G90DRV IF(IROHF.EQ.3) MCSCF = .TRUE. G90DRV IF(ISCF.GT.1) COMPLX = .TRUE. G90DRV IF(COMPLX) GOTO 900 G90DRV END IF G90DRV IF(NBOOPT(5).EQ.1) AUHF = .TRUE. G90DRV ORTHO = .FALSE. G90DRV G90DRV No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G90DRV G90DRV IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G90DRV G90DRV Expectation values of the Fock operator are in atomic units: G90DRV G90DRV MUNIT = 0 G90DRV G90DRV Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G90DRV G90DRV ICORE(1) = NATOMS G90DRV ICORE(2) = NDIM G90DRV ICORE(3) = NBAS G90DRV ICORE(4) = MUNIT G90DRV ICORE(5) = 0 G90DRV IF(ROHF) ICORE(5) = 1 G90DRV ICORE(6) = 0 G90DRV IF(UHF) ICORE(6) = 1 G90DRV ICORE(7) = 0 G90DRV IF(CI) ICORE(7) = 1 G90DRV ICORE(8) = 0 G90DRV IF(OPEN) ICORE(8) = 1 G90DRV ICORE(9) = 0 G90DRV IF(MCSCF) ICORE(9) = 1 G90DRV ICORE(10) = 0 G90DRV IF(AUHF) ICORE(10) = 1 G90DRV ICORE(11) = 0 G90DRV IF(ORTHO) ICORE(11) = 1 G90DRV ICORE(12) = 1 G90DRV NFILE = 3 G90DRV CALL NBWRIT(ICORE,12,NFILE) G90DRV G90DRV Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G90DRV G90DRV II = 0 G90DRV DO 120 I = 1,NATOMS G90DRV II = II + 1 G90DRV ICORE(II) = IATNO(I) G90DRV 120 CONTINUE G90DRV DO 130 I = 1,NATOMS G90DRV II = II + 1 G90DRV ICORE(II) = IZNUC(I) G90DRV 130 CONTINUE G90DRV DO 140 I = 1,NBAS G90DRV II = II + 1 G90DRV ICORE(II) = LCTR(I) G90DRV 140 CONTINUE G90DRV DO 150 I = 1,NBAS G90DRV II = II + 1 G90DRV ICORE(II) = LANG(I) G90DRV 150 CONTINUE G90DRV NFILE = 4 G90DRV CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) G90DRV G90DRV Fetch the total energy from the RWF and store it on the NBODAF: G90DRV G90DRV CALL TREAD(501,CORE,32,1,32,1,0) G90DRV CORE(1) = CORE(32) G90DRV CORE(2) = CORE(32) G90DRV NFILE = 8 G90DRV CALL NBWRIT(CORE,2,NFILE) G90DRV G90DRV Store the atomic coordinates on the NBO DAF: (Note that these G90DRV coordinates are used in the calculation of dipole moments.) G90DRV G90DRV DO 160 I = 1,3*NATOMS G90DRV CORE(I) = C(I) * TOANG G90DRV 160 CONTINUE G90DRV NFILE = 9 G90DRV CALL NBWRIT(CORE,3*NATOMS,NFILE) G90DRV G90DRV Store the overlap matrix on the NBODAF: G90DRV G90DRV L2 = NDIM*(NDIM+1)/2 G90DRV CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1) G90DRV CALL PACK(CORE,NDIM,NBAS,L2) G90DRV NFILE = 10 G90DRV CALL NBWRIT(CORE,L2,NFILE) G90DRV G90DRV Store the density matrices on the NBODAF: G90DRV G90DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.0) WRITE(LFNPR,1000) G90DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.1) WRITE(LFNPR,1010) G90DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.2) WRITE(LFNPR,1020) G90DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.3) WRITE(LFNPR,1030) G90DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.4) WRITE(LFNPR,1040) G90DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.5) WRITE(LFNPR,1050) G90DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.6) WRITE(LFNPR,1060) G90DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.7) WRITE(LFNPR,1070) G90DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.8) WRITE(LFNPR,1080) G90DRV G90DRV L2 = NDIM*(NDIM+1)/2 G90DRV LEN = L2 G90DRV IF(OPEN) LEN = 2 * LEN G90DRV CALL DENGET(LFNPR,603,NBOOPT(2),LEN,GOTDEN,CORE) G90DRV IF(.NOT.GOTDEN) STOP 'Missing density matrix' G90DRV NFILE = 20 G90DRV CALL NBWRIT(CORE,L2,NFILE) G90DRV G90DRV IF(OPEN) THEN G90DRV NFILE = 21 G90DRV CALL NBWRIT(CORE(L2+1),L2,NFILE) G90DRV END IF G90DRV G90DRV Store the Fock matrices on the NBODAF: G90DRV G90DRV IF(IWFOCK.NE.0) THEN G90DRV IEXIST = ITQRY(536) G90DRV IF(IEXIST.GT.0) THEN G90DRV L2 = NDIM*(NDIM+1)/2 G90DRV CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1) G90DRV CALL PACK(CORE,NDIM,NBAS,L2) G90DRV NFILE = 30 G90DRV CALL NBWRIT(CORE,L2,NFILE) G90DRV END IF G90DRV G90DRV IF(OPEN) THEN G90DRV IEXIST = ITQRY(538) G90DRV IF(IEXIST.GT.0) THEN G90DRV L2 = NDIM*(NDIM+1)/2 G90DRV CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1) G90DRV CALL PACK(CORE,NDIM,NBAS,L2) G90DRV NFILE = 31 G90DRV CALL NBWRIT(CORE,L2,NFILE) G90DRV END IF G90DRV END IF G90DRV END IF G90DRV G90DRV Store the AO to MO transformation matrices on the NBODAF: G90DRV G90DRV IEXIST = ITQRY(524) G90DRV IF(IEXIST.GT.0) THEN G90DRV L3 = NDIM*NDIM G90DRV CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0) G90DRV NFILE = 40 G90DRV CALL NBWRIT(CORE,L3,NFILE) G90DRV END IF G90DRV G90DRV IF(OPEN) THEN G90DRV IEXIST = ITQRY(526) G90DRV IF(IEXIST.GT.0) THEN G90DRV L3 = NDIM*NDIM G90DRV CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0) G90DRV NFILE = 41 G90DRV CALL NBWRIT(CORE,L3,NFILE) G90DRV END IF G90DRV END IF G90DRV G90DRV Store the x,y,z dipole integrals on the NBODAF: G90DRV G90DRV IEXIST = ITQRY(518) G90DRV IF(IEXIST.GT.0) THEN G90DRV L2 = NDIM*(NDIM+1)/2 G90DRV LEN = 3 * L2 G90DRV CALL TREAD(518,CORE,LEN,1,LEN,1,0) G90DRV DO 170 I = 1,LEN G90DRV CORE(I) = CORE(I) * TOANG G90DRV 170 CONTINUE G90DRV NFILE = 50 G90DRV CALL NBWRIT(CORE,L2,NFILE) G90DRV NFILE = 51 G90DRV CALL NBWRIT(CORE(L2+1),L2,NFILE) G90DRV NFILE = 52 G90DRV CALL NBWRIT(CORE(2*L2+1),L2,NFILE) G90DRV END IF G90DRV G90DRV Store the AO basis set info on the NBO DAF: (Note that two integers G90DRV and three integer arrays are stored first. Also remember that ICORE G90DRV and CORE occupy the same memory.) G90DRV G90DRV NEXP = 0 G90DRV DO 180 I = 1,6000 G90DRV IF(EXX(I).EQ.ZERO) GOTO 180 G90DRV NEXP = I G90DRV 180 CONTINUE G90DRV DO 190 I = 1,2+3*NSHELL+5*NEXP G90DRV CORE(I) = ZERO G90DRV 190 CONTINUE G90DRV ICORE(1) = NSHELL G90DRV ICORE(2) = NEXP G90DRV G90DRV Determine if Cartesian or pure D and F functions are used: G90DRV G90DRV CALL ILSW(2,2,I5D6D) G90DRV CALL ILSW(2,16,I7F10F) G90DRV G90DRV NCOMP(I) -- the number of components in the Ith shell: G90DRV G90DRV II = 2 G90DRV DO 420 I = 1,NSHELL G90DRV II = II + 1 G90DRV ICORE(II) = 0 G90DRV MAXL = SHELLT(I) G90DRV ICNSTR = SHELLC(I) G90DRV G90DRV Determine if an S orbital is in the shell: G90DRV G90DRV KS = 0 G90DRV IF(MAXL.EQ.0) KS = 1 G90DRV IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G90DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G90DRV IF(KS.EQ.0) GO TO 310 G90DRV G90DRV S orbital: G90DRV G90DRV ICORE(II) = ICORE(II) + 1 G90DRV G90DRV Determine if a set of P orbitals is in the shell: G90DRV G90DRV 310 CONTINUE G90DRV KP = 0 G90DRV IF(MAXL.EQ.0) GO TO 400 G90DRV IF(MAXL.EQ.1) KP = 1 G90DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G90DRV IF(KP.EQ.0) GO TO 340 G90DRV G90DRV P orbital: G90DRV G90DRV ICORE(II) = ICORE(II) + 3 G90DRV G90DRV If MAXL is less than 2 then there are no D or F orbitals: G90DRV If MAXL is greater than 2 then there must be F orbitals: G90DRV G90DRV 340 IF(MAXL.LT.2) GO TO 400 G90DRV IF(MAXL.GT.2) GO TO 370 G90DRV G90DRV D orbital: G90DRV G90DRV IMAX = I5D6D + 5 G90DRV ICORE(II) = ICORE(II) + IMAX G90DRV G90DRV If MAXL is less than 3 then there are no F orbitals: G90DRV G90DRV 370 IF(MAXL.LT.3) GO TO 400 G90DRV G90DRV F orbital: G90DRV G90DRV IMAX=7 G90DRV IF(I7F10F.EQ.1) IMAX=10 G90DRV ICORE(II) = ICORE(II) + IMAX G90DRV G90DRV Skip here when no more orbitals are found: G90DRV G90DRV 400 CONTINUE G90DRV 420 CONTINUE G90DRV G90DRV NPRIM(I) -- the number of gaussian primitives in the Ith shell: G90DRV G90DRV DO 480 I = 1,NSHELL G90DRV II = II + 1 G90DRV ICORE(II) = SHELLN(I) G90DRV 480 CONTINUE G90DRV G90DRV NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G90DRV EXP, CS, CP, etc.: G90DRV G90DRV DO 490 I = 1,NSHELL G90DRV II = II + 1 G90DRV ICORE(II) = SHELLA(I) G90DRV 490 CONTINUE G90DRV G90DRV EXP(I) -- orbital exponents indexed by NPTR: G90DRV G90DRV DO 500 I = 1,NEXP G90DRV II = II + 1 G90DRV CORE(II) = EXX(I) G90DRV 500 CONTINUE G90DRV G90DRV CS,CP -- orbital coefficients: G90DRV G90DRV DO 510 I = 1,NEXP G90DRV II = II + 1 G90DRV CORE(II) = C1(I) G90DRV 510 CONTINUE G90DRV DO 520 I = 1,NEXP G90DRV II = II + 1 G90DRV CORE(II) = C2(I) G90DRV 520 CONTINUE G90DRV G90DRV Zero CD and CF arrays: G90DRV G90DRV IHOLD = II G90DRV DO 550 I = 1,2*NEXP G90DRV II = II + 1 G90DRV CORE(II) = ZERO G90DRV 550 CONTINUE G90DRV G90DRV Build CD and CF from C3 and C4: G90DRV G90DRV DO 570 I = 1,NSHELL G90DRV IPTR = SHLADF(I) G90DRV IF(IPTR.GT.0) THEN G90DRV DO 560 J = 1,SHELLN(I) G90DRV LPTR = J + SHELLA(I) + IHOLD - 1 G90DRV MPTR = J + IPTR - 1 G90DRV CORE(LPTR) = C3(MPTR) G90DRV CORE(LPTR+NEXP) = C4(MPTR) G90DRV 560 CONTINUE G90DRV END IF G90DRV 570 CONTINUE G90DRV NFILE = 5 G90DRV CALL NBWRIT(CORE,II,NFILE) G90DRV RETURN G90DRV G90DRV 900 WRITE(LFNPR,990) G90DRV RETURN G90DRV G90DRV 990 FORMAT(/1X,'The NBO program is not set up to handle complex ', G90DRV + 'wave functions') G90DRV 1000 FORMAT(/1X,'Analyzing the SCF density') G90DRV 1010 FORMAT(/1X,'Analyzing the MP first order density') G90DRV 1020 FORMAT(/1X,'Analyzing the MP2 density') G90DRV 1030 FORMAT(/1X,'Analyzing the MP3 density') G90DRV 1040 FORMAT(/1X,'Analyzing the MP4 density') G90DRV 1050 FORMAT(/1X,'Analyzing the CI one-particle density') G90DRV 1060 FORMAT(/1X,'Analyzing the CI density') G90DRV 1070 FORMAT(/1X,'Analyzing the QCI/CC density') G90DRV 1080 FORMAT(/1X,'Analyzing the density correct to second order') G90DRV END G90DRV ***********************************************************************G90DRV SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G90DRV ***********************************************************************G90DRV IMPLICIT REAL*8 (A-H,O-Z) G90DRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) G90DRV LOGICAL NEW,ERROR,SEQ G90DRV G90DRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G90DRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G90DRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G90DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G90DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G90DRV + LFNDAF,LFNDEF G90DRV G90DRV If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G90DRV DAF to the RWFs. G90DRV G90DRV IF(NBOOPT(1).EQ.2) THEN G90DRV NEW = .FALSE. G90DRV CALL NBOPEN(NEW,ERROR) G90DRV IF(ERROR) THEN G90DRV WRITE(LFNPR,900) G90DRV STOP G90DRV END IF G90DRV L2 = NDIM * (NDIM + 1)/2 G90DRV IF(OPEN) THEN G90DRV ALPHA = .TRUE. G90DRV BETA = .FALSE. G90DRV CALL FENEWD(CORE) G90DRV CALL TWRITE(528,CORE,L2,1,L2,1,0) G90DRV ALPHA = .FALSE. G90DRV BETA = .TRUE. G90DRV CALL FENEWD(CORE) G90DRV CALL TWRITE(530,CORE,L2,1,L2,1,0) G90DRV ELSE G90DRV ALPHA = .FALSE. G90DRV BETA = .FALSE. G90DRV CALL FENEWD(CORE) G90DRV CALL TWRITE(528,CORE,L2,1,L2,1,0) G90DRV END IF G90DRV SEQ = .FALSE. G90DRV CALL NBCLOS(SEQ) G90DRV END IF G90DRV G90DRV If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G90DRV G90DRV IF(NBOOPT(1).EQ.3) THEN G90DRV NEW = .FALSE. G90DRV CALL NBOPEN(NEW,ERROR) G90DRV IF(ERROR) THEN G90DRV WRITE(LFNPR,900) G90DRV STOP G90DRV END IF G90DRV CALL TREAD(501,CORE,32,1,32,1,0) G90DRV CALL SVE0(CORE(32)) G90DRV SEQ = .FALSE. G90DRV CALL NBCLOS(SEQ) G90DRV END IF G90DRV RETURN G90DRV G90DRV 900 FORMAT(/1X,'Error opening the NBO direct access file in ', G90DRV + 'subroutine DELSCF.') G90DRV END G90DRV ***********************************************************************G90DRV G90DRV E N D O F G 9 0 N B O R O U T I N E S G90DRV G90DRV ***********************************************************************G90DRV ***********************************************************************G88DRV G88DRV G88DRV G 8 8 N B O G88DRV G88DRV G88DRV GAUSSIAN 88 VERSION OF NBO PROGRAM G88DRV G88DRV G88DRV DRIVER ROUTINES: G88DRV G88DRV SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G88DRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G88DRV SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G88DRV G88DRV ***********************************************************************G88DRV SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G88DRV ***********************************************************************G88DRV IMPLICIT REAL*8 (A-H,O-Z) G88DRV G88DRV PARAMETER (MAXFIL = 40) G88DRV G88DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G88DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G88DRV + LFNDAF,LFNDEF G88DRV COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) G88DRV CHARACTER*80 FILENM G88DRV G88DRV DIMENSION CORE(1),IOP(50) G88DRV DIMENSION NBOOPT(10) G88DRV G88DRV LFNIN = 5 G88DRV LFNPR = 6 G88DRV G88DRV DATA TENTH/0.1D0/ G88DRV G88DRV Set NBO options. G88DRV G88DRV DO 10 I = 1,9 G88DRV NBOOPT(I) = IOP(I+39) G88DRV 10 CONTINUE G88DRV NBOOPT(10) = 88 G88DRV G88DRV --- NBO analysis --- G88DRV G88DRV ICONTR = 0 G88DRV IF(ABS(NBOOPT(1)).LT.2) THEN G88DRV CALL CHARPN(4HNBO ) G88DRV CALL NBO(CORE,MEMORY,NBOOPT) G88DRV G88DRV Store the name of the NBO direct access file on the RWFiles G88DRV G88DRV DO 20 I = 1,80 G88DRV CORE(I) = ICHAR(FILENM(I:I)) G88DRV 20 CONTINUE G88DRV CORE(81) = LFNDAF G88DRV CALL TWRITE(636,CORE,81,1,81,1,0) G88DRV G88DRV --- NBO energetic analysis --- G88DRV G88DRV ELSE IF(NBOOPT(1).EQ.2) THEN G88DRV G88DRV Retrieve the name of the NBO direct access file from the RWFiles G88DRV G88DRV CALL TREAD(636,CORE,81,1,81,1,0) G88DRV DO 30 I = 1,80 G88DRV FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G88DRV 30 CONTINUE G88DRV LFNDAF = INT(ABS(CORE(81)) + TENTH) G88DRV CALL CHARPN(4HDELE) G88DRV CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G88DRV IF(IDONE.NE.0) ICONTR = 1 G88DRV IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT) G88DRV G88DRV ELSE IF(NBOOPT(1).EQ.3) THEN G88DRV CALL TREAD(636,CORE,81,1,81,1,0) G88DRV DO 40 I = 1,80 G88DRV FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G88DRV 40 CONTINUE G88DRV LFNDAF = INT(ABS(CORE(81)) + TENTH) G88DRV CALL CHARPN(4HEDEL) G88DRV CALL DELSCF(CORE,CORE,NBOOPT) G88DRV CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G88DRV END IF G88DRV G88DRV RETURN G88DRV END G88DRV ***********************************************************************G88DRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G88DRV ***********************************************************************G88DRV IMPLICIT REAL*8 (A-H,O-Z) G88DRV LOGICAL GOTDEN G88DRV -----------------------------------------------------------------------G88DRV G88DRV Routine FEAOIN accesses the following records of the RWFs: G88DRV G88DRV 501 --- Total energy G88DRV 502 --- Job title G88DRV 506 --- Basis set information G88DRV 512 --- Effective core potential information G88DRV 514 --- AO overlap matrix G88DRV 518 --- AO dipole integrals G88DRV 524 --- MO coefficients (alpha) G88DRV 526 --- MO coefficients (beta) G88DRV 536 --- AO Fock matrix (alpha) G88DRV 538 --- AO Fock matrix (beta) G88DRV 603 --- AO density matrix G88DRV G88DRV ----------------------------------------------------------------------G88DRV G88DRV NBO Common blocks G88DRV G88DRV PARAMETER(MAXATM = 99,MAXBAS = 500) G88DRV G88DRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G88DRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G88DRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G88DRV COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, G88DRV + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, G88DRV + JCORE,JPRINT(60) G88DRV COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) G88DRV COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G88DRV + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) G88DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G88DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G88DRV + LFNDAF,LFNDEF G88DRV G88DRV GAUSSIAN 88 Common blocks G88DRV G88DRV COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(401), G88DRV * ATMCHG(400),C(1200) G88DRV COMMON/LP2/NLP(1600),CLP(1600),ZLP(1600),KFIRST(400,5), G88DRV * KLAST(400,5),LMAX(400),LPSKIP(400),NFroz(400) G88DRV COMMON/B/EXX(6000),C1(6000),C2(6000),C3(6000),X(2000),Y(2000), G88DRV * Z(2000),JAN(2000),SHELLA(2000),SHELLN(2000),SHELLT(2000), G88DRV * SHELLC(2000),AOS(2000),AON(2000),NSHELL,MAXTYP G88DRV INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON G88DRV DIMENSION C4(2000),SHLADF(2000) G88DRV EQUIVALENCE(C4(1),C3(2001)),(SHLADF(1),C3(4001)) G88DRV G88DRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) G88DRV DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G88DRV G88DRV Obtain the following information: G88DRV G88DRV ROHF =.TRUE. If RHF open shell wavefunction G88DRV =.FALSE. otherwise G88DRV G88DRV UHF =.TRUE. If UHF wavefunction G88DRV =.FALSE. otherwise G88DRV G88DRV AUHF =.TRUE. If spin-annihilated UHF wavefunction G88DRV =.FALSE. otherwise G88DRV G88DRV CI =.TRUE. If CI wavefunction G88DRV =.FALSE. otherwise G88DRV G88DRV OPEN =.TRUE. If open shell wavefunction G88DRV =.FALSE. otherwise G88DRV G88DRV COMPLX =.TRUE. If complex wavefunction G88DRV =.FALSE. otherwise G88DRV (Note: The program is not capable of handling this.) G88DRV G88DRV NATOMS Number of atomic centers G88DRV G88DRV NDIM Dimension of matrices (overlap and density) G88DRV G88DRV NBAS Number of basis functions (.le.NDIM) G88DRV G88DRV IPSEUD Set to one if pseudopotentials are used. G88DRV G88DRV IWCUBF This pertains only basis sets with F functions. G88DRV G88DRV If cartesian F functions are input, set IWCUBF to: G88DRV 0, if these are to be transformed to the G88DRV standard set of pure F functions G88DRV 1, if these are to be transformed to the G88DRV cubic set of pure F functions G88DRV G88DRV If pure F functions are input, set to IWCUBF to: G88DRV 0, if these are standard F functions G88DRV 1, if these are cubic F functions G88DRV G88DRV IATNO(I),I=1,NATOMS G88DRV List of atomic numbers G88DRV G88DRV LCTR(I),I=1,NBAS G88DRV List of atomic centers of the basis functions G88DRV (LCTR(3)=2 if basis function 3 is on atom 2) G88DRV G88DRV LANG(I),I=1,NBAS G88DRV List of angular symmetry information for the AO basis G88DRV G88DRV DATA LISTS/ 1/ G88DRV DATA LISTP/ 101, 102, 103/ G88DRV DATA LISTD/ 255, 252, 253, 254, 251, 0, G88DRV + 201, 204, 206, 202, 203, 205/ G88DRV DATA LISTF/ 351, 352, 353, 354, 355, 356, 357, 0, 0, 0, G88DRV + 301, 307, 310, 304, 302, 303, 306, 309, 308, 305/ G88DRV DATA ZERO/0.0D0/ G88DRV DATA TOANG/0.529177249/ G88DRV G88DRV Store job title on NBODAF: G88DRV G88DRV LEN = INTOWP(4000+100) G88DRV CALL TREAD(502,ICORE,LEN,1,LEN,1,0) G88DRV NFILE = 2 G88DRV CALL NBWRIT(ICORE(4001),10,NFILE) G88DRV G88DRV Get the number of atoms from NAT and store the atomic numbers in G88DRV IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G88DRV nuclear charges may not be equivalent if effective core potentials G88DRV (ECP) are used.) G88DRV G88DRV LEN = 0 G88DRV IEXIST = ITQRY(512) G88DRV IF(IEXIST.GT.0) THEN G88DRV LEN = 8 * 400 + 17 * INTOWP(400) G88DRV CALL TREAD(512,NLP,LEN,1,LEN,1,0) G88DRV END IF G88DRV NATOMS = NATOM G88DRV DO 20 I = 1,NATOMS G88DRV IATNO(I) = IAN(I) G88DRV IF(IEXIST.GT.0) THEN G88DRV IZNUC(I) = IATNO(I) - NFROZ(I) G88DRV IF(NFROZ(I).NE.0) IPSEUD = 1 G88DRV ELSE G88DRV IZNUC(I) = IATNO(I) G88DRV END IF G88DRV 20 CONTINUE G88DRV G88DRV Restore the basis set to COMMON/B/: G88DRV G88DRV LEN = 30000 + INTOWP(14002) G88DRV CALL TREAD(506,EXX,LEN,1,LEN,1,0) G88DRV G88DRV The Gaussian programs do not use cubic f basis functions. G88DRV Determine which set of d and f functions are being used, G88DRV Cartesian or pure): G88DRV G88DRV IWCUBF = 0 G88DRV CALL ILSW(2,2,I5D6D) G88DRV CALL ILSW(2,16,I7F10F) G88DRV G88DRV Construct the AO information lists: LCTR and LANG G88DRV G88DRV IBAS = 0 G88DRV DO 90 ISHELL = 1,2000 G88DRV IF(IBAS.EQ.NBASIS) GOTO 100 G88DRV NCTR = JAN(ISHELL) G88DRV MAXL = SHELLT(ISHELL) G88DRV ICNSTR = SHELLC(ISHELL) G88DRV G88DRV Is an s orbital in the shell? G88DRV G88DRV KS = 0 G88DRV IF(MAXL.EQ.0) KS = 1 G88DRV IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G88DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G88DRV IF(KS.EQ.0) GOTO 30 G88DRV G88DRV s orbital: G88DRV G88DRV IBAS = IBAS + 1 G88DRV LCTR(IBAS) = NCTR G88DRV LANG(IBAS) = LISTS G88DRV G88DRV Is a set of p orbitals in the shell? G88DRV G88DRV 30 CONTINUE G88DRV KP = 0 G88DRV IF(MAXL.EQ.0) GOTO 90 G88DRV IF(MAXL.EQ.1) KP = 1 G88DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G88DRV IF(KP.EQ.0) GOTO 50 G88DRV G88DRV p orbitals: G88DRV G88DRV DO 40 I = 1,3 G88DRV IBAS = IBAS + 1 G88DRV LCTR(IBAS) = NCTR G88DRV LANG(IBAS) = LISTP(I) G88DRV 40 CONTINUE G88DRV G88DRV d orbitals: G88DRV G88DRV 50 IF(MAXL.NE.2) GOTO 70 G88DRV IMAX = I5D6D + 5 G88DRV KD = I5D6D + 1 G88DRV DO 60 I = 1,IMAX G88DRV IBAS = IBAS + 1 G88DRV LCTR(IBAS) = NCTR G88DRV LANG(IBAS) = LISTD(I,KD) G88DRV 60 CONTINUE G88DRV GO TO 90 G88DRV G88DRV f orbitals: G88DRV G88DRV 70 IF(MAXL.NE.3) GOTO 90 G88DRV IMAX = 7 G88DRV IF(I7F10F.EQ.1) IMAX = 10 G88DRV KF = I7F10F + 1 G88DRV DO 80 I = 1,IMAX G88DRV IBAS = IBAS + 1 G88DRV LCTR(IBAS) = NCTR G88DRV LANG(IBAS) = LISTF(I,KF) G88DRV 80 CONTINUE G88DRV 90 CONTINUE G88DRV 100 CONTINUE G88DRV NDIM = NBASIS G88DRV NBAS = NBASIS G88DRV G88DRV Determine the type of wave function the density matrix is from: G88DRV G88DRV IF(MULTIP.GT.1) OPEN = .TRUE. G88DRV IF(NBOOPT(2).NE.0) THEN G88DRV CI = .TRUE. G88DRV ELSE G88DRV CALL ILSW(2,1,ISCF) G88DRV CALL ILSW(2,22,IROHF) G88DRV IF(ISCF.EQ.1) UHF = .TRUE. G88DRV IF(UHF) OPEN = .TRUE. G88DRV IF(IROHF.EQ.1) ROHF = .TRUE. G88DRV IF(IROHF.EQ.2) ROHF = .TRUE. G88DRV IF(IROHF.EQ.3) MCSCF = .TRUE. G88DRV IF(ISCF.GT.1) COMPLX = .TRUE. G88DRV IF(COMPLX) GOTO 900 G88DRV END IF G88DRV IF(NBOOPT(5).EQ.1) AUHF = .TRUE. G88DRV ORTHO = .FALSE. G88DRV G88DRV No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G88DRV G88DRV IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G88DRV G88DRV Expectation values of the Fock operator are in atomic units: G88DRV G88DRV MUNIT = 0 G88DRV G88DRV Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G88DRV G88DRV ICORE(1) = NATOMS G88DRV ICORE(2) = NDIM G88DRV ICORE(3) = NBAS G88DRV ICORE(4) = MUNIT G88DRV ICORE(5) = 0 G88DRV IF(ROHF) ICORE(5) = 1 G88DRV ICORE(6) = 0 G88DRV IF(UHF) ICORE(6) = 1 G88DRV ICORE(7) = 0 G88DRV IF(CI) ICORE(7) = 1 G88DRV ICORE(8) = 0 G88DRV IF(OPEN) ICORE(8) = 1 G88DRV ICORE(9) = 0 G88DRV IF(MCSCF) ICORE(9) = 1 G88DRV ICORE(10) = 0 G88DRV IF(AUHF) ICORE(10) = 1 G88DRV ICORE(11) = 0 G88DRV IF(ORTHO) ICORE(11) = 1 G88DRV ICORE(12) = 1 G88DRV NFILE = 3 G88DRV CALL NBWRIT(ICORE,12,NFILE) G88DRV G88DRV Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G88DRV G88DRV II = 0 G88DRV DO 120 I = 1,NATOMS G88DRV II = II + 1 G88DRV ICORE(II) = IATNO(I) G88DRV 120 CONTINUE G88DRV DO 130 I = 1,NATOMS G88DRV II = II + 1 G88DRV ICORE(II) = IZNUC(I) G88DRV 130 CONTINUE G88DRV DO 140 I = 1,NBAS G88DRV II = II + 1 G88DRV ICORE(II) = LCTR(I) G88DRV 140 CONTINUE G88DRV DO 150 I = 1,NBAS G88DRV II = II + 1 G88DRV ICORE(II) = LANG(I) G88DRV 150 CONTINUE G88DRV NFILE = 4 G88DRV CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) G88DRV G88DRV Fetch the total energy from the RWF and store it on the NBODAF: G88DRV G88DRV CALL TREAD(501,CORE,32,1,32,1,0) G88DRV CORE(1) = CORE(32) G88DRV CORE(2) = CORE(32) G88DRV NFILE = 8 G88DRV CALL NBWRIT(CORE,2,NFILE) G88DRV G88DRV Store the atomic coordinates on the NBO DAF: (Note that these G88DRV coordinates are used in the calculation of dipole moments.) G88DRV G88DRV DO 160 I = 1,3*NATOMS G88DRV CORE(I) = C(I) * TOANG G88DRV 160 CONTINUE G88DRV NFILE = 9 G88DRV CALL NBWRIT(CORE,3*NATOMS,NFILE) G88DRV G88DRV Store the overlap matrix on the NBODAF: G88DRV G88DRV L2 = NDIM*(NDIM+1)/2 G88DRV CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1) G88DRV CALL PACK(CORE,NDIM,NBAS,L2) G88DRV NFILE = 10 G88DRV CALL NBWRIT(CORE,L2,NFILE) G88DRV G88DRV Store the density matrices on the NBODAF: G88DRV G88DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.0) WRITE(LFNPR,1000) G88DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.1) WRITE(LFNPR,1010) G88DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.2) WRITE(LFNPR,1020) G88DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.3) WRITE(LFNPR,1030) G88DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.4) WRITE(LFNPR,1040) G88DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.5) WRITE(LFNPR,1050) G88DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.6) WRITE(LFNPR,1060) G88DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.7) WRITE(LFNPR,1070) G88DRV IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.8) WRITE(LFNPR,1080) G88DRV G88DRV L2 = NDIM*(NDIM+1)/2 G88DRV LEN = L2 G88DRV IF(OPEN) LEN = 2 * LEN G88DRV CALL DENGET(LFNPR,603,NBOOPT(2),LEN,GOTDEN,CORE) G88DRV IF(.NOT.GOTDEN) STOP 'Missing density matrix' G88DRV NFILE = 20 G88DRV CALL NBWRIT(CORE,L2,NFILE) G88DRV G88DRV IF(OPEN) THEN G88DRV NFILE = 21 G88DRV CALL NBWRIT(CORE(L2+1),L2,NFILE) G88DRV END IF G88DRV G88DRV Store the Fock matrices on the NBODAF: G88DRV G88DRV IF(IWFOCK.NE.0) THEN G88DRV IEXIST = ITQRY(536) G88DRV IF(IEXIST.GT.0) THEN G88DRV L2 = NDIM*(NDIM+1)/2 G88DRV CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1) G88DRV CALL PACK(CORE,NDIM,NBAS,L2) G88DRV NFILE = 30 G88DRV CALL NBWRIT(CORE,L2,NFILE) G88DRV END IF G88DRV G88DRV IF(OPEN) THEN G88DRV IEXIST = ITQRY(538) G88DRV IF(IEXIST.GT.0) THEN G88DRV L2 = NDIM*(NDIM+1)/2 G88DRV CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1) G88DRV CALL PACK(CORE,NDIM,NBAS,L2) G88DRV NFILE = 31 G88DRV CALL NBWRIT(CORE,L2,NFILE) G88DRV END IF G88DRV END IF G88DRV END IF G88DRV G88DRV Store the AO to MO transformation matrices on the NBODAF: G88DRV G88DRV IEXIST = ITQRY(524) G88DRV IF(IEXIST.GT.0) THEN G88DRV L3 = NDIM*NDIM G88DRV CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0) G88DRV NFILE = 40 G88DRV CALL NBWRIT(CORE,L3,NFILE) G88DRV END IF G88DRV G88DRV IF(OPEN) THEN G88DRV IEXIST = ITQRY(526) G88DRV IF(IEXIST.GT.0) THEN G88DRV L3 = NDIM*NDIM G88DRV CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0) G88DRV NFILE = 41 G88DRV CALL NBWRIT(CORE,L3,NFILE) G88DRV END IF G88DRV END IF G88DRV G88DRV Store the x,y,z dipole integrals on the NBODAF: G88DRV G88DRV IEXIST = ITQRY(518) G88DRV IF(IEXIST.GT.0) THEN G88DRV L2 = NDIM*(NDIM+1)/2 G88DRV LEN = 3 * L2 G88DRV CALL TREAD(518,CORE,LEN,1,LEN,1,0) G88DRV DO 170 I = 1,LEN G88DRV CORE(I) = CORE(I) * TOANG G88DRV 170 CONTINUE G88DRV NFILE = 50 G88DRV CALL NBWRIT(CORE,L2,NFILE) G88DRV NFILE = 51 G88DRV CALL NBWRIT(CORE(L2+1),L2,NFILE) G88DRV NFILE = 52 G88DRV CALL NBWRIT(CORE(2*L2+1),L2,NFILE) G88DRV END IF G88DRV G88DRV Store the AO basis set info on the NBO DAF: (Note that two integers G88DRV and three integer arrays are stored first. Also remember that ICORE G88DRV and CORE occupy the same memory.) G88DRV G88DRV NEXP = 0 G88DRV DO 180 I = 1,6000 G88DRV IF(EXX(I).EQ.ZERO) GOTO 180 G88DRV NEXP = I G88DRV 180 CONTINUE G88DRV DO 190 I = 1,2+3*NSHELL+5*NEXP G88DRV CORE(I) = ZERO G88DRV 190 CONTINUE G88DRV ICORE(1) = NSHELL G88DRV ICORE(2) = NEXP G88DRV G88DRV Determine if Cartesian or pure D and F functions are used: G88DRV G88DRV CALL ILSW(2,2,I5D6D) G88DRV CALL ILSW(2,16,I7F10F) G88DRV G88DRV NCOMP(I) -- the number of components in the Ith shell: G88DRV G88DRV II = 2 G88DRV DO 420 I = 1,NSHELL G88DRV II = II + 1 G88DRV ICORE(II) = 0 G88DRV MAXL = SHELLT(I) G88DRV ICNSTR = SHELLC(I) G88DRV G88DRV Determine if an S orbital is in the shell: G88DRV G88DRV KS = 0 G88DRV IF(MAXL.EQ.0) KS = 1 G88DRV IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G88DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G88DRV IF(KS.EQ.0) GO TO 310 G88DRV G88DRV S orbital: G88DRV G88DRV ICORE(II) = ICORE(II) + 1 G88DRV G88DRV Determine if a set of P orbitals is in the shell: G88DRV G88DRV 310 CONTINUE G88DRV KP = 0 G88DRV IF(MAXL.EQ.0) GO TO 400 G88DRV IF(MAXL.EQ.1) KP = 1 G88DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G88DRV IF(KP.EQ.0) GO TO 340 G88DRV G88DRV P orbital: G88DRV G88DRV ICORE(II) = ICORE(II) + 3 G88DRV G88DRV If MAXL is less than 2 then there are no D or F orbitals: G88DRV If MAXL is greater than 2 then there must be F orbitals: G88DRV G88DRV 340 IF(MAXL.LT.2) GO TO 400 G88DRV IF(MAXL.GT.2) GO TO 370 G88DRV G88DRV D orbital: G88DRV G88DRV IMAX = I5D6D + 5 G88DRV ICORE(II) = ICORE(II) + IMAX G88DRV G88DRV If MAXL is less than 3 then there are no F orbitals: G88DRV G88DRV 370 IF(MAXL.LT.3) GO TO 400 G88DRV G88DRV F orbital: G88DRV G88DRV IMAX=7 G88DRV IF(I7F10F.EQ.1) IMAX=10 G88DRV ICORE(II) = ICORE(II) + IMAX G88DRV G88DRV Skip here when no more orbitals are found: G88DRV G88DRV 400 CONTINUE G88DRV 420 CONTINUE G88DRV G88DRV NPRIM(I) -- the number of gaussian primitives in the Ith shell: G88DRV G88DRV DO 480 I = 1,NSHELL G88DRV II = II + 1 G88DRV ICORE(II) = SHELLN(I) G88DRV 480 CONTINUE G88DRV G88DRV NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G88DRV EXP, CS, CP, etc.: G88DRV G88DRV DO 490 I = 1,NSHELL G88DRV II = II + 1 G88DRV ICORE(II) = SHELLA(I) G88DRV 490 CONTINUE G88DRV G88DRV EXP(I) -- orbital exponents indexed by NPTR: G88DRV G88DRV DO 500 I = 1,NEXP G88DRV II = II + 1 G88DRV CORE(II) = EXX(I) G88DRV 500 CONTINUE G88DRV G88DRV CS,CP -- orbital coefficients: G88DRV G88DRV DO 510 I = 1,NEXP G88DRV II = II + 1 G88DRV CORE(II) = C1(I) G88DRV 510 CONTINUE G88DRV DO 520 I = 1,NEXP G88DRV II = II + 1 G88DRV CORE(II) = C2(I) G88DRV 520 CONTINUE G88DRV G88DRV Zero CD and CF arrays: G88DRV G88DRV IHOLD = II G88DRV DO 550 I = 1,2*NEXP G88DRV II = II + 1 G88DRV CORE(II) = ZERO G88DRV 550 CONTINUE G88DRV G88DRV Build CD and CF from C3 and C4: G88DRV G88DRV DO 570 I = 1,NSHELL G88DRV IPTR = SHLADF(I) G88DRV IF(IPTR.GT.0) THEN G88DRV DO 560 J = 1,SHELLN(I) G88DRV LPTR = J + SHELLA(I) + IHOLD - 1 G88DRV MPTR = J + IPTR - 1 G88DRV CORE(LPTR) = C3(MPTR) G88DRV CORE(LPTR+NEXP) = C4(MPTR) G88DRV 560 CONTINUE G88DRV END IF G88DRV 570 CONTINUE G88DRV NFILE = 5 G88DRV CALL NBWRIT(CORE,II,NFILE) G88DRV RETURN G88DRV G88DRV 900 WRITE(LFNPR,990) G88DRV RETURN G88DRV G88DRV 990 FORMAT(/1X,'The NBO program is not set up to handle complex ', G88DRV + 'wave functions') G88DRV 1000 FORMAT(/1X,'Analyzing the SCF density') G88DRV 1010 FORMAT(/1X,'Analyzing the MP first order density') G88DRV 1020 FORMAT(/1X,'Analyzing the MP2 density') G88DRV 1030 FORMAT(/1X,'Analyzing the MP3 density') G88DRV 1040 FORMAT(/1X,'Analyzing the MP4 density') G88DRV 1050 FORMAT(/1X,'Analyzing the CI one-particle density') G88DRV 1060 FORMAT(/1X,'Analyzing the CI density') G88DRV 1070 FORMAT(/1X,'Analyzing the QCI/CC density') G88DRV 1080 FORMAT(/1X,'Analyzing the density correct to second order') G88DRV END G88DRV ***********************************************************************G88DRV SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G88DRV ***********************************************************************G88DRV IMPLICIT REAL*8 (A-H,O-Z) G88DRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) G88DRV LOGICAL NEW,ERROR,SEQ G88DRV G88DRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G88DRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G88DRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G88DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G88DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G88DRV + LFNDAF,LFNDEF G88DRV G88DRV If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G88DRV DAF to the RWFs. G88DRV G88DRV IF(NBOOPT(1).EQ.2) THEN G88DRV NEW = .FALSE. G88DRV CALL NBOPEN(NEW,ERROR) G88DRV IF(ERROR) THEN G88DRV WRITE(LFNPR,900) G88DRV STOP G88DRV END IF G88DRV L2 = NDIM * (NDIM + 1)/2 G88DRV IF(OPEN) THEN G88DRV ALPHA = .TRUE. G88DRV BETA = .FALSE. G88DRV CALL FENEWD(CORE) G88DRV CALL TWRITE(528,CORE,L2,1,L2,1,0) G88DRV ALPHA = .FALSE. G88DRV BETA = .TRUE. G88DRV CALL FENEWD(CORE) G88DRV CALL TWRITE(530,CORE,L2,1,L2,1,0) G88DRV ELSE G88DRV ALPHA = .FALSE. G88DRV BETA = .FALSE. G88DRV CALL FENEWD(CORE) G88DRV CALL TWRITE(528,CORE,L2,1,L2,1,0) G88DRV END IF G88DRV SEQ = .FALSE. G88DRV CALL NBCLOS(SEQ) G88DRV END IF G88DRV G88DRV If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G88DRV G88DRV IF(NBOOPT(1).EQ.3) THEN G88DRV NEW = .FALSE. G88DRV CALL NBOPEN(NEW,ERROR) G88DRV IF(ERROR) THEN G88DRV WRITE(LFNPR,900) G88DRV STOP G88DRV END IF G88DRV CALL TREAD(501,CORE,32,1,32,1,0) G88DRV CALL SVE0(CORE(32)) G88DRV SEQ = .FALSE. G88DRV CALL NBCLOS(SEQ) G88DRV END IF G88DRV RETURN G88DRV G88DRV 900 FORMAT(/1X,'Error opening the NBO direct access file in ', G88DRV + 'subroutine DELSCF.') G88DRV END G88DRV ***********************************************************************G88DRV G88DRV E N D O F G 8 8 N B O R O U T I N E S G88DRV G88DRV ***********************************************************************G88DRV ***********************************************************************G86DRV G86DRV G86DRV G 8 6 N B O G86DRV G86DRV G86DRV GAUSSIAN 86 VERSION OF NBO PROGRAM G86DRV G86DRV G86DRV DRIVER ROUTINES: G86DRV G86DRV SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G86DRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G86DRV SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G86DRV G86DRV ***********************************************************************G86DRV SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G86DRV ***********************************************************************G86DRV IMPLICIT REAL*8 (A-H,O-Z) G86DRV G86DRV PARAMETER (MAXFIL = 40) G86DRV G86DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G86DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G86DRV + LFNDAF,LFNDEF G86DRV COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) G86DRV CHARACTER*80 FILENM G86DRV G86DRV DIMENSION CORE(1),IOP(50) G86DRV DIMENSION NBOOPT(10) G86DRV G86DRV LFNIN = 5 G86DRV LFNPR = 6 G86DRV G86DRV DATA TENTH/0.1D0/ G86DRV G86DRV Set NBO options. G86DRV G86DRV DO 10 I = 1,9 G86DRV NBOOPT(I) = IOP(I+39) G86DRV 10 CONTINUE G86DRV NBOOPT(10) = 86 G86DRV G86DRV --- NBO analysis --- G86DRV G86DRV ICONTR = 0 G86DRV IF(ABS(NBOOPT(1)).LT.2) THEN G86DRV CALL CHARPN(4HNBO ) G86DRV CALL NBO(CORE,MEMORY,NBOOPT) G86DRV G86DRV Store the name of the NBO direct access file on the RWFiles G86DRV G86DRV DO 20 I = 1,80 G86DRV CORE(I) = ICHAR(FILENM(I:I)) G86DRV 20 CONTINUE G86DRV CORE(81) = LFNDAF G86DRV CALL TWRITE(636,CORE,81,1,81,1,0) G86DRV G86DRV --- NBO energetic analysis --- G86DRV G86DRV ELSE IF(NBOOPT(1).EQ.2) THEN G86DRV G86DRV Retrieve the name of the NBO direct access file from the RWFiles G86DRV G86DRV CALL TREAD(636,CORE,81,1,81,1,0) G86DRV DO 30 I = 1,80 G86DRV FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G86DRV 30 CONTINUE G86DRV LFNDAF = INT(ABS(CORE(81)) + TENTH) G86DRV CALL CHARPN(4HDELE) G86DRV CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G86DRV IF(IDONE.NE.0) ICONTR = 1 G86DRV IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT) G86DRV G86DRV ELSE IF(NBOOPT(1).EQ.3) THEN G86DRV CALL TREAD(636,CORE,81,1,81,1,0) G86DRV DO 40 I = 1,80 G86DRV FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G86DRV 40 CONTINUE G86DRV LFNDAF = INT(ABS(CORE(81)) + TENTH) G86DRV CALL CHARPN(4HEDEL) G86DRV CALL DELSCF(CORE,CORE,NBOOPT) G86DRV CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G86DRV END IF G86DRV G86DRV RETURN G86DRV END G86DRV ***********************************************************************G86DRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G86DRV ***********************************************************************G86DRV IMPLICIT REAL*8 (A-H,O-Z) G86DRV -----------------------------------------------------------------------G86DRV G86DRV Routine FEAOIN accesses the following records of the RWFs: G86DRV G86DRV 203 --- CI density matrix (alpha) G86DRV 204 --- CI density matrix (beta) G86DRV 501 --- Total energy G86DRV 502 --- Job title G86DRV 506 --- Basis set information G86DRV 512 --- Effective core potential information G86DRV 514 --- AO overlap matrix G86DRV 518 --- AO dipole integrals G86DRV 524 --- MO coefficients (alpha) G86DRV 526 --- MO coefficients (beta) G86DRV 528 --- SCF density matrix (alpha) G86DRV 530 --- SCF density matrix (beta) G86DRV 536 --- AO Fock matrix (alpha) G86DRV 538 --- AO Fock matrix (beta) G86DRV G86DRV ----------------------------------------------------------------------G86DRV G86DRV NBO Common blocks G86DRV G86DRV PARAMETER(MAXATM = 99,MAXBAS = 500) G86DRV G86DRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G86DRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G86DRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G86DRV COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, G86DRV + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, G86DRV + JCORE,JPRINT(60) G86DRV COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) G86DRV COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G86DRV + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) G86DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G86DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G86DRV + LFNDAF,LFNDEF G86DRV G86DRV GAUSSIAN 86 Common blocks G86DRV G86DRV COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(401), G86DRV * ATMCHG(400),C(1200) G86DRV COMMON/LP2/NLP(1600),CLP(1600),ZLP(1600),KFIRST(400,5), G86DRV * KLAST(400,5),LMAX(400),LPSKIP(400),NFroz(400) G86DRV COMMON/B/EXX(1200),C1(1200),C2(1200),C3(1200),X(400),Y(400), G86DRV * Z(400),JAN(400),SHELLA(400),SHELLN(400),SHELLT(400), G86DRV * SHELLC(400),AOS(400),AON(400),NSHELL,MAXTYP G86DRV INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON G86DRV DIMENSION C4(400),SHLADF(400) G86DRV EQUIVALENCE(C4(1),C3(401)),(SHLADF(1),C3(801)) G86DRV G86DRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) G86DRV DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G86DRV G86DRV Obtain the following information: G86DRV G86DRV ROHF =.TRUE. If RHF open shell wavefunction G86DRV =.FALSE. otherwise G86DRV G86DRV UHF =.TRUE. If UHF wavefunction G86DRV =.FALSE. otherwise G86DRV G86DRV AUHF =.TRUE. If spin-annihilated UHF wavefunction G86DRV =.FALSE. otherwise G86DRV G86DRV CI =.TRUE. If CI wavefunction G86DRV =.FALSE. otherwise G86DRV G86DRV OPEN =.TRUE. If open shell wavefunction G86DRV =.FALSE. otherwise G86DRV G86DRV COMPLX =.TRUE. If complex wavefunction G86DRV =.FALSE. otherwise G86DRV (Note: The program is not capable of handling this.) G86DRV G86DRV NATOMS Number of atomic centers G86DRV G86DRV NDIM Dimension of matrices (overlap and density) G86DRV G86DRV NBAS Number of basis functions (.le.NDIM) G86DRV G86DRV IPSEUD Set to one if pseudopotentials are used. G86DRV G86DRV IWCUBF This pertains only basis sets with F functions. G86DRV G86DRV If cartesian F functions are input, set IWCUBF to: G86DRV 0, if these are to be transformed to the G86DRV standard set of pure F functions G86DRV 1, if these are to be transformed to the G86DRV cubic set of pure F functions G86DRV G86DRV If pure F functions are input, set to IWCUBF to: G86DRV 0, if these are standard F functions G86DRV 1, if these are cubic F functions G86DRV G86DRV IATNO(I),I=1,NATOMS G86DRV List of atomic numbers G86DRV G86DRV LCTR(I),I=1,NBAS G86DRV List of atomic centers of the basis functions G86DRV (LCTR(3)=2 if basis function 3 is on atom 2) G86DRV G86DRV LANG(I),I=1,NBAS G86DRV List of angular symmetry information for the AO basis G86DRV G86DRV DATA LISTS/ 1/ G86DRV DATA LISTP/ 101, 102, 103/ G86DRV DATA LISTD/ 255, 252, 253, 254, 251, 0, G86DRV + 201, 204, 206, 202, 203, 205/ G86DRV DATA LISTF/ 351, 352, 353, 354, 355, 356, 357, 0, 0, 0, G86DRV + 301, 307, 310, 304, 302, 303, 306, 309, 308, 305/ G86DRV DATA ZERO/0.0D0/ G86DRV DATA TOANG/0.529177249/ G86DRV G86DRV Store job title on NBODAF: G86DRV G86DRV LEN = INTOWP(400+100) G86DRV CALL TREAD(502,ICORE,LEN,1,LEN,1,0) G86DRV NFILE = 2 G86DRV CALL NBWRIT(ICORE(401),10,NFILE) G86DRV G86DRV Get the number of atoms from NAT and store the atomic numbers in G86DRV IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G86DRV nuclear charges may not be equivalent if effective core potentials G86DRV (ECP) are used.) G86DRV G86DRV LEN = 0 G86DRV IEXIST = ITQRY(512) G86DRV IF(IEXIST.GT.0) THEN G86DRV LEN = 8 * 400 + 17 * INTOWP(400) G86DRV CALL TREAD(512,NLP,LEN,1,LEN,1,0) G86DRV END IF G86DRV NATOMS = NATOM G86DRV DO 20 I = 1,NATOMS G86DRV IATNO(I) = IAN(I) G86DRV IF(IEXIST.GT.0) THEN G86DRV IZNUC(I) = IATNO(I) - NFROZ(I) G86DRV IF(NFROZ(I).NE.0) IPSEUD = 1 G86DRV ELSE G86DRV IZNUC(I) = IATNO(I) G86DRV END IF G86DRV 20 CONTINUE G86DRV G86DRV Restore the basis set to COMMON/B/: G86DRV G86DRV LEN = 6000 + INTOWP(2802) G86DRV CALL TREAD(506,EXX,LEN,1,LEN,1,0) G86DRV G86DRV The Gaussian programs do not use cubic f basis functions. G86DRV Determine which set of d and f functions are being used, G86DRV Cartesian or pure): G86DRV G86DRV IWCUBF = 0 G86DRV CALL ILSW(2,2,I5D6D) G86DRV CALL ILSW(2,16,I7F10F) G86DRV G86DRV Construct the AO information lists: LCTR and LANG G86DRV G86DRV IBAS = 0 G86DRV DO 90 ISHELL = 1,400 G86DRV IF(IBAS.EQ.NBASIS) GOTO 100 G86DRV NCTR = JAN(ISHELL) G86DRV MAXL = SHELLT(ISHELL) G86DRV ICNSTR = SHELLC(ISHELL) G86DRV G86DRV Is an s orbital in the shell? G86DRV G86DRV KS = 0 G86DRV IF(MAXL.EQ.0) KS = 1 G86DRV IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G86DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G86DRV IF(KS.EQ.0) GOTO 30 G86DRV G86DRV s orbital: G86DRV G86DRV IBAS = IBAS + 1 G86DRV LCTR(IBAS) = NCTR G86DRV LANG(IBAS) = LISTS G86DRV G86DRV Is a set of p orbitals in the shell? G86DRV G86DRV 30 CONTINUE G86DRV KP = 0 G86DRV IF(MAXL.EQ.0) GOTO 90 G86DRV IF(MAXL.EQ.1) KP = 1 G86DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G86DRV IF(KP.EQ.0) GOTO 50 G86DRV G86DRV p orbitals: G86DRV G86DRV DO 40 I = 1,3 G86DRV IBAS = IBAS + 1 G86DRV LCTR(IBAS) = NCTR G86DRV LANG(IBAS) = LISTP(I) G86DRV 40 CONTINUE G86DRV G86DRV d orbitals: G86DRV G86DRV 50 IF(MAXL.NE.2) GOTO 70 G86DRV IMAX = I5D6D + 5 G86DRV KD = I5D6D + 1 G86DRV DO 60 I = 1,IMAX G86DRV IBAS = IBAS + 1 G86DRV LCTR(IBAS) = NCTR G86DRV LANG(IBAS) = LISTD(I,KD) G86DRV 60 CONTINUE G86DRV GO TO 90 G86DRV G86DRV f orbitals: G86DRV G86DRV 70 IF(MAXL.NE.3) GOTO 90 G86DRV IMAX = 7 G86DRV IF(I7F10F.EQ.1) IMAX = 10 G86DRV KF = I7F10F + 1 G86DRV DO 80 I = 1,IMAX G86DRV IBAS = IBAS + 1 G86DRV LCTR(IBAS) = NCTR G86DRV LANG(IBAS) = LISTF(I,KF) G86DRV 80 CONTINUE G86DRV 90 CONTINUE G86DRV 100 CONTINUE G86DRV NDIM = NBASIS G86DRV NBAS = NBASIS G86DRV G86DRV Determine the type of wave function the density matrix is from: G86DRV G86DRV IF(MULTIP.GT.1) OPEN = .TRUE. G86DRV IF(NBOOPT(2).NE.0) THEN G86DRV CI = .TRUE. G86DRV ELSE G86DRV CALL ILSW(2,1,ISCF) G86DRV CALL ILSW(2,22,IROHF) G86DRV IF(ISCF.EQ.1) UHF = .TRUE. G86DRV IF(UHF) OPEN = .TRUE. G86DRV IF(IROHF.EQ.1) ROHF = .TRUE. G86DRV IF(IROHF.EQ.2) ROHF = .TRUE. G86DRV IF(IROHF.EQ.3) MCSCF = .TRUE. G86DRV IF(ISCF.GT.1) COMPLX = .TRUE. G86DRV IF(COMPLX) GOTO 900 G86DRV END IF G86DRV IF(NBOOPT(5).EQ.1) AUHF = .TRUE. G86DRV ORTHO = .FALSE. G86DRV G86DRV No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G86DRV G86DRV IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G86DRV G86DRV Expectation values of the Fock operator are in atomic units: G86DRV G86DRV MUNIT = 0 G86DRV G86DRV Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G86DRV G86DRV ICORE(1) = NATOMS G86DRV ICORE(2) = NDIM G86DRV ICORE(3) = NBAS G86DRV ICORE(4) = MUNIT G86DRV ICORE(5) = 0 G86DRV IF(ROHF) ICORE(5) = 1 G86DRV ICORE(6) = 0 G86DRV IF(UHF) ICORE(6) = 1 G86DRV ICORE(7) = 0 G86DRV IF(CI) ICORE(7) = 1 G86DRV ICORE(8) = 0 G86DRV IF(OPEN) ICORE(8) = 1 G86DRV ICORE(9) = 0 G86DRV IF(MCSCF) ICORE(9) = 1 G86DRV ICORE(10) = 0 G86DRV IF(AUHF) ICORE(10) = 1 G86DRV ICORE(11) = 0 G86DRV IF(ORTHO) ICORE(11) = 1 G86DRV ICORE(12) = 1 G86DRV NFILE = 3 G86DRV CALL NBWRIT(ICORE,12,NFILE) G86DRV G86DRV Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G86DRV G86DRV II = 0 G86DRV DO 120 I = 1,NATOMS G86DRV II = II + 1 G86DRV ICORE(II) = IATNO(I) G86DRV 120 CONTINUE G86DRV DO 130 I = 1,NATOMS G86DRV II = II + 1 G86DRV ICORE(II) = IZNUC(I) G86DRV 130 CONTINUE G86DRV DO 140 I = 1,NBAS G86DRV II = II + 1 G86DRV ICORE(II) = LCTR(I) G86DRV 140 CONTINUE G86DRV DO 150 I = 1,NBAS G86DRV II = II + 1 G86DRV ICORE(II) = LANG(I) G86DRV 150 CONTINUE G86DRV NFILE = 4 G86DRV CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) G86DRV G86DRV Fetch the total energy from the RWF and store it on the NBODAF: G86DRV G86DRV CALL TREAD(501,CORE,32,1,32,1,0) G86DRV CORE(1) = CORE(32) G86DRV CORE(2) = CORE(32) G86DRV NFILE = 8 G86DRV CALL NBWRIT(CORE,2,NFILE) G86DRV G86DRV Store the atomic coordinates on the NBO DAF: (Note that these G86DRV coordinates are used in the calculation of dipole moments.) G86DRV G86DRV DO 160 I = 1,3*NATOMS G86DRV CORE(I) = C(I) * TOANG G86DRV 160 CONTINUE G86DRV NFILE = 9 G86DRV CALL NBWRIT(CORE,3*NATOMS,NFILE) G86DRV G86DRV Store the overlap matrix on the NBODAF: G86DRV G86DRV L2 = NDIM*(NDIM+1)/2 G86DRV CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV CALL PACK(CORE,NDIM,NBAS,L2) G86DRV NFILE = 10 G86DRV CALL NBWRIT(CORE,L2,NFILE) G86DRV G86DRV Store the density matrices on the NBODAF: G86DRV G86DRV L2 = NDIM*(NDIM+1)/2 G86DRV IF(CI) THEN G86DRV CALL TREAD(203,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV CALL PACK(CORE,NDIM,NBAS,L2) G86DRV NFILE = 20 G86DRV CALL NBWRIT(CORE,L2,NFILE) G86DRV IF(OPEN) THEN G86DRV CALL TREAD(204,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV CALL PACK(CORE,NDIM,NBAS,L2) G86DRV NFILE = 21 G86DRV CALL NBWRIT(CORE,L2,NFILE) G86DRV END IF G86DRV ELSE G86DRV CALL TREAD(528,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV CALL PACK(CORE,NDIM,NBAS,L2) G86DRV NFILE = 20 G86DRV CALL NBWRIT(CORE,L2,NFILE) G86DRV IF(OPEN) THEN G86DRV CALL TREAD(530,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV CALL PACK(CORE,NDIM,NBAS,L2) G86DRV NFILE = 21 G86DRV CALL NBWRIT(CORE,L2,NFILE) G86DRV END IF G86DRV END IF G86DRV G86DRV Store the Fock matrices on the NBODAF: G86DRV G86DRV IF(IWFOCK.NE.0) THEN G86DRV IEXIST = ITQRY(536) G86DRV IF(IEXIST.GT.0) THEN G86DRV L2 = NDIM*(NDIM+1)/2 G86DRV CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV CALL PACK(CORE,NDIM,NBAS,L2) G86DRV NFILE = 30 G86DRV CALL NBWRIT(CORE,L2,NFILE) G86DRV END IF G86DRV G86DRV IF(OPEN) THEN G86DRV IEXIST = ITQRY(538) G86DRV IF(IEXIST.GT.0) THEN G86DRV L2 = NDIM*(NDIM+1)/2 G86DRV CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1) G86DRV CALL PACK(CORE,NDIM,NBAS,L2) G86DRV NFILE = 31 G86DRV CALL NBWRIT(CORE,L2,NFILE) G86DRV END IF G86DRV END IF G86DRV END IF G86DRV G86DRV Store the AO to MO transformation matrices on the NBODAF: G86DRV G86DRV IEXIST = ITQRY(524) G86DRV IF(IEXIST.GT.0) THEN G86DRV L3 = NDIM*NDIM G86DRV CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0) G86DRV NFILE = 40 G86DRV CALL NBWRIT(CORE,L3,NFILE) G86DRV END IF G86DRV G86DRV IF(OPEN) THEN G86DRV IEXIST = ITQRY(526) G86DRV IF(IEXIST.GT.0) THEN G86DRV L3 = NDIM*NDIM G86DRV CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0) G86DRV NFILE = 41 G86DRV CALL NBWRIT(CORE,L3,NFILE) G86DRV END IF G86DRV END IF G86DRV G86DRV Store the x,y,z dipole integrals on the NBODAF: G86DRV G86DRV IEXIST = ITQRY(518) G86DRV IF(IEXIST.GT.0) THEN G86DRV L2 = NDIM*(NDIM+1)/2 G86DRV LEN = 3 * L2 G86DRV CALL TREAD(518,CORE,LEN,1,LEN,1,0) G86DRV DO 170 I = 1,LEN G86DRV CORE(I) = CORE(I) * TOANG G86DRV 170 CONTINUE G86DRV NFILE = 50 G86DRV CALL NBWRIT(CORE,L2,NFILE) G86DRV NFILE = 51 G86DRV CALL NBWRIT(CORE(L2+1),L2,NFILE) G86DRV NFILE = 52 G86DRV CALL NBWRIT(CORE(2*L2+1),L2,NFILE) G86DRV END IF G86DRV G86DRV Store the AO basis set info on the NBO DAF: (Note that two integers G86DRV and three integer arrays are stored first. Also remember that ICORE G86DRV and CORE occupy the same memory.) G86DRV G86DRV NEXP = 0 G86DRV DO 180 I = 1,1200 G86DRV IF(EXX(I).EQ.ZERO) GOTO 180 G86DRV NEXP = I G86DRV 180 CONTINUE G86DRV DO 190 I = 1,2+3*NSHELL+5*NEXP G86DRV CORE(I) = ZERO G86DRV 190 CONTINUE G86DRV ICORE(1) = NSHELL G86DRV ICORE(2) = NEXP G86DRV G86DRV Determine if Cartesian or pure D and F functions are used: G86DRV G86DRV CALL ILSW(2,2,I5D6D) G86DRV CALL ILSW(2,16,I7F10F) G86DRV G86DRV NCOMP(I) -- the number of components in the Ith shell: G86DRV G86DRV II = 2 G86DRV DO 420 I = 1,NSHELL G86DRV II = II + 1 G86DRV ICORE(II) = 0 G86DRV MAXL = SHELLT(I) G86DRV ICNSTR = SHELLC(I) G86DRV G86DRV Determine if an S orbital is in the shell: G86DRV G86DRV KS = 0 G86DRV IF(MAXL.EQ.0) KS = 1 G86DRV IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G86DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G86DRV IF(KS.EQ.0) GO TO 310 G86DRV G86DRV S orbital: G86DRV G86DRV ICORE(II) = ICORE(II) + 1 G86DRV G86DRV Determine if a set of P orbitals is in the shell: G86DRV G86DRV 310 CONTINUE G86DRV KP = 0 G86DRV IF(MAXL.EQ.0) GO TO 400 G86DRV IF(MAXL.EQ.1) KP = 1 G86DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G86DRV IF(KP.EQ.0) GO TO 340 G86DRV G86DRV P orbital: G86DRV G86DRV ICORE(II) = ICORE(II) + 3 G86DRV G86DRV If MAXL is less than 2 then there are no D or F orbitals: G86DRV If MAXL is greater than 2 then there must be F orbitals: G86DRV G86DRV 340 IF(MAXL.LT.2) GO TO 400 G86DRV IF(MAXL.GT.2) GO TO 370 G86DRV G86DRV D orbital: G86DRV G86DRV IMAX = I5D6D + 5 G86DRV ICORE(II) = ICORE(II) + IMAX G86DRV G86DRV If MAXL is less than 3 then there are no F orbitals: G86DRV G86DRV 370 IF(MAXL.LT.3) GO TO 400 G86DRV G86DRV F orbital: G86DRV G86DRV IMAX=7 G86DRV IF(I7F10F.EQ.1) IMAX=10 G86DRV ICORE(II) = ICORE(II) + IMAX G86DRV G86DRV Skip here when no more orbitals are found: G86DRV G86DRV 400 CONTINUE G86DRV 420 CONTINUE G86DRV G86DRV NPRIM(I) -- the number of gaussian primitives in the Ith shell: G86DRV G86DRV DO 480 I = 1,NSHELL G86DRV II = II + 1 G86DRV ICORE(II) = SHELLN(I) G86DRV 480 CONTINUE G86DRV G86DRV NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G86DRV EXP, CS, CP, etc.: G86DRV G86DRV DO 490 I = 1,NSHELL G86DRV II = II + 1 G86DRV ICORE(II) = SHELLA(I) G86DRV 490 CONTINUE G86DRV G86DRV EXP(I) -- orbital exponents indexed by NPTR: G86DRV G86DRV DO 500 I = 1,NEXP G86DRV II = II + 1 G86DRV CORE(II) = EXX(I) G86DRV 500 CONTINUE G86DRV G86DRV CS,CP -- orbital coefficients: G86DRV G86DRV DO 510 I = 1,NEXP G86DRV II = II + 1 G86DRV CORE(II) = C1(I) G86DRV 510 CONTINUE G86DRV DO 520 I = 1,NEXP G86DRV II = II + 1 G86DRV CORE(II) = C2(I) G86DRV 520 CONTINUE G86DRV G86DRV Zero CD and CF arrays: G86DRV G86DRV IHOLD = II G86DRV DO 550 I = 1,2*NEXP G86DRV II = II + 1 G86DRV CORE(II) = ZERO G86DRV 550 CONTINUE G86DRV G86DRV Build CD and CF from C3 and C4: G86DRV G86DRV DO 570 I = 1,NSHELL G86DRV IPTR = SHLADF(I) G86DRV IF(IPTR.GT.0) THEN G86DRV DO 560 J = 1,SHELLN(I) G86DRV LPTR = J + SHELLA(I) + IHOLD - 1 G86DRV MPTR = J + IPTR - 1 G86DRV CORE(LPTR) = C3(MPTR) G86DRV CORE(LPTR+NEXP) = C4(MPTR) G86DRV 560 CONTINUE G86DRV END IF G86DRV 570 CONTINUE G86DRV NFILE = 5 G86DRV CALL NBWRIT(CORE,II,NFILE) G86DRV RETURN G86DRV G86DRV 900 WRITE(LFNPR,1000) G86DRV RETURN G86DRV G86DRV 1000 FORMAT(/1X,'The NBO program is not set up to handle complex ', G86DRV + 'wave functions') G86DRV END G86DRV ***********************************************************************G86DRV SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G86DRV ***********************************************************************G86DRV IMPLICIT REAL*8 (A-H,O-Z) G86DRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) G86DRV LOGICAL NEW,ERROR,SEQ G86DRV G86DRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G86DRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G86DRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G86DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G86DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G86DRV + LFNDAF,LFNDEF G86DRV G86DRV If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G86DRV DAF to the RWFs. G86DRV G86DRV IF(NBOOPT(1).EQ.2) THEN G86DRV NEW = .FALSE. G86DRV CALL NBOPEN(NEW,ERROR) G86DRV IF(ERROR) THEN G86DRV WRITE(LFNPR,900) G86DRV STOP G86DRV END IF G86DRV L2 = NDIM * (NDIM + 1)/2 G86DRV IF(OPEN) THEN G86DRV ALPHA = .TRUE. G86DRV BETA = .FALSE. G86DRV CALL FENEWD(CORE) G86DRV CALL TWRITE(528,CORE,L2,1,L2,1,0) G86DRV ALPHA = .FALSE. G86DRV BETA = .TRUE. G86DRV CALL FENEWD(CORE) G86DRV CALL TWRITE(530,CORE,L2,1,L2,1,0) G86DRV ELSE G86DRV ALPHA = .FALSE. G86DRV BETA = .FALSE. G86DRV CALL FENEWD(CORE) G86DRV CALL TWRITE(528,CORE,L2,1,L2,1,0) G86DRV END IF G86DRV SEQ = .FALSE. G86DRV CALL NBCLOS(SEQ) G86DRV END IF G86DRV G86DRV If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G86DRV G86DRV IF(NBOOPT(1).EQ.3) THEN G86DRV NEW = .FALSE. G86DRV CALL NBOPEN(NEW,ERROR) G86DRV IF(ERROR) THEN G86DRV WRITE(LFNPR,900) G86DRV STOP G86DRV END IF G86DRV CALL TREAD(501,CORE,32,1,32,1,0) G86DRV CALL SVE0(CORE(32)) G86DRV SEQ = .FALSE. G86DRV CALL NBCLOS(SEQ) G86DRV END IF G86DRV RETURN G86DRV G86DRV 900 FORMAT(/1X,'Error opening the NBO direct access file in ', G86DRV + 'subroutine DELSCF.') G86DRV END G86DRV ***********************************************************************G86DRV G86DRV E N D O F G 8 6 N B O R O U T I N E S G86DRV G86DRV ***********************************************************************G86DRV ***********************************************************************G82DRV G82DRV G82DRV G 8 2 N B O G82DRV G82DRV G82DRV GAUSSIAN 82 VERSION OF NBO PROGRAM G82DRV G82DRV G82DRV DRIVER ROUTINES: G82DRV G82DRV SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G82DRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G82DRV SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G82DRV G82DRV ***********************************************************************G82DRV SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR) G82DRV ***********************************************************************G82DRV IMPLICIT REAL*8 (A-H,O-Z) G82DRV G82DRV PARAMETER (MAXFIL = 40) G82DRV G82DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G82DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G82DRV + LFNDAF,LFNDEF G82DRV COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL) G82DRV CHARACTER*80 FILENM G82DRV G82DRV DIMENSION CORE(1),IOP(50) G82DRV DIMENSION NBOOPT(10) G82DRV G82DRV LFNIN = 5 G82DRV LFNPR = 6 G82DRV G82DRV DATA TENTH/0.1D0/ G82DRV G82DRV Set NBO options. G82DRV G82DRV DO 10 I = 1,9 G82DRV NBOOPT(I) = IOP(I+39) G82DRV 10 CONTINUE G82DRV NBOOPT(10) = 82 G82DRV G82DRV --- NBO analysis --- G82DRV G82DRV ICONTR = 0 G82DRV IF(ABS(NBOOPT(1)).LT.2) THEN G82DRV CALL CHARPN(4HNBO ) G82DRV CALL NBO(CORE,MEMORY,NBOOPT) G82DRV G82DRV Store the name of the NBO direct access file on the RWFiles G82DRV G82DRV DO 20 I = 1,80 G82DRV CORE(I) = ICHAR(FILENM(I:I)) G82DRV 20 CONTINUE G82DRV CORE(81) = LFNDAF G82DRV CALL TWRITE(636,CORE,81,1,81,1,0) G82DRV G82DRV --- NBO energetic analysis --- G82DRV G82DRV ELSE IF(NBOOPT(1).EQ.2) THEN G82DRV G82DRV Retrieve the name of the NBO direct access file from the RWFiles G82DRV G82DRV CALL TREAD(636,CORE,81,1,81,1,0) G82DRV DO 30 I = 1,80 G82DRV FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G82DRV 30 CONTINUE G82DRV LFNDAF = INT(ABS(CORE(81)) + TENTH) G82DRV CALL CHARPN(4HDELE) G82DRV CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G82DRV IF(IDONE.NE.0) ICONTR = 1 G82DRV IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT) G82DRV G82DRV ELSE IF(NBOOPT(1).EQ.3) THEN G82DRV CALL TREAD(636,CORE,81,1,81,1,0) G82DRV DO 40 I = 1,80 G82DRV FILENM(I:I) = CHAR(INT(CORE(I) + TENTH)) G82DRV 40 CONTINUE G82DRV LFNDAF = INT(ABS(CORE(81)) + TENTH) G82DRV CALL CHARPN(4HEDEL) G82DRV CALL DELSCF(CORE,CORE,NBOOPT) G82DRV CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) G82DRV END IF G82DRV G82DRV RETURN G82DRV END G82DRV ***********************************************************************G82DRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) G82DRV ***********************************************************************G82DRV IMPLICIT REAL*8 (A-H,O-Z) G82DRV -----------------------------------------------------------------------G82DRV G82DRV Routine FEAOIN accesses the following records of the RWFs: G82DRV G82DRV 203 --- CI density matrix (alpha) G82DRV 204 --- CI density matrix (beta) G82DRV 501 --- Total energy G82DRV 502 --- Job title G82DRV 506 --- Basis set information G82DRV 512 --- Effective core potential information G82DRV 514 --- AO overlap matrix G82DRV 518 --- x dipole integrals G82DRV 519 --- y dipole integrals G82DRV 520 --- z dipole integrals G82DRV 524 --- MO coefficients (alpha) G82DRV 526 --- MO coefficients (beta) G82DRV 528 --- SCF density matrix (alpha) G82DRV 530 --- SCF density matrix (beta) G82DRV 536 --- AO Fock matrix (alpha) G82DRV 538 --- AO Fock matrix (beta) G82DRV G82DRV ----------------------------------------------------------------------G82DRV G82DRV NBO Common blocks G82DRV G82DRV PARAMETER(MAXATM = 99,MAXBAS = 500) G82DRV G82DRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G82DRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G82DRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G82DRV COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, G82DRV + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, G82DRV + JCORE,JPRINT(60) G82DRV COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) G82DRV COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G82DRV + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) G82DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G82DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G82DRV + LFNDAF,LFNDEF G82DRV G82DRV GAUSSIAN 82 Common blocks G82DRV G82DRV COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(101), G82DRV * ATMCHG(100),C(300) G82DRV COMMON/LP2/NLP(400),CLP(400),ZLP(400),KFIRST(100,5), G82DRV * KLAST(100,5),LMAX(100),LPSKIP(100),NFroz(100) G82DRV COMMON/B/EXX(240),C1(240),C2(240),C3(240),X(80),Y(80), G82DRV * Z(80),JAN(80),SHELLA(80),SHELLN(80),SHELLT(80), G82DRV * SHELLC(80),AOS(80),AON(80),NSHELL,MAXTYP G82DRV INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON G82DRV DIMENSION C4(80),SHLADF(80) G82DRV EQUIVALENCE(C4(1),C3(81)),(SHLADF(1),C3(161)) G82DRV G82DRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) G82DRV DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2) G82DRV G82DRV Obtain the following information: G82DRV G82DRV ROHF =.TRUE. If RHF open shell wavefunction G82DRV =.FALSE. otherwise G82DRV G82DRV UHF =.TRUE. If UHF wavefunction G82DRV =.FALSE. otherwise G82DRV G82DRV AUHF =.TRUE. If spin-annihilated UHF wavefunction G82DRV =.FALSE. otherwise G82DRV G82DRV CI =.TRUE. If CI wavefunction G82DRV =.FALSE. otherwise G82DRV G82DRV OPEN =.TRUE. If open shell wavefunction G82DRV =.FALSE. otherwise G82DRV G82DRV COMPLX =.TRUE. If complex wavefunction G82DRV =.FALSE. otherwise G82DRV (Note: The program is not capable of handling this.) G82DRV G82DRV NATOMS Number of atomic centers G82DRV G82DRV NDIM Dimension of matrices (overlap and density) G82DRV G82DRV NBAS Number of basis functions (.le.NDIM) G82DRV G82DRV IPSEUD Set to one if pseudopotentials are used. G82DRV G82DRV IWCUBF This pertains only basis sets with F functions. G82DRV G82DRV If cartesian F functions are input, set IWCUBF to: G82DRV 0, if these are to be transformed to the G82DRV standard set of pure F functions G82DRV 1, if these are to be transformed to the G82DRV cubic set of pure F functions G82DRV G82DRV If pure F functions are input, set to IWCUBF to: G82DRV 0, if these are standard F functions G82DRV 1, if these are cubic F functions G82DRV G82DRV IATNO(I),I=1,NATOMS G82DRV List of atomic numbers G82DRV G82DRV LCTR(I),I=1,NBAS G82DRV List of atomic centers of the basis functions G82DRV (LCTR(3)=2 if basis function 3 is on atom 2) G82DRV G82DRV LANG(I),I=1,NBAS G82DRV List of angular symmetry information for the AO basis G82DRV G82DRV DATA LISTS/ 1/ G82DRV DATA LISTP/ 101, 102, 103/ G82DRV DATA LISTD/ 255, 252, 253, 254, 251, 0, G82DRV + 201, 204, 206, 202, 203, 205/ G82DRV DATA LISTF/ 351, 352, 353, 354, 355, 356, 357, 0, 0, 0, G82DRV + 301, 307, 310, 304, 302, 303, 306, 309, 308, 305/ G82DRV DATA ZERO/0.0D0/ G82DRV DATA TOANG/0.529177249/ G82DRV G82DRV Store job title on NBODAF: G82DRV G82DRV LEN = INTOWP(500) G82DRV CALL TREAD(502,ICORE,LEN,1,LEN,1,0) G82DRV NFILE = 2 G82DRV CALL NBWRIT(ICORE(401),10,NFILE) G82DRV G82DRV Get the number of atoms from NAT and store the atomic numbers in G82DRV IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and G82DRV nuclear charges may not be equivalent if effective core potentials G82DRV (ECP) are used.) G82DRV G82DRV LEN = 0 G82DRV IEXIST = ITQRY(512) G82DRV IF(IEXIST.GT.0) THEN G82DRV LEN = 2 * 400 + 17 * INTOWP(100) G82DRV CALL TREAD(512,NLP,LEN,1,LEN,1,0) G82DRV END IF G82DRV NATOMS = NATOM G82DRV DO 20 I = 1,NATOMS G82DRV IATNO(I) = IAN(I) G82DRV IF(IEXIST.GT.0) THEN G82DRV IZNUC(I) = IATNO(I) - NFROZ(I) G82DRV IF(NFROZ(I).NE.0) IPSEUD = 1 G82DRV ELSE G82DRV IZNUC(I) = IATNO(I) G82DRV END IF G82DRV 20 CONTINUE G82DRV G82DRV Restore the basis set to COMMON/B/: G82DRV G82DRV LEN = 1200 + INTOWP(562) G82DRV CALL TREAD(506,EXX,LEN,1,LEN,1,0) G82DRV G82DRV The Gaussian programs do not use cubic f basis functions. G82DRV Determine which set of d and f functions are being used, G82DRV Cartesian or pure): G82DRV G82DRV IWCUBF = 0 G82DRV CALL ILSW(2,2,I5D6D) G82DRV CALL ILSW(2,16,I7F10F) G82DRV G82DRV Construct the AO information lists: LCTR and LANG G82DRV G82DRV IBAS = 0 G82DRV DO 90 ISHELL = 1,80 G82DRV IF(IBAS.EQ.NBASIS) GOTO 100 G82DRV NCTR = JAN(ISHELL) G82DRV MAXL = SHELLT(ISHELL) G82DRV ICNSTR = SHELLC(ISHELL) G82DRV G82DRV Is an s orbital in the shell? G82DRV G82DRV KS = 0 G82DRV IF(MAXL.EQ.0) KS = 1 G82DRV IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G82DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G82DRV IF(KS.EQ.0) GOTO 30 G82DRV G82DRV s orbital: G82DRV G82DRV IBAS = IBAS + 1 G82DRV LCTR(IBAS) = NCTR G82DRV LANG(IBAS) = LISTS G82DRV G82DRV Is a set of p orbitals in the shell? G82DRV G82DRV 30 CONTINUE G82DRV KP = 0 G82DRV IF(MAXL.EQ.0) GOTO 90 G82DRV IF(MAXL.EQ.1) KP = 1 G82DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G82DRV IF(KP.EQ.0) GOTO 50 G82DRV G82DRV p orbitals: G82DRV G82DRV DO 40 I = 1,3 G82DRV IBAS = IBAS + 1 G82DRV LCTR(IBAS) = NCTR G82DRV LANG(IBAS) = LISTP(I) G82DRV 40 CONTINUE G82DRV G82DRV d orbitals: G82DRV G82DRV 50 IF(MAXL.NE.2) GOTO 70 G82DRV IMAX = I5D6D + 5 G82DRV KD = I5D6D + 1 G82DRV DO 60 I = 1,IMAX G82DRV IBAS = IBAS + 1 G82DRV LCTR(IBAS) = NCTR G82DRV LANG(IBAS) = LISTD(I,KD) G82DRV 60 CONTINUE G82DRV GO TO 90 G82DRV G82DRV f orbitals: G82DRV G82DRV 70 IF(MAXL.NE.3) GOTO 90 G82DRV IMAX = 7 G82DRV IF(I7F10F.EQ.1) IMAX = 10 G82DRV KF = I7F10F + 1 G82DRV DO 80 I = 1,IMAX G82DRV IBAS = IBAS + 1 G82DRV LCTR(IBAS) = NCTR G82DRV LANG(IBAS) = LISTF(I,KF) G82DRV 80 CONTINUE G82DRV 90 CONTINUE G82DRV 100 CONTINUE G82DRV NDIM = NBASIS G82DRV NBAS = NBASIS G82DRV G82DRV Determine the type of wave function the density matrix is from: G82DRV G82DRV IF(MULTIP.GT.1) OPEN = .TRUE. G82DRV IF(NBOOPT(2).NE.0) THEN G82DRV CI = .TRUE. G82DRV ELSE G82DRV CALL ILSW(2,1,ISCF) G82DRV CALL ILSW(2,22,IROHF) G82DRV IF(ISCF.EQ.1) UHF = .TRUE. G82DRV IF(UHF) OPEN = .TRUE. G82DRV IF(IROHF.EQ.1) ROHF = .TRUE. G82DRV IF(IROHF.EQ.2) ROHF = .TRUE. G82DRV IF(IROHF.EQ.3) MCSCF = .TRUE. G82DRV IF(ISCF.GT.1) COMPLX = .TRUE. G82DRV IF(COMPLX) GOTO 900 G82DRV END IF G82DRV IF(NBOOPT(5).EQ.1) AUHF = .TRUE. G82DRV ORTHO = .FALSE. G82DRV G82DRV No Fock matrices for ROHF, MCSCF, or CI wavefunctions: G82DRV G82DRV IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 G82DRV G82DRV Expectation values of the Fock operator are in atomic units: G82DRV G82DRV MUNIT = 0 G82DRV G82DRV Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: G82DRV G82DRV ICORE(1) = NATOMS G82DRV ICORE(2) = NDIM G82DRV ICORE(3) = NBAS G82DRV ICORE(4) = MUNIT G82DRV ICORE(5) = 0 G82DRV IF(ROHF) ICORE(5) = 1 G82DRV ICORE(6) = 0 G82DRV IF(UHF) ICORE(6) = 1 G82DRV ICORE(7) = 0 G82DRV IF(CI) ICORE(7) = 1 G82DRV ICORE(8) = 0 G82DRV IF(OPEN) ICORE(8) = 1 G82DRV ICORE(9) = 0 G82DRV IF(MCSCF) ICORE(9) = 1 G82DRV ICORE(10) = 0 G82DRV IF(AUHF) ICORE(10) = 1 G82DRV ICORE(11) = 0 G82DRV IF(ORTHO) ICORE(11) = 1 G82DRV ICORE(12) = 1 G82DRV NFILE = 3 G82DRV CALL NBWRIT(ICORE,12,NFILE) G82DRV G82DRV Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: G82DRV G82DRV II = 0 G82DRV DO 120 I = 1,NATOMS G82DRV II = II + 1 G82DRV ICORE(II) = IATNO(I) G82DRV 120 CONTINUE G82DRV DO 130 I = 1,NATOMS G82DRV II = II + 1 G82DRV ICORE(II) = IZNUC(I) G82DRV 130 CONTINUE G82DRV DO 140 I = 1,NBAS G82DRV II = II + 1 G82DRV ICORE(II) = LCTR(I) G82DRV 140 CONTINUE G82DRV DO 150 I = 1,NBAS G82DRV II = II + 1 G82DRV ICORE(II) = LANG(I) G82DRV 150 CONTINUE G82DRV NFILE = 4 G82DRV CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) G82DRV G82DRV Fetch the total energy from the RWF and store it on the NBODAF: G82DRV G82DRV CALL TREAD(501,CORE,32,1,32,1,0) G82DRV CORE(1) = CORE(32) G82DRV CORE(2) = CORE(32) G82DRV NFILE = 8 G82DRV CALL NBWRIT(CORE,2,NFILE) G82DRV G82DRV Store the atomic coordinates on the NBO DAF: (Note that these G82DRV coordinates are used in the calculation of dipole moments.) G82DRV G82DRV DO 160 I = 1,3*NATOMS G82DRV CORE(I) = C(I) * TOANG G82DRV 160 CONTINUE G82DRV NFILE = 9 G82DRV CALL NBWRIT(CORE,3*NATOMS,NFILE) G82DRV G82DRV Store the overlap matrix on the NBODAF: G82DRV G82DRV L2 = NDIM*(NDIM+1)/2 G82DRV CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV CALL PACK(CORE,NDIM,NBAS,L2) G82DRV NFILE = 10 G82DRV CALL NBWRIT(CORE,L2,NFILE) G82DRV G82DRV Store the density matrices on the NBODAF: G82DRV G82DRV L2 = NDIM*(NDIM+1)/2 G82DRV IF(CI) THEN G82DRV CALL TREAD(203,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV CALL PACK(CORE,NDIM,NBAS,L2) G82DRV NFILE = 20 G82DRV CALL NBWRIT(CORE,L2,NFILE) G82DRV IF(OPEN) THEN G82DRV CALL TREAD(204,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV CALL PACK(CORE,NDIM,NBAS,L2) G82DRV NFILE = 21 G82DRV CALL NBWRIT(CORE,L2,NFILE) G82DRV END IF G82DRV ELSE G82DRV CALL TREAD(528,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV CALL PACK(CORE,NDIM,NBAS,L2) G82DRV NFILE = 20 G82DRV CALL NBWRIT(CORE,L2,NFILE) G82DRV IF(OPEN) THEN G82DRV CALL TREAD(530,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV CALL PACK(CORE,NDIM,NBAS,L2) G82DRV NFILE = 21 G82DRV CALL NBWRIT(CORE,L2,NFILE) G82DRV END IF G82DRV END IF G82DRV G82DRV Store the Fock matrices on the NBODAF: G82DRV G82DRV IF(IWFOCK.NE.0) THEN G82DRV IEXIST = ITQRY(536) G82DRV IF(IEXIST.GT.0) THEN G82DRV L2 = NDIM*(NDIM+1)/2 G82DRV CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV CALL PACK(CORE,NDIM,NBAS,L2) G82DRV NFILE = 30 G82DRV CALL NBWRIT(CORE,L2,NFILE) G82DRV END IF G82DRV G82DRV IF(OPEN) THEN G82DRV IEXIST = ITQRY(538) G82DRV IF(IEXIST.GT.0) THEN G82DRV L2 = NDIM*(NDIM+1)/2 G82DRV CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1) G82DRV CALL PACK(CORE,NDIM,NBAS,L2) G82DRV NFILE = 31 G82DRV CALL NBWRIT(CORE,L2,NFILE) G82DRV END IF G82DRV END IF G82DRV END IF G82DRV G82DRV Store the AO to MO transformation matrices on the NBODAF: G82DRV G82DRV IEXIST = ITQRY(524) G82DRV IF(IEXIST.GT.0) THEN G82DRV L3 = NDIM*NDIM G82DRV CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0) G82DRV NFILE = 40 G82DRV CALL NBWRIT(CORE,L3,NFILE) G82DRV END IF G82DRV G82DRV IF(OPEN) THEN G82DRV IEXIST = ITQRY(526) G82DRV IF(IEXIST.GT.0) THEN G82DRV L3 = NDIM*NDIM G82DRV CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0) G82DRV NFILE = 41 G82DRV CALL NBWRIT(CORE,L3,NFILE) G82DRV END IF G82DRV END IF G82DRV G82DRV Store the x,y,z dipole integrals on the NBODAF: G82DRV G82DRV IEXIST = ITQRY(518) G82DRV IEXIST = MIN(IEXIST,ITQRY(519)) G82DRV IEXIST = MIN(IEXIST,ITQRY(520)) G82DRV IF(IEXIST.GT.0) THEN G82DRV L2 = NDIM*(NDIM+1)/2 G82DRV CALL TREAD(518,CORE(1),L2,1,L2,1,0) G82DRV CALL TREAD(519,CORE(L2+1),L2,1,L2,1,0) G82DRV CALL TREAD(520,CORE(2*L2+1),L2,1,L2,1,0) G82DRV DO 170 I = 1,3*L2 G82DRV CORE(I) = CORE(I) * TOANG G82DRV 170 CONTINUE G82DRV NFILE = 50 G82DRV CALL NBWRIT(CORE,L2,NFILE) G82DRV NFILE = 51 G82DRV CALL NBWRIT(CORE(L2+1),L2,NFILE) G82DRV NFILE = 52 G82DRV CALL NBWRIT(CORE(2*L2+1),L2,NFILE) G82DRV END IF G82DRV G82DRV Store the AO basis set info on the NBO DAF: (Note that two integers G82DRV and three integer arrays are stored first. Also remember that ICORE G82DRV and CORE occupy the same memory.) G82DRV G82DRV NEXP = 0 G82DRV DO 180 I = 1,240 G82DRV IF(EXX(I).EQ.ZERO) GOTO 180 G82DRV NEXP = I G82DRV 180 CONTINUE G82DRV DO 190 I = 1,2+3*NSHELL+5*NEXP G82DRV CORE(I) = ZERO G82DRV 190 CONTINUE G82DRV ICORE(1) = NSHELL G82DRV ICORE(2) = NEXP G82DRV G82DRV Determine if Cartesian or pure D and F functions are used: G82DRV G82DRV CALL ILSW(2,2,I5D6D) G82DRV CALL ILSW(2,16,I7F10F) G82DRV G82DRV NCOMP(I) -- the number of components in the Ith shell: G82DRV G82DRV II = 2 G82DRV DO 420 I = 1,NSHELL G82DRV II = II + 1 G82DRV ICORE(II) = 0 G82DRV MAXL = SHELLT(I) G82DRV ICNSTR = SHELLC(I) G82DRV G82DRV Determine if an S orbital is in the shell: G82DRV G82DRV KS = 0 G82DRV IF(MAXL.EQ.0) KS = 1 G82DRV IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1 G82DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1 G82DRV IF(KS.EQ.0) GO TO 310 G82DRV G82DRV S orbital: G82DRV G82DRV ICORE(II) = ICORE(II) + 1 G82DRV G82DRV Determine if a set of P orbitals is in the shell: G82DRV G82DRV 310 CONTINUE G82DRV KP = 0 G82DRV IF(MAXL.EQ.0) GO TO 400 G82DRV IF(MAXL.EQ.1) KP = 1 G82DRV IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1 G82DRV IF(KP.EQ.0) GO TO 340 G82DRV G82DRV P orbital: G82DRV G82DRV ICORE(II) = ICORE(II) + 3 G82DRV G82DRV If MAXL is less than 2 then there are no D or F orbitals: G82DRV If MAXL is greater than 2 then there must be F orbitals: G82DRV G82DRV 340 IF(MAXL.LT.2) GO TO 400 G82DRV IF(MAXL.GT.2) GO TO 370 G82DRV G82DRV D orbital: G82DRV G82DRV IMAX = I5D6D + 5 G82DRV ICORE(II) = ICORE(II) + IMAX G82DRV G82DRV If MAXL is less than 3 then there are no F orbitals: G82DRV G82DRV 370 IF(MAXL.LT.3) GO TO 400 G82DRV G82DRV F orbital: G82DRV G82DRV IMAX=7 G82DRV IF(I7F10F.EQ.1) IMAX=10 G82DRV ICORE(II) = ICORE(II) + IMAX G82DRV G82DRV Skip here when no more orbitals are found: G82DRV G82DRV 400 CONTINUE G82DRV 420 CONTINUE G82DRV G82DRV NPRIM(I) -- the number of gaussian primitives in the Ith shell: G82DRV G82DRV DO 480 I = 1,NSHELL G82DRV II = II + 1 G82DRV ICORE(II) = SHELLN(I) G82DRV 480 CONTINUE G82DRV G82DRV NPTR(I) -- pointer for the Ith shell into the gaussian parameters, G82DRV EXP, CS, CP, etc.: G82DRV G82DRV DO 490 I = 1,NSHELL G82DRV II = II + 1 G82DRV ICORE(II) = SHELLA(I) G82DRV 490 CONTINUE G82DRV G82DRV EXP(I) -- orbital exponents indexed by NPTR: G82DRV G82DRV DO 500 I = 1,NEXP G82DRV II = II + 1 G82DRV CORE(II) = EXX(I) G82DRV 500 CONTINUE G82DRV G82DRV CS,CP -- orbital coefficients: G82DRV G82DRV DO 510 I = 1,NEXP G82DRV II = II + 1 G82DRV CORE(II) = C1(I) G82DRV 510 CONTINUE G82DRV DO 520 I = 1,NEXP G82DRV II = II + 1 G82DRV CORE(II) = C2(I) G82DRV 520 CONTINUE G82DRV G82DRV Zero CD and CF arrays: G82DRV G82DRV IHOLD = II G82DRV DO 550 I = 1,2*NEXP G82DRV II = II + 1 G82DRV CORE(II) = ZERO G82DRV 550 CONTINUE G82DRV G82DRV Build CD and CF from C3 and C4: G82DRV G82DRV DO 570 I = 1,NSHELL G82DRV IPTR = SHLADF(I) G82DRV IF(IPTR.GT.0) THEN G82DRV DO 560 J = 1,SHELLN(I) G82DRV LPTR = J + SHELLA(I) + IHOLD - 1 G82DRV MPTR = J + IPTR - 1 G82DRV CORE(LPTR) = C3(MPTR) G82DRV CORE(LPTR+NEXP) = C4(MPTR) G82DRV 560 CONTINUE G82DRV END IF G82DRV 570 CONTINUE G82DRV NFILE = 5 G82DRV CALL NBWRIT(CORE,II,NFILE) G82DRV RETURN G82DRV G82DRV 900 WRITE(LFNPR,1000) G82DRV RETURN G82DRV G82DRV 1000 FORMAT(/1X,'The NBO program is not set up to handle complex ', G82DRV + 'wave functions') G82DRV END G82DRV ***********************************************************************G82DRV SUBROUTINE DELSCF(CORE,ICORE,NBOOPT) G82DRV ***********************************************************************G82DRV IMPLICIT REAL*8 (A-H,O-Z) G82DRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) G82DRV LOGICAL NEW,ERROR,SEQ G82DRV G82DRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G82DRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G82DRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT G82DRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G82DRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G82DRV + LFNDAF,LFNDEF G82DRV G82DRV If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO G82DRV DAF to the RWFs. G82DRV G82DRV IF(NBOOPT(1).EQ.2) THEN G82DRV NEW = .FALSE. G82DRV CALL NBOPEN(NEW,ERROR) G82DRV IF(ERROR) THEN G82DRV WRITE(LFNPR,900) G82DRV STOP G82DRV END IF G82DRV L2 = NDIM * (NDIM + 1)/2 G82DRV IF(OPEN) THEN G82DRV ALPHA = .TRUE. G82DRV BETA = .FALSE. G82DRV CALL FENEWD(CORE) G82DRV CALL TWRITE(528,CORE,L2,1,L2,1,0) G82DRV ALPHA = .FALSE. G82DRV BETA = .TRUE. G82DRV CALL FENEWD(CORE) G82DRV CALL TWRITE(530,CORE,L2,1,L2,1,0) G82DRV ELSE G82DRV ALPHA = .FALSE. G82DRV BETA = .FALSE. G82DRV CALL FENEWD(CORE) G82DRV CALL TWRITE(528,CORE,L2,1,L2,1,0) G82DRV END IF G82DRV SEQ = .FALSE. G82DRV CALL NBCLOS(SEQ) G82DRV END IF G82DRV G82DRV If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF: G82DRV G82DRV IF(NBOOPT(1).EQ.3) THEN G82DRV NEW = .FALSE. G82DRV CALL NBOPEN(NEW,ERROR) G82DRV IF(ERROR) THEN G82DRV WRITE(LFNPR,900) G82DRV STOP G82DRV END IF G82DRV CALL TREAD(501,CORE,32,1,32,1,0) G82DRV CALL SVE0(CORE(32)) G82DRV SEQ = .FALSE. G82DRV CALL NBCLOS(SEQ) G82DRV END IF G82DRV RETURN G82DRV G82DRV 900 FORMAT(/1X,'Error opening the NBO direct access file in ', G82DRV + 'subroutine DELSCF.') G82DRV END G82DRV ***********************************************************************G82DRV G82DRV E N D O F G 8 2 N B O R O U T I N E S G82DRV G82DRV ***********************************************************************G82DRV ***********************************************************************GMSDRV GMSDRV GMSDRV G M S N B O GMSDRV GMSDRV GMSDRV GAMESS VERSION OF NBO PROGRAM GMSDRV GMSDRV GMSDRV DRIVER ROUTINES: GMSDRV GMSDRV SUBROUTINE RUNNBO GMSDRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GMSDRV SUBROUTINE DELSCF(A,IA) GMSDRV GMSDRV ***********************************************************************GMSDRV SUBROUTINE RUNNBO GMSDRV ***********************************************************************GMSDRV IMPLICIT REAL*8 (A-H,O-Z) GMSDRV DIMENSION NBOOPT(10) GMSDRV GMSDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GMSDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GMSDRV + LFNDAF,LFNDEF GMSDRV GMSDRV GAMESS Common Block: GMSDRV GMSDRV COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(99) GMSDRV COMMON /FMCOM/ CORE(1) GMSDRV GMSDRV LFNIN = IR GMSDRV LFNPR = IW GMSDRV GMSDRV Determine the amount of available memory for the NBO analysis. GMSDRV GMSDRV CALL VALFM(ICUR) GMSDRV CALL GOTFM(MEMORY) GMSDRV GMSDRV Set NBO options. GMSDRV GMSDRV NBOOPT(1) = 0 GMSDRV NBOOPT(2) = 0 GMSDRV NBOOPT(3) = 0 GMSDRV NBOOPT(4) = 0 GMSDRV NBOOPT(5) = 0 GMSDRV NBOOPT(6) = 0 GMSDRV NBOOPT(7) = 0 GMSDRV NBOOPT(8) = 0 GMSDRV NBOOPT(9) = 0 GMSDRV NBOOPT(10) = 6 GMSDRV GMSDRV Perform the NPA/NBO/NLMO analyses. GMSDRV GMSDRV CALL NBO(CORE(ICUR+1),MEMORY,NBOOPT) GMSDRV GMSDRV Perform the energetic analysis. GMSDRV GMSDRV 10 NBOOPT(1) = 2 GMSDRV CALL NBOEAN(CORE(ICUR+1),MEMORY,NBOOPT,IDONE) GMSDRV IF(IDONE.NE.0) GOTO 20 GMSDRV CALL DELSCF(CORE(ICUR+1),CORE(ICUR+1)) GMSDRV NBOOPT(1) = 3 GMSDRV CALL NBOEAN(CORE(ICUR+1),MEMORY,NBOOPT,IDONE) GMSDRV GOTO 10 GMSDRV GMSDRV 20 RETURN GMSDRV END GMSDRV ***********************************************************************GMSDRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) GMSDRV ***********************************************************************GMSDRV IMPLICIT REAL*8 (A-H,O-Z) GMSDRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) GMSDRV GMSDRV ----------------------------------------------------------------------GMSDRV GMSDRV This routine fetchs basis set information from the GAMESS common GMSDRV blocks and stores it in the NBO common blocks and direct access file GMSDRV (DAF) for use by the NBO analysis. GMSDRV GMSDRV ----------------------------------------------------------------------GMSDRV GMSDRV Routine FEAOIN accesses the following records of the dictionary file:GMSDRV GMSDRV 2 --- Total energy GMSDRV 12 --- AO overlap matrix GMSDRV 14 --- AO Fock matrix (alpha) GMSDRV 15 --- AO to MO transformation matrix (alpha) GMSDRV 16 --- AO density matrix (bond order matrix) (alpha) GMSDRV 18 --- AO Fock matrix (beta) GMSDRV 19 --- AO to MO transformation matrix (beta) GMSDRV 20 --- AO density matrix (bond order matrix) (beta) GMSDRV 23 --- X dipole integrals GMSDRV 24 --- Y dipole integrals GMSDRV 25 --- Z dipole integrals GMSDRV GMSDRV ----------------------------------------------------------------------GMSDRV GMSDRV NBO Common blocks GMSDRV GMSDRV GMSDRV PARAMETER(MAXATM = 99,MAXBAS = 500) GMSDRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GMSDRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GMSDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GMSDRV COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, GMSDRV + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, GMSDRV + JCORE,JPRINT(60) GMSDRV COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) GMSDRV COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), GMSDRV + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) GMSDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GMSDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GMSDRV + LFNDAF,LFNDEF GMSDRV GMSDRV DIMENSION LABELS(20),WFNS(6) GMSDRV LOGICAL WSTATE(6,6) GMSDRV GMSDRV GAMESS Common blocks GMSDRV GMSDRV PARAMETER (MXGTOT=5000, MXSH=1000, MXATM=50) GMSDRV COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(2047) GMSDRV COMMON /XYZPRP/ X(3),PAD(35) GMSDRV COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(99) GMSDRV COMMON /INFOA / NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(MXATM),C(3,MXATM) GMSDRV COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT), GMSDRV * CF(MXGTOT),CG(MXGTOT), GMSDRV * KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH), GMSDRV * KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL GMSDRV COMMON /SCFOPT/ SCFTYP,BLKTYP,MAXIT,MCONV,NCONV,NPUNCH GMSDRV COMMON /ECP2 / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6), GMSDRV * KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM), GMSDRV * IZCORE(MXATM) GMSDRV GMSDRV Obtain the following information: GMSDRV GMSDRV ROHF =.TRUE. If RHF open shell wavefunction GMSDRV =.FALSE. otherwise GMSDRV GMSDRV UHF =.TRUE. If UHF wavefunction GMSDRV =.FALSE. otherwise GMSDRV GMSDRV AUHF =.TRUE. If spin-annihilated UHF wavefunction GMSDRV =.FALSE. otherwise GMSDRV GMSDRV CI =.TRUE. If CI wavefunction GMSDRV =.FALSE. otherwise GMSDRV GMSDRV OPEN =.TRUE. If open shell wavefunction GMSDRV =.FALSE. otherwise GMSDRV GMSDRV COMPLX =.TRUE. If complex wavefunction GMSDRV =.FALSE. otherwise GMSDRV (Note: The program is not capable of handling this.) GMSDRV GMSDRV NATOMS Number of atomic centers GMSDRV GMSDRV NDIM Dimension of matrices (overlap and density) GMSDRV GMSDRV NBAS Number of basis functions (.le.NDIM) GMSDRV GMSDRV IPSEUD Set to one if pseudopotentials are used. GMSDRV GMSDRV IWCUBF This pertains only basis sets with F functions. GMSDRV GMSDRV If cartesian F functions are input, set IWCUBF to: GMSDRV 0, if these are to be transformed to the GMSDRV standard set of pure F functions GMSDRV 1, if these are to be transformed to the GMSDRV cubic set of pure F functions GMSDRV GMSDRV If pure F functions are input, set to IWCUBF to: GMSDRV 0, if these are standard F functions GMSDRV 1, if these are cubic F functions GMSDRV GMSDRV IATNO(I),I=1,NATOMS GMSDRV List of atomic numbers GMSDRV GMSDRV LCTR(I),I=1,NBAS GMSDRV List of atomic centers of the basis functions GMSDRV (LCTR(3)=2 if basis function 3 is on atom 2) GMSDRV GMSDRV LANG(I),I=1,NBAS GMSDRV List of angular symmetry information for the basis GMSDRV functions GMSDRV GMSDRV LABELS array contains NBO labels for the atomic orbitals GMSDRV GMSDRV DATA LABELS / GMSDRV GMSDRV s GMSDRV --- GMSDRV + 1, GMSDRV GMSDRV px py pz GMSDRV --- --- --- GMSDRV + 101, 102, 103, GMSDRV GMSDRV dxx dyy dzz dxy dxz dyz GMSDRV --- --- --- --- --- --- GMSDRV + 201, 204, 206, 202, 203, 205, GMSDRV GMSDRV fxxx fyyy fzzz fxxy fxxz fxyy fxyz fxzz fyyz fyzz GMSDRV ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- GMSDRV + 301, 307, 310, 302, 303, 304, 305, 306, 308, 309 / GMSDRV GMSDRV GMSDRV WSTATE array contains the values which should be set in the NBO GMSDRV common block /NBFLAG/ depending on wavefunction. GMSDRV GMSDRV DATA WSTATE / GMSDRV logical variable in common NBFLAG GMSDRV ROHF UHF CI OPEN MCSCF AUHF GMSDRV ------- ------- ------ ------ ------ ------ GMSDRV Wavefunction GMSDRV RHF GMSDRV + .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., GMSDRV UHF GMSDRV + .FALSE., .TRUE. , .FALSE., .TRUE. , .FALSE., .FALSE., GMSDRV ROHF GMSDRV + .TRUE. , .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., GMSDRV GVB GMSDRV + .TRUE., .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., GMSDRV MCSCF GMSDRV + .FALSE., .FALSE., .FALSE., .FALSE., .TRUE. , .FALSE., GMSDRV CI GMSDRV + .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., .FALSE./ GMSDRV GMSDRV GMSDRV Wavefunction types: GMSDRV GMSDRV DATA WFNS /8HRHF , GMSDRV + 8HUHF , GMSDRV + 8HROHF , GMSDRV + 8HGVB , GMSDRV + 8HMCSCF , GMSDRV + 8HCI / GMSDRV GMSDRV DATA ZERO/0.0D0/ GMSDRV DATA TOANG/0.529177249/ GMSDRV GMSDRV Store job title on NBODAF: GMSDRV GMSDRV DO 5 I = 1,10 GMSDRV CORE(I) = TITLE(I) GMSDRV 5 CONTINUE GMSDRV NFILE = 2 GMSDRV CALL NBWRIT(CORE,10,NFILE) GMSDRV GMSDRV Get the number of atoms from NAT and store the atomic numbers in GMSDRV IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and GMSDRV nuclear charges may not be equivalent if effective core potentials GMSDRV (ECP) are used.) GMSDRV GMSDRV NATOMS = NAT GMSDRV DO 10 I = 1,NAT GMSDRV IATNO(I) = ZAN(I) + IZCORE(I) GMSDRV IZNUC(I) = ZAN(I) GMSDRV IF(IZCORE(I).NE.0) IPSEUD = 1 GMSDRV 10 CONTINUE GMSDRV GMSDRV KATOM array contains which atom the shell is on, KMIN and KMAX GMSDRV determine the components in the shell by pointing to a range in the GMSDRV LABELS array: GMSDRV GMSDRV II = 0 GMSDRV DO 30 I = 1,NSHELL GMSDRV IATOM = KATOM(I) GMSDRV MIN = KMIN(I) GMSDRV MAX = KMAX(I) GMSDRV DO 20 J = MIN,MAX GMSDRV II = II + 1 GMSDRV LCTR(II) = IATOM GMSDRV LANG(II) = LABELS(J) GMSDRV 20 CONTINUE GMSDRV 30 CONTINUE GMSDRV GMSDRV NBAS = II GMSDRV NDIM = NBAS GMSDRV GMSDRV Inititialize various NBO options depending upon the wavefunction GMSDRV type and basis set type. GMSDRV GMSDRV First, turn off the complex orbitals, indicate that the pure set GMSDRV of F functions is desired when transforming from the cartesian set. GMSDRV GMSDRV COMPLX = .FALSE. GMSDRV IWCUBF = 0 GMSDRV ORTHO = .FALSE. GMSDRV GMSDRV Next set up the wavefunction flags. GMSDRV GMSDRV DO 50 I = 1,6 GMSDRV ISTATE = I GMSDRV IF (SCFTYP.EQ.WFNS(I)) GOTO 60 GMSDRV 50 CONTINUE GMSDRV STOP 'Unknown WFNTYP' GMSDRV GMSDRV 60 ROHF = WSTATE(1,ISTATE) GMSDRV UHF = WSTATE(2,ISTATE) GMSDRV CI = WSTATE(3,ISTATE) GMSDRV OPEN = WSTATE(4,ISTATE) GMSDRV MCSCF = WSTATE(5,ISTATE) GMSDRV AUHF = WSTATE(6,ISTATE) GMSDRV GMSDRV No Fock matrices for ROHF, MCSCF, or CI wavefunctions: GMSDRV GMSDRV IF (ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 GMSDRV GMSDRV Expectation values of the Fock operator are in atomic units: GMSDRV GMSDRV MUNIT = 0 GMSDRV GMSDRV Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: GMSDRV GMSDRV ICORE(1) = NATOMS GMSDRV ICORE(2) = NDIM GMSDRV ICORE(3) = NBAS GMSDRV ICORE(4) = MUNIT GMSDRV ICORE(5) = 0 GMSDRV IF(ROHF) ICORE(5) = 1 GMSDRV ICORE(6) = 0 GMSDRV IF(UHF) ICORE(6) = 1 GMSDRV ICORE(7) = 0 GMSDRV IF(CI) ICORE(7) = 1 GMSDRV ICORE(8) = 0 GMSDRV IF(OPEN) ICORE(8) = 1 GMSDRV ICORE(9) = 0 GMSDRV IF(MCSCF) ICORE(9) = 1 GMSDRV ICORE(10) = 0 GMSDRV IF(AUHF) ICORE(10) = 1 GMSDRV ICORE(11) = 0 GMSDRV IF(ORTHO) ICORE(11) = 1 GMSDRV ICORE(12) = 1 GMSDRV NFILE = 3 GMSDRV CALL NBWRIT(ICORE,12,NFILE) GMSDRV GMSDRV Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: GMSDRV GMSDRV II = 0 GMSDRV DO 70 I = 1,NATOMS GMSDRV II = II + 1 GMSDRV ICORE(II) = IATNO(I) GMSDRV 70 CONTINUE GMSDRV DO 80 I = 1,NATOMS GMSDRV II = II + 1 GMSDRV ICORE(II) = IZNUC(I) GMSDRV 80 CONTINUE GMSDRV DO 90 I = 1,NBAS GMSDRV II = II + 1 GMSDRV ICORE(II) = LCTR(I) GMSDRV 90 CONTINUE GMSDRV DO 95 I = 1,NBAS GMSDRV II = II + 1 GMSDRV ICORE(II) = LANG(I) GMSDRV 95 CONTINUE GMSDRV NFILE = 4 GMSDRV CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) GMSDRV GMSDRV Fetch the total energy from the dictionary file and store it on the GMSDRV NBO DAF: GMSDRV GMSDRV NFILE = 2 GMSDRV CALL DAREAD(IDAF,IODA,CORE,3,NFILE,NAV) GMSDRV CORE(1) = CORE(3) GMSDRV CORE(2) = CORE(3) GMSDRV NFILE = 8 GMSDRV CALL NBWRIT(CORE,2,NFILE) GMSDRV GMSDRV Store the atomic coordinates on the NBO DAF: (Note that these GMSDRV coordinates are used in the calculation of dipole moments. GAMESS GMSDRV requires the Cartesian origin to be at the center of mass!!) GMSDRV GMSDRV I = 0 GMSDRV DO 110 IAT = 1,NATOMS GMSDRV DO 100 K = 1,3 GMSDRV I = I + 1 GMSDRV CORE(I) = (C(K,IAT) - X(K)) * TOANG GMSDRV 100 CONTINUE GMSDRV 110 CONTINUE GMSDRV NFILE = 9 GMSDRV CALL NBWRIT(CORE,3*NATOMS,NFILE) GMSDRV GMSDRV Store the overlap matrix on the NBODAF: GMSDRV GMSDRV NFILE = 12 GMSDRV L2 = NDIM*(NDIM+1)/2 GMSDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV NFILE = 10 GMSDRV CALL NBWRIT(CORE,L2,NFILE) GMSDRV GMSDRV Store the density matrices on the NBODAF: GMSDRV GMSDRV NFILE = 16 GMSDRV L2 = NDIM*(NDIM+1)/2 GMSDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV NFILE = 20 GMSDRV CALL NBWRIT(CORE,L2,NFILE) GMSDRV GMSDRV IF(OPEN) THEN GMSDRV NFILE = 20 GMSDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV NFILE = 21 GMSDRV CALL NBWRIT(CORE,L2,NFILE) GMSDRV END IF GMSDRV GMSDRV Store the Fock matrices on the NBODAF: GMSDRV GMSDRV IF(IWFOCK.NE.0) THEN GMSDRV NFILE = 14 GMSDRV L2 = NDIM*(NDIM+1)/2 GMSDRV IF(IODA(NFILE).GT.0) THEN GMSDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV NFILE = 30 GMSDRV CALL NBWRIT(CORE,L2,NFILE) GMSDRV END IF GMSDRV GMSDRV IF(OPEN) THEN GMSDRV NFILE = 18 GMSDRV IF(IODA(NFILE).GT.0) THEN GMSDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV NFILE = 31 GMSDRV CALL NBWRIT(CORE,L2,NFILE) GMSDRV END IF GMSDRV END IF GMSDRV END IF GMSDRV GMSDRV Store the AO to MO transformation matrices on the NBODAF: GMSDRV GMSDRV IF(IODA(15).NE.0) THEN GMSDRV NFILE = 15 GMSDRV L3 = NDIM*NDIM GMSDRV CALL DAREAD(IDAF,IODA,CORE,L3,NFILE,NAV) GMSDRV NFILE = 40 GMSDRV CALL NBWRIT(CORE,L3,NFILE) GMSDRV IF(OPEN) THEN GMSDRV NFILE = 19 GMSDRV CALL DAREAD(IDAF,IODA,CORE,L3,NFILE,NAV) GMSDRV NFILE = 41 GMSDRV CALL NBWRIT(CORE,L3,NFILE) GMSDRV END IF GMSDRV END IF GMSDRV GMSDRV Store the x,y,z dipole integrals on the NBODAF: GMSDRV GMSDRV IF(IODA(23).NE.0.AND.IODA(24).NE.0.AND.IODA(25).NE.0) THEN GMSDRV L2 = NDIM*(NDIM+1)/2 GMSDRV NFILE = 23 GMSDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV DO 120 I = 1,L2 GMSDRV CORE(I) = CORE(I) * TOANG GMSDRV 120 CONTINUE GMSDRV NFILE = 50 GMSDRV CALL NBWRIT(CORE,L2,NFILE) GMSDRV NFILE = 24 GMSDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV DO 130 I = 1,L2 GMSDRV CORE(I) = CORE(I) * TOANG GMSDRV 130 CONTINUE GMSDRV NFILE = 51 GMSDRV CALL NBWRIT(CORE,L2,NFILE) GMSDRV NFILE = 25 GMSDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV) GMSDRV DO 140 I = 1,L2 GMSDRV CORE(I) = CORE(I) * TOANG GMSDRV 140 CONTINUE GMSDRV NFILE = 52 GMSDRV CALL NBWRIT(CORE,L2,NFILE) GMSDRV END IF GMSDRV GMSDRV Store the AO basis set info on the NBO DAF: (Note that two integers GMSDRV and three integer arrays are stored first. Also remember that ICORE GMSDRV and CORE occupy the same memory.) GMSDRV GMSDRV NEXP = 0 GMSDRV DO 150 I = 1,MXGTOT GMSDRV IF(EX(I).EQ.ZERO) GOTO 150 GMSDRV NEXP = I GMSDRV 150 CONTINUE GMSDRV DO 160 I = 1,2+3*NSHELL+5*NEXP GMSDRV CORE(I) = ZERO GMSDRV 160 CONTINUE GMSDRV ICORE(1) = NSHELL GMSDRV ICORE(2) = NEXP GMSDRV GMSDRV NCOMP(I) -- the number of components in the Ith shell: GMSDRV GMSDRV II = 2 GMSDRV DO 170 I = 1,NSHELL GMSDRV II = II + 1 GMSDRV ICORE(II) = KMAX(I) - KMIN(I) + 1 GMSDRV 170 CONTINUE GMSDRV GMSDRV NPRIM(I) -- the number of gaussian primitives in the Ith shell: GMSDRV GMSDRV DO 180 I = 1,NSHELL GMSDRV II = II + 1 GMSDRV ICORE(II) = KNG(I) GMSDRV 180 CONTINUE GMSDRV GMSDRV NPTR(I) -- pointer for the Ith shell into the gaussian parameters, GMSDRV EXP, CS, CP, etc.: GMSDRV GMSDRV DO 190 I = 1,NSHELL GMSDRV II = II + 1 GMSDRV ICORE(II) = KSTART(I) GMSDRV 190 CONTINUE GMSDRV GMSDRV EXP(I) -- orbital exponents indexed by NPTR: GMSDRV GMSDRV DO 200 I = 1,NEXP GMSDRV II = II + 1 GMSDRV CORE(II) = EX(I) GMSDRV 200 CONTINUE GMSDRV GMSDRV CS,CP,CD,CF -- orbital coefficients: GMSDRV GMSDRV DO 210 I = 1,NEXP GMSDRV II = II + 1 GMSDRV CORE(II) = CS(I) GMSDRV 210 CONTINUE GMSDRV DO 220 I = 1,NEXP GMSDRV II = II + 1 GMSDRV CORE(II) = CP(I) GMSDRV 220 CONTINUE GMSDRV DO 230 I = 1,NEXP GMSDRV II = II + 1 GMSDRV CORE(II) = CD(I) GMSDRV 230 CONTINUE GMSDRV DO 240 I = 1,NEXP GMSDRV II = II + 1 GMSDRV CORE(II) = ZERO GMSDRV 240 CONTINUE GMSDRV NFILE = 5 GMSDRV CALL NBWRIT(CORE,II,NFILE) GMSDRV GMSDRV RETURN GMSDRV END GMSDRV ***********************************************************************GMSDRV SUBROUTINE DELSCF(A,IA) GMSDRV ***********************************************************************GMSDRV IMPLICIT REAL*8 (A-H,O-Z) GMSDRV LOGICAL NEW,ERROR,SEQ GMSDRV GMSDRV NBO common blocks: GMSDRV GMSDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT GMSDRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GMSDRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GMSDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GMSDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GMSDRV + LFNDAF,LFNDEF GMSDRV GMSDRV GAMESS common blocks: GMSDRV GMSDRV PARAMETER (MXGTOT=5000, MXSH=1000, MXATM=50) GMSDRV COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(99) GMSDRV COMMON /INFOA / NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(MXATM),C(3,MXATM) GMSDRV COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK GMSDRV COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTG76 GMSDRV LOGICAL PACK2E GMSDRV GMSDRV DIMENSION A(1),IA(NDIM) GMSDRV GMSDRV DATA TWO/2.0D0/ GMSDRV GMSDRV -----------------------------------------------------------------------GMSDRV GMSDRV SET POINTERS: GMSDRV GMSDRV NTRI = NDIM*(NDIM+1)/2 GMSDRV NSQ = NDIM*NDIM GMSDRV GMSDRV A(IPT1) --- Density matrix (alpha) GMSDRV A(IPT2) --- Density matrix (beta) GMSDRV A(IPT3) --- Fock matrix (alpha) GMSDRV A(IPT4) --- Fock matrix (beta) GMSDRV A(IPT5) --- Core Hamiltonian matrix GMSDRV A(IPT6) --- Integral buffer, scratch GMSDRV A(IPT7) --- Integral buffer GMSDRV A(IPT8) --- Integral buffer GMSDRV GMSDRV IPT1 = 1 + NDIM GMSDRV IPT2 = IPT1 + NTRI GMSDRV IPT3 = IPT2 + NTRI GMSDRV IPT4 = IPT3 + NTRI GMSDRV IPT5 = IPT4 + NTRI GMSDRV IPT6 = IPT5 + NTRI GMSDRV IPT7 = IPT6 + NINTMX GMSDRV IPT8 = IPT7 + NINTMX GMSDRV GMSDRV SET UP ADDRESSING ARRAY: GMSDRV GMSDRV DO 50 I = 1,NDIM GMSDRV IA(I) = (I*(I-1))/2 GMSDRV 50 CONTINUE GMSDRV GMSDRV REWIND INTEGRAL FILE: GMSDRV GMSDRV REWIND IS GMSDRV GMSDRV OPEN THE NBO DIRECT ACCESS FILE GMSDRV GMSDRV NEW = .FALSE. GMSDRV CALL NBOPEN(NEW,ERROR) GMSDRV IF(ERROR) THEN GMSDRV WRITE(LFNPR,900) GMSDRV STOP GMSDRV END IF GMSDRV GMSDRV CALCULATE NUCLEAR REPULSION ENERGY: GMSDRV GMSDRV EN = ENUC(NAT,ZAN,C) GMSDRV IF(UHF) THEN GMSDRV GMSDRV UHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTGMSDRV AND SYMMETRIZE THE SKELETON FOCK MATRIX: GMSDRV GMSDRV ALPHA = .TRUE. GMSDRV BETA = .FALSE. GMSDRV CALL FENEWD(A(IPT1)) GMSDRV ALPHA = .FALSE. GMSDRV BETA = .TRUE. GMSDRV CALL FENEWD(A(IPT2)) GMSDRV CALL HSTARU(A(IPT1),A(IPT3),A(IPT2),A(IPT4),A(IPT7),A(IPT8), GMSDRV + A(IPT6),A(IPT7),A(IPT8),NINTMX,IA,NOPK) GMSDRV CALL SYMH(A(IPT3),A(IPT6),IA) GMSDRV CALL SYMH(A(IPT4),A(IPT6),IA) GMSDRV GMSDRV READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: GMSDRV GMSDRV CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11,NAV) GMSDRV CALL VADD(A(IPT3),1,A(IPT5),1,A(IPT3),1,NTRI) GMSDRV CALL VADD(A(IPT4),1,A(IPT5),1,A(IPT4),1,NTRI) GMSDRV EHFA = TRACEP(A(IPT1),A(IPT5),NBAS) + GMSDRV + TRACEP(A(IPT1),A(IPT3),NBAS) GMSDRV EHFB = TRACEP(A(IPT2),A(IPT5),NBAS) + GMSDRV + TRACEP(A(IPT2),A(IPT4),NBAS) GMSDRV EHF = (EHFA + EHFB)/TWO GMSDRV EDEL = EHF + EN GMSDRV GMSDRV RHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTGMSDRV AND SYMMETRIZE THE SKELETON FOCK MATRIX: GMSDRV GMSDRV ELSE GMSDRV CALL FENEWD(A(IPT1)) GMSDRV CALL HSTAR(A(IPT1),A(IPT3),A(IPT6),A(IPT7),NINTMX,IA,NOPK) GMSDRV CALL SYMH(A(IPT3),A(IPT6),IA) GMSDRV GMSDRV READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: GMSDRV GMSDRV CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11,NAV) GMSDRV CALL VADD(A(IPT3),1,A(IPT5),1,A(IPT3),1,NTRI) GMSDRV EHF1 = TRACEP(A(IPT1),A(IPT5),NDIM) GMSDRV EHF2 = TRACEP(A(IPT1),A(IPT3),NDIM) GMSDRV EHF = (EHF1 + EHF2)/TWO GMSDRV EDEL = EHF + EN GMSDRV END IF GMSDRV GMSDRV SAVE THE DELETION ENERGY ON THE NBO DIRECT ACCESS FILE AND CLOSE THE GMSDRV FILE: GMSDRV GMSDRV CALL SVE0(EDEL) GMSDRV SEQ = .FALSE. GMSDRV CALL NBCLOS(SEQ) GMSDRV RETURN GMSDRV GMSDRV 900 FORMAT(/1X,'Error opening the NBO direct access file in ', GMSDRV + 'subroutine DELSCF.') GMSDRV END GMSDRV ***********************************************************************GMSDRV GMSDRV E N D O F G M S N B O R O U T I N E S GMSDRV GMSDRV ***********************************************************************GMSDRV ***********************************************************************HNDDRV HNDDRV HNDDRV H N D N B O HNDDRV HNDDRV HNDDRV HONDO VERSION OF NBO PROGRAM HNDDRV HNDDRV HNDDRV DRIVER ROUTINES: HNDDRV HNDDRV SUBROUTINE RUNNBO HNDDRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) HNDDRV SUBROUTINE DELSCF(A) HNDDRV HNDDRV ***********************************************************************HNDDRV SUBROUTINE RUNNBO HNDDRV ***********************************************************************HNDDRV IMPLICIT REAL*8 (A-H,O-Z) HNDDRV DIMENSION NBOOPT(10) HNDDRV HNDDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, HNDDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, HNDDRV + LFNDAF,LFNDEF HNDDRV HNDDRV HONDO Common Block: HNDDRV HNDDRV COMMON/IOFILE/IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(99) HNDDRV COMMON/MEMORY/MAXCOR,MAXLCM HNDDRV COMMON/SCM/CORE(1) HNDDRV HNDDRV LFNIN = IR HNDDRV LFNPR = IW HNDDRV HNDDRV Set NBO options. HNDDRV HNDDRV NBOOPT(1) = 0 HNDDRV NBOOPT(2) = 0 HNDDRV NBOOPT(3) = 0 HNDDRV NBOOPT(4) = 0 HNDDRV NBOOPT(5) = 0 HNDDRV NBOOPT(6) = 0 HNDDRV NBOOPT(7) = 0 HNDDRV NBOOPT(8) = 0 HNDDRV NBOOPT(9) = 0 HNDDRV NBOOPT(10) = 7 HNDDRV HNDDRV Perform the NPA/NBO/NLMO analyses. HNDDRV HNDDRV CALL NBO(CORE,MAXCOR,NBOOPT) HNDDRV HNDDRV Perform the energetic analysis. HNDDRV HNDDRV 10 NBOOPT(1) = 2 HNDDRV CALL NBOEAN(CORE,MAXCOR,NBOOPT,IDONE) HNDDRV IF(IDONE.NE.0) GOTO 20 HNDDRV CALL DELSCF(CORE) HNDDRV NBOOPT(1) = 3 HNDDRV CALL NBOEAN(CORE,MAXCOR,NBOOPT,IDONE) HNDDRV GOTO 10 HNDDRV HNDDRV 20 RETURN HNDDRV END HNDDRV ***********************************************************************HNDDRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) HNDDRV ***********************************************************************HNDDRV IMPLICIT REAL*8 (A-H,O-Z) HNDDRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) HNDDRV HNDDRV ----------------------------------------------------------------------HNDDRV HNDDRV This routine fetchs basis set information from the HONDO common HNDDRV blocks and stores it in the NBO common blocks and direct access file HNDDRV (DAF) for use by the NBO analysis. HNDDRV HNDDRV ----------------------------------------------------------------------HNDDRV HNDDRV Routine FEAOIN accesses the following records of the dictionary file:HNDDRV HNDDRV 2 --- Total energy HNDDRV 12 --- AO overlap matrix HNDDRV 14 --- AO Fock matrix (alpha) HNDDRV 15 --- AO to MO transformation matrix (alpha) HNDDRV 16 --- AO density matrix (bond order matrix) (alpha) HNDDRV 18 --- AO Fock matrix (beta) HNDDRV 19 --- AO to MO transformation matrix (beta) HNDDRV 20 --- AO density matrix (bond order matrix) (beta) HNDDRV 33 --- X dipole integrals HNDDRV 34 --- Y dipole integrals HNDDRV 35 --- Z dipole integrals HNDDRV HNDDRV ----------------------------------------------------------------------HNDDRV HNDDRV NBO Common blocks HNDDRV HNDDRV HNDDRV PARAMETER(MAXATM = 99,MAXBAS = 500) HNDDRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO HNDDRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO HNDDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT HNDDRV COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, HNDDRV + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, HNDDRV + JCORE,JPRINT(60) HNDDRV COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) HNDDRV COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), HNDDRV + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) HNDDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, HNDDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, HNDDRV + LFNDAF,LFNDEF HNDDRV HNDDRV HONDO Common blocks HNDDRV HNDDRV COMMON/IOFILE/IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(99) HNDDRV COMMON/INFOA/NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(50),C(3,50) HNDDRV COMMON/MOLNUC/NUC(50) HNDDRV COMMON/NSHEL/EX(440),CS(440),CP(440),CD(440),CF(440),CG(440), HNDDRV * KSTART(120),KATOM(120),KTYPE(120),KNG(120), HNDDRV * KLOC(120),KMIN(120),KMAX(120),NSHELL HNDDRV COMMON/RUNLAB/TITLE(10),ANAM(50),BNAM(50),BFLAB(512) HNDDRV COMMON/SCFOPT/SCFTYP HNDDRV COMMON/WFNOPT/WFNTYP HNDDRV HNDDRV DIMENSION LABELS(20),WFNS(6) HNDDRV LOGICAL WSTATE(6,6),SOME HNDDRV DIMENSION CM(3) HNDDRV HNDDRV Obtain the following information: HNDDRV HNDDRV ROHF =.TRUE. If RHF open shell wavefunction HNDDRV =.FALSE. otherwise HNDDRV HNDDRV UHF =.TRUE. If UHF wavefunction HNDDRV =.FALSE. otherwise HNDDRV HNDDRV AUHF =.TRUE. If spin-annihilated UHF wavefunction HNDDRV =.FALSE. otherwise HNDDRV HNDDRV CI =.TRUE. If CI wavefunction HNDDRV =.FALSE. otherwise HNDDRV HNDDRV OPEN =.TRUE. If open shell wavefunction HNDDRV =.FALSE. otherwise HNDDRV HNDDRV COMPLX =.TRUE. If complex wavefunction HNDDRV =.FALSE. otherwise HNDDRV (Note: The program is not capable of handling this.) HNDDRV HNDDRV NATOMS Number of atomic centers HNDDRV HNDDRV NDIM Dimension of matrices (overlap and density) passed to pHNDDRV HNDDRV NBAS Number of basis functions (.le.NDIM) HNDDRV HNDDRV IPSEUD Set to zero if no pseudopotentials are used. HNDDRV Set to one if pseudopotentials are used. HNDDRV HNDDRV IWCUBF This pertains only basis sets with F functions. HNDDRV HNDDRV If cartesian F functions are input, set IWCUBF to: HNDDRV 0, if these are to be transformed to the HNDDRV standard set of pure F functions HNDDRV 1, if these are to be transformed to the HNDDRV cubic set of pure F functions HNDDRV HNDDRV If pure F functions are input, set to IWCUBF to: HNDDRV 0, if these are standard F functions HNDDRV 1, if these are cubic F functions HNDDRV HNDDRV IATNO(I),I=1,NATOMS HNDDRV List of atomic numbers HNDDRV HNDDRV LCTR(I),I=1,NBAS HNDDRV List of atomic centers of the basis functions HNDDRV (LCTR(3)=2 if basis function 3 is on atom 2) HNDDRV HNDDRV LANG(I),I=1,NBAS HNDDRV List of angular symmetry information for the basis funcHNDDRV HNDDRV LABELS array contains NBO labels for the atomic orbitals HNDDRV HNDDRV DATA LABELS / HNDDRV HNDDRV S HNDDRV --- HNDDRV + 1, HNDDRV HNDDRV Px Py Pz HNDDRV --- --- --- HNDDRV + 101, 102, 103, HNDDRV HNDDRV Dxx Dyy Dzz Dxy Dxz Dyz HNDDRV --- --- --- --- --- --- HNDDRV + 201, 204, 206, 202, 203, 205, HNDDRV HNDDRV Fxxx Fyyy Fzzz Fxxy Fxxz Fxyy Fxyz Fxzz Fyyz Fyzz HNDDRV ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- HNDDRV + 301, 307, 310, 302, 303, 304, 305, 306, 308, 309 / HNDDRV HNDDRV HNDDRV WSTATE array contains the values which should be set in the NBO commoHNDDRV NBFLAG depending on wavefunction. HNDDRV HNDDRV DATA WSTATE / HNDDRV ROHF UHF CI OPEN MCSCF AUHF HNDDRV ------- ------- ------ ------ ------ ------ HNDDRV Wavefunction HNDDRV RHF HNDDRV + .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., HNDDRV UHF HNDDRV + .FALSE., .TRUE. , .FALSE., .TRUE. , .FALSE., .FALSE., HNDDRV ROHF HNDDRV + .TRUE. , .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., HNDDRV GVB HNDDRV + .TRUE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., HNDDRV MCSCF HNDDRV + .FALSE., .FALSE., .FALSE., .FALSE., .TRUE. , .FALSE., HNDDRV CI HNDDRV + .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., .FALSE./ HNDDRV HNDDRV HNDDRV NAMELIST /WFN/ WFNFLG HNDDRV DATA WFNFLG /0/ HNDDRV DATA ZERO/0.0D0/ HNDDRV DATA TOANG/0.529177249/ HNDDRV HNDDRV Wavefunction types: HNDDRV HNDDRV DATA SCFWFN,CIWFN/'SCF ','MCCI '/ HNDDRV DATA WFNS /8HRHF , HNDDRV + 8HUHF , HNDDRV + 8HROHF , HNDDRV + 8HGVB , HNDDRV + 8HMCSCF , HNDDRV + 8HCI / HNDDRV HNDDRV Read in type of wavefunction from the $WFN namelist. HNDDRV HNDDRV REWIND IR HNDDRV READ(IR,WFN,END=3) HNDDRV GO TO 4 HNDDRV 3 CONTINUE HNDDRV WRITE(IW,900) HNDDRV STOP HNDDRV 4 CONTINUE HNDDRV HNDDRV Store job title on NBODAF: HNDDRV HNDDRV DO 5 I = 1,10 HNDDRV CORE(I) = TITLE(I) HNDDRV 5 CONTINUE HNDDRV NFILE = 2 HNDDRV CALL NBWRIT(CORE,10,NFILE) HNDDRV HNDDRV Get the number of atoms from NAT and store the atomic numbers in HNDDRV IATNO and nuclear charges in IZNUC. (NOTE: atomic numbers and HNDDRV nuclear charges may not be equivalent if effective core potentials HNDDRV (ECP) are used.) HNDDRV HNDDRV NATOMS = NAT HNDDRV DO 10 I = 1,NAT HNDDRV IATNO(I) = NUC(I) HNDDRV IZNUC(I) = ZAN(I) HNDDRV IF(IATNO(I).NE.IZNUC(I)) IPSEUD = 1 HNDDRV 10 CONTINUE HNDDRV HNDDRV KATOM array contains which atom the shell is on, KMIN and KMAX HNDDRV determine the components in the shell by pointing to a range in the HNDDRV LABELS array: HNDDRV HNDDRV II = 0 HNDDRV DO 30 I = 1,NSHELL HNDDRV IATOM = KATOM(I) HNDDRV MIN = KMIN(I) HNDDRV MAX = KMAX(I) HNDDRV DO 20 J = MIN,MAX HNDDRV II = II + 1 HNDDRV LCTR(II) = IATOM HNDDRV LANG(II) = LABELS(J) HNDDRV 20 CONTINUE HNDDRV 30 CONTINUE HNDDRV HNDDRV NBAS = II HNDDRV NDIM = NBAS HNDDRV HNDDRV Inititialize various NBO options depending upon the wavefunction HNDDRV type and basis set type. HNDDRV HNDDRV First, turn off the complex orbitals, indicate that the pure set HNDDRV of F functions is desired when transforming from the cartesian set. HNDDRV HNDDRV COMPLX = .FALSE. HNDDRV IWCUBF = 0 HNDDRV ORTHO = .FALSE. HNDDRV HNDDRV Next set up the wavefunction switches. HNDDRV HNDDRV IF(WFNTYP.EQ.SCFWFN) THEN HNDDRV IF(WFNFLG.EQ.0) THEN HNDDRV IF(SCFTYP.EQ.WFNS(1)) ISTATE = 1 HNDDRV IF(SCFTYP.EQ.WFNS(2)) ISTATE = 2 HNDDRV IF(SCFTYP.EQ.WFNS(4)) ISTATE = 4 HNDDRV IF(SCFTYP.EQ.WFNS(1).AND.MUL.GE.2) ISTATE = 3 HNDDRV GOTO 60 HNDDRV END IF HNDDRV IF(WFNFLG.EQ.5) THEN HNDDRV ISTATE = 6 HNDDRV GOTO 60 HNDDRV END IF HNDDRV IF(WFNFLG.EQ.6) THEN HNDDRV ISTATE = 6 HNDDRV GOTO 60 HNDDRV END IF HNDDRV END IF HNDDRV IF(WFNTYP.EQ.CIWFN) THEN HNDDRV IF(WFNFLG.EQ.1) ISTATE = 5 HNDDRV IF(WFNFLG.EQ.2) ISTATE = 6 HNDDRV IF(WFNFLG.EQ.3) ISTATE = 6 HNDDRV IF(WFNFLG.EQ.4) ISTATE = 6 HNDDRV GOTO 60 HNDDRV END IF HNDDRV STOP 'Unknown WFNTYP' HNDDRV HNDDRV 60 ROHF = WSTATE(1,ISTATE) HNDDRV UHF = WSTATE(2,ISTATE) HNDDRV CI = WSTATE(3,ISTATE) HNDDRV OPEN = WSTATE(4,ISTATE) HNDDRV MCSCF = WSTATE(5,ISTATE) HNDDRV AUHF = WSTATE(6,ISTATE) HNDDRV HNDDRV No Fock matrices for ROHF, MCSCF, or CI wavefunctions: HNDDRV HNDDRV IF (ROHF.OR.MCSCF.OR.CI) IWFOCK = 0 HNDDRV HNDDRV Expectation values of the Fock operator are in atomic units: HNDDRV HNDDRV MUNIT = 0 HNDDRV HNDDRV Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN: HNDDRV HNDDRV ICORE(1) = NATOMS HNDDRV ICORE(2) = NDIM HNDDRV ICORE(3) = NBAS HNDDRV ICORE(4) = MUNIT HNDDRV ICORE(5) = 0 HNDDRV IF(ROHF) ICORE(5) = 1 HNDDRV ICORE(6) = 0 HNDDRV IF(UHF) ICORE(6) = 1 HNDDRV ICORE(7) = 0 HNDDRV IF(CI) ICORE(7) = 1 HNDDRV ICORE(8) = 0 HNDDRV IF(OPEN) ICORE(8) = 1 HNDDRV ICORE(9) = 0 HNDDRV IF(MCSCF) ICORE(9) = 1 HNDDRV ICORE(10) = 0 HNDDRV IF(AUHF) ICORE(10) = 1 HNDDRV ICORE(11) = 0 HNDDRV IF(ORTHO) ICORE(11) = 1 HNDDRV ICORE(12) = 1 HNDDRV NFILE = 3 HNDDRV CALL NBWRIT(ICORE,12,NFILE) HNDDRV HNDDRV Store IATNO, IZNUC, LCTR, and LANG on NBO DAF: HNDDRV HNDDRV II = 0 HNDDRV DO 70 I = 1,NATOMS HNDDRV II = II + 1 HNDDRV ICORE(II) = IATNO(I) HNDDRV 70 CONTINUE HNDDRV DO 80 I = 1,NATOMS HNDDRV II = II + 1 HNDDRV ICORE(II) = IZNUC(I) HNDDRV 80 CONTINUE HNDDRV DO 90 I = 1,NBAS HNDDRV II = II + 1 HNDDRV ICORE(II) = LCTR(I) HNDDRV 90 CONTINUE HNDDRV DO 95 I = 1,NBAS HNDDRV II = II + 1 HNDDRV ICORE(II) = LANG(I) HNDDRV 95 CONTINUE HNDDRV NFILE = 4 HNDDRV CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) HNDDRV HNDDRV Fetch the total energy from the dictionary file and store it on the HNDDRV NBO DAF: HNDDRV HNDDRV NFILE = 2 HNDDRV CALL DAREAD(IDAF,IODA,CORE,3,NFILE) HNDDRV CORE(1) = CORE(3) HNDDRV CORE(2) = CORE(3) HNDDRV NFILE = 8 HNDDRV CALL NBWRIT(CORE,2,NFILE) HNDDRV HNDDRV Find the center of mass for this molecule: HNDDRV HNDDRV NCALL = 1 HNDDRV SOME = .FALSE. HNDDRV CALL DIPAMS(CORE,NCALL,NCODE,SOME) HNDDRV SUM = ZERO HNDDRV DO 96 I = 1,3 HNDDRV CM(I) = ZERO HNDDRV 96 CONTINUE HNDDRV DO 98 IAT = 1,NATOMS HNDDRV SUM = SUM + CORE(IAT) HNDDRV DO 97 I = 1,3 HNDDRV CM(I) = CM(I) + CORE(IAT) * C(I,IAT) HNDDRV 97 CONTINUE HNDDRV 98 CONTINUE HNDDRV IF(ABS(SUM).GT.1.0D-5) THEN HNDDRV DO 99 I = 1,3 HNDDRV CM(I) = CM(I) / SUM HNDDRV 99 CONTINUE HNDDRV END IF HNDDRV HNDDRV Store the atomic coordinates on the NBO DAF: (Note that these HNDDRV coordinates are used in the calculation of dipole moments.) HNDDRV HNDDRV I = 0 HNDDRV DO 110 IAT = 1,NATOMS HNDDRV DO 100 K = 1,3 HNDDRV I = I + 1 HNDDRV CORE(I) = (C(K,IAT) - CM(K)) * TOANG HNDDRV 100 CONTINUE HNDDRV 110 CONTINUE HNDDRV NFILE = 9 HNDDRV CALL NBWRIT(CORE,3*NATOMS,NFILE) HNDDRV HNDDRV Store the overlap matrix on the NBODAF: HNDDRV HNDDRV NFILE = 12 HNDDRV L2 = NDIM*(NDIM+1)/2 HNDDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV NFILE = 10 HNDDRV CALL NBWRIT(CORE,L2,NFILE) HNDDRV HNDDRV Store the density matrices on the NBODAF: HNDDRV HNDDRV NFILE = 16 HNDDRV L2 = NDIM*(NDIM+1)/2 HNDDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV NFILE = 20 HNDDRV CALL NBWRIT(CORE,L2,NFILE) HNDDRV HNDDRV IF(OPEN) THEN HNDDRV NFILE = 20 HNDDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV NFILE = 21 HNDDRV CALL NBWRIT(CORE,L2,NFILE) HNDDRV END IF HNDDRV HNDDRV Store the Fock matrices on the NBODAF: HNDDRV HNDDRV IF(IWFOCK.NE.0) THEN HNDDRV NFILE = 14 HNDDRV L2 = NDIM*(NDIM+1)/2 HNDDRV IF(IODA(NFILE).GT.0) THEN HNDDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV NFILE = 30 HNDDRV CALL NBWRIT(CORE,L2,NFILE) HNDDRV END IF HNDDRV HNDDRV IF(OPEN) THEN HNDDRV NFILE = 18 HNDDRV IF(IODA(NFILE).GT.0) THEN HNDDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV NFILE = 31 HNDDRV CALL NBWRIT(CORE,L2,NFILE) HNDDRV END IF HNDDRV END IF HNDDRV END IF HNDDRV HNDDRV Store the AO to MO transformation matrices on the NBODAF: HNDDRV HNDDRV IF(IODA(15).NE.0) THEN HNDDRV NFILE = 15 HNDDRV L3 = NDIM*NDIM HNDDRV CALL DAREAD(IDAF,IODA,CORE,L3,NFILE) HNDDRV NFILE = 40 HNDDRV CALL NBWRIT(CORE,L3,NFILE) HNDDRV IF(OPEN) THEN HNDDRV NFILE = 19 HNDDRV CALL DAREAD(IDAF,IODA,CORE,L3,NFILE) HNDDRV NFILE = 41 HNDDRV CALL NBWRIT(CORE,L3,NFILE) HNDDRV END IF HNDDRV END IF HNDDRV HNDDRV Store the x,y,z dipole integrals on the NBODAF: HNDDRV HNDDRV IF(IODA(33).NE.0.AND.IODA(34).NE.0.AND.IODA(35).NE.0) THEN HNDDRV L2 = NDIM*(NDIM+1)/2 HNDDRV NFILE = 33 HNDDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV DO 120 I = 1,L2 HNDDRV CORE(I) = CORE(I) * TOANG HNDDRV 120 CONTINUE HNDDRV NFILE = 50 HNDDRV CALL NBWRIT(CORE,L2,NFILE) HNDDRV NFILE = 34 HNDDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV DO 130 I = 1,L2 HNDDRV CORE(I) = CORE(I) * TOANG HNDDRV 130 CONTINUE HNDDRV NFILE = 51 HNDDRV CALL NBWRIT(CORE,L2,NFILE) HNDDRV NFILE = 35 HNDDRV CALL DAREAD(IDAF,IODA,CORE,L2,NFILE) HNDDRV DO 140 I = 1,L2 HNDDRV CORE(I) = CORE(I) * TOANG HNDDRV 140 CONTINUE HNDDRV NFILE = 52 HNDDRV CALL NBWRIT(CORE,L2,NFILE) HNDDRV END IF HNDDRV HNDDRV Store the AO basis set info on the NBO DAF: (Note that two integers HNDDRV and three integer arrays are stored first. Also remember that ICORE HNDDRV and CORE occupy the same memory.) HNDDRV HNDDRV NEXP = 0 HNDDRV DO 150 I = 1,440 HNDDRV IF(EX(I).EQ.ZERO) GOTO 150 HNDDRV NEXP = I HNDDRV 150 CONTINUE HNDDRV DO 160 I = 1,2+3*NSHELL+5*NEXP HNDDRV CORE(I) = ZERO HNDDRV 160 CONTINUE HNDDRV ICORE(1) = NSHELL HNDDRV ICORE(2) = NEXP HNDDRV HNDDRV NCOMP(I) -- the number of components in the Ith shell: HNDDRV HNDDRV II = 2 HNDDRV DO 170 I = 1,NSHELL HNDDRV II = II + 1 HNDDRV ICORE(II) = KMAX(I) - KMIN(I) + 1 HNDDRV 170 CONTINUE HNDDRV HNDDRV NPRIM(I) -- the number of gaussian primitives in the Ith shell: HNDDRV HNDDRV DO 180 I = 1,NSHELL HNDDRV II = II + 1 HNDDRV ICORE(II) = KNG(I) HNDDRV 180 CONTINUE HNDDRV HNDDRV NPTR(I) -- pointer for the Ith shell into the gaussian parameters, HNDDRV EXP, CS, CP, etc.: HNDDRV HNDDRV DO 190 I = 1,NSHELL HNDDRV II = II + 1 HNDDRV ICORE(II) = KSTART(I) HNDDRV 190 CONTINUE HNDDRV HNDDRV EXP(I) -- orbital exponents indexed by NPTR: HNDDRV HNDDRV DO 200 I = 1,NEXP HNDDRV II = II + 1 HNDDRV CORE(II) = EX(I) HNDDRV 200 CONTINUE HNDDRV HNDDRV CS,CP,CD,CF -- orbital coefficients: HNDDRV HNDDRV DO 210 I = 1,NEXP HNDDRV II = II + 1 HNDDRV CORE(II) = CS(I) HNDDRV 210 CONTINUE HNDDRV DO 220 I = 1,NEXP HNDDRV II = II + 1 HNDDRV CORE(II) = CP(I) HNDDRV 220 CONTINUE HNDDRV DO 230 I = 1,NEXP HNDDRV II = II + 1 HNDDRV CORE(II) = CD(I) HNDDRV 230 CONTINUE HNDDRV DO 240 I = 1,NEXP HNDDRV II = II + 1 HNDDRV CORE(II) = CF(I) HNDDRV 240 CONTINUE HNDDRV NFILE = 5 HNDDRV CALL NBWRIT(CORE,II,NFILE) HNDDRV HNDDRV 900 FORMAT(/1X,'No namelist /WFN/ found. Stop. ') HNDDRV RETURN HNDDRV END HNDDRV ***********************************************************************HNDDRV SUBROUTINE DELSCF(A) HNDDRV ***********************************************************************HNDDRV IMPLICIT REAL*8 (A-H,O-Z) HNDDRV LOGICAL NEW,ERROR,SEQ HNDDRV HNDDRV NBO common blocks: HNDDRV HNDDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT HNDDRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO HNDDRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO HNDDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, HNDDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, HNDDRV + LFNDAF,LFNDEF HNDDRV HNDDRV HONDO common blocks: HNDDRV HNDDRV COMMON/IJPAIR/IA(1) HNDDRV COMMON/IOFILE/IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(99) HNDDRV COMMON/INFOA/NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(50),C(3,50) HNDDRV COMMON/INTFIL/NOPK,NOK,NOSQUR,NINTMX,NHEX,NTUPL,PACK2E HNDDRV LOGICAL PACK2E HNDDRV HNDDRV DIMENSION A(1) HNDDRV HNDDRV -----------------------------------------------------------------------HNDDRV HNDDRV SET POINTERS: HNDDRV HNDDRV NTRI = NDIM*(NDIM+1)/2 HNDDRV NSQ = NDIM*NDIM HNDDRV HNDDRV A(IPT1) --- Density matrix (alpha) HNDDRV A(IPT2) --- Density matrix (beta) HNDDRV A(IPT3) --- Fock matrix (alpha) HNDDRV A(IPT4) --- Fock matrix (beta) HNDDRV A(IPT5) --- Core Hamiltonian matrix HNDDRV A(IPT6) --- Integral buffer, scratch HNDDRV A(IPT7) --- Integral buffer HNDDRV A(IPT8) --- Integral buffer HNDDRV HNDDRV IPT1 = 1 HNDDRV IPT2 = IPT1 + NTRI HNDDRV IPT3 = IPT2 + NTRI HNDDRV IPT4 = IPT3 + NTRI HNDDRV IPT5 = IPT4 + NTRI HNDDRV IPT6 = IPT5 + NTRI HNDDRV IPT7 = IPT6 + NINTMX HNDDRV IPT8 = IPT7 + NINTMX HNDDRV HNDDRV OPEN THE NBO DIRECT ACCESS FILE HNDDRV HNDDRV NEW = .FALSE. HNDDRV CALL NBOPEN(NEW,ERROR) HNDDRV IF(ERROR) THEN HNDDRV WRITE(LFNPR,900) HNDDRV STOP HNDDRV END IF HNDDRV HNDDRV CALCULATE NUCLEAR REPULSION ENERGY: HNDDRV HNDDRV EN = ENUC(NAT,ZAN,C) HNDDRV IF(UHF) THEN HNDDRV HNDDRV UHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTHNDDRV AND SYMMETRIZE THE SKELETON FOCK MATRIX: HNDDRV HNDDRV ALPHA = .TRUE. HNDDRV BETA = .FALSE. HNDDRV CALL FENEWD(A(IPT1),NTRI) HNDDRV ALPHA = .FALSE. HNDDRV BETA = .TRUE. HNDDRV CALL FENEWD(A(IPT2),NTRI) HNDDRV CALL HSTARU(A(IPT1),A(IPT3),A(IPT2),A(IPT4),A(IPT7),A(IPT8), HNDDRV + A(IPT6),A(IPT7),A(IPT8),NINTMX,IA,NOPK) HNDDRV CALL SYMFCK(A(IPT3),A(IPT6),IA) HNDDRV CALL SYMFCK(A(IPT4),A(IPT6),IA) HNDDRV HNDDRV READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: HNDDRV HNDDRV CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11) HNDDRV DO 100 I = 1,NX HNDDRV A(I-1+IPT3) = A(I-1+IPT3) + A(I-1+IPT5) HNDDRV 100 A(I-1+IPT4) = A(I-1+IPT4) + A(I-1+IPT5) HNDDRV EHFA = DOTTRI(A(IPT1),A(IPT5),NBAS) + HNDDRV + DOTTRI(A(IPT1),A(IPT3),NBAS) HNDDRV EHFB = DOTTRI(A(IPT2),A(IPT5),NBAS) + HNDDRV + DOTTRI(A(IPT2),A(IPT4),NBAS) HNDDRV EHF = (EHFA + EHFB)/2.0 HNDDRV EDEL = EHF + EN HNDDRV HNDDRV RHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTHNDDRV AND SYMMETRIZE THE SKELETON FOCK MATRIX: HNDDRV HNDDRV ELSE HNDDRV CALL FENEWD(A(IPT1),NTRI) HNDDRV CALL HSTAR(A(IPT1),A(IPT3),A(IPT6),A(IPT7),NINTMX,IA,NOPK) HNDDRV CALL SYMFCK(A(IPT3),A(IPT6),IA) HNDDRV HNDDRV READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY: HNDDRV HNDDRV CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11) HNDDRV DO 200 I = 1,NX HNDDRV 200 A(I-1+IPT3) = A(I-1+IPT3) + A(I-1+IPT5) HNDDRV EHF1 = DOTTRI(A(IPT1),A(IPT5),NBAS) HNDDRV EHF2 = DOTTRI(A(IPT1),A(IPT3),NBAS) HNDDRV EHF = (EHF1 + EHF2)/2.0 HNDDRV EDEL = EHF + EN HNDDRV END IF HNDDRV HNDDRV SAVE THE DELETION ENERGY ON THE NBO DIRECT ACCESS FILE AND CLOSE THE HNDDRV FILE: HNDDRV HNDDRV CALL SVE0(EDEL) HNDDRV SEQ = .FALSE. HNDDRV CALL NBCLOS(SEQ) HNDDRV RETURN HNDDRV HNDDRV 900 FORMAT(/1X,'Error opening the NBO direct access file in ', HNDDRV + 'subroutine DELSCF.') HNDDRV END HNDDRV ***********************************************************************HNDDRV HNDDRV E N D O F H N D N B O R O U T I N E S HNDDRV HNDDRV ***********************************************************************HNDDRV ***********************************************************************AMPDRV AMPDRV AMPDRV A M P N B O AMPDRV AMPDRV AMPDRV AMPAC VERSION OF NBO PROGRAM AMPDRV AMPDRV AMPDRV DRIVER ROUTINES: AMPDRV AMPDRV SUBROUTINE RUNNBO AMPDRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) AMPDRV SUBROUTINE DELSCF(CORE,ICORE) AMPDRV AMPDRV ***********************************************************************AMPDRV SUBROUTINE RUNNBO AMPDRV ***********************************************************************AMPDRV IMPLICIT REAL*8 (A-H,O-Z) AMPDRV AMPDRV PARAMETER(MAXATM = 99,MAXBAS = 500) AMPDRV PARAMETER(MEMORY = 4*MAXBAS*MAXBAS) AMPDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, AMPDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, AMPDRV + LFNDAF,LFNDEF AMPDRV AMPDRV DIMENSION CORE(MEMORY),NBOOPT(10) AMPDRV AMPDRV LFNIN = 5 AMPDRV LFNPR = 6 AMPDRV AMPDRV Set NBO options. AMPDRV AMPDRV NBOOPT(1) = 0 AMPDRV NBOOPT(2) = 0 AMPDRV NBOOPT(3) = 0 AMPDRV NBOOPT(4) = 0 AMPDRV NBOOPT(5) = 0 AMPDRV NBOOPT(6) = 0 AMPDRV NBOOPT(7) = 0 AMPDRV NBOOPT(8) = 0 AMPDRV NBOOPT(9) = 0 AMPDRV NBOOPT(10) = 1 AMPDRV AMPDRV Perform the NPA/NBO/NLMO analyses. AMPDRV AMPDRV CALL NBO(CORE,MEMORY,NBOOPT) AMPDRV AMPDRV Perform the energetic analysis. AMPDRV AMPDRV 10 NBOOPT(1) = 2 AMPDRV CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) AMPDRV IF(IDONE.NE.0) GOTO 20 AMPDRV CALL DELSCF(CORE,CORE) AMPDRV NBOOPT(1) = 3 AMPDRV CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE) AMPDRV GOTO 10 AMPDRV AMPDRV 20 RETURN AMPDRV END AMPDRV ***********************************************************************AMPDRV SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT) AMPDRV ***********************************************************************AMPDRV IMPLICIT REAL*8 (A-H,O-Z) AMPDRV DIMENSION CORE(1),ICORE(1),NBOOPT(10) AMPDRV DIMENSION LIST(9),NCORE(12) AMPDRV AMPDRV INCLUDE 'SIZES' AMPDRV AMPDRV NBO COMMON BLOCKS AMPDRV AMPDRV PARAMETER(MAXATM = 99,MAXBAS = 500) AMPDRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO AMPDRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO AMPDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT AMPDRV COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB, AMPDRV + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS, AMPDRV + JCORE,JPRINT(60) AMPDRV COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS) AMPDRV COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), AMPDRV + LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM) AMPDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, AMPDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, AMPDRV + LFNDAF,LFNDEF AMPDRV AMPDRV AMPAC COMMON BLOCKS: AMPDRV AMPDRV COMMON /NATORB/ NATORB(107) AMPDRV COMMON /TITLES/ COMENT(10),TITLE(10) AMPDRV COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK) AMPDRV COMMON /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB) AMPDRV COMMON /FOKMAT/ F(MPACK), FB(MPACK) AMPDRV COMMON /GEOM / GEO(3,NUMATM) AMPDRV COMMON /GEOKST/ NATOM,LABELS(NUMATM), AMPDRV * NA(NUMATM), NB(NUMATM), NC(NUMATM) AMPDRV COMMON /KEYWRD/ KEYWRD AMPDRV CHARACTER*80 KEYWRD AMPDRV AMPDRV DATA LIST/51,151,152,153,254,251,255,253,252/ AMPDRV DATA NCORE/2,10,18,28,36,46,54,68,78,86,100,110/ AMPDRV AMPDRV FEAOIN: (FETCH AO BASIS AND WAVE FUNCTION TYPE INFORMATION) AMPDRV AMPDRV OBTAIN THE FOLLOWING INFORMATION: AMPDRV AMPDRV ROHF =.TRUE. IF RHF OPEN SHELL WAVE FUNCTION AMPDRV =.FALSE. OTHERWISE AMPDRV AMPDRV UHF =.TRUE. IF UHF WAVE FUNCTION AMPDRV =.FALSE. OTHERWISE AMPDRV AMPDRV CI =.TRUE. IF UHF WAVE FUNCTION AMPDRV =.FALSE. OTHERWISE AMPDRV AMPDRV OPEN =.TRUE. IF OPEN SHELL WAVE FUNCTION AMPDRV =.FALSE. OTHERWISE AMPDRV AMPDRV COMPLX =.TRUE. IF COMPLEX WAVE FUNCTION AMPDRV =.FALSE. OTHERWISE AMPDRV (NOTE: THE PROGRAM IS NOT SET UP TO HANDLE THIS CASE) AMPDRV AMPDRV ORTHO =.TRUE. ORTHOGONAL AO BASIS SET AMPDRV AMPDRV NATOMS NUMBER OF ATOMIC CENTERS AMPDRV AMPDRV NDIM DIMENSION OF MATRICES (OVERLAP AND DENSITY) AMPDRV AMPDRV NBAS NUMBER OF BASIS FUNCTIONS (.LE.NDIM) AMPDRV AMPDRV IPSEUD SET TO ZERO IF NO PSEUDOPOTENTIALS ARE USED, AMPDRV SET TO ONE IF PSEUDOPOTENTIALS ARE USED. AMPDRV (THE ONLY EFFECT OF THIS IS TO SUPRESS THE LABELLING OFAMPDRV ORBITALS WHEN ONE OR MORE ATOMS HAS A PSEUDOPOTENTIAL) AMPDRV AMPDRV IWCUBF THIS PERTAINS ONLY TO BASIS SETS WITH F FUNCTIONS. AMPDRV AMPDRV IF CARTESIAN F FUNCTIONS ARE INPUT, SET IWCUBF TO: AMPDRV 0, IF THESE ARE TO BE TRANSFORMED TO THE STANDARD AMPDRV OF PURE F FUNCTIONS AMPDRV 1, IF THESE ARE TO BE TRANSFORMED TO THE CUBIC AMPDRV SET OF PURE F FUNCTIONS AMPDRV AMPDRV IF PURE F FUNCTIONS ARE INPUT, SET TO IWCUBF TO: AMPDRV 0, IF THESE ARE STANDARD F FUNCTIONS AMPDRV 1, IF THESE ARE CUBIC F FUNCTIONS AMPDRV AMPDRV AMPDRV IATNO(I),I=1,NATOMS AMPDRV LIST OF ATOMIC NUMBERS AMPDRV AMPDRV LCTR(I),I=1,NBAS AMPDRV LIST OF ATOMIC CENTERS OF THE BASIS FUNCTIONS AMPDRV (LCTR(3)=2 IF BASIS FUNCT. 3 IS ON ATOM 2) AMPDRV AMPDRV LANG(I),I=1,NBAS AMPDRV LIST OF ANGULAR SYMMETRY INFORMATION FOR THE BASIS AMPDRV FUNCTIONS AMPDRV AMPDRV IWCUBF = 0 AMPDRV IPSEUD = 0 AMPDRV AMPDRV CONSTRUCT ATOM AND AO BASIS INFORMATION LISTS: AMPDRV IATNO(I) = ATOMIC NUMBER OF ATOM "I" AMPDRV IZNUC(I) = NUCLEAR CHARGE ON ATOM "I" (IATNO(I)-# OF CORE ELECTRONAMPDRV LCTR(I) = ATOMIC CENTER FOR BASIS FUNCTION "I" AMPDRV LANG(I) = ANGULAR SYMMETRY LABEL FOR BASIS FUNCTION "I" AMPDRV AMPDRV IBAS = 0 AMPDRV NAT = 0 AMPDRV DO 200 I = 1,NATOM AMPDRV IF(LABELS(I).EQ.99) GOTO 200 AMPDRV NAT = NAT + 1 AMPDRV IATNO(NAT) = LABELS(I) AMPDRV DO 100 J = 1,12 AMPDRV JJ = J AMPDRV IF(IATNO(NAT)-NCORE(JJ).LT.0) GOTO 110 AMPDRV 100 CONTINUE AMPDRV STOP 'UNKNOWN ATOM' AMPDRV AMPDRV 110 JJ = JJ - 1 AMPDRV IF(JJ.EQ.0) THEN AMPDRV IZNUC(NAT) = IATNO(NAT) AMPDRV ELSE AMPDRV IZNUC(NAT) = IATNO(NAT) - NCORE(JJ) AMPDRV IPSEUD = 1 AMPDRV END IF AMPDRV DO 150 J = 1,NATORB(LABELS(I)) AMPDRV IBAS = IBAS + 1 AMPDRV LCTR(IBAS) = NAT AMPDRV LANG(IBAS) = LIST(J) AMPDRV 150 CONTINUE AMPDRV 200 CONTINUE AMPDRV AMPDRV PUT INFO INTO COMMON/NBINFO/: AMPDRV AMPDRV NATOMS = NAT AMPDRV NDIM = IBAS AMPDRV NBAS = IBAS AMPDRV AMPDRV EXPECTATION VALUES OF THE FOCK OPERATOR ARE IN ELECTRON VOLTS: AMPDRV AMPDRV MUNIT = 1 AMPDRV AMPDRV DETERMINE TYPE OF WAVE FUNCTION DENSITY MATRIX IS FROM: AMPDRV AMPDRV ORTHO = .TRUE. AMPDRV IF(INDEX(KEYWRD,'C.I.').NE.0) CI = .TRUE. AMPDRV IF(INDEX(KEYWRD,'UHF').NE.0) UHF = .TRUE. AMPDRV IF(INDEX(KEYWRD,'OPEN').NE.0) OPEN = .TRUE. AMPDRV IF(INDEX(KEYWRD,'DOUBLE').NE.0) OPEN = .TRUE. AMPDRV IF(INDEX(KEYWRD,'TRIPLET').NE.0) OPEN = .TRUE. AMPDRV IF(INDEX(KEYWRD,'QUARTET').NE.0) OPEN = .TRUE. AMPDRV IF(INDEX(KEYWRD,'QUINTET').NE.0) OPEN = .TRUE. AMPDRV IF(INDEX(KEYWRD,'SEXTET').NE.0) OPEN = .TRUE. AMPDRV IF(UHF) OPEN = .TRUE. AMPDRV IF(OPEN) UHF = .TRUE. AMPDRV AMPDRV IF(ROHF.OR.CI) IWFOCK = 0 AMPDRV AMPDRV STORE THE JOB TITLE ON THE NBO DAF: AMPDRV AMPDRV DO 210 I = 1,10 AMPDRV CORE(I) = TITLE(I) AMPDRV 210 CONTINUE AMPDRV NFILE = 2 AMPDRV CALL NBWRIT(CORE,10,NFILE) AMPDRV AMPDRV STORE NATOMS, NDIM, NBAS, MUNIT, WAVEFUNCTION FLAGS, ISWEAN: AMPDRV AMPDRV ICORE(1) = NATOMS AMPDRV ICORE(2) = NDIM AMPDRV ICORE(3) = NBAS AMPDRV ICORE(4) = MUNIT AMPDRV ICORE(5) = 0 AMPDRV IF(ROHF) ICORE(5) = 1 AMPDRV ICORE(6) = 0 AMPDRV IF(UHF) ICORE(6) = 1 AMPDRV ICORE(7) = 0 AMPDRV IF(CI) ICORE(7) = 1 AMPDRV ICORE(8) = 0 AMPDRV IF(OPEN) ICORE(8) = 1 AMPDRV ICORE(9) = 0 AMPDRV IF(MCSCF) ICORE(9) = 1 AMPDRV ICORE(10) = 0 AMPDRV IF(AUHF) ICORE(10) = 1 AMPDRV ICORE(11) = 0 AMPDRV IF(ORTHO) ICORE(11) = 1 AMPDRV ICORE(12) = 1 AMPDRV NFILE = 3 AMPDRV CALL NBWRIT(ICORE,12,NFILE) AMPDRV AMPDRV STORE IATNO, IZNUC, LCTR, AND LANG ON NBO DAF: AMPDRV AMPDRV II = 0 AMPDRV DO 220 I = 1,NATOMS AMPDRV II = II + 1 AMPDRV ICORE(II) = IATNO(I) AMPDRV 220 CONTINUE AMPDRV DO 230 I = 1,NATOMS AMPDRV II = II + 1 AMPDRV ICORE(II) = IZNUC(I) AMPDRV 230 CONTINUE AMPDRV DO 240 I = 1,NBAS AMPDRV II = II + 1 AMPDRV ICORE(II) = LCTR(I) AMPDRV 240 CONTINUE AMPDRV DO 250 I = 1,NBAS AMPDRV II = II + 1 AMPDRV ICORE(II) = LANG(I) AMPDRV 250 CONTINUE AMPDRV NFILE = 4 AMPDRV CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE) AMPDRV AMPDRV STORE ATOMIC COORDINATES ON THE NBO DAF: AMPDRV AMPDRV CALL GMETRY(GEO,CORE) AMPDRV NFILE = 9 AMPDRV CALL NBWRIT(CORE,3*NATOMS,NFILE) AMPDRV AMPDRV STORE THE DENSITY MATRICES ON THE NBO DAF: AMPDRV AMPDRV IWDM = 0 AMPDRV L2 = NDIM*(NDIM+1)/2 AMPDRV IF(OPEN) THEN AMPDRV NFILE = 20 AMPDRV CALL NBWRIT(PA,L2,NFILE) AMPDRV NFILE = 21 AMPDRV CALL NBWRIT(PB,L2,NFILE) AMPDRV ELSE AMPDRV NFILE = 20 AMPDRV CALL NBWRIT(P,L2,NFILE) AMPDRV END IF AMPDRV AMPDRV STORE THE FOCK MATRICES ON THE NBO DAF: AMPDRV AMPDRV IF(.NOT.ROHF.AND..NOT.CI) THEN AMPDRV NFILE = 30 AMPDRV CALL NBWRIT(F,L2,NFILE) AMPDRV IF(OPEN) THEN AMPDRV NFILE = 31 AMPDRV CALL NBWRIT(FB,L2,NFILE) AMPDRV END IF AMPDRV END IF AMPDRV AMPDRV STORE THE AO TO MO TRANSFORMATIONS ON THE NBO DAF: AMPDRV AMPDRV L3 = NDIM*NDIM AMPDRV NFILE = 40 AMPDRV CALL NBWRIT(C,L3,NFILE) AMPDRV IF(OPEN) THEN AMPDRV NFILE = 41 AMPDRV CALL NBWRIT(CBETA,L3,NFILE) AMPDRV END IF AMPDRV AMPDRV RETURN AMPDRV END AMPDRV ***********************************************************************AMPDRV SUBROUTINE DELSCF(CORE,ICORE) AMPDRV ***********************************************************************AMPDRV IMPLICIT REAL*8 (A-H,O-Z) AMPDRV LOGICAL NEW,ERROR,SEQ AMPDRV AMPDRV NBO common blocks: AMPDRV AMPDRV COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT AMPDRV COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO AMPDRV LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO AMPDRV COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, AMPDRV + LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, AMPDRV + LFNDAF,LFNDEF AMPDRV AMPDRV AMPAC COMMON blocks: AMPDRV AMPDRV INCLUDE 'SIZES' AMPDRV AMPDRV COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), AMPDRV + NLAST(NUMATM), NORBS, NELECS, AMPDRV + NALPHA, NBETA, NCLOSE, NOPEN, NDUMY, FRACT AMPDRV COMMON /HMATRX/ H(MPACK) AMPDRV COMMON /WMATRX/ WJ(N2ELEC), WK(N2ELEC) AMPDRV COMMON /FOKMAT/ F(MPACK), FB(MPACK) AMPDRV COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK) AMPDRV COMMON /ATHEAT/ ATHEAT AMPDRV COMMON /ENUCLR/ ENUCLR AMPDRV COMMON /GEOM / GEO(3,NUMATM) AMPDRV AMPDRV DIMENSION CORE(1),ICORE(1),W(N2ELEC) AMPDRV EQUIVALENCE (W(1),WJ(1)) AMPDRV AMPDRV DATA TWO,TOKCAL/2.0D0,23.061D0/ AMPDRV AMPDRV Open the NBO direct access file: AMPDRV AMPDRV NEW = .FALSE. AMPDRV CALL NBOPEN(NEW,ERROR) AMPDRV IF(ERROR) THEN AMPDRV WRITE(LFNPR,900) AMPDRV STOP AMPDRV END IF AMPDRV AMPDRV Compute the one-electron and two-electron integrals, given the atomicAMPDRV coordinates. Also compute the nuclear repulsion contribution to the AMPDRV SCF energy: AMPDRV AMPDRV CALL GMETRY(GEO,CORE) AMPDRV CALL HCORE(CORE,H,W,WJ,WK,ENUCLR) AMPDRV AMPDRV Compute the SCF and deletion energies for UHF wavefunctions: AMPDRV AMPDRV LEN = NBAS * (NBAS + 1) / 2 AMPDRV IF(UHF) THEN AMPDRV AMPDRV Read the spin densities from the NBO direct access file and calculateAMPDRV to total density: AMPDRV AMPDRV ALPHA = .TRUE. AMPDRV BETA = .FALSE. AMPDRV CALL FEDRAW(PA,CORE) AMPDRV CALL PACK(PA,NDIM,NBAS,LEN) AMPDRV ALPHA = .FALSE. AMPDRV BETA = .TRUE. AMPDRV CALL FEDRAW(PB,CORE) AMPDRV CALL PACK(PB,NDIM,NBAS,LEN) AMPDRV DO 10 I = 1,LEN AMPDRV P(I) = PA(I) + PB(I) AMPDRV 10 CONTINUE AMPDRV AMPDRV Alpha spin: construct the alpha Fock matrix: AMPDRV AMPDRV CALL COPY(H,F,LEN,LEN,1) AMPDRV CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV CALL FOCK1(F,P,PA,PB) AMPDRV AMPDRV Alpha spin: construct the alpha Fock matrix: AMPDRV AMPDRV CALL COPY(H,FB,LEN,LEN,1) AMPDRV CALL FOCK2(FB,P,PB,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV CALL FOCK1(FB,P,PB,PA) AMPDRV AMPDRV Determine the SCF energy: AMPDRV AMPDRV EE = HELECT(NBAS,PA,H,F) + HELECT(NBAS,PB,H,FB) AMPDRV ESCF = (EE + ENUCLR) * TOKCAL + ATHEAT AMPDRV AMPDRV Repeat process for the deletion energy: AMPDRV AMPDRV ALPHA = .TRUE. AMPDRV BETA = .FALSE. AMPDRV CALL FENEWD(PA) AMPDRV ALPHA = .FALSE. AMPDRV BETA = .TRUE. AMPDRV CALL FENEWD(PB) AMPDRV DO 20 I = 1,LEN AMPDRV P(I) = PA(I) + PB(I) AMPDRV 20 CONTINUE AMPDRV CALL COPY(H,F,LEN,LEN,1) AMPDRV CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV CALL FOCK1(F,P,PA,PB) AMPDRV CALL COPY(H,FB,LEN,LEN,1) AMPDRV CALL FOCK2(FB,P,PB,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV CALL FOCK1(FB,P,PB,PA) AMPDRV EE = HELECT(NBAS,PA,H,F) + HELECT(NBAS,PB,H,FB) AMPDRV EDEL = (EE + ENUCLR) * TOKCAL + ATHEAT AMPDRV AMPDRV Compute the SCF and deletion energies for RHF wavefunctions: AMPDRV AMPDRV ELSE AMPDRV ALPHA = .FALSE. AMPDRV BETA = .FALSE. AMPDRV CALL FEDRAW(P,CORE) AMPDRV CALL PACK(P,NDIM,NBAS,LEN) AMPDRV DO 30 I = 1,LEN AMPDRV PA(I) = P(I) / TWO AMPDRV PB(I) = P(I) / TWO AMPDRV 30 CONTINUE AMPDRV AMPDRV Construct the Fock matrix: AMPDRV AMPDRV CALL COPY(H,F,LEN,LEN,1) AMPDRV CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV CALL FOCK1(F,P,PA,PB) AMPDRV AMPDRV Determine the SCF energy: AMPDRV AMPDRV EE = HELECT(NBAS,PA,H,F) * TWO AMPDRV ESCF = (EE + ENUCLR) * TOKCAL + ATHEAT AMPDRV AMPDRV Repeat process for the deletion energy: AMPDRV AMPDRV CALL FENEWD(P) AMPDRV DO 40 I = 1,LEN AMPDRV PA(I) = P(I) / TWO AMPDRV PB(I) = P(I) / TWO AMPDRV 40 CONTINUE AMPDRV CALL COPY(H,F,LEN,LEN,1) AMPDRV CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST) AMPDRV CALL FOCK1(F,P,PA,PB) AMPDRV EE = HELECT(NBAS,PA,H,F) * TWO AMPDRV EDEL = (EE + ENUCLR) * TOKCAL + ATHEAT AMPDRV END IF AMPDRV AMPDRV Save these energies on the direct access file: AMPDRV AMPDRV CORE(1) = EDEL AMPDRV CORE(2) = ESCF AMPDRV NFILE = 8 AMPDRV CALL NBWRIT(CORE,2,NFILE) AMPDRV AMPDRV Note that these energies are in units of kcal/mol!! AMPDRV AMPDRV MUNIT = 2 AMPDRV NFILE = 3 AMPDRV CALL NBREAD(ICORE,12,NFILE) AMPDRV ICORE(4) = MUNIT AMPDRV CALL NBWRIT(ICORE,12,NFILE) AMPDRV AMPDRV Close the NBO direct access file: AMPDRV AMPDRV SEQ = .FALSE. AMPDRV CALL NBCLOS(SEQ) AMPDRV RETURN AMPDRV AMPDRV 900 FORMAT(/1X,'Error opening the NBO direct access file in ', AMPDRV + 'subroutine DELSCF.') AMPDRV END AMPDRV ***********************************************************************AMPDRV AMPDRV E N D O F A M P N B O R O U T I N E S AMPDRV AMPDRV ***********************************************************************AMPDRV ÿ