************************************************************************ PATCH FOR $DEL NBO-DELETIONS: REPLACE SUBROUTINE NBODEL WITH CODE BELOW: C*********************************************************************** SUBROUTINE NBODEL(A,MEMORY,IDONE,ISET) C*********************************************************************** C C IDONE : continue NBO deletions [output] C IDONE = 1 if deletions are completed C IDONE = 0 otherwise C C ISET : deletion type [output] C ISET = 0 for NBO deletions (default) C ISET = 1 for NHO deletions C ISET = 2 for NAO deletions C ISET = 3 for NLMO deletions C C A(MEMORY) is scratch storage C C----------------------------------------------------------------------- C 12-Jun-98 EDG Save AO-MO transformation for all deletions C 10-Jun-98 EDG Clean up NEWDM and NBDELE to remove truncation C 12-Jun-96 EDG Add NAO and NHO deletions C 3-Mar-94 EDG Add UHF capabilities for NEDA C----------------------------------------------------------------------- IMPLICIT REAL*8 (A-H,O-Z) EXTERNAL PACK LOGICAL DONE,ERROR,EQUAL DIMENSION A(MEMORY),ICH(3,2),INAM(3),ISP(3) DIMENSION KEYWD(6),KNAO(3),KNHO(3),KNBO(3),KNLMO(4) C C NBO Common Blocks: C PARAMETER(MAXBAS = 9999) 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,LFNLBL,LFNDEF,LFNBRK(100) COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,NNAO,MXBO,MXAO,MXAOLM,MUNIT COMMON/NBEDA/KFRG,NFRG,IFRG(MAXBAS),NFE(MAXBAS),NFEB(MAXBAS) COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS), + NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS), + IPOLBL(10,MAXBAS) C SAVE LBD,L3C,LBLNK2,LBLNK1,LHYP SAVE ZERO,EPS,TENTH SAVE KEYWD,KNAO,KNHO,KNBO,KNLMO C DATA ZERO,EPS,TENTH/0.0D0,1.0D-5,1.0D-1/ DATA LBD/2HBD/,L3C/2H3C/,LBLNK2/2H /,LBLNK1/1H /,LHYP/1H-/ DATA KNAO/1HN,1HA,1HO/,KNHO/1HN,1HH,1HO/,KNBO/1HN,1HB,1HO/ DATA KNLMO/1HN,1HL,1HM,1HO/ C C Allocate memory: C NSQ = NDIM*NDIM N1 = 1 N2 = N1 + NDIM N3 = N2 + NDIM N4 = N3 + NSQ N5 = N4 + NSQ N6 = N5 + NSQ N7 = N6 + NSQ NEND = N7 + NSQ IF(NEND.GT.MEMORY) THEN WRITE(LFNPR,900) NEND,MEMORY IDONE = 1 RETURN END IF C C Read orbital type for deletions: C IF(ISPIN.NE.-2) THEN LEN = 6 CALL HFLD(KEYWD,LEN,ERROR) IF(LEN.EQ.3.AND.EQUAL(KEYWD,KNBO,3)) THEN ISET = 0 ELSE IF(LEN.EQ.3.AND.EQUAL(KEYWD,KNHO,3)) THEN ISET = 1 ELSE IF(LEN.EQ.3.AND.EQUAL(KEYWD,KNAO,3)) THEN ISET = 2 ELSE IF(LEN.EQ.4.AND.EQUAL(KEYWD,KNLMO,4)) THEN ISET = 3 NFILE = 46 CALL NBINQR(NFILE) IF(NFILE.EQ.0) THEN WRITE(LFNPR,950) IDONE = 1 RETURN END IF ELSE CALL RTNFLD ISET = 0 END IF END IF C C NBO deletions: C C A(N1) : NBO occupancies C A(N3) : AO to NBO transformation C A(N4) : NBO Fock matrix (triangular) C A(N5) : scratch C IF(ISET.EQ.0) THEN CALL FENBO(A(N3),A(N1),A(N5),A(N5)) CALL FEFNBO(A(N4)) C C NHO deletions: C C A(N1) : NHO occupancies C A(N3) : AO to NHO transformation C A(N4) : NHO Fock matrix (triangular) C A(N5) : NAO to NHO transformation C A(N6) : scratch C A(N7) : scratch C ELSE IF(ISET.EQ.1) THEN CALL FELBLS CALL FETNAO(A(N3)) CALL FETNHO(A(N5)) CALL MATML1(A(N3),A(N5),A(N7),NDIM,NDIM,NDIM,NBAS,NNAO,NNAO) CALL FEDNAO(A(N6)) CALL SIMTRS(A(N6),A(N5),A(N7),NDIM,NNAO) DO 10 I = 1,NNAO IOFF1 = N1 + I - 1 IOFF2 = N6 + (I - 1) * (NDIM + 1) A(IOFF1) = A(IOFF2) 10 CONTINUE CALL FEFAO(A(N4),IWFOCK) CALL SIMTR1(A(N4),A(N3),A(N7),NDIM,NBAS,NBAS,NNAO) CALL PACK(A(N4),NDIM,NNAO) C C NAO deletions: C C A(N1) : NAO OCCUPANCIES C A(N3) : AO to NAO transformation C A(N4) : NAO Fock matrix (triangular) C A(N6) : scratch C ELSE IF(ISET.EQ.2) THEN CALL FELBLS CALL FETNAO(A(N3)) CALL FEDNAO(A(N6)) DO 20 I = 1,NNAO IOFF1 = N1 + I - 1 IOFF2 = N6 + (I - 1) * (NDIM + 1) A(IOFF1) = A(IOFF2) 20 CONTINUE CALL FEFAO(A(N4),IWFOCK) CALL SIMTR1(A(N4),A(N3),A(N6),NDIM,NBAS,NBAS,NNAO) CALL PACK(A(N4),NDIM,NNAO) C C NLMO deletions: C C A(N1) : NLMO occupancies C A(N3) : AO to NLMO transformation C A(N4) : NLMO Fock matrix (triangular) C A(N5) : scratch C A(N6) : scratch C A(N7) : scratch C C Note: NBOs are overwritten by NLMOs on DAF (for NEDA)! C ELSE IF(ISET.EQ.3) THEN CALL FELBLS CALL FENLMO(A(N3),A(N5),A(N5)) CALL FEDRAW(A(N4),A(N6)) CALL FESRAW(A(N6)) CALL SIMTRS(A(N4),A(N6),A(N7),NDIM,NBAS) CALL SIMTR1(A(N4),A(N3),A(N7),NDIM,NBAS,NBAS,NNAO) DO 30 I = 1,NNAO IOFF1 = N1 + I - 1 IOFF2 = N4 + (I - 1) * (NDIM + 1) A(IOFF1) = A(IOFF2) 30 CONTINUE CALL SVNBO(A(N3),A(N1),A(N7)) CALL FEFAO(A(N4),IWFOCK) CALL SIMTR1(A(N4),A(N3),A(N7),NDIM,NBAS,NBAS,NNAO) CALL PACK(A(N4),NDIM,NNAO) END IF C C Delete Fock matrix elements, forming modified Fock matrix in TRF: C C A(N4) : 'ISET' Fock matrix [input] C A(N5) : modified Fock matrix [output] C A(N7) : scratch C CALL NBDELE(A(N4),A(N5),NNAO,NDIM,A(N7),NSQ,DONE,ISPIN,ISET) C C If no more deletions, exit program: C IF(DONE) THEN IDONE = 1 RETURN END IF C C Diagonalize mofified Fock matrix in TRF: C C A(N5) : modified Fock matrix, TRF [input] C A(N2) : eigenvalues of TRF [output] C A(N4) : eigenvectors of TRF [output] C CALL JACOBI(NNAO,A(N5),A(N2),A(N4),NDIM,NDIM,0) C C Construct new density matrix from eigenvectors of TRF: C C A(N5) : new density matrix [output] C A(N4) : eigenvectors of TRF [input] C A(N2) : eigenvalues of TRF [input] C new occupancies [output] C A(N1) : original occupancies [input] C A(N7) : scratch C CALL NEWDM(A(N5),A(N4),A(N2),A(N1),A(N7),NNAO,NDIM,ISPIN,ISET) CALL SVNEWT(A(N4)) C C Prepare new AO to MO transformation: C C A(N3) : AO to 'ISET' transformation [input] C A(N4) : 'ISET' to MO transformation [input] C A(N6) : AO to MO transformation [output] C A(N7) : scratch C CALL COPY(A(N3),A(N6),NDIM,NBAS,NNAO) CALL MATML1(A(N6),A(N4),A(N7),NDIM,NDIM,NDIM,NBAS,NNAO,NNAO) CALL SVTEDA(A(N6)) C C Transform the new density matrix to the AO basis: C C A(N3) : AO to 'ISET' transformation [input] C A(N5) : new density matrix [input] C A(N4) : scratch C A(N6) : scratch C CALL NBTRSP(A(N3),NDIM,NBAS) CALL UNPACK(A(N5),NDIM,NNAO) CALL SIMTR1(A(N5),A(N3),A(N4),NDIM,NNAO,NNAO,NBAS) CALL PACK(A(N5),NDIM,NBAS) CALL SVNEWD(A(N5)) C C Write details of the deletions: C WRITE(LFNPR,910) IF(ISET.EQ.0) THEN DO 50 IBAS = 1,NNAO IB = IBXM(IBAS) LBL = LABEL(IB,1) NCTR = 1 IF(LBL.EQ.LBD) NCTR = 2 IF(LBL.EQ.L3C) NCTR = 3 DO 40 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 40 CONTINUE I = N1 - 1 + IBAS II = N2 - 1 + IBAS OCCCHG = A(II) - A(I) WRITE(LFNPR,920) 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 50 CONTINUE ELSE DO 60 IBAS = 1,NNAO I = N1 - 1 + IBAS II = N2 - 1 + IBAS OCCCHG = A(II) - A(I) IF(ISET.EQ.1) THEN WRITE(LFNPR,930) IBAS,(NHOLBL(K,IBAS),K=1,10),A(I),A(II), + OCCCHG ELSE IF(ISET.EQ.2) THEN WRITE(LFNPR,930) IBAS,(NAOLBL(K,IBAS),K=1,10),A(I),A(II), + OCCCHG ELSE WRITE(LFNPR,930) IBAS,(NBOLBL(K,IBAS),K=1,10),A(I),A(II), + OCCCHG END IF 60 CONTINUE END IF C C Count electrons on NEDA fragments: C IF(NFRG.NE.0) THEN ICNT = 0 DO 80 I = 1,NFRG SUM = ZERO II = N2 - 1 DO 70 IBAS = 1,NNAO II = II + 1 IF(IFRG(NBOUNI(IBAS)).EQ.I) SUM = SUM + A(II) 70 CONTINUE IF(ISPIN.NE.-2) THEN NFE(I) = INT(SUM + TENTH) DIFF = ABS(SUM - DFLOAT(NFE(I))) ELSE NFEB(I) = INT(SUM + TENTH) DIFF = ABS(SUM - DFLOAT(NFEB(I))) END IF IF(DIFF.GT.EPS) THEN ICNT = ICNT + 1 WRITE(LFNPR,940) I,SUM END IF 80 CONTINUE IF(ICNT.NE.0) CALL NBHALT('NBODEL: error counting electrons') END IF IDONE = 0 RETURN C 900 FORMAT(/1X,'Insufficient memory in subroutine NBODEL:',/5X, + 'Memory needed: ',I10,' Memory available: ',I10,/1X, + 'Deletions halted!') 910 FORMAT(/1X,'Orbital occupancies:',//7X,'Orbital',19X, + 'No deletions This deletion Change',/1X,78('-')) 920 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',3(A2,3A1),9X,F7.5,8X,F7.5,3X, + F8.5) 930 FORMAT(1X,I3,'. ',10A1,21X,F7.5,8X,F7.5,3X,F8.5) 940 FORMAT(1X,'WARNING -- Fragment',I3,' does not have an integer ', + 'number of electrons:',F10.5) 950 FORMAT(/1X,'NLMO deletions require that NLMO analysis be enable', + 'd via the $NBO keylist.') END