C*****************************************************************************
C
C
C
C                  N  B  O     P  R  O  G  R  A  M
C
C                   (SYSTEM INDEPENDENT ROUTINES)
C
C
C
C              LAST PROGRAM MODIFICATION:  OCTOBER 22, 1991
C
C
C        !!! CRAY COMPILATION REQUIRES 64 BIT (-i64) INTEGERS !!!
C        (SEE, IN PARTICULAR, SR JOBOPT, SR NBOPEN, AND SR DEBYTE)
C
C*****************************************************************************
C
C  MAIN SUBROUTINE:
C
C      SUBROUTINE NBO(CORE,NBOOPT,MEMORY)
C
C  JOB INITIALIZATION ROUTINES: (CALLED BY SR NBO)
C
C      SUBROUTINE NBOSET(NBOOPT)
C      SUBROUTINE JOBOPT(NBOOPT)
C      SUBROUTINE NBODIM(MEMORY)
C
C  NAO/NBO/NLMO FORMATION ROUTINES: (CALLED BY SR NBO)
C
C      SUBROUTINE NAODRV(DM,T,A)
C      SUBROUTINE NAOSIM(DM,T,A)
C      SUBROUTINE DMNAO(DM,T,A)
C      SUBROUTINE DMSIM(DM,T,A)
C      SUBROUTINE NBODRV(DM,T,A,MEMORY)
C
C  ROUTINES CALLED BY THE NAO DRIVERS:
C
C      SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF)
C      SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF)
C      SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR)
C      SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK)
C      SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO)
C      SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG)
C
C  ROUTINES CALLED BY SR NAO:
C
C      SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM)
C      SUBROUTINE ATDIAG(N,A,B,EVAL,C)
C      SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM)
C      SUBROUTINE NEWWTS(S,T,WT)
C      SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK)
C      SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK)
C      SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2,
C     +                       LIST,IRPNAO)
C      SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
C     +                    IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
C      SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT)
C      SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO)
C      SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,IRPNAO)
C
C  ROUTINES CALLED BY THE NBO/NLMO DRIVERS:
C
C      SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C     +                                       P,TA,HYB,VA,VB,TOPO)
C      SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C     +                                       P,TA,HYB,VA,VB,TOPO)
C      SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C     +                                  P,TA,HYB,VA,VB,TOPO,IFLG)
C      SUBROUTINE SRTNBO(T,BNDOCC)
C      SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR)
C      SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB)
C      SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN)
C      SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
C      SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR)
C      SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB)
C      SUBROUTINE FNDMOL(IATOMS)
C      SUBROUTINE NBOCLA(BNDOCC,ACCTHR)
C      SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO)
C      SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR)
C      SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG)
C      SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR)
C      SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM)
C      SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,SIAB,NOCC,NAB)
C      SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX)
C      SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX)
C      SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC)
C
C  ROUTINES CALLED BY SR NATHYB, SR CHOOSE:
C
C      SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
C      FUNCTION IWPRJ(NCTR)
C      SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD)
C      SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
C      SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP)
C      SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
C      SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG)
C      SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI)
C      SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
C      SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD)
C      SUBROUTINE FORMT(T,Q,POL)
C      SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
C
C  ROUTINES CALLED BY SR NLMO:
C
C      SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT,
C     +           NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
C      SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL)
C
C  NBO ENERGETIC ANALYSIS ROUTINES:
C
C      SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE)
C      SUBROUTINE NBODEL(A,MEMORY,IDONE)
C      SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE,
C     +                  ISPIN)
C      SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN)
C      SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK)
C      SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL)
C
C  NBO DIRECT ACCESS FILE (DAF) ROUTINES:
C
C      SUBROUTINE NBFILE(NEW,ERROR)
C      SUBROUTINE NBOPEN(NEW,ERROR)
C      SUBROUTINE NBWRIT(IX,NX,IDAR)
C      SUBROUTINE NBREAD(IX,NX,IDAR)
C      SUBROUTINE NBCLOS(SEQ)
C      SUBROUTINE NBINQR(IDAR)
C
C      SUBROUTINE FETITL(TITLE)
C      SUBROUTINE FEE0(EDEL,ETOT)
C      SUBROUTINE SVE0(EDEL)
C      SUBROUTINE FECOOR(ATCOOR)
C      SUBROUTINE FESRAW(S)
C      SUBROUTINE FEDRAW(DM,SCR)
C      SUBROUTINE FEFAO(F,IWFOCK)
C      SUBROUTINE FEAOMO(T,IT)
C      SUBROUTINE FEDXYZ(DXYZ,I)
C      SUBROUTINE SVNBO(T,OCC,ISCR)
C      SUBROUTINE FENBO(T,OCC,ISCR,NELEC)
C      SUBROUTINE FETNBO(T)
C      SUBROUTINE SVPNAO(T)
C      SUBROUTINE FEPNAO(T)
C      SUBROUTINE SVSNAO(S)
C      SUBROUTINE FESNAO(S)
C      SUBROUTINE SVTNAB(T)
C      SUBROUTINE FETNAB(T)
C      SUBROUTINE SVTLMO(T)
C      SUBROUTINE FETLMO(T)
C      SUBROUTINE SVTNHO(T)
C      SUBROUTINE FETNHO(T)
C      SUBROUTINE SVPPAO(DM)
C      SUBROUTINE FEPPAO(DM)
C      SUBROUTINE SVTNAO(T)
C      SUBROUTINE FETNAO(T)
C      SUBROUTINE SVNLMO(T)
C      SUBROUTINE FENLMO(T)
C      SUBROUTINE SVDNAO(DM)
C      SUBROUTINE FEDNAO(DM)
C      SUBROUTINE SVFNBO(F)
C      SUBROUTINE FEFNBO(F)
C      SUBROUTINE SVNEWD(DM)
C      SUBROUTINE FENEWD(DM)
C      SUBROUTINE FEINFO(ICORE,ISWEAN)
C      SUBROUTINE FEBAS(NSHELL,NEXP,ISCR)
C
C  FREE FORMAT INPUT ROUTINES:
C
C      SUBROUTINE STRTIN(LFNIN)
C      SUBROUTINE RDCRD
C      SUBROUTINE IFLD(INT,ERROR)
C      SUBROUTINE RFLD(REAL,ERROR)
C      SUBROUTINE HFLD(KEYWD,LENG,ENDD)
C      SUBROUTINE FNDFLD
C      FUNCTION EQUAL(IA,IB,L)
C
C  OTHER SYSTEM-INDEPENDENT I/O ROUTINES:
C
C      SUBROUTINE GENINP(NEWDAF)
C      SUBROUTINE NBOINP(NBOOPT,IDONE)
C      SUBROUTINE CORINP(IESS,ICOR)
C      SUBROUTINE CHSINP(IESS,ICHS)
C      SUBROUTINE DELINP(NBOOPT,IDONE)
C
C      SUBROUTINE RDCORE(JCORE)
C      SUBROUTINE WRPPNA(T,OCC,IFLG)
C      SUBROUTINE RDPPNA(T,OCC,IFLG)
C      SUBROUTINE WRTNAO(T,IFLG)
C      SUBROUTINE RDTNAO(DM,T,SCR,IFLG)
C      SUBROUTINE WRTNAB(T,IFLG)
C      SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG)
C      SUBROUTINE WRTNBO(T,BNDOCC,IFLG)
C      SUBROUTINE WRNLMO(T,DM,IFLG)
C      SUBROUTINE WRBAS(SCR,ISCR,LFN)
C      SUBROUTINE WRARC(SCR,ISCR,LFN)
C
C      SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG)
C      SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL)
C      SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN)
C      SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR)
C      SUBROUTINE ALTOUT(A,MR,MC,NR,NC)
C      SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR)
C      FUNCTION IOINQR(IFLG)
C      SUBROUTINE LBLAO
C      SUBROUTINE LBLNAO
C      SUBROUTINE LBLNBO
C      SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR)
C
C  GENERAL UTILITY ROUTINES:
C
C      SUBROUTINE ANGLES(X,Y,Z,THETA,PHI)
C      FUNCTION BDFIND(IAT,JAT)
C      SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR)
C      SUBROUTINE CONSOL(AUT,ALT,NDIM,N)
C      SUBROUTINE CONVIN(IJ,LEN,IK,ERROR)
C      SUBROUTINE CONVRT(N,NC1,NC2)
C      SUBROUTINE COPY(A,B,NDIM,NR,NC)
C      SUBROUTINE CORTBL(IAT,ICORE,IECP)
C      SUBROUTINE DEBYTE(I,IBYTE)
C      SUBROUTINE HALT(WORD)
C      SUBROUTINE IDIGIT(KINT,IK,ND,MAXD)
C      FUNCTION IHTYP(IBO,JBO)
C      SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR)
C      SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT)
C      SUBROUTINE MATMLT(A,B,V,NDIM,N)
C      SUBROUTINE MATML2(A,B,V,NDIM,N)
C      FUNCTION NAMEAT(IZ)
C      SUBROUTINE NORMLZ(A,S,M,N)
C      SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK)
C      SUBROUTINE PACK(T,NDIM,NBAS,L2)
C      SUBROUTINE RANK(EIG,N,NDIM,ARCRNK)
C      SUBROUTINE SIMTRN(A,T,V,NDIM,N)
C      SUBROUTINE SIMTRS(A,S,V,NDIM,N)
C      SUBROUTINE TRANSP(A,NDIM,N)
C      SUBROUTINE UNPACK(T,NDIM,NBAS,L2)
C      SUBROUTINE VALTBL(IAT,IVAL)
C      FUNCTION VECLEN(X,N,NDIM)
C
C      SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR,
C     +                 IERR)
C      SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG)
C      SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR)
C      SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM)
C
C*****************************************************************************
      SUBROUTINE NBO(CORE,MEMORY,NBOOPT)
C*****************************************************************************
C
C  Input:
C     CORE       Core memory to be dynamically allocated for storage needs.
C     MEMORY     The number of REAL*8 words available in `CORE'.
C     NBOOPT(10) List of NBO options as summarized below:
C
C     NBOOPT(1)  = -2       Do nothing
C                = -1       Natural Population Analysis (NPA) only
C                =  0       Perform NPA/NBO/NLMO analyses
C                =  1       Perform NPA/NBO/NLMO analyses, don't read keywords
C                =  2       Perform one Fock matrix deletion, forming new DM
C                =  3       Evaluate and print the energy change from deletion
C
C     NBOOPT(2)  =  0       SCF density
C                =  1       MP first order density
C                =  3       MP2 density
C                =  4       MP3 density
C                =  5       MP4 density
C                =  6       CI one-particle density
C                =  7       CI density
C                =  8       QCI/CC density
C                =  9       Density correct to second order
C
C     NBOOPT(3)  =  1       Transform dipole moment matrices to NBO/NLMO bases
C
C     NBOOPT(4)  =  1       Allow strongly resonant Lewis Structures
C                           (Force the RESONANCE keyword)
C
C     NBOOPT(5)  =  1       Spin-annihilated UHF (AUHF) wavefunction
C
C     NBOOPT(6-9)           Unused
C
C     NBOOPT(10) =  0       General version of the NBO program (GENNBO)
C                =  1       AMPAC version
C                =  6       GAMESS version
C                =  7       HONDO version
C                =  8x      Gaussian 8x version
C------------------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL NEWDAF,ERROR,SEQ
C
C  NBO COMMON BLOCKS:
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION CORE(MEMORY),NBOOPT(10)
C
C  IF NBOOPT(1).EQ.-2, THEN NO NBO ANALYSIS WAS REQUESTED:
C
      IF(NBOOPT(1).EQ.-2) RETURN
C
C  SET DEFAULT OPTIONS:
C
      CALL NBOSET(NBOOPT)
C
C  IF THIS IS THE GENERAL VERSION OF THE PROGRAM, READ THE $GENNBO KEYLIST:
C
      IF(NBOOPT(10).EQ.0) THEN
        CALL GENINP(NEWDAF)
      ELSE
        NEWDAF = .TRUE.
      END IF
C
C  SEARCH THE INPUT FILE FOR THE $NBO KEYLIST:
C
      CALL NBOINP(NBOOPT,IDONE)
      IF(IDONE.EQ.1) RETURN
C
C  READ IN JOB OPTIONS FROM THE $NBO KEYLIST:
C
      CALL JOBOPT(NBOOPT)
C
C  CHECK FILENAME AND OPEN SEQUENTIAL FILES:
C
      CALL NBFILE(NEWDAF,ERROR)
      IF(ERROR) RETURN
C
C  OPEN THE NBO DIRECT ACCESS FILE:
C
      CALL NBOPEN(NEWDAF,ERROR)
      IF(ERROR) THEN
        WRITE(LFNPR,900)
        RETURN
      END IF
C
C  FETCH ATOMS, BASIS, AND WAVE FUNCTION INFORMATION:
C
      CALL FEAOIN(CORE,CORE,NBOOPT)
      IF(COMPLX) RETURN
C
C  WRITE THE JOB TITLE TO THE OUTPUT FILE:
C
      CALL FETITL(CORE)
      WRITE(LFNPR,910) (CORE(I),I=1,8)
C
C  SET UP DIMENSIONING INFORMATION AND DETERMINE IF ENOUGH SPACE IS AVAILABLE:
C
      CALL NBODIM(MEMORY)
C
C  SET UP BASIC STORAGE:
C
C  CORE(NDM) :  NDIM BY NDIM MATRIX TO STORE DENSITY MATRIX
C  CORE(NT)  :  NDIM BY NDIM MATRIX TO HOLD OVERLAP OR TRANSFORMATION MATRICES
C  CORE(NSCR):  SCRATCH STORAGE, DYNAMICALLY ALLOCATED ACCORDING NEEDS
C
      N2   = NDIM*NDIM
      NDM  = 1
      NT   = NDM + N2
      NSCR = NT  + N2
      MEM  = MEMORY - NSCR + 1
C
C  READ IN INPUT OVERLAP AND DENSITY MATRICES, AO BASIS:
C
      ALPHA = .FALSE.
      BETA  = .FALSE.
      ISPIN = 0
      CALL FEDRAW(CORE(NDM),CORE(NSCR))
C
C  SIMULATE THE NATURAL POPULATION ANALYSIS IF THE INPUT BASIS IS ORTHOGONAL:
C
      IF(ORTHO) THEN
        CALL NAOSIM(CORE(NDM),CORE(NT),CORE(NSCR))
C
C  LOAD THE OVERLAP MATRIX INTO CORE(NT) AND PERFORM THE NATURAL POPULATION
C  ANALYSIS:
C
      ELSE
        CALL FESRAW(CORE(NT))
        CALL NAODRV(CORE(NDM),CORE(NT),CORE(NSCR))
      END IF
C
C  NOTE: CORE(NDM) NOW CONTAINS THE TOTAL DENSITY MATRIX IN THE NAO BASIS
C        AND CORE(NT) CONTAINS THE AO TO NAO TRANSFORMATION
C
C  PERFORM CLOSED SHELL NBO ANALYSIS:
C
      IF(.NOT.OPEN) THEN
        CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM)
      ELSE
C
C  PERFORM OPEN SHELL NBO ANALYSIS:
C
C  FIRST, ANALYZE ALPHA DENSITY MATRIX:
C
        ALPHA = .TRUE.
        BETA  = .FALSE.
        ISPIN = 2
        IF(ORTHO) THEN
          CALL DMSIM(CORE(NDM),CORE(NT),CORE(NSCR))
        ELSE
          CALL DMNAO(CORE(NDM),CORE(NT),CORE(NSCR))
        END IF
        CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM)
C
C  NOW, ANALYZE BETA DENSITY MATRIX:
C
        ALPHA = .FALSE.
        BETA  = .TRUE.
        ISPIN = -2
        IF(ORTHO) THEN
          CALL DMSIM(CORE(NDM),CORE(NT),CORE(NSCR))
        ELSE
          CALL DMNAO(CORE(NDM),CORE(NT),CORE(NSCR))
        END IF
        CALL NBODRV(CORE(NDM),CORE(NT),CORE(NSCR),MEM)
      END IF
C
C  CLOSE THE NBO DIRECT ACCESS FILE AND OTHER EXTERNAL FILES:
C
      SEQ = .TRUE.
      CALL NBCLOS(SEQ)
      RETURN
C
  900 FORMAT(/1X,'NBO direct access file could not be opened.  NBO ',
     + 'program aborted.')
  910 FORMAT(/1X,'Job title: ',8A8)
      END
C*****************************************************************************
C
C  JOB INITIALIZATION ROUTINES: (CALLED BY SR NBO)
C
C      SUBROUTINE NBOSET(NBOOPT)
C      SUBROUTINE JOBOPT(NBOOPT)
C      SUBROUTINE NBODIM(MEMORY)
C
C*****************************************************************************
      SUBROUTINE NBOSET(NBOOPT)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION NBOOPT(10)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      PARAMETER(MAXFIL = 40)
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBLBL/NLEW,NVAL,LBL(10,MAXBAS,4)
      COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
      CHARACTER*80 FILENM
C
      DATA TENTH,HALF/0.1D0,0.5D0/
C
C  SET DEFAULT JOB OPTIONS:  (MODIFICATIONS TO THESE DEFAULTS
C  SHOULD NOT BE MADE HERE BUT LATER IN THIS SUBROUTINE)
C
C  USE THE BOND-ORDER MATRIX, NOT THE OCCUPATION MATRIX (EXPECTATION
C  VALUES OF THE DENSITY OPERATOR)
C
      IWDM   =  1
      IW3C   =  0
      IWAPOL =  0
      IWHYBS =  0
      IWPNAO =  0
      IWTNAO =  0
      IWTNAB =  0
      IWTNBO =  0
C
C  USE THE FOCK MATRIX, IF THERE IS ONE:
C
      IWFOCK =  1
C
C  SET TO THE DESIRED PRINT LEVEL + 10:
C
      IPRINT = 12
      IPSEUD =  0
      IWDETL =  0
      IWMULP =  0
      ICHOOS =  0
      KOPT   =  0
      JCORE  =  0
      IWCUBF = 0
      OPEN   = .FALSE.
      ORTHO  = .FALSE.
      UHF    = .FALSE.
      AUHF   = .FALSE.
      ROHF   = .FALSE.
      CI     = .FALSE.
      MCSCF  = .FALSE.
      COMPLX = .FALSE.
      DO 10 I = 1,60
        JPRINT(I) = 0
   10 CONTINUE
C
      LFNAO  =  31
      LFNPNA =  32
      LFNNAO =  33
      LFNPNH =  34
      LFNNHO =  35
      LFNPNB =  36
      LFNNBO =  37
      LFNPNL =  38
      LFNNLM =  39
      LFNMO  =  40
      LFNDM  =  41
      LFNNAB =  42
      LFNPPA =  43
      LFNARC =  47
C
C  SET POSITIVE IN ROUTINE JOBOPT IF CHOSEN BY THE USER:
C
      LFNDAF = -48
      LFNDEF =  49
C
C  SETTING NVAL NEGATIVE INDICATES THAT THIS VARIABLE HAS NOT
C  BEEN DETERMINED YET:
C
      NVAL   = -1
C
C  INITIALIZE THE CHARACTER STRING USED TO CREATE FILENAMES:
C
      FILENM(1:4) = 'FILE'
      DO 50 I = 5,80
        FILENM(I:I) = CHAR(32)
   50 CONTINUE
C
C  THAT SOME THRESHOLDS ARE .LT.0 INDICATES THAT THESE VARIABLES HAVE NOT
C  BEEN SET BY THE USER:
C
      THRSET =  -1.9D0
      PRJSET =  -0.2D0
      ACCTHR =  -TENTH
      CRTSET =   1.999
      E2THR  =  -HALF
      ATHR   =  -1.000
      PTHR   = -25.000
      ETHR   =  -0.100
      DTHR   =  -0.020
      DLTHR  =  -1.000
      CHSTHR =  -0.100
C
C  SET JOB OPTIONS ACCORDING TO NBOOPT:
C
C  SKIP THE COMPUTATION OF THE NBOS?
C
      IF(NBOOPT(1).EQ.-1) JPRINT(1) = 1
C
C  TURN OFF $CHOOSE AND $CORE KEYLISTS IF $NBO KEYLIST IS NOT TO
C  BE READ:
C
      IF(NBOOPT(1).EQ.1) ICHOOS = -1
      IF(NBOOPT(1).EQ.1) JCORE  = -1
C
C  FORCE DIPOLE ANALYSIS?
C
      IF(NBOOPT(3).NE.0) THEN
        JPRINT(46) = 1
      END IF
C
C  FORCE RESONANCE KEYWORD?
C
      IF(NBOOPT(4).NE.0) JPRINT(14) = 1
C
C  PROGRAM VERSION:
C
      JPRINT(2) = NBOOPT(10)
C
      RETURN
      END
C******************************************************************************
      SUBROUTINE JOBOPT(NBOOPT)
C******************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ERROR,END,EQUAL,NEXTWD,READ
      DIMENSION NBOOPT(10),INTTMP(80)
C
      PARAMETER(KEYLEN = 9)
      PARAMETER(MAXFIL = 40)
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
      CHARACTER*80 FILENM
C
      DIMENSION KEYWD(KEYLEN),K3CBND(6),KEPERT(6),KLFNPR(5),KTHRSH(6),
     * KDETL(6),KMULA(5),KMULOR(6),KPRJTH(6),KNBNLM(7),
     * KAOPRE(6),KNLMO(4),KNAOMO(5),KNBOMO(5),KNOBND(6),KNPA(3),
     * KSKIPB(6),KRPNAO(5),KBNDID(6),KNLMMO(6),KRESON(5),KPPNAO(7),
     * KAONAO(5),KNANBO(6),KAONBO(5),KAONLM(6),KFNBO(4),KFNLMO(5),
     * KDMNBO(5),KDMNLM(6),KPRINT(5),KNANLM(7),KSPNAO(5),KSPNHO(5),
     * KSPNBO(5),KAOINF(6),KAOPNB(6),KAOMO(4),KNAONH(6),KNHNLM(7),
     * KAONHO(5),KFNHO(4),KAOPNH(6),KFNAO(4),KNHONB(6),KSPNLM(6),
     * KNRT(3),KDMNHO(5),KDMNAO(5),KPLOT(4),KAOPNL(7),KDIAO(4),
     * KBEND(4),KNHOMO(5),KSAO(3),KFAO(3),KDMAO(4),KBOAO(4),KDINLM(6),
     * KNBOSM(6),KNBO(3),KDIPOL(6),KDINAO(5),KDINHO(5),KDINBO(5),
     * KNBDAF(6),KARCHV(7),KFILE(4),KPOLAR(6),KNRTOP(6),KNRTRF(6),
     * KCHSTH(6),KNRTDT(6),KNRTTH(6)
C
      DIMENSION KALT(4),KBFGS(4),KPOWEL(6),KSAP(3)
C
      DATA K3CBND/1H3,1HC,1HB,1HO,1HN,1HD/,KLFNPR/1HL,1HF,1HN,1HP,1HR/,
     * KTHRSH/1HT,1HH,1HR,1HE,1HS,1HH/,KEPERT/1HE,1H2,1HP,1HE,1HR,1HT/,
     * KPLOT/1HP,1HL,1HO,1HT/,KDETL/1HD,1HE,1HT,1HA,1HI,1HL/,
     * KMULA/1HM,1HU,1HL,1HA,1HT/,KMULOR/1HM,1HU,1HL,1HO,1HR,1HB/,
     * KPRJTH/1HP,1HR,1HJ,1HT,1HH,1HR/,KAOPRE/1HA,1HO,1HP,1HN,1HA,1HO/,
     * KNLMO/1HN,1HL,1HM,1HO/,KNPA/1HN,1HP,1HA/,KNBO/1HN,1HB,1HO/,
     * KNAOMO/1HN,1HA,1HO,1HM,1HO/,KNBOMO/1HN,1HB,1HO,1HM,1HO/,
     * KNOBND/1HN,1HO,1HB,1HO,1HN,1HD/,KSKIPB/1HS,1HK,1HI,1HP,1HB,1HO/,
     * KRPNAO/1HR,1HP,1HN,1HA,1HO/,KBNDID/1HB,1HN,1HD,1HI,1HD,1HX/,
     * KNLMMO/1HN,1HL,1HM,1HO,1HM,1HO/,KRESON/1HR,1HE,1HS,1HO,1HN/,
     * KPPNAO/1HP,1HA,1HO,1HP,1HN,1HA,1HO/,KAONAO/1HA,1HO,1HN,1HA,1HO/,
     * KNANBO/1HN,1HA,1HO,1HN,1HB,1HO/,KAONBO/1HA,1HO,1HN,1HB,1HO/
C
      DATA KAONLM/1HA,1HO,1HN,1HL,1HM,1HO/,KFNBO/1HF,1HN,1HB,1HO/,
     * KFNLMO/1HF,1HN,1HL,1HM,1HO/,KPRINT/1HP,1HR,1HI,1HN,1HT/,
     * KDMNBO/1HD,1HM,1HN,1HB,1HO/,KDMNLM/1HD,1HM,1HN,1HL,1HM,1HO/,
     * KNANLM/1HN,1HA,1HO,1HN,1HL,1HM,1HO/,KAOMO/1HA,1HO,1HM,1HO/,
     * KSPNAO/1HS,1HP,1HN,1HA,1HO/,KSPNHO/1HS,1HP,1HN,1HH,1HO/,
     * KSPNBO/1HS,1HP,1HN,1HB,1HO/,KFNAO/1HF,1HN,1HA,1HO/,
     * KAOINF/1HA,1HO,1HI,1HN,1HF,1HO/,KAOPNB/1HA,1HO,1HP,1HN,1HB,1HO/,
     * KAONHO/1HA,1HO,1HN,1HH,1HO/,KFNHO/1HF,1HN,1HH,1HO/,
     * KAOPNH/1HA,1HO,1HP,1HN,1HH,1HO/,KNRT/1HN,1HR,1HT/,
     * KNBNLM/1HN,1HB,1HO,1HN,1HL,1HM,1HO/,KDIAO/1HD,1HI,1HA,1HO/,
     * KDMNHO/1HD,1HM,1HN,1HH,1HO/,KDMNAO/1HD,1HM,1HN,1HA,1HO/,
     * KBEND/1HB,1HE,1HN,1HD/,KNBOSM/1HN,1HB,1HO,1HS,1HU,1HM/,
     * KNHOMO/1HN,1HH,1HO,1HM,1HO/,KSAO/1HS,1HA,1HO/,KFAO/1HF,1HA,1HO/
C
      DATA KDMAO/1HD,1HM,1HA,1HO/,KBOAO/1HB,1HO,1HA,1HO/,
     * KDIPOL/1HD,1HI,1HP,1HO,1HL,1HE/,KNAONH/1HN,1HA,1HO,1HN,1HH,1HO/,
     * KNHNLM/1HN,1HH,1HO,1HN,1HL,1HM,1HO/,KDINAO/1HD,1HI,1HN,1HA,1HO/,
     * KNHONB/1HN,1HH,1HO,1HN,1HB,1HO/,KSPNLM/1HS,1HP,1HN,1HL,1HM,1HO/,
     * KAOPNL/1HA,1HO,1HP,1HN,1HL,1HM,1HO/,KDINHO/1HD,1HI,1HN,1HH,1HO/,
     * KDINBO/1HD,1HI,1HN,1HB,1HO/,KDINLM/1HD,1HI,1HN,1HL,1HM,1HO/,
     * KNBDAF/1HN,1HB,1HO,1HD,1HA,1HF/,
     * KARCHV/1HA,1HR,1HC,1HH,1HI,1HV,1HE/,KFILE/1HF,1HI,1HL,1HE/,
     * KPOLAR/1HA,1HP,1HO,1HL,1HA,1HR/,KNRTOP/1HN,1HR,1HT,1HO,1HP,1HT/,
     * KNRTRF/1HN,1HR,1HT,1HR,1HE,1HF/,KCHSTH/1HC,1HH,1HS,1HT,1HH,1HR/,
     * KNRTDT/1HN,1HR,1HT,1HD,1HT,1HL/,
     * KNRTTH/1HN,1HR,1HT,1HT,1HH,1HR/
C
      DATA KALT/1H$,1HE,1HN,1HD/,KBFGS/1HB,1HF,1HG,1HS/,
     * KPOWEL/1HP,1HO,1HW,1HE,1HL,1HL/,KSAP/1HS,1HA,1HP/
C
      DATA ZERO,ONE/0.0D0,1.0D0/
      DATA IFULL,IVAL,ILEW/4HFULL,3HVAL,3HLEW/
      DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/
      DATA IA,IB,IP/1HA,1HB,1HP/
C
C  READ IN JOB OPTIONS, IN A KEYWORD DIRECTED MANNER:
C
      NUMOPT = 0
      LENNM  = 0
      IF(NBOOPT(1).EQ.1) GOTO 4500
C
C  BEGIN LOOP TO IDENTIFY KEYWORD "KEYWD":
C
      NEXTWD = .TRUE.
  100 LENG = KEYLEN
      IF(NEXTWD) CALL HFLD(KEYWD,LENG,END)
      NEXTWD = .TRUE.
      IF((LENG.EQ.0).OR.END) GO TO 4500
      IF(EQUAL(KEYWD,KALT,4)) GO TO 4500
      NUMOPT = NUMOPT + 1
C
C  KEYWORD: 3CBOND -- SEARCH FOR THREE-CENTER BONDS
C   (DEFAULT IS TO SEARCH ONLY FOR ONE- AND TWO-CENTER NBOS)
      IF(.NOT.EQUAL(KEYWD,K3CBND,6)) GO TO 500
        IW3C = 1
        GO TO 100
C  KEYWORD: LFNPR -- SPECIFY OUTPUT LFN
  500 IF(.NOT.EQUAL(KEYWD,KLFNPR,5)) GO TO 510
      CALL IFLD(LFNPR,ERROR)
        IF(ERROR) CALL HALT('LFNPR')
        GO TO 100
C  KEYWORD: THRESH -- SPECIFY FIXED OCCUPANCY THRESHOLD FOR NBO SEARCH
  510 IF(.NOT.EQUAL(KEYWD,KTHRSH,6)) GO TO 540
      CALL RFLD(THRSET,ERROR)
        IF(ERROR) CALL HALT('THRESH')
        GO TO 100
C  KEYWORD: DETAIL -- PRINT DETAILS OF NBO SEARCH PROCEDURE
  540 IF(.NOT.EQUAL(KEYWD,KDETL,6))  GO TO 550
        IWDETL = 1
        GO TO 100
C  KEYWORD: MULAT -- PRINT MULLIKEN POPULATIONS BY ATOM
  550 IF(.NOT.EQUAL(KEYWD,KMULA,5))  GO TO 560
        IWMULP = 1
        GO TO 100
C  KEYWORD: MULORB -- PRINT MULLIKEN POPULATIONS BY ORBITAL AND ATOM
  560 IF(.NOT.EQUAL(KEYWD,KMULOR,6)) GO TO 580
        IWMULP = 2
        GO TO 100
C  KEYWORD: PRJTHR -- USER SETS VALUE OF PROJECTION THRESHOLD FOR NBO SEARCH
C           FOR REJECTING LINEARLY DEPENDENT HYBRIDS
  580 IF(.NOT.EQUAL(KEYWD,KPRJTH,6)) GO TO 610
      CALL RFLD(PRJSET,ERROR)
        IF(ERROR) CALL HALT('PRJTHR')
        GO TO 100
C  KEYWORD: FNBO -- PRINT NBO FOCK MATRIX
  610 IF(.NOT.EQUAL(KEYWD,KFNBO,4)) GO TO 620
        JPRINT(37) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(37),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(37).EQ.IVAL) JPRINT(37) = IFULL
        END IF
        GO TO 100
C  KEYWORD: AOPNAO -- OUTPUT RAW AO TO PNAO TRANSFORMATION
  620 IF(.NOT.EQUAL(KEYWD,KAOPRE,6)) GO TO 640
        JPRINT(44) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(44),LFNPNA,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(44).EQ.IVAL) JPRINT(44) = IFULL
          IF(JPRINT(44).EQ.ILEW) JPRINT(44) = IFULL
        END IF
        GO TO 100
C  KEYWORD: NLMOMO -- COMPUTE AND PRINT NLMO TO MO TRANSF.
  640 IF(.NOT.EQUAL(KEYWD,KNLMMO,6)) GO TO 650
        JPRINT(13) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(13),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
        END IF
        GO TO 100
C  KEYWORD: NLMO -- COMPUTE AND PRINT NLMOS
  650 IF(.NOT.EQUAL(KEYWD,KNLMO,4))  GO TO 660
        IF(LENG.NE.4) GO TO 660
        JPRINT(8) = 1
        GO TO 100
C  KEYWORD: NAOMO -- COMPUTE AND PRINT NAO TO MO TRANSF.
  660 IF(.NOT.EQUAL(KEYWD,KNAOMO,5)) GO TO 670
        JPRINT(9) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(9),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
        END IF
        GO TO 100
C  KEYWORD: NBOMO -- COMPUTE AND PRINT NBO TO MO TRANSF.
  670 IF(.NOT.EQUAL(KEYWD,KNBOMO,5)) GO TO 680
        JPRINT(45) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(45),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
        END IF
        GO TO 100
C  KEYWORD: NOBOND -- COMPUTE ONLY ONE-CENTER NBOS
  680 IF(.NOT.EQUAL(KEYWD,KNOBND,6)) GO TO 690
        JPRINT(10) = 1
        GO TO 100
C  KEYWORD: SKIPBO -- SKIP NBO PROCEDURE
  690 IF(.NOT.EQUAL(KEYWD,KSKIPB,6)) GO TO 700
        JPRINT(1) = 1
        GO TO 100
C  KEYWORD: RPNAO -- COMPUTE REVISED PURE AO TO PNAO TRANSF.
  700 IF(.NOT.EQUAL(KEYWD,KRPNAO,5)) GO TO 710
        JPRINT(11) = 1
        GO TO 100
C  KEYWORD: BNDIDX -- PRINT BOND INDICES
  710 IF(.NOT.EQUAL(KEYWD,KBNDID,6)) GO TO 730
        JPRINT(12) = 1
        GO TO 100
C  KEYWORD: RESONANCE -- ALLOW STRONGLY "NON-LEWIS" NBO OCCUPANCIES
C   (OVERRIDES AUTOMATIC SHUTDOWN OF NBO PROCEDURE IN STRONGLY 
C    DELOCALIZED CASES)
  730 IF(.NOT.EQUAL(KEYWD,KRESON,5)) GO TO 740
        JPRINT(14) = 1
        GO TO 100
C  KEYWORD: PAOPNAO -- I/O WITH PAO TO PNAO TRANSFORMATION
  740 IF(.NOT.EQUAL(KEYWD,KPPNAO,7)) GO TO 750
        IWPNAO = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .TRUE.
          CALL KEYPAR(KEYWD,LENG,IWPNAO,LFNPPA,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(IWPNAO.EQ.IVAL) IWPNAO = IFULL
          IF(IWPNAO.EQ.ILEW) IWPNAO = IFULL
        END IF
        GO TO 100
C  KEYWORD: AONAO -- I/O WITH AO TO NAO TRANSFORMATION
  750 IF(.NOT.EQUAL(KEYWD,KAONAO,5)) GO TO 760
        IWTNAO = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .TRUE.
          CALL KEYPAR(KEYWD,LENG,IWTNAO,LFNNAO,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(IWTNAO.EQ.IVAL) IWTNAO = IFULL
          IF(IWTNAO.EQ.ILEW) IWTNAO = IFULL
        END IF
        GO TO 100
C  KEYWORD: NAONBO -- I/O WITH NAO TO NBO TRANSFORMATION
  760 IF(.NOT.EQUAL(KEYWD,KNANBO,6)) GO TO 770
        IWTNAB = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .TRUE.
          CALL KEYPAR(KEYWD,LENG,IWTNAB,LFNNAB,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(IWTNAB.EQ.IVAL) IWTNAB = IFULL
        END IF
        GO TO 100
C  KEYWORD: AONBO -- OUTPUT AO TO NBO TRANSF. INFORMATION
  770 IF(.NOT.EQUAL(KEYWD,KAONBO,5)) GO TO 780
        IWTNBO = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,IWTNBO,LFNNBO,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(IWTNBO.EQ.IVAL) IWTNBO = IFULL
        END IF
        GO TO 100
C  KEYWORD: FNLMO -- PRINT NLMO FOCK MATRIX
  780 IF(.NOT.EQUAL(KEYWD,KFNLMO,5)) GO TO 790
        JPRINT(15) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(15),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(15).EQ.IVAL) JPRINT(15) = IFULL
        END IF
        GO TO 100
C  KEYWORD: DMNBO -- PRINT NBO DENSITY MATRIX
  790 IF(.NOT.EQUAL(KEYWD,KDMNBO,5)) GO TO 800
        JPRINT(16) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(16),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(16).EQ.IVAL) JPRINT(16) = IFULL
        END IF
        GO TO 100
C  KEYWORD: DMNLMO -- PRINT NLMO DENSITY MATRIX
  800 IF(.NOT.EQUAL(KEYWD,KDMNLM,6)) GO TO 810
        JPRINT(17) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(17),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(17).EQ.IVAL) JPRINT(17) = IFULL
        END IF
        GO TO 100
C  KEYWORD: AONLMO -- COMPUTE AND OUTPUT AO TO NLMO TRANSF.
  810 IF(.NOT.EQUAL(KEYWD,KAONLM,6)) GO TO 820
        JPRINT(23) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(23),LFNNLM,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(23).EQ.IVAL) JPRINT(23) = IFULL
        END IF
        GO TO 100
C  KEYWORD: PRINT -- READ IN PRINT OPTION LEVEL "IPRINT"
  820 IF(.NOT.EQUAL(KEYWD,KPRINT,5)) GO TO 830
        CALL IFLD(IPRINT,ERROR)
        IF(ERROR) CALL HALT('PRINT')
        GO TO 100
C  KEYWORD: NAONLMO -- PRINT NAO TO NLMO TRANSFORMATION MATRIX
  830 IF(.NOT.EQUAL(KEYWD,KNANLM,7)) GO TO 840
        JPRINT(18) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(18),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(18).EQ.IVAL) JPRINT(18) = IFULL
        END IF
        GO TO 100
C  KEYWORD: SPNAO -- PRINT S-PNAO OVERLAP MATRIX
  840 IF(.NOT.EQUAL(KEYWD,KSPNAO,5)) GO TO 850
        JPRINT(19) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(19),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(19).EQ.IVAL) JPRINT(19) = IFULL
          IF(JPRINT(19).EQ.ILEW) JPRINT(19) = IFULL
        END IF
        GO TO 100
C  KEYWORD: SPNHO -- PRINT S-PNHO OVERLAP MATRIX
  850 IF(.NOT.EQUAL(KEYWD,KSPNHO,5)) GO TO 860
        JPRINT(20) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(20),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(20).EQ.IVAL) JPRINT(20) = IFULL
          IF(JPRINT(20).EQ.ILEW) JPRINT(20) = IFULL
        END IF
        GO TO 100
C  KEYWORD: NHONLMO -- OUTPUT THE NHO TO NLMO TRANSFORMATION
  860 IF(.NOT.EQUAL(KEYWD,KNHNLM,7)) GO TO 870
        JPRINT(24) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(24),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(24).EQ.IVAL) JPRINT(24) = IFULL
        END IF
        GO TO 100
C  KEYWORD: SPNBO -- PRINT S-PNBO OVERLAP MATRIX
  870 IF(.NOT.EQUAL(KEYWD,KSPNBO,5)) GO TO 880
        JPRINT(21) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(21),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(21).EQ.IVAL) JPRINT(21) = IFULL
        END IF
        GO TO 100
C  KEYWORD: AOINFO -- WRITE BASIS SET INFO
  880 IF(.NOT.EQUAL(KEYWD,KAOINF,6)) GO TO 910
        JPRINT(22) = LFNAO
        CALL IFLD(ITEMP,ERROR)
        IF(.NOT.ERROR) JPRINT(22) = ABS(ITEMP)
        GO TO 100
C  KEYWORD: AOPNBO -- WRITE AO TO PNBO TRANSFORMATION
  910 IF(.NOT.EQUAL(KEYWD,KAOPNB,6)) GO TO 920
        JPRINT(25) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(25),LFNPNB,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(25).EQ.IVAL) JPRINT(25) = IFULL
        END IF
        GO TO 100
C  KEYWORD: AOMO -- WRITE AO TO MO TRANSFORMATION 
  920 IF(.NOT.EQUAL(KEYWD,KAOMO,4)) GO TO 930
        JPRINT(26) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(26),LFNMO,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
        END IF
        GO TO 100
C  KEYWORD: DMAO -- WRITE AO DENSITY MATRIX 
  930 IF(.NOT.EQUAL(KEYWD,KDMAO,4)) GO TO 940
        JPRINT(27) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(27),LFNDM,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(27).EQ.IVAL) JPRINT(27) = IFULL
          IF(JPRINT(27).EQ.ILEW) JPRINT(27) = IFULL
        END IF
        GO TO 100
C  KEYWORD: AONHO -- WRITE AO TO NHO TRANSFORMATION 
  940 IF(.NOT.EQUAL(KEYWD,KAONHO,5)) GO TO 950
        JPRINT(28) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(28),LFNNHO,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(28).EQ.IVAL) JPRINT(28) = IFULL
          IF(JPRINT(28).EQ.ILEW) JPRINT(28) = IFULL
        END IF
        GO TO 100
C  KEYWORD: FNHO -- PRINT NHO FOCK MATRIX
  950 IF(.NOT.EQUAL(KEYWD,KFNHO,4)) GO TO 960
        JPRINT(29) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(29),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(29).EQ.IVAL) JPRINT(29) = IFULL
          IF(JPRINT(29).EQ.ILEW) JPRINT(29) = IFULL
        END IF
        GO TO 100
C  KEYWORD: AOPNHO -- WRITE AO TO PNHO TRANSFORMATION 
  960 IF(.NOT.EQUAL(KEYWD,KAOPNH,6)) GO TO 970
        JPRINT(30) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(30),LFNPNH,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(30).EQ.IVAL) JPRINT(30) = IFULL
          IF(JPRINT(30).EQ.ILEW) JPRINT(30) = IFULL
        END IF
        GO TO 100
C  KEYWORD: FNAO -- PRINT NAO FOCK MATRIX
  970 IF(.NOT.EQUAL(KEYWD,KFNAO,4)) GO TO 990
        JPRINT(31) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(31),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(31).EQ.IVAL) JPRINT(31) = IFULL
          IF(JPRINT(31).EQ.ILEW) JPRINT(31) = IFULL
        END IF
        GO TO 100
C  KEYWORD: NAONHO -- OUTPUT THE NAO TO NHO TRANSFORMATION
  990 IF(.NOT.EQUAL(KEYWD,KNAONH,6)) GO TO 1010
        JPRINT(33) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(33),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(33).EQ.IVAL) JPRINT(33) = IFULL
          IF(JPRINT(33).EQ.ILEW) JPRINT(33) = IFULL
        END IF
        GO TO 100
C  KEYWORD: DMNHO -- PRINT NHO DENSITY MATRIX
 1010 IF(.NOT.EQUAL(KEYWD,KDMNHO,5)) GO TO 1020
        JPRINT(34) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(34),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(34).EQ.IVAL) JPRINT(34) = IFULL
          IF(JPRINT(34).EQ.ILEW) JPRINT(34) = IFULL
        END IF
        GO TO 100
C  KEYWORD: DMNAO -- PRINT NAO DENSITY MATRIX
 1020 IF(.NOT.EQUAL(KEYWD,KDMNAO,5)) GO TO 1040
        JPRINT(35) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(35),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(35).EQ.IVAL) JPRINT(35) = IFULL
          IF(JPRINT(35).EQ.ILEW) JPRINT(35) = IFULL
        END IF
        GO TO 100
C  KEYWORD: BEND -- PRINT NHO DIRECTIONALITY AND BOND BENDING INFO
 1040 IF(.NOT.EQUAL(KEYWD,KBEND,4)) GO TO 1050
        JPRINT(36) = 1
        CALL RFLD(TEMP,ERROR)
        IF(ERROR) GO TO 100
        ATHR = ABS(TEMP)
        CALL RFLD(TEMP,ERROR)
        IF(ERROR) GO TO 100
        PTHR = ABS(TEMP)
        IF(PTHR.LT.ONE) PTHR = ONE
        CALL RFLD(TEMP,ERROR)
        IF(ERROR) GO TO 100
        ETHR = ABS(TEMP)
        GO TO 100
C  KEYWORD: NHOMO -- COMPUTE AND PRINT NHO TO MO TRANSF.
 1050 IF(.NOT.EQUAL(KEYWD,KNHOMO,5)) GO TO 1060
        JPRINT(38) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(38),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
        END IF
        GO TO 100
C  KEYWORD: SAO -- PRINT AO OVERLAP MATRIX
 1060 IF(.NOT.EQUAL(KEYWD,KSAO,3)) GO TO 1070
        JPRINT(39) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(39),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(39).EQ.IVAL) JPRINT(39) = IFULL
          IF(JPRINT(39).EQ.ILEW) JPRINT(39) = IFULL
        END IF
        GO TO 100
C  KEYWORD: FAO -- PRINT AO FOCK MATRIX
 1070 IF(.NOT.EQUAL(KEYWD,KFAO,3)) GO TO 1080
        JPRINT(40) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(40),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(40).EQ.IVAL) JPRINT(40) = IFULL
          IF(JPRINT(40).EQ.ILEW) JPRINT(40) = IFULL
        END IF
        GO TO 100
C  KEYWORD: NHONBO -- OUTPUT NHO TO NBO TRANSFORMATION
 1080 IF(.NOT.EQUAL(KEYWD,KNHONB,6)) GO TO 1090
        JPRINT(41) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(41),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(41).EQ.IVAL) JPRINT(41) = IFULL
        END IF
        GO TO 100
C  KEYWORD: BOAO -- PRINT AO BOND-ORDER MATRIX
 1090 IF(.NOT.EQUAL(KEYWD,KBOAO,4)) GO TO 1100
        JPRINT(42) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(42),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(42).EQ.IVAL) JPRINT(42) = IFULL
          IF(JPRINT(42).EQ.ILEW) JPRINT(42) = IFULL
        END IF
        GO TO 100
C  KEYWORD: E2PERT -- 2ND-ORDER PERTURBATIVE ANALYSIS OF THE NBO FOCK MATRIX
 1100 IF(.NOT.EQUAL(KEYWD,KEPERT,6)) GO TO 1110
        JPRINT(3) = 1
        CALL RFLD(TEMP,ERROR)
        IF(ERROR) GO TO 100
        E2THR = ABS(TEMP)
        GO TO 100
C  KEYWORD: PLOT -- WRITE AO BASIS, DENSITY, AND TRANSFORMS FOR PLOTTING
 1110 IF(.NOT.EQUAL(KEYWD,KPLOT,4)) GO TO 1120
        JPRINT(43) = 1
        GO TO 100
C  KEYWORD: NPA -- PRINT THE NATURAL POPULATION ANALYSIS
 1120 IF(.NOT.EQUAL(KEYWD,KNPA,3)) GO TO 1130
        JPRINT(4) = 1
        GO TO 100
C  KEYWORD: NBOSUM -- PRINT THE NBO SUMMARY
 1130 IF(.NOT.EQUAL(KEYWD,KNBOSM,6)) GO TO 1140
        JPRINT(6) = 1
        GO TO 100
C  KEYWORD: NBO -- PRINT THE NBO ANALYSIS
 1140 IF(.NOT.EQUAL(KEYWD,KNBO,3)) GO TO 1150
        IF(LENG.NE.3) GO TO 1150
        JPRINT(5) = 1
        GO TO 100
C  KEYWORD: DIPOLE -- PRINT NBO/NLMO DIPOLE ANALYSIS:
 1150 IF(.NOT.EQUAL(KEYWD,KDIPOL,6)) GO TO 1160
        JPRINT(46) = 1
        CALL RFLD(TEMP,ERROR)
        IF(ERROR) GO TO 100
        DTHR = ABS(TEMP)
        GO TO 100
C  KEYWORD: NBONLMO -- PRINT NBO TO NLMO TRANSFORMATION MATRIX
 1160 IF(.NOT.EQUAL(KEYWD,KNBNLM,7)) GO TO 1170
        JPRINT(47) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(47),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(47).EQ.IVAL) JPRINT(47) = IFULL
        END IF
        GO TO 100
C  KEYWORD: SPNLMO -- OUTPUT THE PNLMO OVERLAP MATRIX
 1170 IF(.NOT.EQUAL(KEYWD,KSPNLM,6)) GO TO 1180
        JPRINT(48) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(48),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(48).EQ.IVAL) JPRINT(48) = IFULL
        END IF
        GO TO 100
C  KEYWORD: AOPNLMO -- OUTPUT THE AO-PNLMO TRANSFORMATION MATRIX
 1180 IF(.NOT.EQUAL(KEYWD,KAOPNL,7)) GO TO 1190
        JPRINT(49) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(49),LFNPNL,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(49).EQ.IVAL) JPRINT(49) = IFULL
        END IF
        GO TO 100
C  KEYWORD: DIAO -- OUTPUT THE AO DIPOLE INTEGRALS
 1190 IF(.NOT.EQUAL(KEYWD,KDIAO,4)) GO TO 1200
        JPRINT(50) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(50),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(50).EQ.IVAL) JPRINT(50) = IFULL
          IF(JPRINT(50).EQ.ILEW) JPRINT(50) = IFULL
        END IF
        GO TO 100
C  KEYWORD: DINAO -- OUTPUT THE NAO DIPOLE INTEGRALS
 1200 IF(.NOT.EQUAL(KEYWD,KDINAO,5)) GO TO 1210
        JPRINT(51) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(51),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(51).EQ.IVAL) JPRINT(51) = IFULL
          IF(JPRINT(51).EQ.ILEW) JPRINT(51) = IFULL
        END IF
        GO TO 100
C  KEYWORD: DINHO -- OUTPUT THE NHO DIPOLE INTEGRALS
 1210 IF(.NOT.EQUAL(KEYWD,KDINHO,5)) GO TO 1220
        JPRINT(52) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(52),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(52).EQ.IVAL) JPRINT(52) = IFULL
          IF(JPRINT(52).EQ.ILEW) JPRINT(52) = IFULL
        END IF
        GO TO 100
C  KEYWORD: DINBO -- OUTPUT THE NBO DIPOLE INTEGRALS
 1220 IF(.NOT.EQUAL(KEYWD,KDINBO,5)) GO TO 1230
        JPRINT(53) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(53),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(53).EQ.IVAL) JPRINT(53) = IFULL
        END IF
        GO TO 100
C  KEYWORD: DINLMO -- OUTPUT THE NLMO DIPOLE INTEGRALS
 1230 IF(.NOT.EQUAL(KEYWD,KDINLM,6)) GO TO 1240
        JPRINT(54) = IFULL
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          READ = .FALSE.
          CALL KEYPAR(KEYWD,LENG,JPRINT(54),LFNDEF,READ,ERROR)
          IF(ERROR) NEXTWD = .FALSE.
          IF(JPRINT(54).EQ.IVAL) JPRINT(54) = IFULL
        END IF
        GO TO 100
C  KEYWORD: NBODAF -- CHOOSE AN ALTERNATE DAF
 1240 IF(.NOT.EQUAL(KEYWD,KNBDAF,6)) GO TO 1250
        LFNDAF = ABS(LFNDAF)
        CALL IFLD(ITEMP,ERROR)
        IF(.NOT.ERROR) LFNDAF = ABS(ITEMP)
        GO TO 100
C  KEYWORD: ARCHIVE -- WRITE THE ARCHIVE FILE
 1250 IF(.NOT.EQUAL(KEYWD,KARCHV,7)) GO TO 1260
        JPRINT(7) = LFNARC
        CALL IFLD(ITEMP,ERROR)
        IF(.NOT.ERROR) JPRINT(7) = ABS(ITEMP)
        GO TO 100
C  KEYWORD: FILE -- SELECT ALTERNATE FILENAME
 1260 IF(.NOT.EQUAL(KEYWD,KFILE,4)) GO TO 1270
        LENG = 80
        CALL HFLD(INTTMP,LENG,END)
        IF(.NOT.END) LENNM = LENG
        GO TO 100
C  KEYWORD: APOLAR -- ENFORCE APOLAR BONDS:
 1270 IF(.NOT.EQUAL(KEYWD,KPOLAR,6)) GO TO 1290
        IWAPOL = 1
        GO TO 100
C  KEYWORD: NRTOPT -- OPTIMIZE NRT WEIGHTS:
 1290 IF(.NOT.EQUAL(KEYWD,KNRTOP,6)) GO TO 1300
        IF(JPRINT(14).EQ.0) JPRINT(14) = 1
        IF(JPRINT(32).EQ.0) JPRINT(32) = 1
        JPRINT(55) = IB
        LENG = KEYLEN
        CALL HFLD(KEYWD,LENG,END)
        IF(.NOT.END) THEN
          IF(EQUAL(KEYWD,KBFGS,4)) THEN
            JPRINT(55) = IB
          ELSE IF(EQUAL(KEYWD,KPOWEL,6)) THEN
            JPRINT(55) = IP
          ELSE IF(EQUAL(KEYWD,KSAP,3)) THEN
            JPRINT(55) = 1234567
            IF(LENG.GT.3) CALL CONVIN(KEYWD(4),LENG-3,JPRINT(55),ERROR)
            IF(ERROR) CALL HALT('NRTOPT')
            JPRINT(55) = ABS(JPRINT(55)) 
          ELSE IF(EQUAL(KEYWD,KSAP,2)) THEN
            JPRINT(55) = -1234567
            IF(LENG.GT.2) CALL CONVIN(KEYWD(3),LENG-2,JPRINT(55),ERROR)
            IF(ERROR) CALL HALT('NRTOPT')
            JPRINT(55) = -ABS(JPRINT(55)) 
          ELSE
            NEXTWD = .FALSE.
          END IF
        END IF
	GO TO 100
C  KEYWORD: NRTREF -- NUMBER OF REFERENCE STRUCTURES IN NRT ANALYSIS
 1300 IF(.NOT.EQUAL(KEYWD,KNRTRF,6)) GO TO 1310
        IF(JPRINT(14).EQ.0) JPRINT(14) = 1
        IF(JPRINT(32).EQ.0) JPRINT(32) = 1
        CALL IFLD(ITEMP,ERROR)
        IF(ERROR) GO TO 100
        JPRINT(56) = MAX(1,ABS(ITEMP))
        GO TO 100
C  KEYWORD: CHSTHR -- SET THE OCCUPANCY THRESHOLD IN CHOOSE
 1310 IF(.NOT.EQUAL(KEYWD,KCHSTH,6)) GO TO 1320
        CHSTHR = ABS(CHSTHR)
        CALL RFLD(TEMP,ERROR)
        IF(ERROR) GO TO 100
        CHSTHR = ABS(TEMP)
        GO TO 100
C  KEYWORD: NRTDTL -- DETAIL NRT ANALYSIS 
 1320 IF(.NOT.EQUAL(KEYWD,KNRTDT,6)) GO TO 1340
        IF(JPRINT(14).EQ.0) JPRINT(14) = 1
        IF(JPRINT(32).EQ.0) JPRINT(32) = 1
        JPRINT(57) = 1
	CALL IFLD(ITEMP,ERROR)
        IF(ERROR) GO TO 100
        JPRINT(57) = MAX(1,ABS(ITEMP))
        GO TO 100
C  KEYWORD: NRTTHR -- SET THRESHOLD FOR DELOCALIZATION LIST 
 1340 IF(.NOT.EQUAL(KEYWD,KNRTTH,6)) GO TO 1360
        IF(JPRINT(14).EQ.0) JPRINT(14) = 1
        IF(JPRINT(32).EQ.0) JPRINT(32) = 1
        DLTHR = ABS(DLTHR)
	CALL RFLD(TEMP,ERROR)
	IF(ERROR) GO TO 100
	DLTHR = ABS(TEMP)
        GO TO 100
C  KEYWORD: NRT -- PERFORM NATURAL RESONANCE THEORY ANALYSIS:
C  (NOTE THAT WE SHOULD CHECK THIS KEYWORD AFTER WE CHECK THE OTHER
C  `NRT' KEYWORDS, LIKE `NRTOPT'.  OTHERWISE, KEYWORD CONFLICTS CAN
C  OCCUR.)
 1360 IF(.NOT.EQUAL(KEYWD,KNRT,3)) GO TO 1370
        JPRINT(14) = 1
        JPRINT(32) = 1
        CALL IFLD(ITEMP,ERROR)
        IF(.NOT.ERROR) JPRINT(32) = ITEMP
        GO TO 100
 1370 GO TO 4800
C------------------------------------------------------------------------------
 4500 CONTINUE
C
C  IF OPTION `FILE' WAS SELECTED, EXTRACT THE FILENAME FROM HOLLERITH
C  ARRAY INTTMP:
C
      IF(LENNM.NE.0) THEN
        IDIV = IB - IA
        DO 4510 I = 1,LENNM
          FILENM(I:I) = CHAR(MOD((INTTMP(I)-IA)/IDIV,256) + 65)
 4510   CONTINUE
        DO 4520 I = LENNM+1,80
          FILENM(I:I) = CHAR(32)
 4520   CONTINUE
      END IF
C------------------------------------------------------------------------------
C
C  IF THE PRINT LEVEL IS SET TO ZERO AND NO OTHER OPTIONS WERE ENTERED,
C  COMPLETELY SHUT OFF PROGRAM PRINTING:
C
      IF(NUMOPT.EQ.1.AND.IPRINT.EQ.0) IPRINT = -1
C
C  CHECK FOR JOB OPTIONS THAT ARE CURRENTLY INCOMPATABLE:
C
      IF((IWDM.EQ.0).AND.(IWMULP.NE.0)) GO TO 4900
C
C  CHECK FOR JOB OPTIONS THAT ARE STRICTLY INCOMPATIBLE:
C
      IF(ORTHO) THEN
        IWTNAO     = 0
        JPRINT(9)  = 0
        JPRINT(11) = 0
        JPRINT(18) = 0
        JPRINT(19) = 0
        JPRINT(20) = 0
        JPRINT(21) = 0
        JPRINT(25) = 0
        JPRINT(30) = 0
        JPRINT(31) = 0
        JPRINT(33) = 0
        JPRINT(35) = 0
        JPRINT(39) = 0
        JPRINT(44) = 0
        JPRINT(48) = 0
        JPRINT(49) = 0
        JPRINT(51) = 0
      END IF
C------------------------------------------------------------------------------
C
C  START PRINTING NBO OUTPUT:
C
      IF(IPRINT.GE.0) THEN
        WRITE(LFNPR,6000)
        IF(NUMOPT.GT.0) WRITE(LFNPR,6010)
C------------------------------------------------------------------------------
 6000 FORMAT(/1X,79('*')/,13X,
     * 'N A T U R A L   A T O M I C   O R B I T A L   A N D'/,
     * 10X,'N A T U R A L   B O N D   O R B I T A L   ',
     *    'A N A L Y S I S',/1X,79('*'))
 6010 FORMAT(1X)
C------------------------------------------------------------------------------
C
C  JOB CONTROL KEYWORDS:
C
        IF(JPRINT(4).NE.0) WRITE(LFNPR,6020)
        IF(JPRINT(5).NE.0) WRITE(LFNPR,6030)
        IF(JPRINT(6).NE.0) WRITE(LFNPR,6040)
        IF(JPRINT(14).NE.0) WRITE(LFNPR,6050)
        IF(JPRINT(10).NE.0) WRITE(LFNPR,6060)
        IF(IW3C.NE.0) WRITE(LFNPR,6070)
        IF(JPRINT(1).NE.0) WRITE(LFNPR,6080)
        IF(JPRINT(8).NE.0) WRITE(LFNPR,6090)
        IF(JPRINT(32).NE.0) WRITE(LFNPR,6100)
        IF(JPRINT(55).EQ.IB) THEN
          WRITE(LFNPR,6110)
        ELSE IF(JPRINT(55).EQ.IP) THEN
          WRITE(LFNPR,6111)
        ELSE IF(JPRINT(55).LT.0) THEN
          WRITE(LFNPR,6112)
        ELSE IF(JPRINT(55).GT.0) THEN
          WRITE(LFNPR,6113)
        END IF
        IF(JPRINT(56).NE.0) WRITE(LFNPR,6120) JPRINT(56)
        IF(DLTHR.GE.ZERO) WRITE(LFNPR,6160) DLTHR 
        IF(JPRINT(57).NE.0) WRITE(LFNPR,6170) JPRINT(57)
C------------------------------------------------------------------------------
 6020 FORMAT(1X,'      /NPA    / : Print Natural Population Analysis')
 6030 FORMAT(1X,'      /NBO    / : Print Natural Bond Orbital Analysis')
 6040 FORMAT(1X,'      /NBOSUM / : Print summary of the NBO analysis')
 6050 FORMAT(1X,'      /RESON  / : Allow strongly delocalized NBO ',
     *  'set')
 6060 FORMAT(1X,'      /NOBOND / : No two-center NBO search')
 6070 FORMAT(1X,'      /3CBOND / : Search for 3-center bonds')
 6080 FORMAT(1X,'      /SKIPBO / : Skip NBO transformation step')
 6090 FORMAT(1X,'      /NLMO   / : Form Natural Localized Molecular',
     *  ' Orbitals')
 6100 FORMAT(1X,'      /NRT    / : Perform Natural Resonance Theory ',
     * 'Analysis')
 6110 FORMAT(1X,'      /NRTOPT / : Optimize resonance weights with ',
     * 'BFGS method')
 6111 FORMAT(1X,'      /NRTOPT / : Optimize resonance weights with ',
     * 'POWELL method')
 6112 FORMAT(1X,'      /NRTOPT / : Optimize resonance weights with ',
     * 'ANNEAL method')
 6113 FORMAT(1X,'      /NRTOPT / : Optimize resonance weights with ',
     * 'ANNEAL method + penalty')
 6120 FORMAT(1X,'      /NRTREF / : Number of reference structures set',
     * ' to',I3)
 6160 FORMAT(1X,'      /NRTTHR / : Set to ',F5.2)
 6170 FORMAT(1X,'      /NRTDTL / : Set to ',I2)
C------------------------------------------------------------------------------
C
C  JOB THRESHOLD KEYWORDS:
C
        IF(JPRINT(36).NE.0) WRITE(LFNPR,6500)
        IF(ATHR.GE.ZERO.OR.PTHR.GE.ZERO.OR.ETHR.GE.ZERO)
     +             WRITE(LFNPR,6510) ABS(ATHR),ABS(PTHR),ABS(ETHR)
        IF(JPRINT(3).NE.0) WRITE(LFNPR,6520)
        IF(E2THR.GT.ZERO) WRITE(LFNPR,6530) E2THR
        IF(JPRINT(46).NE.0) WRITE(LFNPR,6540)
        IF(DTHR.GE.ZERO) WRITE(LFNPR,6550) ABS(DTHR)
        IF(THRSET.GT.ZERO) WRITE(LFNPR,6560) THRSET
        IF(PRJSET.GT.ZERO) WRITE(LFNPR,6570) PRJSET
        IF(CHSTHR.GT.ZERO) WRITE(LFNPR,6580) CHSTHR
C------------------------------------------------------------------------------
 6500 FORMAT(1X,'      /BEND   / : Print NHO directionality table')
 6510 FORMAT(1X,'                  Print thresholds set to (',F4.1,
     *   ',',F5.1,',',F5.2,')')
 6520 FORMAT(1X,'      /E2PERT / : Analyze NBO Fock matrix')
 6530 FORMAT(1X,'                  Print threshold set to ',F5.2)
 6540 FORMAT(1X,'      /DIPOLE / : Print NBO/NLMO dipole moment ',
     *   'analysis')
 6550 FORMAT(1X,'                  Print threshold set to ',F5.2)
 6560 FORMAT(1X,'      /THRESH / : Set to ',F5.2)
 6570 FORMAT(1X,'      /PRJTHR / : Set to ',F5.2)
 6580 FORMAT(1X,'      /CHSTHR / : Set to ',F5.2)
C------------------------------------------------------------------------------
C
C  MATRIX OUTPUT KEYWORDS:
C
        IF(JPRINT(44).EQ.IFULL) THEN
          WRITE(LFNPR,7000)
        ELSE IF(IOINQR(JPRINT(44)).EQ.IPRNT) THEN
          WRITE(LFNPR,7002) JPRINT(44)
        ELSE IF(IOINQR(JPRINT(44)).EQ.IWRIT) THEN
          WRITE(LFNPR,7004) ABS(JPRINT(44))
        END IF
        IF(IWTNAO.EQ.IFULL) THEN
          WRITE(LFNPR,7010)
        ELSE IF(IOINQR(IWTNAO).EQ.IPRNT) THEN
          WRITE(LFNPR,7012) IWTNAO
        ELSE IF(IOINQR(IWTNAO).EQ.IWRIT) THEN
          WRITE(LFNPR,7014) ABS(IWTNAO)
        ELSE IF(IOINQR(IWTNAO).EQ.IREAD) THEN
          WRITE(LFNPR,7016) ABS(IWTNAO/1000)
        END IF
        IF(JPRINT(30).EQ.IFULL) THEN
          WRITE(LFNPR,7020)
        ELSE IF(IOINQR(JPRINT(30)).EQ.IPRNT) THEN
          WRITE(LFNPR,7022) JPRINT(30)
        ELSE IF(IOINQR(JPRINT(30)).EQ.IWRIT) THEN
          WRITE(LFNPR,7024) ABS(JPRINT(30))
        END IF
        IF(JPRINT(28).EQ.IFULL) THEN
          WRITE(LFNPR,7030)
        ELSE IF(IOINQR(JPRINT(28)).EQ.IPRNT) THEN
          WRITE(LFNPR,7032) JPRINT(28)
        ELSE IF(IOINQR(JPRINT(28)).EQ.IWRIT) THEN
          WRITE(LFNPR,7034) ABS(JPRINT(28))
        END IF
        IF(JPRINT(25).EQ.IFULL) THEN
          WRITE(LFNPR,7040)
        ELSE IF(JPRINT(25).EQ.ILEW) THEN
          WRITE(LFNPR,7042)
        ELSE IF(IOINQR(JPRINT(25)).EQ.IPRNT) THEN
          WRITE(LFNPR,7044) JPRINT(25)
        ELSE IF(IOINQR(JPRINT(25)).EQ.IWRIT) THEN
          WRITE(LFNPR,7046) ABS(JPRINT(25))
        END IF
        IF(IWTNBO.EQ.IFULL) THEN
          WRITE(LFNPR,7050)
        ELSE IF(IWTNBO.EQ.ILEW) THEN
          WRITE(LFNPR,7052)
        ELSE IF(IOINQR(IWTNBO).EQ.IPRNT) THEN
          WRITE(LFNPR,7054) IWTNBO
        ELSE IF(IOINQR(IWTNBO).EQ.IWRIT) THEN
          WRITE(LFNPR,7056) ABS(IWTNBO)
        END IF
        IF(JPRINT(49).EQ.IFULL) THEN
          WRITE(LFNPR,7060)
        ELSE IF(JPRINT(49).EQ.ILEW) THEN
          WRITE(LFNPR,7062)
        ELSE IF(IOINQR(JPRINT(49)).EQ.IPRNT) THEN
          WRITE(LFNPR,7064) JPRINT(49)
        ELSE IF(IOINQR(JPRINT(49)).EQ.IWRIT) THEN
          WRITE(LFNPR,7066) ABS(JPRINT(49))
        END IF
        IF(JPRINT(23).EQ.IFULL) THEN
          WRITE(LFNPR,7070)
        ELSE IF(JPRINT(23).EQ.ILEW) THEN
          WRITE(LFNPR,7072)
        ELSE IF(IOINQR(JPRINT(23)).EQ.IPRNT) THEN
          WRITE(LFNPR,7074) JPRINT(23)
        ELSE IF(IOINQR(JPRINT(23)).EQ.IWRIT) THEN
          WRITE(LFNPR,7076) ABS(JPRINT(23))
        END IF
        IF(JPRINT(26).EQ.IFULL) THEN
          WRITE(LFNPR,7080)
        ELSE IF(JPRINT(26).EQ.IVAL) THEN
          WRITE(LFNPR,7082)
        ELSE IF(JPRINT(26).EQ.ILEW) THEN
          WRITE(LFNPR,7084)
        ELSE IF(IOINQR(JPRINT(26)).EQ.IPRNT) THEN
          WRITE(LFNPR,7086) JPRINT(26)
        ELSE IF(IOINQR(JPRINT(26)).EQ.IWRIT) THEN
          WRITE(LFNPR,7088) ABS(JPRINT(26))
        END IF
        IF(IWPNAO.EQ.IFULL) THEN
          WRITE(LFNPR,7090)
        ELSE IF(IOINQR(IWPNAO).EQ.IPRNT) THEN
          WRITE(LFNPR,7092) IWPNAO
        ELSE IF(IOINQR(IWPNAO).EQ.IWRIT) THEN
          WRITE(LFNPR,7094) ABS(IWPNAO)
        ELSE IF(IOINQR(IWPNAO).EQ.IREAD) THEN
          WRITE(LFNPR,7096) ABS(IWPNAO/1000)
        END IF
        IF(JPRINT(33).EQ.IFULL) THEN
          WRITE(LFNPR,7100)
        ELSE IF(IOINQR(JPRINT(33)).EQ.IPRNT) THEN
          WRITE(LFNPR,7102) JPRINT(33)
        ELSE IF(IOINQR(JPRINT(33)).EQ.IWRIT) THEN
          WRITE(LFNPR,7104) ABS(JPRINT(33))
        END IF
        IF(IWTNAB.EQ.IFULL) THEN
          WRITE(LFNPR,7110)
        ELSE IF(IWTNAB.EQ.ILEW) THEN
          WRITE(LFNPR,7112)
        ELSE IF(IOINQR(IWTNAB).EQ.IPRNT) THEN
          WRITE(LFNPR,7114) IWTNAB
        ELSE IF(IOINQR(IWTNAB).EQ.IWRIT) THEN
          WRITE(LFNPR,7116) ABS(IWTNAB)
        ELSE IF(IOINQR(IWTNAB).EQ.IREAD) THEN
          WRITE(LFNPR,7118) ABS(IWTNAB/1000)
        END IF
        IF(JPRINT(18).EQ.IFULL) THEN
          WRITE(LFNPR,7120)
        ELSE IF(JPRINT(18).EQ.ILEW) THEN
          WRITE(LFNPR,7122)
        ELSE IF(IOINQR(JPRINT(18)).EQ.IPRNT) THEN
          WRITE(LFNPR,7124) JPRINT(18)
        ELSE IF(IOINQR(JPRINT(18)).EQ.IWRIT) THEN
          WRITE(LFNPR,7126) ABS(JPRINT(18))
        END IF
        IF(JPRINT(9).EQ.IFULL) THEN
          WRITE(LFNPR,7130)
        ELSE IF(JPRINT(9).EQ.IVAL) THEN
          WRITE(LFNPR,7132)
        ELSE IF(JPRINT(9).EQ.ILEW) THEN
          WRITE(LFNPR,7134)
        ELSE IF(IOINQR(JPRINT(9)).EQ.IPRNT) THEN
          WRITE(LFNPR,7136) JPRINT(9)
        ELSE IF(IOINQR(JPRINT(9)).EQ.IWRIT) THEN
          WRITE(LFNPR,7138) ABS(JPRINT(9))
        END IF
        IF(JPRINT(41).EQ.IFULL) THEN
          WRITE(LFNPR,7140)
        ELSE IF(JPRINT(41).EQ.ILEW) THEN
          WRITE(LFNPR,7142)
        ELSE IF(IOINQR(JPRINT(41)).EQ.IPRNT) THEN
          WRITE(LFNPR,7144) JPRINT(41)
        ELSE IF(IOINQR(JPRINT(41)).EQ.IWRIT) THEN
          WRITE(LFNPR,7146) ABS(JPRINT(41))
        END IF
        IF(JPRINT(24).EQ.IFULL) THEN
          WRITE(LFNPR,7150)
        ELSE IF(JPRINT(24).EQ.ILEW) THEN
          WRITE(LFNPR,7152)
        ELSE IF(IOINQR(JPRINT(24)).EQ.IPRNT) THEN
          WRITE(LFNPR,7154) JPRINT(24)
        ELSE IF(IOINQR(JPRINT(24)).EQ.IWRIT) THEN
          WRITE(LFNPR,7156) ABS(JPRINT(24))
        END IF
        IF(JPRINT(38).EQ.IFULL) THEN
          WRITE(LFNPR,7160)
        ELSE IF(JPRINT(38).EQ.IVAL) THEN
          WRITE(LFNPR,7162)
        ELSE IF(JPRINT(38).EQ.ILEW) THEN
          WRITE(LFNPR,7164)
        ELSE IF(IOINQR(JPRINT(38)).EQ.IPRNT) THEN
          WRITE(LFNPR,7166) JPRINT(38)
        ELSE IF(IOINQR(JPRINT(38)).EQ.IWRIT) THEN
          WRITE(LFNPR,7168) ABS(JPRINT(38))
        END IF
        IF(JPRINT(47).EQ.IFULL) THEN
          WRITE(LFNPR,7170)
        ELSE IF(JPRINT(47).EQ.ILEW) THEN
          WRITE(LFNPR,7172)
        ELSE IF(IOINQR(JPRINT(47)).EQ.IPRNT) THEN
          WRITE(LFNPR,7174) JPRINT(47)
        ELSE IF(IOINQR(JPRINT(47)).EQ.IWRIT) THEN
          WRITE(LFNPR,7176) ABS(JPRINT(47))
        END IF
        IF(JPRINT(45).EQ.IFULL) THEN
          WRITE(LFNPR,7180)
        ELSE IF(JPRINT(45).EQ.IVAL) THEN
          WRITE(LFNPR,7182)
        ELSE IF(JPRINT(45).EQ.ILEW) THEN
          WRITE(LFNPR,7184)
        ELSE IF(IOINQR(JPRINT(45)).EQ.IPRNT) THEN
          WRITE(LFNPR,7186) JPRINT(45)
        ELSE IF(IOINQR(JPRINT(45)).EQ.IWRIT) THEN
          WRITE(LFNPR,7188) ABS(JPRINT(45))
        END IF
        IF(JPRINT(13).EQ.IFULL) THEN
          WRITE(LFNPR,7190)
        ELSE IF(JPRINT(13).EQ.IVAL) THEN
          WRITE(LFNPR,7192)
        ELSE IF(JPRINT(13).EQ.ILEW) THEN
          WRITE(LFNPR,7194)
        ELSE IF(IOINQR(JPRINT(13)).EQ.IPRNT) THEN
          WRITE(LFNPR,7196) JPRINT(13)
        ELSE IF(IOINQR(JPRINT(13)).EQ.IWRIT) THEN
          WRITE(LFNPR,7198) ABS(JPRINT(13))
        END IF
        IF(JPRINT(42).EQ.IFULL) THEN
          WRITE(LFNPR,7200)
        ELSE IF(IOINQR(JPRINT(42)).EQ.IPRNT) THEN
          WRITE(LFNPR,7202) JPRINT(42)
        ELSE IF(IOINQR(JPRINT(42)).EQ.IWRIT) THEN
          WRITE(LFNPR,7204) ABS(JPRINT(42))
        END IF
        IF(JPRINT(27).EQ.IFULL) THEN
          WRITE(LFNPR,7210)
        ELSE IF(IOINQR(JPRINT(27)).EQ.IPRNT) THEN
          WRITE(LFNPR,7212) JPRINT(27)
        ELSE IF(IOINQR(JPRINT(27)).EQ.IWRIT) THEN
          WRITE(LFNPR,7214) ABS(JPRINT(27))
        END IF
        IF(JPRINT(35).EQ.IFULL) THEN
          WRITE(LFNPR,7220)
        ELSE IF(IOINQR(JPRINT(35)).EQ.IPRNT) THEN
          WRITE(LFNPR,7222) JPRINT(35)
        ELSE IF(IOINQR(JPRINT(35)).EQ.IWRIT) THEN
          WRITE(LFNPR,7224) ABS(JPRINT(35))
        END IF
        IF(JPRINT(34).EQ.IFULL) THEN
          WRITE(LFNPR,7230)
        ELSE IF(IOINQR(JPRINT(34)).EQ.IPRNT) THEN
          WRITE(LFNPR,7232) JPRINT(34)
        ELSE IF(IOINQR(JPRINT(34)).EQ.IWRIT) THEN
          WRITE(LFNPR,7234) ABS(JPRINT(34))
        END IF
        IF(JPRINT(16).EQ.IFULL) THEN
          WRITE(LFNPR,7240)
        ELSE IF(JPRINT(16).EQ.ILEW) THEN
          WRITE(LFNPR,7242)
        ELSE IF(IOINQR(JPRINT(16)).EQ.IPRNT) THEN
          WRITE(LFNPR,7244) JPRINT(16)
        ELSE IF(IOINQR(JPRINT(16)).EQ.IWRIT) THEN
          WRITE(LFNPR,7246) ABS(JPRINT(16))
        END IF
        IF(JPRINT(17).EQ.IFULL) THEN
          WRITE(LFNPR,7250)
        ELSE IF(JPRINT(17).EQ.ILEW) THEN
          WRITE(LFNPR,7252)
        ELSE IF(IOINQR(JPRINT(17)).EQ.IPRNT) THEN
          WRITE(LFNPR,7254) JPRINT(17)
        ELSE IF(IOINQR(JPRINT(17)).EQ.IWRIT) THEN
          WRITE(LFNPR,7256) ABS(JPRINT(17))
        END IF
        IF(JPRINT(40).EQ.IFULL) THEN
          WRITE(LFNPR,7260)
        ELSE IF(IOINQR(JPRINT(40)).EQ.IPRNT) THEN
          WRITE(LFNPR,7262) JPRINT(40)
        ELSE IF(IOINQR(JPRINT(40)).EQ.IWRIT) THEN
          WRITE(LFNPR,7264) ABS(JPRINT(40))
        END IF
        IF(JPRINT(31).EQ.IFULL) THEN
          WRITE(LFNPR,7270)
        ELSE IF(IOINQR(JPRINT(31)).EQ.IPRNT) THEN
          WRITE(LFNPR,7272) JPRINT(31)
        ELSE IF(IOINQR(JPRINT(31)).EQ.IWRIT) THEN
          WRITE(LFNPR,7274) ABS(JPRINT(31))
        END IF
        IF(JPRINT(29).EQ.IFULL) THEN
          WRITE(LFNPR,7280)
        ELSE IF(IOINQR(JPRINT(29)).EQ.IPRNT) THEN
          WRITE(LFNPR,7282) JPRINT(29)
        ELSE IF(IOINQR(JPRINT(29)).EQ.IWRIT) THEN
          WRITE(LFNPR,7284) ABS(JPRINT(29))
        END IF
        IF(JPRINT(37).EQ.IFULL) THEN
          WRITE(LFNPR,7290)
        ELSE IF(JPRINT(37).EQ.ILEW) THEN
          WRITE(LFNPR,7292)
        ELSE IF(IOINQR(JPRINT(37)).EQ.IPRNT) THEN
          WRITE(LFNPR,7294) JPRINT(37)
        ELSE IF(IOINQR(JPRINT(37)).EQ.IWRIT) THEN
          WRITE(LFNPR,7296) ABS(JPRINT(37))
        END IF
        IF(JPRINT(15).EQ.IFULL) THEN
          WRITE(LFNPR,7300)
        ELSE IF(JPRINT(15).EQ.ILEW) THEN
          WRITE(LFNPR,7302)
        ELSE IF(IOINQR(JPRINT(15)).EQ.IPRNT) THEN
          WRITE(LFNPR,7304) JPRINT(15)
        ELSE IF(IOINQR(JPRINT(15)).EQ.IWRIT) THEN
          WRITE(LFNPR,7306) ABS(JPRINT(15))
        END IF
        IF(JPRINT(50).EQ.IFULL) THEN
          WRITE(LFNPR,7310)
        ELSE IF(IOINQR(JPRINT(50)).EQ.IPRNT) THEN
          WRITE(LFNPR,7312) JPRINT(50)
        ELSE IF(IOINQR(JPRINT(50)).EQ.IWRIT) THEN
          WRITE(LFNPR,7314) ABS(JPRINT(50))
        END IF
        IF(JPRINT(51).EQ.IFULL) THEN
          WRITE(LFNPR,7320)
        ELSE IF(IOINQR(JPRINT(51)).EQ.IPRNT) THEN
          WRITE(LFNPR,7322) JPRINT(51)
        ELSE IF(IOINQR(JPRINT(51)).EQ.IWRIT) THEN
          WRITE(LFNPR,7324) ABS(JPRINT(51))
        END IF
        IF(JPRINT(52).EQ.IFULL) THEN
          WRITE(LFNPR,7330)
        ELSE IF(IOINQR(JPRINT(52)).EQ.IPRNT) THEN
          WRITE(LFNPR,7332) JPRINT(52)
        ELSE IF(IOINQR(JPRINT(52)).EQ.IWRIT) THEN
          WRITE(LFNPR,7334) ABS(JPRINT(52))
        END IF
        IF(JPRINT(53).EQ.IFULL) THEN
          WRITE(LFNPR,7340)
        ELSE IF(JPRINT(53).EQ.ILEW) THEN
          WRITE(LFNPR,7342)
        ELSE IF(IOINQR(JPRINT(53)).EQ.IPRNT) THEN
          WRITE(LFNPR,7344) JPRINT(53)
        ELSE IF(IOINQR(JPRINT(53)).EQ.IWRIT) THEN
          WRITE(LFNPR,7346) ABS(JPRINT(53))
        END IF
        IF(JPRINT(54).EQ.IFULL) THEN
          WRITE(LFNPR,7350)
        ELSE IF(JPRINT(54).EQ.ILEW) THEN
          WRITE(LFNPR,7352)
        ELSE IF(IOINQR(JPRINT(54)).EQ.IPRNT) THEN
          WRITE(LFNPR,7354) JPRINT(54)
        ELSE IF(IOINQR(JPRINT(54)).EQ.IWRIT) THEN
          WRITE(LFNPR,7356) ABS(JPRINT(54))
        END IF
        IF(JPRINT(39).EQ.IFULL) THEN
          WRITE(LFNPR,7360)
        ELSE IF(IOINQR(JPRINT(39)).EQ.IPRNT) THEN
          WRITE(LFNPR,7362) JPRINT(39)
        ELSE IF(IOINQR(JPRINT(39)).EQ.IWRIT) THEN
          WRITE(LFNPR,7364) ABS(JPRINT(39))
        END IF
        IF(JPRINT(19).EQ.IFULL) THEN
          WRITE(LFNPR,7370)
        ELSE IF(IOINQR(JPRINT(19)).EQ.IPRNT) THEN
          WRITE(LFNPR,7372) JPRINT(19)
        ELSE IF(IOINQR(JPRINT(19)).EQ.IWRIT) THEN
          WRITE(LFNPR,7374) ABS(JPRINT(19))
        END IF
        IF(JPRINT(20).EQ.IFULL) THEN
          WRITE(LFNPR,7380)
        ELSE IF(IOINQR(JPRINT(20)).EQ.IPRNT) THEN
          WRITE(LFNPR,7382) JPRINT(20)
        ELSE IF(IOINQR(JPRINT(20)).EQ.IWRIT) THEN
          WRITE(LFNPR,7384) ABS(JPRINT(20))
        END IF
        IF(JPRINT(21).EQ.IFULL) THEN
          WRITE(LFNPR,7390)
        ELSE IF(JPRINT(21).EQ.ILEW) THEN
          WRITE(LFNPR,7392)
        ELSE IF(IOINQR(JPRINT(21)).EQ.IPRNT) THEN
          WRITE(LFNPR,7394) JPRINT(21)
        ELSE IF(IOINQR(JPRINT(21)).EQ.IWRIT) THEN
          WRITE(LFNPR,7396) ABS(JPRINT(21))
        END IF
        IF(JPRINT(48).EQ.IFULL) THEN
          WRITE(LFNPR,7400)
        ELSE IF(JPRINT(48).EQ.ILEW) THEN
          WRITE(LFNPR,7402)
        ELSE IF(IOINQR(JPRINT(48)).EQ.IPRNT) THEN
          WRITE(LFNPR,7404) JPRINT(48)
        ELSE IF(IOINQR(JPRINT(48)).EQ.IWRIT) THEN
          WRITE(LFNPR,7406) ABS(JPRINT(48))
        END IF
C------------------------------------------------------------------------------
 7000 FORMAT(1X,'      /AOPNAO / : Print the AO to PNAO transformation')
 7002 FORMAT(1X,'      /AOPNAO / : Print ',I3,' columns of the AO to ',
     *   'PNAO transformation')
 7004 FORMAT(1X,'      /AOPNAO / : Write the AO to PNAO transformation',
     *   ' to LFN',I3)
 7010 FORMAT(1X,'      /AONAO  / : Print the AO to NAO transformation')
 7012 FORMAT(1X,'      /AONAO  / : Print ',I3,' columns of the AO ',
     *   'to NAO transformation')
 7014 FORMAT(1X,'      /AONAO  / : Write the AO to NAO transformation ',
     *   'to LFN',I3)
 7016 FORMAT(1X,'      /AONAO  / : Read AO to NAO transformation from ',
     *          'LFN',I3)
 7020 FORMAT(1X,'      /AOPNHO / : Print the AO to PNHO ',
     *   'transformation')
 7022 FORMAT(1X,'      /AOPNHO / : Print ',I3,' columns of the AO to ',
     *   'PNHO transformation')
 7024 FORMAT(1X,'      /AOPNHO / : Write the AO to PNHO transformation',
     *   ' to LFN',I3)
 7030 FORMAT(1X,'      /AONHO  / : Print the AO to NHO transformation')
 7032 FORMAT(1X,'      /AONHO  / : Print ',I3,' columns of the AO to ',
     *   'NHO transformation')
 7034 FORMAT(1X,'      /AONHO  / : Write the AO to NHO transformation ',
     *   'to LFN',I3)
 7040 FORMAT(1X,'      /AOPNBO / : Print the AO to PNBO ',
     *   'transformation')
 7042 FORMAT(1X,'      /AOPNBO / : Print the occupied PNBOs in the AO ',
     *   'basis')
 7044 FORMAT(1X,'      /AOPNBO / : Print ',I3,' columns of the AO to ',
     *   'PNBO transformation')
 7046 FORMAT(1X,'      /AOPNBO / : Write the AO to PNBO transformation',
     *   ' to LFN',I3)
 7050 FORMAT(1X,'      /AONBO  / : Print the AO to NBO transformation')
 7052 FORMAT(1X,'      /AONBO  / : Print the occupied NBOs in the AO ',
     *   'basis')
 7054 FORMAT(1X,'      /AONBO  / : Print ',I3,' columns of the AO ',
     *   'to NBO transformation')
 7056 FORMAT(1X,'      /AONBO  / : Write the AO to NBO transformation ',
     *   'to LFN',I3)
 7060 FORMAT(1X,'      /AOPNLMO/ : Print the AO to PNLMO ',
     *   'transformation')
 7062 FORMAT(1X,'      /AOPNLMO/ : Print the occupied PNLMOs in the AO',
     *   ' basis')
 7064 FORMAT(1X,'      /AOPNLMO/ : Print ',I3,' columns of the AO to ',
     *   'PNLMO transformation')
 7066 FORMAT(1X,'      /AOPNLMO/ : Write the AO to PNLMO transformatio',
     *   'n to LFN',I3)
 7070 FORMAT(1X,'      /AONLMO / : Print the AO to NLMO ',
     *   'transformation')
 7072 FORMAT(1X,'      /AONLMO / : Print the occupied NLMOs in the AO ',
     *   'basis')
 7074 FORMAT(1X,'      /AONLMO / : Print ',I3,' columns of the AO to ',
     *   'NLMO transformation')
 7076 FORMAT(1X,'      /AONLMO / : Write the AO to NLMO transformation',
     *   ' to LFN',I3)
 7080 FORMAT(1X,'      /AOMO   / : Print all MOs in the AO basis')
 7082 FORMAT(1X,'      /AOMO   / : Print core and valence MOs in ',
     *   'the AO basis')
 7084 FORMAT(1X,'      /AOMO   / : Print the occupied MOs in the AO ',
     *   'basis')
 7086 FORMAT(1X,'      /AOMO   / : Print ',I3,' lowest energy MOs ',
     *   'in the AO basis')
 7088 FORMAT(1X,'      /AOMO   / : Write the AO to MO transformation ',
     *   'to LFN',I3)
 7090 FORMAT(1X,'      /PAOPNAO/ : Print the PAO to PNAO ',
     *   'transformation')
 7092 FORMAT(1X,'      /PAOPNAO/ : Print ',I3,' columns of the PAO ',
     *   'to PNAO transformation')
 7094 FORMAT(1X,'      /PAOPNAO/ : Write the PAO to PNAO ',
     *   'transformation to LFN',I3)
 7096 FORMAT(1X,'      /PAOPNAO/ : Read PAO to PNAO transformation ',
     *          'from LFN',I3)
 7100 FORMAT(1X,'      /NAONHO / : Print the NAO to NHO transformation')
 7102 FORMAT(1X,'      /NAONHO / : Print ',I3,' columns of the NAO ',
     *   'to NHO transformation')
 7104 FORMAT(1X,'      /NAONHO / : Write the NAO to NHO transformation',
     *   ' to LFN',I3)
 7110 FORMAT(1X,'      /NAONBO / : Print the NAO to NBO transformation')
 7112 FORMAT(1X,'      /NAONBO / : Print the occupied NBOs in the NAO ',
     *   'basis')
 7114 FORMAT(1X,'      /NAONBO / : Print ',I3,' columns of the NAO ',
     *   'to NBO transformation')
 7116 FORMAT(1X,'      /NAONBO / : Write the NAO to NBO transformation',
     *   ' to LFN',I3)
 7118 FORMAT(1X,'      /NAONBO / : Read NAO to NBO transformation from',
     *          ' LFN',I3)
 7120 FORMAT(1X,'      /NAONLMO/ : Print the NAO to NLMO ',
     *   'transformation')
 7122 FORMAT(1X,'      /NAONLMO/ : Print the occupied NLMOs in the NAO',
     *   ' basis')
 7124 FORMAT(1X,'      /NAONLMO/ : Print ',I3,' columns of the NAO ',
     *   'to NLMO transformation')
 7126 FORMAT(1X,'      /NAONLMO/ : Write the NAO to NLMO ',
     *   'transformation to LFN',I3)
 7130 FORMAT(1X,'      /NAOMO  / : Print all MOs in the NAO basis')
 7132 FORMAT(1X,'      /NAOMO  / : Print core and valence MOs in ',
     *   'the NAO basis')
 7134 FORMAT(1X,'      /NAOMO  / : Print the occupied MOs in the NAO ',
     *   'basis')
 7136 FORMAT(1X,'      /NAOMO  / : Print ',I3,' lowest energy MOs ',
     *   'in the NAO basis')
 7138 FORMAT(1X,'      /NAOMO  / : Write the NAO to MO transformation ',
     *   'to LFN',I3)
 7140 FORMAT(1X,'      /NHONBO / : Print the NHO to NBO transformation')
 7142 FORMAT(1X,'      /NHONBO / : Print the occupied NBOs in the NHO ',
     *   'basis')
 7144 FORMAT(1X,'      /NHONBO / : Print ',I3,' columns of the NHO ',
     *   'to NBO transformation')
 7146 FORMAT(1X,'      /NHONBO / : Write the NHO to NBO transformation',
     *   ' to LFN',I3)
 7150 FORMAT(1X,'      /NHONLMO/ : Print the NHO to NLMO ',
     *   'transformation')
 7152 FORMAT(1X,'      /NHONLMO/ : Print the occupied NLMOs in the NHO',
     *   ' basis')
 7154 FORMAT(1X,'      /NHONLMO/ : Print ',I3,' columns of the NHO ',
     *   'to NLMO transformation')
 7156 FORMAT(1X,'      /NHONLMO/ : Write the NHO to NLMO ',
     *   'transformation to LFN',I3)
 7160 FORMAT(1X,'      /NHOMO  / : Print all MOs in the NHO basis')
 7162 FORMAT(1X,'      /NHOMO  / : Print core and valence MOs in ',
     *   'the NHO basis')
 7164 FORMAT(1X,'      /NHOMO  / : Print the occupied MOs in the NHO ',
     *   'basis')
 7166 FORMAT(1X,'      /NHOMO  / : Print ',I3,' lowest energy MOs ',
     *   'in the NHO basis')
 7168 FORMAT(1X,'      /NHOMO  / : Write the NHO to MO transformation ',
     *   'to LFN',I3)
 7170 FORMAT(1X,'      /NBONLMO/ : Print the NBO to NLMO ',
     *   'transformation')
 7172 FORMAT(1X,'      /NBONLMO/ : Print the occupied NLMOs in the NBO',
     *   ' basis')
 7174 FORMAT(1X,'      /NBONLMO/ : Print ',I3,' columns of the NBO ',
     *   'to NLMO transformation')
 7176 FORMAT(1X,'      /NBONLMO/ : Write the NBO to NLMO ',
     *   'transformation to LFN',I3)
 7180 FORMAT(1X,'      /NBOMO  / : Print all MOs in the NBO basis')
 7182 FORMAT(1X,'      /NBOMO  / : Print core and valence MOs in ',
     *   'the NBO basis')
 7184 FORMAT(1X,'      /NBOMO  / : Print the occupied MOs in the NBO ',
     *   'basis')
 7186 FORMAT(1X,'      /NBOMO  / : Print ',I3,' lowest energy MOs ',
     *   'in the NBO basis')
 7188 FORMAT(1X,'      /NBOMO  / : Write the NBO to MO transformation ',
     *   'to LFN',I3)
 7190 FORMAT(1X,'      /NLMOMO / : Print all MOs in the NLMO basis')
 7192 FORMAT(1X,'      /NLMOMO / : Print core and valence MOs in ',
     *   'the NLMO basis')
 7194 FORMAT(1X,'      /NLMOMO / : Print the occupied MOs in the NLMO ',
     *   'basis')
 7196 FORMAT(1X,'      /NLMOMO / : Print ',I3,' lowest energy MOs ',
     *   'in the NLMO basis')
 7198 FORMAT(1X,'      /NLMOMO / : Write the NLMO to MO transformation',
     *   ' to LFN',I3)
 7200 FORMAT(1X,'      /BOAO   / : Print the AO bond-order matrix')
 7202 FORMAT(1X,'      /BOAO   / : Print ',I3,' columns of the AO ',
     *   'bond-order matrix')
 7204 FORMAT(1X,'      /BOAO   / : Write the AO bond-order matrix to ',
     *   'LFN',I3)
 7210 FORMAT(1X,'      /DMAO   / : Print the AO density matrix')
 7212 FORMAT(1X,'      /DMAO   / : Print ',I3,' columns of the AO ',
     *   'density matrix')
 7214 FORMAT(1X,'      /DMAO   / : Write the AO density matrix to ',
     *   'LFN',I3)
 7220 FORMAT(1X,'      /DMNAO  / : Print the NAO density matrix')
 7222 FORMAT(1X,'      /DMNAO  / : Print ',I3,' columns of the NAO ',
     *   'density matrix')
 7224 FORMAT(1X,'      /DMNAO  / : Write the NAO density matrix to ',
     *   'LFN',I3)
 7230 FORMAT(1X,'      /DMNHO  / : Print the NHO density matrix')
 7232 FORMAT(1X,'      /DMNHO  / : Print ',I3,' columns of the NHO ',
     *   'density matrix')
 7234 FORMAT(1X,'      /DMNHO  / : Write the NHO density matrix to ',
     *   'LFN',I3)
 7240 FORMAT(1X,'      /DMNBO  / : Print the NBO density matrix')
 7242 FORMAT(1X,'      /DMNBO  / : Print the density matrix elements ',
     *   'of the occupied NBOs')
 7244 FORMAT(1X,'      /DMNBO  / : Print ',I3,' columns of the NBO ',
     *   'density matrix')
 7246 FORMAT(1X,'      /DMNBO  / : Write the NBO density matrix to ',
     *   'LFN',I3)
 7250 FORMAT(1X,'      /DMNLMO / : Print the NLMO density matrix')
 7252 FORMAT(1X,'      /DMNLMO / : Print the density matrix elements ',
     *   'of the occupied NLMOs')
 7254 FORMAT(1X,'      /DMNLMO / : Print ',I3,' columns of the NLMO ',
     *   'density matrix')
 7256 FORMAT(1X,'      /DMNLMO / : Write the NLMO density matrix to ',
     *   'LFN',I3)
 7260 FORMAT(1X,'      /FAO    / : Print the AO Fock matrix')
 7262 FORMAT(1X,'      /FAO    / : Print ',I3,' columns of the AO ',
     *   'Fock matrix')
 7264 FORMAT(1X,'      /FAO    / : Write the AO Fock matrix to ',
     *   'LFN',I3)
 7270 FORMAT(1X,'      /FNAO   / : Print the NAO Fock matrix')
 7272 FORMAT(1X,'      /FNAO   / : Print ',I3,' columns of the NAO ',
     *   'Fock matrix')
 7274 FORMAT(1X,'      /FNAO   / : Write the NAO Fock matrix to ',
     *   'LFN',I3)
 7280 FORMAT(1X,'      /FNHO   / : Print the NHO Fock matrix')
 7282 FORMAT(1X,'      /FNHO   / : Print ',I3,' columns of the NHO ',
     *   'Fock matrix')
 7284 FORMAT(1X,'      /FNHO   / : Write the NHO Fock matrix to ',
     *   'LFN',I3)
 7290 FORMAT(1X,'      /FNBO   / : Print the NBO Fock matrix')
 7292 FORMAT(1X,'      /FNBO   / : Print the Fock matrix elements of ',
     *   'the occupied NBOs')
 7294 FORMAT(1X,'      /FNBO   / : Print ',I3,' columns of the NBO ',
     *   'Fock matrix')
 7296 FORMAT(1X,'      /FNBO   / : Write the NBO Fock matrix to ',
     *   'LFN',I3)
 7300 FORMAT(1X,'      /FNLMO  / : Print the NLMO Fock matrix')
 7302 FORMAT(1X,'      /FNLMO  / : Print the Fock matrix elements of ',
     *   'the occupied NLMOs')
 7304 FORMAT(1X,'      /FNLMO  / : Print ',I3,' columns of the NLMO ',
     *   'Fock matrix')
 7306 FORMAT(1X,'      /FNLMO  / : Write the NLMO Fock matrix to ',
     *   'LFN',I3)
 7310 FORMAT(1X,'      /DIAO   / : Print the AO dipole integrals')
 7312 FORMAT(1X,'      /DIAO   / : Print ',I3,' columns of the AO ',
     *   'dipole matrices')
 7314 FORMAT(1X,'      /DIAO   / : Write the AO dipole integrals',
     *   ' to LFN',I3)
 7320 FORMAT(1X,'      /DINAO  / : Print the NAO dipole integrals')
 7322 FORMAT(1X,'      /DINAO  / : Print ',I3,' columns of the NAO ',
     *   'dipole matrices')
 7324 FORMAT(1X,'      /DINAO  / : Write the NAO dipole integrals',
     *   ' to LFN',I3)
 7330 FORMAT(1X,'      /DINHO  / : Print the NHO dipole integrals')
 7332 FORMAT(1X,'      /DINHO  / : Print ',I3,' columns of the NHO ',
     *   'dipole matrices')
 7334 FORMAT(1X,'      /DINHO  / : Write the NHO dipole integrals',
     *   ' to LFN',I3)
 7340 FORMAT(1X,'      /DINBO  / : Print the NBO dipole integrals')
 7342 FORMAT(1X,'      /DINBO  / : Print the dipole integrals of ',
     *   'occupied NBOs')
 7344 FORMAT(1X,'      /DINBO  / : Print ',I3,' columns of the NBO ',
     *   'dipole matrices')
 7346 FORMAT(1X,'      /DINBO  / : Write the NBO dipole integrals',
     *   ' to LFN',I3)
 7350 FORMAT(1X,'      /DINLMO / : Print the NLMO dipole integrals')
 7352 FORMAT(1X,'      /DINLMO / : Print the dipole integrals of ',
     *   'occupied NLMOs')
 7354 FORMAT(1X,'      /DINLMO / : Print ',I3,' columns of the NLMO ',
     *   'dipole matrices')
 7356 FORMAT(1X,'      /DINLMO / : Write the NLMO dipole integrals',
     *   ' to LFN',I3)
 7360 FORMAT(1X,'      /SAO    / : Print the AO overlap matrix')
 7362 FORMAT(1X,'      /SAO    / : Print ',I3,' columns of the AO ',
     *   'overlap matrix')
 7364 FORMAT(1X,'      /SAO    / : Write the AO overlap matrix to ',
     *   'LFN',I3)
 7370 FORMAT(1X,'      /SPNAO  / : Print the PNAO overlap matrix')
 7372 FORMAT(1X,'      /SPNAO  / : Print ',I3,' columns of the PNAO ',
     *   'overlap matrix')
 7374 FORMAT(1X,'      /SPNAO  / : Write the PNAO overlap matrix to ',
     *   'LFN',I3)
 7380 FORMAT(1X,'      /SPNHO  / : Print the PNHO overlap matrix')
 7382 FORMAT(1X,'      /SPNHO  / : Print ',I3,' columns of the PNHO ',
     *   'overlap matrix')
 7384 FORMAT(1X,'      /SPNHO  / : Write the PNHO overlap matrix to ',
     *   'LFN',I3)
 7390 FORMAT(1X,'      /SPNBO  / : Print the PNBO overlap matrix')
 7392 FORMAT(1X,'      /SPNBO  / : Print the overlap matrix elements ',
     *   'of the occupied PNBOs')
 7394 FORMAT(1X,'      /SPNBO  / : Print ',I3,' columns of the PNBO ',
     *   'overlap matrix')
 7396 FORMAT(1X,'      /SPNBO  / : Write the PNBO overlap matrix to ',
     *   'LFN',I3)
 7400 FORMAT(1X,'      /SPNLMO / : Print the PNLMO overlap matrix')
 7402 FORMAT(1X,'      /SPNLMO / : Print the overlap matrix elements ',
     *   'of the occupied PNLMOs')
 7404 FORMAT(1X,'      /SPNLMO / : Print ',I3,' columns of the PNLMO ',
     *   'overlap matrix')
 7406 FORMAT(1X,'      /SPNLMO / : Write the PNLMO overlap matrix to ',
     *   'LFN',I3)
C------------------------------------------------------------------------------
C
C  OTHER OUTPUT CONTROL KEYWORDS:
C
        IF(LFNPR.NE.6) WRITE(LFNPR,8000) LFNPR
        IF(JPRINT(43).NE.0) WRITE(LFNPR,8010)
        IF(IWDETL.NE.0) WRITE(LFNPR,8020)
        IF(JPRINT(7).NE.0) WRITE(LFNPR,8030) JPRINT(7)
        IF(JPRINT(12).NE.0) WRITE(LFNPR,8040)
        IF(LFNDAF.GE.0) WRITE(LFNPR,8050) LFNDAF
        IF(JPRINT(22).NE.0) WRITE(LFNPR,8060) JPRINT(22)
        IF(IWMULP.EQ.1) WRITE(LFNPR,8070)
        IF(IWMULP.EQ.2) WRITE(LFNPR,8080)
        IF(IWAPOL.NE.0) WRITE(LFNPR,8090)
        IF(JPRINT(11).NE.0) WRITE(LFNPR,8100)
        IF(LENNM.NE.0) WRITE(LFNPR,8110) FILENM(1:52)
C
        IF(IPRINT.LT.10) THEN
          WRITE(LFNPR,8500) IPRINT
        ELSE
          IPRINT = IPRINT - 10
        END IF
C------------------------------------------------------------------------------
 8000 FORMAT(1X,'      /LFNPR  / : set to',I3)
 8010 FORMAT(1X,'      /PLOT   / : Write information for the orbital',
     *   ' plotter')
 8020 FORMAT(1X,'      /DETAIL / : Write out details of NBO search')
 8030 FORMAT(1X,'      /ARCHIVE/ : Write the archive file to LFN',I3)
 8040 FORMAT(1X,'      /BNDIDX / : Print bond indices based on ',
     *  'the NAO density matrix')
 8050 FORMAT(1X,'      /NBODAF / : NBO direct access file written on',
     *   ' LFN',I3)
 8060 FORMAT(1X,'      /AOINFO / : Write AO information to LFN',I3)
 8070 FORMAT(1X,'      /MULAT  / : Print Mulliken populations',
     *                ' by atom')
 8080 FORMAT(1X,'      /MULORB / : Print Mulliken populations',
     *                ' by orbital and atom')
 8090 FORMAT(1X,'      /APOLAR / : Enforce apolar NBOs')
 8100 FORMAT(1X,'      /RPNAO  / : Revise TPNAO with TRYD and TRED')
 8110 FORMAT(1X,'      /FILE   / : Set to ',A52)
 8500 FORMAT(1X,'      /PRINT  / : Print level set to',I3)
C------------------------------------------------------------------------------
      END IF
C
C  SET PRINT LEVEL OPTIONS:
C
      IF(IPRINT.GT.0) THEN
        JPRINT(4)  =  1
        JPRINT(5)  =  1
      END IF
C
      IF(IPRINT.GT.1) THEN
        JPRINT(3)  =  1
        JPRINT(6)  =  1
        JPRINT(36) =  1
      END IF
C
      IF(IPRINT.GT.2) THEN
        JPRINT(8)  =  1
        JPRINT(12) =  1
        JPRINT(46) =  1
      END IF
C
      IF(IPRINT.GT.3) THEN
        IF(JPRINT(7).EQ.0)  JPRINT(7)  = LFNARC
        IF(JPRINT(9).EQ.0)  JPRINT(9)  = IFULL
        IF(JPRINT(13).EQ.0) JPRINT(13) = IFULL
                            JPRINT(14) = 1
        IF(JPRINT(15).EQ.0) JPRINT(15) = IFULL
        IF(JPRINT(16).EQ.0) JPRINT(16) = IFULL
        IF(JPRINT(17).EQ.0) JPRINT(17) = IFULL
        IF(JPRINT(18).EQ.0) JPRINT(18) = IFULL
        IF(JPRINT(19).EQ.0) JPRINT(19) = IFULL
        IF(JPRINT(20).EQ.0) JPRINT(20) = IFULL
        IF(JPRINT(21).EQ.0) JPRINT(21) = IFULL
        IF(JPRINT(24).EQ.0) JPRINT(24) = IFULL
        IF(JPRINT(29).EQ.0) JPRINT(29) = IFULL
        IF(JPRINT(31).EQ.0) JPRINT(31) = IFULL
        IF(JPRINT(32).EQ.0) JPRINT(32) = 1
        IF(JPRINT(33).EQ.0) JPRINT(33) = IFULL
        IF(JPRINT(34).EQ.0) JPRINT(34) = IFULL
        IF(JPRINT(35).EQ.0) JPRINT(35) = IFULL
        IF(JPRINT(37).EQ.0) JPRINT(37) = IFULL
        IF(JPRINT(38).EQ.0) JPRINT(38) = IFULL
        IF(JPRINT(39).EQ.0) JPRINT(39) = IFULL
        IF(JPRINT(40).EQ.0) JPRINT(40) = IFULL
        IF(JPRINT(41).EQ.0) JPRINT(41) = IFULL
        IF(JPRINT(42).EQ.0) JPRINT(42) = IFULL
                            JPRINT(43) = 1
        IF(JPRINT(45).EQ.0) JPRINT(45) = IFULL
        IF(JPRINT(47).EQ.0) JPRINT(47) = IFULL
        IF(JPRINT(48).EQ.0) JPRINT(48) = IFULL
        IF(JPRINT(50).EQ.0) JPRINT(50) = IFULL
        IF(JPRINT(51).EQ.0) JPRINT(51) = IFULL
        IF(JPRINT(52).EQ.0) JPRINT(52) = IFULL
        IF(JPRINT(53).EQ.0) JPRINT(53) = IFULL
        IF(JPRINT(54).EQ.0) JPRINT(54) = IFULL
        IF(JPRINT(55).EQ.0) JPRINT(55) = 1
        IF(IWTNAB.EQ.0)     IWTNAB     = IFULL
                            IWDETL     = 1
        IF(IWDM.NE.0)       IWMULP     = 2
      END IF
C
C  TURN ON THE NLMO ANALYSIS IF REQUIRED:
C
      IF(JPRINT(13).NE.0) JPRINT(8) = 1
      IF(JPRINT(15).NE.0) JPRINT(8) = 1
      IF(JPRINT(17).NE.0) JPRINT(8) = 1
      IF(JPRINT(18).NE.0) JPRINT(8) = 1
      IF(JPRINT(23).NE.0) JPRINT(8) = 1
      IF(JPRINT(46).NE.0) JPRINT(8) = 1
      IF(JPRINT(47).NE.0) JPRINT(8) = 1
      IF(JPRINT(48).NE.0) JPRINT(8) = 1
      IF(JPRINT(49).NE.0) JPRINT(8) = 1
      IF(JPRINT(54).NE.0) JPRINT(8) = 1
C
C  TAKE CARE OF THE PLOT OPTION:
C
      IF(JPRINT(43).NE.0) THEN
                            JPRINT(8)  =  1
        IF(JPRINT(22).EQ.0) JPRINT(22) =  LFNAO
        IF(IWTNAO.EQ.0)     IWTNAO     = -LFNNAO
        IF(JPRINT(28).EQ.0) JPRINT(28) = -LFNNHO
        IF(IWTNBO.EQ.0)     IWTNBO     = -LFNNBO
        IF(JPRINT(23).EQ.0) JPRINT(23) = -LFNNLM
        IF(JPRINT(26).EQ.0) JPRINT(26) = -LFNMO
        IF(JPRINT(27).EQ.0) JPRINT(27) = -LFNDM
        IF(JPRINT(44).EQ.0) JPRINT(44) = -LFNPNA
        IF(JPRINT(30).EQ.0) JPRINT(30) = -LFNPNH
        IF(JPRINT(25).EQ.0) JPRINT(25) = -LFNPNB
        IF(JPRINT(49).EQ.0) JPRINT(49) = -LFNPNL
      END IF
C
C  PRINT HYBRIDS IF THE NBO OUTPUT IS REQUESTED:
C
      IWHYBS = JPRINT(5)
      RETURN
C
C  ABORT PROGRAM: UNRECOGNIZABLE KEYWORD ENCOUNTERED
C
 4800 WRITE(LFNPR,9800) (KEYWD(I),I=1,6)
        STOP
C
C  INCOMPATIBLE JOB OPTIONS HAVE BEEN REQUESTED:
C
 4900 CONTINUE
        WRITE(LFNPR,9900)
        STOP
C
 9800 FORMAT(1X,'Error: Unrecognizable keyword  >>',6A1,'<<',/,1X,
     *          'Program must halt.')
 9900 FORMAT(1X,'The NBO program must stop because the options /MULAT/',
     + ' and /MULORB/',/1X,'currently require the AO bond order matrix',
     + ', rather than the AO density',/1X,'matrix.  The program could ',
     + 'be modified to permit this.')
      END
C*****************************************************************************
      SUBROUTINE NBODIM(MEMORY)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      DIMENSION NSPDFG(5,2)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBBAS/LABEL(MAXBAS,6),LVAL(MAXBAS),IMVAL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
C
      DATA IREAD/4HREAD/
C
C  NBODIM:  SET UP DIMENSIONING INFORMATION, LISTS IN COMMON/NBATOM/,
C           AND COMPARE STORAGE NEEDS WITH AMOUNT OF STORAGE AVAILABLE
C
C  FIND:
C     MXAOLM, THE MAXIMUM NUMBER OF ATOMIC ORBITALS OF THE SAME SYMMETRY
C              ON A SINGLE ATOM
C     MXAO, THE MAXIMUM NUMBER OF ATOMIC ORBITALS PER ATOM
C     MXBO, THE MAXIMUM NUMBER OF ATOMIC ORBITALS PER TWO-CENTER OR
C              THREE-CENTER BOND
C
      DO 300 I = 1,NBAS
        LM = LANG(I)
        LVAL(I) = LM/100
        IM = LM - LVAL(I)*100
        IF(IM.GT.50) IM = IM - 50
        IMVAL(I) = IM
  300 CONTINUE
C
      MXAO   = 0
      MXAO2  = 0
      MXAO3  = 0
      MXAOLM = 0
      LLU = 0
      DO 500 I = 1,NATOMS
        N = 0
        DO 400 IL = 1,5
          DO 400 ITYP = 1,2
  400       NSPDFG(IL,ITYP) = 0
        DO 410 J = 1,NBAS
          IF(LCTR(J).NE.I) GO TO 410
          LM = LANG(J)
          L = LM/100
          IM = LM - L*100
C
C  IF IM.NE.1 (THAT IS, IF THIS IS NOT THE FIRST COMPONENT OF THE
C  ANG. MOM. L FUNCTIONS ON THE ATOM), DON'T COUNT IT IN NSPDFG:
C
          IF(IM.NE.1) GO TO 410
C
C  ITYP=1 FOR CARTESIAN FUNCTION, =2 FOR TRUE SPHERICAL HARMONIC:
C
          ITYP = 1
          IF(IM.GT.50) ITYP = 2
          IL = L + 1
          NSPDFG(IL,ITYP) = NSPDFG(IL,ITYP)+1
  410     IF(LCTR(J).EQ.I) N = N + 1
C
C  NUMBER OF S ORBITALS= NO. S ORBS INPUT + NO. CARTESIAN D AND G ORBS:
C
        NSPDFG(1,1) = NSPDFG(1,1) + NSPDFG(1,2) + NSPDFG(3,1) +
     +                NSPDFG(5,1)
C
C  NUMBER OF P ORBITALS= NO. P ORBS INPUT + NO. CARTESIAN F ORBS:
C
        NSPDFG(2,1) = NSPDFG(2,1) + NSPDFG(2,2) + NSPDFG(4,1)
C
C  NUMBER OF D ORBITALS= NO. D ORBS INPUT + NO. CARTESIAN G ORBS:
C
        NSPDFG(3,1) = NSPDFG(3,1) + NSPDFG(3,2) + NSPDFG(5,1)
C
C  NUMBER OF F ORBITALS:
C
        NSPDFG(4,1) = NSPDFG(4,1) + NSPDFG(4,2)
C
C  NUMBER OF G ORBITALS:
C
        NSPDFG(5,1) = NSPDFG(5,1) + NSPDFG(5,2)
C
        DO 430 IL = 1,5
          IF(NSPDFG(IL,1).LE.MXAOLM) GO TO 430
          MXAOLM = NSPDFG(IL,1)
  430   CONTINUE
C
        NORBS(I) = N
        LL(I) = LLU + 1
        LU(I) = LL(I) + N - 1
        LLU = LU(I)
        IF(N.LE.MXAO) GO TO 460
        MXAO3 = MXAO2
        MXAO2 = MXAO
        MXAO = N
        GO TO 500
  460   IF(N.LE.MXAO2) GO TO 480
        MXAO3 = MXAO2
        MXAO2 = N
        GO TO 500
  480   IF(N.LE.MXAO3) GO TO 500
        MXAO3 = N
  500 CONTINUE
      MXBO = MXAO + MXAO2
      IF(IW3C.EQ.1) MXBO = MXBO + MXAO3
C
C  COMPUTE STORAGE REQUIREMENTS AND COMPARE WITH AVAILABLE CORE SPACE:
C
C  STORAGE FOR DENSITY MATRIX (DM) AND TRANSFORMATIONS (T):
C
      NEED0 = 2*NDIM*NDIM
C
C  COMPUTE STORAGE FOR NATURAL POPULATION ANALYSIS:
C
      NEED1 = 0
      IO = IOINQR(IWTNAO)
      IF(IO.NE.IREAD.AND..NOT.ORTHO) THEN
        NEED  = NDIM + NDIM + NDIM*NDIM + MXAOLM*MXAOLM + NDIM 
     +        + MXAOLM*MXAOLM + MXAOLM*MXAOLM + NDIM + 9*MXAOLM
        NEED1 = MAX(NEED1,NEED)
      END IF
C
      NEED  = NATOMS*NATOMS + NATOMS + NATOMS*NATOMS + NATOMS*NATOMS +
     +        NDIM*NDIM + NDIM
      NEED1 = MAX(NEED1,NEED)
C
      NEED  = NATOMS*NATOMS + NDIM*NDIM + NDIM
      NEED1 = MAX(NEED1,NEED)
C
      IF(JPRINT(9).NE.0) THEN
        NEED  = NATOMS*NATOMS + NDIM*NDIM + NDIM*NDIM + NDIM*(NDIM+5)
        NEED1 = MAX(NEED1,NEED)
      END IF
C
      NEED1 = NEED1 + NEED0
C
C  COMPUTE STORAGE FOR NATURAL BOND ORBITAL ANALYSIS:
C
      NEED2 = 0
      IF(JPRINT(1).EQ.0) THEN
        IF(IOINQR(IWTNAB).NE.IREAD) THEN
          NEED  = NATOMS*NATOMS + NDIM + 3*NDIM + MXAO*NDIM + NDIM
     +          + MXBO*MXBO + MXBO*MXBO + MXBO + MXBO + MXAO*MXAO
     +          + MXAO*MXAO + MXAO + MXAO + MXAO + NATOMS*NATOMS
        ELSE
          NEED  = NATOMS*NATOMS + NDIM + 3*NDIM
        END IF
        NEED2 = MAX(NEED2,NEED)
C
        IF(.NOT.ORTHO) THEN
          NEED  = NATOMS*NATOMS + 4*NDIM*NDIM + MXAO + 3*NDIM
          NEED2 = MAX(NEED2,NEED)
        END IF
C
        NEED  = NATOMS*NATOMS + NDIM + MXAO + NDIM*NDIM + NDIM*NDIM
     +        + NDIM + NDIM
        NEED2 = MAX(NEED2,NEED)
C
        NEED  = NATOMS*NATOMS + NDIM + NDIM + NDIM + NDIM*NDIM
        NEED2 = MAX(NEED2,NEED)
C
        IF(JPRINT(36).NE.0) THEN
          NEED  = NATOMS*NATOMS + NDIM + 3*NATOMS + NDIM*NDIM
     +          + NDIM*NDIM + NDIM
          NEED2 = MAX(NEED2,NEED)
        END IF
C
        NEED  = NATOMS*NATOMS + NDIM + NDIM*NDIM + NDIM*NDIM
     +        + NDIM*(NDIM+5)
        NEED2 = MAX(NEED2,NEED)
C
        IF(JPRINT(6).NE.0) THEN
          NEED  = NATOMS*NATOMS + NDIM + NDIM*NDIM + NDIM + NATOMS
     +          + NDIM
          NEED2 = MAX(NEED2,NEED)
        END IF
C
C  COMPUTE STORAGE FOR NATURAL LOCALIZED MOLECULAR ORBITAL ANALYSIS:
C
        NEED3 = 0
        IF(JPRINT(8).NE.0) THEN
          NEED  = NATOMS*NATOMS + NDIM + NDIM + NDIM*NDIM + NDIM*NDIM
          NEED3 = MAX(NEED3,NEED)
C
          NEED  = NDIM + NDIM + NDIM + NATOMS*NATOMS + 2*NATOMS*NATOMS
     +          + NDIM*NATOMS + NDIM*NATOMS*(NATOMS-1)/2 + NDIM*NDIM
          NEED3 = MAX(NEED3,NEED)
C
          NEED  = NATOMS*NATOMS + NDIM*NDIM + NDIM*NDIM + NDIM*(NDIM+5)
          NEED3 = MAX(NEED3,NEED)
C
          IF(JPRINT(46).NE.0) THEN
            NEED  = NDIM*NDIM + NDIM*NDIM + NDIM*NDIM + NDIM*NDIM
     +            + NDIM*NDIM + NDIM*NDIM + NDIM + NATOMS*NATOMS
            NEED3 = MAX(NEED3,NEED)
          END IF
        END IF
      END IF
C
C  PRINT SCRATCH STORAGE REQUIREMENTS:
C
      IF(IPRINT.GE.0) THEN
        IF(JPRINT(1).EQ.0) THEN
          IF(JPRINT(8).NE.0) THEN
            WRITE(LFNPR,3300) NEED1,NEED2,NEED3,MEMORY
          ELSE
            NEED3 = 0
            WRITE(LFNPR,3200) NEED1,NEED2,MEMORY
          END IF
        ELSE
          NEED2 = 0
          NEED3 = 0
          WRITE(LFNPR,3100) NEED1,MEMORY
        END IF
      END IF
      IF(NEED1.GT.MEMORY.OR.NEED2.GT.MEMORY.OR.NEED3.GT.MEMORY) GOTO 990
      RETURN
C
  990 WRITE(LFNPR,9900)
      STOP
C
 3100 FORMAT(/1X,'Storage needed:',I6,' in NPA (',I7,' available)')
 3200 FORMAT(/1X,'Storage needed:',I6,' in NPA,',I6,' in NBO (',I7,
     + ' available)')
 3300 FORMAT(/1X,'Storage needed:',I6,' in NPA,',I6,' in NBO,',I6,
     + ' in NLMO (',I7,' available)')
 9900 FORMAT(/1X,'*** Not enough core storage is available ***'/)
      END
C**************************************************************************
C
C  NAO/NBO/NLMO FORMATION ROUTINES: (CALLED BY SR NBO)
C
C      SUBROUTINE NAODRV(DM,T,A)
C      SUBROUTINE NAOSIM(DM,T,A)
C      SUBROUTINE DMNAO(DM,T,A)
C      SUBROUTINE DMSIM(DM,T,A)
C      SUBROUTINE NBODRV(DM,T,A,MEMORY)
C
C**************************************************************************
      SUBROUTINE NAODRV(DM,T,A)
C**************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  DRIVER SUBROUTINE TO CALCULATE NATURAL ATOMIC ORBITALS (NAOS)
C  GIVEN 1-PARTICLE DENSITY MATRIX IN AN ARBITRARY ATOM-CENTERED
C  ATOMIC ORBITAL BASIS SET.
C
C        T = OVERLAP MATRIX FOR THE PRIMITIVE AO BASIS
C             (ON RETURN, THIS IS THE AO TO NAO TRANSFORMATION MATRIX)
C       DM = DENSITY MATRIX IN THE PRIMITIVE AO BASIS
C               (OR BOND-ORDER MATRIX, IF IWDM = 1)
C
C   THE SPIN NATURE OF DM IS INDICATED BY:
C    ISPIN =  0: SPINLESS  (CLOSED SHELL)
C    ISPIN = +2: ALPHA SPIN
C    ISPIN = -2: SPIN
C   (ISPIN IS THE RECIPROCAL OF THE S(Z) QUANTUM NO.)
C
C        A = SCRATCH STORAGE FROM THE MAIN PROGRAM.  THE LOCATION OF A(1)
C               IS IN THE COMMON BLOCK /SCM/ IN THE MAIN PROGRAM,
C               AFTER THE STORAGE FOR THE MATRICES 'S','DM'
C             ('A' IS THE VECTOR WHICH IS PARTITIONED
C                   ACCORDING TO THE STORAGE NEEDS OF EACH PROGRAM RUN)
C     ATOM, BASIS, OPTION, NBINFO: COMMON BLOCKS WITH DATA TRANSFERED FROM
C        FROM THE INPUT PROGRAMS.
C
C-----------------------------------------------------------------------------
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
C
      DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(1)
      CHARACTER*80 TITLE
C
      DATA ONE/1.0D0/
      DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/
C
C  FORM LABELS FOR THE RAW AO BASIS SET:
C
      CALL LBLAO
C
C  COPY THE AO CENTERS AND LABELS FROM /NBAO/ TO /NBBAS/:
C
      DO 5 I = 1,NBAS
        LBL(I) = LCTR(I)
        LORBC(I) = LANG(I)
    5 CONTINUE
C
C  WRITE OUT THE AO BASIS SET INFORMATION:
C
      IF(JPRINT(22).GT.0) THEN
        CALL WRBAS(A,A,JPRINT(22))
      END IF
C
C  WRITE OUT THE ARCHIVE FILE:
C
      IF(JPRINT(7).NE.0) THEN
        CALL WRARC(A,A,JPRINT(7))
      END IF
C
C  OUTPUT THE AO OVERLAP MATRIX:
C
      IO = IOINQR(JPRINT(39))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'AO overlap matrix:'
        CALL AOUT(T,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(39))
      END IF
C
C  OUTPUT THE AO-MO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(26))
      IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
        CALL FEAOMO(A,IT)
        IF(IT.NE.0) THEN
          TITLE = 'MOs in the AO basis:'
          CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26))
        END IF
      END IF
C
C  OUTPUT THE AO FOCK MATRIX:
C
      IO = IOINQR(JPRINT(40))
      IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
        CALL FEFAO(A,IWFOCK)
        IF(IWFOCK.NE.0) THEN
          TITLE = 'AO Fock matrix:'
          CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40))
        END IF
      END IF
C
C  OUTPUT THE AO BOND-ORDER MATRIX:
C
      IO = IOINQR(JPRINT(42))
      IF(IWDM.EQ.1.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
        TITLE = 'Spinless AO bond-order matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(42))
      END IF
C
C  CONVERT THE BOND-ORDER MATRIX TO THE DENSITY MATRIX:
C
      IF(IWDM.NE.0) CALL SIMTRM(DM,T,A,NDIM,NBAS,IWMULP,IWCUBF)
C
C  OUTPUT THE AO DENSITY MATRIX:
C
      IO = IOINQR(JPRINT(27))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'Spinless AO density matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27))
      END IF
C
C  OUTPUT THE AO DIPOLE MATRICES:
C
      IO = IOINQR(JPRINT(50))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        IX = 1
        CALL FEDXYZ(A,IX)
        IF(IX.NE.0) THEN
          TITLE = 'AO x dipole integrals:'
          CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
        END IF
        IX = 2
        CALL FEDXYZ(A,IX)
        IF(IX.NE.0) THEN
          TITLE = 'AO y dipole integrals:'
          CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
        END IF
        IX = 3
        CALL FEDXYZ(A,IX)
        IF(IX.NE.0) THEN
          TITLE = 'AO z dipole integrals:'
          CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
        END IF
      END IF
C
C  ALLOCATE SCRATCH COMMON FOR NAO ROUTINES:
C
C  A(I1) = V(NDIM)  (ALSO USED FOR GUIDE(NATOMS,NATOMS))
C  A(I2) = RENORM(NDIM)
C  A(I3) = BLK(NDIM,NDIM)
C  A(I4) = SBLK(MXAOLM,MXAOLM)
C  A(I5) = EVAL(NDIM)
C  A(I6) = C(MXAOLM,MXAOLM)
C  A(I7) = EVECT(MXAOLM,MXAOLM)
C  A(I8) = EVAL2(NDIM)
C  LEAVE THIS LAST IN THE LIST SINCE THESE ARE INTEGERS:
C  A(I9) = LISTAO(MXAOLM,9)
C
      NBLOCK = MXAOLM*MXAOLM
      I1   = 1
      I2   = I1 + NDIM
      I3   = I2 + NDIM
      I4   = I3 + NDIM*NDIM
      I5   = I4 + NBLOCK
      I6   = I5 + NDIM
      I7   = I6 + NBLOCK
      I8   = I7 + NBLOCK
      I9   = I8 + NDIM
C     IEND = I9 + 9*MXAOLM
C
C  READ IN T-NAO, NAO LABELS, THE PNAO OVERLAP MATRIX, AND COMPUTE THE
C  NAO DENSITY MATRIX: (NOTE THAT T CONTAINS THE PNAO OVERLAP MATRIX
C  AFTER RDTNAO IS CALLED)
C
      IF(IOINQR(IWTNAO).EQ.IREAD) THEN
        CALL RDTNAO(DM,T,A(I1),IWTNAO)
        GO TO 580
      END IF
C
C  TRANSFORM ALL SETS OF CARTESIAN D,F,G ORBITALS, AND RELABEL ALL ORBITALS:
C
      CALL DFGORB(A(I2),DM,T,ICTRAN,IWCUBF,0,LFNPR)
C
C  STORE PURE AO DENSITY MATRIX IN SCRATCH STORAGE:
C
      CALL SVPPAO(DM)
C
C  CONSOLIDATE DENSITY MATRIX AND OVERLAP MATRIX IN DM:
C
      CALL CONSOL(DM,T,NDIM,NBAS)
C
C  FIND NATURAL ATOMIC ORBITAL BASIS SET TRANSFORMATION T FROM DM:
C  (UPON RETURN, DM CONTAINS THE FULL NAO DENSITY MATRIX)
C
      CALL NAO(T,DM,A(I1),A(I3),A(I4),A(I5),A(I6),A(I7),A(I8),A(I9),
     *         NBLOCK)
C
C  IF D ORBITALS WERE TRANSFORMED, TRANSFORM THE NAO TRANSFORMATION T
C  SO THAT T IS THE TRANSFORM FROM THE ORIGINAL AO'S TO THE NAO'S:
C
      IF(ICTRAN.NE.0) CALL DFGORB(A(I2),DM,T,IDTRAN,IWCUBF,1,LFNPR)
C
C  SAVE TNAO FOR LATER USE:
C
      CALL SVTNAO(T)
C
C  IF D ORBITALS WERE TRANSFORMED, TRANSFORM THE PNAO TRANSFORMATION
C  SO THAT IT IS THE TRANSFORM FROM THE ORIGINAL AO'S TO THE PNAO'S:
C
      CALL FEPNAO(A(I3))
C
C  FOR CASE THAT RPNAOS ARE WRITTEN TO DISK, SET OCCUPANCY WEIGHTS TO -1
C  AS A SIGNAL THAT THEY SHOULD BE RECOMPUTED:
C
      DO 260 I = 0,NBAS-1
  260   A(I4+I) = -ONE
C
      IF(ICTRAN.NE.0) CALL DFGORB(A(I2),DM,A(I3),IDTRAN,IWCUBF,1,LFNPR)
C
C  COMPUTE NON-ORTHOGONAL NAO OVERLAP MATRIX, SPNAO:
C
      CALL FESRAW(T)
      CALL SIMTRS(T,A(I3),A(I4),NDIM,NBAS)
      CALL SVSNAO(T)
C
C  WRITE T-NAO, NAO LABELS, AND THE PNAO OVERLAP MATRIX:
C
      IF(IOINQR(IWTNAO).EQ.IWRIT) CALL WRTNAO(T,IWTNAO)
C
C  DM IS NOW THE DENSITY MATRIX IN THE NAO BASIS
C  T IS THE NON-ORTHOGONAL PNAO OVERLAP MATRIX  (!!!)
C
  580 CONTINUE
      I1   = 1
      I2   = I1 + NATOMS*NATOMS
      I3   = I2 + NATOMS
      I4   = I3 + NATOMS*NATOMS
      I5   = I4 + NATOMS*NATOMS
      I6   = I5 + NDIM*NDIM
C     IEND = I6 + NDIM
      CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
C
C  DO NOT DESTROY THE MATRIX AT A(I1).  THIS HOLDS THE WIBERG BOND
C  INDEX WHICH NEEDS TO BE PASSED TO THE NBO ROUTINES.
C
C  SAVE THE NAO DENSITY MATRIX:
C
      CALL SVDNAO(DM)
C
C  FORM THE NAO LABELS:
C
      CALL LBLNAO
C
C  REORGANIZE THE SCRATCH VECTOR:
C
      I1   = 1
      I2   = I1 + NATOMS*NATOMS
C     IEND = I2 + NDIM*NDIM
C
C  OUTPUT THE AO-PNAO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(44))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEPNAO(T)
        TITLE = 'PNAOs in the AO basis:'
        CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(44))
      END IF
C
C  OUTPUT THE PNAO OVERLAP MATRIX:
C
      IO = IOINQR(JPRINT(19))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FESNAO(A(I2))
        TITLE = 'PNAO overlap matrix:'
        CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(19))
      END IF
C
C  FETCH THE AO-NAO TRANSFORMATION FROM THE NBO DAF:
C
      CALL FETNAO(T)
C
C  PRINT THE AO-NAO TRANSFORMATION MATRIX:
C
      IF(IOINQR(IWTNAO).EQ.IPRNT) THEN
        TITLE = 'NAOs in the AO basis:'
        CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IWTNAO)
      END IF
C
C  OUTPUT THE NAO DIPOLE MATRICES:
C
      IO = IOINQR(JPRINT(51))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        IX = 1
        CALL FEDXYZ(A(I2),IX)
        IF(IX.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NAO x dipole integrals:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51))
        END IF
        IX = 2
        CALL FEDXYZ(A(I2),IX)
        IF(IX.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NAO y dipole integrals:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51))
        END IF
        IX = 3
        CALL FEDXYZ(A(I2),IX)
        IF(IX.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NAO z dipole integrals:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(51))
        END IF
      END IF
C
C  IF THIS IS AN OPEN SHELL WAVEFUNCTION, DON'T DO ANYTHING MORE:
C
      IF(OPEN) RETURN
C
C  OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(9))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        I1   = 1
        I2   = I1 + NATOMS*NATOMS
        I3   = I2 + NDIM*NDIM
        I4   = I3 + NDIM*NDIM
C       IEND = I4 + NDIM*(NDIM+5)
        CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
      END IF
C
C  REORGANIZE THE SCRATCH VECTOR:
C
      I1   = 1
      I2   = I1 + NATOMS*NATOMS
      I3   = I2 + NDIM*NDIM
C     IEND = I3 + NDIM
C
C  OUTPUT THE NAO FOCK MATRIX:
C
      IO = IOINQR(JPRINT(31))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEFAO(A(I2),IWFOCK)
        IF(IWFOCK.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NAO Fock matrix:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31))
        END IF
      END IF
C
C  OUTPUT THE NAO DENSITY MATRIX:
C
      IO = IOINQR(JPRINT(35))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'NAO density matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35))
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE NAOSIM(DM,T,A)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
C
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1)
      CHARACTER*80 TITLE
C
      DATA ZERO,ONE/0.0D0,1.0D0/
      DATA IPRNT,IWRIT/4HPRNT,4HWRIT/
C
C  THIS ROUTINE SIMULATES THE ACTION OF THE NAO SUBPROGRAM:
C
C  FORM LABELS FOR THE RAW AO BASIS SET:
C
      CALL LBLAO
C
C  COPY THE AO CENTERS AND LABELS FROM /NBAO/ TO /NBBAS/:
C
      DO 5 I = 1,NBAS
        LBL(I) = LCTR(I)
        LORBC(I) = LANG(I)
    5 CONTINUE
C
C  WRITE OUT THE AO BASIS SET INFORMATION:
C
      IF(JPRINT(22).GT.0) THEN
        CALL WRBAS(A,A,JPRINT(22))
      END IF
C
C  WRITE OUT THE ARCHIVE FILE:
C
      IF(JPRINT(7).NE.0) THEN
        CALL WRARC(A,A,JPRINT(7))
      END IF
C
C  OUTPUT THE AO-MO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(26))
      IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
        CALL FEAOMO(A,IT)
        IF(IT.NE.0) THEN
          TITLE = 'MOs in the AO basis:'
          CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26))
        END IF
      END IF
C
C  OUTPUT THE AO FOCK MATRIX:
C
      IO = IOINQR(JPRINT(40))
      IF(.NOT.OPEN.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
        CALL FEFAO(A,IWFOCK)
        IF(IWFOCK.NE.0) THEN
          TITLE = 'AO Fock matrix:'
          CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40))
        END IF
      END IF
C
C  OUTPUT THE AO DENSITY MATRIX:
C
      IO = IOINQR(JPRINT(27))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'Spinless AO density matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27))
      END IF
C
C  OUTPUT THE AO DIPOLE MATRICES:
C
      IO = IOINQR(JPRINT(50))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        IX = 1
        CALL FEDXYZ(A,IX)
        IF(IX.NE.0) THEN
          TITLE = 'AO x dipole integrals:'
          CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
        END IF
        IX = 2
        CALL FEDXYZ(A,IX)
        IF(IX.NE.0) THEN
          TITLE = 'AO y dipole integrals:'
          CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
        END IF
        IX = 3
        CALL FEDXYZ(A,IX)
        IF(IX.NE.0) THEN
          TITLE = 'AO z dipole integrals:'
          CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(50))
        END IF
      END IF
C
C  INITIALIZE THE AO TO NAO TRANSFORMATION MATRIX (UNIT MATRIX):
C
      DO 20 J = 1,NBAS
        DO 10 I = 1,NBAS
          T(I,J) = ZERO
   10   CONTINUE
        T(J,J) = ONE
   20 CONTINUE
C
C  SAVE TNAO FOR LATER USE:
C
      CALL SVTNAO(T)
C
C  FILL ATOMIC ORBITAL INFORMATION LISTS:
C
      DO 30 I = 1,NBAS
        NAOCTR(I) = LCTR(I)
        NAOL(I)   = LANG(I)
        LSTOCC(I) = 1
   30 CONTINUE
C
C  PERFORM THE NATURAL POPULATION ANALYSIS: (NOTE THAT ROUTINE NAOANL
C  EXPECTS TO FIND THE OVERLAP MATRIX IN T, WHICH IS THE UNIT MATRIX
C  FOR ORTHOGONAL BASIS SETS. UPON RETURN FROM NAOANL, T IS THE AO TO
C  NAO TRANSFORMATION, WHICH IS STILL A UNIT MATRIX):
C
      I1   = 1
      I2   = I1 + NATOMS*NATOMS
      I3   = I2 + NATOMS
      I4   = I3 + NATOMS*NATOMS
      I5   = I4 + NATOMS*NATOMS
      I6   = I5 + NDIM*NDIM
C     IEND = I6 + NDIM
      CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
C
C  DO NOT DESTROY THE MATRIX AT A(I1).  THIS HOLDS THE WIBERG BOND
C  INDEX WHICH NEEDS TO BE PASSED TO THE NBO ROUTINES.
C
C  SAVE THE NAO DENSITY MATRIX:
C
      CALL SVDNAO(DM)
C
C  FORM THE NAO LABELS:
C
      CALL LBLNAO
C
C  IF THIS IS AN OPEN SHELL WAVEFUNCTION, DON'T DO ANYTHING MORE:
C
      IF(OPEN) RETURN
C
C  OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(9))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        I1   = 1
        I2   = I1 + NATOMS*NATOMS
        I3   = I2 + NDIM*NDIM
        I4   = I3 + NDIM*NDIM
C       IEND = I4 + NDIM*(NDIM+5)
        CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
      END IF
C
C  REORGANIZE THE SCRATCH VECTOR:
C
      I1   = 1
      I2   = I1 + NATOMS*NATOMS
      I3   = I2 + NDIM*NDIM
C     IEND = I3 + NDIM
C
C  OUTPUT THE NAO FOCK MATRIX:
C
      IO = IOINQR(JPRINT(31))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEFAO(A(I2),IWFOCK)
        IF(IWFOCK.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NAO Fock matrix:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31))
        END IF
      END IF
C
C  OUTPUT THE NAO DENSITY MATRIX:
C
      IO = IOINQR(JPRINT(35))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'NAO density matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35))
      END IF
      RETURN
      END
C**************************************************************************
      SUBROUTINE DMNAO(DM,T,A)
C**************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
      COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS)
C
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1)
      CHARACTER*80 TITLE
C
      DATA IPRNT,IWRIT/4HPRNT,4HWRIT/
C
C  PLACE ALPHA OR BETA OCCUPATION MATRIX IN DM AND TRANSFORM FROM THE AO
C  TO NAO BASIS:
C
      IF(ALPHA) THEN
        IF(JPRINT(4).NE.0) WRITE(LFNPR,2100)
      ELSE
        DO 70 I = 1,NBAS
          NAOCTR(I) = NAOC(I)
          NAOL(I) = NAOA(I)
          LBL(I) = LCTR(I)
          LORBC(I) = LANG(I)
   70   CONTINUE
        CALL FETNAO(T)
        IF(JPRINT(4).NE.0) WRITE(LFNPR,2200)
      END IF
C
C  OUTPUT THE AO-MO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(26))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEAOMO(A,IT)
        IF(IT.NE.0) THEN
          TITLE = 'MOs in the AO basis:'
          CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26))
        END IF
      END IF
C
C  OUTPUT THE AO FOCK MATRIX:
C
      IO = IOINQR(JPRINT(40))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEFAO(A,IWFOCK)
        IF(IWFOCK.NE.0) THEN
          TITLE = 'AO Fock matrix:'
          CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40))
        END IF
      END IF
C
C  FETCH ALPHA OR BETA DM (ACCORDING TO WHETHER ALPHA OR BETA IS TRUE):
C
      CALL FEDRAW(DM,A)
C
C  OUTPUT THE AO BOND-ORDER MATRIX:
C
      IO = IOINQR(JPRINT(42))
      IF(IWDM.NE.0.AND.(IO.EQ.IPRNT.OR.IO.EQ.IWRIT)) THEN
        TITLE = 'AO bond-order matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(42))
      END IF
C
C  CONVERT THE BOND-ORDER MATRIX TO THE DENSITY MATRIX:
C
      IF(IWDM.NE.0) THEN
        I1   = 1
        I2   = I1 + NDIM*NDIM
C       IEND = I2 + NDIM*NDIM
        CALL FESRAW(A(I1))
        CALL SIMTRM(DM,A(I1),A(I2),NDIM,NBAS,IWMULP,IWCUBF)
      END IF
C
C  OUTPUT THE AO DENSITY MATRIX:
C
      IO = IOINQR(JPRINT(27))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'AO density matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27))
      END IF
C
C  TRANSFORM DM TO THE NAO BASIS:
C
      CALL SIMTRS(DM,T,A,NDIM,NBAS)
C
C  SAVE THE NAO DENSITY MATRIX IN SCRATCH STORAGE:
C
      CALL SVDNAO(DM)
C
C  PRINT THE NATURAL POPULATION ANALYSIS FOR THIS SPIN CASE:
C
      I1   = 1
      I2   = I1 + NATOMS*NATOMS
      I3   = I2 + NATOMS
      I4   = I3 + NATOMS*NATOMS
      I5   = I4 + NATOMS*NATOMS
      I6   = I5 + NDIM*NDIM
C     IEND = I6 + NDIM
      CALL FESNAO(T)
      CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
C
C  NOTE: DO NOT DESTROY THE WIBERG BOND INDEX WHICH IS STORED IN THE FIRST
C  NATOMS*NATOMS ELEMENTS OF THE SCRATCH VECTOR A.  THIS IS MATRIX IS
C  REQUIRED FOR THE NBO ANALYSIS:
C
C  NOTE THAT T IS NOW T-AO-NAO:
C
C  FORM THE NAO LABELS:
C
      CALL LBLNAO
C
C  OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(9))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        I1   = 1
        I2   = I1 + NATOMS*NATOMS
        I3   = I2 + NDIM*NDIM
        I4   = I3 + NDIM*NDIM
C       IEND = I4 + NDIM*(NDIM+5)
        CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
      END IF
C
C  REORGANIZE THE SCRATCH VECTOR:
C
      I1   = 1
      I2   = I1 + NATOMS*NATOMS
      I3   = I2 + NDIM*NDIM
C     IEND = I3 + NDIM
C
C  OUTPUT THE NAO FOCK MATRIX:
C
      IO = IOINQR(JPRINT(31))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEFAO(A(I2),IWFOCK)
        IF(IWFOCK.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NAO Fock matrix:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31))
        END IF
      END IF
C
C  OUTPUT THE NAO DENSITY MATRIX:
C
      IO = IOINQR(JPRINT(35))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'NAO density matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35))
      END IF
      RETURN
C
 2100 FORMAT(//1X,
     * '***************************************************',/1X,
     * '*******         Alpha spin orbitals         *******',/1X,
     * '***************************************************')
 2200 FORMAT(//1X,
     * '***************************************************',/1X,
     * '*******         Beta  spin orbitals         *******',/1X,
     * '***************************************************')
      END
C**************************************************************************
      SUBROUTINE DMSIM(DM,T,A)
C**************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
      COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS)
C
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),A(1)
      CHARACTER*80 TITLE
C
      DATA IPRNT,IWRIT/4HPRNT,4HWRIT/
C
C  SIMULATE THE ALPHA/BETA NAO SUBPROGRAM:
C
      IF(ALPHA) THEN
        IF(JPRINT(4).NE.0) WRITE(LFNPR,2100)
      ELSE
        DO 70 I = 1,NBAS
          NAOCTR(I) = NAOC(I)
          NAOL(I) = NAOA(I)
          LBL(I) = LCTR(I)
          LORBC(I) = LANG(I)
   70   CONTINUE
        CALL FETNAO(T)
        IF(JPRINT(4).NE.0) WRITE(LFNPR,2200)
      END IF
C
C  OUTPUT THE AO-MO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(26))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEAOMO(A,IT)
        IF(IT.NE.0) THEN
          TITLE = 'MOs in the AO basis:'
          CALL AOUT(A,NDIM,NBAS,NBAS,TITLE,1,JPRINT(26))
        END IF
      END IF
C
C  OUTPUT THE AO FOCK MATRIX:
C
      IO = IOINQR(JPRINT(40))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEFAO(A,IWFOCK)
        IF(IWFOCK.NE.0) THEN
          TITLE = 'AO Fock matrix:'
          CALL AOUT(A,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(40))
        END IF
      END IF
C
C  FETCH ALPHA OR BETA DM (ACCORDING TO WHETHER ALPHA OR BETA IS TRUE):
C
      CALL FEDRAW(DM,A)
C
C  OUTPUT THE AO DENSITY MATRIX:
C
      IO = IOINQR(JPRINT(27))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'AO density matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,1,JPRINT(27))
      END IF
C
C  SAVE THE NAO DENSITY MATRIX IN SCRATCH STORAGE:
C
      CALL SVDNAO(DM)
C
C  PRINT THE NATURAL POPULATION ANALYSIS FOR THIS SPIN CASE:
C
      I1   = 1
      I2   = I1 + NATOMS*NATOMS
      I3   = I2 + NATOMS
      I4   = I3 + NATOMS*NATOMS
      I5   = I4 + NATOMS*NATOMS
      I6   = I5 + NDIM*NDIM
C     IEND = I6 + NDIM
      CALL NAOANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6))
C
C  NOTE: DO NOT DESTROY THE WIBERG BOND INDEX WHICH IS STORED IN THE FIRST
C  NATOMS*NATOMS ELEMENTS OF THE SCRATCH VECTOR A.  THIS IS MATRIX IS
C  REQUIRED FOR THE NBO ANALYSIS:
C
C  FORM THE NAO LABELS:
C
      CALL LBLNAO
C
C  OUTPUT THE NAO-MO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(9))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        I1   = 1
        I2   = I1 + NATOMS*NATOMS
        I3   = I2 + NDIM*NDIM
        I4   = I3 + NDIM*NDIM
C       IEND = I4 + NDIM*(NDIM+5)
        CALL FRMTMO(T,A(I2),A(I3),A(I4),2,JPRINT(9))
      END IF
C
C  REORGANIZE THE SCRATCH VECTOR:
C
      I1   = 1
      I2   = I1 + NATOMS*NATOMS
      I3   = I2 + NDIM*NDIM
C     IEND = I3 + NDIM
C
C  OUTPUT THE NAO FOCK MATRIX:
C
      IO = IOINQR(JPRINT(31))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEFAO(A(I2),IWFOCK)
        IF(IWFOCK.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NAO Fock matrix:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,2,JPRINT(31))
        END IF
      END IF
C
C  PRINT THE NAO DENSITY MATRIX:
C
      IO = IOINQR(JPRINT(35))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'NAO density matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,2,JPRINT(35))
      END IF
      RETURN
C
 2100 FORMAT(//1X,
     * '***************************************************',/1X,
     * '*******         Alpha spin orbitals         *******',/1X,
     * '***************************************************')
 2200 FORMAT(//1X,
     * '***************************************************',/1X,
     * '*******         Beta  spin orbitals         *******',/1X,
     * '***************************************************')
      END
C**************************************************************************
      SUBROUTINE NBODRV(DM,T,A,MEMORY)
C**************************************************************************
C
C  DRIVER SUBROUTINE TO CALCULATE NATURAL HYBRID ORBITALS (NHOS) AND
C  NATURAL BOND ORBITALS (NBOS) FROM THE DENSITY MATRIX IN THE NAO BASIS
C
C        T = SCRATCH STORAGE
C       DM = NAO DENSITY MATRIX
C            THE SPIN NATURE OF DM IS INDICATED BY:
C            ISPIN =  0: SPINLESS  (CLOSED SHELL)
C            ISPIN = +2: ALPHA SPIN
C            ISPIN = -2: SPIN
C            (ISPIN IS THE RECIPROCAL OF THE S(Z) QUANTUM NO.)
C
C        A = SCRATCH STORAGE FROM THE MAIN PROGRAM.  THE LOCATION OF A(1)
C               IS IN THE COMMON BLOCK /SCM/ IN THE MAIN PROGRAM,
C               AFTER THE STORAGE FOR THE MATRICES 'S','DM'
C             ('A' IS THE VECTOR WHICH IS PARTITIONED
C                   ACCORDING TO THE STORAGE NEEDS OF EACH PROGRAM RUN)
C     ATOM, BASIS, OPTION, NBINFO: COMMON BLOCKS WITH DATA TRANSFERED FROM
C        FROM THE INPUT PROGRAMS.
C
C-----------------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*80 TITLE
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM),
     +              NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM)
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
C
      DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(1)
C
      DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/
      DATA ZERO/0.0D0/
C
C  SKIP NBO TRANSFORMATION IF REQUESTED:
C
      IF(JPRINT(1).GT.0) THEN
        WRITE(LFNPR,2000)
        RETURN
      END IF
C
C  ORGANIZE SCRATCH STORAGE VECTOR A.  WARNING:  THIS IS REDEFINED
C  SEVERAL TIMES AFTER THE NBOS ARE FORMED
C
C  A(I0)  = GUIDE(NATOMS,NATOMS)
C  A(I1)  = BNDOCC(NDIM)
C  A(I2)  = POL(NDIM,3)
C  A(I3)  = Q(MXAO,NDIM)
C  A(I4)  = V(NDIM)
C  A(I5)  = BLK(MXBO,MXBO)
C  A(I6)  = C(MXBO,MXBO)
C  A(I7)  = EVAL(MXBO)
C  A(I8)  = BORB(MXBO)
C  A(I9)  = P(MXAO,MXAO)
C  A(I10) = PK(MXAO,MXAO)
C  A(I11) = HYB(MXAO)
C  A(I12) = VA(MXAO)
C  A(I13) = VB(MXAO)
C
      I0   = 1
      I1   = I0  + NATOMS*NATOMS
      I2   = I1  + NDIM
      I3   = I2  + 3*NDIM
      I4   = I3  + MXAO*NDIM
      I5   = I4  + NDIM
      I6   = I5  + MXBO*MXBO
      I7   = I6  + MXBO*MXBO
      I8   = I7  + MXBO
      I9   = I8  + MXBO
      I10  = I9  + MXAO*MXAO
      I11  = I10 + MXAO*MXAO
      I12  = I11 + MXAO
      I13  = I12 + MXAO
      I14  = I13 + MXAO
C     IEND = I14 + NATOMS*NATOMS
C
      IF(JPRINT(5).NE.0.AND.ISPIN.EQ.0) WRITE(LFNPR,1400)
      IF(JPRINT(5).NE.0.AND.ISPIN.EQ.2) WRITE(LFNPR,1410)
      IF(JPRINT(5).NE.0.AND.ISPIN.EQ.-2) WRITE(LFNPR,1420)
C
C  READ IN T-NAB, LABEL, IBXM, TRANSFORM DM, AND FIND BNDOCC IF IWTNAB=IREAD:
C
      IF(IOINQR(IWTNAB).EQ.IREAD) THEN
        CALL RDTNAB(T,DM,A(I1),A(I2),IWTNAB)
      ELSE
C
C  SEARCH INPUT FILE FOR $CORE INPUT:
C
        IF(.NOT.BETA) THEN
          CALL CORINP(JPRINT(2),JCORE)
          CALL RDCORE(JCORE)
        END IF
C
C  SEARCH INPUT FILE FOR $CHOOSE INPUT:
C
        IF(.NOT.BETA) THEN
          CALL CHSINP(JPRINT(2),ICHOOS)
          IF(OPEN.AND.ICHOOS.EQ.1.AND.JPRINT(32).NE.0) THEN
            WRITE(LFNPR,1390)
            ICHOOS = 0
          END IF
        END IF
C
C  CALCULATE NATURAL HYBRID ORBITALS AND BOND ORBITALS:
C
        IF(ICHOOS.NE.1) CALL NATHYB(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4),
     +                            A(I5),A(I6),A(I7),A(I8),A(I9),A(I10),
     +                            A(I11),A(I12),A(I13),A(I14))
        IF(ICHOOS.EQ.1) CALL CHSDRV(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4),
     +                            A(I5),A(I6),A(I7),A(I8),A(I9),A(I10),
     +                            A(I11),A(I12),A(I13),A(I14))
C
C  IF NBO SEARCH WAS ABANDONED, DON'T TRY TO DO ANYTHING FURTHER:
C
        IF(JPRINT(1).LT.0) RETURN
C
C  SORT THE NBOS BY ATOM:
C
        CALL SRTNBO(T,A(I1))
C
C  FORM THE NBO DENSITY MATRIX:
C
        CALL SIMTRS(DM,T,A(I2),NDIM,NBAS)
C
C  CHECK NHO OVERLAPS TO SEE IF BOND ORBITALS SHOULD BE RELABELLED:
C
        IF(.NOT.ORTHO) THEN
          I0   = 1
          I1   = I0 + NATOMS*NATOMS
          I2   = I1 + NDIM
          I3   = I2 + MXAO
          I4   = I3 + NDIM*NDIM
          I5   = I4 + NDIM*NDIM
          I6   = I5 + NDIM
C         IEND = I6 + NDIM
          CALL XCITED(DM,T,A(I2),A(I3),A(I4),A(I5),A(I6),A(I6))
        END IF
      END IF
C
C  T  NOW CONTAINS THE NAO-NBO TRANSFORMATION MATRIX
C  DM NOW CONTAINS THE NBO DENSITY MATRIX
C  A(I0)  CONTAINS THE WIBERG BOND INDEX MATRIX      ! DON'T DESTROY THIS
C  A(I1)  CONTAINS THE NBO OCCUPANCIES               ! DON'T DESTROY THIS
C  A(I2)  IS SCRATCH SPACE
C
C  SAVE THE NAO-NBO TRANSFORMATION ON THE NBO DAF:
C
      CALL SVTNAB(T)
C
C  FORM THE NBO LABELS:
C
      CALL LBLNBO
C
C  WRITE OUT THE ANALYSIS OF BOND ORBITALS:
C
      I0   = 1
      I1   = I0 + NATOMS*NATOMS
      I2   = I1 + NDIM
      I3   = I2 + NDIM
      I4   = I3 + NDIM
C     IEND = I4 + NDIM*NDIM
      CALL ANLYZE(T,A(I1),A(I2),A(I3),A(I4))
C
C  WRITE OUT HYBRID DIRECTIONALITY AND BOND BENDING INFO:
C
      IF(JPRINT(36).NE.0) THEN
        I0   = 1
        I1   = I0 + NATOMS*NATOMS
        I2   = I1 + NDIM
        I3   = I2 + 3*NATOMS
        I4   = I3 + NDIM*NDIM
        I5   = I4 + NDIM*NDIM
C       IEND = I5 + NDIM
        CALL HYBDIR(A(I1),A(I2),A(I3),A(I4),A(I5))
      END IF
C
C  FIND MOLECULAR UNITS:
C
      CALL FNDMOL(A(I2))
C
C  CLASSIFY ALL THE NBOS ACCORDING TO DONOR/ACCEPTOR TYPE:
C
      CALL NBOCLA(A(I1),ACCTHR)
C
C  OUTPUT TRANSFORMATION MATRICES FOR THE PNHO AND NHO BASIS SETS,
C  AND THE NHO DENSITY MATRIX, NHO FOCK MATRIX, AND NHO DIPOLE MATRICES:
C
C  THE SECTION OF THE CODE MAKES USE OF T AND DM.  THESE MATRICES
C  WILL BE RESTORED LATER:  [NOTE: DO NOT DESTROY INFO ALREADY STORED
C  IN A(I0) AND A(I1)]
C
C  REORGANIZE THE SCRATCH VECTOR:
C
      I0   = 1
      I1   = I0 + NATOMS*NATOMS
      I2   = I1 + NDIM
      I3   = I2 + NDIM*NDIM
      I4   = I3 + NDIM*NDIM
C     IEND = I4 + NDIM*(NDIM+5)
C
C  OUTPUT THE AO-PNHO TRANSFORMATION AND THE PNHO OVERLAP MATRIX:
C
      IO = IOINQR(JPRINT(20))
      JO = IOINQR(JPRINT(30))
      IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR.
     +   (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN
        CALL FEPNAO(T)
        CALL FETNHO(A(I2))
        CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
        CALL FESRAW(A(I2))
        CALL NORMLZ(T,A(I2),NDIM,NBAS)
        IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN
          TITLE = 'PNHOs in the AO basis:'
          CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(30))
        END IF
        IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'PNHO overlap matrix:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(20))
        END IF
      ENDIF
C
C  FORM THE AO-NHO TRANSFORMATION MATRIX:
C
      CALL FETNAO(T)
      CALL FETNHO(A(I2))
      CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
C
C  OUTPUT THE AO-NHO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(28))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'NHOs in the AO basis:'
        CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(28))
      END IF
C
C  OUTPUT THE NAO-NHO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(33))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FETNHO(A(I2))
        TITLE = 'NHOs in the NAO basis:'
        CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,2,JPRINT(33))
      END IF
C
C  OUTPUT THE NHO-MO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(38))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FRMTMO(T,A(I2),A(I3),A(I4),3,JPRINT(38))
      END IF
C
C  OUTPUT THE NHO DENSITY MATRIX:
C
      IO = IOINQR(JPRINT(34))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEDRAW(DM,A(I2))
        IF(IWDM.EQ.1) THEN
          CALL FESRAW(A(I2))
          CALL SIMTRS(DM,A(I2),A(I3),NDIM,NBAS)
        END IF
        CALL SIMTRS(DM,T,A(I2),NDIM,NBAS)
        TITLE = 'NHO density matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,3,JPRINT(34))
      END IF
C
C  OUTPUT THE NHO FOCK MATRIX:
C
      IO = IOINQR(JPRINT(29))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FEFAO(A(I2),IWFOCK)
        IF(IWFOCK.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NHO Fock matrix:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(29))
        END IF
      END IF
C
C  OUTPUT THE NHO DIPOLE MATRICES:
C
      IO = IOINQR(JPRINT(52))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        IX = 1
        CALL FEDXYZ(A(I2),IX)
        IF(IX.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NHO x dipole integrals:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52))
        END IF
        IX = 2
        CALL FEDXYZ(A(I2),IX)
        IF(IX.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NHO y dipole integrals:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52))
        END IF
        IX = 3
        CALL FEDXYZ(A(I2),IX)
        IF(IX.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NHO z dipole integrals:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,3,JPRINT(52))
        END IF
      END IF
C
C  OUTPUT TRANSFORMATION MATRICES FOR THE PNBO AND NBO BASIS SETS,
C  AND THE NBO DENSITY MATRIX, NBO FOCK MATRIX, AND NBO DIPOLE MATRICES:
C
C  [NOTE: DO NOT DESTROY INFO ALREADY STORED IN A(I0) AND A(I1)]
C
C  REORGANIZE THE SCRATCH VECTOR:
C
      I0   = 1
      I1   = I0 + NATOMS*NATOMS
      I2   = I1 + NDIM
      I3   = I2 + NDIM*NDIM
      I4   = I3 + NDIM*NDIM
C     IEND = I4 + NDIM*(NDIM+5)
C
C  OUTPUT THE AO-PNBO TRANSFORMATION AND THE PNBO OVERLAP MATRIX:
C
      IO = IOINQR(JPRINT(21))
      JO = IOINQR(JPRINT(25))
      IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR.
     +   (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN
        CALL FEPNAO(T)
        CALL FETNAB(A(I2))
        CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
        CALL FESRAW(A(I2))
        CALL NORMLZ(T,A(I2),NDIM,NBAS)
        IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN
          TITLE = 'PNBOs in the AO basis:'
          CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(25))
        END IF
        IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'PNBO overlap matrix:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(21))
        END IF
      END IF
C
C  FORM THE AO-NBO TRANSFORMATION MATRIX:
C
      CALL FETNAO(T)
      CALL FETNAB(A(I2))
      CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
C
C  SAVE THE AO-NBO TRANSFORMATION, NBO OCCS, AND NBO LABELS ON NBO DAF:
C
      CALL SVNBO(T,A(I1),A(I2))
C
C  WRITE THE AO-NBO TRANSFORMATION WITH NBO LABELS AND OCCUPANCIES:
C
      IF(IOINQR(IWTNBO).EQ.IWRIT) CALL WRTNBO(T,A(I1),IWTNBO)
C
C  PRINT THE AO-NBO TRANSFORMATION MATRIX:
C
      IF(IOINQR(IWTNBO).EQ.IPRNT) THEN
        TITLE = 'NBOs in the AO basis:'
        CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IWTNBO)
      END IF
C
C  WRITE THE NAO-NBO TRANSFORMATION MATRIX:
C
      IF(IOINQR(IWTNAB).EQ.IWRIT) THEN
        CALL FETNAB(A(I2))
        CALL WRTNAB(A(I2),IWTNAB)
      END IF
C
C  PRINT THE NAO-NBO TRANSFORMATION TO THE OUTPUT FILE:
C
      IF(IOINQR(IWTNAB).EQ.IPRNT) THEN
        CALL FETNAB(A(I2))
        TITLE = 'NBOs in the NAO basis:'
        CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,2,IWTNAB)
      END IF
C
C  OUTPUT THE NHO-NBO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(41))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FETNHO(A(I2))
        CALL TRANSP(A(I2),NDIM,NBAS)
        CALL FETNAB(A(I3))
        CALL MATMLT(A(I2),A(I3),A(I4),NDIM,NBAS)
        TITLE = 'NBOs in the NHO basis:'
        CALL AOUT(A(I2),NDIM,NBAS,NBAS,TITLE,3,JPRINT(41))
      END IF
C
C  OUTPUT THE NBO-MO TRANSFORMATION MATRIX:
C
      IO = IOINQR(JPRINT(45))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        CALL FRMTMO(T,A(I2),A(I3),A(I4),4,JPRINT(45))
      END IF
C
C  FORM THE NBO DENSITY MATRIX:
C
      CALL FEDRAW(DM,A(I2))
      IF(IWDM.EQ.1.AND..NOT.ORTHO) THEN
        CALL FESRAW(A(I2))
        CALL SIMTRS(DM,A(I2),A(I3),NDIM,NBAS)
      END IF
      CALL SIMTRS(DM,T,A(I2),NDIM,NBAS)
C
C  OUTPUT THE NBO DENSITY MATRIX:
C
      IO = IOINQR(JPRINT(16))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        TITLE = 'NBO density matrix:'
        CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,4,JPRINT(16))
      END IF
C
C  OUTPUT THE NBO FOCK MATRIX:
C
      CALL FEFAO(A(I2),IWFOCK)
      IF(IWFOCK.NE.0) THEN
        CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
        CALL SVFNBO(A(I2))
        IO = IOINQR(JPRINT(37))
        IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
          TITLE = 'NBO Fock matrix:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(37))
        END IF
      END IF
C
C  OUTPUT THE NBO DIPOLE MATRICES:
C
      IO = IOINQR(JPRINT(53))
      IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
        IX = 1
        CALL FEDXYZ(A(I2),IX)
        IF(IX.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NBO x dipole integrals:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53))
        END IF
        IX = 2
        CALL FEDXYZ(A(I2),IX)
        IF(IX.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NBO y dipole integrals:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53))
        END IF
        IX = 3
        CALL FEDXYZ(A(I2),IX)
        IF(IX.NE.0) THEN
          CALL SIMTRS(A(I2),T,A(I3),NDIM,NBAS)
          TITLE = 'NBO z dipole integrals:'
          CALL AOUT(A(I2),NDIM,-NBAS,NBAS,TITLE,4,JPRINT(53))
        END IF
      END IF
C
C  PERFORM PERTURBATIVE ANALYSIS OF THE NBO FOCK MATRIX:
C
      IF(JPRINT(3).EQ.1.AND.IWFOCK.NE.0) CALL FNBOAN(A(I1),A(I2),A(I3))
C
C  PRINT THE NBO SUMMARY:
C
      IF(JPRINT(6).EQ.1) THEN
        I0   = 1
        I1   = I0 + NATOMS*NATOMS
        I2   = I1 + NDIM
        I3   = I2 + NDIM*NDIM
        I4   = I3 + NDIM
        I5   = I4 + NATOMS
C       IEND = I5 + NDIM
        CALL NBOSUM(A(I2),A(I1),A(I3),A(I4),A(I5))
      END IF
C
C  CONTINUE WITH THE CONSTRUCTION OF THE NLMOS:
C
      IF(JPRINT(8).NE.0) THEN
C
C  STORE IN A(I0) THE VECTOR RESON(NDIM), THE SQUARES OF THE DIAGONAL 
C  ELEMENTS OF THE NBO TO NLMO TRANSFORMATION MATRIX.  IALARM SOUNDS
C  THE ALARM THAT THE NLMO STEP IS TO BE SKIPPED:
C
C   DM   : NBO DENSITY         ! TRANSFORMED TO NLMO BASIS ON RETURN
C   A(I0): RESON(NDIM)         ! PERCENTAGES OF PARENT NBO
C   A(I1): LMOOCC(NDIM)        ! NLMO OCCUPANCIES
C   A(I2): TNLMO(NDIM,NDIM)    ! NBO-NLMO TRANSFORM
C   A(I3): TSYM                ! SCRATCH
C
C  (DO NOT DESTROY THE WIBERG BOND INDEX!)
C
        I0   = 1 + NATOMS*NATOMS
        I1   = I0 + NDIM
        I2   = I1 + NDIM
        I3   = I2 + NDIM*NDIM
C       IEND = I3 + NDIM*NDIM
        CALL NLMO(NBAS,DM,A(I1),A(I2),A(I3),A(I0),NOCC,IALARM)
        IF(IALARM.NE.0) RETURN
C
C  SAVE THE NBO TO NLMO TRANSFORMATION MATRIX ON THE NBO DAF:
C
        CALL SVTLMO(A(I2))
C
C  FORM THE NAO TO NLMO TRANSFORMATION IN T:
C
        CALL FETNAB(T)
        CALL MATMLT(T,A(I2),A(I3),NDIM,NBAS)
C
C  SET UP STORAGE FOR LMOANL:
C
C   A(I0): RESON(NDIM)
C   A(I1): LMOOCC(NDIM)
C   A(I2): TS(NDIM)
C   A(I3): BORDER(NATOMS,NATOMS)
C   A(I4): OWBORD(NATOMS,NATOMS)
C   A(I5): ATLMO(NOCC,NATOMS)
C   A(I6): SIAB(NOCC,NAB)
C
C  (DO NOT DESTROY THE WIBERG BOND INDEX!)
C
        NAB = NATOMS*(NATOMS-1)/2
        IF(NATOMS.EQ.1) NAB = 1
        I0   = 1 + NATOMS*NATOMS
        I1   = I0 + NDIM
        I2   = I1 + NDIM
        I3   = I2 + NDIM
        I4   = I3 + NATOMS*NATOMS
        I5   = I4 + NATOMS*NATOMS
        I6   = I5 + NOCC*NATOMS
        I7   = I6 + NOCC*NAB
C       IEND = I7 + NDIM*NDIM
        CALL COPY(DM,A(I7),NDIM,NBAS,NBAS)
        CALL LMOANL(T,A(I7),A(I0),A(I1),A(I2),A(I3),A(I4),A(I5),
     +              A(I6),NOCC,NAB)
C
C  OUTPUT TRANSFORMATION MATRICES FOR THE PNLMO AND NLMO BASIS SETS,
C  AND THE NLMO DENSITY MATRIX, NLMO FOCK MATRIX, AND NLMO DIPOLE MATRICES:
C
C  REORGANIZE THE SCRATCH VECTOR:
C
C  (DO NOT DESTROY THE WIBERG BOND INDEX!)
C
        I0   = 1 + NATOMS*NATOMS
        I1   = I0 + NDIM*NDIM
        I2   = I1 + NDIM*NDIM
C       IEND = I2 + NDIM*(NDIM+5)
C
C  OUTPUT THE AO-PNLMO TRANSFORMATION AND THE PNLMO OVERLAP MATRIX:
C
        IO = IOINQR(JPRINT(48))
        JO = IOINQR(JPRINT(49))
        IF((IO.EQ.IPRNT.OR.IO.EQ.IWRIT).OR.
     +     (JO.EQ.IPRNT.OR.JO.EQ.IWRIT)) THEN
          CALL FEPNAO(T)
          CALL FETNAB(A(I0))
          CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS)
          CALL FETLMO(A(I0))
          CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS)
          CALL FESRAW(A(I0))
          CALL NORMLZ(T,A(I0),NDIM,NBAS)
          IF(JO.EQ.IPRNT.OR.JO.EQ.IWRIT) THEN
            TITLE = 'PNLMOs in the AO basis:'
            CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(49))
          END IF
          IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
            CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS)
            TITLE = 'PNLMO overlap matrix:'
            CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(48))
          END IF
        END IF
C
C  FORM THE AO-NLMO TRANSFORMATION MATRIX:
C
        CALL FETNAO(T)
        CALL FETNAB(A(I0))
        CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS)
        CALL FETLMO(A(I0))
        CALL MATMLT(T,A(I0),A(I1),NDIM,NBAS)
C
C  SAVE THE AO-NLMO TRANSFORMATION ON NBO DAF:
C
        CALL SVNLMO(T)
C
C  WRITE OUT THE AO-NLMO TRANSFORMATION MATRIX:
C
        IO = IOINQR(JPRINT(23))
        IF(IO.EQ.IWRIT) CALL WRNLMO(T,DM,JPRINT(23))
C
C  PRINT THE AO-NLMO TRANSFORMATION MATRIX:
C
        IF(IO.EQ.IPRNT) THEN
          TITLE = 'NLMOs in the AO basis:'
          CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,JPRINT(23))
        END IF
C
C  OUTPUT THE NAO-NLMO TRANSFORMATION MATRIX:
C
        IO = IOINQR(JPRINT(18))
        IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
          CALL FETNAB(A(I0))
          CALL FETLMO(A(I1))
          CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS)
          TITLE = 'NLMOs in the NAO basis:'
          CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,2,JPRINT(18))
        END IF
C
C  OUTPUT THE NHO-NLMO TRANSFORMATION MATRIX:
C
        IO = IOINQR(JPRINT(24))
        IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
          CALL FETNHO(A(I0))
          CALL TRANSP(A(I0),NDIM,NBAS)
          CALL FETNAB(A(I1))
          CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS)
          CALL FETLMO(A(I1))
          CALL MATMLT(A(I0),A(I1),A(I2),NDIM,NBAS)
          TITLE = 'NLMOs in the NHO basis:'
          CALL AOUT(A(I0),NDIM,NBAS,NBAS,TITLE,3,JPRINT(24))
        END IF
C
C  OUTPUT THE NBO-NLMO TRANSFORMATION MATRIX:
C
        IO = IOINQR(JPRINT(47))
        IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
          CALL FETLMO(A(I0))
          TITLE = 'NLMOs in the NBO basis:'
          CALL AOUT(A(I0),NDIM,NBAS,NBAS,TITLE,4,JPRINT(47))
        END IF
C
C  OUTPUT THE NLMO-MO TRANSFORMATION MATRIX:
C
        IO = IOINQR(JPRINT(13))
        IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
          CALL FRMTMO(T,A(I0),A(I1),A(I2),5,JPRINT(13))
        END IF
C
C  OUTPUT THE NLMO DENSITY MATRIX:
C
        IO = IOINQR(JPRINT(17))
        IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
          TITLE = 'NLMO density matrix:'
          CALL AOUT(DM,NDIM,-NBAS,NBAS,TITLE,5,JPRINT(17))
        END IF
C
C  OUTPUT THE NLMO FOCK MATRIX:
C
        IO = IOINQR(JPRINT(15))
        IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
          CALL FEFAO(A(I0),IWFOCK)
          IF(IWFOCK.NE.0) THEN
            CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS)
            TITLE = 'NLMO Fock matrix:'
            CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(15))
          END IF
        END IF
C
C  OUTPUT THE NLMO DIPOLE MATRICES:
C
        IO = IOINQR(JPRINT(54))
        IF(IO.EQ.IPRNT.OR.IO.EQ.IWRIT) THEN
          IX = 1
          CALL FEDXYZ(A(I0),IX)
          IF(IX.NE.0) THEN
            CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS)
            TITLE = 'NLMO x dipole integrals:'
            CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54))
          END IF
          IX = 2
          CALL FEDXYZ(A(I0),IX)
          IF(IX.NE.0) THEN
            CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS)
            TITLE = 'NLMO y dipole integrals:'
            CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54))
          END IF
          IX = 3
          CALL FEDXYZ(A(I0),IX)
          IF(IX.NE.0) THEN
            CALL SIMTRS(A(I0),T,A(I1),NDIM,NBAS)
            TITLE = 'NLMO z dipole integrals:'
            CALL AOUT(A(I0),NDIM,-NBAS,NBAS,TITLE,5,JPRINT(54))
          END IF
        END IF
C
C  PERFORM THE NBO/NLMO DIPOLE MOMENT ANALYSIS:
C
C  DM   :  NLMO DENSITY MATRIX
C  T    :  AO-NLMO TRANSFORMATION MATRIX
C  A(I1):  C(NDIM,NDIM)
C  A(I2):  TNBO(NDIM,NDIM)
C  A(I3):  DX(NDIM,NDIM)
C  A(I4):  DY(NDIM,NDIM)
C  A(I5):  DZ(NDIM,NDIM)
C  A(I6):  SCR(NDIM,NDIM)
C  A(I7):  INDEX(NDIM)
C
C  (DO NOT DESTROY THE WIBERG BOND INDEX!)
C
        IF(JPRINT(46).NE.0) THEN
          I1   = 1 + NATOMS*NATOMS
          I2   = I1 + NDIM*NDIM
          I3   = I2 + NDIM*NDIM
          I4   = I3 + NDIM*NDIM
          I5   = I4 + NDIM*NDIM
          I6   = I5 + NDIM*NDIM
          I7   = I6 + NDIM*NDIM
C         IEND = I7 + NDIM
          CALL DIPANL(DM,T,A(I1),A(I2),A(I3),A(I4),A(I5),A(I6),A(I7))
        END IF
      END IF
C
C  PERFORM NATURAL RESONANCE THEORY ANALYSIS:
C
      IF(JPRINT(32).NE.0) THEN
C
C  CAREFULLY DETERMINE THE MAXIMUM NUMBER OF RESONANCE STRUCTURES
C  (MAXRES) THAT THE SCRATCH VECTOR CAN ACCOMODATE.  ASSUME THAT
C  THERE WILL BE ROUGHLY 6(=NEL)  ELEMENTS REQUIRED PER ATOM TO STORE
C  THE TOPO MATRICES FOR EACH RESONANCE STRUCTURE: (1 FOR NUMBER OF
C  BONDS, 1 FOR NUMBER OF LONE PAIRS, AND 4 BONDED ATOMS -- SEE
C  SR TOPSTR)
C
        NEL = 6
        TOT = ZERO
        DO 80 IBAS = 1,NBAS
          TOT = TOT + DM(IBAS,IBAS)
   80   CONTINUE
        NELEC = NINT(TOT)
        NLOW = NATOMS*(NATOMS-1)/2
        MAXREF = MAX(JPRINT(56),1)
C
C  CAREFULLY DETERMINE THE MAXIMUM NUMBER OF RESONANCE STRUCTURES (MAXRES)
C  WHICH THE SCRATCH VECTOR CAN ACCOMODATE.  ASSUME NDIM IS LARGER THAN
C  MAXRES (THIS IS NOT USUALLY THE CASE):
C
        IC = NDIM*NDIM + 4*NDIM + MXAO*NDIM + NDIM + MXBO*MXBO +
     +       MXBO*MXBO + MXBO + MXBO + MXAO*MXAO + MXAO*MXAO + 
     +       MXAO + MXAO + MXAO + NATOMS*NATOMS + NDIM*MAXREF + 
     +       NDIM*NDIM + MAXREF + MAXREF + NDIM*MAXREF + NDIM +
     +       NDIM*NDIM + NDIM*NDIM + NDIM*NDIM + NATOMS*NATOMS +
     +       MAXREF - MEMORY
        IB = NDIM*MAXREF + 6*MAXREF + NLOW*MAXREF + 9 + NATOMS*NEL
        IA = 0
        MAXRES = INT(-IC / IB)
C
C  CHECK THIS ASSUMPTION:
C
        IF(MAXRES.GT.NDIM) THEN
          IC = IC - NDIM*NDIM - NDIM*NDIM
          IA = 2
          DET = SQRT(REAL(IB * IB - 4 * IA * IC))
          MAXRES = INT((-REAL(IB) + DET) / REAL(2 * IA))
        END IF
        IF(MAXRES.GT.NDIM*NDIM) THEN
          IC = IC - NDIM*NDIM
          IB = IB + 1
          IA = 2
          DET = SQRT(REAL(IB * IB - 4 * IA * IC))
          MAXRES = INT((-REAL(IB) + DET) / REAL(2 * IA))
        END IF
        LEN = NEL * NATOMS * MAXRES
C
C  PARTITION THE SCRATCH VECTOR:
C
        I0  = 1
        I1  = I0 + NATOMS*NATOMS
        I2  = I1 + MAXRES*MAXREF
        I3  = I2 + MAXRES*MAXREF
        I4  = I3 + MAXREF
        MEM = MEMORY - I4 + 1
C       CALL NRTDRV(DM,T,A(I0),A(I1),A(I2),A(I3),A(I4),MAXRES,MAXREF,
C    +              NLOW,LEN,NELEC,MEM)
      END IF
      RETURN
C
 1390 FORMAT(/1X,'WARNING:  The $CHOOSE keylist is incompatible with ',
     + 'the NRT analysis for open',/1X,'          shell NBO analyses.',
     + '  Program execution will continue, ignoring the',/1X,'       ',
     + '   $CHOOSE keylist.')
 1400 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS:')
 1410 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS,',
     * ' alpha spin orbitals:')
 1420 FORMAT(//1X,'NATURAL BOND ORBITAL ANALYSIS,',
     * ' beta spin orbitals:')
 2000 FORMAT(//1X,'NBO analysis skipped by request.')
      END
C*****************************************************************************
C
C  ROUTINES CALLED BY THE NAO DRIVERS:
C
C      SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF)
C      SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF)
C      SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR)
C      SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK)
C      SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO)
C      SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG)
C
C*****************************************************************************
      SUBROUTINE SIMTRM(A,S,V,NDIM,N,IWMULP,IWCUBF)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  SIMILARITY TRANSFORM A ==> S(TRANSPOSE)*A*S, USING SCRATCH VECTOR V.
C   WRITE THE DIAGONAL ELEMENTS OF A*S BY CALLING SUBROUTINE MULANA IF
C          IWMULP.NE.0
C     (THESE ARE THE MULLIKEN POPULATIONS IF S= OVERLAP MATRIX
C                                       AND A= BOND-ORDER MATRIX)
C
      DIMENSION A(NDIM,NDIM),S(NDIM,NDIM),V(1)
      CALL MATMLT(A,S,V,NDIM,N)
      I1=NDIM+1
      IF(IWMULP.NE.0) CALL MULANA(A,V(1),V(I1),IWMULP,IWCUBF)
      CALL MATML2(S,A,V,NDIM,N)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE MULANA(BS,VMAYER,BMAYER,IWMULP,IWCUBF)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C
C  PERFORM MAYER-MULLIKEN BOND ORDER ANALYSIS
C
C  PRINT OUT DIAGONAL ELEMENTS OF BS=B*S, WHERE
C      B= BOND-ORDER MATRIX,   S= OVERLAP MATRIX,   BOTH IN ORIGINAL AO BASIS
C   THIS CONSTITUTES A MULLIKEN POPULATION ANALYSIS.
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      DIMENSION BS(NDIM,NDIM),VMAYER(NATOMS),BMAYER(NATOMS,NATOMS),
     *          IANG(5),ANGL(60),LANG(60),CUBICF(7)
      CHARACTER*80 TITLE
      DATA IANG/'s','p','d','f','g'/
      DATA LANG/ 51,151,152,153,251,252,253,254,255,
     *          351,352,353,354,355,356,357,
     *          451,452,453,454,455,456,457,458,459,
     *            1,101,102,103,201,202,203,204,205,206,
     *          301,302,303,304,305,306,307,308,309,310,
     *          401,402,403,404,405,406,407,408,409,410,
     *          411,412,413,414,415/
      DATA ANGL/4H    ,4Hx   ,4Hy   ,4Hz   ,4Hxy  ,4Hxz  ,4Hyz  ,
     *   4Hx2y2,4Hz2  ,4H(0) ,4H(c1),4H(s1),4H(c2),4H(s2),4H(c3),
     *   4H(s3),4H(0) ,4H(c1),4H(s1),4H(c2),4H(s2),4H(c3),4H(s3),
     *   4H(c4),4H(s4),
     *          4H    ,4Hx   ,4Hy   ,4Hz   ,4Hxx  ,4Hxy  ,4Hxz  ,
     *   4Hyy  ,4Hyz  ,4Hzz  ,4Hxxx ,4Hxxy ,4Hxxz ,4Hxyy ,4Hxyz ,
     *   4Hxzz ,4Hyyy ,4Hyyz ,4Hyzz ,4Hzzz ,4Hxxxx,4Hxxxy,4Hxxxz,
     *   4Hxxyy,4Hxxyz,4Hxxzz,4Hxyyy,4Hxyyz,4Hxyzz,4Hxzzz,4Hyyyy,
     *   4Hyyyz,4Hyyzz,4Hyzzz,4Hzzzz/
      DATA CUBICF/4H(d1),4H(d2),4H(d3),4H(b) ,4H(e1),4H(e2),4H(e3)/
      DATA ZERO/0.0D0/
      IF(IWCUBF.EQ.0) GO TO 20
C  IF THE F FUNCTIONS ARE A CUBIC SET, INSERT THE PROPER LABELS:
        DO 10 I=1,7
          II=I+9
   10     ANGL(II)=CUBICF(I)
   20 CONTINUE
      IF(IWMULP.EQ.1) WRITE(LFNPR,1000)
      IF(IWMULP.EQ.2) WRITE(LFNPR,1100)
      IF(IWMULP.EQ.2) WRITE(LFNPR,1200)
      SUMT=ZERO
      DO 100 I=1,NATOMS
        VMAYER(I)=ZERO
        DO 100 J=1,NATOMS
  100     BMAYER(I,J)=ZERO
      DO 300 IAT=1,NATOMS
        IZ=IATNO(IAT)
        NAM=NAMEAT(IZ)
        SUMAT=ZERO
        DO 200 I=1,NBAS
          IF(LBL(I).NE.IAT) GO TO 200
          LM=LORBC(I)
          L=LM/100
          IL=IANG(L+1)
          DO 130 ILM=1,60
            IF(LM.EQ.LANG(ILM)) GO TO 140
 130        CONTINUE
C
          STOP
 140      CONTINUE
          OCC=BS(I,I)
          SUMAT=SUMAT+OCC
        IF(IWMULP.EQ.2) WRITE(LFNPR,1300) I,NAM,IAT,IL,ANGL(ILM),OCC
        DO 180 J=1,NBAS
          JAT=LBL(J)
          IF(JAT.EQ.IAT) GO TO 180
          BMAYER(IAT,JAT)=BMAYER(IAT,JAT)+BS(I,J)*BS(J,I)
  180     CONTINUE
  200   CONTINUE
        IF(IWMULP.EQ.1) WRITE(LFNPR,1800) NAM,IAT,SUMAT
        IF(IWMULP.EQ.2) WRITE(LFNPR,1900) NAM,IAT,SUMAT
  300   SUMT=SUMT+SUMAT
      IF(IWMULP.NE.0) WRITE(LFNPR,1600) SUMT
      TITLE = 'Mayer-Mulliken atom-atom bond order matrix:'
      CALL AOUT(BMAYER,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS)
      DO 310 I=1,NATOMS
        DO 310 J=1,NATOMS
  310     VMAYER(I)=VMAYER(I)+BMAYER(I,J)
      TITLE = 'Mayer-Mulliken valencies by atom:'
      CALL AOUT(VMAYER,NATOMS,NATOMS,1,TITLE,0,1)
      RETURN
 1000 FORMAT(//1X,'Total gross Mulliken populations by atom:',
     * //4X,'Atom #',7X,'Total')
 1100 FORMAT(//1X,'Input atomic orbitals, gross Mulliken populations:',
     +//1X,' AO',2X,'Atom #',2X,'lang',2X,'Mulliken Population',
     +4X,'Atom #',7X,'Total')
 1200 FORMAT(1X,79('-'))
 1300 FORMAT(1X,I3,3X,A2,I3,2X,A1,A4,F13.7)
 1600 FORMAT(/1X,'Total number of electrons: ',F11.6)
 1800 FORMAT(5X,A2,I3,F15.7)
 1900 FORMAT(44X,A2,I3,F15.7)
      END
C*****************************************************************************
      SUBROUTINE DFGORB(RENORM,DM,T,ITRAN,IWCUBF,ITOPT,LFNPR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LIST(6,MAXBAS),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),A(6,6),B(6),M(6),
     *  RENORM(NDIM),
     *  LF(3,3),LFCUB(3,3),LFT(3,3),LFCUBT(3,3),LG(3,3),LGT(3,3)
      DATA LF    /301,304,306,302,307,309,303,308,310/
      DATA LFCUB /306,304,301,309,302,307,303,308,310/
      DATA LFT   /151,356,352,152,357,353,153,354,351/
      DATA LFCUBT/151,355,351,152,356,352,153,357,353/
      DATA LG    /402,407,409,403,408,410,405,412,414/
      DATA LGT   /251,455,459,252,452,456,253,453,457/
      DATA ZERO,ONE,TWO,THREE,FOUR,SIX,EIGHT
     *    /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,6.0D0,8.0D0/
C**********************************************************************
C
C     SUBROUTINE TO TRANSFORM THE OVERLAP AND DENSITY MATRICES IF D, F, G
C  ORBITALS ARE PRESENT, OR TRANSFORM A TRANSFORMATION MATRIX SO THAT IT
C  STARTS FROM THE RAW AO INSTEAD OF THE PURE AO BASIS
C  THIS TRANSFORMATION WILL NOT WORK IF DM IS THE BOND-ORDER MATRIX.
C
C         LIST(6,MAXBAS): THE LIST OF FUNCTIONS TO BE TRANSFORMED
C               LIST(1,I),LIST(2,I),LIST(3,I) ARE CORRESPONDING SETS OF
C               D,F, OR G FUNCTIONS.  IT IS ASSUMED THAT, FOR EXAMPLE,
C               THE THIRD DX2 FUNCTION FOUND IN THE ANGULAR MOMENTA LIST "LORB"
C               CORRESPONDS TO THE THIRD DY2 AND THE THIRD DZ2 FUNCTIONS IN
C               THE LIST OF BASIS FUNCTIONS!
C         ITRAN=IDTRAN+IFTRAN+IGTRAN
C         IDTRAN: THE NUMBER OF SETS OF CARTESIAN D ORBITALS FOUND
C         IFTRAN: THE NUMBER OF SETS OF CARTESIAN F ORBITALS FOUND
C         IGTRAN: THE NUMBER OF SETS OF CARTESIAN G ORBITALS FOUND
C         A     : THE TRANSFORMATION MATRIX
C
C         ITOPT : IF ZERO, TRANSFORM DM AND S (IN T) FROM RAW AO TO PURE 
C                                                                   AO BASIS
C                 IF ONE,  PRE-MULTIPLY T BY THE AO TO PURE AO TRANSF.
C                        --- THIS CONVERTS A TRANSF. THAT STARTS FROM PURE AOS
C                            TO A TRANSF. THAT STARTS FROM THE RAW AOS
C
C         RENORM: RENORMALIZATION VECTOR FOR CARTESIAN TO PURE TRANSFORM.
C                 (PRODUCED IF ITOPT=0, USED AS INPUT IF ITOPT=1)
C
C**********************************************************************
      DO 10 I=1,NBAS
  10  LORB(I)=0
      IDTRAN=0
      N1=0
      N2=0
      N3=0
      N4=0
      N5=0
      N6=0
C...CONSTRUCT LIST:
      DO 70 IBAS=1,NBAS
C   DX2:
        IF(LORBC(IBAS).NE.201) GO TO 20
          N1=N1+1
          LIST(1,N1)=IBAS
          GO TO 70
C   DY2:
   20   IF(LORBC(IBAS).NE.204) GO TO 30
          N2=N2+1
          LIST(2,N2)=IBAS
          GO TO 70
C   DZ2:
   30   IF(LORBC(IBAS).NE.206) GO TO 40
          N3=N3+1
          LIST(3,N3)=IBAS
          GO TO 70
C   LABEL DXY:
   40   IF(LORBC(IBAS).NE.202) GO TO 50
          N4=N4+1
          LORB(IBAS)=251
          GO TO 70
C   LABEL DXZ:
   50   IF(LORBC(IBAS).NE.203) GO TO 60
          N5 =N5+1
          LORB(IBAS)=252
          GO TO 70
C   LABEL DYZ:
   60   IF(LORBC(IBAS).NE.205) GO TO 70
          N6=N6+1
          LORB(IBAS)=253
   70   CONTINUE
      IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1950
      IF(N1.NE.N4.OR.N1.NE.N5.OR.N1.NE.N6) GO TO 1950
      IDTRAN=N1
      IF(IDTRAN.EQ.0) GO TO 160
C SET UP TRANSFORM. COEFF:
C  S=R2=X2+Y2+Z2:
      A(1,1)= ONE
      A(2,1)= ONE
      A(3,1)= ONE
C  D(X2-Y2):
      A(1,2)= ONE
      A(2,2)=-ONE
      A(3,2)= ZERO
C  D(3Z2-R2)=-X2-Y2+2Z2:
      A(1,3)=-ONE
      A(2,3)=-ONE
      A(3,3)= TWO
      IF(ITOPT.EQ.0) GO TO 110
      DO 90 J=1,3
        RENOR=RENORM(LIST(J,1))
        DO 90 I=1,3
   90     A(I,J)=A(I,J)*RENOR
      CALL TRANSP(A,6,3)
  110 CONTINUE
C...LOOP OVER D SETS IN DLIST:
      DO 150 ID=1,IDTRAN
        M(1)=LIST(1,ID)
        M(2)=LIST(2,ID)
        M(3)=LIST(3,ID)
C...TRANSFORM S AND DM:
        IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1)
        IF(ITOPT.NE.0) GO TO 150
          CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0)
          CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0)
C...SET THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED:
        LORB(M(1))=51
        LORB(M(2))=254
        LORB(M(3))=255
  150   CONTINUE
C**********************************************************************
  160 CONTINUE
C  F ORBITALS
      IFTRAN=0
      DO 400 IFBLK=1,3
        N1=0
        N2=0
        N3=0
        IF(IWCUBF.NE.0) GO TO 190
          LF1=LF(1,IFBLK)
          LF2=LF(2,IFBLK)
          LF3=LF(3,IFBLK)
          GO TO 200
  190   CONTINUE
          LF1=LFCUB(1,IFBLK)
          LF2=LFCUB(2,IFBLK)
          LF3=LFCUB(3,IFBLK)
  200   CONTINUE
C...CONSTRUCT THE LIST:
        DO 260 IBAS=1,NBAS
          IF(LORBC(IBAS).NE.LF1) GO TO 220
            N1=N1+1
            LIST(1,N1)=IBAS
            GO TO 260
  220     IF(LORBC(IBAS).NE.LF2) GO TO 230
            N2=N2+1
            LIST(2,N2)=IBAS
            GO TO 260
  230     IF(LORBC(IBAS).NE.LF3) GO TO 260
            N3=N3+1
            LIST(3,N3)=IBAS
            GO TO 260
  260     CONTINUE
        IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1960
        IF(IFBLK.EQ.1) IFTRAN=N1
        IF((IFBLK.NE.1).AND.(IFTRAN.NE.N1)) GO TO 1960
        IF(IFTRAN.EQ.0) GO TO 500
        IF(IWCUBF.EQ.0) GO TO 270
C SET UP TRANSFORM. COEFF, CUBIC F ORBITALS
C  PX=X*R2, PY=Y*R2, PZ=Z*Z2
          A(1,1)= ONE
          A(2,1)= ONE
          A(3,1)= ONE
C  FX(Z2-Y2), FY(Z2-X2), FZ(X2-Y2)
          A(1,2)= ONE
          A(2,2)=-ONE
          A(3,2)= ZERO
C  FX(5Z2-3R2), FY(5Y2-3R2), FZ(5Z2-3R2)
          A(1,3)=-THREE
          A(2,3)=-THREE
          A(3,3)= TWO
          GO TO 310
  270   IF(IFBLK.GT.1) GO TO 280
C SET UP TRANSFORM. COEFF, FOR FIRST F BLOCK
C  PX=X*R2
          A(1,1)= ONE
          A(2,1)= ONE
          A(3,1)= ONE
C  FX(X2-3Y2)
          A(1,2)= ONE
          A(2,2)=-THREE
          A(3,2)= ZERO
C  FX(5Z2-R2)
          A(1,3)=-ONE
          A(2,3)=-ONE
          A(3,3)= FOUR
          GO TO 310
  280   IF(IFBLK.EQ.3) GO TO 290
C SET UP TRANSFORM. COEFF, FOR SECOND F BLOCK
C  PY=Y*R2
          A(1,1)= ONE
          A(2,1)= ONE
          A(3,1)= ONE
C  FY(3X2-Y2)
          A(1,2)= THREE
          A(2,2)=-ONE
          A(3,2)= ZERO
C  FY(5Z2-R2)
          A(1,3)=-ONE
          A(2,3)=-ONE
          A(3,3)= FOUR
          GO TO 310
  290   CONTINUE
C SET UP TRANSFORM. COEFF, FOR THIRD F BLOCK
C  PZ Z*R2
          A(1,1)= ONE
          A(2,1)= ONE
          A(3,1)= ONE
C  FZ(X2-Y2)
          A(1,2)= ONE
          A(2,2)=-ONE
          A(3,2)= ZERO
C  FZ(5Z2-3R2)
          A(1,3)=-THREE
          A(2,3)=-THREE
          A(3,3)= TWO
  310   CONTINUE
      IF(ITOPT.EQ.0) GO TO 330
      DO 320 J=1,3
        RENOR=RENORM(LIST(J,1))
        DO 320 I=1,3
  320     A(I,J)=A(I,J)*RENOR
      CALL TRANSP(A,6,3)
  330 CONTINUE
C...LOOP OVER F SETS IN LIST:
        DO 390 IT=1,IFTRAN
          M(1)=LIST(1,IT)
          M(2)=LIST(2,IT)
          M(3)=LIST(3,IT)
C...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0)
        IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1)
        IF(ITOPT.NE.0) GO TO 340
          CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0)
          CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0)
C...FIX THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED:
  340   CONTINUE
          IF(IWCUBF.NE.0) GO TO 350
            LORB(M(1))=LFT(1,IFBLK)
            LORB(M(2))=LFT(2,IFBLK)
            LORB(M(3))=LFT(3,IFBLK)
            GO TO 390
  350     CONTINUE
            LORB(M(1))=LFCUBT(1,IFBLK)
            LORB(M(2))=LFCUBT(2,IFBLK)
            LORB(M(3))=LFCUBT(3,IFBLK)
  390     CONTINUE
  400   CONTINUE
C   SEARCH FOR FXYZ AND RELABEL:
      LF1=305
      LF1T=355
      IF(IWCUBF.NE.0) LF1T=354
      N1=0
      DO 420 IBAS=1,NBAS
        IF(LORBC(IBAS).NE.LF1) GO TO 420
          N1=N1+1
          LORB(IBAS)=LF1T
  420     CONTINUE
      IF(IFTRAN.NE.N1) GO TO 1960
  500 CONTINUE
C  G ORBITALS
      IGTRAN=0
      DO 800 IGBLK=1,3
        N1=0
        N2=0
        N3=0
          LG1=LG(1,IGBLK)
          LG2=LG(2,IGBLK)
          LG3=LG(3,IGBLK)
C...CONSTRUCT THE LIST:
        DO 560 IBAS=1,NBAS
          LANG=LORBC(IBAS)
          IF(LANG.NE.LG1) GO TO 520
            N1=N1+1
            LIST(1,N1)=IBAS
            GO TO 560
  520     IF(LANG.NE.LG2) GO TO 530
            N2=N2+1
            LIST(2,N2)=IBAS
            GO TO 560
  530     IF(LANG.NE.LG3) GO TO 560
            N3=N3+1
            LIST(3,N3)=IBAS
            GO TO 560
  560     CONTINUE
        IF(N1.NE.N2.OR.N1.NE.N3) GO TO 1970
        IF(IGBLK.EQ.1) IGTRAN=N1
        IF((IGBLK.NE.1).AND.(IGTRAN.NE.N1)) GO TO 1970
        IF(IGTRAN.EQ.0) GO TO 1000
          IF(IGBLK.GT.1) GO TO 580
C SET UP TRANSFORM. COEFF, FOR FIRST G BLOCK
C  DXY=XY*R2
            A(1,1)= ONE
            A(2,1)= ONE
            A(3,1)= ONE
C  G(2S)
            A(1,2)= ONE
            A(2,2)=-ONE
            A(3,2)= SIX
C  G(4S)
            A(1,3)= ONE
            A(2,3)=-ONE
            A(3,3)= ZERO
            GO TO 610
  580     IF(IGBLK.EQ.3) GO TO 590
C SET UP TRANSFORM. COEFF, FOR SECOND G BLOCK
C  DXZ=XZ*R2
            A(1,1)= ONE
            A(2,1)= ONE
            A(3,1)= ONE
C  G(1C)
            A(1,2)=-THREE
            A(2,2)=-THREE
            A(3,2)= FOUR
C  G(3C)
            A(1,3)= ONE
            A(2,3)=-THREE
            A(3,3)= ZERO
            GO TO 610
  590     CONTINUE
C SET UP TRANSFORM. COEFF, FOR THIRD G BLOCK
C  DYZ=YZ*R2
            A(1,1)= ONE
            A(2,1)= ONE
            A(3,1)= ONE
C  G(1S)
            A(1,2)=-THREE
            A(2,2)=-THREE
            A(3,2)= FOUR
C  G(3S)
            A(1,3)= THREE
            A(2,3)=-ONE
            A(3,3)= ZERO
  610   CONTINUE
      IF(ITOPT.EQ.0) GO TO 630
      DO 620 J=1,3
        RENOR=RENORM(LIST(J,1))
        DO 620 I=1,3
  620     A(I,J)=A(I,J)*RENOR
      CALL TRANSP(A,6,3)
  630 CONTINUE
C...LOOP OVER G SETS IN LIST:
        DO 690 IT=1,IGTRAN
          M(1)=LIST(1,IT)
          M(2)=LIST(2,IT)
          M(3)=LIST(3,IT)
C...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0)
          IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,-1)
          IF(ITOPT.NE.0) GO TO 660
            CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,3,0)
            CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,3,0)
C...FIX THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED:
  660   CONTINUE
          LORB(M(1))=LGT(1,IGBLK)
          LORB(M(2))=LGT(2,IGBLK)
          LORB(M(3))=LGT(3,IGBLK)
  690     CONTINUE
  800   CONTINUE
C  G ORBITALS --- FOURTH (6X6) BLOCK
        N1=0
        N2=0
        N3=0
        N4=0
        N5=0
        N6=0
C...CONSTRUCT THE LIST:
        DO 870 IBAS=1,NBAS
          LANG=LORBC(IBAS)
          IF(LANG.NE.401) GO TO 820
            N1=N1+1
            LIST(1,N1)=IBAS
            GO TO 870
  820     IF(LANG.NE.411) GO TO 830
            N2=N2+1
            LIST(2,N2)=IBAS
            GO TO 870
  830     IF(LANG.NE.415) GO TO 840
            N3=N3+1
            LIST(3,N3)=IBAS
            GO TO 870
  840     IF(LANG.NE.404) GO TO 850
            N4=N4+1
            LIST(1,N4)=IBAS
            GO TO 870
  850     IF(LANG.NE.406) GO TO 860
            N5=N5+1
            LIST(2,N5)=IBAS
            GO TO 870
  860     IF(LANG.NE.413) GO TO 870
            N6=N6+1
            LIST(3,N6)=IBAS
            GO TO 870
  870     CONTINUE
        IF(IGTRAN.NE.N1.OR.N1.NE.N2.OR.N1.NE.N3) GO TO 1970
        IF(N1.NE.N4.OR.N1.NE.N5.OR.N1.NE.N6) GO TO 1970
C SET UP TRANSFORM. COEFF, FOR FOURTH G BLOCK
C  S=(R2)2
            A(1,1)= ONE
            A(2,1)= ONE
            A(3,1)= ONE
            A(4,1)= TWO
            A(5,1)= TWO
            A(6,1)= TWO
C  D(3Z2-R2)
            A(1,2)=-ONE
            A(2,2)=-ONE
            A(3,2)= TWO
            A(4,2)=-TWO
            A(5,2)= ONE
            A(6,2)= ONE
C  D(X2-Y2)
            A(1,3)= ONE
            A(2,3)=-ONE
            A(3,3)= ZERO
            A(4,3)= ZERO
            A(5,3)= ONE
            A(6,3)=-ONE
C  G(0)
            A(1,4)= THREE
            A(2,4)= THREE
            A(3,4)= EIGHT
            A(4,4)= SIX
            A(5,4)=-SIX*FOUR
            A(6,4)=-SIX*FOUR
C  G(2C)
            A(1,5)=-ONE
            A(2,5)=-ONE
            A(3,5)= ZERO
            A(4,5)= SIX
            A(5,5)=-SIX
            A(6,5)= ZERO
C  G(4C)
            A(1,6)= ONE
            A(2,6)= ONE
            A(3,6)= ZERO
            A(4,6)=-SIX
            A(5,6)= ZERO
            A(6,6)= ZERO
      IF(ITOPT.EQ.0) GO TO 930
      DO 920 J=1,6
        RENOR=RENORM(LIST(J,1))
        DO 920 I=1,6
  920     A(I,J)=A(I,J)*RENOR
      CALL TRANSP(A,6,6)
  930 CONTINUE
        IF(ITOPT.NE.0) CALL TRANSP(A,6,6)
C...LOOP OVER G SETS IN LIST:
        DO 960 IT=1,IGTRAN
          M(1)=LIST(1,IT)
          M(2)=LIST(2,IT)
          M(3)=LIST(3,IT)
          M(4)=LIST(4,IT)
          M(5)=LIST(5,IT)
          M(6)=LIST(6,IT)
C...TRANSFORM S AND DM:
C...TRANSFORM S AND DM, OR T (IF ITOPT.NE.0)
          IF(ITOPT.NE.0) CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,6,-1)
          IF(ITOPT.NE.0) GO TO 950
            CALL LIMTRN(T,M,A,B,NDIM,NBAS,6,6,0)
            CALL LIMTRN(DM,M,A,B,NDIM,NBAS,6,6,0)
C...CHANGE THE ORBITAL LABELS FOR THE 3 ORBITALS TRANSFORMED:
  950     CONTINUE
          LORB(M(1))=51
          LORB(M(2))=254
          LORB(M(3))=255
          LORB(M(4))=451
          LORB(M(5))=454
          LORB(M(6))=458
  960     CONTINUE
C  RENORMALIZATION, ITOPT=0 :
 1000 CONTINUE
      ITRAN=IDTRAN+IFTRAN+IGTRAN
      IF(ITOPT.NE.0) RETURN
      IF(ITRAN.EQ.0) GO TO 1200
      DO 1020 I=1,NBAS
        X=T(I,I)
 1020   RENORM(I)=ONE/SQRT(X)
      DO 1040 I=1,NBAS
        DO 1040 J=1,NBAS
          RIJ=RENORM(I)*RENORM(J)
          T(I,J)=T(I,J)*RIJ
 1040    DM(I,J)=DM(I,J)*RIJ
C  RELABELLING OF NON-TRANSFORMED ORBITALS:
 1200 CONTINUE
      DO 1230 I=1,NBAS
        IF(LORB(I).NE.0) GO TO 1230
        LANG=LORBC(I)
        LORB(I)=LANG
        L=LANG/100
        IDIF=LANG-L*100
        IF(IDIF.GT.50) GO TO 1230
          LORB(I)=LORB(I)+50
 1230   CONTINUE
      RETURN
C  ERROR MESSAGES:
 1950 WRITE(LFNPR,1951)
 1951 FORMAT(' Unequal numbers of d function components were',
     +' found in the input.',/,' These cannot be properly transformed-',
     +'-perhaps they were improperly labelled.')
      STOP
 1960 WRITE(LFNPR,1961)
 1961 FORMAT(' Unequal numbers of f function components were',
     +' found in the input.',/,' These cannot be properly transformed-',
     +'-perhaps they were improperly labelled.')
      STOP
 1970 WRITE(LFNPR,1971)
 1971 FORMAT(' Unequal numbers of g function components were',
     +' found in the input.',/,' These cannot be properly transformed-',
     +'-perhaps they were improperly labelled.')
      STOP
      END
C*****************************************************************************
      SUBROUTINE NAO(T,S,OCC,BLK,SBLK,EVAL,C,EVECT,EVAL2,LISTAO,NBLOCK)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C********************************************************************
C
C  MAIN SUBROUTINE 'NAO' FOR NATURAL ATOMIC ORBITAL BASIS SET.
C
C
C  INPUT REQUIRED:
C        S = OVERLAP MATRIX ELEMENTS IN LOWER TRIANGLE (BELOW DIAGONAL)
C          = DENSITY MATRIX ELEMENTS IN UPPER TRIANGLE (INCLUDING DIAG.)
C               (INPUT AO'S MUST(!) BE NORMALIZED.  ON RETURN, S IS THE
C                FULL DENSITY MATRIX.  OVERLAP MATRIX ELEMENTS ARE LOST.)
C      LBL = LIST OF ATOMIC CENTERS; LBL(I) = N IF ORBITAL I IS ON CENTER N
C     LORB = LIST OF ANGULAR MOMENTUM TYPE FOR EACH ORBITAL;
C            LORB(I) = N IF ORBITAL I IS OF 'TYPE' N.
C            N = ( 51,151,152,153)     = (S,PX,PY,PZ)
C              = (251,252,253,254,255) = (DXY,DXZ,DYZ,D(X2-Y2),D(3Z2-R2))
C              = (351-357 FOR THE 7 TYPES OF F ORBITALS)
C              = (451-459 FOR THE 9 TYPES OF G ORBITALS)
C
C  OUTPUT:
C        T = TRANSFORMATION MATRIX FROM INPUT AO'S TO NAO'S (ROWS ARE
C            LABELLED BY PRIMITIVE AO'S, COLUMNS BY NAO'S)
C   NAOCTR = LIST OF ATOMIC CENTERS FOR NAO'S; NAOCTR(I) = N IF NAO # I
C            IS ON CENTER #N.
C     NAOL = LIST OF ANGULAR MOMENTUM TYPE FOR EACH NAO, SAME FORMAT AS "LORB"
C
C  BEFORE RETURN:
C   LSTOCC = LIST OF NATURAL MINIMAL BASIS ('OCCUPIED') ORBITALS;
C            LSTOCC(I)=N (I=1,...,NOCC) MEANS THAT NAO #N BELONGS
C            TO THE NMB SET.
C   LSTEMT = LIST OF NATURAL RYDBERG BASIS ('EMPTY') ORBITALS;
C            LSTEMT(I)=N (I=1,...,NEMT) MEANS THAT NAO #N BELONGS
C            TO THE NRB SET.
C
C  AFTER RETURN:
C   LSTOCC(I) = 1 ONLY IF NAO #I BELONGS TO THE NMB SET.
C
C********************************************************************
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),OCC(NDIM),BLK(NDIM,NDIM),
     +          SBLK(MXAOLM,MXAOLM),EVAL(NBAS),EVAL2(NBAS),
     +          LISTAO(MXAOLM,9),C(NBLOCK),EVECT(MXAOLM,MXAOLM)
      CHARACTER*80 TITLE
      DATA ZERO,ONE/0.0D0,1.0D0/
      DATA IPRNT,IWRIT,IREAD/4HPRNT,4HWRIT,4HREAD/
C
C  SKIP T-NAO FORMATION IF IOINQR(IWPNAO).EQ.IREAD:
C
      IF(IOINQR(IWPNAO).EQ.IREAD) GO TO 200
C
C  ZERO TRANSFORMATION MATRIX T:
C
      DO 10 J = 1,NBAS
        LSTOCC(J) = 0
        LSTEMT(J) = 0
        DO 10 I = 1,NBAS
   10     T(I,J) = ZERO
C
C  NF COUNTS THE ACCUMULATED ORBITALS:
C
      NF = 0
C
C  NOCC COUNTS THE ACCUMULATED 'OCCUPIED' ORBITALS:
C  NEMT COUNTS THE ACCUMULATED 'EMPTY' ORBITALS:
C
      NOCC = 0
      NEMT = 0
C
C  BEGIN MAIN NAO LOOP OVER ATOMIC CENTERS:
C
      DO 140 ICNTR = 1,NATOMS
C
C  LOOP OVER ANGULAR MOMENTUM BLOCKS (S,P,D,F,G).  NL COUNTS THE NUMBER
C  OF ORBITALS IN EACH "M" COMPONENT OF THE "L" BLOCK:
C
        DO 130 IL = 1,5
          IF(NF.GT.NBAS) GO TO 130
          L = IL - 1
          M = 2*L + 1
C
C  SCAN ORBITAL LABELS TO GATHER 'LISTAO' OF ORBITALS BELONGING TO
C  PROPER ATOM AND ANGULAR MOMENTUM SYMMETRY:
C
          DO 20 IM = 1,M
            LANG = 100*L + IM + 50
            NL = 0
            DO 20 I = 1,NBAS
              IF((LBL(I).NE.ICNTR).OR.(LORB(I).NE.LANG)) GO TO 20
              NL = NL + 1
              LISTAO(NL,IM) = I
   20       CONTINUE
          IF(NL.EQ.0) GO TO 140
C
C  LOAD THIS LIST OF ORBITALS INTO BLK AND SBLK (DENSITY MATRIX AND
C  OVERLAP ELEMENTS, RESP.), AND AVERAGE THE DENSITY MATRIX ELEMENTS
C  OVER THE M COMPONENTS OF L FOR THE ATOM:
C
          CALL LOADAV(LISTAO,NL,M,S,NDIM,BLK,SBLK,MXAOLM)
C
C  SOLVE THE GENERALIZED EIGENVALUE PROBLEM:
C
          CALL ATDIAG(NL,BLK,SBLK,EVAL,C)
C
C  ORDER THE EIGENVECTORS BY OCCUPANCY EIGENVALUE:
C
          CALL RANK(EVAL,NL,NL,LARC)
C
C  LOOP OVER THE 2*L+1 COMPONENTS TO STORE T-NAO DATA:
C
          DO 120 IM = 1,M
C
C  PARTITION ORBITALS INTO 'OCCUPIED' AND 'EMPTY' SETS:
C
            CALL SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,ICNTR,L,NL,NF,NDIM)
C
C  STORE THE ORDERED EIGENVECTORS IN T:
C
            DO 120 J = 1,NL
              JR = LARC(J)
              NF = NF + 1
              OCC(NF) = EVAL(J)
              DO 110 I = 1,NL
                IAO = LISTAO(I,IM)
                IJR = I + NL*(JR-1)
                T(IAO,NF) = C(IJR)
  110         CONTINUE
C
C  MAKE UP NAO ORBITAL LABELS:
C
              NAOCTR(NF) = ICNTR
              NAOL(NF) = L*100 + IM + 50
  120       CONTINUE
  130     CONTINUE
  140   CONTINUE
  200 CONTINUE
C
C  READ IN PRE-ORTHOGONAL T-NAO DATA:
C
      IF(IOINQR(IWPNAO).NE.IREAD) GO TO 300
        CALL RDPPNA(T,OCC)
C
C  RECOMPUTE AND SYMMETRY-AVERAGE WEIGHTS, REORGANIZE LSTOCC IF THE INPUT
C  PNAOS ARE RPNAOS:
C
        IF(OCC(1).LT.ZERO) CALL NEWWTS(S,T,OCC)
        NOCC = 0
        NEMT = 0
        LANG = 0
        ILBL = 1
        NLANG = 0
        DO 280 I = 1,NBAS
          IF(LSTOCC(I).GT.0) NOCC = NOCC + 1
          IF((NAOCTR(I).NE.ILBL).OR.(NAOL(I).NE.LANG)) GO TO 240
            NLANG = NLANG + 1
            GO TO 250
  240     IF(NLANG.GT.MXAOLM) MXAOLM = NLANG
            NLANG = 1
            ILBL = NAOCTR(I)
            LANG = NAOL(I)
  250     CONTINUE
          DO 260 J = 1,NBAS
  260       IF(LSTOCC(J).EQ.I) GO TO 280
          NEMT = NEMT + 1
          LSTEMT(NEMT) = I
  280   CONTINUE
  300 CONTINUE
C
C  WRITE PREORTHOGONAL T-NAO DATA TO LFNPPA:
C
      IF(IOINQR(IWPNAO).EQ.IWRIT) CALL WRPPNA(T,OCC,IWPNAO)
C
C  SAVE T-PNAO FOR LATER USE IN COMPUTING THE NON-ORTHOGONAL OVERLAPS
C  BETWEEN NAOS OR NBOS:
C
      CALL SVPNAO(T)
      IF(IOINQR(IWPNAO).EQ.IPRNT) THEN
        TITLE = 'PNAOs in the PAO basis:'
        CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,-1,IWPNAO)
      END IF
C
C  FINAL ORTHOGONALIZATION:
C
      DO 450 I = 1,NBAS
        DO 440 J = 1,I
  440     S(J,I) = S(I,J)
  450   S(I,I) = ONE
      CALL WORTH(S,T,BLK,LSTOCC,NDIM,NBAS,NOCC,OCC,EVAL,BLK)
      IF(NEMT.EQ.0) GO TO 700
      CALL SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,BLK)
C
C  PUT P-PAO IN UPPER TRIANGLE OF S (AND DIAGONAL):
C
      CALL FEPPAO(BLK)
      DO 460 J = 1,NBAS
        DO 460 I = 1,J
  460     S(I,J) = BLK(I,J)
      CALL NEWRYD(T,S,BLK,C,SBLK,EVECT,OCC,EVAL,EVAL2,LISTAO,
     *                                             JPRINT(11))
C
C  SELECT THE SIGNIFICANT RYDBERGS, PUT IN "LARC".
C  PUT THE LIST OF THE REST OF THE RYDBERGS INTO "LISTAO",
C  AND SET THE WEIGHTINGS OF THESE LOW OCCUPANCY ORBITALS TO ONE.
C  THEN, DO A WEIGHTED ORTHOG. AMONG THE SIGNIFICANT RYDBERGS,
C  SCHMIDT ORTHOG. THE LOW OCC. RYDS TO THESE, AND FINALLY
C  DO A LOWDIN ORTHOG. AMONG THE LOW OCC. RYDS.:
C
      CALL RYDSEL(LSTEMT,NEMT,NSEL1,LARC,NSEL2,LISTAO,OCC)
      IF(NSEL1.EQ.0) GO TO 690
      CALL WORTH(S,T,BLK,LARC,NDIM,NBAS,NSEL1,OCC,EVAL,BLK)
      IF(NSEL2.EQ.0) GO TO 700
  690 CONTINUE
      IF(NSEL1.NE.0)
     *   CALL SHMDT(T,S,NDIM,NBAS,NSEL1,LARC,NSEL2,LISTAO,BLK)
      CALL WORTH(S,T,BLK,LISTAO,NDIM,NBAS,NSEL2,OCC,EVAL,BLK)
  700 CONTINUE
      CALL FEPPAO(S)
      CALL SIMTRS(S,T,OCC,NDIM,NBAS)
      CALL REDIAG(S,T,BLK,OCC,SBLK,C,LISTAO,JPRINT(11))
C
C  RETURN OCCUPIED LIST 'LSTOCC' OF 1'S OR 0'S:
C
      DO 820 I = 1,NBAS
  820   LSTOCC(I) = 1
      DO 840 I = 1,NEMT
  840   LSTOCC(LSTEMT(I)) = 0
      RETURN
      END
C*****************************************************************************
      SUBROUTINE NAOANL(DM,SPNAO,BINDEX,BINDT,BMO,OVPOP,F,ENAO)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*80 TITLE
      LOGICAL FIRST,CORE,ALLZER
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
C    Perform the Natural Population Analysis
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),IPRIN(MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBLBL/NLEW,NVAL,LBLS(10,MAXBAS,4)
C
      DIMENSION DM(NDIM,NDIM),SPNAO(NDIM,NDIM),BINDEX(NATOMS,NATOMS),
     *     BINDT(NATOMS),OVPOP(NATOMS,NATOMS),F(NDIM,NDIM),ENAO(NDIM),
     *     JPRIN(MAXBAS),ICORE(4),IVAL(4),NWARN(MAXATM),LABEC(20,2),
     *     OCCEC(20),BMO(NATOMS,NATOMS)
      DIMENSION IANG(5),ANGL(25),LANG(25),CUBICF(7)
C
      DATA IRYD/'Ryd'/
      DATA IANG/'s','p','d','f','g'/
      DATA LANG/ 51,151,152,153,251,252,253,254,255,
     *          351,352,353,354,355,356,357,
     *          451,452,453,454,455,456,457,458,459/
      DATA ANGL/4H    ,4Hx   ,4Hy   ,4Hz   ,4Hxy  ,4Hxz  ,4Hyz  ,
     *   4Hx2y2,4Hz2  ,4H(0) ,4H(C1),4H(S1),4H(C2),4H(S2),4H(C3),
     *   4H(S3),4H(0) ,4H(C1),4H(S1),4H(C2),4H(S2),4H(C3),4H(S3),
     *   4H(C4),4H(S4)/
      DATA CUBICF/4H(D1),4H(D2),4H(D3),4H(B) ,4H(E1),4H(E2),4H(E3)/
      DATA ZERO,TENTH,TWO/0.0D0,0.1D0,2.0D0/
C
C  TEST, TEST2, ALLOW, and ALLOW2 are numbers used in determining if the
C  density matrix trace is close to being an integer.  TEST2 (ALLOW2) must
C  be slightly greater than twice TEST (ALLOW):
C
      DATA TEST,TEST2/1.0D-5,2.1D-5/    
      DATA ALLOW,ALLOW2/1.0D-3,2.1D-3/
      DATA ICHCOR,ICHVAL,ICHRYD/'Cor','Val','Ryd'/
C
C  If the f functions are a cubic set, insert the proper labels:
C
      IF(IWCUBF.EQ.0) GOTO 20
        DO 10 I = 1,7
          II = I+9
   10     ANGL(II) = CUBICF(I)
   20 CONTINUE
C
C  Update the NAO atom-atom valency matrix:
C
      DO 30 J = 1,NATOMS
        DO 30 I = 1,NATOMS
          OVPOP(I,J) = ZERO
          BMO(I,J) = ZERO
   30     BINDEX(I,J) = ZERO
      DO 50 I = 1,NBAS
        IAT = NAOCTR(I)
        DO 40 J = 1,NBAS
          JAT = NAOCTR(J)
          IF(JAT.NE.IAT) THEN
            SIJ = SPNAO(I,J)
            DMIJ = DM(I,J)
            DMIJ2 = DMIJ*DMIJ
            DMSIJ = DMIJ*SIJ
            BINDEX(JAT,IAT) = BINDEX(JAT,IAT) + DMIJ2
            BMO(JAT,IAT) = BMO(JAT,IAT) + DMIJ
            OVPOP(JAT,IAT) = OVPOP(JAT,IAT) + DMSIJ
          END IF
   40   CONTINUE
   50 CONTINUE
C
C  Determine the NAO orbital energies if a Fock matrix exists.  Use
C  SPNAO to store TNAO:
C
      CALL FETNAO(SPNAO)
      IFOCK = IWFOCK
      IF(OPEN.AND..NOT.(ALPHA.OR.BETA)) IFOCK = 0
      IF(IFOCK.EQ.1) THEN
        CALL FEFAO(F,IWFOCK)
        IF(IWFOCK.NE.0) THEN
          DO 80 I = 1,NBAS
            ENRG = ZERO
            DO 70 J = 1,NBAS
              DO 60 K = 1,NBAS
                ENRG = ENRG + SPNAO(J,I)*F(J,K)*SPNAO(K,I)
   60         CONTINUE
   70       CONTINUE
            ENAO(I) = ENRG
   80     CONTINUE
        END IF
      END IF
C
C  Label NAO's as either 'Cor', 'Val', or 'Ryd':
C
      DO 200 I = 1,NBAS
        LTYP(I) = IRYD
  200 CONTINUE
      IECP = 0
      DO 300 NCTR = 1,NATOMS
        CALL CORTBL(NCTR,ICORE,IECP)
        CALL VALTBL(NCTR,IVAL)
C
C  Loop over s,p,d,f orbitals:
C
        DO 290 L = 0,3
          ITYP = IANG(L+1)
          LNUM = 2*L + 1
          IF(ICORE(L+1).LE.0) GOTO 240
C
C  Label core orbitals:
C
          DO 230 M = 1,ICORE(L+1)
            DO 220 LA = 1,LNUM
              MORB = 0
              OCC = -1.0
              DO 210 N = 1,NBAS
                LM = NAOL(N)
                NORB = LM/100
                IL = IANG(NORB+1)
                NA = MOD(NAOL(N),50)
                IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND.
     +            DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND.
     +                                         LA.EQ.NA) THEN
                      MORB = N
                      OCC = DM(N,N)
                END IF
  210         CONTINUE
              IF(MORB.EQ.0) THEN
                WRITE(LFNPR,2500) ITYP,NAMEAT(IATNO(NCTR)),NCTR,
     +                            (ICORE(I),I=1,4),M,LA
                STOP
              END IF
              LTYP(MORB) = ICHCOR
  220       CONTINUE
  230     CONTINUE
  240     CONTINUE
          IF(IVAL(L+1).LE.0) GOTO 280
C
C  Label valence orbitals:
C
          DO 270 M = 1,IVAL(L+1)
            DO 260 LA = 1,LNUM
              MORB = 0
              OCC = -1.0
              DO 250 N = 1,NBAS
                LM = NAOL(N)
                NORB = LM/100
                IL = IANG(NORB+1)
                NA = MOD(NAOL(N),50)
                IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND.
     +            DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND.
     +                                         LA.EQ.NA) THEN
                      MORB = N
                      OCC = DM(N,N)
                END IF
  250         CONTINUE
              IF(MORB.EQ.0) THEN
                WRITE(LFNPR,2600) ITYP,NAMEAT(IATNO(NCTR)),NCTR,
     +                            (IVAL(I),I=1,4),M,LA
                STOP
              END IF
              LTYP(MORB) = ICHVAL
  260       CONTINUE
  270     CONTINUE
  280     CONTINUE
  290   CONTINUE
  300 CONTINUE
C
C  Assign `principal' quantum numbers using the NAO occupancies:
C
      DO 390 I = 1,NBAS
        IPRIN(I) = 0
  390 CONTINUE
      DO 450 NCTR = 1,NATOMS
        IECP = 1
        CALL CORTBL(NCTR,IVAL,IECP)
        IECP = 0
        CALL CORTBL(NCTR,ICORE,IECP)
        DO 440 L = 0,4
          ITYP = IANG(L+1)
          MMAX = 2*L + 1
          DO 430 M = 1,MMAX
            IF(L.EQ.4) THEN
              N = 3
            ELSE
              N = IVAL(L+1) - ICORE(L+1) + L
            END IF
  400       CONTINUE
              MORB = 0
              OCC = -1.0
              DO 410 J = 1,NBAS
                LM = NAOL(J)
                NORB = LM/100
                IL = IANG(NORB+1)
                NA = MOD(NAOL(J),50)
                  IF(NAOCTR(J).EQ.NCTR.AND.IL.EQ.ITYP.AND.
     +              DM(J,J).GT.OCC.AND.IPRIN(J).EQ.0.AND.
     +                                           M.EQ.NA) THEN
                        MORB = J
                        OCC = DM(J,J)
                  END IF
  410           CONTINUE
              IF(MORB.EQ.0) GOTO 420
              N = N + 1
              IPRIN(MORB) = N
            GOTO 400
  420       CONTINUE
  430     CONTINUE
  440   CONTINUE
  450 CONTINUE
C
C  Assign `principal' quantum numbers using the NAO Fock matrix elements:
C
      IF(IFOCK.EQ.0) GOTO 580
      DO 490 I = 1,NBAS
        JPRIN(I) = 0
  490 CONTINUE
      DO 550 NCTR = 1,NATOMS
        IECP = 1
        CALL CORTBL(NCTR,IVAL,IECP)
        IECP = 0
        CALL CORTBL(NCTR,ICORE,IECP)
        DO 540 L = 0,4
          ITYP = IANG(L+1)
          MMAX = 2*L + 1
          DO 530 M = 1,MMAX
            IF(L.EQ.4) THEN
              N = 3
            ELSE
              N = IVAL(L+1) - ICORE(L+1) + L
            END IF
  500       CONTINUE
              MORB = 0
              ENRG = 1.0D6
              DO 510 J = 1,NBAS
                LM = NAOL(J)
                NORB = LM/100
                IL = IANG(NORB+1)
                NA = MOD(NAOL(J),50)
                  IF(NAOCTR(J).EQ.NCTR.AND.IL.EQ.ITYP.AND.
     +              ENAO(J).LT.ENRG.AND.JPRIN(J).EQ.0.AND.
     +                                           M.EQ.NA) THEN
                        MORB = J
                        ENRG = ENAO(J)
                  END IF
  510           CONTINUE
              IF(MORB.EQ.0) GOTO 520
              N = N + 1
              JPRIN(MORB) = N
            GOTO 500
  520       CONTINUE
  530     CONTINUE
  540   CONTINUE
  550 CONTINUE
  580 CONTINUE
C
C  Count the total number of electrons:
C
      TOT = ZERO
      DO 600 INAO = 1,NBAS
        TOT = TOT + DM(INAO,INAO)
  600 CONTINUE
      NEL = TOT + TENTH
C
C  Store NEL for use by the output routines:
C
      NLEW = NEL
C
C  Check to see if the total number of electrons found is an integer:
C
      IF(TOT.GE.ZERO) THEN
        SUMTT = TOT + TEST
        SUMTI = AINT(SUMTT)
        SUMTF = SUMTT - SUMTI
        IF(SUMTF.GT.TEST2) THEN
          SUMTT = TOT + ALLOW
          SUMTI = AINT(SUMTT)
          SUMTF = SUMTT - SUMTI
          IF(SUMTF.GT.ALLOW2) THEN
            WRITE(LFNPR,955)
            JPRINT(4) = -1
          ELSE
            WRITE(LFNPR,956)
          END IF
        END IF
      ELSE
        WRITE(LFNPR,955)
        JPRINT(4) = -1
      END IF
C
C  Write out Natural Population analysis:
C
      IF(JPRINT(4).NE.0) THEN
        IF(IFOCK.EQ.1) THEN
          WRITE(LFNPR,900)
        ELSE
          WRITE(LFNPR,910)
        END IF
        JCTR = 1
        DO 700 I = 1,NBAS
          NCTR = NAOCTR(I)
          IF(NCTR.NE.JCTR) THEN
            WRITE(LFNPR,*)
            JCTR = NCTR
          END IF
          IAT = IATNO(NCTR)
          NAM = NAMEAT(IAT)
          LM = NAOL(I)
          L = LM/100
          IL = IANG(L+1)
          DO 680 ILM = 1,25
            IF(LM.EQ.LANG(ILM)) GOTO 690
  680     CONTINUE
  690     CONTINUE
          OCC = DM(I,I)
          IF(OCC.LT.ZERO) OCC = ZERO
          IF(IFOCK.EQ.1) THEN
            WRITE(LFNPR,920) I,NAM,NCTR,IL,ANGL(ILM),LTYP(I),
     +                        JPRIN(I),IL,OCC,ENAO(I)
          ELSE
            WRITE(LFNPR,920) I,NAM,NCTR,IL,ANGL(ILM),LTYP(I),
     +                        IPRIN(I),IL,OCC
          END IF
  700   CONTINUE
C
C  Add note about effective core potentials if used:
C
        IECP = 0
        DO 710 I = 1,NATOMS
          IECP = IECP + IATNO(I) - IZNUC(I)
  710   CONTINUE
        IF(IPSEUD.NE.0) THEN
          IF(ALPHA.OR.BETA) IECP = IECP/2
          WRITE(LFNPR,930) IECP
        END IF
C
C  Write out warnings for low occupancy core orbitals:
C
        CRTHRS = CRTSET
        IF(ALPHA.OR.BETA) CRTHRS = CRTHRS - 1.0
        DO 715 N = 1,NATOMS
          NWARN(N) = 0
  715   CONTINUE
        DO 720 I = 1,NBAS
          ICTR = NAOCTR(I)
          IF(LTYP(I).EQ.ICHCOR.AND.DM(I,I).LT.CRTHRS)
     +       NWARN(ICTR) = NWARN(ICTR) + 1
  720   CONTINUE
        FIRST = .TRUE.
        DO 725 N = 1,NATOMS
          NAM = NAMEAT(IATNO(N))
          IF(NWARN(N).EQ.1) THEN
            IF(FIRST) THEN
              WRITE(LFNPR,931) CRTHRS,NAM,N
              FIRST = .FALSE.
            ELSE
              WRITE(LFNPR,932) CRTHRS,NAM,N
            END IF
          ELSE IF(NWARN(N).GT.1) THEN
            IF(FIRST) THEN
              WRITE(LFNPR,933) NWARN(N),CRTHRS,NAM,N
              FIRST = .FALSE.
            ELSE
              WRITE(LFNPR,934) NWARN(N),CRTHRS,NAM,N
            END IF
          END IF
  725   CONTINUE
C
C  Write out warnings for population inversions:
C
        IF(IFOCK.EQ.1) THEN
          DO 730 N = 1,NATOMS
            NWARN(N) = 0
  730     CONTINUE
          DO 735 I = 1,NBAS
            ICTR = NAOCTR(I)
            IF(IPRIN(I).NE.JPRIN(I)) NWARN(ICTR) = 1
            IPRIN(I) = JPRIN(I)
  735     CONTINUE
          FIRST = .TRUE.
          DO 738 N = 1,NATOMS
            NAM = NAMEAT(IATNO(N))
            IF(NWARN(N).GT.0) THEN
              IF(FIRST) THEN
                WRITE(LFNPR,936) NAM,N
                FIRST = .FALSE.
              ELSE
                WRITE(LFNPR,937) NAM,N
              END IF
            END IF
  738     CONTINUE
        END IF
C
C  Summarize the Natural Population Analysis:
C
        WRITE(LFNPR,939)
        SUMAC = ZERO
        SUMAV = ZERO
        SUMAR = ZERO
        NOMAC = 0
        DO 750 I = 1,NATOMS
          SUMC = ZERO
          SUMV = ZERO
          SUMR = ZERO
          NAM = NAMEAT(IATNO(I))
          DO 740 J = 1,NBAS
            IF(NAOCTR(J).EQ.I) THEN
              OCC = DM(J,J)
              IF(OCC.LT.ZERO) OCC = ZERO
              IF(LTYP(J).EQ.ICHCOR) SUMC = SUMC + OCC
              IF(LTYP(J).EQ.ICHVAL) SUMV = SUMV + OCC
              IF(LTYP(J).EQ.ICHRYD) SUMR = SUMR + OCC
              IF(LTYP(J).EQ.ICHCOR) NOMAC = NOMAC + 2
            END IF
  740     CONTINUE
          TOT = SUMC + SUMV + SUMR
          IF(ALPHA.OR.BETA) THEN
            CHG = IZNUC(I)/2.0 - TOT
          ELSE
            CHG = IZNUC(I) - TOT
          END IF
          ECP = FLOAT(IATNO(I) - IZNUC(I))
          IF(ALPHA.OR.BETA) ECP = ECP/TWO
          WRITE(LFNPR,940) NAM,I,CHG,SUMC+ECP,SUMV,SUMR,TOT+ECP
          SUMAC = SUMAC + SUMC
          SUMAV = SUMAV + SUMV
          SUMAR = SUMAR + SUMR
  750   CONTINUE
        TOT = SUMAC + SUMAV + SUMAR
        CHG = -1.0 * TOT
        IF(ALPHA.OR.BETA) THEN
          NOMAC = NOMAC/2
          DO 760 I = 1,NATOMS
            CHG = CHG + IZNUC(I)/2.0
  760     CONTINUE
        ELSE
          DO 770 I = 1,NATOMS
            CHG = CHG + IZNUC(I)
  770     CONTINUE
        END IF
        WRITE(LFNPR,950) CHG,SUMAC+FLOAT(IECP),SUMAV,SUMAR,
     +                   TOT+FLOAT(IECP)
C
C  Write out NMB and NRB populations and percentage occupancies:
C
        WRITE(LFNPR,960)
        NOMA = NEL
        NOMAV = NOMA - NOMAC
        SUMA = SUMAC + SUMAV
        IF(IPSEUD.NE.0) THEN
          ECP = IECP
          SUMA = SUMA + ECP
          NOMA = NOMA + IECP
          WRITE(LFNPR,970) ECP
        END IF
        IF(NOMAC.NE.0) THEN
          PCENT = SUMAC/NOMAC * 100.0
          WRITE(LFNPR,980) SUMAC,PCENT,NOMAC
        ELSE IF(SUMAC.NE.ZERO) THEN
          PCENT = ZERO
          WRITE(LFNPR,980) SUMAC,PCENT,NOMAC
        END IF
        IF(NOMAV.NE.0) THEN
          PCENT = SUMAV/NOMAV * 100.0
          WRITE(LFNPR,990) SUMAV,PCENT,NOMAV
        ELSE IF(SUMAV.NE.ZERO) THEN
          PCENT = ZERO
          WRITE(LFNPR,990) SUMAV,PCENT,NOMAV
        END IF
        IF(NOMA.NE.0) THEN
          PCENT = SUMA/NOMA * 100.0
        ELSE
          PCENT = ZERO
        END IF
        WRITE(LFNPR,1000) SUMA,PCENT,NOMA
        IF(NOMA.NE.0) THEN
          PCENT = SUMAR/NOMA * 100.0
          WRITE(LFNPR,1010) SUMAR,PCENT,NOMA
        ELSE IF(SUMAR.NE.ZERO) THEN
          PCENT = 0
          WRITE(LFNPR,1010) SUMAR,PCENT,NOMA
        END IF
C
C  Write out Natural Electron Configuration:
C
        WRITE(LFNPR,1040)
        DO 899 NCTR = 1,NATOMS
          ICT = 0
          IECP = 1
          CALL CORTBL(NCTR,ICORE,IECP)
          DO 870 NPL = 1,8
            DO 860 N = 1,NPL
              L = NPL - N
              IF(L.GE.0.AND.L.LT.N) THEN
                IF(N.GT.ICORE(L+1)+L) THEN
                  ICT = ICT + 1
                  LABEC(ICT,1) = N
                  LABEC(ICT,2) = IANG(L+1)
                  OCCEC(ICT) = ZERO
                END IF
              END IF
  860       CONTINUE
  870     CONTINUE
          DO 890 I = 1,NBAS
            ICTR = NAOCTR(I)
            IF(ICTR.EQ.NCTR.AND.LTYP(I).NE.ICHCOR) THEN
              NORB = NAOL(I)/100
              IL = IANG(NORB+1)
              DO 880 J = 1,ICT
                IF(IPRIN(I).EQ.LABEC(J,1).AND.
     +                   IL.EQ.LABEC(J,2)) THEN
                  OCCEC(J) = OCCEC(J) + DM(I,I)
                  GOTO 890
                END IF
  880         CONTINUE
            END IF
  890     CONTINUE
          IF(LABEC(1,1).NE.1) THEN
            CORE = .TRUE.
          ELSE
            CORE = .FALSE.
          END IF
          THOLD = 5.0D-3
          JMAX = ICT
C
C  Remove low occupancy subshells:
C
          DO 893 JCT = 1,ICT
  891       CONTINUE
            IF(OCCEC(JCT).LT.THOLD) THEN
              ALLZER = .TRUE.
              DO 892 KCT = JCT,ICT-1
                LABEC(KCT,1) = LABEC(KCT+1,1)
                LABEC(KCT,2) = LABEC(KCT+1,2)
                OCCEC(KCT)   = OCCEC(KCT+1)
                IF(OCCEC(KCT).GE.THOLD) ALLZER = .FALSE.
  892         CONTINUE
              OCCEC(ICT) = ZERO
              IF(ALLZER) THEN
                JMAX = JCT - 1
                GOTO 895
              END IF
              GOTO 891
            END IF
  893     CONTINUE
  895     CONTINUE
          NAM = NAMEAT(IATNO(NCTR))
          IF(JMAX.EQ.0) THEN
            IF(.NOT.CORE) THEN
              WRITE(LFNPR,1050) NAM,NCTR
            ELSE
              WRITE(LFNPR,1060) NAM,NCTR
            END IF
          ELSE
            IF(.NOT.CORE) THEN
              WRITE(LFNPR,1050) NAM,NCTR,((LABEC(K,J),J=1,2),OCCEC(K),
     +                          K=1,JMAX)
            ELSE
              WRITE(LFNPR,1060) NAM,NCTR,((LABEC(K,J),J=1,2),OCCEC(K),
     +                          K=1,JMAX)
            END IF
          END IF
  899   CONTINUE
      END IF
      IF(JPRINT(4).LT.0) STOP
C
C  Write out Wiberg Bond Index Matrix if requested:
C
      IF(JPRINT(12).NE.0) THEN
        TITLE = 'Wiberg bond index matrix in the NAO basis:'
        CALL AOUT(BINDEX,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS)
        DO 3010 IAT = 1,NATOMS
          BINDT(IAT) = ZERO
          DO 3000 JAT = 1,NATOMS
            IF(IAT.EQ.JAT) GOTO 3000
            BINDT(IAT) = BINDT(IAT) + BINDEX(JAT,IAT)
 3000     CONTINUE
 3010   CONTINUE
        TITLE = 'Wiberg bond index, Totals by atom:'
        CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1)
C
C  Write out overlap-weighted bond populations:
C
        TITLE = 'Atom-atom overlap-weighted NAO bond order:'
        CALL AOUT(OVPOP,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS)
        DO 3030 IAT = 1,NATOMS
          BINDT(IAT) = ZERO
          DO 3020 JAT = 1,NATOMS
            IF(IAT.EQ.JAT) GOTO 3020
            BINDT(IAT) = BINDT(IAT) + OVPOP(JAT,IAT)
 3020     CONTINUE
 3030   CONTINUE
        TITLE(1:43)  = 'Atom-atom overlap-weighted NAO bond order, '
        TITLE(44:58) = 'Totals by atom:'
        CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1)
C
C  Write out MO bond orders:
C
        TITLE = 'MO bond order:'
        CALL AOUT(BMO,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS)
        DO 3050 IAT = 1,NATOMS
          BINDT(IAT) = ZERO
          DO 3040 JAT = 1,NATOMS
            IF(IAT.EQ.JAT) GOTO 3040
            BINDT(IAT) = BINDT(IAT) + BMO(JAT,IAT)
 3040     CONTINUE
 3050   CONTINUE
        TITLE  = 'MO atomic valencies:'
        CALL AOUT(BINDT,NATOMS,NATOMS,1,TITLE,0,1)
      END IF
C
C  Save NAO info in COMMON/NBNAO/:
C
      DO 888 I = 1,NBAS
        NAOC(I) = NAOCTR(I)
        NAOA(I) = NAOL(I)
  888 CONTINUE
      RETURN
C
  900 FORMAT(//,1X,
     +'NATURAL POPULATIONS:  Natural atomic orbital occupancies ',/,1X,
     +'                                                         ',/,1X,
     +' NAO Atom #  lang   Type(AO)    Occupancy      Energy    ',/,1X,
     +'---------------------------------------------------------')
  910 FORMAT(//,1X,
     +'NATURAL POPULATIONS:  Natural atomic orbital occupancies ',/,1X,
     +'                                                         ',/,1X,
     +' NAO Atom #  lang   Type(AO)    Occupancy                ',/,1X,
     +'-------------------------------------------              ')
  920 FORMAT(1X,I3,3X,A2,I3,2X,A1,A4,2X,A3,'(',I2,A1,')',4X,
     + F8.5,4X,F10.5)
  930 FORMAT(/,1X,
     +'[',I3,' electrons found in the effective core potential]')
  931 FORMAT(/,1X,
     +'WARNING:  1 low occupancy (<',F6.4,'e) core orbital  found ',
     +'on ',A2,I2)
  932 FORMAT(1X,
     +'          1 low occupancy (<',F6.4,'e) core orbital  found ',
     +'on ',A2,I2)
  933 FORMAT(/,1X,
     +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals found',
     +' on ',A2,I2)
  934 FORMAT(1X,
     +'        ',I3,' low occupancy (<',F6.4,'e) core orbitals found',
     +' on ',A2,I2)
  936 FORMAT(/,1X,
     +'WARNING:  Population inversion found on atom ',A2,I2)
  937 FORMAT(1X,
     +'          Population inversion found on atom ',A2,I2)
  939 FORMAT(//,1X,
     +'Summary of Natural Population Analysis:                  ',/,1X,
     +'                                                         ',/,1X,
     +'                                      Natural Population ',/,1X,
     +'              Natural   ',47('-'),/,1X,3X,'Atom #',5X,
     +'Charge',8X,'Core',6X,'Valence',4X,'Rydberg',6X,'Total',/,1X,
     +71('-'))
  940 FORMAT(1X,4X,A2,I3,2X,F9.5,4X,F9.5,3X,F9.5,2X,F9.5,3X,F9.5)
  950 FORMAT(1X,71('='),/,1X,'  * Total *',F9.5,4X,F9.5,3X,F9.5,2X,
     + F9.5,3X,F9.5)
  955 FORMAT(/1X,
     +'Number of electrons is not an integer!  Please check your ',
     +'data.',/)
  956 FORMAT(/1X,
     +'WARNING: Number of electrons is not within 1.0D-5 of an',
     +' integer.'/)
  960 FORMAT(/,1X,
     +'                                Natural Population      ',/,1X,
     +'--------------------------------------------------------')
  970 FORMAT(1X,'  Effective Core          ',F10.5)
  980 FORMAT(1X,'  Core                    ',F10.5,' (',F8.4,
     +'% of ',I3,')')
  990 FORMAT(1X,'  Valence                 ',F10.5,' (',F8.4,
     +'% of ',I3,')')
 1000 FORMAT(1X,'  Natural Minimal Basis   ',F10.5,' (',F8.4,
     +'% of ',I3,')')
 1010 FORMAT(1X,'  Natural Rydberg Basis   ',F10.5,' (',F8.4,
     +'% of ',I3,')',/,1X,
     +'--------------------------------------------------------')
 1040 FORMAT(/1X,
     +'   Atom #          Natural Electron Configuration',/,1X,
     + 76('-'))
 1050 FORMAT(1X,4X,A2,I3,6X,6X,(13(I1,A1,'(',F5.2,')')))
 1060 FORMAT(1X,4X,A2,I3,6X,'[core]',(13(I1,A1,'(',F5.2,')')))
 2500 FORMAT(/1X,'Subroutine NAOANL could not find a ',A1,'-type ',
     + 'core orbital on atom ',A2,I2,'.',/,1X,'ICORE :',4I3,
     + '     M :',I3,'     LA :',I3)
 2600 FORMAT(/1X,'Subroutine NAOANL could not find a ',A1,'-type ',
     + 'valence orbital on atom ',A2,I2,'.',/,1X,'IVAL :',4I3,
     + '     M :',I3,'     LA :',I3)
      END
C*****************************************************************************
      SUBROUTINE FRMTMO(T,TMO,C,SCR,INDEX,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*80 TITLE
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DIMENSION T(NDIM,NDIM),TMO(NDIM,NDIM),C(NDIM,NDIM),
     +          SCR(NDIM*(NDIM+5))
      DIMENSION BASIS(4)
C
      DATA BASIS/' NAO',' NHO',' NBO','NLMO'/
      DATA ZERO/0.0D0/
C
C  Input:
C     T     --  transformation from AO basis to currect basis
C     INDEX --  current basis = 2,3,4,5 (NAO,NHO,NBO,NLMO)
C     IFLG  --  number of columns of TMO to print
C               or external LFN to write to
C
C  Fetch the AO to MO transformation matrix:
C
      CALL FEAOMO(C,IT)
      IF(IT.EQ.0) RETURN
C
C  Find the MO transformation matrix:
C
      ZERTOL = 1.0E-8
      EPS    = 1.0E-8
      MAXIT  = 10
      LFN0   = 0
      CALL LINEQ(T,TMO,C,SCR,NBAS,NBAS,NDIM,NDIM,ZERTOL,EPS,MAXIT,
     +           LFN0,IERR)
      IF(IERR.NE.0) THEN
        WRITE(LFNPR,910) BASIS(INDEX-1)
        IF(IERR.EQ.1) WRITE(LFNPR,920) BASIS(INDEX-1)
        STOP
      END IF
C
C  Make sure the largest coefficient in each column is positive:
C
      DO 30 KCOL = 1,NBAS
        TMAX = ZERO
        DO 10 JROW = 1,NBAS
          IF(ABS(TMO(JROW,KCOL)).GT.ABS(TMAX)) TMAX = TMO(JROW,KCOL)
   10   CONTINUE
        IF(TMAX.LT.ZERO) THEN
          DO 20 JROW = 1,NBAS
            TMO(JROW,KCOL) = -TMO(JROW,KCOL)
   20     CONTINUE
        END IF
   30 CONTINUE
C
C  Write or print the MO transformation matrix:
C
      IF(INDEX.EQ.2) TITLE = 'MOs in the NAO basis:'
      IF(INDEX.EQ.3) TITLE = 'MOs in the NHO basis:'
      IF(INDEX.EQ.4) TITLE = 'MOs in the NBO basis:'
      IF(INDEX.EQ.5) TITLE = 'MOs in the NLMO basis:'
      CALL AOUT(TMO,NDIM,NBAS,NBAS,TITLE,INDEX,IFLG)
      RETURN
C
  910 FORMAT(/1X,'Error calculating the ',A4,' to MO transformation')
  920 FORMAT(1X,'The AO to ',A4,' transformation is not invertible')
      END
C****************************************************************************
C
C  ROUTINES CALLED BY SR NAO:
C
C      SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM)
C      SUBROUTINE ATDIAG(N,A,B,EVAL,C)
C      SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM)
C      SUBROUTINE NEWWTS(S,T,WT)
C      SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK)
C      SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK)
C      SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2,
C     +                       LIST,IRPNAO)
C      SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
C     +                    IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
C      SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT)
C      SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO)
C      SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,IRPNAO)
C
C*****************************************************************************
      SUBROUTINE LOADAV(LISTAO,NL,M,S,NDIM,A,B,MXAOLM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION S(NDIM,NDIM),LISTAO(MXAOLM,9),A(NL,NL),B(NL,NL)
      DATA ONE,ZERO/1.0D0,0.0D0/
C
C  AVERAGE THE AO DENSITY MATRIX ELEMENTS OVER THE M=2*L+1 COMPONENTS
C  OF L FOR A PARTICULAR ATOM.
C  LOAD DENSITY MATRIX ELEMENTS (UPPER TRIANGLE OF S, INCL. DIAGONAL)
C  INTO A, OVERLAP MATRIX ELEMENTS (LOWER TRIANGLE OF S) INTO B, FOR
C  ORBITALS OF 'LIST'
C
      DO 30 J=1,NL
        DO 20 I=1,J
C  FIND AVERAGE DM ELEMENT OVER THE VALUES OF IM:
          SUM=ZERO
          DO 10 IM=1,M
            IAO=LISTAO(I,IM)
            JAO=LISTAO(J,IM)
   10       SUM=SUM+S(IAO,JAO)
          AVE=SUM/M
C  DENSITY MATRIX ELEMENTS INTO A:
          A(I,J)=AVE
          A(J,I)=AVE
C  OVERLAP MATRIX ELEMENTS INTO B:
          B(I,J)=S(JAO,IAO)
   20     B(J,I)=B(I,J)
   30   B(J,J)=ONE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE ATDIAG(N,A,B,EVAL,C)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  SOLVE GENERALIZED EIGENVALUE PROBLEM (A-EVAL*B)*C = 0.
C
C  USE JACOBI TO DIAGONALIZE B**(-1/2)*A*B**(-1/2); A AND B ARE DESTROYED.
C
      DIMENSION A(N,N),B(N,N),EVAL(N),C(N,N)
      DATA ZERO,ONE/0.0D0,1.0D0/
C  FIRST FORM B**(-1/2) AND STORE IT IN B:
      CALL JACOBI(N,B,EVAL,C,N,N,0)
      DO 10 I=1,N
   10   EVAL(I)=ONE/SQRT(EVAL(I))
      DO 30 I=1,N
        DO 30 J=1,I
          TEMP=ZERO
          DO 20 K=1,N
   20       TEMP=TEMP+EVAL(K)*C(I,K)*C(J,K)
          B(I,J)=TEMP
   30     B(J,I)=TEMP
C  NOW SIMILARITY TRANSFORM A WITH B:
      CALL SIMTRS(A,B,EVAL,N,N)
C  DIAGONALIZE A:
      CALL JACOBI(N,A,EVAL,C,N,N,1)
C  MULTIPLY B*C TO GET EIGENVECTORS FOR ORIGINAL PROBLEM, STORE IN A:
      DO 50 I=1,N
        DO 50 J=1,N
          TEMP=ZERO
          DO 40 K=1,N
   40       TEMP=TEMP+B(I,K)*C(K,J)
   50     A(I,J)=TEMP
C  MOVE FINAL EIGENVECTORS TO C:
      CALL COPY(A,C,N,N,N)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SETBAS(LSTOCC,LSTEMT,NOCC,NEMT,IAT,L,NL,NF,NDIM)
C*****************************************************************************
C
C  Select the set of natural minimal basis (NMB) orbitals for a particular
C  atom and angular symmetry type:  (up to atomic number 105)
C
C------------------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION LSTOCC(NDIM),LSTEMT(NDIM)
      DIMENSION ICORE(4),IVAL(4)
C
C  If g orbitals or orbitals of even higher angular symmetry are selected,
C  there are none in the NMB:
C
      IF(L.GE.4) GOTO 100
C
C  Find core and valence orbitals for this atom:
C
      IECP = 0
      CALL CORTBL(IAT,ICORE,IECP)
      CALL VALTBL(IAT,IVAL)
C
C  Determine the number of shells with angular symmetry L in the NMB.
C  If there are a negative number of core orbitals, ignore them:
C
      NSHELL = MAX0(ICORE(L+1),0) + IVAL(L+1)
      IF(NSHELL.EQ.0) GOTO 100
C
C  Select sets of occupied and empty NAO's:
C
      DO 10 J = 1,NSHELL
        NOCC = NOCC + 1
        LSTOCC(NOCC) = NF + J
   10 CONTINUE
      LEFT = NL - NSHELL
      IF(LEFT.EQ.0) RETURN
      DO 20 J = 1,LEFT
        NEMT = NEMT + 1
        LSTEMT(NEMT) = NF + NSHELL + J
   20 CONTINUE
      RETURN
C
C  No NMB `L'-type orbitals found for this atom:
C
  100 CONTINUE
      DO 110 J = 1,NL
        NEMT = NEMT + 1
        LSTEMT(NEMT) = NF + J
  110 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE NEWWTS(S,T,WT)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),WT(NDIM)
      CHARACTER*80 TITLE
C
      DATA ZERO/0.0D0/
C
C  RECOMPUTE OCCUPANCY WEIGHTS
      NOCC=0
      DO 20 I=1,NBAS
        SUM=ZERO
        DO 10 J=1,NBAS
          DO 10 K=1,NBAS
            SJK=S(J,K)
            IF(J.GT.K) SJK=S(K,J)
   10       SUM=SUM+T(J,I)*SJK*T(K,I)
        WT(I)=SUM
C  REFORMAT LIST LSTOCC:
        IF(LSTOCC(I).EQ.0) GO TO 20
        NOCC=NOCC+1
        LSTOCC(NOCC)=I
   20   CONTINUE
      NSTART=NOCC+1
      DO 40 I=NSTART,NDIM
   40   LSTOCC(I)=0  
C  SYMMETRY-AVERAGE WEIGHTS:
      NL=1
      IORB=0
  100 IORB=IORB+NL
        IF(IORB.GT.NBAS) GO TO 600
        NL=1
        ILBL=NAOCTR(IORB)
        IL=NAOL(IORB)/100
        NM=IL*2+1
        IMAX=NBAS-IORB
        DO 130 IADD=1,IMAX
          JORB=IORB+IADD
          JORBL=NAOL(JORB)/100
          IF(NAOCTR(JORB).NE.ILBL.OR.JORBL.NE.IL) GO TO 140
  130     NL=NL+1
  140   NC=NL/NM
        DO 500 I=1,NC
          SUM=ZERO
          DO 300 M=1,NM
            INAO=IORB+(I-1)+(M-1)*NC
  300       SUM=SUM+WT(INAO)
          AV=SUM/NM
          DO 400 M=1,NM
            INAO=IORB+(I-1)+(M-1)*NC
  400       WT(INAO)=AV
  500     CONTINUE
      GO TO 100
C
  600 CONTINUE
      TITLE = 'New symmetry-averaged occupancy weights:'
      CALL AOUT(WT,NBAS,NBAS,1,TITLE,-1,1)
      RETURN
C
      END
C*****************************************************************************
      SUBROUTINE WORTH(S,T,BLK,LIST,NDIM,NBAS,N,OCC,EVAL,BIGBLK)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C******************************************************************
C
C   WORTH: OCCUPANCY WEIGHTED ORTHOGONALIZATION SUBROUTINE
C
C   S:           FULL OVERLAP MATRIX (PURE AO BASIS)
C                 (NOTE: UPPER TRIANGLE USED FOR SCRATCH, BUT RESTORED AGAIN)
C   T:           PURE AO TO PRE-NAO TRANSFORMATION
C   LIST:        LIST OF ORBITALS TO BE ORTHOGONALIZED
C   N:           NUMBER OF ORBITALS IN LIST
C   OCC:         LIST OF SYMMETRY AVERAGED OCCUPANCY WEIGHTINGS
C
C   NOTE:    BLK AND BIGBLK SHARE THE SAME STORAGE BUT ARE
C               DIMENSIONED DIFFERENTLY.
C
C******************************************************************
      DIMENSION S(NDIM,NDIM),T(NDIM,NDIM),BLK(N,N)
      DIMENSION OCC(NDIM),LIST(NDIM),EVAL(NDIM),BIGBLK(NDIM,NDIM)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DATA ZERO,ONE/0.0D0,1.0D0/
      DATA NTIME/0/
C
C  IMPORTANT CONSTANTS:
C           WTTHR           ALL WEIGHTING FACTORS SMALLER THAN WTTHR ARE SET
C                            TO THE VALUE OF WTTHR.
C           DIAGTH          THRESHOLD FOR MATRIX DIAGONALIZATION USED IN
C                            SUBROUTINE JACOBI.  IN JACOBI, THIS CONSTANT
C                            IS CALLED "DONETH".
C           DANGER          CRITERION FOR DECIDING THAT THE JOB SHOULD BE
C                            ABORTED DUE TO NUMERICAL PROBLEMS CAUSED BY NEAR
C                            LINEAR DEPENDENCIES IN THE BASIS SET.  ALL
C                            EIGENVALUES OF THE WEIGHTED OVERLAP MATRIX MUST
C                            BE GREATER THAN DIAGTH*DANGER.
C
      DATA WTTHR,DIAGTH,DANGER/1.0D-3,1.0D-12,1.0D3/
C
      NTIME=NTIME+1
C  MULTIPLY THE WEIGHT BY A CONSTANT SO THAT THE MAXIMUM WEIGHT IS ONE,
C   AND SET ANY RESULTING WEIGHT THAT IS LESS THAN WTTHR TO THE VALUE OF WTTHR:
      WTMAX=ZERO
      DO 10 I=1,N
        IP=LIST(I)
        IF(OCC(IP).GT.WTMAX) WTMAX=OCC(IP)
   10   CONTINUE
      DO 20 I=1,N
        IP=LIST(I)
        EVAL(IP)=OCC(IP)/WTMAX
        IF(EVAL(IP).LT.WTTHR) EVAL(IP)=WTTHR
   20   CONTINUE
C  FORM THE WEIGHTED PRE-NAO VECTORS:
      DO 30 J=1,N
        JP=LIST(J)
        DO 30 I=1,NBAS
   30     T(I,JP)=T(I,JP)*EVAL(JP)
C  FORM THE WEIGHTED OVERLAP MATRIX OF THE VECTORS IN THE UPPER TRIANGLE OF S:
      DO 70 I=1,N
        IP=LIST(I)
        DO 70 J=1,NBAS
          SIJ=ZERO
          DO 40 K=1,NBAS
            TKI=T(K,IP)
            IF(TKI.EQ.ZERO) GO TO 40
            SIJ=SIJ+TKI*S(K,J)
   40       CONTINUE
   70     BIGBLK(J,I)=SIJ
      DO 100 I=1,N
        DO 100 J=1,I
          JP=LIST(J)
          SIJ=ZERO
          DO 90 K=1,NBAS
            TKJ=T(K,JP)
            IF(TKJ.EQ.ZERO) GO TO 90
            SIJ=SIJ+BIGBLK(K,I)*TKJ
   90       CONTINUE
  100     S(J,I)=SIJ
C  DIAGONALIZE S-TILDE (THE WEIGHTED OVERLAP MATRIX):
      CALL JACOBI(N,S,EVAL,BLK,NDIM,N,0)
C
C  FORM THE INVERSE SQRT OF THE OVERLAP MATRIX OF THESE WEIGHTED VECTORS:
      SMLEST=ONE
      TOOSML=DIAGTH*DANGER
      DO 150 I=1,N
        EIGENV=EVAL(I)
        IF(EIGENV.LT.TOOSML) GO TO 900
        EVAL(I)=ONE/SQRT(EIGENV)
        IF(EIGENV.LT.SMLEST) SMLEST=EIGENV
  150  CONTINUE
      DO 170 I=1,N
        DO 170 J=1,I
          SIJ=ZERO
          DO 160 K=1,N
  160       SIJ=SIJ+EVAL(K)*BLK(I,K)*BLK(J,K)
  170     S(J,I)=SIJ
C
C  THE UPPER TRIANGLE OF S (INCLUDING THE DIAGONAL)
C   NOW CONTAINS THE -0.5 POWER OF THE WEIGHTED OVERLAP MATRIX,
C   AND IS THE WEIGHTED ORTHOG. TRANSFORM THAT WE WANT.
C   NOW, FORM THE TOTAL TRANSFORMATION:
      DO 300 I=1,NBAS
        DO 260 J=1,N
          EVAL(J)=ZERO
          DO 220 K=1,J
            KP=LIST(K)
            TIK=T(I,KP)
            IF(TIK.EQ.ZERO) GO TO 220
            EVAL(J)=EVAL(J)+TIK*S(K,J)
  220       CONTINUE
          JP1=J+1
          DO 240 K=JP1,N
            KP=LIST(K)
            TIK=T(I,KP)
            IF(TIK.EQ.ZERO) GO TO 240
            EVAL(J)=EVAL(J)+TIK*S(J,K)
  240       CONTINUE
  260     CONTINUE
        DO 280 J=1,N
          JP=LIST(J)
  280     T(I,JP)=EVAL(J)
  300   CONTINUE
C  RESTORE FULL OVERLAP MATRIX S:
      DO 400 I=1,NBAS
        IM1=I-1
        DO 380 J=1,IM1
  380     S(J,I)=S(I,J)
  400   S(I,I)=ONE
      RETURN
C
  900 WRITE(LFNPR,1000) EIGENV,TOOSML
      STOP
C
 1000 FORMAT(//1X,'An eigenvalue of the weighted PRE-NAO overlap',
     +' matrix of ',F10.5,' has been',/,1X,'found, which is lower than',
     +' the allowed threshold of ',F10.5,'.  This is',/,1X,'probably',
     +' caused by either an error in the data given to the analysis',
     +' program',/,1X,'or by numerical problems caused by near linear',
     +' dependencies among the basis',/,1X,'functions.')
      END
C*****************************************************************************
      SUBROUTINE SHMDT(T,S,NDIM,NBAS,NOCC,LSTOCC,NEMT,LSTEMT,SBLK)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  SCHMIDT ORTHOGONALIZATION OF COLUMN VECTORS IN T
C     SCHMIDT ORTHOGONALIZE EACH EMPTY ORBITAL (SPECIFIED IN 'LSTEMT')
C        TO THE ORTHONORMAL OCCUPIED (LSTOCC) ORBITALS;
C
      DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),LSTOCC(NDIM),LSTEMT(NDIM),
     *              SBLK(NDIM,NDIM)
      DATA ZERO/0.0D0/
      DO 30 I=1,NBAS
        DO 30 J=1,NOCC
          JP=LSTOCC(J)
          SJI=ZERO
          DO 10 K=1,NBAS
   10       SJI=SJI+T(K,JP)*S(K,I)
   30     SBLK(I,J)=SJI
C   SCHMIDT ORTHOGONALIZE EACH UNOCCUPIED /UI> TO EACH /VJ>:
C...LOOP OVER UNOCCUPIED /UI>'S,
      DO 120 I=1,NEMT
        IP=LSTEMT(I)
C...LOOP OVER OCCUPIED /VJ>'S,
        DO 60 J=1,NOCC
          JP=LSTOCC(J)
C...CALCULATE SJI = <VJ/UI>,
          SJI=ZERO
          DO 40 K=1,NBAS
   40       SJI=SJI+SBLK(K,J)*T(K,IP)
C...AND REPLACE EACH /UI> = /UI> - SJI*/VJ>.
          DO 50 K=1,NBAS
   50       T(K,IP)=T(K,IP)-SJI*T(K,JP)
   60     CONTINUE
  120   CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE NEWRYD(T,S,TPNAO,DMBLK,SBLK,EVECT,OCC,EVAL,EVAL2,
     *                       LIST,IRPNAO)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),TPNAO(NDIM,NDIM),OCC(NDIM),
     +          DMBLK(MXAOLM,MXAOLM),SBLK(MXAOLM,MXAOLM),EVAL(NBAS),
     +          EVECT(MXAOLM,MXAOLM),EVAL2(NBAS),LIST(MXAOLM)
      DATA ONE/1.0D0/
C
C  COMPUTE NEW RYDBERG NAOS AFTER THE SCHMIDT ORTHOGONALIZATION TO
C  THE MINIMAL NAO SET HAS BEEN DONE:
C
C  IF REQUESTED (IRPNAO=JPRINT(11)=1), UPDATE PNAO TRANSFORMATION WITH TRYD:
C
      IF(IRPNAO.EQ.1) CALL FEPNAO(TPNAO)
C
      NL=1
      IORB=0
  100 IORB=IORB+NL
        IF(IORB.GT.NBAS) GO TO 300
        NL=1
        ILBL=NAOCTR(IORB)
        IL=NAOL(IORB)/100
        NM=IL*2+1
        IMAX=NBAS-IORB
        DO 130 IADD=1,IMAX
          JORB=IORB+IADD
          JORBL=NAOL(JORB)/100
          IF(NAOCTR(JORB).NE.ILBL.OR.JORBL.NE.IL) GO TO 140
  130     NL=NL+1
  140   NC=NL/NM
        NSKIP=0
        IMAX=IORB-1+NC
        DO 150 I=1,NBAS
          INAO=LSTOCC(I)
          IF(INAO.LT.IORB.OR.INAO.GT.IMAX) GO TO 150
          NSKIP=NSKIP+1
  150     CONTINUE
        IF(NSKIP.EQ.NC) GO TO 100
        NSTART=NSKIP+1
        NRYDC=NC-NSKIP
        CALL RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
     *              IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
C  END OF LOOP STARTING AT 100
        GO TO 100
  300 CONTINUE
C  RESTORE S:
      DO 350 I=1,NBAS
        IM1=I-1
        DO 340 J=1,IM1
  340     S(J,I)=S(I,J)
  350   S(I,I)=ONE
C
C  SAVE UPDATED T-PNAO TRANSFORMATION:
C
      IF(IRPNAO.EQ.1) CALL SVPNAO(TPNAO)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE RYDIAG(T,S,TPNAO,DMBLK,SBLK,OCC,EVAL,EVECT,EVAL2,
     *                    IORB,NC,NM,NSTART,NRYDC,LARC,LIST,IRPNAO)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),TPNAO(NDIM,NDIM),OCC(NBAS),
     *        DMBLK(NRYDC,NRYDC),SBLK(NRYDC,NRYDC),EVAL(NBAS),
     *        EVECT(NRYDC,NRYDC),LARC(NRYDC),LIST(NRYDC),EVAL2(NBAS)
      DATA ZERO/0.0D0/
C
C  DIAGONALIZE ONE RYDBERG BLOCK, UPDATE T-NAO (IN T) AND, IF IRPNAO.EQ.1,
C  UPDATE TPNAO:
C
      II=0
      DO 20 I=1,NRYDC
        DO 20 J=1,NRYDC
          DMBLK(I,J)=ZERO
          SBLK(I,J)=ZERO
   20     CONTINUE
      DO 500 I=NSTART,NC
        II=II+1
        DO 300 M=1,NM
          INAO=IORB+(I-1)+(M-1)*NC
          DO 140 K=1,NBAS
            DMSUM=ZERO
            SSUM=ZERO
            KM1=K-1
            DO 100 L=1,KM1
              TLI=T(L,INAO)
              DMSUM=DMSUM+TLI*S(L,K)
  100         SSUM=SSUM+TLI*S(K,L)
            TKI=T(K,INAO)
            DMSUM=DMSUM+TKI*S(K,K)
            SSUM=SSUM+TKI
            KP1=K+1
            DO 120 L=KP1,NBAS
              TLI=T(L,INAO)
              DMSUM=DMSUM+TLI*S(K,L)
  120         SSUM=SSUM+TLI*S(L,K)
            EVAL(K)=DMSUM
            EVAL2(K)=SSUM
  140       CONTINUE
          JJ=0
          DO 240 J=NSTART,I
            JJ=JJ+1
            JNAO=IORB+(J-1)+(M-1)*NC
            DMSUM=ZERO
            SSUM=ZERO
            DO 200 K=1,NBAS
              TKJ=T(K,JNAO)
              DMSUM=DMSUM+EVAL(K)*TKJ
  200         SSUM=SSUM+EVAL2(K)*TKJ
            DMBLK(II,JJ)=DMBLK(II,JJ)+DMSUM
            SBLK(II,JJ)=SBLK(II,JJ)+SSUM
  240       CONTINUE
  300     CONTINUE
          DO 350 JJ=1,II
            DMBLK(II,JJ)=DMBLK(II,JJ)/NM
            DMBLK(JJ,II)=DMBLK(II,JJ)
            SBLK(II,JJ)=SBLK(II,JJ)/NM
  350       SBLK(JJ,II)=SBLK(II,JJ)
  500     CONTINUE
      CALL ATDIAG(NRYDC,DMBLK,SBLK,EVAL,EVECT)
      CALL RANK(EVAL,NRYDC,NRYDC,LARC)
      DO 600 J=1,NRYDC
        JC=LARC(J)
        DO 600 I=1,NRYDC
  600     SBLK(I,J)=EVECT(I,JC)
      DO 700 M=1,NM
        JJ=0
        DO 680 J=NSTART,NC
          JJ=JJ+1
          JNAO=IORB+(J-1)+(M-1)*NC
          OCC(JNAO)=EVAL(JJ)
          LIST(JJ)=JNAO
  680     CONTINUE
C  USE LIMTRN TO UPDATE T:
        CALL LIMTRN(T,LIST,SBLK,DMBLK,NDIM,NBAS,NRYDC,NRYDC,1)
  700 CONTINUE
C
      IF(IRPNAO.EQ.0) RETURN
C
C  UPDATE TPNAO, BUT DO THIS IN SUCH A WAY THAT THE INTRA-ATOMIC BLOCKS
C  OF THE OVERLAP MATRIX IN THE REVISED PNAO MATRIX REMAIN DIAGONAL
C  AND THAT THE PNAOS REMAIN NORMALIZED.   IN ORDER TO ACCOMPLISH THIS,
C  WE MUST LOWDIN-ORTHOGONALIZE THE RYDBERG TRANSFORMATION IN "SBLK":
C
      CALL SYMORT(EVECT,SBLK,DMBLK,NRYDC,NRYDC,EVAL)
      DO 800 M=1,NM
        JJ=0
        DO 780 J=NSTART,NC
          JJ=JJ+1
          LIST(JJ)=IORB+(J-1)+(M-1)*NC
  780     CONTINUE
        CALL LIMTRN(TPNAO,LIST,SBLK,DMBLK,NDIM,NBAS,NRYDC,NRYDC,1)
  800   CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE RYDSEL(LSTEMT,NEMT,NSEL1,LIST1,NSEL2,LIST2,WT)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION WT(NDIM),LIST1(NBAS),LIST2(NBAS),LSTEMT(NBAS)
      DATA ONE,WTTHR/1.0D0,1.0D-4/
C
C   DIVIDE THE RYDBERG ORBITALS INTO 2 GROUPS:
C      LIST1:     RYDBERGS OF SIGNIFICANT OCCUPANCY ( .GT.WTTHR )
C
C      LIST2:     RYDBERGS OF VERY LOW OCCUPANCY ( .LT.WTTHR )
C
C      WTTHR IS SET TO 0.0001
C
C    SET THE WEIGHTINGS OF THE RYDBERGS IN LIST2 TO ONE SO THAT THE WEIGHTED
C      ORTHOGONALIZATION THAT WILL LATER BE DONE AMONG THESE ORBITALS WILL
C      BE IN FACT A LOWDIN ORTHOG.
C
      NSEL1=0
      NSEL2=0
      DO 100 I=1,NEMT
        IRYD=LSTEMT(I)
        IF(WT(IRYD).LT.WTTHR) GO TO 50
          NSEL1=NSEL1+1
          LIST1(NSEL1)=IRYD
          GO TO 100
   50   CONTINUE
          NSEL2=NSEL2+1
          LIST2(NSEL2)=IRYD
          WT(IRYD)=ONE
  100   CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE REDIAG(DM,T,TPNAO,EVAL,BLK,C,IRANK,IRPNAO)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBBAS/LDEG(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),TPNAO(NDIM,NDIM),
     +  C(MXAOLM,MXAOLM),EVAL(NDIM),BLK(MXAOLM,MXAOLM),IRANK(NBAS)
C
C  REDIAGONALIZE THE SYMMETRY AVERAGED DM SUBBLOCKS FOR EACH ANGULAR
C  SYMMETRY ON EACH ATOM:
C
C  READ IN OLD T-PNAO INTO TPNAO SO THAT IT CAN BE UPDATED (IF IRPNAO.EQ.1):
C
      IF(IRPNAO.EQ.1) CALL FEPNAO(TPNAO)
      NF = 0
      IORB = 0
      NL = 1
   10 IORB = IORB + NL
        IF(IORB.GT.NBAS) GO TO 100
        NL = 1
        ILBL = NAOCTR(IORB)
        IL = NAOL(IORB)/100
        NM = IL*2 + 1
        IMAX = NBAS - IORB
        DO 30 IADD = 1,IMAX
          JORB = IORB + IADD
          JORBL = NAOL(JORB)/100
          IF((NAOCTR(JORB).NE.ILBL).OR.(JORBL.NE.IL)) GO TO 40
   30     NL = NL + 1
   40   NC = NL/NM
        IF(NC.EQ.1) GO TO 80
        CALL REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,
     *                 IRPNAO)
        GO TO 10
   80   DO 90 M = 1,NM
          NF = NF + 1
   90     CONTINUE
        GO TO 10
  100 CONTINUE
      IF(IRPNAO.EQ.0) RETURN
C
C  SAVE NEW T-PNAO FROM TPNAO:
C
      CALL SVPNAO(TPNAO)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE REDBLK(T,TPNAO,IL,DM,BLK,EVAL,C,NF,IORB,NC,IRANK,
     *                           IRPNAO)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LDEG(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      DIMENSION DM(NDIM,NDIM),BLK(NC,NC),C(NC,NC),EVAL(NDIM),
     +  T(NDIM,NDIM),TPNAO(NDIM,NDIM),IRANK(NBAS)
      DATA ZERO/0.0D0/
C
C  FIND THE REDIAGONALIZATION TRANSFORMATION FOR THE DM SUBBLOCK FOR
C  THE ANGULAR MOMENTUM "IL" ON AN ATOM, PUT IN T2:
C
      NM = IL*2 + 1
      DO 30 J = 1,NC
        DO 30 I = 1,J
          SUM = ZERO
          DO 10 M = 1,NM
            INAO = IORB + I-1 + (M-1)*NC
            JNAO = IORB + J-1 + (M-1)*NC
   10       SUM = SUM + DM(INAO,JNAO)
          AVE = SUM/NM
          BLK(I,J) = AVE
   30     BLK(J,I) = AVE
      CALL JACOBI(NC,BLK,EVAL,C,NC,NC,1)
      CALL RANK(EVAL,NC,NC,LARC)
      DO 80 J = 1,NC
        JC = LARC(J)
        DO 80 I = 1,NC
   80     BLK(I,J) = C(I,JC)
      DO 110 M = 1,NM
        DO 100 J = 1,NC
          NF = NF + 1
  100     IRANK(J) = NF
        CALL LIMTRN(T,IRANK,BLK,C,NDIM,NBAS,NC,NC,1)
        CALL LIMTRN(DM,IRANK,BLK,C,NDIM,NBAS,NC,NC,0)
        IF(IRPNAO.EQ.1) CALL LIMTRN(TPNAO,IRANK,BLK,C,NDIM,NBAS,NC,NC,1)
  110 CONTINUE
C
      RETURN
      END
C****************************************************************************
C
C  ROUTINES CALLED BY THE NBO/NLMO DRIVERS:
C
C      SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C     +                                       P,TA,HYB,VA,VB,TOPO)
C      SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C     +                                       P,TA,HYB,VA,VB,TOPO)
C      SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
C     +                                  P,TA,HYB,VA,VB,TOPO,IFLG)
C      SUBROUTINE SRTNBO(T,BNDOCC)
C      SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR)
C      SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB)
C      SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN)
C      SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
C      SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR)
C      SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB)
C      SUBROUTINE FNDMOL(IATOMS)
C      SUBROUTINE NBOCLA(BNDOCC,ACCTHR)
C      SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO)
C      SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR)
C      SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG)
C      SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR)
C      SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM)
C      SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,SIAB,NOCC,NAB)
C      SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX)
C      SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX)
C      SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC)
C
C****************************************************************************
      SUBROUTINE NATHYB(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
     *                                       P,TA,HYB,VA,VB,TOPO)
C****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  Construct orthogonal matrix T for transformation from AO's to
C  Natural Hybrid Bond Orbitals using input density matrix DM.
C
C  REQUIRED INPUT INCLUDES:
C        DM = DENSITY MATRIX IN ORTHONORMAL ATOMIC ORBITAL BASIS;
C                  REAL(1,NDIM;1,NDIM)
C      NBAS = NO. OF ORBITALS = ACTUAL DIMENSION OF DM,S,T,NAOL,DMT
C    NATOMS = NO. OF ATOMS (NOT INCLUDING GHOSTS) IN THE MOLECULE
C     IATNO = LIST OF ATOMIC NUMBERS
C    NAOCTR = ORBITAL LABEL LIST.  NAOCTR(I)=IAT IF NAO # I IS ON ATOM IAT
C                INTEGER(1,NDIM).  NAOS OF GIVEN ATOM GROUPED TOGETHER.
C      IW3C = 1 IF PROGRAM IS TO SEARCH FOR 3-CENTER BONDS,
C           = 0 OTHERWISE
C     GUIDE = WIBERG ATOM-ATOM BOND INDEX MATRIX, USED AS GUIDE FOR NBO SEARCH
C
C  OUTPUT:
C         T = BOND ORBITAL TRANSFORMATION MATRIX (NDIM,NDIM).
C                ROWS ARE LABELLED BY NAOS, COLUMNS BY NBOS.
C     LABEL = LIST OF BOND ORBITAL LABELS
C      IBXM = PERMUTATION LIST OF BOND ORBITAL LABELS (VERY IMPORTANT!)
C
      LOGICAL DETAIL,NOBOND,FIRST
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      INTEGER UL
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM),
     +            N3CTR,I3CTR(10,3)
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),V(NDIM),BORB(MXBO),
     * POL(NDIM,3),BNDOCC(NDIM),NAME(3),HYBEXP(3),
     * Q(MXAO,NDIM),BLK(MXBO,MXBO),EVAL(MXBO),C(MXBO,MXBO),
     * P(MXAO,MXAO),TA(MXAO,MXAO),HYB(MXAO),VA(MXAO),VB(MXAO),
     * GUIDE(NATOMS,NATOMS),TOPO(NATOMS*NATOMS)
      DATA GTHRSH/1.5D-1/
      DATA ISTAR,IBLNK/'*',' '/
      DATA NAME/'LP','BD','3C'/
      DATA LRY,LCR/'RY','CR'/
      DATA ZERO,ZEROP,TENTH,ONE,TWO,FOUR
     * /0.D0,1.D-6,0.1D0,1.0D0,2.0D0,4.0D0/
      DATA TWOP/2.0001D0/
      DATA PT8,PT99/0.8D0,0.99D0/
C
C  PRJINC, the amount to increase PRJTHR by if problems with linear
C  dependency between the hybrids arise.
C
      DATA PRJINC/0.05D0/
C
      NOPVAL(I) = NORBS(I) - INO(I)
C
      DETAIL = .FALSE.
      IF(IWDETL.NE.0) DETAIL = .TRUE.
      NOBOND = .FALSE.
      IF(JPRINT(10).NE.0) NOBOND = .TRUE.
C
C  Initial iteration loop:  If no satisfactory Lewis structure (all
C  antibond occupancies < 0.1) for THRESH = 1.90, THRESH is decremented
C  up to 4 times by 0.1 in search of a better structure.  If the DM is
C  not spinless, THRESH is set to 0.90 and is decremented as above.
C
      PRJTHR = ABS(PRJSET)
      THRESH = ABS(THRSET)
      IF(ISPIN.NE.0) THRESH = THRESH - ONE
      IF(NOBOND) THRESH = ONE
      IF(NOBOND.AND.(ISPIN.NE.0)) THRESH = ONE/TWO
      IF(ISPIN.NE.0) GTHRSH = GTHRSH/FOUR
C
C  Determine the atom ordering for the initial search for bonds:
C
      IF(NATOMS.EQ.1) THEN
        IORDER(1) = 1
        GOTO 45
      END IF
C
C  Find the two atoms which have the largest bond index:
C
      GMAX = ZERO
      DO 10 J = 2,NATOMS
        DO 5 I = 1,J-1
          IF(GUIDE(I,J).GT.GMAX) THEN
            GMAX = GUIDE(I,J)
            IAT  = I
          END IF
    5   CONTINUE
   10 CONTINUE
      IORDER(1) = IAT
C
C  Add atoms to IORDER according to these connectivities:
C
      ICNT = 1
      INXT = ICNT
      JCNT = ICNT
   15 IPTR = INXT
        I1ST = 1
        DO 20 I = 1,NATOMS
          TOPO(I) = GUIDE(I,IORDER(IPTR))
   20   CONTINUE
        CALL RANK(TOPO,NATOMS,NATOMS,JORDER)
        JPTR = 1
   25   IF(TOPO(JPTR).GT.PT8) THEN
          IFLG = 1
          DO 30 I = 1,ICNT
            IF(IORDER(I).EQ.JORDER(JPTR)) IFLG = 0
   30     CONTINUE
          IF(IFLG.EQ.1) THEN
            ICNT = ICNT + 1
            IORDER(ICNT) = JORDER(JPTR)
            IF(I1ST.EQ.1) THEN
              I1ST = 0
              INXT = ICNT
            END IF
          END IF
        ELSE
          GOTO 35
        END IF
        JPTR = JPTR + 1
        GOTO 25
C
   35   CONTINUE
        IF(I1ST.EQ.1) THEN
          JCNT = JCNT + 1
          INXT = JCNT
          IF(INXT.GT.NATOMS) GOTO 45
          IF(INXT.GT.ICNT) THEN
            KPTR = 0
   40       KPTR = KPTR + 1
            KFLG = 1
            DO 41 I = 1,ICNT
              IF(IORDER(I).EQ.KPTR) KFLG = 0
   41       CONTINUE
            IF(KFLG.EQ.0) GOTO 40
            ICNT = ICNT + 1
            IORDER(ICNT) = KPTR
          END IF
        END IF
      GOTO 15
C
   45 CONTINUE
      ITER   = 0
      IALARM = 0
   50 IF(IALARM.EQ.0) ITER = ITER + 1
C
C  Store density matrix in upper triangle of T:
C
      DO 60 J = 1,NBAS
        DO 60 I = 1,J
   60     T(I,J) = DM(I,J)
C
C  Zero arrays Q, POL, IATHY, INO, and LABEL:
C
      DO 100 I = 1,NBAS
        DO 70 K = 1,2
   70     LABEL(I,K) = IBLNK
        DO 80 K = 3,6
   80     LABEL(I,K) = 0
        DO 90 K = 1,3
          POL(I,K) = ZERO
   90     IATHY(I,K) = 0
        DO 100 K = 1,MXAO
  100     Q(K,I) = ZERO
      DO 110 I = 1,NATOMS
  110   INO(I) = 0
C
C  Remove core orbitals from the density matrix:
C
      IBD = 0
      CALL CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
C
C  Main NHO loops
C  --------------
C  Doubly occupied (IOCC=1) or singly occupied (IOCC=2) NHO's
C  If ISPIN.NE.0, search is only for singly occupied nbos (IOCC=1):
C
      OCCMX = THRESH
C
C  Main NHO loops over singles, doubles, and triples of atoms:
C
      NA1 = NATOMS + 1
      DO 310 IA1 = 1,NA1
        IA = IA1 - 1
        IF((IA.GT.0).AND.(NOPVAL(IORDER(IA)).LE.0)) GO TO 310
        DO 300 IB1 = 1,NA1
          IB = IB1 - 1
          IF((IB.GT.0).AND.(NOPVAL(IORDER(IB)).LE.0)) GO TO 300
          DO 290 IC1 = 2,NA1
            IC = IC1 - 1
            IF((IC.GT.0).AND.(NOPVAL(IORDER(IC)).LE.0)) GO TO 290
            IF(IA.NE.0) GO TO 130
            IF(IB.NE.0) GO TO 120
C
C  Lone pairs:
C
            NCTR = 1
            IAT1 = IORDER(IC)
            IAT2 = 0
            IAT3 = 0
            GO TO 140
C
C  Bond pairs:
C
  120       CONTINUE
            IF(NOBOND) GO TO 290
            NCTR = 2
            IAT1 = IORDER(IB)
            IAT2 = IORDER(IC)
            IAT3 = 0
            IF(IAT1.GE.IAT2) GO TO 290
            IF(GUIDE(IAT1,IAT2).LT.GTHRSH) GO TO 290
            GO TO 140
C
C  3-center bonds:
C
  130       CONTINUE
            IF(IW3C.NE.1) GO TO 320
            NCTR = 3
            IAT1 = IORDER(IA)
            IAT2 = IORDER(IB)
            IAT3 = IORDER(IC)
            IF(IAT1.GE.IAT2) GO TO 300
            IF(IAT2.GE.IAT3) GO TO 290
            IF(GUIDE(IAT1,IAT2).GT.GTHRSH) GO TO 140
            IF(GUIDE(IAT1,IAT3).GT.GTHRSH) GO TO 140
            IF(GUIDE(IAT2,IAT3).GT.GTHRSH) GO TO 140
            GO TO 290
  140       CONTINUE
C
C  Deplete DM of one(two) center orbitals if search for two(three)
C  center orbitals is beginning:
C
            IF(IWPRJ(NCTR).NE.0)
     *            CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD)
C
C  Load proper atomic blocks of DM into BLK:
C 
            CALL LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
C
C  Diagonalize BLK:
C
            CALL JACOBI(NB,BLK,EVAL,C,MXBO,MXBO,1)
C
C  Rank eigenvectors by occupancy eigenvalue:
C
            CALL RANK(EVAL,NB,MXBO,LARC)
            IF(DETAIL) WRITE(LFNPR,1400) IAT1,IAT2,IAT3
            IF(DETAIL) WRITE(LFNPR,1403) THRESH
            IF(DETAIL) WRITE(LFNPR,1405) (EVAL(IRNK),IRNK=1,NB)
            IACCEP = 0
            DO 250 IRNK = 1,NB
              IR = LARC(IRNK)
              OCC = EVAL(IRNK)
              DO 200 I = 1,NB
  200           BORB(I) = C(I,IR)
              IF(DETAIL) WRITE(LFNPR,1410) IRNK,OCC
              IF(DETAIL) WRITE(LFNPR,1420) (BORB(I),I=1,NB)
C
C  Throw out orbital if occupancy is less than the threshhold "OCCMX":
C
              IF(OCC.LT.OCCMX) GO TO 280
C
C  Check to see that bond orbital "BORB" doesn't contain previously used
C  hybrids:
C
              IF(NCTR.EQ.1) GO TO 240
              CALL PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,TA,HYB,VA,VB,HYBEXP)
              IF(.NOT.DETAIL) GO TO 220
              DO 210 IHYB = 1,NCTR
  210           WRITE(LFNPR,1500) IHYB,HYBEXP(IHYB)
  220         CONTINUE
              DO 230 IHYB = 1,NCTR
  230           IF(HYBEXP(IHYB).LT.PRJTHR) GO TO 250
  240         CONTINUE
              IBD = IBD + 1
              IACCEP = IACCEP + 1
C
C  Decompose "BORB" into its constituent atomic hybrids and store in Q:
C
              CALL STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
C
C  Construct bond orbital labels:
C
              LABEL(IBD,1) = NAME(NCTR)
              LABEL(IBD,2) = IBLNK
              LABEL(IBD,3) = IACCEP
              LABEL(IBD,4) = IAT1
              LABEL(IBD,5) = IAT2
              LABEL(IBD,6) = IAT3
              BNDOCC(IBD) = OCC
              IF(DETAIL) WRITE(LFNPR,1600) IBD,(LABEL(IBD,I),I=1,3)
  250         CONTINUE
  280       CONTINUE
  290       CONTINUE
  300     CONTINUE
  310   CONTINUE
  320 CONTINUE
C
C  Symmetric orthogonalization of principal hybrids:
C
      CALL ORTHYB(Q,BLK,TA,EVAL,C,IALARM,0)
C
C   IALARM sounds the alarm that there is linear dependency between some
C   of the hybrids. The remedy is to increase prjthr and repeat the NBO
C   search. IALARM is equal to the number of the violating atom.
C
      IF(IALARM.NE.0) THEN
        OLDPRJ = PRJTHR
        PRJTHR = OLDPRJ + PRJINC
        IF(JPRINT(5).NE.0) WRITE(LFNPR,1800) OLDPRJ,PRJTHR
        IF(PRJTHR.GE.PT99) THEN
          WRITE(LFNPR,1810) IALARM
          JPRINT(1) = -1
          RETURN
        END IF
        GOTO 700
      END IF
C
C  Augment open-valence atoms with non-arbitrary hybrids orthogonal to
C  those found previously:
C
      DO 580 IA = 1,NATOMS
        IF(NOPVAL(IA).LE.0) GO TO 580
C
C  IULA: upper limit of NAOs on atom. Find NMB, the number of natural
C  minimal basis functions on the atom:
C
        LLA = LL(IA)
        IULA = UL(IA)
        NMB = 0
        DO 470 I = LLA,IULA
          IF(LSTOCC(I).EQ.1) NMB = NMB + 1
  470   CONTINUE
C
C  Find the number of bond, core, and lone pair hybrids on the atom, IOCC:
C  Also find IOCCLP, number of lone pair orbitals already found on IA, for
C  use in labelling the extra lone pairs below:
C
        IOCC = 0
        IOCCLP = 0
        DO 480 IB = 1,IBD
          IF((LABEL(IB,4).NE.IA).AND.(LABEL(IB,5).NE.IA).AND.
     *            (LABEL(IB,6).NE.IA)) GO TO 480
          IOCC = IOCC + 1
          IF(LABEL(IB,1).EQ.NAME(1)) IOCCLP = IOCCLP + 1
  480   CONTINUE
C
C  NEXLP: number of extra (low occupancy) LP orbitals on atom IAT. (This
C  is the number of low occupancy orbitals with valence shell character)
C  Set NEXLP to zero if (NMB-IOCC) is less than zero in order that the
C  orbitals are not miscounted!!
C
        NEXLP = NMB - IOCC
        IF(NEXLP.LT.0) NEXLP = 0
        NOCC = INO(IA)
        CALL FRMPRJ(P,IA,Q,NOCC,TA,VA,VB)
        NORB = NORBS(IA)
        NAUGM = NORB - NOCC
        CALL AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
C
C  Stash and label extra lone pairs that AUGMNT put in BLK: (These ar
C  taken to be the highest occupied orbitals, which AUGMNT places first)
C
        DO 510 IAUGM = 1,NEXLP
          DO 500 J = 1,NORB
  500       BORB(J) = BLK(J,IAUGM)
          IBD = IBD + 1
          CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB)
          LABEL(IBD,1) = NAME(1)
          LABEL(IBD,2) = IBLNK
          LABEL(IBD,3) = IAUGM + IOCCLP
          LABEL(IBD,4) = IA
          LABEL(IBD,5) = 0
          LABEL(IBD,6) = 0
  510   CONTINUE
C
C  Stash and label the Rydberg orbitals that AUGMNT put in BLK:
C
        IRYD = 0
        NSTART = NEXLP + 1
        DO 540 IAUGM = NSTART,NAUGM
          DO 530 J = 1,NORB
  530       BORB(J) = BLK(J,IAUGM)
          IBD = IBD + 1
          IRYD = IRYD + 1
          CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB)
          LABEL(IBD,1) = LRY
          LABEL(IBD,2) = ISTAR
          LABEL(IBD,3) = IRYD
          LABEL(IBD,4) = IA
          LABEL(IBD,5) = 0
          LABEL(IBD,6) = 0
  540     CONTINUE
  580   CONTINUE
C
C  Include antibond labels:
C
      IBO = IBD
      DO 660 I = 1,IBO
C
C  Exit loop if LABEL(I,1) is 'LP', 'RY', or 'CR':
C
        IF(LABEL(I,1).EQ.NAME(1)) GO TO 660
        IF(LABEL(I,1).EQ.LRY) GO TO 660
        IF(LABEL(I,1).EQ.LCR) GO TO 660
         NAB = 1
         IF(LABEL(I,1).EQ.NAME(3)) NAB = 2
         DO 650 IAB = 1,NAB
           IBD = IBD + 1
           DO 640 J = 1,6
  640        LABEL(IBD,J) = LABEL(I,J)
           LABEL(IBD,2) = ISTAR
  650      CONTINUE
  660   CONTINUE
C
C  Replace density matrix DM from T:
C
  700 CONTINUE
      DO 740 J=1,NBAS
        DO 740 I=1,J
          DM(I,J)=T(I,J)
          DM(J,I)=DM(I,J)
          T(J,I)=ZERO
  740     T(I,J)=ZERO
C
C  Remember the alarm!
C
      IF(IALARM.NE.0) GO TO 50
C
C  Miscounted bond orbitals...exit for open shell:
C
      IF(IBD.NE.NBAS) THEN
        WRITE(LFNPR,1200) THRESH,IBD,NBAS
        WRITE(LFNPR,1210) (I,(LABEL(I,J),J=1,6),I=1,IBD)
        STOP
      END IF
C
C  Find new polarization parameters for orthonormal hybrids:
C
      CALL REPOL(DM,Q,POL,BLK,EVAL,C,IBD)
C
C  Form final T-NAB (NAO to NBO transformation) from orthonormal
C  hybrids:
C
      CALL FORMT(T,Q,POL)
C
C  Find occupancies, find total number of electrons and occupied orbitals:
C
      TOTELE = ZERO
      DO 800 I = 1,NBAS
        OCCI = ZERO
        DO 790 J = 1,NBAS
          DO 790 K = 1,NBAS
  790       OCCI = OCCI + T(J,I) * DM(J,K) * T(K,I)
        IF(ABS(OCCI).LT.ZEROP) OCCI = ZERO
        IF(OCCI.GT.TWOP) GO TO 960
        ZEROPM = -ZEROP
        IF(OCCI.LT.ZEROPM) GO TO 960
        BNDOCC(I) = OCCI
        V(I) = OCCI
        TOTELE = TOTELE + BNDOCC(I)
  800 CONTINUE
      NEL = TOTELE + TENTH
      IF(ABS(TOTELE-NEL).GT.5E-4) GO TO 970
      TOTELE = NEL
      NOCC = NEL
      IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2)
C
C  Make sure all but the NOCC highest occupied NBOs are starred:
C
      CALL RANK(V,NBAS,NDIM,LARC)
      DO 804 I = 1,NOCC
        IR = LARC(I)
        LABEL(IBXM(IR),2) = IBLNK
  804 CONTINUE
      DO 805 I = NOCC+1,NBAS
        IR = LARC(I)
        LABEL(IBXM(IR),2) = ISTAR
  805 CONTINUE
C
C  Determine whether this is a good resonance structure:
C
      CALL CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
      IF(ICONT.EQ.0) THEN
        JPRINT(1) = -1
        RETURN
      END IF
      IF(ICONT.EQ.-1) GO TO 50
      IF(ICONT.EQ.1) GO TO 50
C
C  Before final return, write out info about core orbitals which
C  were isolated in subroutine CORE:
C
      CRTHRS = CRTSET
      IF(ISPIN.NE.0) CRTHRS = CRTHRS - ONE
      FIRST = .TRUE.
      DO 952 IAT = 1,NATOMS
        ILOW = 0
        DO 951 I = 1,NBAS
          IF(LABEL(IBXM(I),1).EQ.LCR.AND.LABEL(IBXM(I),4).EQ.IAT
     +       .AND.BNDOCC(I).LT.CRTHRS) ILOW = ILOW + 1
  951   CONTINUE
        IF(ILOW.NE.0) THEN
          IF(FIRST) THEN
            FIRST = .FALSE.
            NAM = NAMEAT(IATNO(IAT))
            IF(ILOW.NE.1) THEN
              IF(JPRINT(5).EQ.1) WRITE(LFNPR,3010) ILOW,CRTHRS,NAM,IAT
            ELSE
              IF(JPRINT(5).EQ.1) WRITE(LFNPR,3011) ILOW,CRTHRS,NAM,IAT
            END IF
          ELSE
            NAM = NAMEAT(IATNO(IAT))
            IF(ILOW.NE.1) THEN
              IF(JPRINT(5).EQ.1) WRITE(LFNPR,3020) ILOW,CRTHRS,NAM,IAT
            ELSE
              IF(JPRINT(5).EQ.1) WRITE(LFNPR,3021) ILOW,CRTHRS,NAM,IAT
            END IF
          END IF
        END IF
  952 CONTINUE
      RETURN
C
C  Problems with a bond orbital occupancy:
C
  960 WRITE(LFNPR,1300) OCCI
      JPRINT(1) = -1
      RETURN
C
C  Total number of electrons is not an integer:
C
  970 WRITE(LFNPR,1310) TOTELE
      JPRINT(1) = -1
      RETURN
C
 1200 FORMAT(/,1X,'For an occupancy threshold of ',F4.2,' the search',
     + ' for NBOs found',/,1X,I3,' orbitals orbitals rather than ',I4)
 1210 FORMAT(3X,'Label ',I3,':',A3,A1,I2,3I3)
 1300 FORMAT(/,1X,'A bond orbital with an occupancy of ',F8.5,
     + ' electrons was found!',/,1X,'Please check you input data.')
 1310 FORMAT(/,1X,'The total number of electron is not an integer:',
     + F10.5,/,1X,'Please check your input data.')
 1400 FORMAT(/,1X,'Search of DM block between the following atoms:',
     +          3I4)
 1403 FORMAT(6X,'Select orbitals with eigenvalue > ',F9.6)
 1405 FORMAT(6X,8F9.6)
 1410 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':')
 1420 FORMAT(11X,8F7.4)
 1500 FORMAT(11X,'Hybrid ',I1,' in eigenvector has a projection ',
     +    'expectation of ',F6.3)
 1600 FORMAT(11X,'*** NBO accepted: Number',I3,'.   Label:',A2,A1,
     + '(',I2,')')
 1800 FORMAT(/4X,'PRJTHR will be raised from ',F6.3,' to',F6.3,
     + ' and the NBO search repeated.',/)
 1810 FORMAT(//,1X,'Linearly independent hybrids for atom',I3,
     +' cannot be found.',/,1X,'The NBO program must abort.')
 3010 FORMAT(/,1X,
     +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals ',
     +'found on ',A2,I2)
 3011 FORMAT(/,1X,
     +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbital  ',
     +'found on ',A2,I2)
 3020 FORMAT(1X,
     +'        ',I3,' low occupancy (<',F6.4,'e) core orbitals ',
     +'found on ',A2,I2)
 3021 FORMAT(1X,
     +'        ',I3,' low occupancy (<',F6.4,'e) core orbital  ',
     +'found on ',A2,I2)
      END
C*****************************************************************************
      SUBROUTINE CHSDRV(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
     *                                       P,TA,HYB,VA,VB,TOPO)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      LOGICAL END,ERROR,EQUAL
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM),
     +            N3CTR,I3CTR(10,3)
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),GUIDE(NATOMS,NATOMS),
     * BNDOCC(NDIM),POL(NDIM,3),Q(MXAO,NDIM),V(NDIM),BLK(MXBO,MXBO),
     * C(MXBO,MXBO),EVAL(MXBO),BORB(MXBO),P(MXAO,MXAO),TA(MXAO,MXAO),
     * HYB(MXAO),VA(MXAO),VB(MXAO),TOPO(NATOMS,NATOMS)
      DIMENSION KEYWD(6),KLONE(4),KBOND(4),K3CBON(6),KALPHA(5),
     * KBETA(4),IVAL(4),KALT(4)
      DATA KLONE/1HL,1HO,1HN,1HE/,
     *     KBOND/1HB,1HO,1HN,1HD/,
     *     K3CBON/1H3,1HC,1HB,1HO,1HN,1HD/,
     *     KALPHA/1HA,1HL,1HP,1HH,1HA/,
     *     KBETA/1HB,1HE,1HT,1HA/,
     *     KS/1HS/,KD/1HD/,KT/1HT/,KQ/1HQ/,
     *     KALT/1H$,1HE,1HN,1HD/
C
C  Search for `ALPHA' or `BETA' character string in case of alpha or
C  beta spin density matrices:
C
      IF(ISPIN.EQ.2) THEN
   20   LENG = 5
          CALL HFLD(KEYWD,LENG,END)
          IF(END.AND.LENG.EQ.0) GOTO 810
          IF(.NOT.EQUAL(KEYWD,KALPHA,5)) GOTO 20
        CONTINUE
      ELSE IF(ISPIN.EQ.-2) THEN
   30   LENG = 5
          CALL HFLD(KEYWD,LENG,END)
          IF(END.AND.LENG.EQ.0) GOTO 820
          IF(.NOT.EQUAL(KEYWD,KBETA,4)) GOTO 30
        CONTINUE
      END IF
C
C  Fill diagonal elements of the TOPO matrix with nominal numbers of
C  lone pairs to be found on each atom:
C
      DO 50 IAT = 1,NATOMS
        NLP = 0
        CALL VALTBL(IAT,IVAL)
        DO 40 L = 0,3
          NLP = NLP + IVAL(L+1)*(2*L + 1)
   40   CONTINUE
        NTOPO(IAT,IAT) = 100 + NLP
   50 CONTINUE
C
C  Read in chosen lone pairs, bonds, and 3-center bonds:
C
      NCTR = 0
      N3CTR = 0
   60 CONTINUE
        LENG = 6
        CALL HFLD(KEYWD,LENG,END)
        IF(END.OR.EQUAL(KEYWD,KALT,4)) GOTO 300
        NCTRO = NCTR
        NCTR = 0
        IF(EQUAL(KEYWD,KLONE,4))  NCTR = 1
        IF(EQUAL(KEYWD,KBOND,4))  NCTR = 2
        IF(EQUAL(KEYWD,K3CBON,6)) NCTR = 3
        IF(NCTR.EQ.0) GO TO 1010
        IF(NCTR.LT.NCTRO) GO TO 1020
        GOTO (100,150,200), NCTR
C
C  Read in lone pairs:
C
  100 CONTINUE
        CALL IFLD(IAT,ERROR)
        IF(ERROR) THEN
          LENG = 6
          CALL HFLD(KEYWD,LENG,END)
          GO TO 60
        END IF
        CALL IFLD(NUM,ERROR)
        IF(ERROR) GOTO 830
        NTOPO(IAT,IAT) = NUM
      GOTO 100
C
C  Read in bonds:
C
  150 CONTINUE
        LENG = 1
        CALL HFLD(KEYWD,LENG,END)
        IF(END) GOTO 60
        NUM = 0
        IF(EQUAL(KEYWD,KS,1)) NUM = 1
        IF(EQUAL(KEYWD,KD,1)) NUM = 2
        IF(EQUAL(KEYWD,KT,1)) NUM = 3
        IF(EQUAL(KEYWD,KQ,1)) NUM = 4
        IF(NUM.EQ.0) GOTO 840
        CALL IFLD(IAT1,ERROR)
        IF(ERROR) GOTO 840
        CALL IFLD(IAT2,ERROR)
        IF(ERROR) GOTO 840
        IAT = MAX0(IAT1,IAT2)
        JAT = MIN0(IAT1,IAT2)
        NTOPO(IAT,JAT) = NUM
        NTOPO(JAT,IAT) = NUM
      GOTO 150
C
C  Read in 3-center bonds:
C
  200 CONTINUE
        IF(IW3C.NE.1) IW3C = 1
        LENG = 1
        CALL HFLD(KEYWD,LENG,END)
        IF(END) GOTO 60
        NUM = 0
        IF(EQUAL(KEYWD,KS,1)) NUM = 1
        IF(EQUAL(KEYWD,KD,1)) NUM = 2
        IF(EQUAL(KEYWD,KT,1)) NUM = 3
        IF(EQUAL(KEYWD,KQ,1)) NUM = 4
        IF(NUM.EQ.0) GOTO 860
        CALL IFLD(IAT1,ERROR)
        IF(ERROR) GOTO 860
        CALL IFLD(IAT2,ERROR)
        IF(ERROR) GOTO 860
        CALL IFLD(IAT3,ERROR)
        IF(ERROR) GOTO 860
        N3CTR = N3CTR + 1
        IF(N3CTR.GT.10) GOTO 870
        I3CTR(N3CTR,1) = IAT1
        I3CTR(N3CTR,2) = IAT2
        I3CTR(N3CTR,3) = IAT3
      GOTO 200
C
C  Modify nominal sets of lone pairs by number of bonds and 3-center
C  bonds.
C
  300 CONTINUE
      DO 330 IAT = 1,NATOMS
        NLP = NTOPO(IAT,IAT)
        IF(NLP.LT.100) GOTO 330
        NLP = MOD(NLP,100)
        NBD = 0
        DO 310 JAT = 1,NATOMS
          IF(IAT.NE.JAT.AND.NTOPO(JAT,IAT).NE.0) THEN
            NBD = NBD + NTOPO(JAT,IAT)
          END IF
  310   CONTINUE
        DO 320 KAT = 1,3
          DO 315 JAT = 1,N3CTR
            IF(I3CTR(JAT,KAT).EQ.IAT) NBD = NBD + 1
  315     CONTINUE
  320   CONTINUE
        NLP = NLP - NBD
        IF(NLP.LT.0) NLP = 0
        NTOPO(IAT,IAT) = NLP
  330 CONTINUE
C
C  Use CHOOSE to find bond orbitals using NTOPO and I3CTR:
C
      IFLG = 0
      CALL CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,P,TA,HYB,
     +            VA,VB,TOPO,IFLG)
      RETURN
C
  810 WRITE(LFNPR,1180)
      JPRINT(1) = -1
      RETURN
C
  820 WRITE(LFNPR,1190)
      JPRINT(1) = -1
      RETURN
  830 WRITE(LFNPR,1130)
      JPRINT(1) = -1
      RETURN
C
  840 WRITE(LFNPR,1140)
      JPRINT(1) = -1
      RETURN
C
  860 WRITE(LFNPR,1160)
      JPRINT(1) = -1
      RETURN
C
  870 WRITE(LFNPR,1170)
      JPRINT(1) = -1
      RETURN
C
 1010 WRITE(LFNPR,1110) (KEYWD(I),I=1,6)
      JPRINT(1) = -1
      RETURN
C
 1020 WRITE(LFNPR,1120)
      JPRINT(1) = -1
      RETURN
C
 1110 FORMAT(/1X,'Error in input of bond orbitals:',/,1X,
     * 'Keyword for orbital type is not LONE, BOND, or 3CBOND (read `',
     * 6A1,''')')
 1120 FORMAT(/1X,'Error in input of bond orbitals:',/,1X,
     * 'Orbital types should be in the order: LONE, BOND, 3CBOND')
 1130 FORMAT(/1X,'Error in input of bond orbitals:',/,1X,
     * 'Unrecognizable characters in input of lone orbitals')
 1140 FORMAT(/1X,'Error in input of bond orbitals:',/,1X,
     * 'Unrecognizable characters in input of two center orbitals')
 1160 FORMAT(/1X,'Error in input of bond orbitals:',/,1X,
     * 'Unrecognizable characters in input of three center orbitals')
 1170 FORMAT(/1X,'Too many three center bonds:',
     * '  Increase parameter MAX3C')
 1180 FORMAT(/1X,'End of file encountered before the word ALPHA was ',
     * 'found')
 1190 FORMAT(/1X,'End of file encountered before the word BETA was ',
     * 'found')
      END
C*****************************************************************************
C
C     SUBROUTINES CALLED BY NATHYB AND CHSDRV FOR FORMING NBOS 
C
C
C*****************************************************************************
      SUBROUTINE CHOOSE(DM,T,GUIDE,BNDOCC,POL,Q,V,BLK,C,EVAL,BORB,
     *                                    P,TA,HYB,VA,VB,TOPO,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  Construct orthogonal matrix T for transformation from AO's to
C  Natural Hybrid Bond Orbitals using input density matrix DM
C  with the chosen bonding pattern read from LFNIN
C
      LOGICAL DETAIL,FIRST,PRINT,LEFT
      INTEGER UL
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM),
     +            N3CTR,I3CTR(10,3)
C
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),GUIDE(NATOMS,NATOMS),
     * BNDOCC(NDIM),POL(NDIM,3),Q(MXAO,NDIM),V(NDIM),BLK(MXBO,MXBO),
     * C(MXBO,MXBO),EVAL(MXBO),BORB(MXBO),P(MXAO,MXAO),TA(MXAO,MXAO),
     * HYB(MXAO),VA(MXAO),VB(MXAO),TOPO(NATOMS,NATOMS)
      DIMENSION NAME(3),HYBEXP(3),KTOPO(MAXATM,MAXATM),KFLG(10)
      DIMENSION SCR(MAXATM*(MAXATM-1)/2),IPT(MAXATM*(MAXATM-1)/2)
C
      DATA ISTAR,IBLNK,NAME,LRY,LCR/'*',' ','LP','BD','3C','RY','CR'/
      DATA ZERO,ZEROP,TENTH,PT99,ONE,TWO,TWOP
     + /0.0D0,1.0D-6,0.1D0,0.99D0,1.0D0,2.0D0,2.0001D0/
C
C  IFLG is a print flag on entering CHOOSE.  If set to 0(1), CHOOSE
C  will(not) print some output to LFNPR.  On exit, if IFLG is set to
C  -1, there was an error in finding the requested structure:
C
C  PRJINC, the amount to increase PRJTHR by if problems with linear
C  dependency between the hybrids arise.
C
      DATA PRJINC/0.05D0/
C
      NOPVAL(I) = NORBS(I) - INO(I)
C
      PRINT = .FALSE.
      IF(IFLG.EQ.0) PRINT = .TRUE.
      IF(JPRINT(5).EQ.0) PRINT = .FALSE.
      DETAIL = .FALSE.
      IF(IWDETL.NE.0) DETAIL = .TRUE.
      PRJTHR = ABS(PRJSET)
      ITER = 0
C
C  Initialize KTOPO and KFLG arrays:  (KFLG is set to 1 if the 3-center
C  bond has not been fund yet.)
C
      DO 10 I = 1,NATOMS
        DO 5 J = 1,I
          KTOPO(I,J) = NTOPO(I,J)
          KTOPO(J,I) = NTOPO(J,I)
    5   CONTINUE
   10 CONTINUE
      DO 15 I = 1,N3CTR
        KFLG(I) = 1
   15 CONTINUE
C
C  Determine the atom ordering for the search for bond orbitals:
C
      IF(NATOMS.EQ.1) THEN
        IORDER(1) = 1
      ELSE
        II = 0
        DO 20 JAT = 2,NATOMS
          DO 19 IAT = 1,JAT-1
            II = II + 1
            SCR(II) = KTOPO(IAT,JAT) - GUIDE(IAT,JAT)
   19     CONTINUE
   20   CONTINUE
        NN = NATOMS * (NATOMS - 1) / 2
        CALL RANK(SCR,NN,NN,IPT)
C
C  Begin search for bond orbitals where the formal bond order is much
C  greater than the corresponding Wiberg bond index:
C
        IPOS = 0
        JPOS = 0
   21   CONTINUE
          JPOS = JPOS + 1
          IF(JPOS.GT.NN) STOP 'Problems with atom permutation list'
          IAT  = IPT(JPOS)
          JAT  = 2
   22     CONTINUE
            IF(JAT.GT.IAT) GOTO 23
            IAT = IAT - JAT + 1
            JAT = JAT + 1
          GOTO 22
   23     CONTINUE
C
C  Add IAT and JAT to the atom permutation list IORDER:
C
          MFLG = 0
          DO 24 I = 1,IPOS
            IF(IORDER(I).EQ.IAT) MFLG = 1
   24     CONTINUE
          IF(MFLG.EQ.0) THEN
            IPOS = IPOS + 1
            IORDER(IPOS) = IAT
          END IF
          MFLG = 0
          DO 25 I = 1,IPOS
            IF(IORDER(I).EQ.JAT) MFLG = 1
   25     CONTINUE
          IF(MFLG.EQ.0) THEN
            IPOS = IPOS + 1
            IORDER(IPOS) = JAT
          END IF
        IF(IPOS.LT.NATOMS) GOTO 21
      END IF
C
C  Return to here if it should prove necessary to raise PRJTHR:
C
   35 CONTINUE
      ITER = ITER + 1
      OCCTHR = ABS(THRSET)
      IF(ISPIN.NE.0) OCCTHR = OCCTHR - ONE
      OCCTHR = OCCTHR + TENTH
C
C  Store density matrix in upper triangle of T:
C
      DO 50 J = 1,NBAS
        DO 40 I = 1,J
          T(I,J) = DM(I,J)
   40   CONTINUE
   50 CONTINUE
C
C  Zero arrays Q,POL,IATHY,INO,LABEL:
C
      DO 100 I = 1,NBAS
        DO 60 K = 1,2
          LABEL(I,K) = IBLNK
   60   CONTINUE
        DO 70 K = 3,6
          LABEL(I,K) = 0
   70   CONTINUE
        DO 80 K = 1,3
          POL(I,K) = ZERO
          IATHY(I,K) = 0
   80   CONTINUE
        DO 90 K = 1,MXAO
          Q(K,I) = ZERO
   90   CONTINUE
  100 CONTINUE
      DO 110 I = 1,NATOMS
        INO(I) = 0
  110 CONTINUE
C
C  Remove core orbitals from the density matrix:
C
      IBD = 0
      CALL CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
C
C  Return here if there are still more lone pairs or bonds to be found.
C  Lower the occupancy threshold for acceptance by a tenth:
C
  115 CONTINUE
      OCCTHR = OCCTHR - TENTH
      LEFT = .FALSE.
C
C   ********      START DIRECTED NBO SEARCH      *********
C
C  Loop over numbers of centers, removing lone pairs and 2- and 3-center
C  bonds from the density matrix according to KTOPO and I3CTR:
C
      NCTR = 0
  120 NCTR = NCTR + 1
C
C  Deplete DM of one(two) center orbitals if search for two(three)
C  center orbitals is beginning:
C
        IF(NCTR.NE.1) CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD)
C
        ICNTR = 0
C
C  Return here for 3-c bonds and lone pairs:
C
  130   ICNTR = ICNTR + 1
          IF(NCTR.EQ.1) THEN
            IF(ICNTR.GT.NATOMS) GOTO 120
            NUM = KTOPO(IORDER(ICNTR),IORDER(ICNTR))
            IF(NUM.LE.0) GOTO 130
            IAT1 = IORDER(ICNTR)
            IAT2 = 0
            IAT3 = 0
            GOTO 200
          ELSE IF(NCTR.EQ.2) THEN
            IF(ICNTR.GT.NATOMS) GOTO 120
            JCNTR = ICNTR
C
C  Return here for 2-c bonds:
C
  150       JCNTR = JCNTR + 1
              IF(JCNTR.GT.NATOMS) GOTO 130
              NUM = KTOPO(IORDER(JCNTR),IORDER(ICNTR))
              IF(NUM.EQ.0) GOTO 150
              IAT1 = MIN(IORDER(ICNTR),IORDER(JCNTR))
              IAT2 = MAX(IORDER(ICNTR),IORDER(JCNTR))
              IAT3 = 0
              GOTO 200
          ELSE IF(NCTR.EQ.3) THEN
            IF(ICNTR.GT.N3CTR) GOTO 120
            IF(KFLG(ICNTR).EQ.0) GOTO 130
            NUM = 1
            IAT1 = MIN(I3CTR(ICNTR,1),I3CTR(ICNTR,2),I3CTR(ICNTR,3))
            IAT3 = MAX(I3CTR(ICNTR,1),I3CTR(ICNTR,2),I3CTR(ICNTR,3))
            IAT2 = I3CTR(ICNTR,1)
            IF(IAT2.EQ.IAT1.OR.IAT2.EQ.IAT3) IAT2 = I3CTR(ICNTR,2)
            IF(IAT2.EQ.IAT1.OR.IAT2.EQ.IAT3) IAT2 = I3CTR(ICNTR,3)
            GOTO 200
          ELSE 
            GOTO 300
          END IF
C
C  Load proper atomic blocks of DM into BLK, and diagonalize BLK:
C
  200 CONTINUE
      CALL LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
      CALL JACOBI(NB,BLK,EVAL,C,MXBO,MXBO,1)
C
C  Rank eigenvectors by occupancy eigenvalue:
C
      CALL RANK(EVAL,NB,MXBO,LARC)
      IF(DETAIL) WRITE(LFNPR,1400) IAT1,IAT2,IAT3
      IF(DETAIL) WRITE(LFNPR,1402) NUM,OCCTHR
      IF(DETAIL) WRITE(LFNPR,1405) (EVAL(IRNK),IRNK=1,NB)
C
C  Loop over eigenvalues selecting the NUM highest occupied:
C
      IACCEP = 0
      DO 250 IRNK = 1,NB
        IR = LARC(IRNK)
        OCC = EVAL(IRNK)
        DO 210 I = 1,NB
  210     BORB(I) = C(I,IR)
        IF(DETAIL) WRITE(LFNPR,1410) IRNK,OCC
        IF(DETAIL) WRITE(LFNPR,1420) (BORB(I),I=1,NB)
C
C  If this is a low occupancy orbital, skip the rest of these and can come
C  back to them later:
C
        IF(OCC.LT.OCCTHR) THEN
          IF(NCTR.EQ.1) THEN
            KTOPO(IAT1,IAT1) = NUM - IACCEP
            IF(DETAIL) WRITE(LFNPR,1610) KTOPO(IAT1,IAT1)
          ELSE IF(NCTR.EQ.2) THEN
            KTOPO(IAT1,IAT2) = NUM - IACCEP
            KTOPO(IAT2,IAT1) = KTOPO(IAT1,IAT2)
            IF(DETAIL) WRITE(LFNPR,1610) KTOPO(IAT1,IAT2)
          ELSE
            IONE = 1
            IF(DETAIL) WRITE(LFNPR,1610) IONE
          END IF
          IF(LEFT) THEN
            IF(OCCMAX.LT.OCC) OCCMAX = OCC
          ELSE
            LEFT = .TRUE.
            OCCMAX = OCC
          END IF
          GOTO 280
        END IF
C
C  Check to see if bond orbital "BORB" contains previously used hybrids:
C
C        IF(NCTR.NE.1) THEN
          CALL PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,TA,HYB,VA,VB,HYBEXP)
          IF(DETAIL) THEN
            DO 220 IHYB = 1,NCTR
              WRITE(LFNPR,1500) IHYB,HYBEXP(IHYB)
  220       CONTINUE
          END IF
          DO 230 IHYB = 1,NCTR
            IF(HYBEXP(IHYB).LT.PRJTHR) GOTO 250
  230     CONTINUE
C        END IF
        IBD = IBD + 1
        IACCEP = IACCEP + 1
C
C  Decompose "BORB" into its constituent atomic hybrids and store in Q:
C
        CALL STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
C
C  Construct bond orbital labels:
C
        IF(NCTR.EQ.1) THEN
          ISHIFT = NTOPO(IAT1,IAT1) - KTOPO(IAT1,IAT1)
        ELSE IF(NCTR.EQ.2) THEN
          ISHIFT = NTOPO(IAT1,IAT2) - KTOPO(IAT1,IAT2)
        ELSE
          ISHIFT = 0
        END IF
        LABEL(IBD,1) = NAME(NCTR)
        LABEL(IBD,2) = IBLNK
        LABEL(IBD,3) = IACCEP + ISHIFT
        LABEL(IBD,4) = IAT1
        LABEL(IBD,5) = IAT2
        LABEL(IBD,6) = IAT3
        BNDOCC(IBD) = OCC
        IF(DETAIL) WRITE(LFNPR,1600) IBD,(LABEL(IBD,I),I=1,3)
        IF(IACCEP.EQ.NUM) THEN
          IF(NCTR.EQ.1) THEN
            KTOPO(IAT1,IAT1) = 0
          ELSE IF(NCTR.EQ.2) THEN
            KTOPO(IAT1,IAT2) = 0
            KTOPO(IAT2,IAT1) = 0
          ELSE
            KFLG(ICNTR) = 0
          END IF
          GOTO 280
        END IF
  250 CONTINUE
        IF(IACCEP.NE.NUM.AND.NCTR.EQ.2.AND.PRINT)
     *            WRITE(LFNPR,2000) PRJTHR,IACCEP,NUM,IAT1,IAT2
        IF(IACCEP.NE.NUM.AND.NCTR.EQ.3.AND.PRINT)
     *            WRITE(LFNPR,2100) PRJTHR,IACCEP,NUM,IAT1,IAT2,IAT3
        IFLG = -1
  280 IF(NCTR.EQ.1.OR.NCTR.EQ.3) THEN
        GOTO 130
      ELSE
  290   JCNTR=JCNTR+1
        IF(JCNTR.GT.NATOMS) GOTO 130
        NUM=KTOPO(IORDER(JCNTR),IORDER(ICNTR))
        IF(NUM.EQ.0) GOTO 290
        IAT1=IORDER(ICNTR)
        IAT2=IORDER(JCNTR)
        IAT3=0
        GOTO 200
      END IF
C
C   ******** END OF LOOP FOR DIRECTED NBO SEARCH *********
C
  300 CONTINUE
C
C  If some orbitals were left behind, go back and fetch them:
C
      IF(LEFT) THEN
        OCCTHR = OCCMAX
        GOTO 115
      END IF
C
C  Symmetrically orthogonalize principal hybrids:
C
      CALL ORTHYB(Q,BLK,TA,EVAL,C,IALARM,IFLG)
C
C  IALARM sounds the alarm that there is linear dependency between some of the
C  hybrids.  IALARM is equal to the number of the violating atom.  Replenish
C  DM from T and repeat the NBO search:
C
      IF(IALARM.NE.0) THEN
        OLDPRJ = PRJTHR
        PRJTHR = OLDPRJ + PRJINC
        IF(PRINT) WRITE(LFNPR,1800) OLDPRJ,PRJTHR
        IF(PRJTHR.GE.PT99) THEN
          IF(PRINT) WRITE(LFNPR,1810) IALARM
          IFLG = -1
          JPRINT(1) = -1
          RETURN
        END IF
        GOTO 700
      END IF
C
C  Augment open-valence atoms with non-arbitrary hybrids orthogonal to those
C  found previously:
C
      DO 580 IA = 1,NATOMS
        IF(NOPVAL(IA).LE.0) GOTO 580
C
C  Find NMB, the number of natural minimal basis functions on this atom:
C
        LLA = LL(IA)
        IULA = UL(IA)
        NMB = 0
        DO 470 I = LLA,IULA
          IF(LSTOCC(I).EQ.1) NMB = NMB + 1
  470   CONTINUE
C
C  Find the number of bond, core, and lone pair hybrids on this atom, IOCC.
C  Also find IOCCLP, the number of lone pair orbitals already found
C  on atom IA for use in labelling the extra lone pairs below:
C
        IOCC = 0
        IOCCLP = 0
        DO 480 IB = 1,IBD
          IF((LABEL(IB,4).NE.IA).AND.(LABEL(IB,5).NE.IA).AND.
     *            (LABEL(IB,6).NE.IA)) GOTO 480
          IOCC = IOCC + 1
          IF(LABEL(IB,1).EQ.NAME(1)) THEN
            IOCCLP = IOCCLP + 1
          END IF
  480   CONTINUE
C
C  NEXLP, the number of extra (low occupancy) LP orbitals on atom IAT.
C  (This is the number of low occupancy orbitals with valence shell character)
C  Set NEXLP to zero if (NMB-IOCC) is less than zero!!
C
        NEXLP = NMB - IOCC
        IF(NEXLP.LT.0) NEXLP = 0
        NOCC = INO(IA)
        CALL FRMPRJ(P,IA,Q,NOCC,TA,VA,VB)
        NORB = NORBS(IA)
        NAUGM = NORB - NOCC
        CALL AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
C
C  Stash and label extra lone pairs that AUGMNT put in BLK:
C  (These are taken to be the highest occupied orbitals, which
C  AUGMNT places first)
C
        DO 510 IAUGM = 1,NEXLP
          DO 500 J = 1,NORB
  500       BORB(J) = BLK(J,IAUGM)
          IBD = IBD + 1
          CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB)
          LABEL(IBD,1) = NAME(1)
          LABEL(IBD,2) = ISTAR
          LABEL(IBD,3) = IAUGM+IOCCLP
          LABEL(IBD,4) = IA
          LABEL(IBD,5) = 0
          LABEL(IBD,6) = 0
  510   CONTINUE
C
C  Stash and label the Rydberg orbitals that AUGMNT put in BLK:
C
        IRYD = 0
        NSTART = NEXLP + 1
        DO 540 IAUGM = NSTART,NAUGM
          DO 530 J = 1,NORB
  530       BORB(J) = BLK(J,IAUGM)
          IBD = IBD + 1
          IRYD = IRYD + 1
          CALL STASH(BORB,IBD,IA,0,0,POL,Q,HYB)
          LABEL(IBD,1) = LRY
          LABEL(IBD,2) = ISTAR
          LABEL(IBD,3) = IRYD
          LABEL(IBD,4) = IA
          LABEL(IBD,5) = 0
          LABEL(IBD,6) = 0
  540   CONTINUE
  580 CONTINUE
C
C  Include antibond labels:
C
      IBO = IBD
      DO 660 I = 1,IBO
C
C  Exit loop if LABEL(I,1) is 'LP', 'RY', OR 'CR':
C
        IF(LABEL(I,1).EQ.NAME(1)) GOTO 660
        IF(LABEL(I,1).EQ.LRY)     GOTO 660
        IF(LABEL(I,1).EQ.LCR)     GOTO 660
          NAB = 1
          IF(LABEL(I,1).EQ.NAME(3)) NAB = 2
          DO 650 IAB = 1,NAB
            IBD = IBD + 1
            DO 640 J = 1,6
  640         LABEL(IBD,J) = LABEL(I,J)
            LABEL(IBD,2) = ISTAR
  650     CONTINUE
  660 CONTINUE
      IF(IBD.EQ.NBAS) GOTO 670
        WRITE(LFNPR,2200)
        STOP
  670 CONTINUE
C
C  Replace density matrix DM from T:
C
  700 CONTINUE
      DO 750 J = 1,NBAS
        DO 740 I = 1,J
          DM(I,J) = T(I,J)
          DM(J,I) = DM(I,J)
          T(J,I) = ZERO
          T(I,J) = ZERO
  740   CONTINUE
  750 CONTINUE
C
C  If the alarm sounded, repeat directed NBO search:
C
      IF(IALARM.NE.0) GOTO 35
C
C  Find new polarization parameters for orthonormal hybrids:
C
      CALL REPOL(DM,Q,POL,BLK,EVAL,C,IBD)
C
C  Form final T-NAB (NAO to NBO transformation) from orthonormal hybrids:
C
      CALL FORMT(T,Q,POL)
C
C  Find occupancies, find total number of electrons and occupied orbitals:
C
      TOTELE = ZERO
      DO 800 I = 1,NBAS
        OCCI = ZERO
        DO 790 J = 1,NBAS
          DO 790 K = 1,NBAS
  790       OCCI = OCCI + T(J,I) * DM(J,K) * T(K,I)
        IF(ABS(OCCI).LT.ZEROP) OCCI = ZERO
        IF(OCCI.GT.TWOP) GO TO 960
        ZEROPM = -ZEROP
        IF(OCCI.LT.ZEROPM) GO TO 960
        BNDOCC(I) = OCCI
        V(I) = OCCI
        TOTELE = TOTELE + BNDOCC(I)
  800 CONTINUE
      NEL = TOTELE + TENTH
      IF(ABS(TOTELE-NEL).GT.5E-4) GO TO 965
      TOTELE = NEL
      NOCC = NEL
      IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2)
C
C  If the number of unstarred orbitals is not equal to the number of occupied
C  MOs, then simply rank the orbitals by occupancy, and ``unstarr'' the NOCC
C  highest occupied:  (This can be dangerous!  However, many of the subsequent
C  routines assume the only NOCC orbitals are starred, and therefore, this
C  mismatch must be corrected.)
C
      NOSTR = 0
      DO 801 I = 1,NBAS
        IF(LABEL(IBXM(I),2).NE.ISTAR) NOSTR = NOSTR + 1
  801 CONTINUE
      IF(NOSTR.NE.NOCC) THEN
        CALL RANK(V,NBAS,NDIM,LARC)
        DO 804 I = 1,NOCC
          IR = LARC(I)
          LABEL(IBXM(IR),2) = IBLNK
  804   CONTINUE
        DO 805 I = NOCC+1,NBAS
          IR = LARC(I)
          LABEL(IBXM(IR),2) = ISTAR
  805   CONTINUE
      END IF
C
C  Determine whether this is a good resonance structure:
C
      CALL CYCLES(ITER,ABS(THRSET),GUIDE,BNDOCC,TOPO,ICONT)
C
C  Write out info about core orbitals which were isolated in subroutine
C  CORE:
C
      IF(.NOT.PRINT) GOTO 953
      CRTHRS = CRTSET
      IF(ISPIN.NE.0) CRTHRS = CRTHRS - ONE
      FIRST = .TRUE.
      DO 952 IAT = 1,NATOMS
        ILOW = 0
        DO 951 I = 1,NBAS
          IF(LABEL(IBXM(I),1).EQ.LCR.AND.LABEL(IBXM(I),4).EQ.IAT
     +       .AND.BNDOCC(I).LT.CRTHRS) ILOW = ILOW + 1
  951   CONTINUE
        IF(ILOW.NE.0) THEN
          IF(FIRST) THEN
            FIRST = .FALSE.
            NAM = NAMEAT(IATNO(IAT))
            IF(ILOW.NE.1) THEN
              WRITE(LFNPR,3010) ILOW,CRTHRS,NAM,IAT
            ELSE
              WRITE(LFNPR,3011) ILOW,CRTHRS,NAM,IAT
            END IF
          ELSE
            NAM = NAMEAT(IATNO(IAT))
            IF(ILOW.NE.1) THEN
              WRITE(LFNPR,3020) ILOW,CRTHRS,NAM,IAT
            ELSE
              WRITE(LFNPR,3021) ILOW,CRTHRS,NAM,IAT
            END IF
          END IF
        END IF
  952 CONTINUE
  953 CONTINUE
      RETURN
C
C  Bad orbital occupancy:
C
  960 IF(PRINT) WRITE(LFNPR,1300) OCCI
      IFLG = -1
      JPRINT(1) = -1
      RETURN
C
C  Total number of electrons is not an integer:
C
  965 WRITE(LFNPR,1310) TOTELE
      IFLG = -1
      JPRINT(1) = -1
      RETURN
C
 1300 FORMAT(/,1X,'A bond orbital with an occupancy of ',F8.5,
     + ' electrons was found!',/,1X,'Please check you input data.')
 1310 FORMAT(/,1X,'The total number of electron is not an integer:',
     + F10.5,/,1X,'Please check your input data.')
 1400 FORMAT(/,1X,'Search of DM block between the following atoms:',
     +          3I4)
 1402 FORMAT(6X,'Select ',I2,' orbital(s) with eigenvalue > ',F9.6)
 1405 FORMAT(6X,8F9.6)
 1410 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':')
 1420 FORMAT(11X,8F7.4)
 1500 FORMAT(11X,'Hybrid ',I1,' in eigenvector has a projection ',
     +    'expectation of ',F6.3)
 1600 FORMAT(11X,'*** NBO accepted: Number',I3,'.   Label:',A2,A1,
     + '(',I2,')')
 1610 FORMAT(1X,'Still need to find',I2,' more orbital(s)')
 1800 FORMAT(/4X,'PRJTHR will be raised from ',F6.3,' to',F6.3,
     + ' and the NBO search repeated.',/)
 1810 FORMAT(//,1X,'Linearly independent hybrids for atom',I3,
     +' cannot be found.',/,1X,'The NBO program must abort.')
 2000 FORMAT(/,1X,'At a projection threshold of',F6.3,', only ',I1,
     + ' of the ',I1,' requested bonds',/,1X,'between atoms ',I2,
     + ' and ',I2,' can be constructed.  The NBO analysis will',/,
     + 1X,'continue, augmenting the NBO set with extra lone pairs ',
     + 'on the atoms',/,1X,'as necessary.')
 2100 FORMAT(/,1X,'At a projection threshold of',F6.3,', only ',I1,
     + ' of the ',I1,' requested bonds',/,1X,'between atoms ',I2,', ',
     + I2,', and ',I2,' can be constructed.  The NBO analysis',/,1X,
     + 'will continue, augmenting the NBO set with extra lone pairs ',
     + 'on the',/,1X,'atoms as necessary.')
 2200 FORMAT(/,1X,'Miscounted orbitals, program must abort')
 3010 FORMAT(/,1X,
     +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbitals ',
     +'found on ',A2,I2)
 3011 FORMAT(/,1X,
     +'WARNING:',I3,' low occupancy (<',F6.4,'e) core orbital  ',
     +'found on ',A2,I2)
 3020 FORMAT(1X,
     +'        ',I3,' low occupancy (<',F6.4,'e) core orbitals ',
     +'found on ',A2,I2)
 3021 FORMAT(1X,
     +'        ',I3,' low occupancy (<',F6.4,'e) core orbital  ',
     +'found on ',A2,I2)
      END
C*****************************************************************************
      SUBROUTINE SRTNBO(T,BNDOCC)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL PERMUT
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
C
      DIMENSION T(NDIM,NDIM),BNDOCC(NDIM)
      DIMENSION NAME(3)
C
      DATA LBD,L3C,NAME,LSTAR/'BD','3C','CR','LP','RY','*'/
C
C  Reorder the NBOs according to bond type and constituent atomic centers:
C
C  Fix atom ordering in the NBO labels:
C
      DO 100 I = 1,NBAS
        NCTR = 0
        DO 10 J = 4,6
          IF(LABEL(I,J).NE.0) THEN
            NCTR = NCTR + 1
            LARC(NCTR) = LABEL(I,J)
          END IF
   10   CONTINUE
        DO 30 J = 1,NCTR-1
          DO 20 K = 1,NCTR-J
            IF(LARC(K).GT.LARC(K+1)) THEN
              ITEMP     = LARC(K)
              LARC(K)   = LARC(K+1)
              LARC(K+1) = ITEMP
            END IF
   20     CONTINUE
   30   CONTINUE
        DO 40 J = 1,NCTR
          LABEL(I,J+3) = LARC(J)
   40   CONTINUE
        DO 50 J = NCTR+1,3
          LABEL(I,J+3) = 0
   50   CONTINUE
  100 CONTINUE
C        
C  Place the 2- and 3-center bonds first in the list of NBOs: (No bonds if
C  the NOBOND keyword was specified)
C
      ICNT = 0
      IF(JPRINT(10).EQ.0) THEN
        DO 200 I = 1,NATOMS-1
          DO 190 J = I+1,NATOMS
            IF(I.NE.J) THEN
              K = -1
  110         K = K + 1
              DO 180 L = ICNT+1,NBAS
                LBL1 = LABEL(IBXM(L),1)
                LBL2 = LABEL(IBXM(L),2)
                LBL3 = LABEL(IBXM(L),3)
                LBL4 = LABEL(IBXM(L),4)
                LBL5 = LABEL(IBXM(L),5)
                LBL6 = LABEL(IBXM(L),6)
                IF((LBL1.EQ.LBD.OR.LBL1.EQ.L3C).AND.LBL2.NE.LSTAR) THEN
                  IF(LBL4.EQ.I.AND.LBL5.EQ.J.AND.LBL6.EQ.K) THEN
                    ICNT = ICNT + 1
                    LABEL(IBXM(L),1)    = LABEL(IBXM(ICNT),1)
                    LABEL(IBXM(L),2)    = LABEL(IBXM(ICNT),2)
                    LABEL(IBXM(L),3)    = LABEL(IBXM(ICNT),3)
                    LABEL(IBXM(L),4)    = LABEL(IBXM(ICNT),4)
                    LABEL(IBXM(L),5)    = LABEL(IBXM(ICNT),5)
                    LABEL(IBXM(L),6)    = LABEL(IBXM(ICNT),6)
                    LABEL(IBXM(ICNT),1) = LBL1
                    LABEL(IBXM(ICNT),2) = LBL2
                    LABEL(IBXM(ICNT),3) = LBL3
                    LABEL(IBXM(ICNT),4) = LBL4
                    LABEL(IBXM(ICNT),5) = LBL5
                    LABEL(IBXM(ICNT),6) = LBL6
                    TEMP         = BNDOCC(L)
                    BNDOCC(L)    = BNDOCC(ICNT)
                    BNDOCC(ICNT) = TEMP
                    DO 170 M = 1,NBAS
                      TEMP      = T(M,L)
                      T(M,L)    = T(M,ICNT)
                      T(M,ICNT) = TEMP
  170               CONTINUE
                  END IF
                END IF
  180         CONTINUE
              IF(IW3C.NE.0.AND.K.EQ.0) K = J
              IF(K.GT.0.AND.K.LT.NATOMS) GOTO 110
            END IF
  190     CONTINUE
  200   CONTINUE
      END IF
C
C  Next add any core, lone pair, and Rydberg orbitals:
C
      DO 300 II = 1,3
        DO 290 I = 1,NATOMS
          DO 280 J = ICNT+1,NBAS
            LBL1 = LABEL(IBXM(J),1)
            LBL4 = LABEL(IBXM(J),4)
            IF(LBL1.EQ.NAME(II).AND.LBL4.EQ.I) THEN
              ICNT = ICNT + 1
              DO 260 K = 1,6
                ITEMP               = LABEL(IBXM(J),K)
                LABEL(IBXM(J),K)    = LABEL(IBXM(ICNT),K)
                LABEL(IBXM(ICNT),K) = ITEMP
  260         CONTINUE
              TEMP         = BNDOCC(J)
              BNDOCC(J)    = BNDOCC(ICNT)
              BNDOCC(ICNT) = TEMP
              DO 270 K = 1,NBAS
                TEMP      = T(K,J)
                T(K,J)    = T(K,ICNT)
                T(K,ICNT) = TEMP
  270         CONTINUE
            END IF
  280     CONTINUE
  290   CONTINUE
  300 CONTINUE
C
C  Add in any antibonds:
C
      IF(JPRINT(10).EQ.0) THEN
        DO 400 I = 1,NATOMS-1
          DO 390 J = I+1,NATOMS
            IF(I.NE.J) THEN
              K = -1
              IF(IW3C.NE.0) K = J
  310         K = K + 1
              DO 380 L = ICNT+1,NBAS
                LBL1 = LABEL(IBXM(L),1)
                LBL2 = LABEL(IBXM(L),2)
                LBL3 = LABEL(IBXM(L),3)
                LBL4 = LABEL(IBXM(L),4)
                LBL5 = LABEL(IBXM(L),5)
                LBL6 = LABEL(IBXM(L),6)
                IF((LBL1.EQ.LBD.OR.LBL1.EQ.L3C).AND.LBL2.EQ.LSTAR) THEN
                  IF(LBL4.EQ.I.AND.LBL5.EQ.J.AND.LBL6.EQ.K) THEN
                    ICNT = ICNT + 1
                    LABEL(IBXM(L),1)    = LABEL(IBXM(ICNT),1)
                    LABEL(IBXM(L),2)    = LABEL(IBXM(ICNT),2)
                    LABEL(IBXM(L),3)    = LABEL(IBXM(ICNT),3)
                    LABEL(IBXM(L),4)    = LABEL(IBXM(ICNT),4)
                    LABEL(IBXM(L),5)    = LABEL(IBXM(ICNT),5)
                    LABEL(IBXM(L),6)    = LABEL(IBXM(ICNT),6)
                    LABEL(IBXM(ICNT),1) = LBL1
                    LABEL(IBXM(ICNT),2) = LBL2
                    LABEL(IBXM(ICNT),3) = LBL3
                    LABEL(IBXM(ICNT),4) = LBL4
                    LABEL(IBXM(ICNT),5) = LBL5
                    LABEL(IBXM(ICNT),6) = LBL6
                    TEMP         = BNDOCC(L)
                    BNDOCC(L)    = BNDOCC(ICNT)
                    BNDOCC(ICNT) = TEMP
                    DO 370 M = 1,NBAS
                      TEMP      = T(M,L)
                      T(M,L)    = T(M,ICNT)
                      T(M,ICNT) = TEMP
  370               CONTINUE
                  END IF
                END IF
  380         CONTINUE
              IF(K.GT.0.AND.K.LT.NATOMS) GOTO 310
            END IF
  390     CONTINUE
  400   CONTINUE
      END IF
C
C  Lastly, make sure orbitals are ordered by serial number:
C
  410 PERMUT = .FALSE.
      DO 500 I = 1,NBAS-1
        IF(LABEL(IBXM(I),1).EQ.LABEL(IBXM(I+1),1)) THEN
          IF(LABEL(IBXM(I),2).EQ.LABEL(IBXM(I+1),2)) THEN
            IF(LABEL(IBXM(I),4).EQ.LABEL(IBXM(I+1),4)) THEN
              IF(LABEL(IBXM(I),5).EQ.LABEL(IBXM(I+1),5)) THEN
                IF(LABEL(IBXM(I),6).EQ.LABEL(IBXM(I+1),6)) THEN
                  IF(LABEL(IBXM(I),3).GT.LABEL(IBXM(I+1),3)) THEN
                    PERMUT = .TRUE.
                    LBL3 = LABEL(IBXM(I),3)
                    LABEL(IBXM(I),3) = LABEL(IBXM(I+1),3)
                    LABEL(IBXM(I+1),3) = LBL3
                    TEMP = BNDOCC(I)
                    BNDOCC(I) = BNDOCC(I+1)
                    BNDOCC(I+1) = TEMP
                    DO 490 J = 1,NBAS
                      TEMP = T(J,I)
                      T(J,I) = T(J,I+1)
                      T(J,I+1) = TEMP
  490               CONTINUE
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
  500 CONTINUE
      IF(PERMUT) GOTO 410
      RETURN
      END
C*****************************************************************************
      SUBROUTINE XCITED(DM,T,HYB,THYB,S,OCC,SCR,ISCR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL FIRST
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),HYB(MXAO),THYB(NDIM,NDIM),
     +          S(NDIM,NDIM),OCC(NDIM),SCR(NDIM),ISCR(NDIM)
      DIMENSION PCT(5),IAT(3)
      DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/
      DATA ZERO,TENTH,ONE,THRESH/0.0D0,0.1D0,1.0D0,1.0D-4/
      DATA LSTAR,LBLNK/'*',' '/
C
C  Form a temporary NAO to NHO transformation matrix.  Check hybrid
C  overlap to make sure the NBO's were properly labelled as Lewis
C  and non-Lewis orbitals:
C
C  Count number of hybrids as they are written out:
C
      NHYB = 0
C
C  Main loop over bond orbitals:
C
      DO 200 NBOND = 1,NBAS
        IB = IBXM(NBOND)
        LBL = LABEL(IB,1)
        IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR = 1
        IF(LBL.EQ.LBD) NCTR = 2
        IF(LBL.EQ.L3C) NCTR = 3
C
C  Loop over atomic centers of bond orbital NBOND:
C
        DO 190 ICTR = 1,NCTR
          I = LABEL(IB,ICTR+3)
          KL = LL(I)
          KU = LU(I)
          DO 120 K = 1,MXAO
            LTYP(K) = 0
  120       HYB(K) = ZERO
C
C  Choose sign for polarization coefficients:
C
          ISGN = 1
          IF(LABEL(IB,2).NE.LSTAR) GO TO 130
          IF(ICTR.LT.2) GO TO 130
          IF(ICTR.EQ.3) IPAR3C = -IPAR3C
          IF(ICTR.EQ.3.AND.IPAR3C.GT.0) GO TO 130
          ISGN = -ISGN
  130     CONTINUE
C
C  Extract hybrid (HYB) from transformation matrix T; LTYP(I) is the
C  orbital angular momentum quantum no. of A.O. # I:
C
          KH = 0
          DO 140 K = KL,KU
            KH = KH + 1
            HYB(KH) = T(K,NBOND)
  140       LTYP(KH) = NAOA(K)/100
          CALL HTYPE(HYB,LTYP,MXAO,KH,COEF,PCT,NL,ISGN)
          IF(ABS(COEF).LT.THRESH) GO TO 190
C
C  Check to see if this orbital has been found before:
C
          DO 160 IHYB = 1,NHYB
            TEMP = ZERO
            IH = 0
            DO 150 K = KL,KU
              IH = IH + 1
              TEMP = TEMP + HYB(IH)*THYB(K,IHYB)
  150       CONTINUE
            IF(ABS(ABS(TEMP)-ONE).LT.THRESH) GO TO 190
            IF(ABS(TEMP).GT.THRESH) THEN
              WRITE(LFNPR,900) NHYB+1,NBOND,ICTR,TEMP,IHYB
              STOP
            END IF
  160     CONTINUE
C
C  Add this hybrid to the temporary THYB:
C
          NHYB = NHYB + 1
          IF(NHYB.GT.NBAS) STOP 'Too many hybrids'
          DO 170 K = 1,NBAS
            THYB(K,NHYB) = ZERO
  170     CONTINUE
          IH = 0
          DO 180 K = KL,KU
            IH = IH + 1
            THYB(K,NHYB) = HYB(IH)
  180     CONTINUE
  190   CONTINUE
  200 CONTINUE
      IF(NHYB.LT.NBAS) STOP 'Missing hybrids'
C
C  THYB now contains the temporary NAO to NHO transformation matrix.
C  Form the non-orthogonal PNHO overlap and NHO to NBO transformation matrices:
C
      CALL FESNAO(S)
      CALL SIMTRS(S,THYB,SCR,NDIM,NBAS)
C
      CALL TRANSP(THYB,NDIM,NBAS)
      CALL MATMLT(THYB,T,SCR,NDIM,NBAS)
C
C  Check to see that the bonds and antibonds have the correct hybrid
C  overlap.  Fix the labels if there is a problem:
C
      FIRST = .TRUE.
      DO 300 NBOND = 1,NBAS
        IB = IBXM(NBOND)
        LBL1 = LABEL(IB,1)
        IF(LBL1.EQ.LLP.OR.LBL1.EQ.LCR.OR.LBL1.EQ.LRY) ICTR = 1
        IF(LBL1.EQ.LBD) ICTR = 2
        IF(LBL1.EQ.L3C) ICTR = 3
        NCTR = 0
        DO 210 IHYB = 1,NHYB
          IF(ABS(THYB(IHYB,NBOND)).GT.THRESH) THEN
            NCTR = NCTR + 1
            IF(NCTR.GT.3) THEN
              WRITE(LFNPR,910) NBOND
              STOP
            END IF
            IAT(NCTR) = IHYB
          END IF
  210   CONTINUE
        IF(NCTR.GT.ICTR) THEN
          WRITE(LFNPR,920) ICTR,NBOND,NCTR
          STOP
        END IF
        IF(NCTR.GT.1) THEN
          ISGN = 1
          DO 230 JCTR = 1,NCTR-1
            DO 220 KCTR = JCTR+1,NCTR
              JHYB = IAT(JCTR)
              KHYB = IAT(KCTR)
              TEMP = S(JHYB,KHYB)*THYB(JHYB,NBOND)*THYB(KHYB,NBOND)
              IF(TEMP.LT.ZERO) ISGN = -1
  220       CONTINUE
  230     CONTINUE
          LBL2 = LABEL(IB,2)
          IF(LBL2.EQ.LBLNK.AND.ISGN.EQ.-1) THEN
            IF(FIRST.AND.JPRINT(5).NE.0) WRITE(LFNPR,930)
            FIRST = .FALSE.
            LABEL(IB,2) = LSTAR
            IF(JPRINT(5).NE.0) WRITE(LFNPR,940) NBOND,LBL1,LSTAR
          ELSE IF(LBL2.EQ.LSTAR.AND.ISGN.EQ.1) THEN
            IF(FIRST.AND.JPRINT(5).NE.0) WRITE(LFNPR,930)
            FIRST = .FALSE.
            LABEL(IB,2) = LBLNK
            IF(JPRINT(5).NE.0) WRITE(LFNPR,940) NBOND,LBL1,LBLNK
          END IF
        END IF
  300 CONTINUE
C
C  Determine the number of occupied orbitals:
C
      TOT = ZERO
      DO 310 I = 1,NBAS
        TOT = TOT + DM(I,I)
  310 CONTINUE
      NOCC = TOT + TENTH
      IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2)
C
C  Count the number of unstarred orbitals:
C
      ICNT = 0
      DO 320 I = 1,NBAS
        IF(LABEL(IBXM(I),2).NE.LSTAR) ICNT = ICNT + 1
  320 CONTINUE
C
C  If the number of unstarred orbitals is not equal to the number of
C  occupied orbitals, fix the orbital labels:
C
      IF(ICNT.NE.NOCC) THEN
        DO 330 I = 1,NBAS
          OCC(I) = DM(I,I)
  330   CONTINUE
        CALL RANK(OCC,NBAS,NDIM,ISCR)
C
C  If there are more unstarred orbitals than occupied, add stars to the
C  least occupied lone pairs:
C
        IF(ICNT.GT.NOCC) THEN
          IDIFF = ICNT - NOCC
          DO 350 I = 1,IDIFF
            IP = 0
            DO 340 J = 1,NBAS
              JP = IBXM(ISCR(J))
              IF(LABEL(JP,1).EQ.LLP.AND.LABEL(JP,2).NE.LSTAR) IP = J
  340       CONTINUE
            IF(IP.EQ.0) THEN
              WRITE(LFNPR,950) ICNT,NOCC
              STOP
            END IF
            LABEL(IBXM(ISCR(IP)),2) = LSTAR
            IF(JPRINT(5).NE.0) WRITE(LFNPR,940) ISCR(IP),
     +                         LABEL(IBXM(ISCR(IP)),1),LSTAR
  350     CONTINUE
C
C  Remove stars from the highest occupied lone pairs/Rydbergs if there are
C  too few starred orbitals:
C
        ELSE
          IDIFF = NOCC - ICNT
          DO 370 I = 1,IDIFF
            IP = 0
            DO 360 J = NBAS,1,-1
              JP = IBXM(ISCR(J))
              IF((LABEL(JP,1).EQ.LLP.OR.LABEL(JP,1).EQ.LRY)
     +                         .AND.LABEL(JP,2).EQ.LSTAR) IP = J
  360       CONTINUE
            IF(IP.EQ.0) THEN
              WRITE(LFNPR,950) ICNT,NOCC
              STOP
            END IF
            LABEL(IBXM(ISCR(IP)),2) = LBLNK
            IF(JPRINT(5).NE.0) WRITE(LFNPR,940) ISCR(IP),
     +                         LABEL(IBXM(ISCR(IP)),1),LBLNK
  370     CONTINUE
        END IF
      END IF
      RETURN
C
  900 FORMAT(/1X,'Hybrid ',I3,' (NBO ',I3,', Center ',I2,') has a ',
     + 'non-negligible overlap of ',F8.5,/,1X,'with hybrid ',I3,'.')
  910 FORMAT(/1X,'NBO ',I3,' has hybrid contributions from more than ',
     + '3 atomic centers.')
  920 FORMAT(/1X,'Error: the ',I1,'-center NBO ',I3,' has ',
     + 'contributions from ',I2,' atomic centers.')
  930 FORMAT(/1X,'          --- Apparent excited state configuration ',
     + '---',/1X,'The following "inverted" NBO labels reflect the ',
     + 'actual hybrid overlap:')
  940 FORMAT(1X,'                NBO ',I3,' has been relabelled ',A2,A1)
  950 FORMAT(/1X,'Unable to label the NBOs properly: ',I3,' unstarred ',
     + 'orbitals',/1X,'                                   ',I3,
     + ' occupied orbitals')
      END
C*****************************************************************************
      SUBROUTINE ANLYZE(T,BNDOCC,HYB,HYCOEF,THYB)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER UL
C
C  Print out details of bond-orbital transformation from matrix T.
C
C  Required input:
C         T = Transformation matrix from S.R. NATHYB; REAL (1,NDIM;1,NDIM)
C      NDIM = Declared dimensionality of array T
C      NBAS = No. of orbitals = actual dimension of T, NAOL
C      NAOL = Integer list of orbital angular momentum type
C                NAOL(I)/100 = l = Q.N. of atomic orbital I
C     IATNO = List of atomic numbers; IATNO(I) is the atomic number
C                of atom I as an integer
C    NATOMS = No. of atoms (not including ghosts) in the molecule
C    IWHYBS = 1 if hybrid A.O. coefficients are to be printed,
C             0 otherwise
C     LFNPR = Logical file number for printout.
C    NAOCTR = List of atomic centers of OAO or NAO basis orbitals
C     LABEL = List of bond orbital labels
C      IBXM = Permutation list of bond orbitals
C    BNDOCC = List of bond orbital occupancies
C     ISPIN = 0 for spinless NBOs
C           = 2 for alpha spin NBOs
C           =-2 for beta  spin NBOs
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)
      COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      DIMENSION T(NDIM,NDIM),HYB(MXAO),BNDOCC(NDIM),THYB(NDIM,NDIM),
     * PCT(5),POW(5),LNAME(5),ISP(3),NAM(3),ICH(3,2),HYCOEF(NDIM)
      DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/
      DATA LNAME/'s','p','d','f','g'/
      DATA ZERO,THRESH,T99,T99P/0.0D0,1.D-2,99.99D0,99.995D0/
      DATA TENTH,HUNDRD,TTHOTH/0.1D0,100.0D0,0.0001D0/
      DATA LHYP,LBLNK,LSTAR,L2BLNK/'-',' ','*','  '/
C
C  Count the number of electrons:
C
      TOTELE = ZERO
      DO 20 I = 1,NBAS
        TOTELE = TOTELE + BNDOCC(I)
   20   CONTINUE
      TOTELE = TOTELE + TENTH
      NEL = TOTELE
      TOTELE = NEL
C
C  Count the number of core orbitals and the occupancies of the core,
C  valence Lewis, valence non-Lewis, and extra-valence Rydberg orbitals.
C  (Also count the number of electrons in the ECP, if employed)
C
      MCR = 0
      OCCCR = ZERO
      OCCVL = ZERO
      OCCVNL = ZERO
      DO 50 I = 1,NBAS
        IF(LABEL(IBXM(I),2).NE.LSTAR) THEN
          IF(LABEL(IBXM(I),1).EQ.LCR) THEN
            MCR = MCR + 1
            OCCCR = OCCCR + BNDOCC(I)
          ELSE
            OCCVL = OCCVL + BNDOCC(I)
          END IF
        ELSE
          IF(LABEL(IBXM(I),1).NE.LRY) THEN
            OCCVNL = OCCVNL + BNDOCC(I)
          END IF
        END IF
   50 CONTINUE
      OCCEVR = TOTELE - OCCCR - OCCVL - OCCVNL
      IF(ISPIN.EQ.0) THEN
        MCR = 2 * MCR
      END IF
      MVL = NEL - MCR
      MECP = 0
      IF(IPSEUD.NE.0) THEN
        DO 60 I = 1,NATOMS
          MECP = MECP + IATNO(I) - IZNUC(I)
   60   CONTINUE
        IF(ISPIN.NE.0) MECP = MECP/2
      END IF
      MLEW = MCR + MVL + MECP
      OCCLEW = OCCCR + OCCVL + MECP
      OCCNON = OCCVNL + OCCEVR
C
C  Write summary of NBO occupancies:
C
      IF(JPRINT(5).EQ.1.AND.NEL.NE.0) THEN
        WRITE(LFNPR,2000)
        IF(IPSEUD.NE.0) WRITE(LFNPR,2010) FLOAT(MECP)
        IF(MCR.NE.0) THEN
          PCENT = OCCCR/MCR * HUNDRD
          WRITE(LFNPR,2020) OCCCR,PCENT,MCR
        END IF
        IF(MVL.NE.0) THEN
          PCENT = OCCVL/MVL * HUNDRD
          WRITE(LFNPR,2030) OCCVL,PCENT,MVL
        END IF
        WRITE(LFNPR,2040)
        PCENT = OCCLEW/MLEW * HUNDRD
        WRITE(LFNPR,2050) OCCLEW,PCENT,MLEW
        WRITE(LFNPR,2060)
        PCENT = OCCVNL/MLEW * HUNDRD
        WRITE(LFNPR,2070) OCCVNL,PCENT,MLEW
        PCENT = OCCEVR/MLEW * HUNDRD
        WRITE(LFNPR,2080) OCCEVR,PCENT,MLEW
        WRITE(LFNPR,2040)
        PCENT = OCCNON/MLEW * HUNDRD
        WRITE(LFNPR,2090) OCCNON,PCENT,MLEW
        WRITE(LFNPR,2100)
      END IF
C
C  Write out NBOs:
C
      IF(JPRINT(5).EQ.1) THEN
        WRITE(LFNPR,1000)
        WRITE(LFNPR,1100) (LHYP,J=1,79)
      END IF
C
C  Main loop over bond orbitals:
C
      NHYB = 0
      MHYB = 0
      IPAR3C = 1
      DO 180 NBOND = 1,NBAS
        IB = IBXM(NBOND)
        LBL = LABEL(IB,1)
        IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR = 1
        IF(LBL.EQ.LBD) NCTR = 2
        IF(LBL.EQ.L3C) NCTR = 3
        DO 110 I = 1,3
          IA = LABEL(IB,I+3)
          CALL CONVRT(IA,ICH(I,1),ICH(I,2))
          NAM(I) = L2BLNK
          IF(IA.GT.0) NAM(I) = NAMEAT(IATNO(IA))
          ISP(I) = LHYP
          IF(I.GE.NCTR) ISP(I) = LBLNK
  110     CONTINUE
C
C  Loop over atomic centers of bond orbital NBOND:
C
        DO 170 ICTR = 1,NCTR
          I = LABEL(IB,ICTR+3)
          NEL = NAMEAT(IATNO(I))
          KL = LL(I)
          KU = UL(I)
          DO 120 K = 1,MXAO
            LTYP(K) = 0
  120       HYB(K) = ZERO
C
C  Choose sign for polarization coefficients:
C
          ISGN = 1
          IF(LABEL(IB,2).NE.LSTAR) GO TO 130
          IF(ICTR.LT.2) GO TO 130
          IF(ICTR.EQ.3) IPAR3C = -IPAR3C
          IF(ICTR.EQ.3.AND.IPAR3C.GT.0) GO TO 130
          ISGN = -ISGN
  130     CONTINUE
C
C  Extract hybrid (HYB) from transformation matrix T; LTYP(I) is the
C  orbital angular momentum quantum no. of A.O. # I:
C
          KH = 0
          DO 140 K = KL,KU
            KH = KH + 1
            HYB(KH) = T(K,NBOND)
  140       LTYP(KH) = NAOA(K)/100
          CALL HTYPE(HYB,LTYP,MXAO,KH,COEF,PCT,NL,ISGN)
C
C  Find leading non-zero contribution to determine POW(L) for each L:
C
          LSTD = 0
          DO 160 L = 1,NL
            IF(LSTD.GT.0) GO TO 150
            POW(L) = ZERO
            STD = PCT(L)
            IF(STD.LT.THRESH) GO TO 160
            LSTD = L
  150       POW(L) = PCT(L)/STD
            IF(POW(L).GT.T99P) POW(L) = T99
  160       CONTINUE
C
C  Write out NHO for center ICTR:
C
          COEFSQ = COEF * COEF * HUNDRD
          NL1 = NL
          IF(NL1.GT.3) NL1 = 3
          IF(ICTR.EQ.1.AND.NCTR.EQ.1.AND.JPRINT(5).EQ.1) 
     +      WRITE(LFNPR,1210) NBOND,BNDOCC(NBOND),
     +        (LABEL(IB,K),K=1,3),NAM(1),ICH(1,1),ICH(1,2),
     +        PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1)
          IF(ICTR.EQ.1.AND.NCTR.GT.1.AND.JPRINT(5).EQ.1) 
     +      WRITE(LFNPR,1220) NBOND,BNDOCC(NBOND),
     +        (LABEL(IB,K),K=1,3),
     +        (NAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3)
          IF(NCTR.NE.1.AND.JPRINT(5).EQ.1) WRITE(LFNPR,1300) COEFSQ,
     +        COEF,NEL,I,PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1)
          IF(NL.GT.3.AND.JPRINT(5).EQ.1) WRITE(LFNPR,1310) 
     +        (LNAME(L),POW(L),PCT(L),L=4,NL)
          IF(IWHYBS.NE.0.AND.BNDOCC(NBOND).GT.TTHOTH.AND.JPRINT(5).EQ.1)
     +        WRITE(LFNPR,1500) (HYB(K),K=1,KH)
          CALL FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
C
C  If this is a new hybrid, form its label:
C
          IF(MHYB.NE.NHYB) THEN
            MHYB = NHYB
            CALL LBLNHO(NHYB,NBOND,ICTR,NCTR)
          END IF
  170   CONTINUE
  180 CONTINUE
      RETURN
C
 1000 FORMAT(//,1X,'    (Occupancy)   Bond orbital/ Coefficients/ ',
     + 'Hybrids')
 1100 FORMAT(1X,80A1)
 1210 FORMAT(1X,I3,'. (',F7.5,') ',A2,A1,'(',I2,')',A2,2A1,12X,
     + ' s(',F6.2,'%)',2(A1,F5.2,'(',F6.2,'%)'))
 1220 FORMAT(1X,I3,'. (',F7.5,') ',A2,A1,'(',I2,')',3(A2,3A1))
 1300 FORMAT(16X,'(',F6.2,'%)',2X,
     + F7.4,'*',A2,I2,' s(',F6.2,'%)',2(A1,F5.2,'(',F6.2,'%)'))
 1310 FORMAT(50X,2(A1,F5.2,'(',F6.2,'%)'))
 1500 FORMAT(39X,5F8.4)
 2000 FORMAT(/,1X,56('-'))
 2010 FORMAT(1X,'  Effective Core          ',F9.5)
 2020 FORMAT(1X,'  Core                    ',F9.5,' (',F7.3,'% of ',
     +  I3,')')
 2030 FORMAT(1X,'  Valence Lewis           ',F9.5,' (',F7.3,'% of ',
     +  I3,')')
 2040 FORMAT(2X,18('='),7X,28('='))
 2050 FORMAT(1X,'  Total Lewis             ',F9.5,' (',F7.3,'% of ',
     +  I3,')')
 2060 FORMAT(2X,53('-'))
 2070 FORMAT(1X,'  Valence non-Lewis       ',F9.5,' (',F7.3,'% of ',
     +  I3,')')
 2080 FORMAT(1X,'  Rydberg non-Lewis       ',F9.5,' (',F7.3,'% of ',
     +  I3,')')
 2090 FORMAT(1X,'  Total non-Lewis         ',F9.5,' (',F7.3,'% of ',
     +  I3,')')
 2100 FORMAT(1X,56('-'))
      END
C*****************************************************************************
      SUBROUTINE HTYPE(HYB,LTYP,MXAO,NH,COEF,PCT,NL,ISGN)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION HYB(MXAO),LTYP(MXAO),PCT(5)
C
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
C  ANALYZE INPUT HYBRID 'HYB' FOR POLARIZATION COEFFICIENT 'COEF'
C  AND PERCENTAGES OF EACH ANGULAR MOMENTUM COMPONENT.
C
      DATA ZERO,THRESH,HUNDRD/0.0D0,1.D-4,100.0D0/
C
      NL = 0
C
C  ZERO PERCENTAGES AND POLARIZATION COEFFICIENT:
C
      DO 10 L1 = 1,5
   10   PCT(L1) = ZERO
      COEF = ZERO
C
C  LOOP OVER ATOMIC CONTRIBUTIONS TO HYBRID, COMPUTING PERCENTAGES
C  AND POLARIZATION COEFFICIENT:
C
      DO 20 I = 1,NH
        L1 = LTYP(I) + 1
        IF(L1.GT.5) GO TO 800
        PCT(L1) = PCT(L1) + HYB(I)**2
   20   COEF = COEF + HYB(I)**2
      IF(ABS(COEF).LT.THRESH) RETURN
C
C  CALCULATE PERCENTAGE CONTRIBUTION FOR EACH ANGULAR SYMMETRY:
C
      DO 30 L1 = 1,5
   30   PCT(L1) = PCT(L1)/COEF*HUNDRD
      COEF = SQRT(COEF)
C
C  SWITCH THE SIGN OF THE COEFFICIENT IF ISGN IS NEGATIVE:
C
      IF(ISGN.LT.0) COEF = -COEF
C
C  NORMALIZE THE HYBRID:
C
      DO 50 I = 1,NH
   50   HYB(I) = HYB(I)/COEF
C
C  FIND THE MAXIMUM NUMBER OF ANGULAR MOMENTUM TYPES (NL):
C
      DO 60 I = 1,NH
        IF(ABS(HYB(I)).LT.THRESH) GO TO 60
         IF(LTYP(I).LE.NL) GO TO 60
          NL = LTYP(I)
   60   CONTINUE
      NL = NL + 1
      RETURN
C
  800 CONTINUE
      WRITE(LFNPR,900) L1-1
      STOP
C
  900 FORMAT(/1X,'AO with unknown angular symmetry, l = ',I3)
      END
C*****************************************************************************
      SUBROUTINE FRMHYB(HYB,THYB,COEF,HYCOEF,KL,KU,NHYB)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DIMENSION HYB(1),THYB(NDIM,NDIM),HYCOEF(NDIM)
C
      DATA ZERO,ONE,THRESH/0.0D0,1.0D0,1.0D-4/
C
C  FORM FULL NAO TO NHO TRANFORMATION IN THYB, ADDING ONE HYBRID WITH
C  EACH CALL.  PUT POLARIZATION COEF IN HYCOEF FOR EACH HYBRID.
C
C  MAKE SURE THIS HYBRID ISN'T ALREADY IN THE LIST:
C
      IF(ABS(COEF).LT.THRESH) RETURN
      DO 20 IHYB = 1,NHYB
        TEMP = ZERO
        IH = 0
        DO 10 K = KL,KU
          IH = IH + 1
          TEMP = TEMP + HYB(IH)*THYB(K,IHYB)
   10   CONTINUE
        IF(ABS(ABS(TEMP)-ONE).LT.THRESH) RETURN
        IF(ABS(TEMP).GT.THRESH) THEN
          WRITE(LFNPR,900) NHYB+1,TEMP,IHYB
          STOP
        END IF
   20 CONTINUE
C
C  ADD THIS HYBRID TO THE LIST:
C
      NHYB = NHYB + 1
      IF(NHYB.GT.NBAS) STOP 'Too many hybrids'
      DO 50 I = 1,NBAS
        THYB(I,NHYB) = ZERO
   50 CONTINUE
      IH = 0
      DO 70 I = KL,KU
        IH = IH + 1
        THYB(I,NHYB) = HYB(IH)
   70 CONTINUE
      HYCOEF(NHYB) = COEF
      IF(NHYB.NE.NBAS) RETURN
      CALL SVTNHO(THYB)
      RETURN
C
  900 FORMAT(/1X,'Hybrid ',I3,' has a ',
     + 'non-negligible overlap of ',F8.5,' with hybrid ',I3,'.')
      END
C*****************************************************************************
      SUBROUTINE HYBDIR(BNDOCC,ATCOOR,THYB,TBND,SCR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP1(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      DIMENSION BNDOCC(NDIM),ATCOOR(NATOMS*3),THYB(NDIM,NDIM),
     +          TBND(NDIM,NDIM),SCR(NDIM)
      DIMENSION ISTR(8),PHYB(3),XYZ(3,2),KHYB(3),AZI(2),POL(2),DEV(2)
      DIMENSION ISKIP(2)
C
      DATA LCR,LLP,LRY,LBD,L3C/'CR','LP','RY','BD','3C'/
      DATA LHYP/'-'/
      DATA ZERO,ONE,THRESH,CUTOFF/0.0D0,1.0D0,1.0D-4,1.0D-8/
C
C  Compute hybrid directionality and bond bending for selected NBO's:
C
C  Thresholds:   ATHR  --   Angular deviation threshold
C                PTHR  --   Percentage p-character threshold
C                ETHR  --   Occupancy threshold
C
      CONV = 180.0/(4.0*ATAN(ONE))
      WRITE(LFNPR,900) ABS(ATHR),ABS(PTHR),ABS(ETHR)
C
C  Get atomic centers, NAO to NHO trans., and NAO to NBO trans.:
C
      CALL FECOOR(ATCOOR)
      CALL FETNHO(THYB)
      CALL FETNAB(TBND)
      CALL TRANSP(TBND,NDIM,NBAS)
      CALL MATMLT(TBND,THYB,SCR,NDIM,NBAS)
C
C  Loop over NBOs:
C
      ICNT = 0
      DO 100 IBAS = 1,NBAS
        IB = IBXM(IBAS)
        LBL1 = LABEL(IB,1)
        LBL2 = LABEL(IB,2)
        LBL3 = LABEL(IB,3)
        IF(LBL1.EQ.LLP.OR.LBL1.EQ.LRY) NCTR = 1
        IF(LBL1.EQ.LBD) NCTR = 2
C
C  Skip 3-center orbitals, core orbitals, low occupancy orbitals:
C
        IF(LBL1.EQ.L3C) GO TO 100
        IF(LBL1.EQ.LCR) GO TO 100
        IF(BNDOCC(IBAS).LT.ABS(ETHR)) GO TO 100
C
C  Find the hybrids which contribute to this NBO:
C
        ICTR = 0
        DO 10 IHYB = 1,NBAS
          IF(ABS(TBND(IBAS,IHYB)).GT.THRESH) THEN
            ICTR = ICTR + 1
            KHYB(ICTR) = IHYB
          END IF
   10   CONTINUE
        IF(ICTR.NE.NCTR) THEN
          WRITE(LFNPR,910) NCTR,IBAS,ICTR
          STOP
        END IF
C
C  Make sure the hybrids are on the proper nuclear centers and compute
C  the percentage p-character in the hybrid:
C
        DO 30 ICTR = 1,NCTR
          IHYB = KHYB(ICTR)
          JCTR = LABEL(IB,ICTR+3)
          CALL HYBCMP(XYZ(1,ICTR),PHYB(ICTR),IHYB,JCTR,THYB(1,IHYB))
   30   CONTINUE
C
C  If these hybrids have low p-character, skip them:
C
        ISKIP(1) = 0
        ISKIP(2) = 0
        IF(NCTR.EQ.1.AND.PHYB(1).LT.ABS(PTHR)) GO TO 100
        IF(NCTR.EQ.2) THEN
          IF(PHYB(1).LT.ABS(PTHR)) ISKIP(1) = 1
          IF(PHYB(2).LT.ABS(PTHR)) ISKIP(2) = 1
          IF(ISKIP(1).EQ.1.AND.ISKIP(2).EQ.1) GO TO 100
        END IF
C
C  Compute the polar and azimuthal angles of each hybrid:
C
        DO 70 ICTR = 1,NCTR
          IF(ISKIP(ICTR).EQ.1) GO TO 70
          CALL ANGLES(XYZ(1,ICTR),XYZ(2,ICTR),XYZ(3,ICTR),POL(ICTR),
     +                AZI(ICTR))
   70   CONTINUE
C
C  Compute the deviation from the line of nuclear centers for 2-center
C  orbitals:
C
        IF(NCTR.EQ.2) THEN
          ICTR = LABEL(IB,4)
          JCTR = LABEL(IB,5)
          X = ATCOOR(JCTR*3-2) - ATCOOR(ICTR*3-2)
          Y = ATCOOR(JCTR*3-1) - ATCOOR(ICTR*3-1)
          Z = ATCOOR(JCTR*3)   - ATCOOR(ICTR*3)
          IF(ABS(X).LT.CUTOFF) X = ZERO
          IF(ABS(Y).LT.CUTOFF) Y = ZERO
          IF(ABS(Z).LT.CUTOFF) Z = ZERO
          R = SQRT(X*X + Y*Y + Z*Z)
          X = X / R
          Y = Y / R
          Z = Z / R
          CALL ANGLES(X,Y,Z,THETA,PHI)
          PROJ = XYZ(1,1)*X + XYZ(2,1)*Y + XYZ(3,1)*Z
          IF(ABS(PROJ-ONE).LT.CUTOFF) THEN
            DEV(1) = ZERO
          ELSE IF(ABS(PROJ+ONE).LT.CUTOFF) THEN
            DEV(1) = 180.0
          ELSE IF(PROJ.LT.ONE.AND.PROJ.GT.-ONE) THEN
            DEV(1) = ACOS(PROJ) * CONV
            DEV(1) = ABS(DEV(1))
          ELSE
            STOP 'ArcCosine out of bounds in SR HYBDIR'
          END IF
          PROJ = XYZ(1,2)*X + XYZ(2,2)*Y + XYZ(3,2)*Z
          IF(ABS(PROJ-ONE).LT.CUTOFF) THEN
            DEV(2) = 180.0
          ELSE IF(ABS(PROJ+ONE).LT.CUTOFF) THEN
            DEV(2) = ZERO
          ELSE IF(PROJ.LT.ONE.AND.PROJ.GT.-ONE) THEN
            DEV(2) = ACOS(PROJ) * CONV
            DEV(2) = ABS(ABS(DEV(2)) - 180.0)
          ELSE
            STOP 'ArcCosine out of bounds in SR HYBDIR'
          END IF
          IF(DEV(1).LT.ABS(ATHR)) ISKIP(1) = 1
          IF(DEV(2).LT.ABS(ATHR)) ISKIP(2) = 1
          IF(ISKIP(1).EQ.1.AND.ISKIP(2).EQ.1) GO TO 100
        END IF
C
C  Write out directionality info:
C
        ICNT = ICNT + 1
        ISTR(1) = LBL1
        ISTR(2) = LBL2
        ISTR(3) = LBL3
        ISTR(4) = NAMEAT(IATNO(LABEL(IB,4)))
        ISTR(5) = LABEL(IB,4)
        IF(NCTR.EQ.2) THEN
          ISTR(6) = LHYP
          ISTR(7) = NAMEAT(IATNO(LABEL(IB,5)))
          ISTR(8) = LABEL(IB,5)
          IF(ISKIP(1).EQ.1) THEN
            WRITE(LFNPR,940) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(2),
     +                       AZI(2),DEV(2)
          ELSE IF(ISKIP(2).EQ.1) THEN
            WRITE(LFNPR,950) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(1),
     +                       AZI(1),DEV(1)
          ELSE
            WRITE(LFNPR,960) IBAS,(ISTR(I),I=1,8),THETA,PHI,POL(1),
     +                       AZI(1),DEV(1),POL(2),AZI(2),DEV(2)
          END IF
        ELSE
          WRITE(LFNPR,970) IBAS,(ISTR(I),I=1,5),POL(1),AZI(1)
        END IF
  100 CONTINUE
      IF(ICNT.EQ.0) WRITE(LFNPR,980)
      RETURN
C
  900 FORMAT(//1X,'NHO Directionality and "Bond Bending" (deviations ',
     + 'from line of nuclear centers)',//1X,'        [Thresholds for ',
     + 'printing:  angular deviation  > ',F4.1,' degree]',/1X,
     + '                                   hybrid p-character > ',F4.1,
     + '%',/1X,'                                   orbital occupancy  ',
     + '>  ',F4.2,'e',//1X,'                      Line of Centers     ',
     + '   Hybrid 1              Hybrid 2',/1X,'                      ',
     + '---------------  -------------------   ------------------',/1X,
     + '          NBO           Theta   Phi    Theta   Phi    Dev    ',
     + 'Theta   Phi    Dev',/1X,'=====================================',
     + '==========================================')
  910 FORMAT(/1X,'Error: the ',I1,'-center NBO ',I3,' has ',
     + 'contributions from ',I2,' atomic centers.')
  940 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1,
     + '     --     --    --     ',F5.1,2X,F5.1,1X,F5.1)
  950 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1,
     + 3X,F5.1,2X,F5.1,1X,F5.1,'      --     --    --')
  960 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,A1,A2,I2,3X,F5.1,2X,F5.1,
     + 3X,F5.1,2X,F5.1,1X,F5.1,4X,F5.1,2X,F5.1,1X,F5.1)
  970 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,'          --     --',4X,
     + F5.1,2X,F5.1,'   --       --     --    --')
  980 FORMAT(1X,'   None exceeding thresholds')
      END
C*****************************************************************************
      SUBROUTINE HYBCMP(XYZ,PCENT,IHYB,JCTR,HYB)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION XYZ(3),HYB(1)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBNAO/NAOC(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DATA ZERO,THRESH,CUTOFF/0.0D0,1.0D-4,1.0D-8/
C
C  Add the px,py,pz components of this hybrid vectorially and determine
C  its percentage p-character:
C
      XYZ(1) = ZERO
      XYZ(2) = ZERO
      XYZ(3) = ZERO
      PCENT  = ZERO
      HNORM  = ZERO
C
C  Make sure this hybrid is situated on the correct atom, JCTR:
C
      JMAX  = 1
      TMAX  = ABS(HYB(1))
      DO 10 INAO = 2,NBAS
        IF(ABS(HYB(INAO)).GT.TMAX) THEN
          JMAX = INAO
          TMAX = ABS(HYB(INAO))
        END IF
   10 CONTINUE
      IF(NAOC(JMAX).NE.JCTR) THEN
        WRITE(LFNPR,920) IHYB,JCTR,NAOC(JMAX)
        STOP
      END IF
C
C  Find the sign of the largest s-component of this hybrid:
C
      JMAX  = 0
      TMAX  = ZERO
      DO 20 INAO = 1,NBAS
        L = NAOA(INAO)/100
        IF(L.EQ.0.AND.ABS(HYB(INAO)).GT.TMAX) THEN
          JMAX = INAO
          TMAX = ABS(HYB(INAO))
        END IF
   20 CONTINUE
C
C  If the sign of the largest s-component is negative, change the
C  phase of this hybrid:
C
      IF(JMAX.NE.0.AND.HYB(JMAX).LT.-THRESH) THEN
        DO 30 INAO = 1,NBAS
          HYB(INAO) = -HYB(INAO)
   30   CONTINUE
      ENDIF
C
C  Sum the px,py,pz components of this hybrid, determine the percent
C  p-character:
C
      DO 40 INAO = 1,NBAS
        IF(NAOC(INAO).EQ.JCTR) THEN
          L = NAOA(INAO)/100
          IF(L.EQ.1) THEN
            PCENT = PCENT + HYB(INAO)*HYB(INAO)
            M = MOD(NAOA(INAO),50)
            XYZ(M) = XYZ(M) + HYB(INAO)
          END IF
          HNORM = HNORM + HYB(INAO)*HYB(INAO)
        END IF
   40 CONTINUE
      IF(HNORM.LT.THRESH) THEN
        WRITE(LFNPR,930) JCTR,IHYB
        STOP
      END IF
      PCENT = PCENT/HNORM * 100.0
C
C  Normalize the px,py,pz vector:
C
      HNORM = ZERO
      DO 50 IX = 1,3
        IF(ABS(XYZ(IX)).LT.CUTOFF) XYZ(IX) = ZERO
        HNORM = HNORM + XYZ(IX)*XYZ(IX)
   50 CONTINUE
      HNORM = SQRT(HNORM)
      IF(ABS(HNORM).LT.CUTOFF) THEN
        PCENT = ZERO
      ELSE
        DO 60 IX = 1,3
          XYZ(IX) = XYZ(IX)/HNORM
   60   CONTINUE
      END IF
      RETURN
C
  920 FORMAT(/1X,'Expected to find hybrid ',I3,' on nuclear center ',
     + I2,' rather than center ',I2,'.')
  930 FORMAT(/1X,'The atomic orbitals on nuclear center ',I2,' do not ',
     + 'contribute to hybrid ',I3,'.')
      END
C*****************************************************************************
      SUBROUTINE FNDMOL(IATOMS)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM),
     +              NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION IATOMS(NATOMS)
      LOGICAL BDFIND
C
C  FIND MOLECULAR UNITS :  Modified algorithm replacing original which
C  had problems with determining molecular units for odd numberings of
C  atoms.   (E. Glendening  3/12/88)
C
      NMOLEC = 0
      DO 20 I = 1,NATOMS
        MOLAT(I) = 0
        DO 10 J = 1,NATOMS
          MOLEC(I,J) = 0
   10   CONTINUE
   20 CONTINUE
      DO 30 I = 1,NATOMS
        IATOMS(I) = I
   30 CONTINUE
      LATOMS = NATOMS
   40 CONTINUE
        NMOLEC = NMOLEC+1
        MOLAT(NMOLEC) = 1
        MOLEC(NMOLEC,1) = IATOMS(1)
        LATOMS = LATOMS-1
        IF(LATOMS.NE.0) THEN
          DO 50 I = 1,LATOMS
            IATOMS(I) = IATOMS(I+1)
   50     CONTINUE
          IAT = 1
   60     CONTINUE
            I = 1
   70       CONTINUE
              IF(BDFIND(MOLEC(NMOLEC,IAT),IATOMS(I))) THEN
                MOLAT(NMOLEC) = MOLAT(NMOLEC)+1
                MOLEC(NMOLEC,MOLAT(NMOLEC)) = IATOMS(I)
                LATOMS = LATOMS-1
                IF(I.LE.LATOMS) THEN
                  DO 80 J = I,LATOMS
                    IATOMS(J) = IATOMS(J+1)
   80             CONTINUE
                END IF
              ELSE
                I = I+1
              END IF
            IF(I.LE.LATOMS) GOTO 70
            IAT = IAT+1
          IF(IAT.LE.MOLAT(NMOLEC).AND.LATOMS.NE.0) GOTO 60
        END IF
      IF(LATOMS.GT.0) GOTO 40
C
C  SORT ATOMS IN MOLECULAR UNITS:
C
      DO 110 I = 1,NMOLEC
        DO 100 J = 1,MOLAT(I)-1
          DO 90 K = 1,MOLAT(I)-J
            IF(MOLEC(I,K).GT.MOLEC(I,K+1)) THEN
              ITEMP = MOLEC(I,K)
              MOLEC(I,K) = MOLEC(I,K+1)
              MOLEC(I,K+1) = ITEMP
            END IF
   90     CONTINUE
  100   CONTINUE
  110 CONTINUE
C
C  ALPHA SPIN: SAVE BONDING INFO IN NMOLA,MOLATA,MOLECA:
C
      IF(ISPIN.EQ.2) THEN
        NMOLA = NMOLEC
        DO 610 IMOL = 1,NMOLEC
          MOLATA(IMOL) = MOLAT(IMOL)
          IMOLAT = MOLAT(IMOL)
          DO 600 IATMOL = 1,IMOLAT
            MOLECA(IMOL,IATMOL) = MOLEC(IMOL,IATMOL)
  600     CONTINUE
  610   CONTINUE
C
C  BETA SPIN: MAKE SURE THAT BETA MOLECULAR UNITS ARE THE SAME AS ALPHA:
C
      ELSE IF(ISPIN.EQ.-2) THEN
        IF(NMOLA.NE.NMOLEC) GO TO 800
        DO 730 IMOL = 1,NMOLEC
          IMOLAT = MOLAT(IMOL)
          IF(IMOLAT.NE.MOLATA(IMOL)) GO TO 800
          DO 720 IATMOL = 1,IMOLAT
            IF(MOLECA(IMOL,IATMOL).NE.MOLEC(IMOL,IATMOL)) GO TO 800
  720     CONTINUE
  730   CONTINUE
      END IF
      RETURN
C
  800 WRITE(LFNPR,1800)
      NMOLA = -NMOLA
      RETURN
C
 1800 FORMAT(/1X,'The molecular units found in the alpha and beta ',
     + 'manifolds are inequivalent.',/1X,'For labelling purposes, ',
     + 'the molecular units of the beta system will be used.')
      END
C*****************************************************************************
      SUBROUTINE NBOCLA(BNDOCC,ACCTHR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),MOLLST(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM),
     +              NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM)
      DIMENSION BNDOCC(NBAS)
      DATA LBD,L3C,LSTAR/2HBD,2H3C,1H*/
      DATA THRESH,ONE,ZERO,TWO/1.50D0,1.0D0,0.0D0,2.0D0/
      DATA DONTHR/1.0D-1/
C
C  CLASSIFY NBOS ACCORDING TO DONOR/ACCEPTOR TYPE:
C
      IF(ACCTHR.LE.ZERO) THEN
        ACCTHR = THRESH
        IF(ISPIN.NE.0) ACCTHR = ACCTHR - ONE
      END IF
      IF(ISPIN.NE.0) DONTHR = DONTHR / TWO
C
C  MAKE UP LIST MOLLST OF WHICH "MOLECULE" EACH ATOM IS IN:
C
      DO 80 IAT = 1,NATOMS
        DO 60 IMOL = 1,NMOLEC
          IMOLAT = MOLAT(IMOL)
          DO 50 IATMOL = 1,IMOLAT
            IF(MOLEC(IMOL,IATMOL).EQ.IAT) GO TO 70
   50     CONTINUE
   60   CONTINUE
        STOP 'ROUTINE NBOCLA'
   70   MOLLST(IAT) = IMOL
   80   CONTINUE
C
C  MAKE UP LISTS OF NBO ORBITALS:
C    NBOUNI(IBAS) = MOLECULAR UNIT
C    NBOTYP(IBAS) = NUMBER OF CENTERS (+10 IF A LOW OCCUPANCY LONE PAIR)
C                                     (+20 IF AN ANTIBOND/RYDBERG)
      DO 200 IBAS = 1,NBAS
        IB = IBXM(IBAS)
        IAT = LABEL(IB,4)
        IMOL = MOLLST(IAT)
        NBOUNI(IBAS) = IMOL
        LAB = LABEL(IB,1)
        NCTR = 1
        IF(LAB.EQ.LBD) NCTR = 2
        IF(LAB.EQ.L3C) NCTR = 3
        NBOTYP(IBAS) = NCTR
        IF(LABEL(IB,2).EQ.LSTAR) GO TO 180
        IF(BNDOCC(IBAS).GT.ACCTHR) GO TO 200
C
C  LOW OCCUPANCY VALENCE ORBITAL
C
          NBOTYP(IBAS) = NCTR + 10
          GO TO 200
C
C  ANTIBOND/RYDBERG
C
  180   NBOTYP(IBAS) = NCTR + 20
C
C  HIGH OCCUPANCY RY* OR BD* ORBITAL
C
        IF(BNDOCC(IBAS).GT.DONTHR) NBOTYP(IBAS) = NCTR + 10
  200 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FNBOAN(BNDOCC,F,MOLNBO)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),MOLLST(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM),
     +              NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      DIMENSION BNDOCC(NBAS),F(NDIM,NDIM),MOLNBO(2,NBAS,NMOLEC)
      DIMENSION INAM(3),JNAM(3),ICH(3,2),JCH(3,2),ISP(3),JSP(3)
C
      DATA LBD/2HBD/,L3C/2H3C/,LBLNK1/1H /,LBLNK2/2H  /,LHYP/1H-/
      DATA HUNDTH/0.01D0/
      DATA AUKCAL/627.51D0/,EVKCAL/23.060D0/
      DATA ZERO,ONE,TWO,TEN/0.0D0,1.0D0,2.0D0,1.0D1/
C
C  PERFORM 2ND ORDER ANALYSIS OF THE FOCK MATRIX:
C
C  ETHR1 IS THE THRESHOLD FOR PRINTING THE INTRAMOLECULAR PERTURBATIONAL
C  ENERGIES (0.5 KCAL/MOL FOR CLOSED SHELL, 0.25 KCAL/MOL FOR OPEN SHELL)
C  SIMILARLY, ETHR2 IS THE INTERMOLECULAR THRESHOLD, (0.05 KCAL/MOL).
C
      ETHR1 = ABS(E2THR)
      IF(ISPIN.NE.0.AND.E2THR.LT.ZERO) ETHR1 = ETHR1/TWO
      ETHR2 = ABS(E2THR)/TEN
      IF(ISPIN.NE.0.AND.E2THR.LT.ZERO) ETHR2 = ETHR2/TWO
C
C  FETCH THE NBO FOCK MATRIX:
C
      NTRI = NDIM * (NDIM+1)/2
      CALL FEFNBO(F)
      CALL UNPACK(F,NDIM,NBAS,NTRI)
C
C  ANALYZE FOCK MATRIX:
C
C  MAKE UP LIST MOLNBO(1,IBAS,IMOL) OF CORE/LP/BOND NBOS IN MOLEC. UNIT IMOL
C               MOLNBO(2,IBAS,IMOL) OF RYDBERG/ANTIBOND NBOS IN MOLEC. IMOL
C
      DO 200 IMOL = 1,NMOLEC
        NOCC = 0
        NSTAR = 0
        DO 110 IBAS = 1,NBAS
          DO 100 I = 1,2
            MOLNBO(I,IBAS,IMOL) = 0
  100     CONTINUE
  110   CONTINUE
        DO 150 IBAS = 1,NBAS
          IF(IMOL.NE.NBOUNI(IBAS)) GO TO 150
          IF(NBOTYP(IBAS).GT.20) GO TO 130
            NOCC = NOCC + 1
            MOLNBO(1,NOCC,IMOL) = IBAS
            IF(NBOTYP(IBAS).LT.10) GO TO 150
  130     CONTINUE
            NSTAR = NSTAR + 1
            MOLNBO(2,NSTAR,IMOL) = IBAS
  150   CONTINUE
  200 CONTINUE
C
C  DETERMINE THE CONVERSION FROM INPUT ENERGY UNITS TO KCAL:
C
      IF(MUNIT.EQ.0) THEN
        CONV = AUKCAL
      ELSE IF(MUNIT.EQ.1) THEN
        CONV = EVKCAL
      ELSE
        CONV = ONE
      END IF
C
C  LOOP OVER PAIRS OF UNITS:
C
      WRITE(LFNPR,2700) ETHR1
      IF(NMOLEC.GT.1) WRITE(LFNPR,2710) ETHR2
      IF(MUNIT.EQ.0) THEN
        WRITE(LFNPR,2720)
      ELSE IF(MUNIT.EQ.1) THEN
        WRITE(LFNPR,2730)
      ELSE
        WRITE(LFNPR,2740)
      END IF
      DO 400 IMOL = 1,NMOLEC
        DO 400 JMOL = 1,NMOLEC
          IF(IMOL.EQ.JMOL) WRITE(LFNPR,2300) IMOL
          IF(IMOL.NE.JMOL) WRITE(LFNPR,2400) IMOL,JMOL
          ETHRSH = ETHR1
          IF(IMOL.NE.JMOL) ETHRSH = ETHR2
          NELE = 0
          DO 305 IOCC = 1,NBAS
            IBAS = MOLNBO(1,IOCC,IMOL)
            IF(IBAS.EQ.0) GO TO 305
            IB = IBXM(IBAS)
            LBL = LABEL(IB,1)
            NCTR = 1
            IF(LBL.EQ.LBD) NCTR = 2
            IF(LBL.EQ.L3C) NCTR = 3
            DO 250 I = 1,3
              IA = LABEL(IB,I+3)
              CALL CONVRT(IA,ICH(I,1),ICH(I,2))
              INAM(I) = LBLNK2
              IF(IA.GT.0) INAM(I) = NAMEAT(IATNO(IA))
              ISP(I) = LHYP
              IF(I.GE.NCTR) ISP(I) = LBLNK1
  250       CONTINUE
            DO 300 JSTAR = 1,NBAS
              JBAS = MOLNBO(2,JSTAR,JMOL)
              IF(JBAS.EQ.0) GO TO 300
              IF(IBAS.EQ.JBAS) GO TO 300
              DE = F(JBAS,JBAS) - F(IBAS,IBAS)
              IF(DE.LT.HUNDTH) GO TO 300
              ABSFIJ = ABS(F(IBAS,JBAS))
              EPERT = (ABSFIJ**2)/DE
C
C  COMPUTE OCCUPANCY FACTOR TO MULTIPLY BY:
C
              TOTOCC = BNDOCC(IBAS)+BNDOCC(JBAS)
              FULLOC = TWO
              IF(ISPIN.NE.0) FULLOC = ONE
              OCCFAC = TOTOCC
              IF(TOTOCC.GT.FULLOC) OCCFAC = TWO * FULLOC - TOTOCC
C
C  MULTIPLY EPERT BY SUM OF OCCUPANCIES OF NBOS IBAS AND JBAS:
C
              EPERT = EPERT * OCCFAC
              EKCAL = EPERT * CONV
              IF(EKCAL.LT.ETHRSH) GO TO 300
              NELE = NELE + 1
              JB = IBXM(JBAS)
              LBL = LABEL(JB,1)
              NCTR = 1
              IF(LBL.EQ.LBD) NCTR = 2
              IF(LBL.EQ.L3C) NCTR = 3
              DO 260 J = 1,3
                JA = LABEL(JB,J+3)
                CALL CONVRT(JA,JCH(J,1),JCH(J,2))
                JNAM(J) = LBLNK2
                IF(JA.GT.0) JNAM(J) = NAMEAT(IATNO(JA))
                JSP(J) = LHYP
                IF(J.GE.NCTR) JSP(J) = LBLNK1
  260         CONTINUE
              WRITE(LFNPR,2800) IBAS,(LABEL(IB,K),K=1,3),
     *           (INAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,2),
     *            INAM(3),ICH(3,1),ICH(3,2),
     *                           JBAS,(LABEL(JB,K),K=1,3),
     *           (JNAM(K),JCH(K,1),JCH(K,2),JSP(K),K=1,2),
     *            JNAM(3),JCH(3,1),JCH(3,2),
     *                          EKCAL,DE,ABSFIJ
  300   CONTINUE
  305   CONTINUE
        IF(NELE.EQ.0) WRITE(LFNPR,2500)
  400 CONTINUE
      RETURN
C
 2300 FORMAT(/1X,'within unit ',I2)
 2400 FORMAT(/1X,'from unit ',I2,' to unit ',I2)
 2500 FORMAT(1X,'      None above threshold')
 2700 FORMAT(//,1X,'Second Order Perturbation Theory Analysis ',
     *             'of Fock Matrix in NBO Basis'//,1X,
     *          '    Threshold for printing:  ',F5.2,' kcal/mol')
 2710 FORMAT(1X,'   (Intermolecular threshold:',F5.2,' kcal/mol)')
 2720 FORMAT(56X,'  E(2)  E(j)-E(i) F(i,j)'/
     * 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X,
     *            'kcal/mol   a.u.    a.u. ',/1X,79('='))
 2730 FORMAT(56X,'  E(2)  E(j)-E(i) F(i,j)'/
     * 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X,
     *            'kcal/mol   e.V.    e.V. ',/1X,79('='))
 2740 FORMAT(56X,'  E(2)  E(j)-E(i) F(i,j)'/
     * 6X,'Donor NBO (i)',14X,'Acceptor NBO (j)',7X,
     *            'kcal/mol   kcal    kcal ',/1X,79('='))
 2800 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1,
     *   '/',I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1,
     *       F8.2,F8.2,F9.3)
      END
C*****************************************************************************
      SUBROUTINE NBOSUM(F,BNDOCC,LIST,LISTA,SCR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL FIRST
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBMOL/NMOLEC,MOLAT(MAXATM),MOLEC(MAXATM,MAXATM),
     +              NMOLA,MOLATA(MAXATM),MOLECA(MAXATM,MAXATM)
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DIMENSION F(NDIM,NDIM),BNDOCC(NDIM),LIST(NDIM),LISTA(NATOMS,2),
     +          SCR(1)
      DIMENSION ISTR(80),ILAB(9)
C
      DATA ZERO,EPS,TWO,TEN,HUNDRD/0.0D0,5.0D-6,2.0D0,1.0D1,1.0D2/
      DATA TENTH/1.0D-1/
      DATA LSTAR,LRY/'*','RY'/
C
C  Set flag to zero -- Determine strong delocalizations from perturbative
C  analysis of the NBO Fock matrix:
C
      IFLG = 0
C
C  Threshold for printing delocalizations:
C
      THR1 = ABS(E2THR)
      IF(ISPIN.NE.0) THR = THR/TWO
      THR2 = THR1 / TEN
C
C  Get Fock matrix if there is one:
C
      IF(IWFOCK.NE.0) THEN
        NTRI = NDIM * (NDIM+1)/2
        CALL FEFNBO(F)
        CALL UNPACK(F,NDIM,NBAS,NTRI)
      END IF
C
C  Print summary heading, then loop over molecules:
C
      IF(IWFOCK.NE.0) THEN
        WRITE(LFNPR,900)
      ELSE
        WRITE(LFNPR,910)
      END IF
      DO 200 IMOL = 1,NMOLEC
C
C  Determine the molecular formula, the nuclear charge, and the number of
C  ECP electrons of this molecular unit:
C
        NAT  = 0
        MECP = 0
        CHARGE = ZERO
        DO 20 IAT = 1,MOLAT(IMOL)
          KAT = IATNO(MOLEC(IMOL,IAT))
          MECP = MECP + FLOAT(KAT - IZNUC(MOLEC(IMOL,IAT)))
          CHARGE = CHARGE + FLOAT(KAT)
          DO 10 JAT = 1,NAT
            IF(LISTA(JAT,1).EQ.KAT) THEN
              LISTA(JAT,2) = LISTA(JAT,2) + 1
              GO TO 20
            END IF
   10     CONTINUE
          NAT = NAT + 1
          LISTA(NAT,1) = KAT
          LISTA(NAT,2) = 1
   20   CONTINUE
        IF(ISPIN.NE.0) MECP = MECP/2
        IF(ISPIN.NE.0) CHARGE = CHARGE/TWO
        CALL CHEM(NAT,NATOMS,LISTA,NL,ISTR)
        WRITE(LFNPR,920) IMOL,(ISTR(I),I=1,NL)
C
C  Loop over NBO's on this molecular unit:
C
        OCCLEW = FLOAT(MECP)
        OCCNON = ZERO
        OCCRYD = ZERO
        DO 190 IBAS = 1,NBAS
          IF(NBOUNI(IBAS).EQ.IMOL) THEN
            IB = IBXM(IBAS)
            ILAB(1) = LABEL(IB,1)
            ILAB(2) = LABEL(IB,2)
            ILAB(3) = LABEL(IB,3)
            IPTR    = 3
            NCTR    = MOD(NBOTYP(IBAS),10)
            DO 30 ICTR = 1,NCTR
              IPTR         = IPTR + 2
              ILAB(IPTR)   = LABEL(IB,ICTR+3)
              ILAB(IPTR-1) = NAMEAT(IATNO(ILAB(IPTR)))
   30       CONTINUE
            OCC  = BNDOCC(IBAS)
            IF(ILAB(1).EQ.LRY) THEN
              OCCRYD = OCCRYD + OCC
            ELSE IF(ILAB(2).EQ.LSTAR) THEN
              OCCNON = OCCNON + OCC
            ELSE
              OCCLEW = OCCLEW + OCC
            END IF
C
C  If there is a Fock matrix, find the orbital energy and principal
C  delocalizations:
C
            IF(IWFOCK.NE.0) THEN
              ENRG  = F(IBAS,IBAS)
              CALL GETDEL(IBAS,OCC,THR1,THR2,NL,LIST,SCR,F,IFLG)
              FIRST = .TRUE.
              IL    = 0
   40         CALL DLCSTR(IBAS,IL,NL,LIST,ML,ISTR)
              IF(FIRST) THEN
                IF(NCTR.EQ.1) THEN
                  WRITE(LFNPR,930) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG,
     +                             (ISTR(J),J=1,ML)
                ELSE IF(NCTR.EQ.2) THEN
                  WRITE(LFNPR,940) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG,
     +                             (ISTR(J),J=1,ML)
                ELSE
                  WRITE(LFNPR,950) IBAS,(ILAB(I),I=1,IPTR),OCC,ENRG,
     +                             (ISTR(J),J=1,ML)
                END IF
                FIRST = .FALSE.
              ELSE
                  WRITE(LFNPR,960) (ISTR(J),J=1,ML)
              END IF
              IF(IL.LT.NL) GO TO 40
C
C  Otherwise only write out orbital labels and occupancy:
C
            ELSE
              IF(NCTR.EQ.1) THEN
                WRITE(LFNPR,930) IBAS,(ILAB(I),I=1,IPTR),OCC
              ELSE IF(NCTR.EQ.2) THEN
                WRITE(LFNPR,940) IBAS,(ILAB(I),I=1,IPTR),OCC
              ELSE
                WRITE(LFNPR,950) IBAS,(ILAB(I),I=1,IPTR),OCC
              END IF
            END IF
          END IF
  190   CONTINUE
        WRITE(LFNPR,970)
        TOTAL = OCCLEW + OCCNON + OCCRYD
C
C  Make sure the total number of electrons is an integer if there is only
C  one molecular unit:
C
        IF(NMOLEC.EQ.1) THEN
          TOTAL  = TOTAL + TENTH
          NEL    = TOTAL
          TOTAL  = NEL
          OCCRYD = TOTAL - OCCLEW - OCCNON
        END IF
C
C  Write a summary of the electron population on this molecular unit:
C
        IF(ABS(TOTAL-FLOAT(NINT(TOTAL))).LT.1.0D-5) 
     +                    TOTAL = FLOAT(NINT(TOTAL))
        CHARGE = CHARGE - TOTAL
        IF(TOTAL.GT.EPS) THEN
          PLEW = OCCLEW/TOTAL*HUNDRD
          PNON = OCCNON/TOTAL*HUNDRD
          PRYD = OCCRYD/TOTAL*HUNDRD
        ELSE
          PLEW = ZERO
          PNON = ZERO
          PRYD = ZERO
        END IF
        WRITE(LFNPR,980) OCCLEW,PLEW
        WRITE(LFNPR,990) OCCNON,PNON
        WRITE(LFNPR,1000) OCCRYD,PRYD
        WRITE(LFNPR,970)
        WRITE(LFNPR,1010) IMOL,TOTAL,HUNDRD
        WRITE(LFNPR,1020) IMOL,CHARGE
        IF(IMOL.LT.NMOLEC) WRITE(LFNPR,*)
  200 CONTINUE
      RETURN
C
  900 FORMAT(//1X,'Natural Bond Orbitals (Summary):',//53X,'Principal ',
     + 'Delocalizations',/1X,'          NBO              Occupancy  ',
     + '  Energy      (geminal,vicinal,remote)',/1X,79('='))
  910 FORMAT(//1X,'Natural Bond Orbitals (Summary):',//1X,'          ',
     + 'NBO              Occupancy  ',/1X,40('-'))
  920 FORMAT(1X,'Molecular unit ',I2,'  ',60A1)
  930 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,10X,F9.5,F12.5,4X,28A1)
  940 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,'-',A2,I2,5X,F9.5,F12.5,
     + 4X,28A1)
  950 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,I2,'-',A2,I2,'-',A2,I2,F9.5,
     + F12.5,4X,28A1)
  960 FORMAT(52X,28A1)
  970 FORMAT(1X,'      -------------------------------')
  980 FORMAT(1X,'             Total Lewis',F11.5,'  (',F8.4,'%)')
  990 FORMAT(1X,'       Valence non-Lewis',F11.5,'  (',F8.4,'%)')
 1000 FORMAT(1X,'       Rydberg non-Lewis',F11.5,'  (',F8.4,'%)')
 1010 FORMAT(1X,'           Total unit ',I2,F11.5,'  (',F8.4,'%)')
 1020 FORMAT(1X,'          Charge unit ',I2,F11.5)
      END
C*****************************************************************************
      SUBROUTINE GETDEL(IBO,OCC,THR1,THR2,NL,LIST,DEL,DELOC,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      DIMENSION LIST(NDIM),DEL(NDIM),DELOC(NDIM,NDIM)
C
      DATA ZERO,ONE,CUTOFF,TENTH/0.0D0,1.0D0,1.0D-4,0.1D0/
      DATA AUKCAL,EVKCAL/627.51,23.060/
C
C Determine the conversion factor to kcal:
C
      IF(MUNIT.EQ.0) THEN
        CONV = AUKCAL
      ELSE IF(MUNIT.EQ.1) THEN
        CONV = EVKCAL
      ELSE
        CONV = ONE
      END IF
C
C Determine the strength of each delocalization:
C
      DO 10 JBO = 1,NBAS
        LIST(JBO) = 0
        DEL(JBO) = ZERO
   10 CONTINUE
C
      NL = 0
      IF(OCC.LT.TENTH) RETURN
      DO 20 JBO = 1,NBAS
        IF(IBO.NE.JBO) THEN
          IF(NBOTYP(JBO).GE.10) THEN
            DEL(JBO) = DELOC(IBO,JBO)*DELOC(IBO,JBO)
            IF(IFLG.EQ.0) THEN
              DIV = ABS(DELOC(IBO,IBO)-DELOC(JBO,JBO))
              IF(DIV.NE.ZERO) THEN
                DEL(JBO) = OCC * DEL(JBO)/DIV * CONV
              ELSE
                DEL(JBO) = ZERO
              END IF
            END IF
          END IF
          IF(DEL(JBO).GT.THR2.AND.NBOUNI(IBO).NE.NBOUNI(JBO)) THEN
            NL = NL + 1
            LIST(NL) = JBO
          ELSE IF(DEL(JBO).GT.THR1) THEN
            NL = NL + 1
            LIST(NL) = JBO
          END IF
        END IF
   20 CONTINUE
C
C  Sort delocalizations:
C
      DO 100 I = 1,NL
        DO 90 J = 1,NL-1
          KBO = LIST(J)
          LBO = LIST(J+1)
          IF(DEL(LBO)-DEL(KBO).GT.CUTOFF) THEN
            LIST(J) = LBO
            LIST(J+1) = KBO
          END IF
   90   CONTINUE
  100 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE DLCSTR(IBO,IL,NL,LIST,ML,ISTR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (MAXCHR = 28, MAXD = 4)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
      DIMENSION LIST(NDIM),ISTR(80)
      INTEGER IK(MAXD)
C
      DATA ICOMMA,ILEFT,IRIGHT/',','(',')'/
C
C  Build a character string (for the NBO summary table) which contains
C  the delocalization information for NBO # IBO:
C
      ML = 0
   10 IL = IL + 1
      IF(IL.GT.NL) GO TO 30
      CALL IDIGIT(LIST(IL),IK,ND,MAXD)
      IF(ML+ND+4.GT.MAXCHR) GO TO 30
      IF(ML.NE.0) THEN
        ML = ML + 1
        ISTR(ML) = ICOMMA
      END IF
      DO 20 I = 1,ND
        ML = ML + 1
        ISTR(ML) = IK(I)
   20 CONTINUE
      ML = ML + 1
      ISTR(ML) = ILEFT
      ML = ML + 1
      ISTR(ML) = IHTYP(IBO,LIST(IL))
      ML = ML + 1
      ISTR(ML) = IRIGHT
      GO TO 10
C
   30 IL = IL - 1
      RETURN
      END
C*****************************************************************************
      SUBROUTINE NLMO(N,A,EVAL,EVEC,TSYM,RESON,NOCC,IALARM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  FORM NATURAL LOCALIZED MOLECULAR ORBITALS FROM DENSITY MATRIX A.
C
C        N: ACTUAL DIMENSION OF A,EVEC
C     NDIM: DECLARED DIMENSION OF A,EVEC
C     TSYM: SCRATCH
C    RESON: SQUARES OF DIAGONAL ELEMENTS OF NBO TO NLMO TRANSF, TIMES 100%
C   IALARM: ALARM THAT THE ORBITAL OCCUPANCIES ARE OUT OF ORDER AND THAT
C           THE LMO STEP SHOULD BE AVOIDED
C
C  THESE VALUES ARE SET:
C
C     DIFFER = 1.0D-5
C
C     DONE   = 1.0D-10 (THIS IS THE PARAMETER FOR CONVERGENCE OF THE OFF-
C                       DIAGONAL MATRIX ELEMENTS.)
C
C     EPS    = 1.0D-11 (THIS PARAMETER HAS TO DO WITH THE MACHINE PRECISION
C                       AND SHOULD BE SET TO A VALUE BETWEEN "DONE" AND THE
C                       MACHINE PRECISION.)
C
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ZEROJ
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      DIMENSION A(NDIM,NDIM),EVEC(NDIM,1),EVAL(1),TSYM(1),RESON(NDIM)
      DIMENSION ROT(2,2)
      DIMENSION ILIST(100),JLIST(100),IOFF(100),JOFF(100),IUNIQ(100),
     +   JUNIQ(100)
C
C  IMPORTANT PARAMETERS:
C
      DATA DIFFER,DONE,EPS/1.0D-5,1.0D-10,1.0D-11/
C
C  NOFFMX IS SET TO THE DIMENSION OF VECTORS ILIST,JLIST,IOFF,JOFF,IUNIQ,JUNIQ:
C
      DATA DEGTHR,NOFFMX/1.0D-3,100/
      DATA ZERO,ONE,TEN,HUNDRD/0.0D0,1.0D0,10.0D0,100.0D0/
C
      WRITE(LFNPR,8390)
      THR1 = ONE - DEGTHR
      THR2 = ONE - DEGTHR*5
      NTIME = 0
C
C  IF THERE IS ONLY ONE BASIS FUNCTION, SOLVE THIS TRIVIAL CASE AND RETURN:
C
      IF(N.GT.1) GO TO 10
        EVEC(1,1) = ONE
        EVAL(1) = A(1,1)
        RETURN
   10 CONTINUE
C
      DO 30 J = 1,N
        DO 20 I = 1,N
   20     EVEC(I,J) = ZERO
   30   EVEC(J,J) = ONE
C
C  COUNT THE NUMBER OF ELECTRONS AND OCCUPIED ORBITALS:
C
      TOTELE = ZERO
      DO 50 I = 1,N
   50   TOTELE = TOTELE + A(I,I)
      TOTELE = TOTELE + DIFFER
      NOCC = TOTELE
      IF(ISPIN.EQ.0) NOCC = NOCC/2 + MOD(NOCC,2)
      NVIRST = NOCC + 1
C
C  CHECK IF OCCUPANCIES ARE IN ORDER:
C
      IALARM = 0
      VIRMAX = ZERO
      DO 60 J = NVIRST,N
        IF(A(J,J).LT.VIRMAX) GO TO 60
        VIRMAX = A(J,J)
   60 CONTINUE
      OCCMIN = HUNDRD
      DO 70 I = 1,NOCC
        IF(A(I,I).GT.OCCMIN) GO TO 70
        OCCMIN = A(I,I)
   70 CONTINUE
      X = OCCMIN - VIRMAX
C
C  21 OCT 1987.  THE FOLLOWING FEATURE OF THE PROGRAM HAS BEEN
C    TURNED OFF BECAUSE SOMETIMES IT IS NOT POSSIBLE TO DIAGONALIZE
C    THE NBO DENSITY MATRIX WHEN ONE OF THE ``A'' NBOS IS DEGENERATE
C    IN OCCUPANCY WITH ONE OR MORE ``B'' NBOS:
C
C  THE "ABS(X).LT.DIFFER" PART OF THE NEXT LINE IS INCLUDED SO THAT
C   NLMOS CAN BE COMPUTED WHEN A NUMBER OF ORBITALS ARE NEARLY
C   DEGENERATE IN OCCUPANCY, AS FOR INSTANCE IN CLI6, WHERE SIX
C   LITHIUM LONE PAIRS ARE DEGENERATE BUT ONLY ONE OF THEM CAN
C   BE PLACED IN THE "OCCUPIED" SET OF NLMOS.
C     IF(X.GT.ZERO.OR.ABS(X).LT.DIFFER) GO TO 100
C
C  THE ABOVE STATEMENT IS REPLACED BY:
C
      IF(X.GT.DIFFER) GO TO 100
C
C  OCCUPANCIES OUT OF ORDER:
C
      IALARM = 1
      IF(ABS(X).GT.DIFFER) GO TO 80
        WRITE(LFNPR,8010)
        GO TO 90
   80   WRITE(LFNPR,8000)
   90 CONTINUE
      RETURN
C
C   START LOOP:
C
  100 CONTINUE
      NTIME = NTIME + 1
C
C  FIRST, FIND ELEMENT A(IOCC,JEMT) OF LARGEST MAGNITUDE, OFFTOP:
C
      OFFTOP = ZERO
      DO 200 JEMT = NVIRST,N
        DO 200 IOCC = 1,NOCC
          ABSAIJ = ABS(A(IOCC,JEMT))
          IF(ABSAIJ.LT.OFFTOP) GO TO 200
          OFFTOP = ABSAIJ
          AII = A(IOCC,IOCC)
          AJJ = A(JEMT,JEMT)
  200 CONTINUE
C
C  RETURN IF CONVERGENCE HAS BEEN ACHIEVED:
C
      IF(OFFTOP.LT.DONE) GO TO 900
C
C  FIND ALL ELEMENTS DEGENERATE WITH LARGEST ONE, OFFTOP:
C  (CHECK CORRESPONDING DIAGONAL ELEMENTS ALSO)
C  NOFF: NUMBER OF DEGENERATE ELEMENTS
C  IOFF(K),JOFF(K): KTH DEGENERATE ELEMENT
C
      OFFTST = OFFTOP * THR1
      AIIL = AII*THR2
      AJJL = AJJ*THR2
      AIIU = AII/THR2
      AJJU = AJJ/THR2
      ZEROJ = .FALSE.
      IF(AJJ.LT.DIFFER) ZEROJ = .TRUE.
      NOFF = 0
      DO 250 JEMT = NVIRST,N
        DO 250 IOCC = 1,NOCC
          ABSAIJ = ABS(A(IOCC,JEMT))
          IF(ABSAIJ.LT.OFFTST) GO TO 250
          AIII = A(IOCC,IOCC)
          AJJJ = A(JEMT,JEMT)
          IF((AIII.LT.AIIL).OR.(AIII.GT.AIIU)) GO TO 250
C
C  SKIP TEST OF DIAG. ELEM. IF SMALL (.LT.DIFFER):
C
          IF(ZEROJ) GO TO 240
          IF((AJJJ.LT.AJJL).OR.(AJJJ.GT.AJJU)) GO TO 250
  240     NOFF = NOFF + 1
          IOFF(NOFF) = IOCC
          JOFF(NOFF) = JEMT
  250     CONTINUE
      IF(NOFF.LT.NOFFMX) GO TO 260
        WRITE(LFNPR,2500) NOFF,NOFFMX
 2500   FORMAT(//1X,'NOFF = ',I5,' IS GREATER THAN NOFFMX =',I5,
     *            /5X,'  MUST ABORT NLMO PROCEDURE')
        IALARM = 1
        RETURN
  260 CONTINUE
C
      S = AJJ - AII
      ABSS = ABS(S)
C
C  IF THE ROTATION IS VERY CLOSE TO 45 DEGREES, SET SIN AND COS TO 1/(ROOT 2)
C
      TEST=EPS*OFFTOP
      IF (ABSS.GT.TEST) GO TO 330
      S=.707106781D0
      C=S
      GO TO 340
C
C  CALCULATION OF SIN AND COS FOR ROTATION THAT IS NOT VERY CLOSE TO 45 DEGREES
  330 T=OFFTOP/S
      S=0.25D0/ SQRT(0.25D0+T*T)
C
C    JACOBI ROTATION ANGLE:   COS=C ,  SIN=S
      C= SQRT(0.5D0+S)
      S=2.D0*T*S/C
  340 CONTINUE
C  PRINT STATEMENTS FOR NLMO PROCEDURE DETAILS:
C      WRITE(LFNPR,9903) OFFTOP,S,C,NOFF
C 9903 FORMAT(' ******   OFFTOP,S,C,NOFF:',3F14.9,I3)
C      WRITE(LFNPR,9901) (IOFF(I),I=1,NOFF)
C 9901 FORMAT(' IOFF:',20I3)
C      WRITE(LFNPR,9902) (JOFF(I),I=1,NOFF)
C 9902 FORMAT(' JOFF:',20I3)
C
C     SIMPLE 2 BY 2 ROTATION, NO DEGENERACY PROBLEMS:
      IF(NOFF.GT.1) GO TO 400
        IOCC=IOFF(1)
        JEMT=JOFF(1)
        IF(A(IOCC,JEMT).LT.ZERO) S=-S
        ROT(1,1)=C
        ROT(2,2)=C
        ROT(1,2)=S
        ROT(2,1)=-S
        IOFF(2)=JOFF(1)
        CALL LIMTRN(A,IOFF,ROT,EVAL,NDIM,N,2,2,0)
C
C     ROTATION COMPLETED
        DO 380 I=1,N
          T=EVEC(I,IOCC)
          EVEC(I,IOCC)=C*T-EVEC(I,JEMT)*S
  380     EVEC(I,JEMT)=S*T+EVEC(I,JEMT)*C
        GO TO 800
C
  400 CONTINUE
C
C  NOFF.GT.1:
C   COMPUTE "AVERAGED" UNITARY TRANSFORMATION SO THAT SYMMETRY IS PRESERVED
C
C    CONSTRUCT UNIQUE LISTS OF ORBITALS INVOLVED:
C
C      IUNIQ(L): L-TH UNIQUE OCCUPIED ORB.
C      NIUNIQ:   NO. OF UNIQUE OCC. ORBS
C      ILIST(L): LOCATION IN THE UNIQUE LIST (IUNIQ) OF THE I VALUE OF THE
C                            L-TH OFFDIAG. ELEMENT
C      JUNIQ, NJUNIQ, AND JLIST ARE FOR THE EMPTY ORBITALS.
C
        IUNIQ(1)=IOFF(1)
        ILIST(1)=1
        NIUNIQ=1
        DO 500 MOFF=2,NOFF
          I=IOFF(MOFF)
          IIMAX=MOFF-1
          DO 490 II=1,IIMAX
            IF(IOFF(II).NE.I) GO TO 490
            ILIST(MOFF)=ILIST(II)
            GO TO 500
  490       CONTINUE
          NIUNIQ=NIUNIQ+1
          ILIST(MOFF)=NIUNIQ
          IUNIQ(NIUNIQ)=I
  500     CONTINUE
C
        JUNIQ(1)=JOFF(1)
        JLIST(1)=NIUNIQ+1
        NJUNIQ=1
        DO 540 MOFF=2,NOFF
          J=JOFF(MOFF)
          JJMAX=MOFF-1
          DO 530 JJ=1,JJMAX
            IF(JOFF(JJ).NE.J) GO TO 530
            JLIST(MOFF)=JLIST(JJ)
            GO TO 540
  530       CONTINUE
          NJUNIQ=NJUNIQ+1
          JLIST(MOFF)=NJUNIQ+NIUNIQ
          JUNIQ(NJUNIQ)=J
  540     CONTINUE
        NROT=NIUNIQ+NJUNIQ
        NROT2=NROT*NROT
        N1=NROT2+1
        N2=NROT2+N1
C  CONSTRUCT TSYM:
        CALL SYMUNI(TSYM,A,C,S,TSYM(N1),TSYM(N2),EVAL,NROT,
     *              NIUNIQ,NJUNIQ,
     *              ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
C
C   MAKE IUNIQ INTO A COMPLETE LIST OF THE UNIQUE ORBITALS, AND TRANSFORM
C    THE NBO TO NLMO TRANSF. (EVEC) AND THE DM (A) BY TSYM:
        II=NIUNIQ
        DO 700 I=1,NJUNIQ
          II=II+1
  700     IUNIQ(II)=JUNIQ(I)
        CALL LIMTRN(EVEC,IUNIQ,TSYM,EVAL,NDIM,N,NROT,NROT,1)
        CALL LIMTRN(A,IUNIQ,TSYM,EVAL,NDIM,N,NROT,NROT,0)
C  SEE HOW MUCH THE ELEMENTS WERE REDUCED:
C        DO 750 MOFF=1,NOFF
C          I=IOFF(MOFF)
C          J=JOFF(MOFF)
C          WRITE(LFNPR,9920) I,J,(A(I,J))
C 9920     FORMAT(' I,J,AIJ:',2I3,F14.9)
C  750     CONTINUE
C
  800   CONTINUE
C      TOTELE=ZERO
C      DO 810 J=1,N
C        TOTELE=TOTELE+A(J,J)
C  810   CONTINUE
C      TOT=NEL
C      FRACT=TOTELE-TOT
C      WRITE(LFNPR,7000) NOFF,TOTELE,FRACT
      GO TO 100
C
C  FINISHED: PLACE OCCUPANCIES IN EVAL AND COUNT UP ELECTRONS:
C
  900 CONTINUE
      TOTELE = ZERO
      DO 910 J = 1,N
        EVAL(J) = A(J,J)
        TOTELE = TOTELE + EVAL(J)
        X = EVEC(J,J)
        RESON(J) = X * X * HUNDRD
  910 CONTINUE
      TOTP = TOTELE + DIFFER
      NEL = TOTP
      TOT = NEL
      FRACT = ABS(TOTELE-TOT)
      IF(FRACT.GT.DIFFER) GO TO 990
C
C  FIND THE LARGEST OFF-DIAGONAL DENSITY MATRIX ELEMENT:
C
      AMAX = ZERO
      DO 960 J = 2,N
        JM1 = J - 1
        DO 950 I = 1,JM1
          IF(ABS(A(I,J)).LT.AMAX) GO TO 950
          AMAX = ABS(A(I,J))
  950   CONTINUE
  960 CONTINUE
      WRITE(LFNPR,9500) AMAX
C
C  IF THIS IS A CORRELATED WAVEFUNCTION, RETURN TO THE CALLING ROUTINE:
C
      IF(CI.OR.MCSCF.OR.AUHF) RETURN
C
C  FOR SCF WAVEFUNCTIONS, MAKE SURE THIS MATRIX ELEMENT IS SMALL:
C
      IF(AMAX.LT.HUNDRD*HUNDRD*DONE) RETURN
      WRITE(LFNPR,9550)
      IALARM = 1
      RETURN
C
C  NON-INTEGER NUMBER OF ELECTRONS:
C
  990 WRITE(LFNPR,9900) DIFFER,TOTELE
      WRITE(LFNPR,9600)
      WRITE(LFNPR,9610) (EVAL(I),I=1,NBAS)
      IALARM = 1
      RETURN
C
 8000 FORMAT(/1X,'Highest occupied NBOs are not at the beginning',
     +    ' of the NBO list;',/,1X,'The NLMO program is not ',
     +    'currently set up to handle this.')
 8010 FORMAT(/1X,'Degeneracy between orbitals in the (a) and (b)',
     *     ' sets detected;',
     *    /1X,'NLMO program cannot always handle this situation.')
 8390 FORMAT(//1X,'NATURAL LOCALIZED MOLECULAR ORBITAL (NLMO) ',
     *     'ANALYSIS:')
 9500 FORMAT(/1X,'Maximum off-diagonal element of DM in NLMO basis:',
     *         E13.5)
 9550 FORMAT(/1X,'Something went wrong in the NLMO procedure; density',
     * ' matrix of SCF',/1X,'wave function has not been diagonalized')
 9600 FORMAT(/1X,'Occupancies of NLMOs:')
 9610 FORMAT(/1X,8F10.5)
 9900 FORMAT(/1X,'Number of electrons (trace of DM, NLMO basis) is not',
     * ' within ',F10.5/' of an integer:',F10.5,' - - PROGRAM ABORT')
      END
C*****************************************************************************
      SUBROUTINE LMOANL(T,S,RESON,OCC,TS,BORDER,OWBORD,ATLMO,
     *                  SIAB,NOCC,NAB)
C*****************************************************************************
c Revision 1.2  88/03/03  11:29:56  reed
c To reduce amount of output, deleted some blank lines, commented out print
c of atom totals for bond orders, and the atomic contrib. to the NLMO is
c only printed if it is greater than 0.01%.
c
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER UL
      LOGICAL CLOSED
C
C  PRINT OUT DETAILS OF NAO TO NLMO TRANSFORMATION IN MATRIX T.
C
C  REQUIRED INPUT:
C      NDIM = DECLARED DIMENSIONALITY OF ARRAY T
C      NBAS = NO. OF ORBITALS = ACTUAL DIMENSION OF T, NAOL
C      NAOL = INTEGER LIST OF ORBITAL ANG. MOMENTUM TYPE
C                NAOL(I)/100 = L = Q.N. OF ATOMIC ORBITAL I
C     IATNO = LIST OF ATOMIC NUMBERS; IATNO(I) IS THE NUCLEAR CHARGE
C                OF ATOM I AS AN INTEGER
C    NATOMS = NO. OF ATOMS (NOT INCLUDING GHOSTS) IN THE MOLECULE
C    IWHYBS = 1 IF HYBRID A.O. COEFFICIENTS ARE TO BE PRINTED,
C             0 OTHERWISE.
C     LFNPR = LOGICAL FILE NUMBER FOR PRINTOUT.
C    NAOCTR = LIST OF ATOMIC CENTERS OF OAO OR NAO BASIS ORBITALS
C     LABEL = LIST OF BOND ORBITAL LABELS
C      IBXM = PERMUTATION LIST OF BOND ORBITALS
C    BNDOCC = LIST OF BOND ORBITAL OCCUPANCIES
C     ISPIN = 0 FOR CLOSED SHELL
C           = 2 FOR ALPHA SPIN
C           =-2 FOR BETA  SPIN
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP1(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LTYP(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DIMENSION T(NDIM,NDIM),S(NDIM,NDIM),OCC(NDIM),RESON(NDIM),
     * TS(NDIM),SIAB(NOCC,NAB),ATLMO(NOCC,NATOMS),
     * BORDER(NATOMS,NATOMS),OWBORD(NATOMS,NATOMS),
     * PCT(5),POW(5),LNAME(5),ISP(3),NAM(3),ICH(3,2)
      CHARACTER*80 TITLE
      DATA LLP,LBD,L3C,LCR,LRY/'LP','BD','3C','CR','RY'/
      DATA LNAME/'s','p','d','f','g'/
      DATA ZERO,HUNDTH,T99,T99P/0.0D0,1.D-2,99.99D0,99.995D0/
      DATA TWO,TENTH,HUNDRD,THR/2.0D0,0.1D0,100.0D0,1.0D-6/
      DATA LHYP,LBLNK,L2BLNK/'-',' ','  '/
      DATA BOTHR/2.0D-3/
C
      CLOSED=.TRUE.
      IF(ISPIN.NE.0) CLOSED=.FALSE.
      IF(ISPIN.EQ.0) WRITE(LFNPR,8400)
      IF(ISPIN.EQ.2) WRITE(LFNPR,8410)
      IF(ISPIN.EQ.-2) WRITE(LFNPR,8420)
      WRITE(LFNPR,8000)
      WRITE(LFNPR,8100) (LHYP,J=1,79)
C  LOOP OVER OCCUPIED NLMOS:
      DO 900 NLMO=1,NBAS
        IF(OCC(NLMO).LT.TENTH) GO TO 900
        IB=IBXM(NLMO)
        LBL=LABEL(IB,1)
        IF(LBL.EQ.LLP.OR.LBL.EQ.LCR.OR.LBL.EQ.LRY) NCTR=1
        IF(LBL.EQ.LBD) NCTR=2
        IF(LBL.EQ.L3C) NCTR=3
        DO 110 I=1,3
          IA=LABEL(IB,I+3)
          CALL CONVRT(IA,ICH(I,1),ICH(I,2))
          NAM(I)=L2BLNK
          IF(IA.GT.0) NAM(I)=NAMEAT(IATNO(IA))
          ISP(I)=LHYP
          IF(I.GE.NCTR) ISP(I)=LBLNK
  110     CONTINUE
C  LOOP OVER ATOMIC CENTERS OF BOND ORBITAL NBOND
        DO 170 ICTR=1,NCTR
          ISP(ICTR)=LHYP
          IF(ICTR.EQ.NCTR) ISP(ICTR)=LBLNK
          I=LABEL(IB,ICTR+3)
          NEL=NAMEAT(IATNO(I))
  170     CONTINUE
          WRITE(LFNPR,8220) NLMO,OCC(NLMO),RESON(NLMO),(LABEL(IB,K),
     +                K=1,3),(NAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3)
          IF(OCC(NLMO).LT.TENTH.AND.LBL.EQ.LRY) GO TO 900
C  LOOP OVER ATOMS:  (J COUNTS OVER NAOS)
        DO 700 IAT=1,NATOMS
          NL=0
          DO 200 L=1,5
  200       PCT(L)=ZERO
          JLOW=LL(IAT)
          JHIGH=UL(IAT)
          DO 300 J=JLOW,JHIGH
            L=NAOL(J)/100+1
            COEF=T(J,NLMO)
            PCT(L)=PCT(L)+COEF*COEF
  300       CONTINUE
C  PRINT OUT CONTRIBUTION FROM ATOM IAT (AND SAVE IN ATLMO):
          NL=L
          POL=ZERO
          DO 340 L=1,5
  340       POL=POL+PCT(L)
          IF(NLMO.LE.NOCC) ATLMO(NLMO,IAT)=POL
          PCTPOL=POL*HUNDRD
C  PRINT ONLY CONTRIBUTIONS GREATER THAN 0.01%
          IF(PCTPOL.LT.HUNDTH) GO TO 700
          DO 350 L=1,5
  350       PCT(L)=HUNDRD*PCT(L)/POL
C  FIND LEADING NON-ZERO CONTRIBUTION TO DETERMINE POW(L) FOR EACH L
          LSTD=0
          DO 460 L=1,NL
            IF(LSTD.GT.0) GO TO 450
             POW(L)=ZERO
             STD=PCT(L)
             IF(STD.LT.HUNDTH) GO TO 460
              LSTD=L
  450       POW(L)=PCT(L)/STD
             IF(POW(L).GT.T99P) POW(L)=T99
  460     CONTINUE
          NL1=NL
          NEL=NAMEAT(IATNO(IAT))
          IF(NL1.GT.3) NL1=3
          WRITE(LFNPR,8300)
     *        PCTPOL,NEL,IAT,PCT(1),(LNAME(L),POW(L),PCT(L),L=2,NL1)
          IF(NL.GT.3) WRITE(LFNPR,8310)
     *        (LNAME(L),POW(L),PCT(L),L=4,NL)
  700     CONTINUE
  900   CONTINUE
C
C  NOW, COMPUTE HYBRID OVERLAPS SIAB:
C
      IF(ORTHO) GOTO 2200
      CALL FESNAO(S)
      DO 1500 NLMO=1,NOCC
        IAB=0
        NATM1=NATOMS-1
        DO 1400 IAT=1,NATM1
          IALOW=LL(IAT)
          IAHIGH=UL(IAT)
          DO 1100 L=1,NBAS
            IF(L.GE.IALOW.AND.L.LE.IAHIGH) GO TO 1100
            TS(L)=ZERO
            DO 1050 K=IALOW,IAHIGH
 1050         TS(L)=TS(L)+T(K,NLMO)*S(K,L)
 1100       CONTINUE
C          IF(IAT.GT.2) GO TO 1130
C          CALL ALTOUT(TS,1,NDIM,1,NDIM)
C 1130     CONTINUE
          JAT0=IAT+1
          DO 1300 JAT=JAT0,NATOMS
            IAB=IAB+1
            OVP=ZERO
            JALOW=LL(JAT)
            JAHIGH=UL(JAT)
            DO 1200 L=JALOW,JAHIGH
 1200         OVP=OVP+TS(L)*T(L,NLMO)
            ANORM=SQRT(ATLMO(NLMO,IAT)*ATLMO(NLMO,JAT))
            IF(ANORM.LT.THR) GO TO 1250
            SIAB(NLMO,IAB)=OVP/ANORM
C            IF(IAT.GT.2) GO TO 1300
C            WRITE(LFNPR,9996) JAT,IAB,JALOW,JAHIGH,OVP,ANORM,
C     *                    SIAB(NLMO,IAB)
C 9996       FORMAT(1X,'JAT,IAB,JALOW,JAHIGH,OVP,ANORM,SIAB:',
C     *              /5X,4I3,3F11.6)
            GO TO 1300
 1250       SIAB(NLMO,IAB)=ZERO
C            IF(IAT.GT.2) GO TO 1300
C            WRITE(LFNPR,9996) JAT,IAB,JALOW,JAHIGH,OVP,ANORM,
C     *                    SIAB(NLMO,IAB)
 1300       CONTINUE
 1400     CONTINUE
 1500   CONTINUE
C  NOW WE ARE READY TO COMPUTE BOND ORDERS!
      IF(JPRINT(12).NE.0) THEN
        IAB=0
        NATM1=NATOMS-1
        WRITE(LFNPR,9000)
        DO 2000 IAT=1,NATM1
          JAT0=IAT+1
          DO 1900 JAT=JAT0,NATOMS
            IAB=IAB+1
            SUM=ZERO
            OWSUM=ZERO
            DO 1800 NLMO=1,NOCC
              ALAMA2=ATLMO(NLMO,IAT)
              ALAMB2=ATLMO(NLMO,JAT)
              OVP=SIAB(NLMO,IAB)
              BO=ALAMA2
              IF(ALAMB2.LT.ALAMA2) BO=ALAMB2
C              WRITE(LFNPR,8999) ALAMA2,ALAMB2,BO
C 8999         FORMAT(1X,'ALAMA2,ALAMB2,BO:',3F14.7)
              IF(CLOSED) BO=BO*TWO
              OWBO=BO*OVP
              IF(OVP.LT.ZERO) BO=-BO
              IF(ABS(BO).GT.BOTHR)
     *          WRITE(LFNPR,9100) IAT,JAT,NLMO,BO,OVP
              SUM=SUM+BO
              OWSUM=OWSUM+OWBO
 1800         CONTINUE
C            WRITE(LFNPR,9110) SUM,OWSUM
            BORDER(IAT,JAT)=SUM
            BORDER(JAT,IAT)=SUM
            OWBORD(IAT,JAT)=OWSUM
            OWBORD(JAT,IAT)=OWSUM
 1900       CONTINUE
 2000     CONTINUE
C  ZERO DIAGONAL ELEMENTS!
        DO 2020 IAT=1,NATOMS
          BORDER(IAT,IAT)=ZERO
 2020     OWBORD(IAT,IAT)=ZERO
C  COMPUTE TOTALS BY ATOM AND PRINT RESULTS:
        DO 2100 IAT=1,NATOMS
          SUM=ZERO
          DO 2050 JAT=1,NATOMS
            SUM=SUM+BORDER(IAT,JAT)
 2050     CONTINUE
          TS(IAT)=SUM
 2100   CONTINUE
        TITLE = 'Atom-Atom Net Linear NLMO/NPA Bond Orders:'
        CALL AOUT(BORDER,NATOMS,NATOMS,NATOMS,TITLE,0,NATOMS)
        TITLE = 'Linear NLMO/NPA Bond Orders, Totals by Atom:'
        CALL AOUT(TS,NATOMS,NATOMS,1,TITLE,0,1)
      END IF
 2200 CONTINUE
      RETURN
C
 8000 FORMAT(1X,'NLMO/Occupancy/Percent from Parent NBO/ Atomic ',
     + 'Hybrid Contributions')
 8100 FORMAT(1X,80A1)
 8220 FORMAT(1X,I3,'. (',F7.5,') ',F8.4,'%  ',A2,A1,'(',I2,')',
     + 3(A2,3A1))
 8300 FORMAT(26X,F7.3,'% ',A2,I2,' s(',F6.2,'%)',2(A1,F5.2,'(',
     +  F6.2,'%)'))
 8310 FORMAT(50X,2(A1,F5.2,'(',F6.2,'%)'))
 8400 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ',
     *  'in NAO Basis:')
 8410 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ',
     *  'in NAO Basis, Alpha Spin:')
 8420 FORMAT(/1X,'Hybridization/Polarization Analysis of NLMOs ',
     *  'in NAO Basis, Beta Spin:')
 9000 FORMAT(/1X,'Individual LMO bond orders greater than 0.002',
     *   ' in magnitude,'/1X,
     * 'with the overlap between the hybrids in the NLMO given:',//1X,
     *   'Atom I / Atom J / NLMO / Bond Order / Hybrid Overlap /')
 9100 FORMAT(1X,I4,I8,2X,I6,F14.7,F16.7)
      END
C*****************************************************************************
      SUBROUTINE DIPANL(DM,T,C,TNBO,DX,DY,DZ,SCR,INDEX)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL TEST
C
C  DM       --  NLMO density matrix (input)
C  T        --  AO to NLMO transformation matrix (input)
C  C        --  NBO to NLMO transformation matrix (retrieved from NBODAF)
C  TNBO     --  AO to NBO transformation (retrieved from NBODAF)
C  DX,DY,DZ --  AO dipole matrices (retrieved from NBODAF)
C  SCR      --  NDIM*NDIM word scratch vector
C  INDEX    --  temporary indexing array
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBDXYZ/XDIP,YDIP,ZDIP,CHARGE(MAXATM)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORB(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),C(NDIM,NDIM),TNBO(NDIM,NDIM),
     +         DX(NDIM,NDIM),DY(NDIM,NDIM),DZ(NDIM,NDIM),SCR(NDIM*NDIM),
     +         INDEX(NDIM)
      DIMENSION ISTR(14),COUPLE(3)
C
      DATA TENTEN,SMALL,ZERO,TENTH,ONE,TWO/1.0D-10,1.0D-5,0.0D0,0.1D0,
     +                                     1.0D0,2.0D0/
      DATA TOESU/4.803242E-10/
      DATA IHYPH,IBLNK/1H-,1H /
C
      DEBYE = TOESU / TENTEN
C
C  Copy the nuclear charges into CHARGE:
C
      IF(ALPHA.OR..NOT.OPEN) THEN
        DO 10 I = 1,NATOMS
          CHARGE(I) = IZNUC(I)
   10   CONTINUE
      END IF
C
C  Determine the number of occupied orbitals and make sure that the
C  occupied NLMOs are at the beginning of the list:
C
      TOT = ZERO
      DO 20 I = 1,NBAS
        TOT = TOT + DM(I,I)
        SCR(I) = DM(I,I)
   20 CONTINUE
      NEL = TOT + TENTH
      TOT = NEL
      NOCC = NEL
      IF(.NOT.OPEN) NOCC = NOCC/2 + MOD(NOCC,2)
C
      CALL RANK(SCR,NBAS,NDIM,INDEX)
      DO 30 I = 1,NOCC
        IF(INDEX(I).GT.NOCC) THEN
          WRITE(LFNPR,1000)
          RETURN
        END IF
   30 CONTINUE
C
C  Determine the occupancy factor:
C
      ETA = TWO
      IF(OPEN) ETA = ONE
C
C  Compute the electronic contributions to the NBO bond dipole moments:
C
      CALL FETLMO(C)
      CALL FETNBO(TNBO)
      II = 1
      CALL DIPELE(DX,C,TNBO,SCR,ETA,NOCC,II)
      IF(II.EQ.0) RETURN
      II = 2
      CALL DIPELE(DY,C,TNBO,SCR,ETA,NOCC,II)
      IF(II.EQ.0) RETURN
      II = 3
      CALL DIPELE(DZ,C,TNBO,SCR,ETA,NOCC,II)
      IF(II.EQ.0) RETURN
C
C  Add the nuclear contributions to these bond dipole moments:
C
      CALL DIPNUC(DX,DY,DZ,SCR,ETA,NOCC)
C
C  Convert to Debye:
C
      DO 50 I = 1,NOCC
        DO 40 J = 1,NBAS
          DX(J,I) = DX(J,I) * DEBYE
          DY(J,I) = DY(J,I) * DEBYE
          DZ(J,I) = DZ(J,I) * DEBYE
   40   CONTINUE
   50 CONTINUE
C
C  Print dipole analysis:
C
      XNBO  = ZERO
      YNBO  = ZERO
      ZNBO  = ZERO
      XNLMO = ZERO
      YNLMO = ZERO
      ZNLMO = ZERO
      DO 100 I = 1,NOCC
        IF(I.EQ.1) THEN
          IF(ALPHA) WRITE(LFNPR,1010)
          IF(BETA)  WRITE(LFNPR,1020)
          IF(.NOT.OPEN) WRITE(LFNPR,1030)
          WRITE(LFNPR,1040) ABS(DTHR)
        ELSE
          WRITE(LFNPR,1050)
        END IF
C
C  Build the label for this NBO/NLMO:
C
        IB = IBXM(I)
        ISTR(1) = LABEL(IB,1)
        ISTR(2) = LABEL(IB,2)
        ISTR(3) = LABEL(IB,3)
        DO 70 J = 1,3
          J4 = 4 * J
          IF(LABEL(IB,J+3).EQ.0) THEN
            DO 60 K = J4-1,J4+2
              ISTR(K) = IBLNK
   60       CONTINUE
          ELSE
            IF(J.NE.1) ISTR(J4-1) = IHYPH
            ISTR(J4)   = NAMEAT(IATNO(LABEL(IB,J+3)))
            CALL CONVRT(LABEL(IB,J+3),ISTR(J4+1),ISTR(J4+2))
          END IF
   70   CONTINUE
C
C  Compute the NLMO bond dipole (the NBO bond dipoles are on the diagonal
C  of DX,DY,DZ):
C
        X = ZERO
        Y = ZERO
        Z = ZERO
        DO 80 J = 1,NBAS
          X = X + DX(J,I)
          Y = Y + DY(J,I)
          Z = Z + DZ(J,I)
   80   CONTINUE
C
        XNBO  = XNBO  + DX(I,I)
        YNBO  = YNBO  + DY(I,I)
        ZNBO  = ZNBO  + DZ(I,I)
        XNLMO = XNLMO + X
        YNLMO = YNLMO + Y
        ZNLMO = ZNLMO + Z
C
C  Compute the net dipole for these orbitals:
C
        TOT = SQRT(DX(I,I)*DX(I,I) + DY(I,I)*DY(I,I) + DZ(I,I)*DZ(I,I))
        TOTNLM = SQRT(X*X + Y*Y + Z*Z)
C
        WRITE(LFNPR,1060) I,(ISTR(J),J=1,14),X,Y,Z,TOTNLM,
     +                    DX(I,I),DY(I,I),DZ(I,I),TOT
C
C  Print delocalization terms which are stronger than ABS(DTHR):
C
        ICNT = 0
        DO 90 J = 1,NBAS
          IF(J.NE.I) THEN
            TOT = SQRT(DX(J,I)*DX(J,I) + DY(J,I)*DY(J,I)
     +                                  + DZ(J,I)*DZ(J,I))
            IF(TOT.GT.ABS(DTHR)) THEN
              ICNT = ICNT + 1
              INDEX(ICNT) = J
              SCR(ICNT) = TOT
            END IF
          END IF
   90   CONTINUE
C
        DO 95 J = 1,ICNT
          DO 94 K = 1,ICNT-J
            IF(SCR(K+1)-SCR(K).GT.SMALL) THEN
              ITEMP      = INDEX(K)
              INDEX(K)   = INDEX(K+1)
              INDEX(K+1) = ITEMP
              TEMP       = SCR(K)
              SCR(K)     = SCR(K+1)
              SCR(K+1)   = TEMP
            END IF
   94     CONTINUE
   95   CONTINUE
C
        DO 96 JJ = 1,ICNT
          J = INDEX(JJ)
          WRITE(LFNPR,1070) J,DX(J,I),DY(J,I),DZ(J,I),SCR(JJ)
   96   CONTINUE
  100 CONTINUE
C
C  Compute and print the correction for residual nuclear charges:
C
      IF(.NOT.ALPHA) THEN
        CALL FECOOR(SCR)
        X = ZERO
        Y = ZERO
        Z = ZERO
        TEST = .FALSE.
        DO 110 I = 1,NATOMS
          IF(ABS(CHARGE(I)).GT.SMALL) TEST = .TRUE.
          X = X + SCR(3*I-2) * CHARGE(I) * DEBYE
          Y = Y + SCR(3*I-1) * CHARGE(I) * DEBYE
          Z = Z + SCR(3*I)   * CHARGE(I) * DEBYE
  110   CONTINUE
        IF(TEST) THEN
          TOT = SQRT(X*X + Y*Y + Z*Z)
          WRITE(LFNPR,1080) X,Y,Z,TOT,X,Y,Z,TOT
          XNBO  = XNBO  + X
          YNBO  = YNBO  + Y
          ZNBO  = ZNBO  + Z
          XNLMO = XNLMO + X
          YNLMO = YNLMO + Y
          ZNLMO = ZNLMO + Z
        END IF
      END IF
C
C  Print net dipole moments:
C
      TOT = SQRT(XNBO*XNBO + YNBO*YNBO + ZNBO*ZNBO)
      TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO)
      WRITE(LFNPR,1090) XNLMO,YNLMO,ZNLMO,TOTNLM,XNBO,YNBO,ZNBO,TOT
C
C  Compute and print the total delocalization correction:
C
      X = XNLMO - XNBO
      Y = YNLMO - YNBO
      Z = ZNLMO - ZNBO
      TOT = SQRT(X*X + Y*Y + Z*Z)
      WRITE(LFNPR,1100) X,Y,Z,TOT
C
C  Compute and print the NLMO coupling correction:
C
      TEST = .FALSE.
      DO 130 I = 1,NBAS
        IF(I.GT.NOCC.AND.ABS(DM(I,I)).GT.SMALL) TEST = .TRUE.
        DO 120 J = I+1,NBAS
          IF(ABS(DM(J,I)).GT.SMALL) TEST = .TRUE.
  120   CONTINUE
  130 CONTINUE
      IF(TEST) THEN
        TOT = ZERO
        DO 160 K = 1,3
          II = K
          CALL FEDXYZ(DX,II)
          CALL SIMTRS(DX,T,SCR,NDIM,NBAS)
          COUPLE(K) = ZERO
          DO 150 I = 1,NBAS
            IF(I.LE.NOCC) THEN
              COUPLE(K) = COUPLE(K) + (ETA - DM(I,I)) * DX(I,I)
            ELSE
              COUPLE(K) = COUPLE(K) - DM(I,I) * DX(I,I)
            END IF
            DO 140 J = I+1,NBAS
              COUPLE(K) = COUPLE(K) - TWO * DM(J,I) * DX(J,I)
  140       CONTINUE
  150     CONTINUE
          COUPLE(K) = COUPLE(K) * DEBYE
          TOT = TOT + COUPLE(K) * COUPLE(K)
  160   CONTINUE
        TOT = SQRT(TOT)
        WRITE(LFNPR,1110) XNLMO,YNLMO,ZNLMO,TOTNLM,XNLMO,YNLMO,ZNLMO,
     +                    TOTNLM,(COUPLE(K),K=1,3),TOT
        XNLMO = XNLMO + COUPLE(1)
        YNLMO = YNLMO + COUPLE(2)
        ZNLMO = ZNLMO + COUPLE(3)
        TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO)
        IF(ALPHA) WRITE(LFNPR,1120) XNLMO,YNLMO,ZNLMO,TOTNLM
        IF(BETA)  WRITE(LFNPR,1130) XNLMO,YNLMO,ZNLMO,TOTNLM
        IF(.NOT.OPEN) WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM
      ELSE
        IF(ALPHA) WRITE(LFNPR,1120) XNLMO,YNLMO,ZNLMO,TOTNLM,
     +                              XNLMO,YNLMO,ZNLMO,TOTNLM
        IF(BETA)  WRITE(LFNPR,1130) XNLMO,YNLMO,ZNLMO,TOTNLM,
     +                              XNLMO,YNLMO,ZNLMO,TOTNLM
        IF(.NOT.OPEN) WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM,
     +                                  XNLMO,YNLMO,ZNLMO,TOTNLM
      END IF
C
C  Save the alpha spin dipoles:
C
      IF(ALPHA) THEN
        XDIP = XNLMO
        YDIP = YNLMO
        ZDIP = ZNLMO
      END IF
C
C  Print out the total dipole moment for open shell species:
C
      IF(BETA) THEN
        XNLMO  = XNLMO + XDIP
        YNLMO  = YNLMO + YDIP
        ZNLMO  = ZNLMO + ZDIP
        TOTNLM = SQRT(XNLMO*XNLMO + YNLMO*YNLMO + ZNLMO*ZNLMO)
        WRITE(LFNPR,1140) XNLMO,YNLMO,ZNLMO,TOTNLM
      END IF
      RETURN
C
 1000 FORMAT(/1X,'The highest occupied NBOs are not at the beginning ',
     + 'of the list.',/1X,'The dipole moment analysis is currently not',
     + ' set up to handle this.')
 1010 FORMAT(//1X,'Dipole moment analysis, alpha spin:')
 1020 FORMAT(//1X,'Dipole moment analysis, beta spin:')
 1030 FORMAT(//1X,'Dipole moment analysis:')
 1040 FORMAT(/1X,'[Print threshold: Net dipole >',F5.2,' Debye]',//1X,
     + '                                NLMO bond dipole            ',
     + 'NBO bond dipole',/1X,'                            ----------',
     + '---------------  ------------------------',/1X,'         ',
     + 'Orbital              x     y     z   Total      x     y     ',
     + 'z   Total',/1X,79('='))
 1050 FORMAT(1X)
 1060 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',A2,3A1,A2,3A1,A2,2A1,1X,4F6.2,
     + 3X,4F6.2)
 1070 FORMAT(1X,44X,'deloc ',I3,':',4F6.2)
 1080 FORMAT(/1X,'  Residual nuclear charge  ',4F6.2,'   ',4F6.2)
 1090 FORMAT(1X,'                           -----------------------',
     + '-----------------------------',/1X,'        Net dipole moment',
     + '  ',4F6.2,'   ',4F6.2)
 1100 FORMAT(1X,'Delocalization correction  ',24X,'   ',4F6.2,/1X,
     + '                           -----------------------------',
     + '-----------------------')
 1110 FORMAT(1X,'        Net dipole moment  ',4F6.2,'   ',4F6.2,/1X,
     + ' NLMO coupling correction  ',4F6.2,/1X,'                  ',
     + '         -------------------------')
 1120 FORMAT(1X,'        Alpha spin dipole  ',4F6.2,'   ',4F6.2)
 1130 FORMAT(1X,'         Beta spin dipole  ',4F6.2,'   ',4F6.2)
 1140 FORMAT(1X,'      Total dipole moment  ',4F6.2,'   ',4F6.2)
      END
C*****************************************************************************
      SUBROUTINE DIPELE(DXYZ,C,T,SCR,ETA,NOCC,INDEX)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION DXYZ(NDIM,NDIM),C(NDIM,NDIM),T(NDIM,NDIM),SCR(NDIM,NDIM)
C
C
C  Compute the electronic contribution for the x (INDEX=1), y (=2),
C  and z (=3) components of the dipole:
C
C  Get the AO dipole matrix and transform to the NBO basis:
C
      CALL FEDXYZ(DXYZ,INDEX)
      IF(INDEX.EQ.0) RETURN
      CALL SIMTRS(DXYZ,T,SCR,NDIM,NBAS)
C
C  Compute the electronic contribution for doubly occupied, filled NBOs:
C
      DO 30 I = 1,NOCC
        SCR(I,I) = -ETA * DXYZ(I,I)
   30 CONTINUE
C
C  Compute delocalization contributions for each filled NBO:
C
      DO 60 I = 1,NOCC
        DO 50 J = 1,NBAS
          IF(J.NE.I) THEN
            SCR(J,I) = C(J,I) * DXYZ(I,I) - C(I,I) * DXYZ(J,I)
            DO 40 K = 1,NBAS
                SCR(J,I) = SCR(J,I) - C(K,I) * DXYZ(K,J)
   40       CONTINUE
            SCR(J,I) = ETA * C(J,I) * SCR(J,I)
          END IF
   50   CONTINUE
   60 CONTINUE
      CALL COPY(SCR,DXYZ,NDIM,NBAS,NBAS)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE DIPNUC(DX,DY,DZ,ATCOOR,ETA,NOCC)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBDXYZ/XDIP,YDIP,ZDIP,CHARGE(MAXATM)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      DIMENSION DX(NDIM,NDIM),DY(NDIM,NDIM),DZ(NDIM,NDIM),
     +          ATCOOR(3,NATOMS)
C
      DATA ZERO/0.0D0/
C
C  Fetch the atomic coordinates:
C
      CALL FECOOR(ATCOOR)
C
C  Calculate the nuclear contributions to the dipole moment:
C
      DO 20 I = 1,NOCC
        NCTR = MOD(NBOTYP(I),10)
        X = ZERO
        Y = ZERO
        Z = ZERO
        DO 10 J = 1,NCTR
          IAT = LABEL(IBXM(I),J+3)
          X   = X + ATCOOR(1,IAT)
          Y   = Y + ATCOOR(2,IAT)
          Z   = Z + ATCOOR(3,IAT)
          CHARGE(IAT) = CHARGE(IAT) - ETA/NCTR
   10   CONTINUE
        X = ETA * X / NCTR
        Y = ETA * Y / NCTR
        Z = ETA * Z / NCTR
        DX(I,I) = DX(I,I) + X
        DY(I,I) = DY(I,I) + Y
        DZ(I,I) = DZ(I,I) + Z
   20 CONTINUE
      RETURN
      END
C*****************************************************************************
C
C  ROUTINES CALLED BY SR NATHYB, SR CHOOSE:
C
C      SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
C      FUNCTION IWPRJ(NCTR)
C      SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD)
C      SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
C      SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP)
C      SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
C      SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG)
C      SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI)
C      SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
C      SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD)
C      SUBROUTINE FORMT(T,Q,POL)
C      SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
C
C*****************************************************************************
      SUBROUTINE CORE(DM,T,BORB,POL,Q,HYB,BNDOCC,IBD,DETAIL,LFNPR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  Label core, valence, and Rydberg NAO's and deplete DM of the density
C  of the core orbitals
C
      LOGICAL DETAIL,FIRST
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
     +       IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),BORB(MXBO),POL(NDIM,3),
     *  Q(MXAO,NDIM),HYB(MXAO),BNDOCC(NDIM),ICORE(4),IVAL(4),IANG(5)
      DATA ZERO,ONE/0.0D0,1.0D0/
      DATA IBLK,ICOR,IRYD/'  ','CR','Ryd'/
      DATA ICHCOR,ICHVAL/'Cor','Val'/
      DATA IANG/'s','p','d','f','g'/
C
C  Label NAO's on each center:
C
      DO 10 I = 1,NBAS
        LTYP(I) = IRYD
   10 CONTINUE
      IECP = 0
      DO 110 NCTR = 1,NATOMS
        CALL CORTBL(NCTR,ICORE,IECP)
        CALL VALTBL(NCTR,IVAL)
C
C  Loop over s,p,d,f orbitals:
C
        DO 100 L = 0,3
          ITYP = IANG(L+1)
          LNUM = 2*L + 1
          IF(ICORE(L+1).LE.0) GOTO 50
C
C  Label core orbitals:
C
          DO 40 M = 1,ICORE(L+1)
            DO 30 LA = 1,LNUM
              MORB = 0
              OCC = -1.0
              DO 20 N = 1,NBAS
                LM = NAOL(N)
                NORB = LM/100
                IL = IANG(NORB+1)
                NA = MOD(NAOL(N),50)
                IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND.
     +            DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND.
     +                                         LA.EQ.NA) THEN
                      MORB = N
                      OCC = DM(N,N)
                END IF
   20         CONTINUE
              IF(MORB.EQ.0) THEN
                WRITE(LFNPR,2500) ITYP,NAMEAT(IATNO(NCTR)),NCTR,
     +                            (ICORE(I),I=1,4),M,LA
                STOP
              END IF
              LTYP(MORB) = ICHCOR
   30       CONTINUE
   40     CONTINUE
   50     CONTINUE
          IF(IVAL(L+1).LE.0) GOTO 90
C
C  Label valence orbitals:
C
          DO 80 M = 1,IVAL(L+1)
            DO 70 LA = 1,LNUM
              MORB = 0
              OCC = -1.0
              DO 60 N = 1,NBAS
                LM = NAOL(N)
                NORB = LM/100
                IL = IANG(NORB+1)
                NA = MOD(NAOL(N),50)
                IF(NAOCTR(N).EQ.NCTR.AND.IL.EQ.ITYP.AND.
     +            DM(N,N).GT.OCC.AND.LTYP(N).EQ.IRYD.AND.
     +                                         LA.EQ.NA) THEN
                      MORB = N
                      OCC = DM(N,N)
                END IF
   60         CONTINUE
              IF(MORB.EQ.0) THEN
                WRITE(LFNPR,2600) ITYP,NAMEAT(IATNO(NCTR)),NCTR,
     +                            (IVAL(I),I=1,4),M,LA
                STOP
              END IF
              LTYP(MORB) = ICHVAL
   70       CONTINUE
   80     CONTINUE
   90     CONTINUE
  100   CONTINUE
  110 CONTINUE
C
C  Isolate core orbitals on all atoms, removing their density from the
C  density matrix:
C
      DO 300 IAT = 1,NATOMS
        NB = IUL(IAT) - ILL(IAT) + 1
        IAC = 0
        FIRST = .TRUE.
        DO 290 N = ILL(IAT),IUL(IAT)
          IF(LTYP(N).EQ.ICHCOR) THEN
            IF(DETAIL.AND.FIRST) THEN
              FIRST = .FALSE.
              WRITE(LFNPR,1000) IAT
            END IF
            IAC = IAC + 1
            IBD = IBD + 1
            DO 280 I = 1,NB
              BORB(I) = ZERO
  280       CONTINUE
            BORB(N-ILL(IAT)+1) = ONE
            CALL STASH(BORB,IBD,IAT,0,0,POL,Q,HYB)
            LABEL(IBD,1) = ICOR
            LABEL(IBD,2) = IBLK
            LABEL(IBD,3) = IAC
            LABEL(IBD,4) = IAT
            BNDOCC(IBD)  = DM(N,N)
            IF(DETAIL) WRITE(LFNPR,1010) IAC,BNDOCC(IBD)
            IF(DETAIL) WRITE(LFNPR,1020) (BORB(I),I=1,NB)
            IF(DETAIL) WRITE(LFNPR,1030) IBD,(LABEL(IBD,I),I=1,3)
          END IF
  290   CONTINUE
  300 CONTINUE
C
C  Deplete the density matrix of CR orbitals:
C
      CALL DEPLET(DM,T,Q,POL,BORB,BNDOCC,IBD)
      RETURN
C
 1000 FORMAT(/,1X,'Search of DM block for core orbitals on atom:',I4)
 1010 FORMAT(6X,'Eigenvector (',I2,') has occupancy ',F9.6,':')
 1020 FORMAT(11X,8F7.4)
 1030 FORMAT(11X,'*** NBO accepted: Number',I3,'.   Label:',A2,A1,
     + '(',I2,')')
 2500 FORMAT(/1X,'Subroutine CORE could not find a ',A1,'-type ',
     + 'core orbital on atom ',A2,I2,'.',/,1X,'ICORE :',4I3,
     + '     M :',I3,'     LA :',I3)
 2600 FORMAT(/1X,'Subroutine CORE could not find a ',A1,'-type ',
     + 'valence orbital on atom ',A2,I2,'.',/,1X,'IVAL :',4I3,
     + '     M :',I3,'     LA :',I3)
      END
C*****************************************************************************
      FUNCTION IWPRJ(NCTR)
C*****************************************************************************
      DATA NCTR0/0/
C
C  RETURN 0 (NO PROJECTION WANTED) IF NCTR IS UNCHANGED, 1 OTHERWISE.
C
      IWPRJ=0
      IF(NCTR.EQ.NCTR0) RETURN
       IWPRJ=1
       NCTR0=NCTR
       RETURN
      END
C*****************************************************************************
      SUBROUTINE DEPLET(DM,T,Q,POL,BORB,BNDOCC,NBD)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  DEPLETE DENSITY MATRIX DM OF CONTRIBUTION FROM B.O.'BORB':
C     DM ==> DM - OCC*BORB*BORB(TRANSPOSE).
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
     +       IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      DIMENSION DM(NDIM,NDIM),T(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3),
     *  BORB(MXBO),BNDOCC(NDIM)
      DIMENSION IAT(3)
C  RESTORE DM FROM T
      DO 10 J=1,NBAS
        DO 10 I=1,J
          DM(I,J)=T(I,J)
   10     DM(J,I)=DM(I,J)
C  MAIN LOOP OVER NBD AVAILABLE BOND ORBITALS:
      DO 90 IBD=1,NBD
        OCC=BNDOCC(IBD)
C  FIND ATOMS FOR B.O. #IBD
        NCTR=0
        DO 20 J=1,3
          IAT(J)=LABEL(IBD,J+3)
          IF(IAT(J).LE.0) GO TO 30
          NCTR=NCTR+1
   20     CONTINUE
C  RECONSTRUCT BORB FOR B.O. #IBD
   30   NELM=0
        DO 40 ICTR=1,NCTR
          IA=IAT(ICTR)
          IHYB=IATHY(IBD,ICTR)+ILL(IA)-1
          P=POL(IBD,ICTR)
          NH=NORBS(IA)
          DO 40 IH=1,NH
            NELM=NELM+1
   40       BORB(NELM)=P*Q(IH,IHYB)
C  SUBTRACT OCC*BORB*BORB(T) FROM DM
        NROW=0
        DO 80 ICTR=1,NCTR
          IA=IAT(ICTR)
          IU=IUL(IA)
          IL=ILL(IA)
          DO 70 IROW=IL,IU
            NROW=NROW+1
            NCOL=0
            DO 60 JCTR=1,NCTR
              JA=IAT(JCTR)
              JU=IUL(JA)
              JL=ILL(JA)
              DO 50 ICOL=JL,JU
                NCOL=NCOL+1
   50           DM(IROW,ICOL)=DM(IROW,ICOL)-OCC*BORB(NROW)*BORB(NCOL)
   60         CONTINUE
   70       CONTINUE
   80     CONTINUE
   90   CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE LOAD(DM,IAT1,IAT2,IAT3,BLK,NB)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  ZERO THE MATRIX 'BLK' AND LOAD IN ATOMIC BLOCKS OF DENSITY
C  MATRIX 'DM' FOR THE ATOMS LISTED IN 'IAT'
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
     +       IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      DIMENSION BLK(MXBO,MXBO),DM(NDIM,NDIM),IAT(3)
      DATA ZERO/0.0D0/
      IAT(1)=IAT1
      IAT(2)=IAT2
      IAT(3)=IAT3
C  ZERO 'BLK'
      DO 10 I=1,MXBO
        DO 10 J=1,MXBO
   10     BLK(I,J)=ZERO
      NROW=0
      NCOL=0
      DO 50 I=1,3
        IA=IAT(I)
        IF(IA.EQ.0) GO TO 50
        IU=IUL(IA)
        IL=ILL(IA)
        DO 40 IROW=IL,IU
          NROW=NROW+1
          NCOL=0
          DO 30 J=1,3
            JA=IAT(J)
            IF(JA.EQ.0) GO TO 30
            JU=IUL(JA)
            JL=ILL(JA)
            DO 20 ICOL=JL,JU
              NCOL=NCOL+1
              BLK(NROW,NCOL)=DM(IROW,ICOL)
   20         CONTINUE
   30       CONTINUE
   40     CONTINUE
   50   CONTINUE
      NB=NROW
      RETURN
      END
C*****************************************************************************
      SUBROUTINE PRJEXP(BORB,IAT1,IAT2,IAT3,Q,P,PK,HYB,VA,VB,HYBEXP)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  DETERMINE HOW MUCH OF BORB IS COMPOSED OF PREVIOUSLY USED HYBRIDS.
C
C  RETURN HYBEXP(I) = EXPECTATION VALUE OF HYBRID "I" IN BORB OVER THE
C                     PROJECTION OPERATOR P FOR THE ATOM OF THE HYBRID.
C
C  IF NO HYBRID ON ATOM I CONTRIBUTES TO BORB, HYBEXP(I) = ZERO.
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
     +       IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
C
      DIMENSION IAT(3),HYB(MXAO),BORB(MXBO),Q(MXAO,NDIM),P(MXAO,MXAO),
     *  PK(MXAO,MXAO),VA(MXAO),VB(MXAO),HYBEXP(3)
C
      DATA ZERO,ONE,EPS/0.0D0,1.0D0,1.0D-5/
C
C  LOOP OVER ATOMIC HYBRIDS:
C
      IAT(1) = IAT1
      IAT(2) = IAT2
      IAT(3) = IAT3
      KMAX   = 0
      DO 50 I = 1,3
        HYBEXP(I) = ZERO
        IA = IAT(I)
        IF(IA.EQ.0) GO TO 50
C
C  EXTRACT THE ITH ATOMIC HYBRID FROM BORB:
C
        NU = IUL(IA)
        NL = ILL(IA)
        KMIN = KMAX + 1
        KMAX = KMAX + NU - NL + 1
        MJ = 0
        DO 10 K = KMIN,KMAX
          MJ = MJ + 1
          HYB(MJ) = BORB(K)
   10   CONTINUE
C
C  DO HYBRIDS FROM THE ITH ATOM CONTRIBUTE TO BORB?
C
        S = ZERO
        DO 20 J = 1,MJ
          S = S + HYB(J)**2
   20   CONTINUE
        IF(S.LT.EPS) GO TO 50
C
C  DETERMINE THE PROJECTION EXPECTATION FOR THIS HYBRID:
C
        NH = INO(IA)
        IF(NH.EQ.0) THEN
          HYBEXP(I) = ONE
        ELSE
          CALL FRMPRJ(P,IA,Q,NH,PK,VA,VB)
          PAV = ZERO
          DO 40 J = 1,MJ
            DO 30 K = 1,MJ
              PAV = PAV + HYB(K) * P(K,J) * HYB(J)
   30       CONTINUE
   40     CONTINUE
          HYBEXP(I) = ABS(PAV) / S
        END IF
   50 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE STASH(BORB,IBD,IAT1,IAT2,IAT3,POL,Q,HYB)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  DECOMPOSE BOND ORBITAL 'BORB' AND STORE CONSTITUENT HYBRIDS IN Q
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
     +       IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
C
      DIMENSION POL(NDIM,3),Q(MXAO,NDIM),BORB(MXBO),IAT(3),HYB(MXAO)
C
      DATA ZERO/0.0D0/
C
C  LOOP OVER CENTERS:
C
      IAT(1) = IAT1
      IAT(2) = IAT2
      IAT(3) = IAT3
      KMAX   = 0
      DO 40 I = 1,3
        IA = IAT(I)
        IF(IA.EQ.0) GO TO 40
        NU = IUL(IA)
        NL = ILL(IA)
C
C  EXTRACT HYBRID FROM BOND ORBITAL FOR ATOM IA:
C
        KMIN = KMAX + 1
        KMAX = KMAX + NU - NL + 1
        MJ = 0
        DO 10 K = KMIN,KMAX
          MJ = MJ + 1
          HYB(MJ) = BORB(K)
   10   CONTINUE
C
C  EXTRACT POLARIZATION COEFFICIENT, STORE IN 'POL':
C
        PSQ = ZERO
        DO 20 J = 1,MJ
          PSQ = PSQ + HYB(J)**2
   20   CONTINUE
        P = SQRT(PSQ)
        POL(IBD,I) = P
C
C  ONE MORE HYBRID FOR ATOM IA:
C
        INO(IA) = INO(IA) + 1
        NCOL = ILL(IA) + INO(IA) - 1
C
C  PLACE NORMALIZED HYBRID IN APPROPRIATE BLOCK OF Q:
C
        NH = NU - NL + 1
        DO 30 NROW = 1,NH
          IF(P.EQ.ZERO) THEN
            Q(NROW,NCOL) = ZERO
          ELSE
            Q(NROW,NCOL) = HYB(NROW)/P
          END IF
   30   CONTINUE
        IATHY(IBD,I) = INO(IA)
   40 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE ORTHYB(Q,S,TA,EVAL,C,IALARM,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  SYMMETRIC ORTHOGONALIZATION OF AVAILABLE HYBRIDS IN Q:
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       ILU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
C
      DIMENSION Q(MXAO,NDIM),S(MXBO,MXBO),TA(MXAO,MXAO),
     *                    EVAL(MXBO),C(MXBO,MXBO)
C
      DATA ZERO,ONE/0.0D0,1.0D0/
      DATA TOOSML/1.0D-4/
C
C  TOOSML: "TOO SMALL" -- THRESHOLD FOR AN S MATRIX EIGENVALUE THAT IS TOO
C   SMALL AND WILL CAUSE NUMERICAL PROBLEMS AND IS INDICATIVE OF NEAR-LINEAR
C   DEPENDENCY IN THE HYBRIDS:
C
      IALARM = 0
      DO 100 IA = 1,NATOMS
        IL = LL(IA)
        NH = INO(IA)
        IF(NH.GT.MXAO) GO TO 800
        IF(NH.LE.1) GO TO 100
C
C  LOAD IA-BLOCK OF Q INTO TA:
C
        DO 10 J = 1,NH
          DO 5 I = 1,MXAO
            TA(I,J) = Q(I,IL+J-1)
    5     CONTINUE
   10   CONTINUE
C
C  FORM OVERLAP MATRIX S = TA(TRANSP)*TA:
C
        DO 30 J = 1,NH
          DO 25 I = J,NH
            TEMP = ZERO
            DO 20 K = 1,MXAO
              TEMP = TEMP + TA(K,I) * TA(K,J)
   20       CONTINUE
            S(I,J) = TEMP
            S(J,I) = TEMP
   25     CONTINUE
   30   CONTINUE
C
C  DIAGONALIZE OVERLAP MATRIX:
C
        CALL JACOBI(NH,S,EVAL,C,MXBO,MXBO,0)
C
C  FORM INVERSE SQUARE ROOT OF S, STORE IN S: (AVOID NUMERICAL PROBLEMS
C  OF LINEAR DEPENDENCE ("TOO SMALL" EIGENVALUES) BY PRESCREENING THE
C  EIGENVALUES)
C
        DO 40 I = 1,NH
          IF(EVAL(I).LT.TOOSML) GO TO 810
          EVAL(I) = ONE / SQRT(EVAL(I))
   40   CONTINUE
        DO 60 J = 1,NH
          DO 55 I = J,NH
            TEMP = ZERO
            DO 50 K = 1,NH
              TEMP = TEMP + EVAL(K) * C(I,K) * C(J,K)
   50       CONTINUE
            S(I,J) = TEMP
            S(J,I) = TEMP
   55     CONTINUE
   60   CONTINUE
C
C  FORM NEW TAP=TA*S**(-1/2), STORE IN C:
C
        DO 80 J = 1,NH
          DO 75 I = 1,MXAO
            TEMP = ZERO
            DO 70 K = 1,NH
              TEMP = TEMP + TA(I,K) * S(K,J)
   70       CONTINUE
            C(I,J) = TEMP
   75     CONTINUE
   80   CONTINUE
C
C  REPLACE ORTHOGONALIZED TA IN ARRAY Q:
C
        DO 90 J = 1,NH
          DO 85 I = 1,MXAO
            Q(I,IL+J-1) = C(I,J)
   85     CONTINUE
   90   CONTINUE
  100 CONTINUE
C
C  SYMMETRIC ORTHOGONALIZATION COMPLETE:
C
      RETURN
C
C  SOUND THE ALARM THAT TOO MANY HYBRIDS WERE FOUND ON THIS ATOM:
C
  800 CONTINUE
      IALARM = IA
      IF(IFLG.EQ.0) WRITE(LFNPR,900) MXAO,IA,NH
      RETURN
C
C  SOUND THE ALARM THAT THERE ARE TOO MANY HYBRIDS OR THAT THERE IS
C  LINEAR DEPENDENCY IN THE HYBRIDS!!
C
  810 CONTINUE
      IALARM = IA
      IF(IFLG.EQ.0) WRITE(LFNPR,910) IA,EVAL(I),TOOSML
      RETURN
C
  900 FORMAT(/4X,'Only expected to find',I3,' hybrids on atom',I3,
     + ', but found',I3,'.')
  910 FORMAT(/4X,'The hybrids on atom',I3,' are linearly dependent.',
     + '  An eigenvalue (',F10.6,')',/4X,'of the hybrid overlap ',
     + 'matrix is too small (<',F7.5,').')
      END
C*****************************************************************************
      SUBROUTINE FRMPRJ(P,IA,Q,NK,PK,VK,PI)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  FORM PROJECTION MATRIX P TO ANNIHILATE COMPONENTS OF NK OCCUPIED
C  HYBRIDS FOR ATOM IA.
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
     +       IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
C
      DIMENSION P(MXAO,MXAO),VK(MXAO),PI(MXAO),Q(MXAO,NDIM),
     *          PK(MXAO,MXAO)
C
      DATA ZERO,ONE/0.0D0,1.0D0/
C
C  INITIALIZE P = UNIT MATRIX:
C
      NB = NORBS(IA)
      DO 10 J = 1,NB
        DO 5 I = 1,J
          P(I,J) = ZERO
          P(J,I) = ZERO
          IF(I.EQ.J) P(I,J) = ONE
    5   CONTINUE
   10 CONTINUE
C
C  FORM PROJECTION MATRIX P = P1*P2*...*PK*...*PNK TO ANNIHILATE
C  COMPONENTS OF THE NK OCCUPIED HYBRIDS VK:  PK = I - VK*VK(T).
C  LOOP OVER OCCUPIED HYBRIDS VK, K = 1,...,NK:
C
      IF(NK.LE.0) RETURN
C
C  EXTRACT OCCUPIED HYBRID VK FROM ARRAY Q:
C
      DO 90 K = 1,NK
        ICOL = ILL(IA) + K - 1
        DO 30 I = 1,NB
          VK(I) = Q(I,ICOL)
   30   CONTINUE
C
C  FORM PROJECTION MATRIX PK:
C
        DO 40 J = 1,NB
          DO 35 I = 1,J
            PK(I,J) = -VK(I) * VK(J)
            PK(J,I) = PK(I,J)
            IF(I.EQ.J) PK(I,J) = PK(I,J) + ONE
   35     CONTINUE
   40   CONTINUE
C
C  ACCUMULATE TOTAL PROJECTOR P(K) = P(K-1)*PK:
C
        DO 80 I = 1,NB
          DO 60 J = 1,NB
            PI(J) = ZERO
            DO 50 L = 1,NB
              PI(J) = PI(J) + P(I,L) * PK(L,J)
   50       CONTINUE
   60     CONTINUE
          DO 70 J = 1,NB
            P(I,J) = PI(J)
   70     CONTINUE
   80   CONTINUE
   90 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE AUGMNT(P,BLK,C,EVAL,DM,TA,BORB,V,LARC,IA,NOCC,NORB)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
      DIMENSION P(MXAO,MXAO),TA(MXAO,MXAO),DM(NDIM,NDIM),C(MXBO,MXBO),
     + EVAL(MXBO),BORB(MXBO),V(MXBO),BLK(MXBO,MXBO),LARC(NBAS)
C
      DATA ZERO,EPS,PT99,ONE/0.0D0,1.0D-5,0.99D0,1.0D0/
C
C  FIRST, FORM SET OF "OPTIMALLY DIAGONAL" UNIT VECTORS TO SPAN RYDBERG SPACE:
C
      NAUG = NORB - NOCC
      DO 10 I = 1,NORB
        LARC(I) = 0
   10 CONTINUE
C
C  SELECT PROJECTED NAO UNIT VECTOR FROM PROJECTOR IN P:
C
      DO 300 IPROJ = 1,NAUG
        IMAX = 0
        PRJMAX = ZERO
        DO 80 IAO = 1,NORB
          IF(LARC(IAO).NE.0) GO TO 80
          PROJ = ABS(P(IAO,IAO))
          IF(PROJ.GT.PT99) GO TO 100
          IF(PROJ.LT.PRJMAX) GO TO 80
          PRJMAX = PROJ
          IMAX = IAO
   80   CONTINUE
        IAO = IMAX
        PROJ = PRJMAX
  100   CONTINUE
C
C  PUT VECTOR IN BORB, NORMALIZE, AND SAVE IN C:
C
        SB = ZERO
        DO 120 J = 1,NORB
          B = P(IAO,J)
          SB = SB + B * B
          BORB(J) = B
  120   CONTINUE
        LARC(IAO) = IPROJ
        RNORM = ONE / SQRT(SB)
        DO 130 J = 1,NORB
          BORB(J) = BORB(J) * RNORM
  130   CONTINUE
        DO 140 J = 1,NORB
          C(J,IPROJ) = BORB(J)
  140   CONTINUE
        IF(IPROJ.EQ.NAUG) GO TO 300
C
C  ADD BORB TO THE PROJECTOR IN P:
C
        DO 150 J = 1,NORB
          DO 145 I = 1,J
            TA(I,J) = -BORB(I) * BORB(J)
            TA(J,I) = TA(I,J)
            IF(I.EQ.J) TA(I,I) = TA(I,I) + ONE
  145     CONTINUE
  150   CONTINUE
        DO 200 I = 1,NORB
          DO 180 J = 1,NORB
            V(J) = ZERO
            DO 170 L = 1,NORB
              V(J) = V(J) + P(I,L) * TA(L,J)
  170       CONTINUE
  180     CONTINUE
          DO 190 J = 1,NORB
            P(I,J) = V(J)
  190     CONTINUE
  200   CONTINUE
  300 CONTINUE
C
C  PUT PROJECTED VECTORS IN TA, ORDERED ACCORDING TO THE NAO PARENT:
C
      IAUG = 0
      DO 350 IAO = 1,NORB
        IF(LARC(IAO).EQ.0) GO TO 350
        IAUG = IAUG + 1
        ITCOL = LARC(IAO)
        DO 330 J = 1,NORB
          TA(J,IAUG) = C(J,ITCOL)
  330   CONTINUE
  350 CONTINUE
C
C  LOAD DM BLOCK FOR ATOM IA IN BLK:
C
      CALL LOAD(DM,IA,0,0,BLK,NORB)
C
C  FORM BLOCK OF DM IN RYDBERG BASIS IN UPPER CORNER OF BLK:
C
      DO 500 IB = 1,NORB
        DO 450 J = 1,NAUG
          SUM = ZERO
          DO 440 K = 1,NORB
            SUM = SUM + BLK(IB,K) * TA(K,J)
  440     CONTINUE
          V(J) = SUM
  450   CONTINUE
        DO 480 J = 1,NAUG
          BLK(IB,J) = V(J)
  480   CONTINUE
  500 CONTINUE
      DO 550 J = 1,NAUG
        DO 520 I = 1,J
          SUM = ZERO
          DO 510 K = 1,NORB
            SUM = SUM + TA(K,I) * BLK(K,J)
  510     CONTINUE
          V(I) = SUM
  520   CONTINUE
        DO 530 I = 1,NAUG
          BLK(I,J) = V(I)
  530   CONTINUE
  550 CONTINUE
      DO 560 J = 1,NAUG
        JJ = J - 1
        DO 555 I = 1,JJ
          BLK(J,I) = BLK(I,J)
  555   CONTINUE
  560 CONTINUE
C
C  DIAGONALIZE DM:
C
      CALL JACOBI(NAUG,BLK,EVAL,C,MXBO,MXBO,1)
C
C  ORDER EIGENVECTORS BY OCCUPANCY (WITHIN EPS), FORM FINAL RYDBERG VECTORS:
C
      DO 570 I = 1,NAUG
        LARC(I) = I
  570 CONTINUE
      NAUG1 = NAUG - 1
      DO 620 I = 1,NAUG1
        I1 = I + 1
        DO 610 J = I1,NAUG
          DIFF = EVAL(J) - EVAL(I)
          IF(DIFF.LT.EPS) GO TO 610
          TEMP = EVAL(I)
          EVAL(I) = EVAL(J)
          EVAL(J) = TEMP
          ITEMP = LARC(I)
          LARC(I) = LARC(J)
          LARC(J) = ITEMP
  610   CONTINUE
  620 CONTINUE
      DO 700 J = 1,NAUG
        LJ = LARC(J)
        DO 680 I = 1,NORB
          SUM = ZERO
          DO 670 K = 1,NAUG
            SUM = SUM + TA(I,K) * C(K,LJ)
  670     CONTINUE
          BLK(I,J) = SUM
  680   CONTINUE
  700 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE REPOL(DM,Q,POL,BLK,EVAL,C,NBD)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL PRINT,FIRST
C
C  DIAGONALIZE DENSITY MATRIX IN BASIS OF ORTHONORMAL HYBRIDS FOR
C  EACH BOND ORBITAL TO FIND NEW POLARIZATION COEFFICIENTS.
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),ILL(MAXATM),
     +       IUL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION DM(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3),
     *        BLK(MXBO,MXBO),EVAL(MXBO),C(MXBO,MXBO)
C
      DATA ZERO,PT1,ONE,TWO/0.0D0,0.1D0,1.0D0,2.0D0/
      DATA LSTAR/1H*/
C
C  FIRST, COUNT NUMBER OF BONDS AND 3C BONDS:
C
      NBOND = 0
      N3CB  = 0
      DO 20 IB = 1,NBAS
        IF(LABEL(IB,2).EQ.LSTAR) GO TO 20
        IF(LABEL(IB,5).EQ.0) GO TO 20
        NBOND = NBOND + 1
        IF(LABEL(IB,6).EQ.0) GO TO 20
        N3CB = N3CB + 1
   20 CONTINUE
C
C  IAB+1 IS THE NUMBER OF THE FIRST ANTIBOND IN THE NBO LIST:
C
      IAB = NBAS - NBOND - N3CB
C
      PRINT = JPRINT(5).EQ.1
      FIRST = .TRUE.
      APCOEF = ONE / SQRT(TWO)
      DO 200 IB = 1,NBD
        IF(LABEL(IB,2).EQ.LSTAR) GO TO 200
        NCTR = 1
        IF(LABEL(IB,5).GT.0) NCTR = 2
        IF(LABEL(IB,6).GT.0) NCTR = 3
        IF(NCTR.EQ.1) GO TO 200
        IF(IWAPOL.EQ.0.OR.NCTR.EQ.3) THEN
          DO 120 I = 1,NCTR
            IA  = LABEL(IB,I+3)
            NHI = NORBS(IA)
            DO 115 J = 1,I
              JA  = LABEL(IB,J+3)
              NHJ = NORBS(JA)
              DIJ = ZERO
              DO 110 IR = 1,NHI
                IRP = ILL(IA)+IR-1
                CRI = Q(IR,ILL(IA)+IATHY(IB,I)-1)
                DO 105 JS = 1,NHJ
                  JSP = ILL(JA) + JS - 1
                  CSJ = Q(JS,ILL(JA)+IATHY(IB,J)-1)
                  DIJ = DIJ+CRI*CSJ*DM(IRP,JSP)
  105           CONTINUE
  110         CONTINUE
              BLK(I,J) = DIJ
              BLK(J,I) = DIJ
  115       CONTINUE
  120     CONTINUE
C
C  DIAGONALIZE 'BLK' AND EXTRACT NEW POLARIZATION COEFFICIENTS
C
          CALL JACOBI(NCTR,BLK,EVAL,C,MXBO,MXBO,0)
          CALL RANK(EVAL,NCTR,MXBO,LARC)
C
C  MAKE SURE REPOLARIZATION IS NOT TOO DRASTIC (TAKE A LOOK AT THE BOND
C  ORBITAL ONLY):
C
          S = ZERO
          DO 125 I = 1,NCTR
            S = S + POL(IB,I) * C(I,LARC(1))
  125     CONTINUE
          IF(S.LT.PT1.AND.NCTR.EQ.2) THEN
            IF(FIRST.AND.PRINT) WRITE(LFNPR,*)
            FIRST = .FALSE.
            IF(PRINT) WRITE(LFNPR,900) IB,S
            IAB = IAB + 1
            POL(IAB,1) =  POL(IB,2)
            POL(IAB,2) = -POL(IB,1)
          ELSE
C
C  STORE THE NEW POLARIZATION COEFFICIENTS IN POL:
C
            DO 130 I = 1,NCTR
              POL(IB,I) = C(I,LARC(1))
  130       CONTINUE
            IAB = IAB + 1
            DO 150 I = 1,NCTR
              POL(IAB,I) = C(I,LARC(2))
  150       CONTINUE
            IF(NCTR.NE.3) GO TO 200
            IAB = IAB + 1
            DO 160 I = 1,NCTR
              POL(IAB,I) = C(I,LARC(3))
  160       CONTINUE
          END IF
C
C  CONSTRAIN BONDS TO BE APOLAR, IF REQUESTED (NOT SET UP TO WORK WITH
C  3-CENTER BONDS):
C
        ELSE
          POL(IB,1) = APCOEF
          POL(IB,2) = APCOEF
          IAB = IAB + 1
          POL(IAB,1) = APCOEF
          POL(IAB,2) = -APCOEF
        END IF
  200 CONTINUE
      RETURN
C
  900 FORMAT(1X,'WARNING: significant repolarization of NBO ',I3,' (S=',
     + F7.4,'); REPOL disabled.')
      END
C*****************************************************************************
      SUBROUTINE FORMT(T,Q,POL)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER UL
C
C  CONSTRUCTION OF FINAL TRANSFORMATION  MATRIX T FROM ORTHONORMAL
C  HYBRIDS; ROWS OF T LABELLED BY NAOS, COLUMNS BY NBOS.
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOC(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),IBX(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       UL(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBNAO/NAOCTR(MAXBAS),NAOA(MAXBAS),LTYP(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DIMENSION T(NDIM,NDIM),Q(MXAO,NDIM),POL(NDIM,3)
C
      DATA LCR,LLP,LBD,LSTAR,LRY/'CR','LP','BD','*','RY'/
      DATA ZERO/0.0D0/
C
C  REORDER OCCUPIED NBOS TO PUT LONE AND CORE PAIRS LAST:
C
      NCR = 0
      NLP = 0
      NBDS = 0
      DO 10 NSCAN = 1,NBAS
        IF(LABEL(NSCAN,2).EQ.LSTAR) GO TO 10
        NBDS = NBDS + 1
        IF(LABEL(NSCAN,1).EQ.LLP) NLP = NLP + 1
        IF(LABEL(NSCAN,1).EQ.LCR) NCR = NCR + 1
   10 CONTINUE
      ICR = 0
      ILP = 0
      IBO = 0
      IAB = 0
      DO 40 IBD = 1,NBAS
        IF(LABEL(IBD,2).EQ.LSTAR) GO TO 30
        IF(LABEL(IBD,1).EQ.LCR) GO TO 15
        IF(LABEL(IBD,1).EQ.LLP) GO TO 20
C
C  PAIR BONDS:
C
        IBO = IBO + 1
        IBX(IBD) = IBO
        GO TO 40
C
C  CORE PAIRS:
C
   15   ICR = ICR + 1
        IBX(IBD) = ICR + NBDS - NCR - NLP
        GO TO 40
C
C  LONE PAIRS AND CORE PAIRS:
C
   20   ILP = ILP + 1
        IBX(IBD) = ILP + NBDS - NLP
        GO TO 40
C
C  ANTIBONDS:
C
   30   IAB = IAB + 1
        IBX(IBD) = NBDS + IAB
   40 CONTINUE
C
C  ZERO TRANSFORMATION ARRAY:
C
      DO 60 I = 1,NBAS
        DO 50 J = 1,NBAS
          T(I,J) = ZERO
   50   CONTINUE
   60 CONTINUE
C
C  DEPOSIT FINAL BOND ORBITALS IN MATRIX T:
C
      NBO = 0
      DO 130 IBD = 1,NBAS
        KBD = IBD
        IF(LABEL(IBD,2).NE.LSTAR) GO TO 100
        IF(LABEL(IBD,1).EQ.LRY) GO TO 100
        IF(LABEL(IBD,1).EQ.LLP) GO TO 100
C
C  ANTIBOND ORBITALS: SEARCH OCCUPIED ORB. LIST TO GET PROPER HYBRIDS.
C  SEARCH OCCUPIED BOND ORBS. FOR MATCH WITH ANTIBOND ATOMS:
C
        DO 90 K = 1,NBO
          DO 70 I = 4,6
            IF(LABEL(K,I).NE.LABEL(IBD,I)) GO TO 90
            IF((LABEL(K,3).LE.0).AND.(LABEL(K,1).EQ.LBD)) GO TO 90
   70     CONTINUE
C
C  NEGATIVE IRNK = LABEL(K,3) MEANS BOND ORBITAL WAS ALREADY USED:
C
C  FOUND MATCH; SET LABEL(K,3)<0:
C
          KBD = K
          LABEL(KBD,3) = -LABEL(KBD,3)
          GO TO 100
   90   CONTINUE
C
C  COULDN'T FIND MATCH...EXIT:
C
        WRITE(LFNPR,9000) IBD,(LABEL(IBD,JJ),JJ=1,6)
        STOP 
C
C  DEPOSIT BOND ORBITALS IN T MATRIX:
C
  100   CONTINUE
        DO 120 I = 1,3
          IA = LABEL(IBD,I+3)
          IF(IA.EQ.0) GO TO 120
          JL = LL(IA)
          JU = UL(IA)
          IROW = 0
          ICOL = JL + IATHY(KBD,I) - 1
          DO 110 J = JL,JU
            IROW = IROW + 1
            JB = IBX(IBD)
  110       T(J,JB) = POL(IBD,I) * Q(IROW,ICOL)
  120     CONTINUE
        IF(IBD.EQ.KBD) NBO = IBD
  130   CONTINUE
C
C  RESTORE LABEL(I,3) > 0:
C
      DO 140 I = 1,NBAS
        IF(LABEL(I,3).LT.0) LABEL(I,3) = -LABEL(I,3)
  140   CONTINUE
C
C  SET ARRAY IBXM: IBXM(IB) IS THE CURRENT LOCATION OF B.O. # IB:
C
      DO 150 IB = 1,NBAS
        I = IBX(IB)
  150   IBXM(I) = IB
C
C  SET PHASE OF 1-CENTER ORBITALS SUCH THAT THE LARGEST S-TYPE NAO CONTRIBUTION
C  IS POSITIVE:
C
      DO 200 IB = 1,NBAS
        NCTR = 1
        DO 160 IL = 5,6
          IF(LABEL(IBXM(IB),IL).NE.0) NCTR = NCTR + 1
  160   CONTINUE
        IF(NCTR.EQ.1) THEN
          JMAX = 0
          TMAX = -1.0D0
          DO 170 IN = 1,NBAS
            IF(NAOA(IN).LT.100) THEN
              IF(ABS(T(IN,IB)).GT.TMAX) THEN
                JMAX = IN
                TMAX = ABS(T(IN,IB))
              END IF
            END IF
  170     CONTINUE
          IF(JMAX.NE.0) THEN
            IF(T(JMAX,IB).LT.-1.0D-4) THEN
              DO 180 IN = 1,NBAS
                T(IN,IB) = -T(IN,IB)
  180         CONTINUE
            END IF
          END IF
        END IF
  200 CONTINUE
      RETURN
C
 9000 FORMAT(/,1X,'Can''t find bond/antibond match for NBO ',
     + I3,2X,A2,A1,'(',I2,')',3I4)
      END
C*****************************************************************************
      SUBROUTINE CYCLES(ITER,THRESH,GUIDE,BNDOCC,TOPO,ICONT)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBTHR/THRSET,PRJSET,ACCTHR,CRTSET,E2THR,ATHR,PTHR,ETHR,
     +             DTHR,DLTHR,CHSTHR
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBTOPO/IORDER(MAXATM),JORDER(MAXATM),NTOPO(MAXATM,MAXATM),
     +            N3CTR,I3CTR(10,3)
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION GUIDE(NATOMS,NATOMS),BNDOCC(NDIM),TOPO(NATOMS,NATOMS)
C
      SAVE JTER,DEVMIN,RHOMIN,BEST,RHO,JBADL
C
      DATA LCR,LBD,L3C,LLP,LSTAR/2HCR,2HBD,2H3C,2HLP,1H*/
      DATA SMALL,ZERO,TENTH,ONE,ONEPT5,THREE,HUNDRD
     +              /1.0D-4,0.0D0,0.1D0,1.0D0,1.5D0,3.0D0,1.0D2/
      DATA DEVTHR/0.1D0/
      DATA JTERMX/9/
C
C  Subroutine CYCLES controls the search for an acceptable resonance
C  structure:
C
C  Arguments:
C        ITER   : iteration counter incremented by the calling routine
C        THRESH : occupancy threshold used in search for NBOs
C        GUIDE  : Wiberg bond index
C        BNDOCC : array containing the NBO occupancies
C        TOPO   : bond index matrix to be compared with the Wiberg indices
C        ICONT  : control flag (see below)
C
C  ITER, GUIDE, and BNDOCC are unaltered by this routine
C  THRESH is modified by this routine, if the RESONANCE keyword is selected
C  The TOPO matrix is constructed by this routine
C
C  Control flag : (set by this routine)
C    ICONT =  2 : an acceptable Lewis structure has been found, continue
C          =  1 : an acceptable Lewis structure has been found, recompute the
C                 NBOs for this structure
C          =  0 : bogus Lewis structure, terminate search for NBOs
C          = -1 : occupancy threshold and/or atom ordering have been
C                 changed.  Repeat the search for NBOs.
C
C  Set atom permuting counter and minimum deviation in GUIDE-TOPO:
C
      IF(ITER.EQ.1) THEN
        JTER  =  0
        ICONT = -1
      END IF
      JTER = JTER + 1
      IF(JTER.EQ.1) DEVMIN = HUNDRD
C
C  The minimum occupancy threshold is 1.5e (0.5e for open shell):
C
      THRMIN = ONEPT5
      IF(ISPIN.NE.0) THRMIN = THRMIN - ONE
C
C  Determine the number of low occupancy orbitals in the Lewis structure:
C
      IBADL  = 0
      IBADNL = 0
      SUMLEW = ZERO
      TOTELE = ZERO
      DO 10 I = 1,NBAS
        TOTELE = TOTELE + BNDOCC(I)
        IF(LABEL(IBXM(I),2).NE.LSTAR) THEN
          SUMLEW = SUMLEW + BNDOCC(I)
          IF(BNDOCC(I).LT.THRESH) IBADL = IBADL + 1
        ELSE
          IF(BNDOCC(I).GT.ABS(ACCTHR)) IBADNL = IBADNL + 1
        END IF
   10 CONTINUE
      NEL    = TOTELE + TENTH
      TOTELE = NEL
      SUM    = TOTELE - SUMLEW
C
C  Count the ECP electrons in the Lewis structure:
C
      IF(IPSEUD.NE.0) THEN
        MECP = 0
        DO 20 IAT = 1,NATOMS
          MECP = MECP + IATNO(IAT) - IZNUC(IAT)
   20   CONTINUE
        IF(ISPIN.NE.0) MECP = MECP/2
        SUMLEW = SUMLEW + FLOAT(MECP)
      END IF
C
C  Keep track of the best Lewis structure found so far:
C
      IF(JTER.EQ.1) RHOMIN = HUNDRD
      IF(ITER.EQ.1.OR.SUM.LT.RHO) THEN
        BEST  = THRESH
        RHO   = SUM
        JBADL = IBADL
        DO 25 I = 1,NATOMS
          JORDER(I) = IORDER(I)
   25   CONTINUE
      END IF
C
C  Count the number of core, lone pair, and bonding orbitals in this
C  resonance structure:
C
      MCR = 0
      MBD = 0
      M3C = 0
      MLP = 0
      DO 30 I = 1,NBAS
        IF(LABEL(I,1).EQ.LCR.AND.LABEL(I,2).NE.LSTAR) MCR = MCR + 1
        IF(LABEL(I,1).EQ.LBD.AND.LABEL(I,2).NE.LSTAR) MBD = MBD + 1
        IF(LABEL(I,1).EQ.L3C.AND.LABEL(I,2).NE.LSTAR) M3C = M3C + 1
        IF(LABEL(I,1).EQ.LLP.AND.LABEL(I,2).NE.LSTAR) MLP = MLP + 1
   30 CONTINUE
C
C  Build the TOPO matrix from lone pairs and 2- and 3-center bonds:
C
      DO 50 I = 1,NATOMS
        DO 40 J = 1,NATOMS
          TOPO(I,J) = ZERO
   40   CONTINUE
   50 CONTINUE
C
      DO 60 I = 1,NBAS
        IB   = IBXM(I)
        IF(LABEL(IB,1).NE.LCR.AND.LABEL(IB,2).NE.LSTAR) THEN
          IAT1 = LABEL(IB,4)
          NCTR = 1
          IAT2 = LABEL(IB,5)
          IF(IAT2.NE.0) NCTR = 2
          IAT3 = LABEL(IB,6)
          IF(IAT3.NE.0) NCTR = 3
          IF(NCTR.EQ.1) THEN
            TOPO(IAT1,IAT1) = TOPO(IAT1,IAT1) + ONE
          ELSE IF(NCTR.EQ.2) THEN
            TOPO(IAT1,IAT2) = TOPO(IAT1,IAT2) + ONE
            TOPO(IAT2,IAT1) = TOPO(IAT2,IAT1) + ONE
          ELSE
            TOPO(IAT1,IAT2) = TOPO(IAT1,IAT2) + ONE/THREE
            TOPO(IAT2,IAT1) = TOPO(IAT2,IAT1) + ONE/THREE
            TOPO(IAT1,IAT3) = TOPO(IAT1,IAT3) + ONE/THREE
            TOPO(IAT3,IAT1) = TOPO(IAT3,IAT1) + ONE/THREE
            TOPO(IAT2,IAT3) = TOPO(IAT2,IAT3) + ONE/THREE
            TOPO(IAT3,IAT2) = TOPO(IAT3,IAT2) + ONE/THREE
          END IF
        END IF
   60 CONTINUE
C
C  Determine the largest off-diagonal element of GUIDE-TOPO:
C
      DEV = ZERO
      DO 80 J = 2,NATOMS
        DO 70 I = 1,J-1
          IF(GUIDE(I,J)-TOPO(I,J).GT.DEV) THEN
            DEV = GUIDE(I,J) - TOPO(I,J)
            IAT = I
            JAT = J
          END IF
   70   CONTINUE
   80 CONTINUE
C
C  Write info about this resonance structure:
C
      IF(JPRINT(5).EQ.1) THEN
        IF(ITER.EQ.1) WRITE(LFNPR,1000)
        WRITE(LFNPR,1010) ITER,JTER,ABS(THRESH),SUMLEW,SUM,MCR,MBD,
     +                    M3C,MLP,IBADL,IBADNL,DEV
      END IF
C
C  Decide if this structure is acceptable:
C
C   *  Accept the structure if CHOOSE was employed.
C   *  Accept the structure if there is only one atom.
C   *  Accept the structure if there are no low occupancy Lewis orbitals
C      and DEV is less than DEVTHR.
C   *  Accept the structure if the NOBOND option was selected.
C
C  Good resonance structure:
C
      IF(IBADL.EQ.0.AND.DEV.LT.DEVTHR) THEN
        IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
        IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030)
        ICONT = 2
        RETURN
C
C  Only one atom:
C
      ELSE IF(NATOMS.EQ.1) THEN
        IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
        IF(JPRINT(5).EQ.1) WRITE(LFNPR,1035)
        ICONT = 2
        RETURN
C
C  Directed NBO search:
C
      ELSE IF(ICHOOS.EQ.1) THEN
        IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
        IF(JPRINT(5).EQ.1) WRITE(LFNPR,1040)
        ICONT = 2
        RETURN
C
C  NOBOND option selected:
C
      ELSE IF(JPRINT(10).NE.0) THEN
        IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
        IF(JPRINT(5).EQ.1) WRITE(LFNPR,1050)
        ICONT = 2
        RETURN
      END IF
C
C  Structure accepted due to the specification of the RESONANCE keyword
C  or the occupancy threshold.  Otherwise, accept the structure only if
C  there are no high occupancy Lewis orbitals:
C
      IF(ICONT.EQ.1) THEN
        IF(THRSET.GE.ZERO) THEN
          IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
          IF(JPRINT(5).EQ.1) WRITE(LFNPR,1060)
          ICONT = 2
        ELSE IF(JPRINT(14).NE.0) THEN
          IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
          IF(JPRINT(5).EQ.1) WRITE(LFNPR,1070)
          ICONT = 2
        ELSE IF(IBADL.NE.0) THEN
          IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
          IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030)
          ICONT = 2
        END IF
        RETURN
      END IF
C
C  If DEV.EQ.DEVMIN.AND.SUM.EQ.RHOMIN or too many atoms permutations,
C  stop atom permutations:
C
      IF((ABS(DEV-DEVMIN).LT.SMALL.AND.ABS(SUM-RHOMIN).LT.SMALL).OR.
     +                                 JTER.GE.JTERMX) THEN
C
C  If the occupancy threshold was set by the user, accept the best
C  structure:
C
        IF(THRSET.GE.ZERO) THEN
          IF(ABS(SUM-RHO).LT.SMALL) THEN
            IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
            IF(JPRINT(5).EQ.1) WRITE(LFNPR,1060)
            ICONT = 2
          ELSE
            DO 90 I = 1,NATOMS
              IORDER(I) = JORDER(I)
   90       CONTINUE
            JTER  = 0
            ICONT = 1
          END IF
C
C  If the RESONANCE keyword was specified, pick the best resonance structure
C  for this occupancy threshold, and possibly decrement the threshold and
C  continue the search:
C
        ELSE IF(JPRINT(14).NE.0) THEN
          THRESH = THRESH - TENTH
          IF(THRMIN-THRESH.GT.SMALL) THEN
            THRESH = THRESH + TENTH
            IF(ABS(THRESH-BEST).LT.SMALL.AND.ABS(SUM-RHO).LT.SMALL) THEN
              IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
              IF(JPRINT(5).EQ.1) WRITE(LFNPR,1070)
              ICONT = 2
            ELSE
              DO 100 I = 1,NATOMS
                IORDER(I) = JORDER(I)
  100         CONTINUE
              THRESH = BEST
              JTER  = 0
              ICONT = 1
            END IF
          ELSE
            DO 110 I = 1,NATOMS
              IORDER(I) = JORDER(I)
  110       CONTINUE
            JTER  =  0
            ICONT = -1
          END IF
C
C  Otherwise, accept the best structure, but only if it had no Lewis
C  orbitals with occupancy less than the occupancy threshold:
C
        ELSE
          IF(ABS(SUM-RHO).LT.SMALL.AND.IBADL.EQ.0) THEN
            IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
            IF(JPRINT(5).EQ.1) WRITE(LFNPR,1030)
            ICONT = 2
          ELSE IF(JBADL.EQ.0) THEN
            DO 115 I = 1,NATOMS
              IORDER(I) = JORDER(I)
  115       CONTINUE
            JTER  = 0
            ICONT = 1
          ELSE
            IF(JPRINT(5).EQ.1) WRITE(LFNPR,1020)
            IF(JPRINT(5).EQ.1) WRITE(LFNPR,1080)
            ICONT = 0
          END IF
        END IF
        RETURN
C
C  Loop through atom ordering to find alternative resonance structures:
C
      ELSE
        IF(DEV.LT.DEVMIN) DEVMIN = DEV
        IF(SUM.LT.RHOMIN) RHOMIN = SUM
        IF(IAT.EQ.IORDER(1).AND.JAT.EQ.IORDER(2)) THEN
          DEV1 = ZERO
          DO 130 J = 2,NATOMS
            DO 120 I = 1,J-1
              IF(GUIDE(I,J)-TOPO(I,J).GT.DEV1) THEN
                IF((I.NE.IORDER(1).AND.J.NE.IORDER(2)).AND.
     +             (J.NE.IORDER(1).AND.I.NE.IORDER(2))) THEN
                  DEV1 = GUIDE(I,J) - TOPO(I,J)
                  IAT  = I
                  JAT  = J
                END IF
              END IF
  120       CONTINUE
  130     CONTINUE
        END IF
C
        JFLG = 0
        DO 140 I = NATOMS,2,-1
          IF(IORDER(I).EQ.JAT) JFLG = 1
          IF(JFLG.EQ.1) IORDER(I) = IORDER(I-1)
  140   CONTINUE
        IORDER(1) = JAT
        IFLG = 0
        DO 150 I = NATOMS,2,-1
          IF(IORDER(I).EQ.IAT) IFLG = 1
          IF(IFLG.EQ.1) IORDER(I) = IORDER(I-1)
  150   CONTINUE
        IORDER(1) = IAT
        ICONT = -1
      END IF
      RETURN
C
 1000 FORMAT(/1X,'                      Occupancies       Lewis ',
     + 'Structure    Low   High',/1X,'          Occ.    --------',
     + '-----------  -----------------   occ   occ',/1X,' Cycle ',
     + '  Thresh.   Lewis   Non-Lewis     CR  BD  3C  LP    (L) ',
     + '  (NL)   Dev',/1X,77('='))
 1010 FORMAT(1X,I3,'(',I1,')',3X,F5.2,F12.5,F10.5,3X,4I4,2X,I4,3X,I4,
     + 3X,F5.2)
 1020 FORMAT(1X,77('-'))
 1030 FORMAT(/1X,'Structure accepted: No low occupancy Lewis orbitals')
 1035 FORMAT(/1X,'Structure accepted: Only a single atom')
 1040 FORMAT(/1X,'Structure accepted: NBOs selected via the $CHOOSE ',
     + 'keylist')
 1050 FORMAT(/1X,'Structure accepted: Search for bonds prevented ',
     + 'by NOBOND keyword')
 1060 FORMAT(/1X,'Structure accepted: Occupancy threshold (THRESH) ',
     + 'set by user')
 1070 FORMAT(/1X,'Structure accepted: RESONANCE keyword permits ',
     + 'strongly delocalized structure')
 1080 FORMAT(/1X,'Only strongly delocalized resonance structures can',
     + ' be found.',/1X,'The default procedure is to abort the NBO ',
     + 'search.  Include',/1X,'the RESONANCE keyword in the $NBO ',
     + 'keylist to override this test.')
      END
C*****************************************************************************
C
C  ROUTINES CALLED BY SR NLMO:
C
C      SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT,
C     +           NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
C      SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL)
C
C*****************************************************************************
      SUBROUTINE SYMUNI(TSYM,A,COS,SIN,OVLP,BLK,EVAL,NROT,
     *           NIUNIQ,NJUNIQ,ILIST,JLIST,NOFF,IOFF,JOFF,NDIM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DIMENSION TSYM(NROT,NROT),A(NDIM,NDIM),BLK(NROT,NROT),
     *  OVLP(NROT,NROT),EVAL(NROT)
      DIMENSION IOFF(NOFF),JOFF(NOFF),ILIST(NOFF),JLIST(NOFF)
      DATA ZERO,ONE/0.0D0,1.0D0/
      DATA EPS/1.0D-6/
      DO 40 I=1,NROT
        DO 30 J=1,NROT
   30     TSYM(I,J)=ZERO
   40     TSYM(I,I)=ONE
      DO 60 MOFF=1,NOFF
        IOCC=ILIST(MOFF)
        JEMT=JLIST(MOFF)
        DO 60 I=1,NROT
          T=TSYM(I,IOCC)
          U=TSYM(I,JEMT)
          TSYM(I,IOCC)=COS*T-SIN*U
   60     TSYM(I,JEMT)=SIN*T+COS*U
C
C   AVERAGE GROUPS OF THE ELEMENTS OF THE TRANSFORMATION MATRIX TSYM
C    SO THAT THE SYMMETRY INHERENT IN THE DENSITY MATRIX A IS PRESERVED,
C    MAKING SURE THAT THE RESULTING "AVERAGED" TRANSFORMATION IS UNITARY
C
C
      JST=NIUNIQ+1
      NROT=JST-1+NJUNIQ
C
C   AVE. DIAG. ELEM OF OCC ORBS
      IF(NIUNIQ.EQ.1) GO TO 140
      TOT=ZERO
      DO 100 I=1,NIUNIQ
  100   TOT=TOT+TSYM(I,I)
      AVE=TOT/NIUNIQ
      DO 110 I=1,NIUNIQ
  110   TSYM(I,I)=AVE
C
C   AVE. DIAG. ELEM OF EMPTY ORBS
  140 IF(NJUNIQ.EQ.1) GO TO 180
      TOT=ZERO
      DO 150 J=JST,NROT
  150   TOT=TOT+TSYM(J,J)
      AVE=TOT/NJUNIQ
      DO 160 J=JST,NROT
  160   TSYM(J,J)=AVE
C
C  ZERO OFFDIAG ELEM BETW OCC ORBS:
  180 IF(NIUNIQ.EQ.1) GO TO 240
      DO 220 I=2,NIUNIQ
        DO 220 J=1,I
          IF(I.EQ.J) GO TO 220
          TSYM(I,J)=ZERO
          TSYM(J,I)=ZERO
  220     CONTINUE
C
C  ZERO OFFDIAG ELEM BETW EMPTY ORBS:
  240 IF(NJUNIQ.EQ.1) GO TO 280
      JST2=JST+1
      DO 270 I=JST2,NROT
        DO 270 J=JST,I
          IF(I.EQ.J) GO TO 270
          TSYM(I,J)=ZERO
          TSYM(J,I)=ZERO
  270     CONTINUE
C
C  AVE. OFFDIAG ELEM BETW OCC AND EMPTY ORBS (PIVOTED ELEMENTS ONLY):
  280 CONTINUE
      TOT=ZERO
      DO 310 MOFF=1,NOFF
        II=ILIST(MOFF)
        JJ=JLIST(MOFF)
  310   TOT=TOT+ABS(TSYM(II,JJ))+ABS(TSYM(JJ,II))
      NOFF2=NOFF*2
      AVE=TOT/NOFF2
      DO 330 MOFF=1,NOFF
        II=ILIST(MOFF)
        JJ=JLIST(MOFF)
        TSYM(II,JJ)=-AVE
  330   TSYM(JJ,II)= AVE
C
C  NOW ZERO THE NON-PIVOTED ELEMENTS:
      DO 450 I=1,NIUNIQ
        DO 440 J=JST,NROT
          DO 420 MOFF=1,NOFF
            IF(I.EQ.ILIST(MOFF).AND.J.EQ.JLIST(MOFF)) GO TO 440
  420       CONTINUE
          TSYM(I,J)= ZERO
          TSYM(J,I)= ZERO
  440     CONTINUE
  450   CONTINUE
C
C  RENORMALIZE VECTORS:
      DO 700 J=1,NROT
        TOT=ZERO
        DO 650 I=1,NROT
  650     TOT=TOT+TSYM(I,J)*TSYM(I,J)
        RNORM=SQRT(TOT)
        IF(RNORM.GT.EPS) GO TO 680
          WRITE(LFNPR,2880) NROT,TOT,EPS,RNORM
 2880     FORMAT('NROT,TOT,EPS,RNORM:',I3,3F14.9)
          CALL ALTOUT(TSYM,NROT,NROT,NROT,NROT)
          STOP
  680   CONTINUE
        DO 690 I=1,NROT
  690     TSYM(I,J)=TSYM(I,J)/RNORM
  700   CONTINUE
C
C  NOW, MAKE SURE THE SIGNS ARE CORRECT:
      DO 800 MOFF=1,NOFF
        I=IOFF(MOFF)
        J=JOFF(MOFF)
        IF(A(I,J).GT.ZERO) GO TO 800
          II=ILIST(MOFF)
          JJ=JLIST(MOFF)
          TSYM(II,JJ)=-TSYM(II,JJ)
          TSYM(JJ,II)=-TSYM(JJ,II)
  800   CONTINUE
C
C  FINALLY, THE CRUCIAL STEP OF SYMMETRICALLY ORTHOGONALIZING THE VECTORS
C   SO THAT THE TRANSFORMATION IS UNITARY:
      CALL SYMORT(OVLP,TSYM,BLK,NROT,NROT,EVAL)
      RETURN
C
      END
C*****************************************************************************
      SUBROUTINE SYMORT(S,T,BLK,NDIM,N,EVAL)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C******************************************************************
C
C   SYMORT: SYMMETRIC ORTHOGONALIZATION SUBROUTINE
C
C   S:           FULL OVERLAP MATRIX               (DESTROYED!)
C   T:           VECTORS TO BE ORTHOGED.
C   N:           NUMBER OF VECTORS
C
C   NOTE:    BLK AND BIGBLK SHARE THE SAME STORAGE BUT ARE
C               DIMENSIONED DIFFERENTLY.
C            THE SAME APPLIES FOR S AND SBLK.
C
C******************************************************************
      DIMENSION S(N,N),T(NDIM,NDIM),BLK(N,N),EVAL(N)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DATA ZERO,ONE/0.0D0,1.0D0/
C
C  IMPORTANT CONSTANTS:
C           DIAGTH          THRESHOLD FOR MATRIX DIAGONALIZATION USED IN
C                            SUBROUTINE JACOBI.  IN JACOBI, THIS CONSTANT
C                            IS CALLED "DONETH".
C           DANGER          CRITERION FOR DECIDING THAT THE JOB SHOULD BE
C                            ABORTED DUE TO NUMERICAL PROBLEMS CAUSED BY NEAR
C                            LINEAR DEPENDENCIES IN THE BASIS SET.  ALL
C                            EIGENVALUES OF THE WEIGHTED OVERLAP MATRIX MUST
C                            BE GREATER THAN DIAGTH*DANGER.
C
      DATA DIAGTH,DANGER/1.0D-12,1.0D3/
C
C  FORM THE INVERSE SQRT OF THE OVERLAP MATRIX OF THE VECTORS:
      DO 70 I=1,N
        DO 70 J=1,N
          SIJ=ZERO
          DO 40 K=1,N
   40       SIJ=SIJ+T(K,I)*T(K,J)
   70     S(I,J)=SIJ
      CALL JACOBI(N,S,EVAL,BLK,N,N,0)
      SMLEST=ONE
      TOOSML=DIAGTH*DANGER
      DO 150 I=1,N
        EIGENV=EVAL(I)
        IF(EIGENV.LT.TOOSML) GO TO 900
        EVAL(I)=ONE/SQRT(EIGENV)
        IF(EIGENV.LT.SMLEST) SMLEST=EIGENV
  150  CONTINUE
      DO 170 I=1,N
        DO 170 J=1,I
          SIJ=ZERO
          DO 160 K=1,N
  160       SIJ=SIJ+EVAL(K)*BLK(I,K)*BLK(J,K)
          S(I,J)=SIJ
  170     S(J,I)=SIJ
C
C  S NOW CONTAINS THE -0.5 POWER OF THE OVERLAP MATRIX,
C   AND IS THE ORTHOG. TRANSFORM THAT WE WANT.
C   NOW, FORM THE TOTAL TRANSFORMATION:
      DO 210 I=1,N
        DO 200 J=1,N
          EVAL(J)=ZERO
          DO 200 K=1,N
  200       EVAL(J)=EVAL(J)+T(I,K)*S(K,J)
      DO 210 J=1,N
  210   T(I,J)=EVAL(J)
      RETURN
C
  900 WRITE(LFNPR,910) EIGENV,TOOSML
  910 FORMAT(/1X,'An eigenvalue of the overlap matrix of the ',
     *   'symmetrized Jacobi transf. ',
     *   'matrix of ',E13.5,' has been found.'/1X,
     *   'This is lower than the allowed threshold of ',E13.5)
      STOP
      END
C*****************************************************************************
C
C  NBO ENERGETIC ANALYSIS ROUTINES:
C
C      SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE)
C      SUBROUTINE NBODEL(A,MEMORY,IDONE)
C      SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE,
C     +                  ISPIN)
C      SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN)
C      SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK)
C      SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL)
C
C*****************************************************************************
      SUBROUTINE NBOEAN(A,MEMORY,NBOOPT,IDONE)
C*****************************************************************************
C
C     NBOEAN: CONTROLLER SUBROUTINE TO DO NBO ENERGETIC ANALYSIS
C               BY FOCK MATRIX DELETION METHOD
C
C       A(MEMORY) IS SCRATCH STORAGE
C
C       NBOOPT(1) = 2       READ IN NEXT DELETION AND FORM NEW DM
C                 = 3       COMPUTE ENERGY CHANGE FOR THIS DELETION
C
C       SET IDONE TO 1 IF NO DELETIONS ARE FOUND:
C
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ERROR,NEW,SEQ
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION A(MEMORY),NBOOPT(10)
C
      DATA THRNEG/-1.0D-3/
      DATA ONE,AUKCAL,EVKCAL/1.0D0,627.51,23.061/
C
C  OPEN THE OLD NBO DAF:
C
      NEW = .FALSE.
      CALL NBOPEN(NEW,ERROR)
      IF(ERROR) THEN
        IDONE = 1
        RETURN
      END IF
      CALL FEINFO(A,ISWEAN)
C
C  IF NBOOPT(1) = 3,  COMPUTE THE ENERGY OF DELETION:
C
      IF(NBOOPT(1).EQ.3) THEN
        CALL FEE0(EDEL,ETOT)
        ECHANG = EDEL - ETOT
        IF(MUNIT.EQ.0) THEN
          CONV = AUKCAL
        ELSE IF(MUNIT.EQ.1) THEN
          CONV = EVKCAL
        ELSE
          CONV = ONE
        END IF
        EKCAL = ECHANG * CONV
        IF(EKCAL.LT.THRNEG) WRITE(LFNPR,2130)
        IF(MUNIT.EQ.0) THEN
          WRITE(LFNPR,2100) EDEL,ETOT,ECHANG,EKCAL
        ELSE IF(MUNIT.EQ.1) THEN
          WRITE(LFNPR,2110) EDEL,ETOT,ECHANG,EKCAL
        ELSE
          WRITE(LFNPR,2120) EDEL,ETOT,ECHANG,EKCAL
        END IF
        IDONE = 0
        SEQ = .FALSE.
        CALL NBCLOS(SEQ)
        RETURN
      END IF
C
C  PERFORM THE NBO ENERGETIC ANALYSIS:
C
C  IF ISWEAN IS SET TO 1, SEARCH FOR THE $DEL KEYLIST:
C
      IF(ISWEAN.EQ.1) THEN
        CALL DELINP(NBOOPT,IDONE)
        IF(IDONE.EQ.1) GOTO 900
      ELSE IF(NBOOPT(10).GT.80) THEN
        CALL STRTIN(LFNIN)
      END IF
C
C  ROHF, MCSCF, CI, AND AUHF WAVE FUNCTIONS ARE NOT ACCEPTABLE:
C
      IF(ROHF.OR.MCSCF.OR.CI.OR.AUHF) THEN
        IDONE = 1
        GOTO 900
      END IF
C
      ISPIN = 0
      IF(UHF) ISPIN = 2
      ALPHA = .FALSE.
      BETA  = .FALSE.
      IF(UHF) ALPHA = .TRUE.
      CALL NBODEL(A,MEMORY,IDONE)
      IF(IDONE.EQ.1) GOTO 900
C
      IF(UHF) THEN
        ISPIN = -2
        ALPHA = .FALSE.
        BETA  = .TRUE.
        CALL NBODEL(A,MEMORY,IDONE)
      END IF
C
      WRITE(LFNPR,3000)
      SEQ = .FALSE.
      CALL NBCLOS(SEQ)
      RETURN
C
  900 CONTINUE
      SEQ = .FALSE.
      CALL NBCLOS(SEQ)
      RETURN
C
 2100 FORMAT(1X,78('-'),/,3X,
     +'Energy of deletion : ',F20.9,/,3X,
     +'  Total SCF energy : ',F20.9,/,3X,
     +'                       -------------------',/,3X,
     +'     Energy change : ',F17.6,' a.u.,   ',F13.3,' kcal/mol'/
     +1X,78('-'))
 2110 FORMAT(1X,78('-'),/,3X,
     +'Energy of deletion : ',F20.9,/,3X,
     +'  Total SCF energy : ',F20.9,/,3X,
     +'                       -------------------',/,3X,
     +'     Energy change : ',F17.6,' e.V.,   ',F13.3,' kcal/mol'/
     +1X,78('-'))
 2120 FORMAT(1X,78('-'),/,3X,
     +'Energy of deletion : ',F13.3,/,3X,
     +'  Total SCF energy : ',F13.3,/,3X,
     +'                       -------------------',/,3X,
     +'     Energy change : ',F13.3,' kcal/mol,   ',F13.3,' kcal/mol'/
     +1X,78('-'))
 2130 FORMAT(/,6X,
     +'***** WARNING *****  The variational principle has been',/,5X,
     +'  violated and the above deletion energy is invalid!!',//,5X,
     +'Probable cause:  A deletion was attempted that did not ',/,5X,
     +'have as high symmetry as was employed in the integral',/,5X,
     +'and SCF computation.  REMEDY:  Redo computation without',/,5X,
     +'symmetry if this non-symmetry-conserving deletion is still',/,5X,
     +'desired.')
 3000 FORMAT(/1X,
     +'NEXT STEP:  Evaluate the energy of the new density matrix',/,1X,
     +'            that has been constructed from the deleted NBO',/,1X,
     +'            Fock matrix by doing one SCF cycle.'/)
      END
C*****************************************************************************
      SUBROUTINE NBODEL(A,MEMORY,IDONE)
C*****************************************************************************
C
C     NBODEL: SUBROUTINE TO DELETE BOND ORBITAL FOCK MATRIX ELEMENTS FOR
C              A PARTICULAR SPIN CASE:
C                ISPIN = 0     CLOSED SHELL
C                        2     ALPHA SPIN
C                       -2     BETA  SPIN
C
C     IDONE IS SET EQUAL TO 1 IF THERE ARE NO MORE DELETIONS,
C                           0 OTHERWISE.
C
C     A(MEMORY) IS SCRATCH STORAGE 
C
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL DONE
      DIMENSION A(MEMORY),ICH(3,2),INAM(3),ISP(3)
C
C  NBO Common Blocks:
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DATA LBD/2HBD/,L3C/2H3C/,LBLNK2/2H  /,LBLNK1/1H /,LHYP/1H-/
C
C   FNBO  :  NBO FOCK MATRIX (TRIANGULAR)
C   TRF   :  TRUNCATED FOCK MATRIX (SQUARE)
C   EIGVR :  EIGENVECTORS OF FTRUNC
C   DMNEW :  NEW AO DM (FROM TRUNCATION) -- TRIANGULAR
C   OCC   :  OCCUPATION VECTOR OF BOND ORBITALS
C   OCCNEW:  OCCUPATION VECTOR OF BOND ORBITALS, AFTER DELETION
C   TNBO  :  AO TO NBO TRANSFORMATION MATRIX
C   SCR   :  SCRATCH VECTOR
C
C  SET UP STORAGE SPACE:
C
C   A(N1):  OCC
C   A(N2):  OCCNEW
C   A(N3):  TNBO
C   A(N4):  FNBO, EIGVR
C   A(N5):  SCR, TRF, DMNEW
C   A(N6):  SCR
C   A(N7):  IDEL
C
      NSQ  = NDIM*NDIM
      N1   = 1
      N2   = N1 + NDIM
      N3   = N2 + NDIM
      N4   = N3 + NSQ
      N5   = N4 + NSQ
      N6   = N5 + NSQ
      N7   = N6 + NDIM
      NEND = N7 + NSQ
      IF(NEND.GT.MEMORY) GO TO 950
      CALL FENBO(A(N3),A(N1),A(N5),NELEC)
      CALL FEFNBO(A(N4))
C
C  DELETE REQUESTED FOCK MATRIX ELEMENTS, FORMING TRUNCATED FOCK MATRIX
C             IN TRF
C
C   IDEL  :  LIST OF DELETED ORBITALS, ELEMENTS, OR BLOCKS
C   ITYPE :  TYPE OF DELETION: 1 FOR ORBITALS
C                              2 FOR INDIVIDUAL MATRIX ELEMENTS
C			       3 FOR ZEROING INTERSECTION BETWEEN TWO SETS
C			                                 OF ORBITALS
C                              4 FOR ENTIRE MATRIX BLOCKS
C   NDEL  :  NUMBER OF ORBITALS, ELEMENTS OR BLOCKS TO BE DELETED
C
      CALL DELETE(A(N4),A(N5),NDIM,A(N7),NSQ,ITYPE,NDEL,NTRUNC,DONE,
     +            ISPIN)
C
C  IF NO MORE DELETIONS, EXIT PROGRAM
C
      IF(DONE) GO TO 900
C  DIAGONALIZE TRUNCATED FOCK MATRIX IN TRF
C
      CALL JACOBI(NTRUNC,A(N5),A(N2),A(N4),NDIM,NDIM,0)
C
C  CONSTRUCT NEW DENSITY MATRIX IN DM FROM EIGENVECTORS OF TRF,
C   IN NBO BASIS:
C   A(N2):  EIGENVALUES OF TRF        (ENTERING)
C   A(N2):  NEW NBO ORBITAL OCCUPANCIES  (EXITING)
C
      NMOOCC=NELEC
      IF(ISPIN.EQ.0) NMOOCC=NELEC/2
      CALL NEWDM(A(N5),A(N4),A(N2),NDIM,A(N7),NSQ,NDEL,ITYPE,NMOOCC,
     +           ISPIN)
C
C  TAKE TRANSPOSE OF T SO THAT IT CAN TRANSFORM THE DENSITY MATRIX
C    FROM THE NBO BASIS TO THE UNSYMMETRIZED AO BASIS:
C
      CALL TRANSP(A(N3),NDIM,NDIM)
      CALL SIMLTR(NDIM,NDIM,A(N5),A(N3),A(N4),A(N6),1)
      CALL SVNEWD(A(N5))
C
      WRITE(LFNPR,2200)
      WRITE(LFNPR,2700)
      DO 500 IBAS=1,NDIM
            IB=IBXM(IBAS)
            LBL=LABEL(IB,1)
            NCTR=1
            IF(LBL.EQ.LBD) NCTR=2
            IF(LBL.EQ.L3C) NCTR=3
            DO 350 I=1,3
              IAT=LABEL(IB,I+3)
              CALL CONVRT(IAT,ICH(I,1),ICH(I,2))
              INAM(I)=LBLNK2
              IF(IAT.GT.0) INAM(I)=NAMEAT(IATNO(IAT))
              ISP(I)=LHYP
              IF(I.GE.NCTR) ISP(I)=LBLNK1
  350         CONTINUE
        I=N1-1+IBAS
        II=N2-1+IBAS
        OCCCHG=A(II)-A(I)
        WRITE(LFNPR,2800) IBAS,(LABEL(IB,K),K=1,3),
     *         (INAM(K),ICH(K,1),ICH(K,2),ISP(K),K=1,3),
     *         A(I),A(II),OCCCHG
  500   CONTINUE
      IDONE=0
      RETURN
C
  900 CONTINUE
      IDONE=1
      RETURN
C
  950 CONTINUE
      WRITE(LFNPR,9500) NEND,MEMORY
      IDONE=1
      RETURN
C
 2200 FORMAT(/1X,'Occupations of bond orbitals:')
 2700 FORMAT(/7X,'Orbital',19X,'No deletions   This deletion   Change',
     + /,1X,78('-'))
 2800 FORMAT(1X,I3,'. ',A2,A1,'(',I2,')',3(A2,3A1),
     *       9X,F7.5,8X,F7.5,3X,F8.5)
 9500 FORMAT(/1X,'Insufficient memory in subroutine NBODEL:',
     *      /5X,'Memory needed: ',I10,'   Memory available: ',I10,
     *      /1X,'Deletions halted!')
      END
C*****************************************************************************
      SUBROUTINE DELETE(F,TRF,NDIM,IDEL,LEN,ITYPE,NDEL,NTRUNC,DONE,
     +                  ISPIN)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ERROR,DONE,EQUAL
      LOGICAL DONOR,ACCPTR,LIST1,LIST2
      DIMENSION KEYWD(6),F(1),TRF(NDIM,NDIM),IDEL(LEN)
      DIMENSION LORB(3),LELE(3),LBLO(3),LDEL(3),LZERO(4),LSAME(4),
     *          LEND(3),LDESTR(6),LDELOC(5),LNOSTR(6),LATOM(4),
     *          LNOGEM(5),LNOVIC(5),LALT(4)
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      DATA ZERO/0.0D0/,ISTAR/1H*/
      DATA LDEL/1HD,1HE,1HL/,LZERO/1HZ,1HE,1HR,1HO/,LEND/1HE,1HN,1HD/
      DATA LALPHA,LBETA/1HA,1HB/,LSAME/1HS,1HA,1HM,1HE/
      DATA LORB,LELE,LBLO/1HO,1HR,1HB,1HE,1HL,1HE,1HB,1HL,1HO/
      DATA LDESTR/1HD,1HE,1HS,1HT,1HA,1HR/
      DATA LNOSTR/1HN,1HO,1HS,1HT,1HA,1HR/
      DATA LDELOC/1HD,1HE,1HL,1HO,1HC/,LATOM/1HA,1HT,1HO,1HM/
      DATA LNOVIC/1HN,1HO,1HV,1HI,1HC/,LNOGEM/1HN,1HO,1HG,1HE,1HM/
      DATA LALT/1H$,1HE,1HN,1HD/
      DATA LG,LV/'g','v'/
C
C   THIS SUBROUTINE IS CALLED AT THE START OF EACH DELETION AND READS
C    IN FROM LFNIN THE INSTRUCTIONS FOR THIS DELETION
C
C   NTRUNC= DIMENSION OF FOCK MATRIX AFTER DELETIONS:
      NTRUNC=NDIM
      WRITE(LFNPR,8700)
C  COUNT UP NUMBER OF MOLECULAR UNITS, NCHEMU:
      NCHEMU=0
      DO 1 I=1,NDIM
        NUNIT=NBOUNI(I)
        IF(NUNIT.GT.NCHEMU) NCHEMU=NUNIT
    1   CONTINUE
      IF(ISPIN.EQ.0) GO TO 10
C  IF OPEN SHELL, LOOK FOR FIRST LETTER OF "ALPHA" OR "BETA" KEYWORD:
        LENG=3
        CALL HFLD(KEYWD,LENG,DONE)
        IF(EQUAL(KEYWD,LEND,3)) DONE=.TRUE.
        IF(EQUAL(KEYWD,LALT,3)) DONE=.TRUE.
        IF(DONE) RETURN
        IF((ISPIN.EQ.2).AND.(KEYWD(1).NE.LALPHA)) GO TO 9300
        IF((ISPIN.EQ.-2).AND.(KEYWD(1).NE.LBETA)) GO TO 9400
        IF(ISPIN.EQ.2) WRITE(LFNPR,8100)
        IF(ISPIN.EQ.-2) WRITE(LFNPR,8200)
C  SEARCH FOR FIRST 3 LETTERS OF "DELETE", "ZERO", "SAME", "DESTAR",
C    "NOSTAR", "NOGEM", "NOVIC", OR AN END MARK '**':
   10 CONTINUE
      LENG=3
      CALL HFLD(KEYWD,LENG,DONE)
      IF(EQUAL(KEYWD,LEND,3)) DONE=.TRUE.
      IF(EQUAL(KEYWD,LALT,3)) DONE=.TRUE.
      IF(DONE) RETURN
C  IF BETA DELETIONS ARE THE SAME AS THE ALPHA DELETIONS ALREADY READ IN,
C    SKIP TO 100:
      IF((ISPIN.EQ.-2).AND.EQUAL(KEYWD,LSAME,3)) GO TO 100
      IF(EQUAL(KEYWD,LZERO,3)) GO TO 600
      IF(EQUAL(KEYWD,LNOVIC,3)) GO TO 3000
      IF(EQUAL(KEYWD,LNOGEM,3)) GO TO 3010
      IF(EQUAL(KEYWD,LDESTR,3)) GO TO 5000
      IF(EQUAL(KEYWD,LNOSTR,3)) GO TO 5500
      IF(.NOT.EQUAL(KEYWD,LDEL,3)) GO TO 9000
C  READ IN NUMBER OF ITEMS TO DELETE, NDEL:
      CALL IFLD(NDEL,ERROR)
      IF(ERROR) GO TO 9100
C  READ IN TYPE OF DELETION AND DETERMINE IF IT IS ORBITAL, ELEMENT, OR BLOCK:
C   (ITYPE STORES THE DELETION TYPE)
      CALL HFLD(KEYWD,LENG,DONE)
      IF(LENG.LT.3) GO TO 9200
      IF(.NOT.EQUAL(KEYWD,LORB,3)) GO TO 20
      ITYPE=1
      GO TO 80
  20  IF(.NOT.EQUAL(KEYWD,LELE,3)) GO TO 30
      ITYPE=2
      GO TO 80
  30  IF(.NOT.EQUAL(KEYWD,LBLO,3)) GO TO 9200
      ITYPE=4
  80  CONTINUE
C  NREAD=NUMBER OF NUMBERS THAT MUST BE READ
      NREAD=NDEL*ITYPE
C  READ IN ORBITALS,ELEMENTS, OR BLOCKS:
      DO 90 I=1,NREAD
        CALL IFLD(IDEL(I),ERROR)
        IF(ERROR) GO TO 9500
   90   CONTINUE
C
  100 CONTINUE
      IF(ITYPE.NE.1) GO TO 200
C   DELETE NDEL ORBITALS, ADJUSTING NTRUNC ACCORDINGLY:
        NTRUNC=NDIM-NDEL
C   ORDER THE ORBITAL NUMBERS:
        CALL ORDER(ISCR1,IDEL,NDEL,NDIM,ISCR2)
        WRITE(LFNPR,8610) (IDEL(I),I=1,NDEL)
C   FILL TRF WITH TRUNCATED FOCK MATRIX, DELETING REQUESTED ORBITALS:
        IFF=0
        IOUT=1
        II=0
        DO 140 I=1,NDIM
          IF(IOUT.GT.NDEL) GO TO 110
          IF(I.NE.IDEL(IOUT)) GO TO 110
            IFF=IFF+I
            IOUT=IOUT+1
            GO TO 140
  110     CONTINUE
            II=II+1
            JOUT=1
            JJ=0
            DO 130 J=1,I
              IF(JOUT.GT.NDEL) GO TO 120
              IF(J.NE.IDEL(JOUT)) GO TO 120
                IFF=IFF+1
                JOUT=JOUT+1
                GO TO 130
  120         CONTINUE
                JJ=JJ+1
                IFF=IFF+1
                TRF(II,JJ)=F(IFF)
                TRF(JJ,II)=F(IFF)
  130         CONTINUE
  140     CONTINUE
        RETURN
  200 CONTINUE
C  ELEMENT OR BLOCK DELETIONS: START BY FILLING TRF WITH FULL NBO FOCK MATRIX:
      II=0
      DO 210 I=1,NDIM
        DO 210 J=1,I
          II=II+1
          TRF(I,J)=F(II)
          TRF(J,I)=F(II)
  210     CONTINUE
      IF(ITYPE.NE.2) GO TO 300
C  ZERO REQUESTED MATRIX ELEMENTS:
        NDEL2=NDEL*2
        WRITE(LFNPR,8620) (IDEL(I),I=1,NDEL2)
        DO 240 I=1,NDEL
          I2=2*I
          ID=IDEL(I2-1)
          JD=IDEL(I2)
          TRF(ID,JD)=ZERO
          TRF(JD,ID)=ZERO
  240     CONTINUE
        RETURN
  300 CONTINUE
      IF(ITYPE.NE.4) STOP
C  ZERO REQUESTED MATRIX BLOCKS:
        DO 400 ID=1,NDEL
          IDST=(ID-1)*4
          J1=IDEL(IDST+1)
          J2=IDEL(IDST+2)
          I1=IDEL(IDST+3)
          I2=IDEL(IDST+4)
          IF(J1.LE.J2) GO TO 320
            IDEL(IDST+2)=J1
            IDEL(IDST+1)=J2
            J1=IDEL(IDST+1)
            J2=IDEL(IDST+2)
  320     IF(I1.LE.I2) GO TO 330
            IDEL(IDST+4)=I1
            IDEL(IDST+3)=I2
            I1=IDEL(IDST+3)
            I2=IDEL(IDST+4)
  330     DO 380 I=I1,I2
            DO 380 J=J1,J2
C  SKIP DIAGONAL ELEMENTS:
              IF(I.EQ.J) GO TO 380
              TRF(I,J)=ZERO
              TRF(J,I)=ZERO
  380       CONTINUE
  400     CONTINUE
        NDEL4=NDEL*4
        WRITE(LFNPR,8640) (IDEL(I),I=1,NDEL4)
      RETURN
C  DELETE INTERSECTION IN FOCK MATRIX BETWEEN PAIRS OF SETS OF ORBITALS:
  600 ITYPE=3
C  START BY FILLING TRF WITH FULL NBO FOCK MATRIX:
      II=0
      DO 610 I=1,NDIM
        DO 610 J=1,I
          II=II+1
          TRF(I,J)=F(II)
          TRF(J,I)=F(II)
  610     CONTINUE
C  READ IN NUMBER OF PAIRS OF SETS OF ORBITALS, NDEL:
      CALL IFLD(NDEL,ERROR)
      IF(ERROR) GO TO 9500
      LENG=5
C  CHECK THE NEXT WORD TO SEE IF IT IS "DELOCALIZATION" INSTEAD OF "BLOCK":
C  (IF SO, THE BLOCK WILL BE SPECIFIED BY MOLECULAR UNITS INSTEAD OF BY BLOCKS)
      CALL HFLD(KEYWD,LENG,DONE)
      IF(EQUAL(KEYWD,LDELOC,5)) GO TO 1000
C  CHECK THE WORD TO SEE IF IT IS "ATOM" INSTEAD OF "BLOCK":
C   (IF SO, THE BLOCK WILL BE SPECIFIED BY ORBITALS ON GROUPS OF ATOMS)
      IF(EQUAL(KEYWD,LATOM,4)) GO TO 1200
      NSTART=0
      DO 800 K=1,NDEL
C  READ IN THE NUMBER OF ORBITALS IN EACH SET OF THE PAIR, NSET1 AND NSET2:
C    (SKIP THE 'BY' BETWEEN NSET1 AND NSET2)
        CALL IFLD(NSET1,ERROR)
        IF(ERROR) GO TO 9500
        CALL HFLD(KEYWD,LENG,DONE)
        CALL IFLD(NSET2,ERROR)
        IF(ERROR) GO TO 9500
        NSTART=NSTART+2
        IDEL(NSTART-1)=NSET1
        IDEL(NSTART)=NSET2
C  READ IN THE ORBITALS OF BOTH SETS
        NTOT=NSET1+NSET2
        DO 620 I=1,NTOT
          CALL IFLD(IDEL(NSTART+I),ERROR)
          IF(ERROR) GO TO 9500
  620     CONTINUE
C  NOW, ZERO ALL INTERSECTING ELEMENTS BETWEEN THE TWO SETS:
        NSTRT2=NSTART+NSET1
        DO 700 I=1,NSET1
          ID=IDEL(NSTART+I)
          DO 700 J=1,NSET2
            JD=IDEL(NSTRT2+J)
            IF(ID.EQ.JD) GO TO 700
            TRF(ID,JD)=ZERO
            TRF(JD,ID)=ZERO
  700       CONTINUE
        NSTART=NSTART+NTOT
  800   CONTINUE
      GO TO 4000
C
C  ZEROING OF DELOCALIZATION WITHIN OR BETWEEN MOLECULAR UNITS.
C
C   USE THE NBO MOLECULAR UNIT (NBOUNI) AND NBO TYPE (NBOTYP) LISTS.
 1000 CONTINUE
      NSTART=0
      DO 1100 K=1,NDEL
C  SKIP THE NEXT WORD ("FROM"):
        CALL HFLD(KEYWD,LENG,DONE)
C  READ IN THE NUMBER OF THE FIRST MOLECULAR UNIT, IUNIT1:
        CALL IFLD(IUNIT1,ERROR)
        IF(ERROR) GO TO 9500
C  SKIP THE "TO" AND READ IN IUNIT2:
        CALL HFLD(KEYWD,LENG,DONE)
        CALL IFLD(IUNIT2,ERROR)
        IF(ERROR) GO TO 9500
        WRITE(LFNPR,8300) IUNIT1,IUNIT2
        NSTART=NSTART+2
C  FIND ALL OF THE NONSTAR (CORE/"LONE PAIR"/BOND) NBOS ON UNIT IUNIT1:
        NSET1=0
        DO 1020 IBAS=1,NDIM
          IF(NBOUNI(IBAS).NE.IUNIT1) GO TO 1020
          IF(NBOTYP(IBAS).GT.20) GO TO 1020
          NSET1=NSET1+1
          IDEL(NSTART+NSET1)=IBAS
 1020     CONTINUE
        IDEL(NSTART-1)=NSET1
C  FIND ALL OF THE STAR (RYDBERG/ANTIBOND) NBOS ON UNIT IUNIT2:
        NSET2=0
        NSTRT2=NSTART+NSET1
        DO 1040 IBAS=1,NDIM
          IF(NBOUNI(IBAS).NE.IUNIT2) GO TO 1040
          IF(NBOTYP(IBAS).LT.10) GO TO 1040
          NSET2=NSET2+1
          IDEL(NSTRT2+NSET2)=IBAS
 1040     CONTINUE
        IDEL(NSTART)=NSET2
        NTOT=NSET1+NSET2
C  NOW, ZERO ALL INTERSECTING ELEMENTS BETWEEN THE TWO SETS:
        DO 1060 I=1,NSET1
          ID=IDEL(NSTART+I)
          DO 1060 J=1,NSET2
            JD=IDEL(NSTRT2+J)
            IF(ID.EQ.JD) GO TO 1060
            TRF(ID,JD)=ZERO
            TRF(JD,ID)=ZERO
 1060       CONTINUE
        NSTART=NSTART+NTOT
 1100   CONTINUE
      GO TO 4000
C
C   ZEROING OF DELOCALIZATION BETWEEN GROUPS OF ATOMS
C
C   USE THE NBO TYPE (NBOTYP) AND NBO LABEL (LABEL) LISTS.
 1200 CONTINUE
      MSTART=0
      NSTART=0
C  SKIP THE 'BLOCKS' BEFORE NSET1:
      CALL HFLD(KEYWD,LENG,DONE)
      DO 1400 K=1,NDEL
C  READ IN THE NUMBER OF ATOMS IN EACH SET OF THE PAIR, NSET1 AND NSET2:
C    (SKIP THE 'BY' BETWEEN NSET1 AND NSET2)
        CALL IFLD(MSET1,ERROR)
        IF(ERROR) GO TO 9500
        CALL HFLD(KEYWD,LENG,DONE)
        CALL IFLD(MSET2,ERROR)
        IF(ERROR) GO TO 9500
        MSTART=MSTART+2
        ISCR1(MSTART-1)=MSET1
        ISCR1(MSTART)=MSET2
C  READ IN THE ATOMS OF BOTH SETS:
        MTOT=MSET1+MSET2
        DO 1220 I=1,MTOT
          CALL IFLD(ISCR1(MSTART+I),ERROR)
          IF(ERROR) GO TO 9500
 1220     CONTINUE
        MSTRT2=MSTART+MSET1
        WRITE(LFNPR,8350)
        WRITE(LFNPR,8631) (ISCR1(MSTART+I),I=1,MSET1)
        WRITE(LFNPR,8360)
        WRITE(LFNPR,8631) (ISCR1(MSTRT2+I),I=1,MSET2)
        WRITE(LFNPR,8370)
C  CONSTRUCT THE LIST OF THE TWO SETS OF ORBITALS FROM THE ATOM LISTS,
C    PLACING THE ORBITAL LIST IN IDEL IN THE STANDARD MANNER FOR ITYPE=3:
        NSTART=NSTART+2
        NSET1=0
        NSET2=0
        DO 1300 JBAS=1,NDIM
          DONOR=.FALSE.
          ACCPTR=.FALSE.
          IF(NBOTYP(JBAS).LT.20) DONOR=.TRUE.
          IF(NBOTYP(JBAS).GE.10) ACCPTR=.TRUE.
          LIST1=.FALSE.
          LIST2=.FALSE.
C    REMEMBER TO CONSULT IBXM BEFORE GETTING INFO FROM LABEL!
          JB=IBXM(JBAS)
          DO 1240 J=4,6
            JAT=LABEL(JB,J)
            IF(JAT.EQ.0) GO TO 1240
            DO 1230 I=1,MSET1
              IAT=ISCR1(MSTART+I)
              IF(IAT.NE.JAT) GO TO 1230
              GO TO 1240
 1230         CONTINUE
            GO TO 1250
 1240       CONTINUE
          LIST1=.TRUE.
 1250     CONTINUE
          DO 1270 J=4,6
            JAT=LABEL(JB,J)
            IF(JAT.EQ.0) GO TO 1270
            DO 1260 I=1,MSET2
              IAT=ISCR1(MSTRT2+I)
              IF(IAT.NE.JAT) GO TO 1260
              GO TO 1270
 1260         CONTINUE
            GO TO 1280
 1270       CONTINUE
          LIST2=.TRUE.
 1280     CONTINUE
          IF(LIST1.AND.LIST2) GO TO 1300
          IF(.NOT.LIST1.AND..NOT.LIST2) GO TO 1300
          IF(LIST1.AND..NOT.DONOR) GO TO 1300
          IF(LIST2.AND..NOT.ACCPTR) GO TO 1300
          IF(LIST2) GO TO 1290
C   LIST1.AND.DONOR=.TRUE. CASE:
            NSET1=NSET1+1
            IDEL(NSTART+NSET1)=JBAS
            GO TO 1300
C   LIST2.AND.ACCPTR=.TRUE. CASE:
 1290     CONTINUE
            NSET2=NSET2+1
            ISCR2(NSET2)=JBAS
 1300   CONTINUE
C
        IDEL(NSTART-1)=NSET1
        IDEL(NSTART)=NSET2
        NTOT=NSET1+NSET2
C  PLACE ORBITAL SET 2 IN IDEL:
        NSTRT2=NSTART+NSET1
        DO 1320 I=1,NSET2
 1320     IDEL(NSTRT2+I)=ISCR2(I)
C  NOW, ZERO ALL INTERSECTING ELEMENTS BETWEEN THE TWO SETS OF ORBITALS:
        DO 1340 I=1,NSET1
          ID=IDEL(NSTART+I)
          DO 1340 J=1,NSET2
            JD=IDEL(NSTRT2+J)
            TRF(ID,JD)=ZERO
 1340       TRF(JD,ID)=ZERO
        MSTART=MSTART+NTOT
        NSTART=NSTART+NTOT
 1400   CONTINUE
      GO TO 4000
C
C  DELETE ALL VICINAL OR GEMINAL DELOCALIZATIONS:
C
 3000 IVIC=1
      WRITE(LFNPR,8550)
      GOTO 3020
 3010 IVIC=0
      WRITE(LFNPR,8560)
 3020 CONTINUE
      ITYPE=3
C
C  START BY FILLING TRF WITH FULL NBO FOCK MATRIX:
C
      II=0
      DO 3025 I=1,NDIM
        DO 3025 J=1,I
          II=II+1
          TRF(I,J)=F(II)
          TRF(J,I)=F(II)
 3025 CONTINUE
C
C  FIND THE TOTAL NUMBER OF BLOCKS OF THE FOCK MATRIX TO DELETE:
C
      NDEL=0
      NSTART=0
      DO 3070 IBAS=1,NDIM
        IB=IBXM(IBAS)
        IF(LABEL(IB,2).NE.ISTAR) THEN
          NACC=0
          DO 3060 JBAS=1,NDIM
            JB=IBXM(JBAS)
            IF(LABEL(JB,2).EQ.ISTAR) THEN
              ITMP = IHTYP(IBAS,JBAS)
C
C  VICINAL DELOCALIZATION:
C
              IF(IVIC.EQ.1.AND.ITMP.EQ.LV) THEN
                NACC=NACC+1
                IDEL(NSTART+NACC+3)=JBAS
C
C  GEMINAL DELOCALIZATION:
C
              ELSE IF(IVIC.EQ.0.AND.ITMP.EQ.LG) THEN
                NACC=NACC+1
                IDEL(NSTART+NACC+3)=JBAS
              END IF
            END IF
 3060     CONTINUE
          IF(NACC.GT.0) THEN
            NDEL=NDEL+1
            IDEL(NSTART+1)=1
            IDEL(NSTART+2)=NACC
            IDEL(NSTART+3)=IBAS
            DO 3065 JB=1,NACC
              JBAS=IDEL(NSTART+JB+3)
              IF(JBAS.NE.IBAS) THEN
                TRF(IBAS,JBAS)=ZERO
                TRF(JBAS,IBAS)=ZERO
              END IF
 3065       CONTINUE
            NSTART=NSTART+NACC+3
            IF(NSTART.GT.LEN) STOP 'INCREASE DIMENSION OF ARRAY IDEL'
          END IF
        END IF
 3070 CONTINUE
      GOTO 4000
C
C  WRITE OUT INFORMATION FROM DELETION, FOR ITYPE=3:
 4000 CONTINUE
      INDX=0
      DO 4050 K=1,NDEL
        NSET1=IDEL(INDX+1)
        NSET2=IDEL(INDX+2)
        INDX=INDX+2
        NL=INDX+1
        NU=INDX+NSET1
        WRITE(LFNPR,8630)
        WRITE(LFNPR,8631) (IDEL(I),I=NL,NU)
        WRITE(LFNPR,8632)
        NL=INDX+NSET1+1
        NU=INDX+NSET1+NSET2
        WRITE(LFNPR,8631) (IDEL(I),I=NL,NU)
        INDX=NU
 4050   CONTINUE
      RETURN
C  DELETE ALL THE "STAR" NBOS ON ONE OR MORE MOLECULES:
C   (SET ITYPE=1 FOR ORBITAL DELETIONS)
 5000 CONTINUE
      ITYPE=1
C  READ IN THE NUMBER OF MOLECULAR UNITS TO "DESTAR":
      CALL IFLD(NUNITS,ERROR)
      IF(ERROR) GO TO 9500
C  SKIP THE KEYWORD "UNITS":
      LENG=3
      CALL HFLD(KEYWD,LENG,DONE)
C  READ IN THE NUMBERS OF THE UNITS TO DESTAR, FINDING THE STAR ORBITALS
C   FROM THE LISTS NBOUNI AND NBOTYP:
      NDEL=0
      DO 5100 I=1,NUNITS
        CALL IFLD(IUNIT,ERROR)
        IF(ERROR) GO TO 9500
        WRITE(LFNPR,8400) IUNIT
        DO 5050 IBAS=1,NDIM
          IF(NBOUNI(IBAS).NE.IUNIT) GO TO 5050
          IF(LABEL(IBAS,2).NE.ISTAR) GO TO 5050
          NDEL=NDEL+1
          IDEL(NDEL)=IBAS
 5050     CONTINUE
 5100   CONTINUE
C  GO AND DO THE DELETIONS OF THE NDEL ORBITALS THAT ARE NOW IN IDEL:
      GO TO 100
C
C  DELETE ALL STAR NBOS:
 5500 CONTINUE
      ITYPE=1
      NDEL=0
      WRITE(LFNPR,8500)
      DO 5600 IBAS=1,NDIM
        IF(LABEL(IBAS,2).NE.ISTAR) GO TO 5600
        NDEL=NDEL+1
        IDEL(NDEL)=IBAS
 5600   CONTINUE
C  GO AND DO THE DELETIONS OF THE NDEL ORBITALS THAT ARE NOW IN IDEL:
      GO TO 100
C
 8100 FORMAT(1X,' ----------- Alpha spin NBO deletions ----------- '/)
 8200 FORMAT(1X,' ----------- Beta  spin NBO deletions ----------- '/)
 8300 FORMAT(1X,'Zero delocalization from unit ',I2,' to unit ',I2)
 8350 FORMAT(1X,'Zero delocalization from NBOs localized on atoms:')
 8360 FORMAT(1X,'to NBOs localized on atoms:')
 8370 FORMAT(1X,'    (NBOs in common to the two groups of atoms ',
     *  'left out)')
 8400 FORMAT(1X,'DESTAR unit ',I2,': Delete all Rydberg/antibond',
     * ' NBOs from this unit')
 8500 FORMAT(1X,'NOSTAR: Delete all Rydberg/antibond NBOs')
 8550 FORMAT(1X,'NOVIC: Delete all vicinal delocalizations')
 8560 FORMAT(1X,'NOGEM: Delete all geminal delocalizations')
 8610 FORMAT(1X,'Deletion of the following orbitals ',
     * 'from the NBO Fock matrix:',(/1X,20I4))
 8620 FORMAT(1X,'Deletion of the following NBO Fock matrix ',
     * 'elements:',/(7(2X,'(',I3,',',I3,')')))
 8630 FORMAT(1X,'Deletion of the NBO Fock matrix elements ',
     * 'between orbitals:')
 8631 FORMAT(1X,20I4)
 8632 FORMAT(1X,'and orbitals:')
 8640 FORMAT(1X,'Deletion of the following NBO Fock matrix ',
     * 'blocks:',/(2(2X,'(',I3,'-',I3,'/',I3,'-',I3,')')))
 8700 FORMAT(/)
C
C  ERROR MESSAGES:
 9000 WRITE(LFNPR,9010) (KEYWD(I),I=1,3)
 9010 FORMAT(1X,'First character string does not have the',
     * ' first three letters of DELETE or ZERO:',/1X,3A1)
      STOP
 9100 WRITE(LFNPR,9110)
 9110 FORMAT(1X,'Non-integer was input for number of items to delete.')
      STOP
 9200 WRITE(LFNPR,9210) (KEYWD(I),I=1,3)
 9210 FORMAT(1X,'No match with first three letters of the keywords ',
     * 'for deletion type'/' (ORBITAL,ELEMENT,BLOCK) found:',
     * 3A1)
      STOP
 9300 WRITE(LFNPR,9310)
 9310 FORMAT(1X,'Keyword ALPHA (or A) not found to start alpha NBO',
     *          ' deletion input.')
      STOP
 9400 WRITE(LFNPR,9410)
 9410 FORMAT(1X,'Keyword BETA (or B) not found to start beta NBO',
     *          ' deletion input.')
 9500 WRITE(LFNPR,9510)
 9510 FORMAT(' There is an error in the input of deletions.')
      STOP
      END
C*****************************************************************************
      SUBROUTINE NEWDM(DM,U,EIG,NDIM,IDEL,LEN,NDEL,ITYPE,NMOOCC,ISPIN)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       IATNO(MAXBAS),IBXM(MAXBAS),NRANK(2*MAXBAS),LOCC(2*MAXBAS)
      DIMENSION DM(1),U(NDIM,NDIM),EIG(NDIM),IDEL(LEN)
      DATA ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/
C  ONETWO: ONE IF OPEN SHELL (ISPIN.NE.0), TWO IF CLOSED SHELL (DOUBLY OCC MOS)
      ONETWO=TWO
      IF(ISPIN.NE.0) ONETWO=ONE
C  NTRUNC: DIMENSION OF TRUNCATED FOCK MATRIX
      NTRUNC=NDIM
      IF(ITYPE.EQ.1) NTRUNC=NDIM-NDEL
C  RANK THE EIGENVALUES 'EIG' FROM THE TRUNCATED FOCK MATRIX FROM LOWEST
C   TO HIGHEST IN 'NRANK':
      CALL RNKEIG(NRANK,EIG,NTRUNC,NDIM,LOCC)
C  PUT IN 'LOCC' THE LOCATIONS OF THE 'NMOOCC' LOWEST EIGENVALUES:
C   (THESE CORRESPOND TO THE DOUBLY OCCUPIED MOS)
      NOCC=0
      DO 20 I=1,NTRUNC
        IF(NRANK(I).GT.NMOOCC) GO TO 20
          NOCC=NOCC+1
          LOCC(NOCC)=I
   20   CONTINUE
C  NDELOR: NUMBER OF DELETED ORBITALS
      NDELOR=NDIM-NTRUNC
C
C  CONSTRUCT THE NEW NBO DENSITY MATRIX:
C
C  LOOP OVER ROWS:
      II=0
      IJ=0
      IOUT=1
      DO 105 I=1,NDIM
        IF(IOUT.GT.NDELOR) GO TO 40
        IF(I.NE.IDEL(IOUT)) GO TO 40
C  ZERO ROWS OF THE NEW NBO DENSITY MATRIX THAT WERE ZEROED
C    IN THE TRUNCATION, ALSO ZEROING THE ORBITAL OCCPANCY, EIG(I):
          IOUT=IOUT+1
          EIG(I)=ZERO
          DO 30 J=1,I
            IJ=IJ+1
   30       DM(IJ)=ZERO
          GO TO 105
   40   CONTINUE
        II=II+1
C  LOOP OVER COLUMNS:
        JOUT=1
        JJ=0
        DO 100 J=1,I
          IF(JOUT.GT.NDELOR) GO TO 50
          IF(J.NE.IDEL(JOUT)) GO TO 50
C  ZERO COLUMNS OF THE NEW NBO DENSITY MATRIX THAT WERE ZEROED
C    IN THE TRUNCATION OF THE NBO FOCK MATRIX:
            JOUT=JOUT+1
            IJ=IJ+1
            DM(IJ)=ZERO
            GO TO 100
   50     CONTINUE
C  FIND DM(IJ) FROM THE EIGENVECTORS OF THE TRUNCATED NBO FOCK MATRIX IN 'U',
C  SUMMING OVER THE OCCUPIED MOS, AND MULTIPLYING BY TWO FOR DOUBLE OCCUPANCY:
          JJ=JJ+1
          SUM=ZERO
          DO 80 K=1,NMOOCC
   80       SUM=SUM+U(II,LOCC(K))*U(JJ,LOCC(K))
          IJ=IJ+1
          DM(IJ)=SUM*ONETWO
          IF(I.EQ.J) EIG(I)=SUM*ONETWO
  100   CONTINUE
  105   CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE RNKEIG(RANK,EIG,N,NDIM,ARCRNK)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  RANK EIGENVALUES IN 'EIG', LOWEST VALUES FIRST, IN 'RANK':
C
      INTEGER RANK,ARCRNK
      DIMENSION RANK(NDIM),EIG(NDIM),ARCRNK(NDIM)
      DO 10 I=1,N
   10   ARCRNK(I)=I
      DO 40 I=1,N
        IF(I.EQ.N) GO TO 30
         I1=I+1
         DO 20 J=I1,N
         IF(EIG(J).GE.EIG(I)) GO TO 20
           TEMP=EIG(I)
           EIG(I)=EIG(J)
           EIG(J)=TEMP
           ITEMP=ARCRNK(I)
           ARCRNK(I)=ARCRNK(J)
           ARCRNK(J)=ITEMP
   20     CONTINUE
   30    RANK(ARCRNK(I))=I
   40   CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SIMLTR(N,NDIM,F,U,R,S,KNTROL)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION F(1),U(NDIM,1),S(1),R(1)
C  TAKE U(TRANSPOSE)*F*U:
C     F    MATRIX TO BE TRANSFORMED (PACKED UPPER TRIANGULAR)
C     U    IS THE TRANSFORMATION MATRIX
C     R    IS THE MATRIX IN WHICH THE RESULT WILL BE RETURNED
C     S    IS A SCRATCH MATRIX OF DIMENSION N
C     KNTROL....=0  RESULT RETURNED ONLY IN  R
C               =1  RESULT COPIED INTO  F
C
      IN=0
      DO 50 I=1,N
        JN=0
        DO 20 J=1,N
          SUM=0.
          KN=0
          DO 10 K=1,N
            JK=JN+K
            IF(J.LT.K) JK=KN+J
            SUM=SUM+F(JK)*U(K,I)
   10       KN=KN+K
          S(J)=SUM
   20     JN=JN+J
        DO 40 J=1,I
          SUM=0.
          DO 30 K=1,N
   30       SUM=SUM+S(K)*U(K,J)
          IJ=IN+J
   40     R(IJ)=SUM
   50   IN=IN+I
      IF(KNTROL.EQ.0) RETURN
      NT=N*(N+1)/2
      DO 60 I=1,NT
   60   F(I)=R(I)
      RETURN
      END
C*****************************************************************************
C
C  NBO DIRECT ACCESS FILE (DAF) ROUTINES:
C
C      SUBROUTINE NBFILE(NEW,ERROR)
C      SUBROUTINE NBOPEN(NEW,ERROR)
C      SUBROUTINE NBWRIT(IX,NX,IDAR)
C      SUBROUTINE NBREAD(IX,NX,IDAR)
C      SUBROUTINE NBCLOS(SEQ)
C      SUBROUTINE NBINQR(IDAR)
C
C      SUBROUTINE FETITL(TITLE)
C      SUBROUTINE FEE0(EDEL,ETOT)
C      SUBROUTINE SVE0(EDEL)
C      SUBROUTINE FECOOR(ATCOOR)
C      SUBROUTINE FESRAW(S)
C      SUBROUTINE FEDRAW(DM,SCR)
C      SUBROUTINE FEFAO(F,IWFOCK)
C      SUBROUTINE FEAOMO(T,IT)
C      SUBROUTINE FEDXYZ(DXYZ,I)
C      SUBROUTINE SVNBO(T,OCC,ISCR)
C      SUBROUTINE FENBO(T,OCC,ISCR,NELEC)
C      SUBROUTINE FETNBO(T)
C      SUBROUTINE SVPNAO(T)
C      SUBROUTINE FEPNAO(T)
C      SUBROUTINE SVSNAO(S)
C      SUBROUTINE FESNAO(S)
C      SUBROUTINE SVTNAB(T)
C      SUBROUTINE FETNAB(T)
C      SUBROUTINE SVTLMO(T)
C      SUBROUTINE FETLMO(T)
C      SUBROUTINE SVTNHO(T)
C      SUBROUTINE FETNHO(T)
C      SUBROUTINE SVPPAO(DM)
C      SUBROUTINE FEPPAO(DM)
C      SUBROUTINE SVTNAO(T)
C      SUBROUTINE FETNAO(T)
C      SUBROUTINE SVNLMO(T)
C      SUBROUTINE FENLMO(T)
C      SUBROUTINE SVDNAO(DM)
C      SUBROUTINE FEDNAO(DM)
C      SUBROUTINE SVFNBO(F)
C      SUBROUTINE FEFNBO(F)
C      SUBROUTINE SVNEWD(DM)
C      SUBROUTINE FENEWD(DM)
C      SUBROUTINE FEINFO(ICORE,ISWEAN)
C      SUBROUTINE FEBAS(NSHELL,NEXP,ISCR)
C
C*****************************************************************************
      SUBROUTINE NBFILE(NEW,ERROR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL NEW,ERROR,NEED,THERE
      CHARACTER*80 TEMP
C
      PARAMETER (MAXFIL = 40)
C
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
      CHARACTER*80 FILENM
C
      DATA IWRIT,IREAD/4HWRIT,4HREAD/
C
C  Create a list IFILE of external LFNs.  First find the files that
C  will be written:
C
      ERROR = .FALSE.
      NFILE = 0
      DO 10 I = 1,999
        NEED = .FALSE.
        IF(IWPNAO.EQ.-I)     NEED = .TRUE.
        IF(IWTNAO.EQ.-I)     NEED = .TRUE.
        IF(IWTNAB.EQ.-I)     NEED = .TRUE.
        IF(IWTNBO.EQ.-I)     NEED = .TRUE.
        IF(JPRINT(7).EQ. I)  NEED = .TRUE.
        IF(JPRINT(9).EQ.-I)  NEED = .TRUE.
        IF(JPRINT(13).EQ.-I) NEED = .TRUE.
        IF(JPRINT(15).EQ.-I) NEED = .TRUE.
        IF(JPRINT(16).EQ.-I) NEED = .TRUE.
        IF(JPRINT(17).EQ.-I) NEED = .TRUE.
        IF(JPRINT(18).EQ.-I) NEED = .TRUE.
        IF(JPRINT(19).EQ.-I) NEED = .TRUE.
        IF(JPRINT(20).EQ.-I) NEED = .TRUE.
        IF(JPRINT(21).EQ.-I) NEED = .TRUE.
        IF(JPRINT(22).EQ. I) NEED = .TRUE.
        IF(JPRINT(23).EQ.-I) NEED = .TRUE.
        IF(JPRINT(24).EQ.-I) NEED = .TRUE.
        IF(JPRINT(25).EQ.-I) NEED = .TRUE.
        IF(JPRINT(26).EQ.-I) NEED = .TRUE.
        IF(JPRINT(27).EQ.-I) NEED = .TRUE.
        IF(JPRINT(28).EQ.-I) NEED = .TRUE.
        IF(JPRINT(29).EQ.-I) NEED = .TRUE.
        IF(JPRINT(30).EQ.-I) NEED = .TRUE.
        IF(JPRINT(31).EQ.-I) NEED = .TRUE.
        IF(JPRINT(33).EQ.-I) NEED = .TRUE.
        IF(JPRINT(34).EQ.-I) NEED = .TRUE.
        IF(JPRINT(35).EQ.-I) NEED = .TRUE.
        IF(JPRINT(37).EQ.-I) NEED = .TRUE.
        IF(JPRINT(38).EQ.-I) NEED = .TRUE.
        IF(JPRINT(39).EQ.-I) NEED = .TRUE.
        IF(JPRINT(40).EQ.-I) NEED = .TRUE.
        IF(JPRINT(41).EQ.-I) NEED = .TRUE.
        IF(JPRINT(42).EQ.-I) NEED = .TRUE.
        IF(JPRINT(44).EQ.-I) NEED = .TRUE.
        IF(JPRINT(45).EQ.-I) NEED = .TRUE.
        IF(JPRINT(47).EQ.-I) NEED = .TRUE.
        IF(JPRINT(48).EQ.-I) NEED = .TRUE.
        IF(JPRINT(49).EQ.-I) NEED = .TRUE.
        IF(JPRINT(50).EQ.-I) NEED = .TRUE.
        IF(JPRINT(51).EQ.-I) NEED = .TRUE.
        IF(JPRINT(52).EQ.-I) NEED = .TRUE.
        IF(JPRINT(53).EQ.-I) NEED = .TRUE.
        IF(JPRINT(54).EQ.-I) NEED = .TRUE.
        IF(NEED) THEN
          NFILE = NFILE + 1
          IF(NFILE.GT.MAXFIL) THEN
            WRITE(LFNPR,890) MAXFIL
            ERROR = .TRUE.
            RETURN
          END IF
          IFILE(NFILE) = I
        END IF
   10 CONTINUE
C
C  Add files that may be read:
C
      MFILE = NFILE
      IF(IOINQR(IWPNAO).EQ.IREAD) THEN
        MFILE = MFILE + 1
        IF(MFILE.GT.MAXFIL) THEN
          WRITE(LFNPR,890) MAXFIL
          ERROR = .TRUE.
          RETURN
        END IF
        IFILE(MFILE) = IWPNAO/1000
      END IF
      IF(IOINQR(IWTNAO).EQ.IREAD) THEN
        MFILE = MFILE + 1
        IF(MFILE.GT.MAXFIL) THEN
          WRITE(LFNPR,890) MAXFIL
          ERROR = .TRUE.
          RETURN
        END IF
        IFILE(MFILE) = IWTNAO/1000
      END IF
      IF(IOINQR(IWTNAB).EQ.IREAD) THEN
        MFILE = MFILE + 1
        IF(MFILE.GT.MAXFIL) THEN
          WRITE(LFNPR,890) MAXFIL
          ERROR = .TRUE.
          RETURN
        END IF
        IFILE(MFILE) = IWTNAB/1000
      END IF
C
C  Make sure that no files are both written and read:
C
      DO 30 I = NFILE+1,MFILE
        DO 20 J = 1,NFILE
          IF(ABS(IFILE(I)).EQ.IFILE(J)) THEN     
            WRITE(LFNPR,900) IFILE(J)
            ERROR = .TRUE.
            RETURN
          END IF
   20   CONTINUE
   30 CONTINUE
      NFILE = MFILE
C
C  Also check that the NBO DAF has its own LFN:
C
      DO 40 I = 1,NFILE
        IF(ABS(IFILE(I)).EQ.ABS(LFNDAF)) THEN
          WRITE(LFNPR,900) IFILE(I)
          ERROR = .TRUE.
          RETURN
        END IF
   40 CONTINUE
C
C  Select an alternate filename if this one is not acceptable:
C
      TEMP = FILENM
      DO 50 I = 1,80
        IF(TEMP(I:I).EQ.CHAR(32)) THEN
          LENGTH = I - 1
          GO TO 60
        END IF
   50 CONTINUE
      LENGTH = 76
   60 CONTINUE
      IO = IOINQR(IWPNAO)
      JO = IOINQR(IWTNAO)
      KO = IOINQR(IWTNAB)
      IF(NEW.AND.IO.NE.IREAD.AND.JO.NE.IREAD.AND.KO.NE.IREAD) THEN
        DO 100 I = 0,999
          LEN = LENGTH
          IF(I.NE.0) THEN
            II = I
   65       LEN = LEN + 1
            TEMP(LEN:LEN) = CHAR(MOD(II,10) + 48)
            II = II / 10
            IF(II.NE.0) GOTO 65
            IF(LEN.EQ.LENGTH+2) THEN
              TEMP(LEN+1:LEN+1) = TEMP(LEN:LEN)
              TEMP(LEN:LEN) = TEMP(LEN-1:LEN-1)
              TEMP(LEN-1:LEN-1) = TEMP(LEN+1:LEN+1)
            ELSE IF(LEN.EQ.LENGTH+3) THEN
              TEMP(LEN+1:LEN+1) = TEMP(LEN:LEN)
              TEMP(LEN:LEN) = TEMP(LEN-2:LEN-2)
              TEMP(LEN-2:LEN-2) = TEMP(LEN+1:LEN+1)
            END IF
          END IF
          TEMP(LEN+1:LEN+1) = '.'
C
C  First check the DAF:
C
          K = ABS(LFNDAF)
          IF(ABS(LFNDAF).LT.100) K = K * 10
          TEMP(LEN+2:LEN+2) = CHAR(K/100 + 48)
          TEMP(LEN+3:LEN+3) = CHAR(MOD(K/10,10) + 48)
          IF(ABS(LFNDAF).LT.100) THEN
            TEMP(LEN+4:LEN+4) = CHAR(32)
          ELSE
            TEMP(LEN+4:LEN+4) = CHAR(MOD(K,10) + 48)
          END IF
          INQUIRE(FILE=TEMP,EXIST=THERE)
          IF(THERE) GO TO 100
C
C  Now check the rest:
C
          DO 70 J = 1,NFILE
            K = ABS(IFILE(J))
            IF(ABS(IFILE(J)).LT.100) K = K * 10
            TEMP(LEN+2:LEN+2) = CHAR(K/100 + 48)
            TEMP(LEN+3:LEN+3) = CHAR(MOD(K/10,10) + 48)
            IF(ABS(IFILE(J)).LT.100) THEN
              TEMP(LEN+4:LEN+4) = CHAR(32)
            ELSE
              TEMP(LEN+4:LEN+4) = CHAR(MOD(K,10) + 48)
            END IF
            INQUIRE(FILE=TEMP, EXIST=THERE)
            IF(THERE) GO TO 100
   70     CONTINUE
          GO TO 200
  100   CONTINUE
        WRITE(LFNPR,910)
        ERROR = .TRUE.
        RETURN
C
C  This is a good one!!  If the filename has changed, write a warning:
C
  200   CONTINUE
        IF(FILENM(1:LEN).NE.TEMP(1:LEN)) THEN
          FILENM(1:LEN) = TEMP(1:LEN)
          DO 210 I = LEN+1,80
            FILENM(I:I) = CHAR(32)
  210     CONTINUE
          WRITE(LFNPR,920) FILENM(1:52)
        END IF
        LENGTH = LEN
      END IF
C
C  Open external files:
C
      TEMP = FILENM
      TEMP(LENGTH+1:LENGTH+1) = '.'
      DO 300 I = 1,NFILE
        K = ABS(IFILE(I))
        IF(ABS(IFILE(I)).LT.100) K = K * 10
        TEMP(LENGTH+2:LENGTH+2) = CHAR(K/100 + 48)
        TEMP(LENGTH+3:LENGTH+3) = CHAR(MOD(K/10,10) + 48)
        IF(ABS(IFILE(I)).LT.100) THEN
          TEMP(LENGTH+4:LENGTH+4) = CHAR(32)
        ELSE
          TEMP(LENGTH+4:LENGTH+4) = CHAR(MOD(K,10) + 48)
        END IF
        IF(IFILE(I).GT.0) THEN
          OPEN(UNIT=IFILE(I), FILE=TEMP, STATUS='NEW')
        ELSE
          OPEN(UNIT=ABS(IFILE(I)), FILE=TEMP, STATUS='OLD')
        END IF
  300 CONTINUE
      RETURN
C
  890 FORMAT(/1X,'I/O is limited to ',I2,' files.  Program abort.')
  900 FORMAT(/1X,'Illegal request for input and output with LFN',I3)
  910 FORMAT(/1X,'The search for an acceptable filename has failed.')
  920 FORMAT(/1X,'Filename:  Changed to ',A52)
      END
C*****************************************************************************
      SUBROUTINE NBOPEN(NEW,ERROR)
C*****************************************************************************
C
C  The following records of the NBO direct access file (DAF) are used:
C
C          1  ---   NBODAF common block
C          2  ---   Job title
C          3  ---   NATOMS,NDIM,NBAS,MUNIT,wavefunction flags,ISWEAN
C          4  ---   IATNO,IZNUC,LCTR,LANG
C          5  ---   AO basis set information
C          8  ---   Deletion energy, total energy
C          9  ---   Atomic coordinates
C         10  ---   AO overlap matrix
C         11  ---   PNAO overlap matrix
C         20  ---   AO density matrix (alpha)
C         21  ---   AO density matrix (beta)
C         22  ---   Pure AO density matrix
C         23  ---   NAO density matrix (alpha)
C         24  ---   NAO density matrix (beta)
C         25  ---   AO density matrix with NBO deletions (alpha)
C         26  ---   AO density matrix with NBO deletions (beta)
C         27  ---   NBO occupancies (alpha)
C         28  ---   NBO occupancies (beta)
C         30  ---   AO Fock matrix (alpha)
C         31  ---   AO Fock matrix (beta)
C         32  ---   NAO Fock matrix (alpha)
C         33  ---   NAO Fock matrix (beta)
C         34  ---   NBO Fock matrix (alpha)
C         35  ---   NBO Fock matrix (beta)
C         40  ---   AO to MO transformation matrix (alpha)
C         41  ---   AO to MO transformation matrix (beta)
C         42  ---   AO to PNAO transformation matrix
C         43  ---   AO to NAO transformation matrix
C         44  ---   AO to NBO transformation matrix  (alpha)
C         45  ---   AO to NBO transformation matrix  (beta)
C         46  ---   AO to NLMO transformation matrix
C         47  ---   NAO to NHO transformation matrix
C         48  ---   NAO to NBO transformation matrix
C         49  ---   NBO to NLMO transformation matrix
C         50  ---   X dipole integrals
C         51  ---   Y dipole integrals
C         52  ---   Z dipole integrals
C         60  ---   NBO labels (alpha)
C         61  ---   NBO labels (beta)
C-----------------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL NEW,ERROR
      CHARACTER*80 TEMP
C
C  Note that ISINGL is no longer a parameter (6/7/90):
C
      PARAMETER (LENGTH = 256)
      PARAMETER (NBDAR = 100)
      PARAMETER (MAXFIL = 40)
C
      COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
      COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
      CHARACTER*80 FILENM
C
      DIMENSION IX(NBDAR+2),IXSNBO(LENGTH/2)
C
      EQUIVALENCE (IXSNBO(1),IXDNBO(1))
      EQUIVALENCE (IX(1),INBO)
C
      SAVE ISW,LENREC
C
      DATA IBLNK/1H /
      DATA ISW/0/
C
C     INBO   :  Fortran file number
C     IONBO  :  Indexing array mapping the logical records of the
C               NBO DAF onto the physical records of the disk file
C     NAV    :  Number of physical records currently on the DAF
C     NBDAR  :  Maximum number of logical records on the DAF
C
      INBO = ABS(LFNDAF)
C
C  Are we working on a 32 (ISINGL=2) or 64 (ISINGL=1) bit machine?
C
      IF(ISW.EQ.0) THEN
        DO 10 I = 1,4
          IBLNK = IBLNK / 256
   10   CONTINUE
        IF(IBLNK.EQ.0) THEN
          ISINGL = 2
        ELSE
          ISINGL = 1
        END IF
C
C  Determine an appropriate record length for the NBO DAF:
C
        LREC   = LENGTH / 4
        LENREC = 0
        DO 30 I = 1,6
          LREC = LREC * 2
          OPEN(UNIT=INBO, FILE='nb$temp.dat', STATUS='NEW',
     +         ACCESS='DIRECT', RECL=LREC, FORM='UNFORMATTED',
     +         ERR=40)
          WRITE(INBO,REC=1,ERR=20) IXDNBO
C
C  If I.EQ.1 at this point, ERR did not work properly in the preceding 
C  statement (this appears to be the case for the XL FORTRAN compiler
C  running on an IBM RISC station/6000):
C
          IF(I.EQ.1) LREC = LENGTH * 8 / ISINGL
          IF(ISINGL.EQ.1) LENREC = LREC / 2
          IF(ISINGL.EQ.2) LENREC = LREC
   20     CLOSE(UNIT=INBO, STATUS='DELETE')
          IF(LENREC.NE.0) GO TO 50
   30   CONTINUE
C
C  Problems...
C
   40   CONTINUE
        WRITE(LFNPR,900)
        ERROR = .TRUE.
        RETURN
C
   50   CONTINUE
        ISW = 1
      END IF
C
C  Open the NBO direct access file (DAF) -- typically assigned to LFN48:
C
      TEMP = FILENM
      DO 60 I = 1,80
        IF(TEMP(I:I).EQ.CHAR(32)) THEN
          LEN = I - 1
          GO TO 70
        END IF
   60 CONTINUE
      LEN = 76
   70 CONTINUE
      K = INBO
      IF(INBO.LT.100) K = K * 10
      TEMP(LEN+1:LEN+1) = '.'
      TEMP(LEN+2:LEN+2) = CHAR(K/100 + 48)
      TEMP(LEN+3:LEN+3) = CHAR(MOD(K/10,10) + 48)
      IF(INBO.LT.100) THEN
        TEMP(LEN+4:LEN+4) = CHAR(32)
      ELSE
        TEMP(LEN+4:LEN+4) = CHAR(MOD(K,10) + 48)
      END IF
C
C  If this is a new NBO DAF, write COMMON/NBODAF/ on the first record:
C
      IF(NEW) THEN
        OPEN(UNIT=INBO, FILE=TEMP, STATUS='NEW', ACCESS='DIRECT', 
     +       RECL=LENREC, FORM='UNFORMATTED', ERR=110)
        NAV   = 1
        NBNAV = 1
        DO 80 I = 1,NBDAR
          IONBO(I) = 0
   80   CONTINUE
        NF = 1
        NX = (NBDAR + 2) / ISINGL
        CALL NBWRIT(IX,NX,NF)
C
C  Otherwise, open the old file and read in COMMON/NBODAF/ from the
C  first record:
C
      ELSE
        OPEN(UNIT=INBO, FILE=TEMP, STATUS='OLD', ACCESS='DIRECT', 
     +       RECL=LENREC, FORM='UNFORMATTED', ERR=110)
        NBNAV = 1
        MAXIX = LENGTH * ISINGL/2
        LDAR  = NBDAR + 2
        MAX = 0
   90   MIN = MAX + 1
        MAX = MAX + MAXIX
        IF(MAX.GT.LDAR) MAX = LDAR
        IF(ISINGL.EQ.1) READ(INBO,REC=NBNAV) IXSNBO
        IF(ISINGL.EQ.2) READ(INBO,REC=NBNAV) IXDNBO
        DO 100 I = MIN,MAX
          IX(I) = IXDNBO(I-MIN+1)
  100   CONTINUE
        NBNAV = NBNAV + 1
        IF(MAX.LT.LDAR) GO TO 90
        INBO = ABS(LFNDAF)
      END IF
      ERROR = .FALSE.
      RETURN
C
C  Error encountered while opening this file:
C
  110 ERROR = .TRUE.
      RETURN
C
  900 FORMAT(/1X,'Routine NBOPEN could not determine an appropriate ',
     + 'record length.')
      END
C*****************************************************************************
      SUBROUTINE NBWRIT(IX,NX,IDAR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (LENGTH = 256)
      PARAMETER (NBDAR = 100)
C
      COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
      COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
C
      DIMENSION IX(1),IXSNBO(LENGTH/2)
C
      EQUIVALENCE (IXSNBO(1),IXDNBO(1))
C
      MAXIX = LENGTH * ISINGL / 2
      LDAR  = NX * ISINGL
      IF(IONBO(IDAR).NE.0) GO TO 100
C
C  If this is the first write to the NBO DAF:
C
      IONBO(IDAR) = NAV
      NBNAV = NAV
C
      MAX = 0
   10 MIN = MAX + 1
      MAX = MAX + MAXIX
      IF(MAX.GT.LDAR) MAX = LDAR
      DO 20 I = MIN,MAX
   20 IXDNBO(I-MIN+1) = IX(I)
      IF(ISINGL.EQ.1) WRITE(INBO,REC=NBNAV) IXSNBO
      IF(ISINGL.EQ.2) WRITE(INBO,REC=NBNAV) IXDNBO
      NBNAV = NBNAV + 1
      IF(MAX.LT.LDAR) GO TO 10
      NAV = NBNAV
      RETURN
C
C  Or if this is a rewrite:
C
  100 CONTINUE
      NBNAV = IONBO(IDAR)
      MAX = 0
  110 MIN = MAX + 1
      MAX = MAX + MAXIX
      IF(MAX.GT.LDAR) MAX = LDAR
      DO 120 I = MIN,MAX
  120 IXDNBO(I-MIN+1) = IX(I)
      IF(ISINGL.EQ.1) WRITE(INBO,REC=NBNAV) IXSNBO
      IF(ISINGL.EQ.2) WRITE(INBO,REC=NBNAV) IXDNBO
      NBNAV = NBNAV + 1
      IF(MAX.LT.LDAR) GO TO 110
      RETURN
      END
C*****************************************************************************
      SUBROUTINE NBREAD(IX,NX,IDAR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (LENGTH = 256)
      PARAMETER (NBDAR = 100)
C
      COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
      COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
C
      DIMENSION IX(1),IXSNBO(LENGTH/2)
C
      EQUIVALENCE (IXSNBO(1),IXDNBO(1))
C
      NBNAV = IONBO(IDAR)
      MAXIX = LENGTH * ISINGL / 2
      LDAR  = NX * ISINGL
C
      MAX = 0
   10 MIN = MAX + 1
      MAX = MAX + MAXIX
      IF(MAX.GT.LDAR) MAX = LDAR
      IF(ISINGL.EQ.1) READ(INBO,REC=NBNAV) IXSNBO
      IF(ISINGL.EQ.2) READ(INBO,REC=NBNAV) IXDNBO
      DO 20 I = MIN,MAX
   20 IX(I) = IXDNBO(I-MIN+1)
      NBNAV = NBNAV + 1
      IF(MAX.LT.LDAR) GO TO 10
      RETURN
      END
C*****************************************************************************
      SUBROUTINE NBCLOS(SEQ)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL SEQ
C
      PARAMETER (LENGTH = 256)
      PARAMETER (NBDAR = 100)
      PARAMETER (MAXFIL = 40)
C
      COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
      COMMON/NBONAV/IXDNBO(LENGTH),NBNAV,ISINGL
      COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)
      CHARACTER*80 FILENM
C
      DIMENSION IX(NBDAR+2)
      EQUIVALENCE (IX(1),INBO)
C
C  First close the NBO direct access file, remembering to write
C  COMMON/NBODAF/ to the first logical record:
C
      NF = 1
      NX = (NBDAR + 2) / ISINGL
      CALL NBWRIT(IX,NX,NF)
      CLOSE(UNIT=INBO, STATUS='KEEP')
C
C  Then close the remainder of the files used by the NBO program:
C
      DO 10 I = 1,NFILE
        CLOSE(UNIT=ABS(IFILE(I)), STATUS='KEEP')
   10 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE NBINQR(IDAR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (NBDAR = 100)
      COMMON/NBODAF/INBO,NAV,IONBO(NBDAR)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      IF(IDAR.LT.1.OR.IDAR.GT.NBDAR) THEN
        WRITE(LFNPR,900) IDAR,NBDAR
        STOP
      END IF
C
      IF(IONBO(IDAR).EQ.0) IDAR = 0
      RETURN
C
  900 FORMAT(/1X,'NBO DAF record out of range: IDAR = ',I4,
     + '  NBDAR = ',I4)
      END
C*****************************************************************************
      SUBROUTINE FETITL(TITLE)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION TITLE(10)
C
C  FETITL:  FETCHES THE JOB TITLE FROM THE NBODAF:
C
      NFILE = 2
      CALL NBREAD(TITLE,10,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEE0(EDEL,ETOT)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION X(2)
C
C  FEE0:  FETCHES THE DELETION AND TOTAL SCF ENERGY
C
      NFILE = 8
      CALL NBREAD(X,2,NFILE)
      EDEL = X(1)
      ETOT = X(2)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVE0(EDEL)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION X(2)
C
C  SVE0:  SAVES THE DELETION ENERGY
C
      NFILE = 8
      CALL NBREAD(X,2,NFILE)
      X(1) = EDEL
      CALL NBWRIT(X,2,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FECOOR(ATCOOR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION ATCOOR(3*NATOMS)
C
C  FECOOR:  FETCH THE ATOMIC CARTESIAN COORDINATES IN ANGSTROMS.
C
      NFILE = 9
      CALL NBREAD(ATCOOR,3*NATOMS,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEBAS(NSHELL,NEXP,ISCR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION ISCR(1)
C
C  FEBAS:  FETCHES THE BASIS SET INFO
C
      NFILE = 5
      CALL NBINQR(NFILE)
      IF(NFILE.GT.0) THEN
        CALL NBREAD(ISCR,2,NFILE)
        II = 0
        II = II + 1
        NSHELL = ISCR(II)
        II = II + 1
        NEXP   = ISCR(II)
        LEN    = 2 + 3*NSHELL + 5*NEXP
        CALL NBREAD(ISCR,LEN,NFILE)
      ELSE
        NSHELL = 0
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FESRAW(S)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
      DIMENSION S(NDIM,NDIM)
C
C  FESRAW:  FETCHES THE OVERLAP MATRIX (RAW AO. BASIS)
C           INTO S(NDIM,NDIM) A FULL SQUARE MATRIX.
C
      NFILE = 10
      L2 = NDIM*(NDIM+1)/2
      CALL NBREAD(S,L2,NFILE)
      CALL UNPACK(S,NDIM,NBAS,L2)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEDRAW(DM,SCR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION DM(1),SCR(1)
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
      DATA NFILEA,NFILEB/20,21/
C
C  FEDRAW:  FETCHES THE DENSITY MATRIX (RAW A.O. BASIS) IN DM(NDIM,NDIM)
C           IF ALPHA =.TRUE.  FETCH ALPHA MATRIX
C           IF BETA  =.TRUE   FETCH BETA MATRIX.
C           IF OPEN .AND. .NOT.(ALPHA .OR. BETA) =.TRUE  FETCH THE TOTAL D.M.
C
      L2 = NDIM*(NDIM+1)/2
      NFILE = NFILEA
      IF(BETA) NFILE = NFILEB
      CALL NBREAD(DM,L2,NFILE)
C
      IF(.NOT.OPEN) GOTO 300
      IF(ALPHA.OR.BETA) GOTO 300
      CALL NBREAD(SCR,L2,NFILEB)
C
C  FORM THE TOTAL DENSITY MATRIX:
C
      DO 100 I = 1,L2
        DM(I) = DM(I) + SCR(I)
  100 CONTINUE
C
  300 CALL UNPACK(DM,NDIM,NBAS,L2)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEFAO(F,IWFOCK)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION F(1)
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
      DATA NFILEA,NFILEB/30,31/
C
C  FEFAO:  FETCHES THE AO FOCK MATRIX 
C          IF ALPHA .EQ. .TRUE.  WE WANT THE ALPHA FOCK MATRIX
C          IF BETA .EQ. .TRUE.  WE WANT THE BETA FOCK MATRIX.
C          IF THE REQUESTED MATRIX DOES NOT EXIST THEN IWFOCK = 0
C
      L2 = NDIM*(NDIM+1)/2
      NFILE = NFILEA
      IF(BETA) NFILE = NFILEB
      CALL NBINQR(NFILE)
      IF(NFILE.GT.0) THEN
        CALL NBREAD(F,L2,NFILE)
        CALL UNPACK(F,NDIM,NBAS,L2)
      ELSE
        IWFOCK = 0
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEAOMO(T,IT)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION T(1)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
      DATA NFILEA,NFILEB/40,41/
C
C FEAOMO:  FETCH THE AO TO MO TRANSFORMATION MATRIX:
C          (IT = 1, AO TO MO TRANSFORM IS ON NBO DAF)
C          (IT = 0, AO TO MO TRANSFORM IS NOT ON NBO DAF)
C
      NFILE = NFILEA
      IF (BETA) NFILE = NFILEB
      CALL NBINQR(NFILE)
      IF(NFILE.GT.0) THEN
        IT = 1
        L3 = NDIM*NDIM
        CALL NBREAD(T,L3,NFILE)
      ELSE
        IT = 0
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEDXYZ(DXYZ,I)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION DXYZ(1)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
      DATA NFILEX,NFILEY,NFILEZ/50,51,52/
C
C  FEDXYZ:    FETCH THE AO DIPOLE MOMENT MATRICES (IN ANGSTROMS)
C      I=1:  X       I=2:    Y           I=3:   Z
C
      IF(I.EQ.1) NFILE = NFILEX
      IF(I.EQ.2) NFILE = NFILEY
      IF(I.EQ.3) NFILE = NFILEZ
C
      CALL NBINQR(NFILE)
      IF(NFILE.GT.0) THEN
        L2 = NDIM*(NDIM+1)/2
        CALL NBREAD(DXYZ,L2,NFILE)
        CALL UNPACK(DXYZ,NDIM,NBAS,L2)
      ELSE
        I = 0
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVNBO(T,OCC,ISCR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORB(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
C
      DIMENSION T(NDIM,NDIM),OCC(NDIM),ISCR(1)
C
C  SVNBO:  SAVES NBO INFORMATION (TRANSFORMATION, OCCUPANCIES, LABELS, ETC.)
C          IF ALPHA .EQ. .TRUE.  SAVE THE ALPHA INFORMATION
C          IF BETA .EQ. .TRUE.  SAVE THE BETA INFORMATION.
C
C  SAVE THE AO TO NBO TRANSFORMATION MATRIX:
C
      L1 = NDIM
      L3 = NDIM*NDIM
      L4 = 10*NDIM
      NFILE = 44
      IF (BETA) NFILE = 45
      CALL NBWRIT(T,L3,NFILE)
C
C  SAVE NBO ORBITAL OCCUPANCIES:
C
      NFILE = 27
      IF (BETA) NFILE = 28
      CALL NBWRIT(OCC,L1,NFILE)
C
C  SAVE THE LISTS OF NBO INFORMATION FOR LATER USE IN THE DELETIONS.
C  PACK THE INFORMATION INTO ISCR(10*NDIM):
C
      II = 0
      DO 40 K = 1,6
        DO 30 I = 1,NBAS
          II = II + 1
          ISCR(II) = LABEL(I,K)
   30   CONTINUE
   40 CONTINUE
      DO 50 I = 1,NBAS
        II = II + 1
        ISCR(II) = IBXM(I) 
   50 CONTINUE
      DO 60 I = 1,NATOMS
        II = II + 1
        ISCR(II) = IATNO(I) 
   60 CONTINUE
      DO 70 I = 1,NBAS
        II = II + 1
        ISCR(II) = NBOUNI(I)
   70 CONTINUE
      DO 80 I = 1,NBAS
        II = II + 1
        ISCR(II) = NBOTYP(I) 
   80 CONTINUE
C
      NFILE = 60
      IF (BETA) NFILE = 61
      CALL NBWRIT(ISCR,L4,NFILE)
C
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FENBO(T,OCC,ISCR,NELEC)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       IATNO(MAXBAS),IBXM(MAXBAS),ISCR1(2*MAXBAS),ISCR2(2*MAXBAS)
C
      DIMENSION T(NDIM,NDIM),OCC(NDIM),ISCR(1)
C
      DATA ZERO,TENTH /0.0D0,1.0D-1/
C
C  FENBO:  FETCHES NBO INFORMATION (TRANSFORMATION, OCCUPANCIES, LABELS, ETC.)
C          IF ALPHA .EQ. .TRUE.  FETCH THE ALPHA INFORMATION
C          IF BETA .EQ. .TRUE.  FETCH THE BETA INFORMATION.
C
C  FETCH THE AO TO NBO TRANSFORMATION MATRIX:
C
      L1 = NDIM
      L3 = NDIM*NDIM
      L4 = NDIM*10
      NFILE = 44
      IF (BETA) NFILE = 45
      CALL NBREAD(T,L3,NFILE)
C
C  FETCH NBO ORBITAL OCCUPANCIES:
C
      NFILE = 27
      IF (BETA) NFILE = 28
      CALL NBREAD(OCC,L1,NFILE)
C
C  COUNT UP THE TOTAL NUMBER OF ELECTRONS AS AN INTEGER NELEC:
C
      ELE = ZERO
      DO 10 I = 1,NBAS
        ELE = ELE + OCC(I)
   10 CONTINUE
      ELE = ELE + TENTH
      NELEC = ELE
C
C  FETCH THE VARIOUS LISTS OF NBO INFORMATION FOR USE IN THE DELETIONS.
C  UNPACK THE INFORMATION INTO LABEL(MAXBAS,6),IBXM(MAXBAS),IATNO(MAXBAS),
C  NBOUNI(MAXBAS) AND NBOTYP(MAXBAS) FROM ISCR(10*NDIM):
C
      NFILE = 60
      IF (BETA) NFILE = 61
      CALL NBREAD(ISCR,L4,NFILE)
C
      II = 0
      DO 40 K = 1,6
        DO 30 I = 1,NBAS
          II = II + 1
          LABEL(I,K) = ISCR(II)
   30   CONTINUE
   40 CONTINUE
      DO 50 I = 1,NBAS
        II = II + 1
        IBXM(I) = ISCR(II)
   50 CONTINUE
      DO 60 I = 1,NATOMS
        II = II + 1
        IATNO(I) = ISCR(II)
   60 CONTINUE
      DO 70 I = 1,NBAS
        II = II + 1
        NBOUNI(I) = ISCR(II)
   70 CONTINUE
      DO 80 I = 1,NBAS
        II = II + 1
        NBOTYP(I) = ISCR(II)
   80 CONTINUE
C
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FETNBO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION T(1)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C  FETNBO: FETCH THE AO TO NBO TRANSFORMATION MATRIX
C
      L3 = NDIM*NDIM
      NFILE = 44
      IF (BETA) NFILE = 45
      CALL NBREAD(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVPNAO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION T(1)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C  SVPNAO:  SAVES THE AO TO PNAO TRANSFORMATION MATRIX.
C
      NFILE = 42
      L3 = NDIM*NDIM 
      CALL NBWRIT(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEPNAO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION T(1)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C  FEPNAO:  FETCHES THE AO TO PNAO TRANSFORMATION MATRIX.
C
      NFILE = 42
      L3 = NDIM*NDIM
      CALL NBREAD(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVSNAO(S)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION S(NDIM,NDIM)
C
C   SVSNAO:  SAVE THE OVERLAP MATRIX IN THE PNAO OR RPNAO BASIS SET.
C
      NFILE = 11
      L2 = NDIM*(NDIM+1)/2
      CALL PACK(S,NDIM,NBAS,L2)
      CALL NBWRIT(S,L2,NFILE)
      CALL UNPACK(S,NDIM,NBAS,L2)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FESNAO(S)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
      DIMENSION S(NDIM,NDIM)
C
C   FESNAO:   FETCH THE OVERLAP MATRIX IN THE PNAO OR RPNAO BASIS SET.
C
      NFILE = 11
      L2 = NDIM*(NDIM+1)/2
      CALL NBREAD(S,L2,NFILE)
      CALL UNPACK(S,NDIM,NBAS,L2)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVTNAB(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM)
C
C  SVTNAB:  SAVE THE NAO TO NBO TRANSFORMATION MATRIX.
C
      NFILE = 48
      L3 = NDIM*NDIM 
      CALL NBWRIT(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FETNAB(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM)
C
C  FETNAB:  FETCH THE NAO TO NBO TRANSFORMATION MATRIX 
C
      NFILE = 48
      L3 = NDIM*NDIM
      CALL NBREAD(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVTLMO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM)
C
C  SVTLMO:  SAVE THE NBO TO NLMO TRANSFORMATION MATRIX.
C
      NFILE = 49
      L3 = NDIM*NDIM 
      CALL NBWRIT(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FETLMO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM)
C
C  FETLMO:  FETCH THE NBO TO NLMO TRANSFORMATION MATRIX 
C
      NFILE = 49
      L3 = NDIM*NDIM
      CALL NBREAD(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVTNHO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM)
C
C  SVTNHO:   TEMPORARILY SAVE THE NAO TO NHO TRANSFORMATION
C
      NFILE = 47
      L3 = NDIM*NDIM 
      CALL NBWRIT(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FETNHO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM)
C
C  FETNHO:   FETCH THE NAO TO NHO TRANSFORMATION
C
      NFILE = 47
      L3 = NDIM*NDIM 
      CALL NBREAD(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVPPAO(DM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION DM(NDIM,NDIM)
C
C  SVPPAO:  TEMPORARILY SAVES THE PURE AO (PAO) DENSITY MATRIX.
C           (THIS IS NOT THE RAW AO BASIS, BUT THE BASIS AFTER THE
C           TRANSFORMATION FROM CARTESIAN TO PURE D,F,G FUNCTIONS).
C
      NFILE = 22
      L2 = NDIM*(NDIM+1)/2
      CALL PACK(DM,NDIM,NBAS,L2)
      CALL NBWRIT(DM,L2,NFILE)
      CALL UNPACK(DM,NDIM,NBAS,L2)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEPPAO(DM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION DM(NDIM,NDIM)
C
C  FEPPAO:  FETCHES THE PURE AO (PAO) DENSITY MATRIX.
C           (THIS IS NOT THE RAW AO BASIS, BUT THE BASIS AFTER THE
C           TRANSFORMATION FROM CARTESIAN TO PURE D,F,G FUNCTIONS).
C
      NFILE = 22
      L2 = NDIM*(NDIM+1)/2
      CALL NBREAD(DM,L2,NFILE)
      CALL UNPACK(DM,NDIM,NBAS,L2)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVTNAO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM)
C
C  SVTNAO:  SAVE THE AO TO NAO TRANSFORMATION MATRIX.
C
      IF(.NOT.ORTHO) THEN
        NFILE = 43
        L3 = NDIM*NDIM 
        CALL NBWRIT(T,L3,NFILE)
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FETNAO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM)
C
      DATA ZERO,ONE/0.0D0,1.0D0/
C
C  FETNAO:  FETCHES THE AO TO NAO TRANSFORMATION MATRIX.
C
      IF(ORTHO) THEN
        DO 20 J = 1,NDIM
          DO 10 I = 1,NDIM
            T(I,J) = ZERO
   10     CONTINUE
          T(J,J) = ONE
   20   CONTINUE
      ELSE
        NFILE = 43
        L3 = NDIM*NDIM
        CALL NBREAD(T,L3,NFILE)
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVNLMO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM)
C
C  SVNLMO:  SAVE THE AO TO NLMO TRANSFORMATION MATRIX
C
      NFILE = 46
      L3 = NDIM*NDIM 
      CALL NBWRIT(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FENLMO(T)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION T(NDIM,NDIM)
C
C  FENLMO:  FETCH THE AO TO NLMO TRANSFORMATION MATRIX
C
      NFILE = 46
      L3 = NDIM*NDIM
      CALL NBREAD(T,L3,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVDNAO(DM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION DM(NDIM,NDIM)
C
C  SVDNAO:  SAVE THE NAO DENSITY MATRIX
C
      IF(.NOT.ORTHO) THEN
        NFILE = 23
        IF(BETA) NFILE = 24
        L2 = NDIM*(NDIM+1)/2
        CALL PACK(DM,NDIM,NBAS,L2)
        CALL NBWRIT(DM,L2,NFILE)
        CALL UNPACK(DM,NDIM,NBAS,L2)
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEDNAO(DM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      DIMENSION DM(NDIM,NDIM)
C
C  FEDNAO:  FETCHES THE NAO DENSITY MATRIX (AO DM FOR ORTHOGONAL BASIS SETS)
C
      IF(ORTHO) THEN
        CALL FEDRAW(DM,DM)
      ELSE
        NFILE = 23
        IF(BETA) NFILE = 24
        L2 = NDIM*(NDIM+1)/2
        CALL NBREAD(DM,L2,NFILE)
        CALL UNPACK(DM,NDIM,NBAS,L2)
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVFNBO(F)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      DIMENSION F(NDIM,NDIM)
C
C  SVFNBO:  SAVES THE NBO FOCK MATRIX
C
      NFILE = 34
      IF (BETA) NFILE = 35
      L2 = NDIM*(NDIM+1)/2
      CALL PACK(F,NDIM,NBAS,L2)
      CALL NBWRIT(F,L2,NFILE)
      CALL UNPACK(F,NDIM,NBAS,L2)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEFNBO(F)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      DIMENSION F(1)
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C  FEFNBO:  FETCHES THE NBO FOCK MATRIX, LEAVING IT IN TRIANGULAR FORM!!
C           IF ALPHA.EQ.TRUE.  WE WANT THE ALPHA FOCK MATRIX
C           IF BETA.EQ.TRUE.   WE WANT THE BETA FOCK MATRIX.
C
      NFILE = 34
      IF (BETA) NFILE = 35
      L2 = NDIM*(NDIM+1)/2
      CALL NBREAD(F,L2,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SVNEWD(DM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      DIMENSION DM(1)
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C SVNEWD:  SAVE THE NEW DENSITY MATRIX (RAW AO BASIS) FROM NBO DELETION
C
      NFILE = 25
      IF (BETA) NFILE = 26
      L2 = NDIM*(NDIM+1)/2
      CALL NBWRIT(DM,L2,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FENEWD(DM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      DIMENSION DM(1)
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
C FENEWD:  FETCH THE NEW DENSITY MATRIX (RAW AO BASIS) 
C
      NFILE = 25
      IF (BETA) NFILE = 26
      L2 = NDIM*(NDIM+1)/2
      CALL NBREAD(DM,L2,NFILE)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FEINFO(ICORE,ISWEAN)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      DIMENSION ICORE(12)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
      COMMON/NBBAS/LABEL(MAXBAS,6),LVAL(MAXBAS),IMVAL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
C  Restore wavefunction information from the NBO DAF:
C
C  Restore NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:
C
      NFILE = 3
      CALL NBREAD(ICORE,12,NFILE)
      NATOMS = ICORE(1)
      NDIM   = ICORE(2)
      NBAS   = ICORE(3)
      MUNIT  = ICORE(4)
      ROHF   = .FALSE.
      IF(ICORE(5).EQ.1)  ROHF  = .TRUE.
      UHF    = .FALSE.
      IF(ICORE(6).EQ.1)  UHF   = .TRUE.
      CI     = .FALSE.
      IF(ICORE(7).EQ.1)  CI    = .TRUE.
      OPEN   = .FALSE.
      IF(ICORE(8).EQ.1)  OPEN  = .TRUE.
      MCSCF  = .FALSE.
      IF(ICORE(9).EQ.1)  MCSCF = .TRUE.
      AUHF   = .FALSE.
      IF(ICORE(10).EQ.1) AUHF  = .TRUE.
      ORTHO  = .FALSE.
      IF(ICORE(11).EQ.1) ORTHO = .TRUE.
      ISWEAN = ICORE(12)
C
C  IF ISWEAN IS 1, SET ICORE(12) TO 0 AND WRITE TO NBO DAF.  NOTE, ISWEAN IS
C  SET TO 1 BY THE FEAOIN DRIVER ROUTINE.  THIS TELLS THE ENERGETIC ANALYSIS
C  ROUTINES TO SEARCH FOR THE $DEL KEYLIST.  ISWEAN IS RESET TO 0 HERE SO
C  THAT MULTIPLE DELETIONS CAN BE READ FROM A SINGLE $DEL KEYLIST:
C
      IF(ISWEAN.EQ.1) THEN
        ICORE(12) = 0
        CALL NBWRIT(ICORE,12,NFILE)
      END IF
      RETURN
      END
C*****************************************************************************
C
C  FREE FORMAT INPUT ROUTINES:
C
C      SUBROUTINE STRTIN(LFNIN)
C      SUBROUTINE RDCRD
C      SUBROUTINE IFLD(INT,ERROR)
C      SUBROUTINE RFLD(REAL,ERROR)
C      SUBROUTINE HFLD(KEYWD,LENG,ENDD)
C      SUBROUTINE FNDFLD
C      FUNCTION EQUAL(IA,IB,L)
C
C*****************************************************************************
C
C  USER  INSTRUCTIONS:
C
C     1. THE CHARACTER STRING "END" IS THE FIELD TERMINATING MARK:
C
C     2. COMMAS AND EQUAL SIGNS ARE TREATED AS EQUIVALENT TO BLANKS.
C          COMMAS, EQUAL SIGNS, AND BLANKS DELIMIT INPUT ITEMS.
C
C     3. ALL CHARACTERS TO THE RIGHT OF AN EXCLAMATION MARK ! ARE TREATED AS
C          COMMENTS, AND THE NEXT CARD IS READ IN WHEN THESE ARE ENCOUNTERED.
C
C     4. UPPER AND LOWER CASE CHARACTERS CAN BE READ BY THESE ROUTINES.
C          HOWEVER, LOWER CASE CHARACTERS ARE CONVERTED TO UPPER CASE
C          WHEN ENCOUNTERED.
C
C     5. TO READ IN DATA FOR THE FIRST TIME FROM LFN "LFNIN" (PERHAPS
C          AFTER USING THESE SUBROUTINES TO READ IN DATA FROM ANOTHER LFN),
C          OR TO CONTINUE READING IN DATA FROM LFNIN AFTER ENCOUNTERING
C          A FIELD TERMINATING MARK, CALL STRTIN(LFNIN)  (START INPUT)
C
C     6. TO FETCH THE NEXT NON-BLANK STRING OF CHARACTERS FROM LFN LFNIN,
C           CALL HFLD(KEYWD,LENGTH,END),
C            WHERE KEYWD   IS A VECTOR OF DIMENSION "LENGTH"  OR LONGER,
C                  LENGTH  IS THE MAXIMUM NUMBER OF CHARACTERS TO FETCH,
C                  END     MUST BE A DECLARED LOGICAL VARIABLE.
C           UPON RETURN,
C            END=.TRUE. IF A FIELD TERMINATING MARK WAS FOUND TO BE THE NEXT
C                 NON-BLANK CHARACTER STRING.  OTHERWISE, END=.FALSE.
C            END=.TRUE. AND LENGTH=0 MEANS THE END-OF-FILE WAS FOUND.
C            LENGTH IS CHANGED TO THE ACTUAL NUMBER OF CHARACTERS IN STRING
C                 IF THIS IS LESS THAN THE VALUE OF LENGTH SET BY THE CALLING
C                 PROGRAM.
C            KEYWD(1) THROUGH KEYWD(LENGTH) CONTAIN THE CHARACTER STRING,
C                 ONE CHARACTER PER ELEMENT OF KEYWD.
C
C     7. TO FETCH THE INTEGER VALUE OF THE NEXT CHARACTER STRING,
C           CALL IFLD(INT,ERROR),
C            WHERE INT     IS THE VARIABLE TO BE READ,
C                  ERROR   MUST BE A DECLARED LOGICAL VARIABLE.
C            UPON RETURN,
C             IF ERROR=.FALSE., AN INTEGER WAS FOUND AND PLACED IN "INT".
C             IF ERROR=.TRUE. AND INT.GT.0, A FIELD TERMINATING MARK WAS
C                 FOUND AS THE NEXT CHARACTER STRING.
C             IF ERROR=.TRUE. AND INT.LT.0, THE NEXT CHARACTER STRING FOUND
C                 WAS NEITHER AN INTEGER NOR A FIELD TERMINATING MARK.
C
C     8. TO FETCH THE REAL VALUE OF THE NEXT CHARACTER STRING,
C           (AN EXPONENT IS ALLOWED, WITH OR WITHOUT AN "E" OR "F".
C             IF NO LETTER IS PRESENT TO SIGNIFY THE EXPONENT FIELD,
C             A + OR - SIGN MUST START THE EXPONENT.  IF NO MANTISSA IS
C             PRESENT, THE EXPONENT FIELD MUST START WITH A LETTER, AND
C             THE MANTISSA IS SET TO ONE.)
C           CALL RFLD(REAL,ERROR),
C            WHERE REAL    IS THE VARIABLE TO BE READ,
C                  ERROR   MUST BE A DECLARED LOGICAL VARIABLE.
C            UPON RETURN,
C             IF ERROR=.FALSE., A REAL NUMBER WAS FOUND AND PLACED IN "REAL".
C             IF ERROR=.TRUE. AND REAL.GT.1, A FIELD TERMINATING MARK WAS
C                 FOUND AS THE NEXT CHARACTER STRING.
C             IF ERROR=.TRUE. AND REAL.LT.-1, THE NEXT CHARACTER STRING FOUND
C                 WAS NEITHER A REAL NUMBER NOR A FIELD TERMINATING MARK.
C
C     9. TO COMPARE THE CORRESPONDING FIRST L ELEMENTS OF EACH OF TWO VECTORS
C          IA(L) AND IB(L) TO SEE IF THE VECTORS ARE EQUIVALENT,
C           USE THE FUNCTION EQUAL(IA,IB,L).
C           EQUAL MUST BE DECLARED LOGICAL IN THE CALLING PROGRAM,
C            AND THE FUNCTION VALUE (.TRUE. OR .FALSE.) WILL TELL IF THE
C            VECTORS IA AND IB ARE EQUAL UP TO ELEMENT L.
C        NOTE: THIS FUNCTION IS USEFUL FOR DETERMINING IF A CHARACTER STRING
C          READ BY A CALL TO HFLD MATCHES A CERTAIN KEYWORD WHICH IS STORED
C          IN A VECTOR, ONE CHARACTER PER ELEMENT.
C
C
C*****************************************************************************
      SUBROUTINE STRTIN(LFNIN)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
      COMMON/NBCRD2/POINT,END,NEXT,EXP
      LOGICAL POINT,END,NEXT,EXP
C
C  INITIALIZE INPUT FROM LFN LFNIN:
C
      LFN  = LFNIN
      END  = .FALSE.
      NEXT = .TRUE.
      CALL RDCRD
C
      RETURN
      END
C*****************************************************************************
      SUBROUTINE RDCRD
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  SUBROUTINE NAME CHANGED FROM RDCARD, DUE TO CONFLICT WITH GAMESS:
C
      COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
      COMMON/NBCRD2/POINT,END,NEXT,EXP
      LOGICAL POINT,END,NEXT,EXP
C
      DATA IA,ICHARA,ICHARZ/1HA,1Ha,1Hz/
      DATA IBLNK,IQ,II/1H ,1H`,1HI/
C
C  READ IN THE NEXT CARD AT LFN:
C
      READ(LFN,1000,END=800,ERR=800) ICD
C
C  CHANGE ALL LOWER CASE CHARACTERS TO UPPER CASE:
C
      DO 10 I = 1,80
        IF(ICD(I).GE.ICHARA.AND.ICD(I).LE.ICHARZ) THEN
          ICD(I) = ICD(I) - ICHARA + IA
        END IF
   10 CONTINUE
C
C  TREAT TABS AS SPACES:
C
      ITAB = IBLNK + II - IQ
      DO 20 I = 1,80
	IF(ICD(I).EQ.ITAB) ICD(I) = IBLNK
   20 CONTINUE
C
C  RESET COLUMN POINTER, IPT:
C
      IPT = 1
      RETURN
C
C  END OF FILE ENCOUNTERED
C
  800 CONTINUE
      END = .TRUE.
      RETURN
C
 1000 FORMAT(80A1)
      END
C*****************************************************************************
      SUBROUTINE IFLD(INT,ERROR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ERROR
C
      COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
      COMMON/NBCRD2/POINT,END,NEXT,EXP
      LOGICAL POINT,END,NEXT,EXP
C
      DATA ZERO,ONE,SMALL/0.0D0,1.0D0,1.0D-3/
C
C  SEARCH LFN FOR THE NEXT STRING OF NON-BLANK CHARACTERS, SEE IF THEY
C  FORM AN INTEGER (IF NOT, ERROR=.TRUE.) AND, IF SO, PLACE ITS NUMERICAL
C  VALUE IN "INT":
C
      INT = 0
      CALL RFLD(REAL,ERROR)
C
C  IF DECIMAL POINT OR AN EXPONENT.LT.0, ERROR = .TRUE.:
C
      IF(EXP) GO TO 100
      IF(POINT) GO TO 100
      IF(NEXP.LT.0) GO TO 100
      IF(LENGTH.EQ.0) GO TO 100
      SIGN = ONE
      IF(REAL.LT.ZERO) SIGN = -ONE
      REAL = REAL + SMALL * SIGN
      INT = REAL
      RETURN
C
  100 ERROR = .TRUE.
      NEXT = .FALSE.
      RETURN
      END
C*****************************************************************************
      SUBROUTINE RFLD(REAL,ERROR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ERROR,EXPSGN,MANTIS
C
      COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
      COMMON/NBCRD2/POINT,END,NEXT,EXP
      LOGICAL POINT,END,NEXT,EXP
C
      DIMENSION NCHAR(15)
C
      DATA NCHAR/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H.,1H+,1H-,
     +  1HD,1HE/
      DATA ZERO,ONE,TEN/0.0D0,1.0D0,10.0D0/
C
C  SEARCH LFN FOR THE NEXT STRING OF NON-BLANK CHARACTERS, SEE IF THEY FORM
C  A REAL NUMBER (EXPONENT IS OPTIONAL) (IF NOT, ERROR=.TRUE.) AND, IF SO,
C  PLACE ITS NUMERICAL VALUE IN "REAL":
C
      REAL   = ZERO
      SIGN   = ONE
      NDEC   = 0
      ISEXP  = 1
      NEXP   = 0
      EXPSGN = .FALSE.
      EXP    = .FALSE.
      POINT  = .FALSE.
      ERROR  = .FALSE.
      MANTIS = .FALSE.
      END    = .FALSE.
C
C  FIND THE NEXT STRING OF NON-BLANK CHARACTERS, "LOOK", OF LENGTH "LENGTH":
C
      IF(NEXT) CALL FNDFLD
      IF(END) GO TO 300
      IF(LENGTH.EQ.0) GO TO 300
C
C  FIND THE NUMERICAL VALUE OF THE CHARACTERS IN "LOOK":
C
      DO 200 J = 1,LENGTH
        LK = LOOK(J)
        DO 20 I = 1,15
          IF(LK.EQ.NCHAR(I)) GO TO 40
   20   CONTINUE
        GO TO 300
   40   K = I - 11
        IF(K) 60,80,100
C
C  THIS CHARACTER IS A NUMBER:
C
   60     CONTINUE
          IF(EXP) GO TO 70
C
C  ADD DIGIT TO MANTISSA:
C
          MANTIS = .TRUE.
          REAL = REAL * TEN + FLOAT(I - 1)
C
C  IF WE ARE TO THE RIGHT OF A DECIMAL POINT, INCREMENT THE DECIMAL COUNTER:
C
          IF(POINT) NDEC = NDEC + 1
          GO TO 200
C
C  ADD DIGIT TO EXPONENT:
C
   70     NEXP = NEXP * 10 + (I - 1)
          GO TO 200
C
C  DECIMAL POINT:
C
   80     IF(POINT) GO TO 300
          POINT = .TRUE.
          GO TO 200
C
C  EXPONENT (+,-,D,E):
C
  100     CONTINUE
          GO TO (110,130,150,150), K
C
C  PLUS SIGN: IF NOT FIRST CHARACTER, COUNT AS PART OF EXPONENT:
C
  110       IF(J.EQ.1) GO TO 200
              IF(EXPSGN) GO TO 200
              EXPSGN = .TRUE.
              EXP = .TRUE.
              GO TO 200
C
C  MINUS SIGN: IF NOT FIRST CHARACTER, COUNT AS PART OF EXPONENT:
C
  130       IF(J.NE.1) GO TO 140
              SIGN = -ONE
              GO TO 200
  140         ISEXP = -1
              IF(EXPSGN) GO TO 200
              EXPSGN = .TRUE.
              EXP = .TRUE.
              GO TO 200
C
C  D OR E: START OF EXPONENT:
C
  150       IF(EXP) GO TO 300
            EXP = .TRUE.
  200  CONTINUE
C
C  SET FINAL VALUE OF REAL (IF NO MANTISSA, BUT EXPONENT PRESENT,
C  SET MANTISSA TO ONE):
C
      IF(EXP.AND..NOT.MANTIS) REAL = ONE
      REAL = REAL * SIGN * (TEN**(-NDEC+ISEXP*NEXP))
      NEXT = .TRUE.
      RETURN
C
C  NO REAL NUMBER FOUND, OR FIELD TERMINATING MARK:
C
  300 CONTINUE
      ERROR = .TRUE.
      REAL  = -TEN
      IF(END) REAL = TEN
      RETURN
      END
C*****************************************************************************
      SUBROUTINE HFLD(KEYWD,LENG,ENDD)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ENDD,EQUAL
C
      COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
      COMMON/NBCRD2/POINT,END,NEXT,EXP
      LOGICAL POINT,END,NEXT,EXP
C
      DIMENSION KEYWD(LENG),KEND(3)
C
      DATA NBLA/1H /
      DATA KEND/1HE,1HN,1HD/
C
C  SEARCH LFN AND FIND NEXT NON-BLANK STRING OF CHARACTERS AND PLACE
C  IN THE VECTOR "KEYWD".  LENG, FROM THE CALLING PROGRAM, IS MAXIMUM
C  LENGTH OF STRING TO PUT IN THE VECTOR KEYWD.  IF "LENGTH" IS LESS
C  THAN "LENG", LENG IS SET TO LENGTH UPON RETURN:
C
      IF(NEXT) CALL FNDFLD
      ENDD  = END
      LENG1 = LENG
      LENG  = MIN0(LENGTH,LENG)
C
C  PLACE LENG CHARACTERS INTO KEYWD:
C
      DO 10 I = 1,LENG
        KEYWD(I) = LOOK(I)
   10 CONTINUE
C
C  FILL THE REST OF KEYWD WITH BLANKS:
C
      DO 20 I = LENG+1,LENG1
        KEYWD(I) = NBLA
   20 CONTINUE
      NEXT = .TRUE.
C
C  CHECK FOR END OF INPUT:
C
      IF(EQUAL(LOOK,KEND,3)) ENDD = .TRUE.
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FNDFLD
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBCRD1/ICD(80),LOOK(80),LENGTH,IPT,LFN,NEXP
      COMMON/NBCRD2/POINT,END,NEXT,EXP
      LOGICAL POINT,END,NEXT,EXP
C
      DATA NBLA/1H /,NCOM/1H,/,NEXC/1H!/,NEQ/1H=/
C
C  FIND NEXT NON-BLANK STRING OF CHARACTERS IN LFN.  READ IN ANOTHER LINE
C  OF LFN UNTIL NON-BLANK CHARACTERS ARE FOUND AND PLACE THEM IN "LOOK",
C  OF LENGTH "LENGTH":
C
      IF(END) GO TO 35
      IF(IPT.GE.80) CALL RDCRD
      IF(END) GO TO 35
C
C  LOOK FOR START OF FIELD.  SKIP TO NEXT CARD IF "!" IS ENCOUNTERED
C  (COMMENT FIELD):
C
   10 CONTINUE
      DO 20 NCOL = IPT,80
        ICARD = ICD(NCOL)
        IF(ICARD.EQ.NEXC) GO TO 30
        IF(ICARD.NE.NBLA.AND.ICARD.NE.NCOM.AND.ICARD.NE.NEQ) GO TO 40
   20 CONTINUE
C
C  NOTHING ADDITIONAL FOUND ON THIS CARD, CONTINUE WITH THE NEXT CARD:
C
   30 CALL RDCRD
      IF(.NOT.END) GO TO 10
C
C  END OF FILE FOUND:
C
   35 LENGTH = 0
      RETURN
C
C  LOOK FOR THE END OF THIS FIELD, COUNTING CHARACTERS AS WE GO AND
C  STORING THESE CHARACTER IN LOOK:
C
   40 M = 0
      DO 80 MCOL = NCOL,80
        ICHAR = ICD(MCOL)
        IF(ICHAR.EQ.NBLA.OR.ICHAR.EQ.NCOM.OR.ICHAR.EQ.NEQ) GO TO 100
        M = M + 1
        LOOK(M) = ICHAR
   80 CONTINUE
C
C  SET LENGTH TO THE LENGTH OF THE NEW STRING IN LOOK AND RESET IPT TO
C  THE NEXT SPACE AFTER THIS STRING:
C
  100 LENGTH = M
      IPT = MCOL
      NEXT = .FALSE.
      RETURN
      END
C*****************************************************************************
      FUNCTION EQUAL(IA,IB,L)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL EQUAL
C
      DIMENSION IA(L),IB(L)
C
C  TEST IF THE FIRST L ELEMENTS OF VECTORS IA AND IB ARE EQUAL:
C
      EQUAL = .FALSE.
      DO 10 I = 1,L
        IF(IA(I).NE.IB(I)) GO TO 20
   10 CONTINUE
      EQUAL = .TRUE.
   20 RETURN
      END
C*****************************************************************************
C
C  OTHER SYSTEM-INDEPENDENT I/O ROUTINES:
C
C      SUBROUTINE GENINP(NEWDAF)
C      SUBROUTINE NBOINP(NBOOPT,IDONE)
C      SUBROUTINE CORINP(IESS,ICOR)
C      SUBROUTINE CHSINP(IESS,ICHS)
C      SUBROUTINE DELINP(NBOOPT,IDONE)
C
C      SUBROUTINE RDCORE(JCORE)
C      SUBROUTINE WRPPNA(T,OCC,IFLG)
C      SUBROUTINE RDPPNA(T,OCC,IFLG)
C      SUBROUTINE WRTNAO(T,IFLG)
C      SUBROUTINE RDTNAO(DM,T,SCR,IFLG)
C      SUBROUTINE WRTNAB(T,IFLG)
C      SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG)
C      SUBROUTINE WRTNBO(T,BNDOCC,IFLG)
C      SUBROUTINE WRNLMO(T,DM,IFLG)
C      SUBROUTINE WRBAS(SCR,ISCR,LFN)
C      SUBROUTINE WRARC(SCR,ISCR,LFN)
C
C      SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG)
C      SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL)
C      SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN)
C      SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR)
C      SUBROUTINE ALTOUT(A,MR,MC,NR,NC)
C      SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR)
C      FUNCTION IOINQR(IFLG)
C      SUBROUTINE LBLAO
C      SUBROUTINE LBLNAO
C      SUBROUTINE LBLNBO
C      SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR)
C
C*****************************************************************************
      SUBROUTINE GENINP(NEWDAF)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL NEWDAF,END,ERROR,EQUAL                                       
C                                                                       
      DIMENSION KEYWD(6),KGEN(4),KEND(4),KREUSE(5),KNBAS(4),KNATOM(6),  
     +      KUPPER(5),KOPEN(4),KORTHO(5),KBOHR(4),KBODM(4),KEV(2),     
     +      KCUBF(6)                                                    
C                                                                       
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO 
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,       
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    
     + JCORE,JPRINT(60)                                                 
      COMMON/NBGEN/REUSE,UPPER,BOHR,DENOP                              
      LOGICAL REUSE,UPPER,BOHR,DENOP                                    
C                                                                       
      DATA KGEN/1H$,1HG,1HE,1HN/,KEND/1H$,1HE,1HN,1HD/,                 
     + KREUSE/1HR,1HE,1HU,1HS,1HE/,KNBAS/1HN,1HB,1HA,1HS/,              
     + KNATOM/1HN,1HA,1HT,1HO,1HM,1HS/,KUPPER/1HU,1HP,1HP,1HE,1HR/,     
     + KOPEN/1HO,1HP,1HE,1HN/,KORTHO/1HO,1HR,1HT,1HH,1HO/,              
     + KBOHR/1HB,1HO,1HH,1HR/,KBODM/1HB,1HO,1HD,1HM/,
     + KEV/1HE,1HV/KCUBF/1HC,1HU,1HB,1HI,1HC,1HF/                       
C                                                                       
C  Initialize variables:                                                
C                                                                       
      NBAS   = 0                                                        
      NATOMS = 0                                                        
      MUNIT  = 0                                                        
      REUSE  = .FALSE.                                                  
      UPPER  = .FALSE.                                                  
      BOHR   = .FALSE.                                                  
      DENOP  = .TRUE.                                                  
C                                                                       
C  Search LFNIN for $GEN:                                               
C                                                                       
      REWIND(LFNIN)                                                     
   10 CALL STRTIN(LFNIN)                                                
      LEN = 6                                                           
      CALL HFLD(KEYWD,LEN,END)                                          
      IF(LEN.EQ.0.AND.END) STOP 'No $GEN keylist in the input file' 
      IF(.NOT.EQUAL(KEYWD,KGEN,4)) GOTO 10                              
C                                                                       
C  $GEN has been found, now read keywords:                              
C                                                                       
   20 LEN = 6                                                           
      CALL HFLD(KEYWD,LEN,END)                                          
      IF(EQUAL(KEYWD,KEND,4)) GOTO 700                                  
C                                                                       
C  Keyword REUSE -- reuse data already stored on the NBO DAF:           
C                                                                       
      IF(EQUAL(KEYWD,KREUSE,5)) THEN                                    
        REUSE = .TRUE.                                                  
        GOTO 20                                                         
      END IF                                                            
C                                                                       
C  Keyword NBAS -- Specify the number of basis functions:               
C                                                                       
      IF(EQUAL(KEYWD,KNBAS,4)) THEN                                     
        CALL IFLD(NBAS,ERROR)                                           
        IF(ERROR) STOP 'Error reading in number of basis functions NBAS'
        GOTO 20                                                         
      END IF                                                            
C                                                                       
C  Keyword NATOMS -- Specify the number of atoms:                       
C                                                                       
      IF(EQUAL(KEYWD,KNATOM,4)) THEN                                    
        CALL IFLD(NATOMS,ERROR)                                         
        IF(ERROR) STOP 'Error reading in number of atoms NATOMS'        
        GOTO 20                                                         
      END IF                                                            
C                                                                       
C  Keyword UPPER -- Read only upper triangular portions of matrices:    
C                                                                       
      IF(EQUAL(KEYWD,KUPPER,5)) THEN                                    
        UPPER = .TRUE.                                                  
        GOTO 20                                                         
      END IF                                                            
C                                                                       
C  Keyword OPEN -- Open shell species (alpha and beta matrices read):   
C                                                                       
      IF(EQUAL(KEYWD,KOPEN,4)) THEN                                     
        OPEN = .TRUE.                                                   
        GOTO 20                                                         
      END IF                                                            
C                                                                       
C  Keyword ORTHO -- Orthogonal basis set (Skip NAO analysis):           
C                                                                       
      IF(EQUAL(KEYWD,KORTHO,5)) THEN                                    
        ORTHO = .TRUE.                                                  
        GOTO 20                                                         
      END IF                                                            
C                                                                       
C  Keyword BOHR -- Atomic coordinates, dipole integrals in bohr:        
C                                                                       
      IF(EQUAL(KEYWD,KBOHR,4)) THEN                                     
        BOHR = .TRUE.                                                   
        GOTO 20                                                         
      END IF                                                            
C                                                                       
C  Keyword BODM -- Input bond order matrix:
C                                                                       
      IF(EQUAL(KEYWD,KBODM,4)) THEN                                    
        DENOP = .FALSE.                                                  
        GOTO 20                                                         
      END IF                                                            
C                                                                       
C  Keyword EV -- Expectation values of the Fock operator are in eV:     
C                                                                       
      IF(EQUAL(KEYWD,KEV,2)) THEN                                       
        MUNIT = 1                                                       
        GOTO 20                                                         
      END IF                                                            
C                                                                       
C  Keyword CUBICF -- Use set of cubic f functions:                       
C                                                                       
      IF(EQUAL(KEYWD,KCUBF,6)) THEN                                     
        IWCUBF = 1                                                      
        GOTO 20                                                         
      END IF                                                            
C                                                                       
C  Unknown keyword -- halt program:                                     
C                                                                       
      WRITE(LFNPR,900) KEYWD                                            
      STOP                                                              
C                                                                       
C  End of $GEN input encountered, make sure GENNBO has all info needed: 
C                                                                       
  700 CONTINUE                                                          
      IF(REUSE) THEN                                                    
        NEWDAF = .FALSE.                                                   
        RETURN                                                          
      ELSE                                                              
        NEWDAF = .TRUE.                                                    
      ENDIF                                                             
C                                                                       
      NDIM = NBAS                                                       
      IF(NBAS.LE.0) STOP 'NBAS must be specified in $GEN keylist'     
      IF(NBAS.GT.MAXBAS) STOP 'Increase parameter MAXBAS'               
      IF(NATOMS.LE.0) STOP 'NATOMS must be specified in $GEN keylist' 
      IF(NATOMS.GT.MAXATM) STOP 'Increase parameter MAXATM'             
      RETURN                                                            
C                                                                       
  900 FORMAT(1X,'Unrecognized keyword >',6A1,'<')                       
      END
C*****************************************************************************
      SUBROUTINE NBOINP(NBOOPT,IDONE)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL END,EQUAL
      DIMENSION NBOOPT(10)
      DIMENSION KEYWD(6),KNBO(4)
C
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DATA KNBO/1H$,1HN,1HB,1HO/
C
C  If NBOOPT(1) = 1, don't search for keywords, just continue with
C  default options:
C
      IF(NBOOPT(1).EQ.1) THEN
        IDONE = 0
        RETURN
      END IF
C
C  If this is the GAMESS, HONDO, or general version of the NBO program,
C  rewind the input file before searching for $NBO:
C
      IREP = 1
      IF(NBOOPT(10).EQ.0) IREP = 0
      IF(NBOOPT(10).EQ.6) IREP = 0
      IF(NBOOPT(10).EQ.7) IREP = 0
      IF(IREP.EQ.0) REWIND(LFNIN)
C
C  Search input file for $NBO:
C
   10 CALL STRTIN(LFNIN)
      LEN = 6
      CALL HFLD(KEYWD,LEN,END)
      IF(EQUAL(KEYWD,KNBO,4)) GOTO 50
      IF(LEN.EQ.0.AND.END) GOTO 60
      GOTO 10
C
C  $NBO found -- continue with the NBO analysis:
C
   50 CONTINUE
      IDONE = 0
      RETURN
C
C  End of file encountered -- Stop NBO analysis, except for the general
C  version of the program (set NBOOPT(1) so keywords are not read):
C
   60 CONTINUE
      IF(IREP.EQ.1) THEN
        REWIND(LFNIN)
        IREP = IREP + 1
        GOTO 10
      ELSE IF(NBOOPT(10).EQ.0) THEN
        NBOOPT(1) = 1
        IDONE = 0
      ELSE
        IDONE = 1
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE CORINP(IESS,ICOR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL END,EQUAL
C
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION KEYWD(6),KCOR(4),KCHS(4),KDEL(4),KNBO(4),KNRT(4)
C
      DATA KCOR/1H$,1HC,1HO,1HR/,KCHS/1H$,1HC,1HH,1HO/,
     +     KDEL/1H$,1HD,1HE,1HL/,KNBO/1H$,1HN,1HB,1HO/,
     +     KNRT/1H$,1HN,1HR,1HT/
C
C  If ICOR is set to -1, do not read in the $CORE keylist:
C
      IF(ICOR.EQ.-1) RETURN
C
C  If this is the GAMESS, HONDO, or general version of the NBO program,
C  rewind the input file before searching for $CORE:
C
      IREP = 1
      IF(IESS.EQ.0) IREP = 0
      IF(IESS.EQ.6) IREP = 0
      IF(IESS.EQ.7) IREP = 0
      IF(IREP.EQ.0) REWIND(LFNIN)
C
C  Search input file for $CORE:
C
   10 CALL STRTIN(LFNIN)
      LEN = 6
      CALL HFLD(KEYWD,LEN,END)
      IF(EQUAL(KEYWD,KCOR,4)) GOTO 50
      IF(EQUAL(KEYWD,KNBO,4)) GOTO 60
      IF(EQUAL(KEYWD,KCHS,4)) GOTO 60
      IF(EQUAL(KEYWD,KDEL,4)) GOTO 60
      IF(EQUAL(KEYWD,KNRT,4)) GOTO 60
      IF(LEN.EQ.0.AND.END) GOTO 70
      GOTO 10
C
C  $CORE found:
C
   50 CONTINUE
      ICOR = 1
      RETURN
C
C  $NBO, $CHOOSE, $DEL -- discontinue the search for $CORE (GAUSSIAN, AMPAC)
C        or $NRT          continue searching for $CORE (GENNBO, GAMESS, HONDO)
C
   60 CONTINUE
      IF(IREP.EQ.0) GOTO 10
      BACKSPACE(LFNIN)
      ICOR = 0
      RETURN
C
C  End of file encountered:
C
   70 CONTINUE
      ICOR = 0
      RETURN
      END
C*****************************************************************************
      SUBROUTINE CHSINP(IESS,ICHS)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL END,EQUAL
C
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION KEYWD(6),KCHS(4),KDEL(4),KNBO(4),KNRT(4)
C
      DATA KCHS/1H$,1HC,1HH,1HO/,KDEL/1H$,1HD,1HE,1HL/,
     +     KNBO/1H$,1HN,1HB,1HO/,KNRT/1H$,1HN,1HR,1HT/
C
C  If ICHS is set to -1, do not search for the $CHOOSE keylist:
C
      IF(ICHS.EQ.-1) RETURN
C
C  If this is the GAMESS, HONDO, or general version of the NBO program,
C  rewind the input file before searching for $CHOOSE:
C
      IREP = 1
      IF(IESS.EQ.0) IREP = 0
      IF(IESS.EQ.6) IREP = 0
      IF(IESS.EQ.7) IREP = 0
      IF(IREP.EQ.0) REWIND(LFNIN)
C
C  Search input file for $CHOOSE:
C
   10 CALL STRTIN(LFNIN)
      LEN = 6
      CALL HFLD(KEYWD,LEN,END)
      IF(EQUAL(KEYWD,KCHS,4)) GOTO 50
      IF(EQUAL(KEYWD,KNBO,4)) GOTO 60
      IF(EQUAL(KEYWD,KDEL,4)) GOTO 60
      IF(EQUAL(KEYWD,KNRT,4)) GOTO 60
      IF(LEN.EQ.0.AND.END) GOTO 70
      GOTO 10
C
C  $CHOOSE found:
C
   50 CONTINUE
      ICHS = 1
      RETURN
C
C  $NBO, $DEL found -- discontinue the search for $CHOOSE (GAUSSIAN, AMPAC)
C      or $NRT         continue searching for $CHOOSE (GENNBO, GAMESS, HONDO)
C
   60 CONTINUE
      IF(IREP.EQ.0) GOTO 10
      BACKSPACE(LFNIN)
      ICHS = 0
      RETURN
C
C  End of file encountered:
C
   70 CONTINUE
      ICHS = 0
      RETURN
      END
C*****************************************************************************
      SUBROUTINE DELINP(NBOOPT,IDONE)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL END,EQUAL
      DIMENSION NBOOPT(10)
      DIMENSION KEYWD(6),KDEL(4),KNBO(4)
C
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DATA KDEL/1H$,1HD,1HE,1HL/,KNBO/1H$,1HN,1HB,1HO/
C
C  If this is the GAMESS, HONDO, or general version of the NBO program,
C  rewind the input file before searching for $DEL:
C
      IREP = 1
      IF(NBOOPT(10).EQ.0) IREP = 0
      IF(NBOOPT(10).EQ.6) IREP = 0
      IF(NBOOPT(10).EQ.7) IREP = 0
      IF(IREP.EQ.0) REWIND(LFNIN)
C
C  Search input file for $DEL:
C
   10 CALL STRTIN(LFNIN)
      LEN = 6
      CALL HFLD(KEYWD,LEN,END)
      IF(EQUAL(KEYWD,KDEL,4)) GOTO 50
      IF(EQUAL(KEYWD,KNBO,4)) GOTO 60
      IF(LEN.EQ.0.AND.END) GOTO 70
      GOTO 10
C
C  $DEL found -- continue with the NBO energetic analysis:
C
   50 CONTINUE
      IDONE = 0
      RETURN
C
C  $NBO found -- discontinue the search for $DEL (GAUSSIAN, AMPAC)
C                continue searching for $DEL (GENNBO, GAMESS, HONDO)
C
   60 CONTINUE
      IF(IREP.EQ.0) GOTO 10
      BACKSPACE(LFNIN)
      IDONE = 1
      RETURN
C
C  End of file encountered -- Stop NBO energetic analysis
C
   70 CONTINUE
      IF(IREP.EQ.1) THEN
        REWIND(LFNIN)
        IREP = IREP + 1
        GOTO 10
      ELSE
        IDONE = 1
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE RDCORE(JCORE)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL ERROR
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
C  Initialize the atomic core array:
C
      DO 10 I = 1,NATOMS
        IATCR(I) = -1
   10 CONTINUE
C
C  Read in modifications to the nominal core table:
C
      IF(JCORE.EQ.1) THEN
        WRITE(LFNPR,900)
   30   CALL IFLD(II,ERROR)
        IF(ERROR) GOTO 40
        IF(II.LT.1.OR.II.GT.NATOMS) GOTO 810
        CALL IFLD(JJ,ERROR)
        IF(ERROR) GOTO 820
        IF(JJ.LT.0) GOTO 830
        IATCR(II) = JJ
        GOTO 30
      END IF
   40 CONTINUE
      RETURN
C
  810 WRITE(LFNPR,910) II
      STOP
C
  820 WRITE(LFNPR,920) II
      STOP
C
  830 WRITE(LFNPR,930) JJ,II
      STOP
C
  900 FORMAT(/1X,'Modified core list read from the $CORE keylist')
  910 FORMAT(/1X,'ATOM ',I4,' not found on this molecule')
  920 FORMAT(/1X,'No core orbitals selected for atom ',I4)
  930 FORMAT(/1X,I4,' core orbitals on atom ',I4,' does not make sense')
      END
C*****************************************************************************
      SUBROUTINE WRPPNA(T,OCC,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
C
      DIMENSION T(NDIM,NDIM),OCC(NDIM)
      CHARACTER*80 TITLE
C
C  Write the PNAO information to the external file ABS(IFLG):
C
C  NOTE: This is the pure-AO to PNAO transformation, not the raw AO
C        to PNAO transform.
C
      TITLE = 'PNAOs in the PAO basis:'
      CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,-1,IFLG)
C
C  Write the NAO orbital labels to the external file:
C
      LFN = ABS(IFLG)
      WRITE(LFN,900) (NAOCTR(J),J=1,NBAS)
      WRITE(LFN,900) (NAOL(J),J=1,NBAS)
      WRITE(LFN,900) (LSTOCC(J),J=1,NBAS)
C
C  Write the PNAO orbital occupancies:
C
      WRITE(LFN,910) (OCC(J),J=1,NBAS)
      RETURN
C
  900 FORMAT(1X,20I4)
  910 FORMAT(1X,5F15.9)
      END
C*****************************************************************************
      SUBROUTINE RDPPNA(T,OCC,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION T(NDIM,NDIM),OCC(NDIM)
      DIMENSION JOB(20)
      LOGICAL ERROR
C
C  Read the PNAO information from the external file ABS(IFLG/1000)
C
C  NOTE: This is the pure-AO to PNAO transformation, not the raw AO
C        to PNAO transform.
C
      LFN = ABS(IFLG/1000)
      WRITE(LFNPR,900)
C
      IF(ISPIN.GE.0) REWIND(LFN)
      CALL AREAD(T,NDIM,NBAS,NBAS,JOB,LFN,ERROR)
      IF(ERROR) GOTO 800
      IF(ISPIN.GE.0) WRITE(LFNPR,910) JOB
      IF(ISPIN.LT.0) WRITE(LFNPR,920)
C
C  Read in orbital labels from LFN:
C
      READ(LFN,1000,END=810) (NAOCTR(J),J=1,NBAS)
      READ(LFN,1000,END=810) (NAOL(J),J=1,NBAS)
      READ(LFN,1000,END=810) (LSTOCC(J),J=1,NBAS)
C
C  Read orbital occupancies:
C
      READ(LFN,1010,END=820) (OCC(J),J=1,NBAS)
      RETURN
C
  800 WRITE(LFNPR,950) LFN
      STOP
C
  810 WRITE(LFNPR,960) LFN
      STOP
C
  820 WRITE(LFNPR,970) LFN
      STOP
C
  900 FORMAT(/1X,'PNAO basis set from a previous calculation used:')
  910 FORMAT(1X,20A4)
  920 FORMAT(/1X,'See alpha NBO output for title of the transformation')
  950 FORMAT(/1X,'Error reading PAO to PNAO transformation from LFN',I3)
  960 FORMAT(/1X,'Error reading PNAO orbital labels from LFN',I3)
  970 FORMAT(/1X,'Error reading PNAO orbital occupancies from LFN',I3)
 1000 FORMAT(1X,20I4)
 1010 FORMAT(1X,5F15.9)
      END
C*****************************************************************************
      SUBROUTINE WRTNAO(T,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
      DIMENSION T(NDIM,NDIM)
      CHARACTER*80 TITLE
C
C  NOTE: T is the PNAO overlap matrix on return to the calling routine
C
C  Fetch the AO to NAO transformation from the NBO DAF, and write
C  it to the external file ABS(IFLG):
C
      CALL FETNAO(T)
      TITLE = 'NAOs in the AO basis:'
      CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG)
C
C  Write the NAO orbital labels to the external file:
C
      LFN = ABS(IFLG)
      WRITE(LFN,900) (NAOCTR(J),J=1,NBAS)
      WRITE(LFN,900) (NAOL(J),J=1,NBAS)
      WRITE(LFN,900) (LSTOCC(J),J=1,NBAS)
C
C  Fetch the PNAO overlap matrix from the NBO DAF, and store only the
C  upper triangular portion on the external file:
C
      CALL FESNAO(T)
      TITLE = 'PNAO overlap matrix:'
      CALL AOUT(T,NDIM,-NBAS,NBAS,TITLE,2,IFLG)
      RETURN
C
  900 FORMAT(1X,20I4)
      END
C*****************************************************************************
      SUBROUTINE RDTNAO(DM,T,SCR,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),LSTEMT(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),SCR(NDIM)
      DIMENSION JOB(20)
      LOGICAL ERROR
C
C  NOTE: T is the PNAO overlap matrix on return to the calling routine
C        DM is the NAO density matrix on return
C
C  Read in AO to NAO transformation from the external file ABS(IFLG/1000),
C  and store it on the NBO DAF:
C
      LFN = ABS(IFLG/1000)
      WRITE(LFNPR,900)
C
      REWIND(LFN)
      CALL AREAD(T,NDIM,NBAS,NBAS,JOB,LFN,ERROR)
      IF(ERROR) GOTO 800
      WRITE(LFNPR,910) JOB
      CALL SVTNAO(T)
C
C  Transform the AO density matrix, presently in DM, to the NAO basis:
C
      CALL SIMTRS(DM,T,SCR,NDIM,NBAS)
C
C  Read in orbital labels from LFN:
C
      READ(LFN,1000,END=810) (NAOCTR(J),J=1,NBAS)
      READ(LFN,1000,END=810) (NAOL(J),J=1,NBAS)
      READ(LFN,1000,END=810) (LSTOCC(J),J=1,NBAS)
C
C  Read the PNAO overlap from LFN, and save this matrix on the NBO DAF:
C
      CALL AREAD(T,NDIM,-NBAS,NBAS,JOB,LFN,ERROR)
      IF(ERROR) GOTO 820
      CALL SVSNAO(T)
      RETURN
C
  800 WRITE(LFNPR,950) LFN
      STOP
C
  810 WRITE(LFNPR,960) LFN
      STOP
C
  820 WRITE(LFNPR,970) LFN
      STOP
C
  900 FORMAT(/1X,'NAO basis set from a previous calculation used:')
  910 FORMAT(1X,20A4)
  950 FORMAT(/1X,'Error reading AO to NAO transformation from LFN',I3)
  960 FORMAT(/1X,'Error reading NAO orbital labels from LFN',I3)
  970 FORMAT(/1X,'Error reading PNAO overlap matrix from LFN',I3)
 1000 FORMAT(1X,20I4)
      END
C*****************************************************************************
      SUBROUTINE WRTNAB(T,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
C
      DIMENSION T(NDIM,NDIM)
      CHARACTER*80 TITLE
C
C  Write the NAO to NBO transformation and NBO info to external file
C  ABS(IFLG):
C
      TITLE = 'NBOs in the NAO basis:'
      CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,2,IFLG)
C
C  Write the NBO labels:
C
      LFN = ABS(IFLG)
      DO 10 I = 1,NBAS
        WRITE(LFN,900) (LABEL(I,J),J=1,6),IBXM(I)
   10 CONTINUE
      RETURN
C
  900 FORMAT(1X,A2,A1,4I3,3X,I3)
      END
C*****************************************************************************
      SUBROUTINE RDTNAB(T,DM,BNDOCC,SCR,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM),BNDOCC(NDIM),SCR(NDIM)
      DIMENSION JOB(20)
      LOGICAL ERROR
C
C  Read the NAO to NBO transformation matrix from the external file
C  ABS(IFLG/1000).  Also read the NBO labels, the NBO occupancies,
C  and transform the input NAO density matrix to the NBO basis:
C
      LFN = ABS(IFLG/1000)
      WRITE(LFNPR,900)
C
      IF(ISPIN.GE.0) REWIND(LFN)
      CALL AREAD(T,NDIM,NBAS,NBAS,JOB,LFN,ERROR)
      IF(ERROR) GOTO 800
      IF(ISPIN.GE.0) WRITE(LFNPR,910) JOB
      IF(ISPIN.LT.0) WRITE(LFNPR,920)
C
C  Read the NBO labels:
C
      DO 10 I = 1,NBAS
        READ(LFN,1000,END=810) (LABEL(I,J),J=1,6),IBXM(I)
   10 CONTINUE
C
C  Transform the NAO density matrix, DM, to the NBO basis, and store the
C  NBO occupancies in BNDOCC:
C
      CALL SIMTRS(DM,T,SCR,NDIM,NBAS)
      DO 20 I = 1,NBAS
        BNDOCC(I) = DM(I,I)
   20 CONTINUE
      RETURN
C
  800 WRITE(LFNPR,950) LFN
      STOP
C
  810 WRITE(LFNPR,960) LFN
      STOP
C
  900 FORMAT(/1X,'NAO to NBO transformation from a previous ',
     + 'calculation will be used:')
  910 FORMAT(1X,20A4)
  920 FORMAT(/1X,'See alpha NBO output for title of the transformation')
  950 FORMAT(/1X,'Error reading NAO to NBO transformation from LFN',I3)
  960 FORMAT(/1X,'Error reading NBO orbital labels from LFN',I3)
 1000 FORMAT(1X,A2,A1,4I3,3X,I3)
      END
C*****************************************************************************
      SUBROUTINE WRTNBO(T,BNDOCC,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION T(NDIM,NDIM),BNDOCC(1)
      CHARACTER*80 TITLE
C
C  Write the AO to NBO transformation matrix and NBO info to the external
C  file ABS(IFLG):
C
      TITLE = 'NBOs in the AO basis:'
      CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG)
C
C  Write out the NBO occupancies:
C
      LFN = ABS(IFLG)
      WRITE(LFN,900) (BNDOCC(J),J=1,NBAS)
C
C  Write out NBOUNI, NBOTYP, LABEL, IBXM, and IATNO:
C
      WRITE(LFN,910) (NBOUNI(J),J=1,NBAS)
      WRITE(LFN,910) (NBOTYP(J),J=1,NBAS)
      WRITE(LFN,920) (LABEL(J,1),J=1,NBAS)
      WRITE(LFN,920) (LABEL(J,2),J=1,NBAS)
      WRITE(LFN,910) (LABEL(J,3),J=1,NBAS)
      WRITE(LFN,910) (LABEL(J,4),J=1,NBAS)
      WRITE(LFN,910) (LABEL(J,5),J=1,NBAS)
      WRITE(LFN,910) (LABEL(J,6),J=1,NBAS)
      WRITE(LFN,910) (IBXM(J),J=1,NBAS)
      WRITE(LFN,910) (IATNO(J),J=1,NATOMS)
      RETURN
C
  900 FORMAT(1X,5F15.9)
  910 FORMAT(1X,20I3)
  920 FORMAT(1X,20A3)
      END
C*****************************************************************************
      SUBROUTINE WRNLMO(T,DM,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION T(NDIM,NDIM),DM(NDIM,NDIM)
      CHARACTER*80 TITLE
C
C  Write the AO to NLMO transformation matrix and NLMO info to the external
C  file ABS(IFLG):
C
      TITLE = 'NLMOs in the AO basis:'
      CALL AOUT(T,NDIM,NBAS,NBAS,TITLE,1,IFLG)
C
C  Write out the NLMO occupancies:
C
      LFN = ABS(IFLG)
      WRITE(LFN,900) (DM(J,J),J=1,NBAS)
C
C  Write out NBOUNI, NBOTYP, LABEL, IBXM, and IATNO:
C
      WRITE(LFN,910) (NBOUNI(J),J=1,NBAS)
      WRITE(LFN,910) (NBOTYP(J),J=1,NBAS)
      WRITE(LFN,920) (LABEL(J,1),J=1,NBAS)
      WRITE(LFN,920) (LABEL(J,2),J=1,NBAS)
      WRITE(LFN,910) (LABEL(J,3),J=1,NBAS)
      WRITE(LFN,910) (LABEL(J,4),J=1,NBAS)
      WRITE(LFN,910) (LABEL(J,5),J=1,NBAS)
      WRITE(LFN,910) (LABEL(J,6),J=1,NBAS)
      WRITE(LFN,910) (IBXM(J),J=1,NBAS)
      WRITE(LFN,910) (IATNO(J),J=1,NATOMS)
      RETURN
C
  900 FORMAT(1X,5F15.9)
  910 FORMAT(1X,20I3)
  920 FORMAT(1X,20A3)
      END
C*****************************************************************************
      SUBROUTINE WRBAS(SCR,ISCR,LFN)
C*****************************************************************************
C
C  Save the AO basis set information on an external file:
C
C-----------------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION SCR(1),ISCR(1)
C
C  Fetch the number of shells NSHELL, the number of exponents NEXP,
C  the NCOMP, NPRIM, and NPTR arrays, and the orbital exponents and
C  coefficients from the NBO DAF:
C
      CALL FEBAS(NSHELL,NEXP,ISCR)
C
C  If NSHELL is zero, then no basis set info has been stored in the
C  DAF:
C
      IF(NSHELL.EQ.0) THEN
        WRITE(LFNPR,900)
        RETURN
      END IF
C
C  Partition the scratch arrays:  (Note that SCR and ISCR occupy the same
C  space in memory)
C
C  ISCR: (integer)
C
C   NSHELL  NEXP   NCOMP   NPRIM   NPTR
C  +------+------+-------+-------+-------+-----------------------------------
C                I1      I2      I3
C
C  SCR: (real)
C                                                                     ATCOOR
C                                           EXP   CS   CP   CD   CF   TITLE
C  ---------------------------------------+-----+----+----+----+----+--------
C                                         I4    I5   I6   I7   I8   I9
C
C  ISCR(I1) : NCOMP(1..NSHELL)
C  ISCR(I2) : NPRIM(1..NSHELL)
C  ISCR(I3) : NPTR(1..NSHELL)
C  SCR(I4)  : EXP(1..NEXP)
C  SCR(I5)  : CS(1..NEXP)
C  SCR(I6)  : CP(1..NEXP)
C  SCR(I7)  : CD(1..NEXP)
C  SCR(I8)  : CF(1..NEXP)
C  SCR(I9)  : TITLE(10) or ATCOOR(3*NATOMS)
C
      I1   = 3
      I2   = I1 + NSHELL
      I3   = I2 + NSHELL
      I4   = I3 + NSHELL
      I5   = I4 + NEXP
      I6   = I5 + NEXP
      I7   = I6 + NEXP
      I8   = I7 + NEXP
      I9   = I8 + NEXP
C     IEND = I9 + MAX0(3*NATOMS,10)
C
C  Fetch job title and write it to the AOINFO external file:
C
      CALL FETITL(SCR(I9))
C
C  Begin writing to the AOINFO external file:
C
      WRITE(LFN,910) (SCR(I9+I),I=0,9)
      WRITE(LFN,920) NATOMS,NSHELL,NEXP
C
C  Fetch the atomic coordinates:
C
      CALL FECOOR(SCR(I9))
C
C  Write atomic numbers and coordinates to external file:
C
      J = 0
      DO 10 I = 1,NATOMS
        WRITE(LFN,930) IATNO(I),(SCR(I9+J+K),K=0,2)
        J = J + 3
   10 CONTINUE
      WRITE(LFN,940)
C
C  Write out information about each shell in the basis set:
C
C     NCTR(I)  --  atomic center of the Ith shell
C
C     NCOMP(I) --  number of components in the Ith shell
C
C     NPTR(I)  --  pointer for the Ith shell into the primitive parameters
C                  of EXP, CS, CP, CD, and CF
C
C     NPRIM(I) --  number of primitive functions in the Ith shell
C
C     LABEL(1..NCOMP(I)) -- symmetry labels for the orbitals of this shell
C
      J1 = 1
      J2 = I1
      J3 = I3
      J4 = I2
      DO 20 I = 1,NSHELL
        NCOMP = ISCR(J2)
        NPRIM = ISCR(J3)
        NPTR  = ISCR(J4)
        WRITE(LFN,950) LCTR(J1),NCOMP,NPRIM,NPTR
        WRITE(LFN,950) ((LANG(J1+J)),J=0,NCOMP-1)
        J1 = J1 + NCOMP
        J2 = J2 + 1
        J3 = J3 + 1
        J4 = J4 + 1
   20 CONTINUE
      WRITE(LFN,940)
C
C  Write out the primitive parameters:
C
      WRITE(LFN,960) (SCR(I4+I),I=0,NEXP-1)
      WRITE(LFN,970)
      WRITE(LFN,960) (SCR(I5+I),I=0,NEXP-1)
      WRITE(LFN,970)
      WRITE(LFN,960) (SCR(I6+I),I=0,NEXP-1)
      WRITE(LFN,970)
      WRITE(LFN,960) (SCR(I7+I),I=0,NEXP-1)
      WRITE(LFN,970)
      WRITE(LFN,960) (SCR(I8+I),I=0,NEXP-1)
      RETURN
C
  900 FORMAT(/1X,'No basis set information is stored on the NBO direct',
     + ' access file.',/1X,'Thus, no `AOINFO'' file can be written.')
  910 FORMAT(1X,9A8,A7,/1X,'Basis set information needed for plotting ',
     + 'orbitals',/1X,75('-'))
  920 FORMAT(1X,3I6,/1X,75('-'))
  930 FORMAT(1X,I4,3(2X,F12.9))
  940 FORMAT(1X,75('-'))
  950 FORMAT(1X,10I6)
  960 FORMAT(2X,4E18.9)
  970 FORMAT(1X)
      END
C*****************************************************************************
      SUBROUTINE WRARC(SCR,ISCR,LFN)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (MAXD = 4)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,       
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    
     + JCORE,JPRINT(60)                                                 
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
C
      DIMENSION SCR(1),ISCR(1),IK(MAXD)
      DIMENSION KGEN(7),KNAT(6),KBAS(4),KOPEN(4),KORTHO(5),KUPPER(5),
     + KBODM(4),KEV(2),KCUBF(6),KEND(4),KCAL(4)
C
      DATA KGEN/1H$,1HG,1HE,1HN,1HN,1HB,1HO/,KBAS/1HN,1HB,1HA,1HS/,
     +     KNAT/1HN,1HA,1HT,1HO,1HM,1HS/,KOPEN/1HO,1HP,1HE,1HN/,
     +     KORTHO/1HO,1HR,1HT,1HH,1HO/,KUPPER/1HU,1HP,1HP,1HE,1HR/,
     +     KBODM/1HB,1HO,1HD,1HM/,KEV/1HE,1HV/,KEND/1H$,1HE,1HN,1HD/,
     +     KCUBF/1HC,1HU,1HB,1HI,1HC,1HF/,KCAL/1HK,1HC,1HA,1HL/
      DATA KBLNK,KEQ/1H ,1H=/
      DATA ABLNKS,ACENTR,ALABEL/8H        ,8HCENTER =,8H LABEL =/
      DATA ANSHLL,ANEXP ,ANCOMP/8HNSHELL =,8H  NEXP =,8H NCOMP =/
      DATA ANPRIM,ANPTR ,AEXP  /8H NPRIM =,8H  NPTR =,8H   EXP =/
      DATA ACS,ACP,ACD,ACF/8H    CS =,8H    CP =,8H    CD =,8H    CF =/
      DATA ZERO/0.0D0/
C
C  Write the ARCHIVE file to LFN:
C
C  This routine has been written assuming NBAS = NDIM.  Skip if
C  this condition is not satisfied:
C
      IF(NBAS.NE.NDIM) THEN
        WRITE(LFNPR,890)
        RETURN
      END IF
C
C  Form the $GENNBO keylist in ISCR:
C
      NC = 0
      DO 10 I = 1,7
        NC = NC + 1
        ISCR(NC) = KGEN(I)
   10 CONTINUE
      NC = NC + 1
      ISCR(NC) = KBLNK
      NC = NC + 1
      ISCR(NC) = KBLNK
C
C  Add the number of atoms and basis functions:
C
      DO 20 I = 1,6
        NC = NC + 1
        ISCR(NC) = KNAT(I)
   20 CONTINUE
      NC = NC + 1
      ISCR(NC) = KEQ
      CALL IDIGIT(NATOMS,IK,ND,MAXD)
      DO 30 I = 1,ND
        NC = NC + 1
        ISCR(NC) = IK(I)
   30 CONTINUE
      NC = NC + 1
      ISCR(NC) = KBLNK
      NC = NC + 1
      ISCR(NC) = KBLNK
C
      DO 40 I = 1,4
        NC = NC + 1
        ISCR(NC) = KBAS(I)
   40 CONTINUE
      NC = NC + 1
      ISCR(NC) = KEQ
      CALL IDIGIT(NBAS,IK,ND,MAXD)
      DO 50 I = 1,ND
        NC = NC + 1
        ISCR(NC) = IK(I)
   50 CONTINUE
      NC = NC + 1
      ISCR(NC) = KBLNK
      NC = NC + 1
      ISCR(NC) = KBLNK
C
C  If OPEN shell, add the OPEN keyword:
C
      IF(OPEN) THEN
        DO 60 I = 1,4
          NC = NC + 1
          ISCR(NC) = KOPEN(I)
   60   CONTINUE
        NC = NC + 1
        ISCR(NC) = KBLNK
        NC = NC + 1
        ISCR(NC) = KBLNK
      END IF
C
C  If the AO basis is orthogonal, add the ORTHO keyword:
C
      IF(ORTHO) THEN
        DO 70 I = 1,5
          NC = NC + 1
          ISCR(NC) = KORTHO(I)
   70   CONTINUE
        NC = NC + 1
        ISCR(NC) = KBLNK
        NC = NC + 1
        ISCR(NC) = KBLNK
      END IF
C
C  Only UPPER triangular portions of symmetric matrices will be given:
C
      DO 80 I = 1,5
        NC = NC + 1
        ISCR(NC) = KUPPER(I)
   80 CONTINUE
      NC = NC + 1
      ISCR(NC) = KBLNK
      NC = NC + 1
      ISCR(NC) = KBLNK
C
C  Enter the bond-order matrix, BODM, if possible:
C
      IF(IWDM.EQ.1) THEN
        DO 90 I = 1,4
          NC = NC + 1
          ISCR(NC) = KBODM(I)
   90   CONTINUE
        NC = NC + 1
        ISCR(NC) = KBLNK
        NC = NC + 1
        ISCR(NC) = KBLNK
      END IF
C
C  Add EV if the energy units are in electron volts:
C
      IF(MUNIT.EQ.1) THEN
        NC = NC + 1
        ISCR(NC) = KEV(1)
        NC = NC + 1
        ISCR(NC) = KEV(2)
        NC = NC + 1
        ISCR(NC) = KBLNK
        NC = NC + 1
        ISCR(NC) = KBLNK
      END IF
C
C  Add KCAL if the energy units are in kcal/mol:
C
      IF(MUNIT.EQ.1) THEN
        NC = NC + 1
        ISCR(NC) = KCAL(1)
        NC = NC + 1
        ISCR(NC) = KCAL(2)
        NC = NC + 1
        ISCR(NC) = KCAL(3)
        NC = NC + 1
        ISCR(NC) = KCAL(4)
        NC = NC + 1
        ISCR(NC) = KBLNK
        NC = NC + 1
        ISCR(NC) = KBLNK
      END IF
C
C  Add CUBICF if these types of orbitals are being used:
C
      IF(IWCUBF.NE.0) THEN
        DO 100 I = 1,6
          NC = NC + 1
          ISCR(NC) = KCUBF(I)
  100   CONTINUE
        NC = NC + 1
        ISCR(NC) = KBLNK
        NC = NC + 1
        ISCR(NC) = KBLNK
      END IF
C
C  Add $END:
C
      DO 110 I = 1,4
        NC = NC + 1
        ISCR(NC) = KEND(I)
  110 CONTINUE
C
C  Write the $GENNBO keylist to the archive file:
C
      WRITE(LFN,900) (ISCR(I),I=1,NC)
C
C  Write the $NBO keylist to the archive file:
C
      WRITE(LFN,910)
C
C  Write the $COORD data list to the archive file:
C
      WRITE(LFN,920)
      CALL FETITL(SCR)
      WRITE(LFN,930) (SCR(I),I=1,10)
      CALL FECOOR(SCR)
      J = 1
      DO 120 I = 1,NATOMS
        WRITE(LFN,940) IATNO(I),IZNUC(I),SCR(J),SCR(J+1),SCR(J+2)
        J = J + 3
  120 CONTINUE
      WRITE(LFN,950)
C
C  Write the $BASIS datalist to the archive file (info from /NBAO/):
C
      WRITE(LFN,960)
      NINT = 17
      STR = ACENTR
      DO 130 I = 1,(NBAS-1)/NINT+1
        NL  = (I - 1) * NINT + 1
        NU  = MIN0(NL+NINT-1,NBAS)
        WRITE(LFN,970) STR,(LCTR(J),J=NL,NU)
        STR = ABLNKS
  130 CONTINUE
      STR = ALABEL
      DO 140 I = 1,(NBAS-1)/NINT+1
        NL  = (I - 1) * NINT + 1
        NU  = MIN0(NL+NINT-1,NBAS)
        WRITE(LFN,970) STR,(LANG(J),J=NL,NU)
        STR = ABLNKS
  140 CONTINUE
      WRITE(LFN,950)
C
C  Write the $CONTRACT datalist to the archive file:
C
C  Fetch the basis set info from the NBO DAF:
C
      CALL FEBAS(NSHELL,NEXP,ISCR)
C
C  Partition the scratch vector:
C
C  ISCR(I1) : NCOMP(1..NSHELL)
C  ISCR(I2) : NPRIM(1..NSHELL)
C  ISCR(I3) : NPTR(1..NSHELL)
C  SCR(I4)  : EXP(1..NEXP)
C  SCR(I5)  : CS(1..NEXP)
C  SCR(I6)  : CP(1..NEXP)
C  SCR(I7)  : CD(1..NEXP)
C  SCR(I8)  : CF(1..NEXP)
C
      I1   = 3
      I2   = I1 + NSHELL
      I3   = I2 + NSHELL
      I4   = I3 + NSHELL
      I5   = I4 + NEXP
      I6   = I5 + NEXP
      I7   = I6 + NEXP
      I8   = I7 + NEXP
C     IEND = I8 + NEXP
C
C  If NSHELL is zero, then no basis set info was ever stored on
C  the DAF:
C
      IF(NSHELL.GT.0) THEN
C
C  Write out numbers of shells and orbital exponents:
C
        WRITE(LFN,980)
        WRITE(LFN,970) ANSHLL,NSHELL
        WRITE(LFN,970) ANEXP,NEXP
C
C  Write out the number of components in each shell:
C
        NINT = 17
        STR = ANCOMP
        DO 150 I = 1,(NSHELL-1)/NINT+1
          NL  = (I - 1) * NINT + 1
          NU  = MIN0(NL+NINT-1,NSHELL)
          WRITE(LFN,970) STR,(ISCR(J),J=I1+NL-1,I1+NU-1)
          STR = ABLNKS
  150   CONTINUE
C
C  Write out the number of primitives in each shell:
C
        STR = ANPRIM
        DO 160 I = 1,(NSHELL-1)/NINT+1
          NL  = (I - 1) * NINT + 1
          NU  = MIN0(NL+NINT-1,NSHELL)
          WRITE(LFN,970) STR,(ISCR(J),J=I2+NL-1,I2+NU-1)
          STR = ABLNKS
  160   CONTINUE
C
C  Write out pointer array which maps orbital exponents and coefficients
C  onto each shell:
C
        STR = ANPTR
        DO 170 I = 1,(NSHELL-1)/NINT+1
          NL  = (I - 1) * NINT + 1
          NU  = MIN0(NL+NINT-1,NSHELL)
          WRITE(LFN,970) STR,(ISCR(J),J=I3+NL-1,I3+NU-1)
          STR = ABLNKS
  170   CONTINUE
C
C  Write out orbital exponents:
C
        NREAL = 4
        STR   = AEXP
        DO 180 I = 1,(NEXP-1)/NREAL+1
          NL  = (I - 1) * NREAL + 1
          NU  = MIN0(NL+NREAL-1,NEXP)
          WRITE(LFN,990) STR,(SCR(J),J=I4+NL-1,I4+NU-1)
          STR = ABLNKS
  180   CONTINUE
C
C  Write out the orbital coefficients for each angular symmetry type
C  unless there are no basis functions of that type:
C
        DO 210 I = 1,4
          IF(I.EQ.1) THEN
            STR = ACS
            II  = I5
          ELSE IF(I.EQ.2) THEN
            STR = ACP
            II  = I6
          ELSE IF(I.EQ.3) THEN
            STR = ACD
            II  = I7
          ELSE IF(I.EQ.4) THEN
            STR = ACF
            II  = I8
          END IF
          IFLG = 0
          DO 190 J = II,II+NEXP-1
            IF(SCR(J).NE.ZERO) IFLG = 1
  190     CONTINUE
          IF(IFLG.EQ.1) THEN
            DO 200 J = 1,(NEXP-1)/NREAL+1
              NL  = (J - 1) * NREAL + 1
              NU  = MIN0(NL+NREAL-1,NEXP)
              WRITE(LFN,990) STR,(SCR(K),K=II+NL-1,II+NU-1)
              STR = ABLNKS
  200       CONTINUE
          END IF
  210   CONTINUE
        WRITE(LFN,950)
      END IF
C
C  Write the $OVERLAP datalist unless the AO basis is orthogonal:
C
      L2 = NDIM * (NDIM + 1) / 2
      IF(.NOT.ORTHO) THEN
        WRITE(LFN,1000)
        CALL FESRAW(SCR)
        L2 = NDIM * (NDIM + 1) / 2
        CALL PACK(SCR,NDIM,NBAS,L2)
        WRITE(LFN,1010) (SCR(I),I=1,L2)
        WRITE(LFN,950)
      END IF
C
C  Write the $DENSITY datalist:
C
      WRITE(LFN,1020)
      IF(OPEN) THEN
        ALPHA = .TRUE.
        BETA  = .FALSE.
        CALL FEDRAW(SCR,SCR)
        CALL PACK(SCR,NDIM,NBAS,L2)
        WRITE(LFN,1010) (SCR(I),I=1,L2)
        ALPHA = .FALSE.
        BETA  = .TRUE.
        CALL FEDRAW(SCR,SCR)
        CALL PACK(SCR,NDIM,NBAS,L2)
        WRITE(LFN,1010) (SCR(I),I=1,L2)
      ELSE
        ALPHA = .FALSE.
        BETA  = .FALSE.
        CALL FEDRAW(SCR,SCR)
        CALL PACK(SCR,NDIM,NBAS,L2)
        WRITE(LFN,1010) (SCR(I),I=1,L2)
      END IF
      WRITE(LFN,950)
C
C  Write the $FOCK datalist:
C
      IF(OPEN) THEN
        ALPHA = .TRUE.
        BETA  = .FALSE.
        IWFOCK = 1
        CALL FEFAO(SCR,IWFOCK)
        IF(IWFOCK.NE.0) THEN
          WRITE(LFN,1030)
          CALL PACK(SCR,NDIM,NBAS,L2)
          WRITE(LFN,1010) (SCR(I),I=1,L2)
          ALPHA = .FALSE.
          BETA  = .TRUE.
          CALL FEFAO(SCR,IWFOCK)
          CALL PACK(SCR,NDIM,NBAS,L2)
          WRITE(LFN,1010) (SCR(I),I=1,L2)
          WRITE(LFN,950)
        END IF
      ELSE
        ALPHA = .FALSE.
        BETA  = .FALSE.
        IWFOCK = 1
        CALL FEFAO(SCR,IWFOCK)
        IF(IWFOCK.NE.0) THEN
          WRITE(LFN,1030)
          CALL PACK(SCR,NDIM,NBAS,L2)
          WRITE(LFN,1010) (SCR(I),I=1,L2)
          WRITE(LFN,950)
        END IF
      END IF
C
C  Write the $LCAOMO datalist:
C
      IF(OPEN) THEN
        ALPHA = .TRUE.
        BETA  = .FALSE.
        CALL FEAOMO(SCR,IAOMO)
        IF(IAOMO.EQ.1) THEN
          WRITE(LFN,1040)
          WRITE(LFN,1010) (SCR(I),I=1,NDIM*NDIM)
          ALPHA = .FALSE.
          BETA  = .TRUE.
          CALL FEAOMO(SCR,IAOMO)
          WRITE(LFN,1010) (SCR(I),I=1,NDIM*NDIM)
          WRITE(LFN,950)
        END IF
      ELSE
        ALPHA = .FALSE.
        BETA  = .FALSE.
        CALL FEAOMO(SCR,IAOMO)
        IF(IAOMO.EQ.1) THEN
          WRITE(LFN,1040)
          WRITE(LFN,1010) (SCR(I),I=1,NDIM*NDIM)
          WRITE(LFN,950)
        END IF
      END IF
C
C  Write the $DIPOLE datalist:
C
      IDIP = 1
      CALL FEDXYZ(SCR,IDIP)
      IF(IDIP.NE.0) THEN
        WRITE(LFN,1050)
        CALL PACK(SCR,NDIM,NBAS,L2)
        WRITE(LFN,1010) (SCR(I),I=1,L2)
        IDIP = 2
        CALL FEDXYZ(SCR,IDIP)
        CALL PACK(SCR,NDIM,NBAS,L2)
        WRITE(LFN,1010) (SCR(I),I=1,L2)
        IDIP = 3
        CALL FEDXYZ(SCR,IDIP)
        CALL PACK(SCR,NDIM,NBAS,L2)
        WRITE(LFN,1010) (SCR(I),I=1,L2)
        WRITE(LFN,950)
      END IF
C
C  Reset logicals ALPHA and BETA:
C
      ALPHA = ISPIN.EQ.2
      BETA  = ISPIN.EQ.-2
      RETURN
C
  890 FORMAT(/1X,'The routine which writes the ARCHIVE file assumes ',
     + 'NBAS = NDIM.  Since',/1X,'this condition is not satisfied, ',
     + 'the ARCHIVE file will not be written.')
  900 FORMAT(1X,78A1)
  910 FORMAT(1X,'$NBO  $END')
  920 FORMAT(1X,'$COORD')
  930 FORMAT(1X,9A8,A6)
  940 FORMAT(1X,2I5,3F15.6)
  950 FORMAT(1X,'$END')
  960 FORMAT(1X,'$BASIS')
  970 FORMAT(1X,1X,A8,1X,17(I3,1X))
  980 FORMAT(1X,'$CONTRACT')
  990 FORMAT(1X,1X,A8,1X,4(E15.7,1X))
 1000 FORMAT(1X,'$OVERLAP')
 1010 FORMAT(1X,1X,5E15.7)
 1020 FORMAT(1X,'$DENSITY')
 1030 FORMAT(1X,'$FOCK')
 1040 FORMAT(1X,'$LCAOMO')
 1050 FORMAT(1X,'$DIPOLE')
      END
C*****************************************************************************
      SUBROUTINE AOUT(A,MR,NR,NC,TITLE,INDEX,IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(MR,1)
      CHARACTER*80 TITLE
      DIMENSION ISHELL(4)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBLBL/NLEW,NVAL,LBL(10,MAXBAS,4)
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
C
      DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/
C
C  Either write A to an external file, or print it in the output file:
C
C  Input:  A     -- matrix to be printed or written out
C
C          MR    -- row dimension of matrix A in calling routine
C
C          NR    -- ABS(NR) is the actual number of rows to be output
C                   [if NR is negative, IFLG is negative (write), and
C                    ABS(NR).EQ.NC (square matrix), only the upper
C                    triangular portion is written out]
C
C          NC    -- actual number of columns in matrix A
C                   [used to determine if A is square, and as an upper
C                    limit on IFLG]
C
C          TITLE -- CHARACTER*80 variable containing a matrix title
C
C          INDEX -- Index selecting appropriate output labels
C                   0 : Atom labels
C                   1 : AO   labels
C                   2 : NAO  labels
C                   3 : NHO  labels
C                   4 : NBO  labels
C                   5 : NLMO labels
C
C          IFLG  -- print/write flag
C                   negative : write to LFN ABS(IFLG)
C                   positive : print IFLG columns of A
C                   'FULL'   : print the full matrix
C                   'VAL'    : print N columns of A, where N is the
C                              number of core + valence orbitals and
C                              is determined by this routine
C                   'LEW'    : print N columns of A, where N is the
C                              number of occupied orbitals and is
C                              determined by this routine
C
      JFLG = IFLG
      IF(JFLG.EQ.0) RETURN
C
C  If JFLG is FULL, then output the total number of columns:
C
      IF(JFLG.EQ.KFULL) JFLG = ABS(NC)
C
C  If JFLG = VAL, output only the valence orbitals, determined from the
C  core and valence tables:
C
      IF(JFLG.EQ.KVAL) THEN
        IF(NVAL.LT.0) THEN
          IECP = 0
          JFLG = 0
          DO 30 IAT = 1,NATOMS
            CALL CORTBL(IAT,ISHELL,IECP)
            DO 10 I = 1,4
              MULT = 2 * (I-1) + 1
              JFLG = JFLG + ISHELL(I)*MULT
   10       CONTINUE
            CALL VALTBL(IAT,ISHELL)
            DO 20 I = 1,4
              MULT = 2 * (I-1) + 1
              JFLG = JFLG + ISHELL(I)*MULT
   20       CONTINUE
   30     CONTINUE
        ELSE
          JFLG = NVAL
        END IF
      END IF
C
C  If JFLG is LEW, only output the occupied orbitals:
C
      IF(JFLG.EQ.KLEW) JFLG = NLEW
C
C  If JFLG is positive, print the matrix A in the output file:
C
      IF(JFLG.GT.0) CALL APRINT(A,MR,NR,NC,TITLE,INDEX,JFLG)
C
C  If JFLG is negative but greater than -1000, write matrix A to the external
C  file ABS(JFLG):
C
      IF(JFLG.LT.0.AND.JFLG.GT.-1000) CALL AWRITE(A,MR,NR,NC,TITLE,JFLG)
C
      RETURN
      END
C*****************************************************************************
      SUBROUTINE APRINT(A,MR,NR,NC,TITLE,INDEX,MCOL)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(MR,1)
      CHARACTER*80 TITLE
      DIMENSION BASIS(5)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBLBL/NLEW,NVAL,LBL(10,MAXBAS,4)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DATA BASIS/4H AO ,4H NAO,4H NHO,4H NBO,4HNLMO/
      DATA ATOM,DASHES/4HAtom,8H--------/
      DATA TENTH/0.1D0/
C
C  Determine the number of columns of matrix A to print in the output file:
C
      NCOL = MCOL
      IF(NCOL.GT.ABS(NC)) NCOL = ABS(NC)
C
      NN = ABS(NR)
      ILABEL = INDEX
      IF(ILABEL.EQ.5) ILABEL = 4
C
      TMAX = ABS(A(1,1))
      DO 20 J = 1,NCOL
        DO 10 I = 1,NN
          IF(ABS(A(I,J)).GT.TMAX) TMAX = ABS(A(I,J))
   10   CONTINUE
   20 CONTINUE
      IF(TMAX.LT.TENTH) THEN
        ND = 1
      ELSE
        ND = INT(LOG10(TMAX)) + 1
      END IF
C
C  Print the matrix title:
C
      WRITE(LFNPR,1000) TITLE(1:78)
C
C  Print the matrix A: (basis function labels)
C
      IF(ILABEL.GE.1.AND.ILABEL.LE.4) THEN
        MAXCOL = MIN(10-ND,8)
        IF(MAXCOL.LT.6) THEN
          CALL ALTOUT(A,MR,NCOL,NN,NCOL)
        ELSE
          NCL = 1
          NCU = MAXCOL
          NLOOPS = (NCOL - 1) / MAXCOL + 1
          DO 60 L = 1,NLOOPS
            IF(NCU.GT.NCOL) NCU = NCOL
            IF(MAXCOL.EQ.8) THEN
              WRITE(LFNPR,900) BASIS(INDEX),(J,J=NCL,NCU)
              WRITE(LFNPR,910) (DASHES,J=NCL,NCU)
              DO 30 I = 1,NN
                WRITE(LFNPR,920) I,(LBL(J,I,ILABEL),J=1,10),
     +                           (A(I,K),K=NCL,NCU)
   30         CONTINUE
            ELSE IF(MAXCOL.EQ.7) THEN
              WRITE(LFNPR,901) BASIS(INDEX),(J,J=NCL,NCU)
              WRITE(LFNPR,911) (DASHES,J=NCL,NCU)
              DO 40 I = 1,NN
                WRITE(LFNPR,921) I,(LBL(J,I,ILABEL),J=1,10),
     +                           (A(I,K),K=NCL,NCU)
   40         CONTINUE
            ELSE
              WRITE(LFNPR,902) BASIS(INDEX),(J,J=NCL,NCU)
              WRITE(LFNPR,912) (DASHES,DASHES,J=NCL,NCU)
              DO 50 I = 1,NN
                WRITE(LFNPR,922) I,(LBL(J,I,ILABEL),J=1,10),
     +                           (A(I,K),K=NCL,NCU)
   50         CONTINUE
            END IF
            NCL = NCU + 1
            NCU = NCU + MAXCOL
   60     CONTINUE
        END IF
C
C  Print the matrix A: (atom labels)
C
      ELSE IF(ILABEL.EQ.0) THEN
        MAXCOL = MIN(10-ND,9)
        IF(MAXCOL.LT.7) THEN
          CALL ALTOUT(A,MR,NCOL,N,NCOL)
        ELSE
          NCL = 1
          NCU = MAXCOL
          NLOOPS = (NCOL - 1) / MAXCOL + 1
          DO 160 L = 1,NLOOPS
            IF(NCU.GT.NCOL) NCU = NCOL
            IF(MAXCOL.EQ.9) THEN
              WRITE(LFNPR,1900) ATOM,(J,J=NCL,NCU)
              WRITE(LFNPR,1910) (DASHES,J=NCL,NCU)
              DO 130 I = 1,NN
                WRITE(LFNPR,1920) I,NAMEAT(IATNO(I)),
     +                            (A(I,K),K=NCL,NCU)
  130         CONTINUE
            ELSE IF(MAXCOL.EQ.8) THEN
              WRITE(LFNPR,1901) ATOM,(J,J=NCL,NCU)
              WRITE(LFNPR,1911) (DASHES,J=NCL,NCU)
              DO 140 I = 1,NN
                WRITE(LFNPR,1921) I,NAMEAT(IATNO(I)),
     +                            (A(I,K),K=NCL,NCU)
  140         CONTINUE
            ELSE
              WRITE(LFNPR,1902) ATOM,(J,J=NCL,NCU)
              WRITE(LFNPR,1912) (DASHES,J=NCL,NCU)
              DO 150 I = 1,NN
                WRITE(LFNPR,1922) I,NAMEAT(IATNO(I)),
     +                            (A(I,K),K=NCL,NCU)
  150         CONTINUE
            END IF
            NCL = NCU + 1
            NCU = NCU + MAXCOL
  160     CONTINUE
        END IF
C
C  Print the matrix A: (no labels)
C
      ELSE
        CALL ALTOUT(A,MR,NCOL,NN,NCOL)
      END IF
      RETURN
C
  900 FORMAT(/9X,A4,3X,8(3X,I3,2X))
  901 FORMAT(/9X,A4,3X,7(4X,I3,2X))
  902 FORMAT(/9X,A4,3X,6(4X,I3,3X))
  910 FORMAT(6X,'----------',8(1X,A7))
  911 FORMAT(6X,'----------',7(1X,A8))
  912 FORMAT(6X,'----------',6(1X,A8,A1))
  920 FORMAT(1X,I3,'. ',10A1,8F8.4)
  921 FORMAT(1X,I3,'. ',10A1,7F9.4)
  922 FORMAT(1X,I3,'. ',10A1,6F10.4)
 1000 FORMAT(//1X,A78)
 1900 FORMAT(/5X,A4,9(2X,I3,3X))
 1901 FORMAT(/5X,A4,8(3X,I3,3X))
 1902 FORMAT(/5X,A4,7(3X,I3,4X))
 1910 FORMAT(5X,'----',1X,9(A6,2X))
 1911 FORMAT(5X,'----',1X,8(A7,2X))
 1912 FORMAT(5X,'----',1X,7(A8,2X))
 1920 FORMAT(1X,I3,'. ',A2,9F8.4)
 1921 FORMAT(1X,I3,'. ',A2,8F9.4)
 1922 FORMAT(1X,I3,'. ',A2,7F10.4)
      END
C*****************************************************************************
      SUBROUTINE AWRITE(A,MR,NR,NC,TITLE,LFN)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(MR,1)
      CHARACTER*80 TITLE
      DIMENSION XJOB(10)
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
C  Write the matrix A to the external file ABS(LFN).  Include job title,
C  matrix title, and specify the spin in needed:
C
      LFNOUT = ABS(LFN)
      IF(LFNOUT.EQ.LFNPR) WRITE(LFNOUT,890)
      IF(ALPHA.OR..NOT.OPEN.OR.LFNOUT.EQ.LFNPR) THEN
        CALL FETITL(XJOB)
        WRITE(LFNOUT,900) XJOB
        WRITE(LFNOUT,910) TITLE(1:79)
      END IF
      IF(ALPHA) WRITE(LFNOUT,920)
      IF(BETA)  WRITE(LFNOUT,930)
C
C  If this is a square matrix and NR is negative, only write the upper
C  triangular portion.  Otherwise, write out the full matrix:
C
      IF(ABS(NR).EQ.ABS(NC).AND.NR.LT.0) THEN
        WRITE(LFNOUT,1000) ((A(I,J),I=1,J),J=1,ABS(NR))
      ELSE
        DO 10 J = 1,ABS(NC)
          WRITE(LFNOUT,1000) (A(I,J),I=1,ABS(NR))
   10   CONTINUE
      END IF
      RETURN
C
  890 FORMAT(/1X)
  900 FORMAT(1X,9A8,A7)
  910 FORMAT(1X,A79,/1X,79('-'))
  920 FORMAT(1X,'ALPHA SPIN')
  930 FORMAT(1X,'BETA  SPIN')
 1000 FORMAT(1X,5F15.9)
      END
C*****************************************************************************
      SUBROUTINE AREAD(A,MR,NR,NC,JOB,LFN,ERROR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(MR,1),JOB(20)
      DIMENSION ITEMP(20)
      LOGICAL ERROR
C
      COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
      LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO
C
      DATA IDASH,IALFA,IBETA/4H----,4HALPH,4HBETA/
C
C  Read the matrix A to the external file LFN:
C
C  Input:  MR    -- row dimension of matrix A in calling routine
C
C          NR    -- ABS(NR) is the actual number of rows to be read
C                   [if NR is negative and ABS(NR).EQ.NC (square matrix),
C                    only the upper triangular portion is stored in the
C                    input file.  This routine will read the upper triangular
C                    portion and unpack it.]
C
C          NC    -- actual number of columns in matrix A
C                   [used to determine if A is square]
C
C          LFN   -- input file
C
C  Output: JOB   -- INTEGER array containing the job title 
C                   [closed shell or alpha spin only]
C
C          ERROR -- set to .true. if the end-of-file was encountered while
C                   reading
C
      IF(ALPHA.OR..NOT.OPEN) READ(LFN,1000,END=800) JOB
      IF(.NOT.OPEN) ISTR = IDASH
      IF(ALPHA)     ISTR = IALFA
      IF(BETA)      ISTR = IBETA
C
   10 READ(LFN,1000,END=800) ITEMP
      IF(ITEMP(1).NE.ISTR) GOTO 10
C
C  If this is a square matrix and NR is negative, only read the upper
C  triangular portion.  Otherwise, read the full matrix:
C
      IF(ABS(NR).EQ.ABS(NC).AND.NR.LT.0) THEN
        READ(LFN,900,END=800) ((A(I,J),I=1,J),J=1,ABS(NR))
        DO 30 J = 1,ABS(NR)-1
          DO 20 I = J+1,ABS(NR)
            A(I,J) = A(J,I)
   20     CONTINUE
   30   CONTINUE
      ELSE
        DO 40 J = 1,ABS(NC)
          READ(LFN,900,END=800) (A(I,J),I=1,ABS(NR))
   40   CONTINUE
      END IF
      ERROR = .FALSE.
      RETURN
C
  800 ERROR = .TRUE.
      RETURN
C
  900 FORMAT(1X,5F15.9)
 1000 FORMAT(1X,20A4)
      END
C*****************************************************************************
      SUBROUTINE ALTOUT(A,MR,MC,NR,NC)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DIMENSION A(MR,MC)
C
C  FOR 80 COLUMN OUTPUT:
C  LIST ELEMENTS OF ARRAY A (MATRIX OR VECTOR).
C     MR,MC DECLARED ROW AND COLUMN DIMENSIONALITY,
C     NR,NC ACTUAL ROW AND COLUMN DIMENSIONALITY,
C
      NCL=1
      NCU=6
      NLOOPS=NC/6+1
      DO 20 L=1,NLOOPS
        IF(NCU.GT.NC) NCU=NC
        WRITE(LFNPR,1100) (J,J=NCL,NCU)
        DO 10 I=1,NR
   10     WRITE(LFNPR,1200) I,(A(I,J),J=NCL,NCU)
        IF(NCU.GE.NC) RETURN
        NCL=NCU+1
   20   NCU=NCU+6
      RETURN
 1100 FORMAT(/11X,10(I3,9X))
 1200 FORMAT(1X,I3,10F12.5)
      END
C*****************************************************************************
      SUBROUTINE KEYPAR(STRING,LEN,IFLG,LFN,READ,ERROR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER STRING(LEN)
      LOGICAL READ,ERROR
C
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DATA IW,IR,IP,IC,IV,IL/1HW,1HR,1HP,1HC,1HV,1HL/
      DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/
C
C  Interpret the KEYword PARameter STRING, storing the result in IFLG.
C  (The default IFLG should be passed to this routine through IFLG)
C
C  The following STRINGs are acceptable:
C
C    STRING = Wnnn     means write to the external file nnn (IFLG = -nnn)
C                      (if nnn is omitted, IFLG = -LFN)
C
C    STRING = Rnnn     means read from the external file nnn (IFLG = -nnn*1000)
C                      (if nnn is omitted, IFLG = -LFN)
C                      (READ must be true to allow reading)
C
C    STRING = PnnnC    means print nnn columns to the output file (IFLG = nnn)
C                      (if nnn is omitted, print full matrix, IFLG = 'FULL')
C                      (the C is optional, it means columns)
C
C    STRING = PVAL     means print val columns to output file (IFLG = 'VAL')
C                      (val is the number of core + valence orbitals)
C                      (only the V is necessary)
C
C
C    STRING = PLEW     means print lew columns to output file (IFLG = 'LEW'
C                      (lew is the number of occupied orbitals)
C                      (only the L is necessary)
C
C    STRING = other    IFLG is left untouched
C
      ERROR = .FALSE.
C
C  Process STRING = W..:
C
      IF(STRING(1).EQ.IW) THEN
        IF(LEN.EQ.1) THEN
          IFLG = -LFN
          RETURN
        END IF
        IF(LEN.GT.1) THEN
          CALL CONVIN(STRING(2),LEN-1,IFLG,ERROR)
          IF(ERROR) RETURN
          IF(IFLG.GT.1000) THEN
            WRITE(LFNPR,900)
            WRITE(LFNPR,910) IFLG
            STOP
          END IF
          IFLG = -IFLG
        END IF
C
C  Process STRING = R..:
C
      ELSE IF(STRING(1).EQ.IR) THEN
        IF(.NOT.READ) THEN
          ERROR = .TRUE.
          RETURN
        END IF
        IF(LEN.EQ.1) THEN
          IFLG = -LFN * 1000
          RETURN
        END IF
        IF(LEN.GT.1) THEN
          CALL CONVIN(STRING(2),LEN-1,IFLG,ERROR)
          IF(ERROR) RETURN
          IF(IFLG.GT.1000) THEN
            WRITE(LFNPR,900)
            WRITE(LFNPR,920) IFLG
            STOP
          END IF
          IFLG = -IFLG * 1000
        END IF
C
C  Process STRING = P..:
C
      ELSE IF(STRING(1).EQ.IP) THEN
        IF(STRING(2).EQ.IV) THEN
          IFLG = KVAL
          RETURN
        END IF
        IF(STRING(2).EQ.IL) THEN
          IFLG = KLEW
          RETURN
        END IF
        IF(LEN.EQ.1) THEN
          IFLG = KFULL
          RETURN
        END IF
        IF(LEN.GT.1) THEN
          IF(STRING(LEN).NE.IC) THEN
            CALL CONVIN(STRING(2),LEN-1,IFLG,ERROR)
          ELSE
            CALL CONVIN(STRING(2),LEN-2,IFLG,ERROR)
          END IF
        END IF
      ELSE
        ERROR = .TRUE.
      END IF
      RETURN
C
  900 FORMAT(/1X,'The NBO program will only communicate with external ',
     + 'files 0 thru 999.')
  910 FORMAT(1X,'You''re attempting to write to file ',I6,'.')
  920 FORMAT(1X,'You''re attempting to read from file ',I6,'.')
      END
C*****************************************************************************
      FUNCTION IOINQR(IFLG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DATA KFULL,KVAL,KLEW/4HFULL,3HVAL,3HLEW/
      DATA KBLNK,KPRNT,KWRIT,KREAD/4H    ,4HPRNT,4HWRIT,4HREAD/
C
C  Interpret IFLG, determining whether the corresponding matrix should be
C  printed, written out, or read:
C
      IF(IFLG.EQ.KFULL) THEN
        IOINQR = KPRNT
      ELSE IF(IFLG.EQ.KVAL) THEN
        IOINQR = KPRNT
      ELSE IF(IFLG.EQ.KLEW) THEN
        IOINQR = KPRNT
      ELSE IF(IFLG.GT.0) THEN
        IOINQR = KPRNT
      ELSE IF(IFLG.LT.0.AND.IFLG.GT.-1000) THEN
        IOINQR = KWRIT
      ELSE IF(IFLG.LT.0) THEN
        IOINQR = KREAD
      ELSE
        IOINQR = KBLNK
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE LBLAO
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(MAXD = 2)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)
      COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS),
     +                       NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS)
C
      DIMENSION ISTR(MAXD),IANG(5),IXYZ(3),IBYTE(4),NUM(10)
C
      DATA IBLNK/' '/
      DATA IANG/'s','p','d','f','g'/
      DATA IXYZ/'x','y','z'/
      DATA ILEFT,IRIGHT/'(',')'/
      DATA NUM/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
      DO 20 IAO = 1,NBAS
        DO 10 I = 1,10
          IAOLBL(I,IAO) = IBLNK
   10   CONTINUE
        LBL = NAMEAT(IATNO(LCTR(IAO)))
        CALL DEBYTE(LBL,IBYTE)
        IAOLBL(1,IAO) = IBYTE(1)
        IAOLBL(2,IAO) = IBYTE(2)
        CALL IDIGIT(LCTR(IAO),ISTR,ND,MAXD)
        IF(ND.EQ.1) THEN
          IAOLBL(4,IAO) = ISTR(1)
        ELSE
          IAOLBL(3,IAO) = ISTR(1)
          IAOLBL(4,IAO) = ISTR(2)
        END IF
        IAOLBL(6,IAO) = ILEFT
        L = LANG(IAO)/100
        IAOLBL(7,IAO) = IANG(L+1)
        IF(L.EQ.0) THEN
          IAOLBL(8,IAO) = IRIGHT
        ELSE IF(L.EQ.1) THEN
          M = MOD(LANG(IAO),10)
          IAOLBL(8,IAO) = IXYZ(M)
          IAOLBL(9,IAO) = IRIGHT
        ELSE IF(L.EQ.2.OR.L.EQ.3) THEN
          IAOLBL(8,IAO) = NUM(MOD(LANG(IAO),10)+1)
          IAOLBL(9,IAO) = IRIGHT
        END IF
   20 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE LBLNAO
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(MAXD = 2)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBNAO/NAOCTR(MAXBAS),NAOL(MAXBAS),LTYP(MAXBAS),
     +       IPRIN(MAXBAS)
      COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS),
     +                       NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS)
C
      DIMENSION ISTR(MAXD),IANG(5),IXYZ(3),IBYTE(4),NUM(10)
C
      DATA IBLNK/' '/
      DATA IANG/'s','p','d','f','g'/
      DATA IXYZ/'x','y','z'/
      DATA ILEFT,IRIGHT/'(',')'/
      DATA NUM/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
      DO 20 INAO = 1,NBAS
        DO 10 I = 1,10
          NAOLBL(I,INAO) = IBLNK
   10   CONTINUE
        LBL = NAMEAT(IATNO(NAOCTR(INAO)))
        CALL DEBYTE(LBL,IBYTE)
        NAOLBL(1,INAO) = IBYTE(1)
        NAOLBL(2,INAO) = IBYTE(2)
        CALL IDIGIT(NAOCTR(INAO),ISTR,ND,MAXD)
        IF(ND.EQ.1) THEN
          NAOLBL(4,INAO) = ISTR(1)
        ELSE
          NAOLBL(3,INAO) = ISTR(1)
          NAOLBL(4,INAO) = ISTR(2)
        END IF
        NAOLBL(5,INAO) = ILEFT
        CALL IDIGIT(IPRIN(INAO),ISTR,ND,MAXD)
        IF(ND.EQ.1) THEN
          NAOLBL(7,INAO) = ISTR(1)
        ELSE
          NAOLBL(6,INAO) = ISTR(1)
          NAOLBL(7,INAO) = ISTR(2)
        END IF
        L = NAOL(INAO)/100
        NAOLBL(8,INAO) = IANG(L+1)
        IF(L.EQ.1) THEN
          M = MOD(NAOL(INAO),10)
          NAOLBL(9,INAO) = IXYZ(M)
        ELSE IF(L.EQ.2.OR.L.EQ.3) THEN
          NAOLBL(9,INAO) = NUM(MOD(NAOL(INAO),10)+1)
        END IF
        NAOLBL(10,INAO) = IRIGHT
   20 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE LBLNBO
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(MAXD = 2)
      INTEGER ISTR(MAXD),IBYTE(4)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL1(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS),
     +                       NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS)
C
      DATA IBLNK,IC,IL,IP,IR,IY,ISTAR,IHYP/' ','c','l','p','r','y','*',
     +                                     '-'/
      DATA ICR,ILP/'CR','LP'/
      DATA ILEFT,IRIGHT/'(',')'/
C
      DO 20 INBO = 1,NBAS
        DO 10 I = 1,10
          NBOLBL(I,INBO) = IBLNK
   10   CONTINUE
        IB = IBXM(INBO)
        NCTR = 1
        IF(LABEL(IB,5).NE.0) NCTR = 2
        IF(LABEL(IB,6).NE.0) NCTR = 3
C
C  One-center labels:
C
        IF(NCTR.EQ.1) THEN
          LBL = NAMEAT(IATNO(LABEL(IB,4)))
          CALL DEBYTE(LBL,IBYTE)
          NBOLBL(1,INBO) = IBYTE(1)
          NBOLBL(2,INBO) = IBYTE(2)
          CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD)
          IF(ND.EQ.1) THEN
            NBOLBL(4,INBO) = ISTR(1)
          ELSE
            NBOLBL(3,INBO) = ISTR(1)
            NBOLBL(4,INBO) = ISTR(2)
          END IF
          NBOLBL(5,INBO) = ILEFT
          IF(LABEL(IB,1).EQ.ICR) THEN
            NBOLBL(6,INBO) = IC
            NBOLBL(7,INBO) = IR
            NBOLBL(8,INBO) = IRIGHT
          ELSE IF(LABEL(IB,1).EQ.ILP) THEN
            NBOLBL(6,INBO) = IL
            NBOLBL(7,INBO) = IP
            IF(LABEL(IB,2).EQ.ISTAR) THEN
              NBOLBL(8,INBO) = ISTAR
              NBOLBL(9,INBO) = IRIGHT
            ELSE
              NBOLBL(8,INBO) = IRIGHT
            END IF
          ELSE
            NBOLBL(6,INBO) = IR
            NBOLBL(7,INBO) = IY
            NBOLBL(8,INBO) = ISTAR
            NBOLBL(9,INBO) = IRIGHT
          END IF
C
C  Two-center labels:
C
        ELSE IF(NCTR.EQ.2) THEN
          LBL = NAMEAT(IATNO(LABEL(IB,4)))
          CALL DEBYTE(LBL,IBYTE)
          NBOLBL(1,INBO) = IBYTE(1)
          NBOLBL(2,INBO) = IBYTE(2)
          CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD)
          IF(ND.EQ.1) THEN
            NBOLBL(4,INBO) = ISTR(1)
          ELSE
            NBOLBL(3,INBO) = ISTR(1)
            NBOLBL(4,INBO) = ISTR(2)
          END IF
          NBOLBL(5,INBO) = IHYP
          LBL = NAMEAT(IATNO(LABEL(IB,5)))
          CALL DEBYTE(LBL,IBYTE)
          NBOLBL(6,INBO) = IBYTE(1)
          NBOLBL(7,INBO) = IBYTE(2)
          CALL IDIGIT(LABEL(IB,5),ISTR,ND,MAXD)
          IF(ND.EQ.1) THEN
            NBOLBL(9,INBO) = ISTR(1)
          ELSE
            NBOLBL(8,INBO) = ISTR(1)
            NBOLBL(9,INBO) = ISTR(2)
          END IF
          NBOLBL(10,INBO) = LABEL(IB,2)
C
C  Three-center labels:
C
        ELSE
          CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD)
          IF(ND.EQ.1) THEN
            NBOLBL(2,INBO) = ISTR(1)
          ELSE
            NBOLBL(1,INBO) = ISTR(1)
            NBOLBL(2,INBO) = ISTR(2)
          END IF
          NBOLBL(3,INBO) = IHYP
          CALL IDIGIT(LABEL(IB,5),ISTR,ND,MAXD)
          IF(ND.EQ.1) THEN
            NBOLBL(5,INBO) = ISTR(1)
          ELSE
            NBOLBL(4,INBO) = ISTR(1)
            NBOLBL(5,INBO) = ISTR(2)
          END IF
          NBOLBL(6,INBO) = IHYP
          CALL IDIGIT(LABEL(IB,6),ISTR,ND,MAXD)
          IF(ND.EQ.1) THEN
            NBOLBL(8,INBO) = ISTR(1)
          ELSE
            NBOLBL(7,INBO) = ISTR(1)
            NBOLBL(8,INBO) = ISTR(2)
          END IF
          NBOLBL(9,INBO) = LABEL(IB,2)
        END IF
   20 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE LBLNHO(INHO,INBO,ICTR,NCTR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER(MAXD = 2)
      INTEGER ISTR(MAXD),IBYTE(4)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),LBL1(MAXBAS),
     +       LORBC(MAXBAS),LORB(MAXBAS)
      COMMON/NBLBL/NLEW,NVAL,IAOLBL(10,MAXBAS),NAOLBL(10,MAXBAS),
     +                       NHOLBL(10,MAXBAS),NBOLBL(10,MAXBAS)
C
      DATA IBLNK,IC,IL,IP,IR,IY,I3,ISTAR,IHYP/' ','c','l','p','r','y',
     +                                        '3','*','-'/
      DATA ICR,ILP/'CR','LP'/
      DATA ILEFT,IRIGHT/'(',')'/
C
      DO 10 I = 1,10
        NHOLBL(I,INHO) = IBLNK
   10 CONTINUE
      IB = IBXM(INBO)
C
C  One-center labels:
C
      IF(NCTR.EQ.1) THEN
        LBL = NAMEAT(IATNO(LABEL(IB,4)))
        CALL DEBYTE(LBL,IBYTE)
        NHOLBL(1,INHO) = IBYTE(1)
        NHOLBL(2,INHO) = IBYTE(2)
        CALL IDIGIT(LABEL(IB,4),ISTR,ND,MAXD)
        IF(ND.EQ.1) THEN
          NHOLBL(4,INHO) = ISTR(1)
        ELSE
          NHOLBL(3,INHO) = ISTR(1)
          NHOLBL(4,INHO) = ISTR(2)
        END IF
        NHOLBL(5,INHO) = ILEFT
        IF(LABEL(IB,1).EQ.ICR) THEN
          NHOLBL(6,INHO) = IC
          NHOLBL(7,INHO) = IR
          NHOLBL(8,INHO) = IRIGHT
        ELSE IF(LABEL(IB,1).EQ.ILP) THEN
          NHOLBL(6,INHO) = IL
          NHOLBL(7,INHO) = IP
          IF(LABEL(IB,2).EQ.ISTAR) THEN
            NHOLBL(8,INHO) = ISTAR
            NHOLBL(9,INHO) = IRIGHT
          ELSE
            NHOLBL(8,INHO) = IRIGHT
          END IF
        ELSE
          NHOLBL(6,INHO) = IR
          NHOLBL(7,INHO) = IY
          NHOLBL(8,INHO) = ISTAR
          NHOLBL(9,INHO) = IRIGHT
        END IF
C
C  Two-center and three-center labels:
C
      ELSE
        LBL = NAMEAT(IATNO(LABEL(IB,3+ICTR)))
        CALL DEBYTE(LBL,IBYTE)
        NHOLBL(1,INHO) = IBYTE(1)
        NHOLBL(2,INHO) = IBYTE(2)
        CALL IDIGIT(LABEL(IB,3+ICTR),ISTR,ND,MAXD)
        IF(ND.EQ.1) THEN
          NHOLBL(4,INHO) = ISTR(1)
        ELSE
          NHOLBL(3,INHO) = ISTR(1)
          NHOLBL(4,INHO) = ISTR(2)
        END IF
        NHOLBL(5,INHO) = ILEFT
        IF(NCTR.EQ.2) THEN
          LBL = NAMEAT(IATNO(LABEL(IB,6-ICTR)))
          CALL DEBYTE(LBL,IBYTE)
          NHOLBL(6,INHO) = IBYTE(1)
          NHOLBL(7,INHO) = IBYTE(2)
          CALL IDIGIT(LABEL(IB,6-ICTR),ISTR,ND,MAXD)
          IF(ND.EQ.1) THEN
            NHOLBL(9,INHO) = ISTR(1)
          ELSE
            NHOLBL(8,INHO) = ISTR(1)
            NHOLBL(9,INHO) = ISTR(2)
          END IF
          NHOLBL(10,INHO) = IRIGHT
        ELSE
          NHOLBL(6,INHO) = I3
          NHOLBL(7,INHO) = IHYP
          NHOLBL(8,INHO) = IC
          NHOLBL(9,INHO) = IRIGHT
        END IF
      END IF
      RETURN
      END
C*****************************************************************************
C
C  GENERAL UTILITY ROUTINES:
C
C      SUBROUTINE ANGLES(X,Y,Z,THETA,PHI)
C      FUNCTION BDFIND(IAT,JAT)
C      SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR)
C      SUBROUTINE CONSOL(AUT,ALT,NDIM,N)
C      SUBROUTINE CONVIN(IJ,LEN,IK,ERROR)
C      SUBROUTINE CONVRT(N,NC1,NC2)
C      SUBROUTINE COPY(A,B,NDIM,NR,NC)
C      SUBROUTINE CORTBL(IAT,ICORE,IECP)
C      SUBROUTINE DEBYTE(I,IBYTE)
C      SUBROUTINE HALT(WORD)
C      SUBROUTINE IDIGIT(KINT,IK,ND,MAXD)
C      FUNCTION IHTYP(IBO,JBO)
C      SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR)
C      SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT)
C      SUBROUTINE MATMLT(A,B,V,NDIM,N)
C      SUBROUTINE MATML2(A,B,V,NDIM,N)
C      FUNCTION NAMEAT(IZ)
C      SUBROUTINE NORMLZ(A,S,M,N)
C      SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK)
C      SUBROUTINE PACK(T,NDIM,NBAS,L2)
C      SUBROUTINE RANK(EIG,N,NDIM,ARCRNK)
C      SUBROUTINE SIMTRN(A,T,V,NDIM,N)
C      SUBROUTINE SIMTRS(A,S,V,NDIM,N)
C      SUBROUTINE TRANSP(A,NDIM,N)
C      SUBROUTINE UNPACK(T,NDIM,NBAS,L2)
C      SUBROUTINE VALTBL(IAT,IVAL)
C      FUNCTION VECLEN(X,N,NDIM)
C
C      SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR,
C     +                 IERR)
C      SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG)
C      SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR)
C      SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM)
C
C*****************************************************************************
      SUBROUTINE ANGLES(X,Y,Z,THETA,PHI)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DATA ZERO,CUTOFF,ONE/0.0D0,1.0D-8,1.0D0/
C
      CONV = 180.0/(4.0*ATAN(ONE))
      IF(X.EQ.ZERO.AND.Y.EQ.ZERO) THEN
        IF(Z.GE.ZERO) THEN
          THETA = ZERO
        ELSE
          THETA = 180.0
        END IF
        PHI = ZERO
      ELSE
        IF(ABS(Z-ONE).LT.CUTOFF) THEN
          THETA = ZERO
        ELSE IF(ABS(Z+ONE).LT.CUTOFF) THEN
          THETA = 180.0
        ELSE IF(Z.LT.ONE.AND.Z.GT.-ONE) THEN
          THETA = ACOS(Z) * CONV
          IF(THETA.GT.180.0) THETA = 360.0 - THETA
        ELSE
          STOP 'ArcCosine out of bounds in SR ANGLES'
        END IF
        PHI   = ATAN2(Y,X) * CONV
        IF(PHI.LT.ZERO) PHI = PHI + 360.0
        IF(ABS(PHI-360.0).LT.0.05) PHI = ZERO
        IF(ABS(THETA).LT.0.05) PHI = ZERO
        IF(ABS(THETA-180.0).LT.0.05) PHI = ZERO
      END IF
      RETURN
      END
C*****************************************************************************
      FUNCTION BDFIND(IAT,JAT)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL BDFIND,IFOUND,JFOUND
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NAOCTR(MAXBAS),NAOL(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
      COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT
C
      DATA LSTAR/1H*/
C
C  SET BDFIND=.TRUE. IF THERE IS AT LEAST ONE BOND BETWEEN ATOMS IAT AND JAT
C
      DO 100 IBAS = 1,NBAS
        IB = IBXM(IBAS)
        IF(LABEL(IB,2).EQ.LSTAR) GO TO 100
        IF(LABEL(IB,3).NE.1) GO TO 100
        IFOUND = .FALSE.
        JFOUND = .FALSE.
        DO 50 K = 4,6
          IF(LABEL(IB,K).EQ.IAT) IFOUND = .TRUE.
          IF(LABEL(IB,K).EQ.JAT) JFOUND = .TRUE.
   50   CONTINUE
        IF(IFOUND.AND.JFOUND) GO TO 200
  100 CONTINUE
      BDFIND = .FALSE.
      RETURN
  200 BDFIND = .TRUE.
      RETURN
      END
C*****************************************************************************
      SUBROUTINE CHEM(NAT,NATOMS,LISTA,NL,ISTR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION LISTA(NATOMS,2),ISTR(80)
C
      PARAMETER (MAXD = 4)
      DIMENSION INUM(MAXD),IBYTE(4)
      DATA IC,IH,IBLNK,ILEFT,IRIGHT/'C','H',' ','(',')'/
C
C  Build the chemical formula from the list of atoms in LISTA:
C
C  Get chemical symbols:
C
      DO 10 IAT = 1,NAT
        LISTA(IAT,1) = NAMEAT(LISTA(IAT,1))
   10 CONTINUE
C
C  Alphabetize these symbols:
C
      DO 30 IAT = 1,NAT-1
        DO 20 JAT = 1,NAT-IAT
          IF(LISTA(JAT,1).GT.LISTA(JAT+1,1)) THEN
            ITEMP = LISTA(JAT,1)
            LISTA(JAT,1) = LISTA(JAT+1,1)
            LISTA(JAT+1,1) = ITEMP
            ITEMP = LISTA(JAT,2)
            LISTA(JAT,2) = LISTA(JAT+1,2)
            LISTA(JAT+1,2) = ITEMP
          END IF
   20   CONTINUE
   30 CONTINUE
C
C  Build chemical formula in ISTR:
C
C  First carbon...
C
      NL = 1
      ISTR(NL) = ILEFT
      DO 50 IAT = 1,NAT
        CALL DEBYTE(LISTA(IAT,1),IBYTE)
        IF(IBYTE(1).EQ.IBLNK.AND.IBYTE(2).EQ.IC) THEN
          NL = NL + 1
          ISTR(NL) = IC
          IF(LISTA(IAT,2).NE.1) THEN
            CALL IDIGIT(LISTA(IAT,2),INUM,ND,MAXD)
            DO 40 IL = 1,ND
              NL = NL + 1
              ISTR(NL) = INUM(IL)
   40       CONTINUE
          END IF
          LISTA(IAT,2) = 0
        END IF
   50 CONTINUE
C
C  then hydrogen...
C
      DO 70 IAT = 1,NAT
        CALL DEBYTE(LISTA(IAT,1),IBYTE)
        IF(IBYTE(1).EQ.IBLNK.AND.IBYTE(2).EQ.IH) THEN
          NL = NL + 1
          ISTR(NL) = IH
          IF(LISTA(IAT,2).NE.1) THEN
            CALL IDIGIT(LISTA(IAT,2),INUM,ND,MAXD)
            DO 60 IL = 1,ND
              NL = NL + 1
              ISTR(NL) = INUM(IL)
   60       CONTINUE
          END IF
          LISTA(IAT,2) = 0
        END IF
   70 CONTINUE
C
C  and now the rest...
C
      DO 90 IAT = 1,NAT
        IF(LISTA(IAT,2).NE.0) THEN
          CALL DEBYTE(LISTA(IAT,1),IBYTE)
          IF(IBYTE(1).NE.IBLNK) THEN
            NL = NL + 1
            ISTR(NL) = IBYTE(1)
          END IF
          IF(IBYTE(2).NE.IBLNK) THEN
            NL = NL + 1
            ISTR(NL) = IBYTE(2)
          END IF
          IF(LISTA(IAT,2).NE.1) THEN
            CALL IDIGIT(LISTA(IAT,2),INUM,ND,MAXD)
            DO 80 IL = 1,ND
              NL = NL + 1
              ISTR(NL) = INUM(IL)
   80       CONTINUE
          END IF
          LISTA(IAT,2) = 0
        END IF
   90 CONTINUE
      NL = NL + 1
      ISTR(NL) = IRIGHT
      RETURN
      END
C*****************************************************************************
      SUBROUTINE CONSOL(AUT,ALT,NDIM,N)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  CONSOLIDATE AUT, ALT TO A SINGLE MATRIX, WITH AUT AS UPPER TRIANGLE
C  (INCLUDING DIAGONAL) AND ALT AS LOWER TRIANGLE.  STORE RESULT IN AUT.
C
      DIMENSION AUT(NDIM,NDIM),ALT(NDIM,NDIM)
      NM1=N-1
      DO 10 J=1,NM1
        JP1=J+1
        DO 10 I=JP1,N
   10     AUT(I,J)=ALT(I,J)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE CONVIN(IJ,LEN,IK,ERROR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION IJ(1)
      DIMENSION INT(10)
      LOGICAL ERROR
C
      DATA INT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C  Convert the array IJ(LEN) into an integer IK:
C
      ERROR = .FALSE.
      IF(LEN.LE.0) THEN
        ERROR = .TRUE.
        RETURN
      END IF
C
C  Make sure all elements of IJ are integers:
C
      IL   = 0
      MULT = 1
      DO 30 I = LEN,1,-1
        DO 10 J = 1,10
          JJ = J - 1
          IF(IJ(I).EQ.INT(J)) GOTO 20
   10   CONTINUE
        ERROR = .TRUE.
        RETURN
C
   20   IL = IL + JJ * MULT
        MULT = MULT * 10
   30 CONTINUE
      IK = IL
      RETURN
      END
C*****************************************************************************
      SUBROUTINE CONVRT(N,NC1,NC2)
C*****************************************************************************
C
C  CONVERT 2-DIGIT INTEGER 'N' TO TWO LITERAL CHARACTERS 'NC1','NC2'.
C
      DIMENSION INT(10)
      DATA ISP,INT/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0/
C
      NC1=ISP
      NC2=ISP
      IF(N.LE.0) RETURN
       IF(N.GE.10) GO TO 10
        NC2=INT(N)
        RETURN
   10 N1=N/10
       IF(N1.GT.9) STOP 'ROUTINE CONVRT'
       NC1=INT(N1)
       N2=N-N1*10
       IF(N2.EQ.0) N2=10
       NC2=INT(N2)
       RETURN
      END
C*****************************************************************************
      SUBROUTINE COPY(A,B,NDIM,NR,NC)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NDIM,1),B(NDIM,1)
C
C  COPY A TO B:
C
      DO 20 J = 1,NC
        DO 10 I = 1,NR
          B(I,J) = A(I,J)
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE CORTBL(IAT,ICORE,IECP)
C*****************************************************************************
C
C   CORE TABLE:
C
C     Determine the number of subshells of core orbitals of each angular
C     symmetry for atom number IAT.  ICORE is an integer array LMAX+1
C     long which returns the number of subshells to the calling subroutine:
C     the number of `s' subshells in ICORE(1), the number of `p' subshells
C     in ICORE(2), etc...
C
C     If the CORE option has been used, the core orbitals stored in the array
C     IATCR are used rather than the core orbitals of the nominal core table.
C
C     If IECP = 0 return the number of subshells, excluding subshells of
C                 an effective core potential.
C     IF IECP = 1 return the number of subshells, including subshells of
C                 an effective core potential.
C
C     Note: It is possible for a negative number of core orbitals be found
C     if effective core potentials are employed.  This happens when the
C     number of core electrons in the effective core potential is either
C     greater than the nominal number of core electrons or is greater than the
C     number of core electrons requested when using the CORE option.
C
C------------------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (LMAX = 3)
      INTEGER CORE(57),ICORE(4),ITEMP(4),IORD(16),JORD(20),KORD(20)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
C
      DATA IORD/1,1,3,1,3,5,1,3,5,1,3,7,5,1,3,7/
      DATA JORD/1,1,3,1,3,1,5,3,1,5,3,1,7,5,3,1,7,5,3,1/
      DATA KORD/1,2,1,3,2,4,1,3,5,2,4,6,1,3,5,7,2,4,6,8/
      DATA CORE/2,0,8,1,1,8,2,2,1,12,2,3,2,6,3,3,2,1,12,3,4,3,1,6,3,4,3,
     +  2,16,3,5,4,2,10,4,5,4,2,1,6,4,5,4,3,1,16,4,6,5,3,1,10,4,6,5,3,2/
C
C  Initialize arrays.  If there is no nuclear charge at this center,
C  return to calling routine:
C
      DO 10 L = 0,LMAX
        ICORE(L+1) = 0
        ITEMP(L+1) = 0
   10 CONTINUE
      IF(IATNO(IAT).LE.0) RETURN
C
C  If the CORE option has not been used for this atom, use the nominal
C  set of core orbitals:
C
      IF(JCORE.NE.1.OR.IATCR(IAT).LT.0) THEN
        JAT = IATNO(IAT)
        II  = 0
   20   II  = II + 1
          JAT = JAT - CORE(II)
          II = II + 1
          IF(JAT.LE.0) THEN
            DO 30 L = 1,CORE(II)
              ICORE(L) = CORE(II+L)
   30       CONTINUE
          ELSE
            II = II + CORE(II)
          END IF
        IF(JAT.GT.0) GOTO 20
      ELSE
C
C  If the CORE option has been used, determine the number of core
C  orbitals on this atom:
C
        II = IATCR(IAT)
        IF(II.GT.0) THEN
          ICT = 0
   40     ICT = ICT + 1
          L = IORD(ICT)/2
          ICORE(L+1) = ICORE(L+1) + 1
          II = II - IORD(ICT)
          IF(II.GT.0) GOTO 40
        END IF
      END IF
C
C  If effective core potentials were used and IECP = 0, remove
C  the core orbitals of the ECP:
C
      IF(IPSEUD.NE.0.AND.IECP.EQ.0) THEN
        II = IATNO(IAT)
        ICT = 0
   50   ICT = ICT + 1
          II = II - 2 * JORD(ICT)
        IF(II.GT.0) GOTO 50
        II = IZNUC(IAT) - II
        IF(II.LE.0) STOP 'Zero or negative IZNUC entry?'
        ICT = ICT + 1
   60   ICT = ICT - 1
          IF(ICT.LE.0) STOP 'Error in SR CORTBL'
          II = II - 2 * JORD(ICT)
          IF(II.GE.0) THEN
            L = JORD(ICT)/2
            IF(ICORE(L+1).GE.KORD(ICT)) ITEMP(L+1) = ITEMP(L+1) + 1
          ELSE
            II = II + 2 * JORD(ICT)
          END IF
        IF(II.NE.0) GOTO 60
        DO 70 L = 0,LMAX
          ICORE(L+1) = ITEMP(L+1)
   70   CONTINUE
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE DEBYTE(I,IBYTE)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION IBYTE(4),KB(4)
C
      SAVE KB,KPAD,KSW
C
      DATA KSW/0/
      DATA KTMP/4HABCD/
C
C  Extract four Hollerith characters from I, store in IBTYE:
C
C  If this is the first time that this routine is called, determine
C  in which bytes of an integer word the Hollerith characters reside:
C
      IF(KSW.EQ.0) THEN
        KSW   = 1
        DO 10 K = 1,4
          KB(K) = 0
   10   CONTINUE
        KBYTE = 0
   20   KBYTE = KBYTE + 1
          IF(KBYTE.GT.8) STOP 'Routine DEBYTE is limited to INTEGER*8'
          KTEST = MOD(KTMP,256)
          IF(KTEST.EQ.65) KB(1) = KBYTE
          IF(KTEST.EQ.66) KB(2) = KBYTE
          IF(KTEST.EQ.67) KB(3) = KBYTE
          IF(KTEST.EQ.68) KB(4) = KBYTE
          KTMP = KTMP/256
        IF(KTMP.NE.0) GOTO 20
        DO 30 K = 1,4
          IF(KB(K).EQ.0) STOP 'Error in routine DEBYTE'
   30   CONTINUE
C
C  Determine the bit padding:
C
        KPAD = 0
        KMLT = 1
        DO 40 K = 1,KBYTE
          IF(K.NE.KB(1)) KPAD = KPAD + 32 * KMLT
          IF(K.NE.KBYTE) KMLT = KMLT * 256
   40   CONTINUE
C
        DO 60 K = 1,4
          KMAX  = KB(K) - 1
          KB(K) = 1
          DO 50 L = 1,KMAX
            KB(K) = KB(K) * 256
   50     CONTINUE
   60   CONTINUE
      END IF
C
C  Extract four Hollerith characters from I:
C
      DO 100 K = 1,4
        IBYTE(K) = MOD(I/KB(K),256)*KB(1) + KPAD
  100 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE HALT(WORD)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB,
     +            LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC,
     +            LFNDAF,LFNDEF
C
      DATA BLANK/1H /
C
      IF(WORD.EQ.BLANK) RETURN
      WRITE(LFNPR,1000) WORD
      STOP
C
 1000 FORMAT(' Non-integer encountered when trying to read variable ',
     + '/',A6,'/')
      END
C*****************************************************************************
      SUBROUTINE IDIGIT(KINT,IK,ND,MAXD)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION IK(MAXD),INT(10)
C
      DATA IBLNK,INT/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0/
C
C  CONVERTS THE INTEGER KINT INTO THE FIRST ND ELEMENTS OF HOLLERITH ARRAY
C  IK(MAXD):
C
      JINT = KINT
      ND   = MAXD
      DO 10 ID = MAXD,1,-1
        II = MOD(JINT,10)
        IF(II.EQ.0) II = 10
        IK(ID) = INT(II)
        IF(II.NE.10) ND = ID
        JINT = JINT/10
   10 CONTINUE
      ND = MAXD - ND + 1
C
C  SHIFT INTEGER REP IN IK SO THAT THE NUMBER OCCUPIES THE FIRST ND
C  ELEMENTS:
C
      DO 20 ID = 1,ND
        IK(ID) = IK(ID+MAXD-ND)
   20 CONTINUE
      DO 30 ID = ND+1,MAXD
        IK(ID) = IBLNK
   30 CONTINUE
      RETURN
      END
C*****************************************************************************
      FUNCTION IHTYP(IBO,JBO)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL BDFIND
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBBAS/LABEL(MAXBAS,6),NBOUNI(MAXBAS),NBOTYP(MAXBAS),
     +       LSTOCC(MAXBAS),IBXM(MAXBAS),LARC(MAXBAS),IATHY(MAXBAS,3)
C
      DATA IV,IG,IR/'v','g','r'/
C
C  Determine whether the IBO->JBO delocalization is vicinal (IHTYP='v'),
C  geminal (IHTYP='g'), or remote (IHTYP='r'):
C
      IHTYP = IR
      IF(NBOUNI(IBO).EQ.NBOUNI(JBO)) THEN
        ICTR = MOD(NBOTYP(IBO),10)
        IB   = IBXM(IBO)
        JCTR = MOD(NBOTYP(JBO),10)
        JB   = IBXM(JBO)
        DO 20 I = 1,ICTR
          IAT = LABEL(IB,I+3)
          DO 10 J = 1,JCTR
            JAT = LABEL(JB,J+3)
            IF(IAT.EQ.JAT) THEN
              IHTYP = IG
              RETURN
            ELSE IF(BDFIND(IAT,JAT)) THEN
              IHTYP = IV
            END IF
   10     CONTINUE
   20   CONTINUE
      END IF
      RETURN
      END
C*****************************************************************************
      SUBROUTINE JACOBI(N,A,EIVU,EIVR,NDIM,NVDIM,ICONTR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  DIAGONALIZE REAL SYMMETRIC MATRIX A BY JACOBI ROTATIONS:
C        N: ACTUAL DIMENSION OF A,EIVR
C     NDIM: DECLARED DIMENSION OF A,EIVR
C   ICONTR: CONTROL OPTION
C
C
C       ********  MODIFIED VERSION, MARCH 1986  *************
C
C
C     ICONTR = 0: REDUCE ALL OFF-DIAGONAL ELEMENTS TO "DONE" OR SMALLER
C                                       -- THIS SETS FULMIX=.TRUE.
C
C     ICONTR = 1: DO THE SAME AS FOR ICONTR=0 EXCEPT DO NOT MIX ORBITALS THAT
C       ARE DEGENERATE TO WITHIN "DIFFER" IF THE OFFDIAGONAL ELEMENT CONNECTING
C       THEM IS LESS THAN "DIFFER".
C                                       -- THIS SETS FULMIX=.FALSE.
C
C  FOR THE PURPOSES OF THE NAO AND NBO PROGRAMS, THESE VALUES ARE SET:
C
C     DIFFER = 1.0D-5
C          THRESHOLD FOR CONSIDERING TWO VECTORS NONDEGENERATE IF
C                         ICONTR=1
C     DONE   = 1.0D-13
C          THIS IS THE PARAMETER FOR CONVERGENCE OF THE OFF-DIAGONAL
C             MATRIX ELEMENTS.  (ABSOLUTE)  --- Reduced from 1.0D-10
C             on 8/31/88.  A more converged Fock matrix was required
C             for the NBO deletions with symmetry to work properly
C             (EDG) ---
C
C     EPS    = 0.5D-13
C          THIS PARAMETER HAS TO DO WITH THE MACHINE PRECISION AND SHOULD
C             BE SET TO A VALUE BETWEEN "DONE" AND THE MACHINE PRECISION.
C             --- Reduced from 1.0D-11.  8/31/88 (EDG) ---
C
      LOGICAL FULMIX
      DIMENSION A(NDIM,1),EIVR(NVDIM,1),EIVU(1)
C  IMPORTANT PARAMETERS:
      DATA DIFFER,DONE,EPS,PT99/1.0D-5,1.0D-13,0.5D-13,0.99D0/
      DATA ZERO,ONE,FIVE/0.0D0,1.0D0,5.0D0/
C
      FULMIX=.TRUE.
      IF(ICONTR.EQ.1) FULMIX=.FALSE.
      IF(N.GT.1) GO TO 10
       EIVR(1,1)=ONE
       EIVU(1)=A(1,1)
       RETURN
   10 CONTINUE
      DO 30 J=1,N
        DO 20 I=1,N
   20     EIVR(I,J)=ZERO
   30   EIVR(J,J)=ONE
C
C        FIND THE ABSOLUTELY LARGEST ELEMENT OF A
C
C  FIRST CHECK THE OFF-DIAGONAL ELEMENTS:
      ATOP=ZERO
      DO 50 J=2,N
        JM1=J-1
        DO 50 I=1,JM1
          IF(ATOP.GT.ABS(A(I,J))) GO TO 50
          ATOP= ABS(A(I,J))
   50     CONTINUE
      OFFTOP=ATOP
C  NOW CHECK THE DIAGONAL ELEMENTS:
      DO 60 J=1,N
          IF(ATOP.GT.ABS(A(J,J))) GO TO 60
          ATOP= ABS(A(J,J))
   60     CONTINUE
C  IF MATRIX IS ALREADY EFFECTIVELY DIAGONAL,
C              PUT DIAGONAL ELEMENTS IN EIVU AND RETURN
      IF(ATOP.LT.DONE) GO TO 260
      IF(OFFTOP.LT.DONE) GO TO 260
C
C        CALCULATE THE STOPPING CRITERION -- DSTOP
C
      AVGF= FLOAT(N*(N-1)/2)
      D=0.0D0
      DO 80 JJ=2,N
        DO 80 II=2,JJ
          S=A(II-1,JJ)/ATOP
   80     D=S*S+D
      DSTOP=(1.D-7)*D
C
C        CALCULATE THE THRESHOLD, THRSH
C
      THRSH= SQRT(D/AVGF)*ATOP
C  TO MAKE THRSH DIFFERENT THAN ANY MATRIX ELEMENT OF A, MULTIPLY BY 0.99
      THRSH=THRSH*PT99
      IF(THRSH.LT.DONE) THRSH=DONE
C
C        START A SWEEP
C
   90 IFLAG=0
      DO 250 JCOL=2,N
        JCOL1=JCOL-1
        DO 250 IROW=1,JCOL1
          AIJ=A(IROW,JCOL)
C
C        COMPARE THE OFF-DIAGONAL ELEMENT WITH THRSH
C
          ABSAIJ=ABS(AIJ)
          IF (ABSAIJ.LT.THRSH) GO TO 250
          AII=A(IROW,IROW)
          AJJ=A(JCOL,JCOL)
          S=AJJ-AII
          ABSS=ABS(S)
C  DON'T ROTATE THE VECTORS IROW AND JCOL IF IROW AND JCOL WOULD STILL
C     BE DEGENERATE WITHIN "DIFFER":
          IF(FULMIX) GO TO 100
            IF((ABSS.LT.DIFFER).AND.(ABSAIJ.LT.DIFFER)) GO TO 250
  100     CONTINUE
C
C        CHECK TO SEE IF THE CHOSEN ROTATION IS LESS THAN THE ROUNDING ERROR
C        IF SO , THEN DO NOT ROTATE.
C
          TEST=EPS*ABSS
          IF (ABSAIJ.LT.TEST) GO TO 250
          IFLAG=1
C
C        IF THE ROTATION IS VERY CLOSE TO 45 DEGREES, SET SIN AND COS
C        TO 1/(ROOT 2).
C
          TEST=EPS*ABSAIJ
          IF (ABSS.GT.TEST) GO TO 130
          S=.707106781D0
          C=S
          GO TO 140
C
C        CALCULATION OF SIN AND COS FOR ROTATION THAT IS NOT VERY CLOSE
C        TO 45 DEGREES
C
  130     T=AIJ/S
          S=0.25D0/ SQRT(0.25D0+T*T)
C
C        COS=C ,  SIN=S
C
          C= SQRT(0.5D0+S)
          S=2.D0*T*S/C
C
C        CALCULATION OF THE NEW ELEMENTS OF MATRIX A
C
  140     DO 150 I=1,IROW
            T=A(I,IROW)
            U=A(I,JCOL)
            A(I,IROW)=C*T-S*U
  150       A(I,JCOL)=S*T+C*U
          I2=IROW+2
          IF (I2.GT.JCOL) GO TO 180
          DO 170 I=I2,JCOL
            T=A(I-1,JCOL)
            U=A(IROW,I-1)
            A(I-1,JCOL)=S*U+C*T
  170       A(IROW,I-1)=C*U-S*T
  180     A(JCOL,JCOL)=S*AIJ+C*AJJ
          A(IROW,IROW)=C*A(IROW,IROW)-S*(C*AIJ-S*AJJ)
          DO 190 J=JCOL,N
            T=A(IROW,J)
            U=A(JCOL,J)
            A(IROW,J)=C*T-S*U
  190       A(JCOL,J)=S*T+C*U
C
C        ROTATION COMPLETED
C
          DO 210 I=1,N
            T=EIVR(I,IROW)
            EIVR(I,IROW)=C*T-EIVR(I,JCOL)*S
  210       EIVR(I,JCOL)=S*T+EIVR(I,JCOL)*C
C
C        CALCULATE THE NEW NORM D AND COMPARE WITH DSTOP
C
          S=AIJ/ATOP
          D=D-S*S
          IF (D.GT.DSTOP) GO TO 240
C
C        RECALCULATE DSTOP AND THRSH TO DISCARD ROUNDING ERRORS
C
          D=ZERO
          DO 230 JJ=2,N
            DO 230 II=2,JJ
              S=A(II-1,JJ)/ATOP
  230         D=S*S+D
          DSTOP=(1.D-7)*D
  240     CONTINUE
          OLDTHR=THRSH
          THRSH= SQRT(D/AVGF)*ATOP*PT99
          IF(THRSH.LT.DONE) THRSH=DONE*PT99
          IF(THRSH.GT.OLDTHR) THRSH=OLDTHR
  250     CONTINUE
      IF(THRSH.LT.DONE) GO TO 260
      IF(IFLAG.EQ.1) GO TO 90
      THRSH=THRSH/FIVE
      GO TO 90
C
C        PLACE EIGENVALUES IN EIVU
C
  260 CONTINUE
      DO 270 J=1,N
        EIVU(J)=A(J,J)
  270   CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE LIMTRN(T,M,A,B,NDIM,NBAS,NCDIM,NC,IOPT)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION T(NDIM,NDIM),M(NCDIM),A(NCDIM,NCDIM),B(NCDIM)
C...DO A LIMITED TRANSFORMATION OF T, INCLUDING ONLY THE "NC" ROWS AND
C    COLUMNS SPECIFIED IN THE VECTOR "M":
C
C   IOPT= 1 :  TAKE T=T*A
C   IOPT= 0 :  TAKE T=A(TRANSPOSE)*T*A
C   IOPT=-1 :  TAKE T=A(TRANSPOSE)*T
C
C
      IF(IOPT.EQ.1) GO TO 100
C   FIRST, TAKE T=A(TRANSPOSE)*T, WHERE T=S,DM
        DO 30 J=1,NBAS
          DO 10 K=1,NC
   10     B(K)=T(M(K),J)
          DO 30 I=1,NC
            SUM=0.0D0
            DO 20 K=1,NC
   20         SUM=SUM+A(K,I)*B(K)
   30       T(M(I),J)=SUM
      IF(IOPT.EQ.-1) RETURN
C   NOW, TAKE T=T*A
  100 CONTINUE
        DO 160 I=1,NBAS
          DO 140 K=1,NC
  140       B(K)=T(I,M(K))
          DO 160 J=1,NC
            SUM=0.0D0
            DO 150 K=1,NC
  150         SUM=SUM+B(K)*A(K,J)
  160       T(I,M(J))=SUM
      RETURN
      END
C*****************************************************************************
      SUBROUTINE MATMLT(A,B,V,NDIM,N)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),B(1),V(NDIM)
      DATA ZERO/0.0D0/
C
C  MULTIPLY A*B (USING SCRATCH VECTOR V), STORE RESULT IN A:
C
      NDIF=NDIM-N
      DO 30 I=1,N
        KJ=0
        IKK=I-NDIM
        DO 20 J=1,N
          IK=IKK
          TEMP=ZERO
          DO 10 K=1,N
            IK=IK+NDIM
            KJ=KJ+1
   10       TEMP=TEMP+A(IK)*B(KJ)
          KJ=KJ+NDIF
   20   V(J)=TEMP
        IJ=I-NDIM
        DO 30 J=1,N
          IJ=IJ+NDIM
   30     A(IJ)=V(J)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE MATML2(A,B,V,NDIM,N)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),B(1),V(NDIM)
      DATA ZERO/0.0D0/
C                       B=A(TRANSPOSE)*B
C  MULTIPLY A(TRANSPOSE)*B (USING SCRATCH VECTOR V), STORE RESULT IN B:
C    ASSUME A*B IS A SYMMETRIC MATRIX, SO ALMOST HALF THE WORK IS SAVED.
C    THIS CAN BE THE SECOND STEP IN A SIMILARITY TRANSFORMATION OF B BY A.
C
      IJ=0
      IJJ=-NDIM
      KJJ=-NDIM
      DO 50 J=1,N
        KII=-NDIM
        KJJ=KJJ+NDIM
        DO 20 I=1,J
          KII=KII+NDIM
          KI=KII
          KJ=KJJ
          TEMP=ZERO
          DO 10 K=1,N
            KI=KI+1
            KJ=KJ+1
   10       TEMP=TEMP+A(KI)*B(KJ)
   20   V(I)=TEMP
        IJJ=IJJ+NDIM
        IJ=IJJ
        JI=J-NDIM
        JM1=J-1
        DO 30 I=1,JM1
          IJ=IJ+1
          JI=JI+NDIM
          VV=V(I)
          B(IJ)=VV
   30     B(JI)=VV
        IJ=IJ+1
   50   B(IJ)=V(J)
      RETURN
      END
C*****************************************************************************
      FUNCTION NAMEAT(IZ)
C*****************************************************************************
C
C  RETURN ATOMIC SYMBOL FOR NUCLEAR CHARGE IZ (.LE. 103):
C
      DIMENSION NAME(103)
      DATA IGHOST/'gh'/IBLANK/'  '/
      DATA NAME/' H','He','Li','Be',' B',' C',' N',' O',' F','Ne',
     + 'Na','Mg','Al','Si',' P',' S','Cl','Ar',' K','Ca','Sc','Ti',
     + ' V','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As',
     + 'Se','Br','Kr','Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru',
     + 'Rh','Pd','Ag','Cd','In','Sn','Sb','Te',' I','Xe','Cs',
     + 'Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy',
     + 'Ho','Er','Tm','Yb','Lu','Hf','Ta',' W','Re','Os','Ir',
     + 'Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn','Fr','Ra',
     + 'Ac','Th','Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es',
     + 'Fm','Md','No','Lr'/
C
      IF(IZ.LT.0.OR.IZ.GT.103) NAMEAT = IBLANK
      IF(IZ.GT.0) NAMEAT = NAME(IZ)
      IF(IZ.EQ.0) NAMEAT = IGHOST
      RETURN
      END
C*****************************************************************************
      SUBROUTINE NORMLZ(A,S,M,N)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(M,M),S(M,M)
C
      DATA ZERO,ONE /0.0D0,1.0D0/
C
C NORMALIZE COLUMNS OF A
C
      DO 40 I = 1,N
        TEMP = ZERO
        DO 20 J = 1,N
          DO 10 K = 1,N
            TEMP = TEMP + A(J,I)*A(K,I)*S(J,K)
   10     CONTINUE
   20   CONTINUE
        FACTOR = ONE/SQRT(TEMP)
        DO 30 J = 1,N
          A(J,I) = FACTOR * A(J,I)
   30   CONTINUE
   40 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE ORDER(RANK,LIST,N,NDIM,ARCRNK)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  RANK POSITIVE ELEMENTS OF INTEGER 'LIST', LOWEST VALUES FIRST.
C
      INTEGER RANK,ARCRNK,TEMP
      DIMENSION RANK(NDIM),LIST(NDIM),ARCRNK(NDIM)
      DO 10 I=1,N
   10   ARCRNK(I)=I
      DO 40 I=1,N
        IF(I.EQ.N)GO TO 30
        I1=I+1
        DO 20 J=I1,N
          IF(LIST(J).GE.LIST(I))GO TO 20
          TEMP=LIST(I)
          LIST(I)=LIST(J)
          LIST(J)=TEMP
          TEMP=ARCRNK(I)
          ARCRNK(I)=ARCRNK(J)
          ARCRNK(J)=TEMP
   20     CONTINUE
   30   RANK(ARCRNK(I))=I
        IF(LIST(I).LE.0) GO TO 50
   40   CONTINUE
      RETURN
   50 DO 60 K=I,N
        RANK(ARCRNK(K))=0
   60   CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE PACK(T,NDIM,NBAS,L2)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION T(1)
C
      DATA ZERO/0.0D0/
C
C  PACK:  PACKS A SYMMETRIC MATRIX T INTO AN UPPER TRIANGULAR MATRIX.
C         T SHOULD BE DIMENSIONED (NDIM,NDIM) IN THE CALLING ROUTINE:
C
      IF(NBAS.GT.NDIM) STOP 'NBAS IS GREATER THAN NDIM'
      II = 0
      DO 200 J = 1,NBAS
        JPTR = (J-1) * NDIM
        DO 100 I = 1,J
          IPTR = JPTR + I
          II = II + 1
          T(II) = T(IPTR)
  100   CONTINUE
  200 CONTINUE
      IF(II.NE.L2) STOP 'ERROR IN ROUTINE PACK'
C
      DO 300 I = II+1,NDIM*NDIM
        T(I) = ZERO
  300 CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE RANK(EIG,N,NDIM,ARCRNK)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  ORDER NUMBERS IN 'EIG', HIGHEST VALUES FIRST,
C    AND CONSTRUCT 'ARCRNK':
C     ARCRNK(I) IS THE OLD LOCATION OF THE I-TH HIGHEST VALUE IN EIG
C      NOTE: UPON RETURN, EIG(I) IS THE I-TH HIGHEST VALUE IN EIG
C      IMPORTANT: NUMBERS IN EIG ARE NOT SWITCHED UNLESS THEY DIFFER
C       BY MORE THAN "DIFFER":  5.0D-8
C
      INTEGER ARCRNK
      DIMENSION ARCRNK(NDIM),EIG(NDIM)
      DATA DIFFER/5.0D-8/
      DO 10 I=1,N
   10   ARCRNK(I)=I
      DO 40 I=1,N
        IF(I.EQ.N)GO TO 40
        I1=I+1
        DO 20 J=I1,N
          IF((EIG(J)-EIG(I)).LT.DIFFER) GO TO 20
          TEMP=EIG(I)
          EIG(I)=EIG(J)
          EIG(J)=TEMP
          ITEMP=ARCRNK(I)
          ARCRNK(I)=ARCRNK(J)
          ARCRNK(J)=ITEMP
   20     CONTINUE
   40   CONTINUE
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SIMTRN(A,T,V,NDIM,N)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  SIMILARITY TRANSFORM A ==> T(TRANSPOSE)*A*T, USING SCRATCH VECTOR V.
C
      DIMENSION A(NDIM,NDIM),T(NDIM,NDIM),V(NDIM)
      CALL MATMLT(A,T,V,NDIM,N)
      CALL TRANSP(A,NDIM,N)
      CALL MATMLT(A,T,V,NDIM,N)
      CALL TRANSP(A,NDIM,N)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE SIMTRS(A,S,V,NDIM,N)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  SIMILARITY TRANSFORM A ==> S(TRANSPOSE)*A*S, USING SCRATCH VECTOR V.
C    FAST VERSION --- ASSUMES RESULT IS A SYMMETRIC MATRIX
C
      DIMENSION A(NDIM,NDIM),S(NDIM,NDIM),V(NDIM)
      CALL MATMLT(A,S,V,NDIM,N)
      CALL MATML2(S,A,V,NDIM,N)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE TRANSP(A,NDIM,N)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NDIM,NDIM)
C
C  TRANSPOSE MATRIX A, STORE RESULT IN A.
C
      DO 10 I=1,N
        DO 10 J=1,I
          TEMP=A(I,J)
          A(I,J)=A(J,I)
   10     A(J,I)=TEMP
      RETURN
      END
C*****************************************************************************
      SUBROUTINE UNPACK(T,NDIM,NBAS,L2)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION T(1)
C
C  UNPACK:  UNPACKS AN UPPER TRIANGULAR MATRIX (VECTOR L2 LONG) INTO A
C           SYMMETRIC MATRIX T(NBAS,NBAS).  NOTE: T SHOULD BE DIMENSIONED
C           (NDIM,NDIM) IN THE CALLING ROUTINE.
C
C  FIRST SPREAD OUT THE L2 NUMBERS INTO THE UPPER PART OF THE WHOLE ARRAY.
C
      J = 0
      K = 1
      IPTR = (NDIM + 1)*(NBAS - K) + 1
      DO 200 I = L2,1,-1
        T(IPTR-J) = T(I)
        IF(J.LT.NBAS-K) THEN
          J = J + 1
        ELSE
          J = 0
          K = K + 1
          IPTR = (NDIM + 1)*(NBAS - K) + 1
        END IF
  200 CONTINUE
C
C  NOW FILL IN THE HOLES IN THE OUTPUT ARRAY.
C
      DO 400 J = 1,NBAS-1
        ICOL = (J-1)*NDIM
        DO 300 I = J+1,NBAS
          IPTR = ICOL + I
          JPTR = (I-1)*NDIM + J
          T(IPTR) = T(JPTR)
  300   CONTINUE
  400 CONTINUE
C
      RETURN
      END
C*****************************************************************************
      SUBROUTINE VALTBL(IAT,IVAL)
C*****************************************************************************
C
C   VALENCE TABLE:
C
C     Determine the number of sets of valence orbitals of each angular
C     symmetry for atom number IAT.  IVAL is an integer array LMAX+1
C     long which returns the number of sets to the calling subroutine:
C     the number of `s' subshells in IVAL(1), the number of `p' subshells
C     in IVAL(2), etc...
C
C------------------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (LMAX = 3)
      DIMENSION IVAL(4),ICORE(4),IORD(20)
C
      PARAMETER(MAXATM = 99,MAXBAS = 500)
      COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM),
     +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)  
      COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,
     + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,
     + JCORE,JPRINT(60)
C
      DATA IORD/1,1,3,1,3,1,5,3,1,5,3,1,7,5,3,1,7,5,3,1/
C
      DO 10 L = 0,LMAX
        IVAL(L+1) = 0
   10 CONTINUE
C
C  Count the number of filled or partially filled subshells:
C
      II = IATNO(IAT)
      IF(II.GT.0) THEN
        ICT = 0
   20   ICT = ICT + 1
        L = IORD(ICT)/2
        IVAL(L+1) = IVAL(L+1) + 1
        II = II - 2*IORD(ICT)
        IF(II.GT.0) GOTO 20
      END IF
C
C  Remove the core subshells.  Note: if there are more core orbitals
C  in the effective core potential than in the nominal core table or
C  from the CORE option, remove these extra core orbitals from the
C  set of valence orbitals:
C
      IECP = 1
      CALL CORTBL(IAT,ICORE,IECP)
      DO 50 L = 0,LMAX
        IVAL(L+1) = IVAL(L+1) - ICORE(L+1)
   50 CONTINUE
      IECP = 0
      CALL CORTBL(IAT,ICORE,IECP)
      DO 60 L = 0,LMAX
        IF(ICORE(L+1).LT.0) THEN
          IVAL(L+1) = IVAL(L+1) + ICORE(L+1)
        END IF
   60 CONTINUE
      RETURN
      END
C*****************************************************************************
      FUNCTION VECLEN(X,N,NDIM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION X(NDIM)
      DATA ZERO/0.0D0/
C
      SUM = ZERO
      DO 10 I = 1,N
        SUM = SUM + X(I)*X(I)
   10 CONTINUE
      VECLEN = SQRT(SUM)
      RETURN
      END
C*****************************************************************************
      SUBROUTINE LINEQ(A,X,B,SCR,N,M,NDIM,MDIM,ZERTOL,EPS,MAXIT,LFNPR,
     +                 IERR)
C*****************************************************************************
C
C  Solve the system of linear equations  A * X  =  B  for matrix X
C                                        ~   ~     ~             ~
C  Input
C -------
C  * Coefficient matrix A of dimension (N,N) with actual
C    dimension (NDIM,NDIM).
C  * Matrix B of dimension (N,M) with actual dimension
C    (NDIM,MDIM)
C  * Working space SCR dimensioned (NDIM,NDIM+5).
C  * Zero tolerance ZERTOL.
C  * Threshold on Euclidean norm (vector length) of the
C    error vector relative to the norm of a column of X.
C  * Maximum number of iterations MAXIT allowed during
C    iterative improvement.
C  * Logical file number LFNPR for printing during iterative
C    improvement.  Set to zero to no printing is desired.
C
C  Output
C --------
C  * Solution X of dimension (N,M) with actual dimension
C    (NDIM,MDIM).
C  * Euclidean norm of the final error vector, EPS.
C  * Number of iterations taken during interative improvement,
C    MAXIT.
C  * Error flag :    IERR = -1   Iterative improvement did not
C                                converge
C                    IERR =  0   No errors encountered
C                    IERR =  1   A matrix is not invertible
C
C------------------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NDIM,NDIM),X(NDIM,MDIM),B(NDIM,MDIM),
     +          SCR(NDIM*(NDIM+5))
      DATA ZERO/0.0/
C
      IF(N.LT.1) STOP 'Dimension N is not positive'
C
C  Partition scratch space:
C
      I1 = 1
      I2 = I1 + NDIM*NDIM
      I3 = I2 + NDIM
      I4 = I3 + NDIM
      I5 = I4 + NDIM
      I6 = I5 + NDIM
C
C  Perform Gauss elimination with scaled partial pivoting:
C
      CALL FACTOR(A,SCR(I1),SCR(I2),SCR(I6),N,NDIM,ZERTOL,IFLAG)
      IF(IFLAG.EQ.0) THEN
        IERR = 1
        RETURN
      ELSE
        IERR = 0
      END IF
C
C  Loop over columns of X and B:
C
      EPSMAX = ZERO
      ITSMAX = 0
      DO 30 KCOL = 1,M
        DO 10 JROW = 1,N
          SCR(I4+JROW-1) = X(JROW,KCOL)
          SCR(I5+JROW-1) = B(JROW,KCOL)
   10   CONTINUE
        ITS = MAXIT
        DEL = EPS
C
C  Use back-substitution and iterative improvement to determine
C  the solution X:
C
        CALL FNDSOL(A,SCR(I4),SCR(I5),SCR(I1),SCR(I2),SCR(I3),SCR(I6),
     +              N,NDIM,DEL,ITS,LFNPR,IERR)
        IF(IERR.NE.0) RETURN
C
C  Copy solution into X:
C
        DO 20 JROW = 1,N
          X(JROW,KCOL) = SCR(I4+JROW-1)
   20   CONTINUE
        IF(DEL.GT.EPSMAX) EPSMAX = DEL
        IF(ITS.GT.ITSMAX) ITSMAX = ITS
   30 CONTINUE
C
      EPS = EPSMAX
      MAXIT = ITSMAX
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FACTOR(A,W,D,IPIVOT,N,NDIM,ZERTOL,IFLAG)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NDIM,NDIM),W(NDIM,NDIM),D(NDIM),IPIVOT(NDIM)
      DATA ZERO,ONE/0.0D0,1.0D0/
C
C  Initial IFLAG.  If IFLAG is 1, then an even number of interchanges
C  has been carried out.  If equal to -1, then an odd number of inter-
C  changes have taken place.  If IFLAG is set to zero on return to the
C  calling routine, then the matrix is not invertible:
C
      IFLAG = 1
C
C  Copy coefficient matrix A to W:
C
      CALL COPY(A,W,NDIM,N,N)
C
C  Initialize D and IPIVOT:
C
      DO 20 I = 1,N
        IPIVOT(I) = I
        ROWMAX = ZERO
        DO 10 J = 1,N
          IF(ABS(W(I,J)).GT.ROWMAX) ROWMAX = ABS(W(I,J))
   10   CONTINUE
        IF(ROWMAX.LE.ZERTOL) THEN
          IFLAG = 0
          ROWMAX = ONE
        END IF
        D(I) = ROWMAX
   20 CONTINUE
      IF(N.EQ.1) RETURN
C
C  Loop over rows, factorizing matrix W:
C
      DO 100 K = 1,N-1
C
C  Determine the pivot row ISTAR:
C
        COLMAX = ABS(W(K,K))/D(K)
        ISTAR = K
        DO 30 I = K+1,N
          TEMP = ABS(W(I,K))/D(K)
          IF(TEMP.GT.COLMAX) THEN
            COLMAX = TEMP
            ISTAR = I
          END IF
   30   CONTINUE
        IF(COLMAX.EQ.ZERO) THEN
          IFLAG = 0
        ELSE
          IF(ISTAR.GT.K) THEN
            IFLAG = -IFLAG
            ITEMP = IPIVOT(ISTAR)
            IPIVOT(ISTAR) = IPIVOT(K)
            IPIVOT(K) = ITEMP
            TEMP = D(ISTAR)
            D(ISTAR) = D(K)
            D(K) = TEMP
            DO 40 J = 1,N
              TEMP = W(ISTAR,J)
              W(ISTAR,J) = W(K,J)
              W(K,J) = TEMP
   40       CONTINUE
          END IF
C
C  Eliminate X(K) from rows K+1,...,N:
C
          DO 60 I = K+1,N
            W(I,K) = W(I,K)/W(K,K)
            DO 50 J = K+1,N
              W(I,J) = W(I,J) - W(I,K)*W(K,J)
   50       CONTINUE
   60     CONTINUE
        END IF
  100 CONTINUE
      IF(ABS(W(N,N)).LE.ZERTOL) IFLAG = 0
      RETURN
      END
C*****************************************************************************
      SUBROUTINE FNDSOL(A,X,B,W,R,E,IPIVOT,N,NDIM,EPS,MAXIT,LFNPR,IERR)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(NDIM,NDIM),X(NDIM),B(NDIM),W(NDIM,NDIM),R(NDIM),
     +          E(NDIM),IPIVOT(NDIM)
      DATA ZERO/0.0D0/
C
C  Find initial guess for X by back substitution:
C
      CALL COPY(B,E,NDIM,N,1)
      CALL SUBST(X,W,E,IPIVOT,N,NDIM)
      IF(MAXIT.EQ.0) RETURN
C
C  Iterate until the vector length of the error vector relative to
C  X is less than EPS:
C
      RELLEN = ZERO
      ITER = 0
   10 IF(RELLEN.GT.EPS) THEN
        ITER = ITER + 1
        DO 30 I = 1,N
          R(I) = B(I)
          DO 20 J = 1,N
            R(I) = R(I) - A(I,J)*X(J)
   20     CONTINUE
   30   CONTINUE
        CALL SUBST(E,W,R,IPIVOT,N,NDIM)
        ELEN = VECLEN(E,N,NDIM)
        XLEN = VECLEN(X,N,NDIM)
        RELLEN = ELEN/XLEN
        DO 40 I = 1,N
          X(I) = X(I) + E(I)
   40   CONTINUE
C
C  Print out iterative improvement info:
C
        IF(LFNPR.GT.0) THEN
          WRITE(LFNPR,900) ITER,RELLEN
        END IF
C
C  If too many iterations have taken place, halt furthur iterations:
C
        IF(ITER.EQ.MAXIT) THEN
          IF(RELLEN.GT.EPS) IERR = -1
          IF(LFNPR.GT.0) THEN
            IF(IERR.LT.0) THEN
              WRITE(LFNPR,910)
            ELSE
              WRITE(LFNPR,920)
            END IF
          END IF
          EPS = RELLEN
          RETURN
        END IF
C
C  Error vector is converged:
C
      ELSE
        IF(LFNPR.GT.0) WRITE(LFNPR,920)
        EPS = RELLEN
        MAXIT = ITER
        RETURN
      END IF
      GOTO 10
C
  900 FORMAT(1X,'Iter = ',I3,'    relative length = ',F10.7)
  910 FORMAT(1X,'No convergence within the specified number of ',
     + 'iterations')
  920 FORMAT(1X,'The error vector is converged')
      END
C*****************************************************************************
      SUBROUTINE SUBST(X,W,B,IPIVOT,N,NDIM)
C*****************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION X(NDIM),W(NDIM,NDIM),B(NDIM),IPIVOT(NDIM)
      DATA ZERO/0.0D0/
C
      IF(N.EQ.1) THEN
        X(1) = B(1)/W(1,1)
        RETURN
      END IF
C
C  Use multipliers stored in W and back substitution to find X:
C
      IP = IPIVOT(1)
      X(1) = B(IP)
      DO 20 I = 2,N
        SUM = ZERO
        DO 10 J = 1,I-1
          SUM = W(I,J)*X(J) + SUM
   10   CONTINUE
        IP = IPIVOT(I)
        X(I) = B(IP) - SUM
   20 CONTINUE
      X(N) = X(N)/W(N,N)
      DO 40 I = N-1,1,-1
        SUM = ZERO
        DO 30 J = I+1,N
          SUM = W(I,J)*X(J) + SUM
   30   CONTINUE
        X(I) = (X(I) - SUM)/W(I,I)
   40 CONTINUE
      RETURN
      END
C*****************************************************************************
C
C                 E N D    O F    N B O    P R O G R A M 
C
C*****************************************************************************
C***********************************************************************GENDRV
C                                                                       GENDRV
C                                                                       GENDRV
C                          G  E  N  N  B  O                             GENDRV
C                                                                       GENDRV
C                                                                       GENDRV
C                    GENERAL VERSION OF NBO PROGRAM                     GENDRV
C                                                                       GENDRV
C                                                                       GENDRV
C  DRIVER ROUTINES:                                                     GENDRV
C                                                                       GENDRV
C      SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                             GENDRV
C      SUBROUTINE CRDINP(TITLE,ATCOOR,BOHR)                             GENDRV
C      SUBROUTINE BASINP                                                GENDRV
C      SUBROUTINE CONINP(CORE,ICORE)                                    GENDRV
C      SUBROUTINE SINP(CORE,UPPER)                                      GENDRV
C      SUBROUTINE DMINP(CORE,UPPER)                                     GENDRV
C      SUBROUTINE FINP(CORE,UPPER,END)                                  GENDRV
C      SUBROUTINE TINP(CORE)                                            GENDRV
C      SUBROUTINE DIPINP(CORE,UPPER,BOHR)                               GENDRV
C                                                                       GENDRV
C***********************************************************************GENDRV
*     PROGRAM GENNBO                                                    GENDRV
C***********************************************************************GENDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GENDRV
C                                                                       GENDRV
*     PARAMETER(MEMORY = 1000000)                                       GENDRV
*     DIMENSION CORE(MEMORY),NBOOPT(10)                                 GENDRV
C                                                                       GENDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
*    +           LFNDAF,LFNDEF                                          GENDRV
C                                                                       GENDRV
*     LFNIN = 5                                                         GENDRV
*     LFNPR = 6                                                         GENDRV
C                                                                       GENDRV
C  Set NBO options.                                                     GENDRV
C                                                                       GENDRV
*     NBOOPT(1)  =  0                                                   GENDRV
*     NBOOPT(2)  =  0                                                   GENDRV
*     NBOOPT(3)  =  0                                                   GENDRV
*     NBOOPT(4)  =  0                                                   GENDRV
*     NBOOPT(5)  =  0                                                   GENDRV
*     NBOOPT(6)  =  0                                                   GENDRV
*     NBOOPT(7)  =  0                                                   GENDRV
*     NBOOPT(8)  =  0                                                   GENDRV
*     NBOOPT(9)  =  0                                                   GENDRV
*     NBOOPT(10) =  0                                                   GENDRV
C                                                                       GENDRV
C  Perform the NPA/NBO/NLMO analyses.                                   GENDRV
C                                                                       GENDRV
*     CALL NBO(CORE,MEMORY,NBOOPT)                                      GENDRV
C                                                                       GENDRV
*     CALL EXIT                                                         GENDRV
*     END                                                               GENDRV
C***********************************************************************GENDRV
*     SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                              GENDRV
C***********************************************************************GENDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GENDRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             GENDRV
*     LOGICAL END                                                       GENDRV
C                                                                       GENDRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               GENDRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       GENDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       GENDRV
*     COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,        GENDRV
*    + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    GENDRV
*    + JCORE,JPRINT(60)                                                 GENDRV
*     COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)                             GENDRV
*     COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), GENDRV
*    +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)                     GENDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
*    +           LFNDAF,LFNDEF                                          GENDRV
*     COMMON/NBGEN/REUSE,UPPER,BOHR,DENOP                               GENDRV
*     LOGICAL REUSE,UPPER,BOHR,DENOP                                    GENDRV
C                                                                       GENDRV
*     IF(REUSE) THEN                                                    GENDRV
C                                                                       GENDRV
C  Restore wavefunction information from the NBO DAF:                   GENDRV
C                                                                       GENDRV
C  Restore NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:       GENDRV
C                                                                       GENDRV
*       NFILE = 3                                                       GENDRV
*       CALL NBREAD(ICORE,12,NFILE)                                     GENDRV
*       II = 0                                                          GENDRV
*       II = II + 1                                                     GENDRV
*       NATOMS = ICORE(II)                                              GENDRV
*       II = II + 1                                                     GENDRV
*       NDIM   = ICORE(II)                                              GENDRV
*       II = II + 1                                                     GENDRV
*       NBAS   = ICORE(II)                                              GENDRV
*       II = II + 1                                                     GENDRV
*       MUNIT  = ICORE(II)                                              GENDRV
*       II = II + 1                                                     GENDRV
*       ROHF   = .FALSE.                                                GENDRV
*       IF(ICORE(II).EQ.1)  ROHF  = .TRUE.                              GENDRV
*       II = II + 1                                                     GENDRV
*       UHF    = .FALSE.                                                GENDRV
*       IF(ICORE(II).EQ.1)  UHF   = .TRUE.                              GENDRV
*       II = II + 1                                                     GENDRV
*       CI     = .FALSE.                                                GENDRV
*       IF(ICORE(II).EQ.1)  CI    = .TRUE.                              GENDRV
*       II = II + 1                                                     GENDRV
*       OPEN   = .FALSE.                                                GENDRV
*       IF(ICORE(II).EQ.1)  OPEN  = .TRUE.                              GENDRV
*       II = II + 1                                                     GENDRV
*       MCSCF  = .FALSE.                                                GENDRV
*       IF(ICORE(II).EQ.1)  MCSCF = .TRUE.                              GENDRV
*       II = II + 1                                                     GENDRV
*       AUHF   = .FALSE.                                                GENDRV
*       IF(ICORE(II).EQ.1) AUHF  = .TRUE.                               GENDRV
*       II = II + 1                                                     GENDRV
*       ORTHO  = .FALSE.                                                GENDRV
*       IF(ICORE(II).EQ.1) ORTHO = .TRUE.                               GENDRV
*       II = II + 1                                                     GENDRV
*       ISWEAN = ICORE(II)                                              GENDRV
C                                                                       GENDRV
C  No Fock matrix from ROHF, MCSCF, or CI wave functions:               GENDRV
C                                                                       GENDRV
*       IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0                              GENDRV
C                                                                       GENDRV
C  Restore IATNO, IZNUC, LCTR, LANG:                                    GENDRV
C                                                                       GENDRV
*       NFILE = 4                                                       GENDRV
*       CALL NBREAD(ICORE,2*NATOMS+2*NBAS,NFILE)                        GENDRV
*       II = 0                                                          GENDRV
*       DO 70 I = 1,NATOMS                                              GENDRV
*         II = II + 1                                                   GENDRV
*         IATNO(I) = ICORE(II)                                          GENDRV
*  70   CONTINUE                                                        GENDRV
*       DO 80 I = 1,NATOMS                                              GENDRV
*         II = II + 1                                                   GENDRV
*         IZNUC(I) = ICORE(II)                                          GENDRV
*         IF(IZNUC(I).NE.IATNO(I)) IPSEUD = 1                           GENDRV
*  80   CONTINUE                                                        GENDRV
*       DO 90 I = 1,NBAS                                                GENDRV
*         II = II + 1                                                   GENDRV
*         LCTR(I) = ICORE(II)                                           GENDRV
*  90   CONTINUE                                                        GENDRV
*       DO 95 I = 1,NBAS                                                GENDRV
*         II = II + 1                                                   GENDRV
*         LANG(I)  = ICORE(II)                                          GENDRV
*  95   CONTINUE                                                        GENDRV
*     ELSE                                                              GENDRV
C                                                                       GENDRV
C  Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:         GENDRV
C                                                                       GENDRV
*       II = 0                                                          GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II)  = NATOMS                                             GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II)  = NDIM                                               GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II)  = NBAS                                               GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II)  = MUNIT                                              GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II)  = 0                                                  GENDRV
*       IF(ROHF)  ICORE(II)  = 1                                        GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II)  = 0                                                  GENDRV
*       IF(UHF)   ICORE(II)  = 1                                        GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II)  = 0                                                  GENDRV
*       IF(CI)    ICORE(II)  = 1                                        GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II)  = 0                                                  GENDRV
*       IF(OPEN)  ICORE(II)  = 1                                        GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II)  = 0                                                  GENDRV
*       IF(MCSCF) ICORE(II)  = 1                                        GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II) = 0                                                   GENDRV
*       IF(AUHF)  ICORE(II) = 1                                         GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II) = 0                                                   GENDRV
*       IF(ORTHO) ICORE(II) = 1                                         GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II) = 1                                                   GENDRV
*       NFILE = 3                                                       GENDRV
*       CALL NBWRIT(ICORE,12,NFILE)                                     GENDRV
C                                                                       GENDRV
C  Read wavefunction info, density matrix, etc. from LFNIN:             GENDRV
C                                                                       GENDRV
C  Read in job title, atoms, nuclear charges, and coords:               GENDRV
C                                                                       GENDRV
*       CALL CRDINP(CORE,CORE,BOHR)                                     GENDRV
C                                                                       GENDRV
C  Read in the AO basis set:                                            GENDRV
C                                                                       GENDRV
*       CALL CONINP(CORE,CORE)                                          GENDRV
C                                                                       GENDRV
C  Read basis function labels and centers:                              GENDRV
C                                                                       GENDRV
*       CALL BASINP                                                     GENDRV
C                                                                       GENDRV
C  Store IATNO, IZNUC, LCTR, and LANG on NBO DAF:                       GENDRV
C                                                                       GENDRV
*       II = 0                                                          GENDRV
*       DO 170 I = 1,NATOMS                                             GENDRV
*         II = II + 1                                                   GENDRV
*         ICORE(II) = IATNO(I)                                          GENDRV
* 170   CONTINUE                                                        GENDRV
*       DO 180 I = 1,NATOMS                                             GENDRV
*         II = II + 1                                                   GENDRV
*         ICORE(II) = IZNUC(I)                                          GENDRV
* 180   CONTINUE                                                        GENDRV
*       DO 190 I = 1,NBAS                                               GENDRV
*         II = II + 1                                                   GENDRV
*         ICORE(II) = LCTR(I)                                           GENDRV
* 190   CONTINUE                                                        GENDRV
*       DO 200 I = 1,NBAS                                               GENDRV
*         II = II + 1                                                   GENDRV
*         ICORE(II) = LANG(I)                                           GENDRV
* 200   CONTINUE                                                        GENDRV
*       NFILE = 4                                                       GENDRV
*       CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE)                        GENDRV
C                                                                       GENDRV
C  Read the overlap matrix from LFNIN and store on the NBO DAF:         GENDRV
C                                                                       GENDRV
*       IF(.NOT.ORTHO) CALL SINP(CORE,UPPER)                            GENDRV
C                                                                       GENDRV
C  Read the density matrix from LFNIN and store on the NBO DAF:         GENDRV
C                                                                       GENDRV
*       CALL DMINP(CORE,UPPER)                                          GENDRV
*       IF(DENOP) IWDM = 0                                              GENDRV
C                                                                       GENDRV
C  Read the Fock matrix from LFNIN and store on the NBO DAF:            GENDRV
C                                                                       GENDRV
*       CALL FINP(CORE,UPPER,END)                                       GENDRV
*       IF(END) THEN                                                    GENDRV
*         IWFOCK = 0                                                    GENDRV
*         IF(OPEN) ROHF = .TRUE.                                        GENDRV
*       ELSE                                                            GENDRV
*         IWFOCK = 1                                                    GENDRV
*         IF(OPEN) UHF  = .TRUE.                                        GENDRV
*       END IF                                                          GENDRV
C                                                                       GENDRV
C  Read the AO to MO transformation matrix from LFNIN and store on the  GENDRV
C  NBO DAF:                                                             GENDRV
C                                                                       GENDRV
*       CALL TINP(CORE)                                                 GENDRV
C                                                                       GENDRV
C  Read the dipole integrals from LFNIN and store on the NBO DAF:       GENDRV
C                                                                       GENDRV
*       CALL DIPINP(CORE,UPPER,BOHR)                                    GENDRV
*     END IF                                                            GENDRV
*     RETURN                                                            GENDRV
*     END                                                               GENDRV
C***********************************************************************GENDRV
*     SUBROUTINE CRDINP(TITLE,ATCOOR,BOHR)                              GENDRV
C***********************************************************************GENDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GENDRV
*     DIMENSION KEYWD(6),KCOORD(6)                                      GENDRV
*     LOGICAL ERROR,END,BOHR,EQUAL                                      GENDRV
C                                                                       GENDRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               GENDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       GENDRV
*     COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,        GENDRV
*    + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    GENDRV
*    + JCORE,JPRINT(60)                                                 GENDRV
*     COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), GENDRV
*    +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)                     GENDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
*    +           LFNDAF,LFNDEF                                          GENDRV
C                                                                       GENDRV
*     DIMENSION TITLE(10),ATCOOR(3*NATOMS)                              GENDRV
C                                                                       GENDRV
*     DATA KCOORD/1H$,1HC,1HO,1HO,1HR,1HD/                              GENDRV
*     DATA TOANG/0.529177249/                                           GENDRV
C                                                                       GENDRV
C  Search LFNIN for $COORD datalist:                                    GENDRV
C                                                                       GENDRV
*     REWIND(LFNIN)                                                     GENDRV
*  10 CALL STRTIN(LFNIN)                                                GENDRV
*     LEN = 6                                                           GENDRV
*     CALL HFLD(KEYWD,LEN,END)                                          GENDRV
*     IF(LEN.EQ.0.AND.END) STOP 'No $COORD datalist in the input file'  GENDRV
*     IF(.NOT.EQUAL(KEYWD,KCOORD,6)) GOTO 10                            GENDRV
C                                                                       GENDRV
C  Read job title and store on NBO DAF:                                 GENDRV
C                                                                       GENDRV
*     READ(LFNIN,1000) (TITLE(I),I=1,10)                                GENDRV
*     NFILE = 2                                                         GENDRV
*     CALL NBWRIT(TITLE,10,NFILE)                                       GENDRV
C                                                                       GENDRV
C  Loop over atoms, reading atomic number, nuclear charge, and coords:  GENDRV
C                                                                       GENDRV
*     II = 0                                                            GENDRV
*     CALL STRTIN(LFNIN)                                                GENDRV
*     DO 100 IAT = 1,NATOMS                                             GENDRV
*       CALL IFLD(IATNO(IAT),ERROR)                                     GENDRV
*       IF(ERROR) STOP 'Error reading atomic number'                    GENDRV
*       CALL IFLD(IZNUC(IAT),ERROR)                                     GENDRV
*       IF(ERROR) STOP 'Error reading nuclear charge'                   GENDRV
*       IF(IATNO(IAT).NE.IZNUC(IAT)) IPSEUD = 1                         GENDRV
*       II = II + 1                                                     GENDRV
*       CALL RFLD(ATCOOR(II),ERROR)                                     GENDRV
*       IF(ERROR) STOP 'Error reading x coordinate'                     GENDRV
*       II = II + 1                                                     GENDRV
*       CALL RFLD(ATCOOR(II),ERROR)                                     GENDRV
*       IF(ERROR) STOP 'Error reading y coordinate'                     GENDRV
*       II = II + 1                                                     GENDRV
*       CALL RFLD(ATCOOR(II),ERROR)                                     GENDRV
*       IF(ERROR) STOP 'Error reading z coordinate'                     GENDRV
* 100 CONTINUE                                                          GENDRV
C                                                                       GENDRV
C  Convert atomic coords to angstroms if entered in bohr:               GENDRV
C                                                                       GENDRV
*     IF(BOHR) THEN                                                     GENDRV
*       DO 200 I = 1,3*NATOMS                                           GENDRV
*         ATCOOR(I) = ATCOOR(I) * TOANG                                 GENDRV
* 200   CONTINUE                                                        GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Store the atomic coordinates on the NBO DAF:                         GENDRV
C                                                                       GENDRV
*     NFILE = 9                                                         GENDRV
*     CALL NBWRIT(ATCOOR,3*NATOMS,NFILE)                                GENDRV
*     RETURN                                                            GENDRV
C                                                                       GENDRV
*1000 FORMAT(10A8)                                                      GENDRV
*     END                                                               GENDRV
C***********************************************************************GENDRV
*     SUBROUTINE BASINP                                                 GENDRV
C***********************************************************************GENDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GENDRV
*     DIMENSION KEYWD(6),KBASIS(6),KCTR(6),KLABEL(5),KEND(4)            GENDRV
*     LOGICAL ERROR,END,EQUAL                                           GENDRV
C                                                                       GENDRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               GENDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       GENDRV
*     COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)                             GENDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
*    +           LFNDAF,LFNDEF                                          GENDRV
C                                                                       GENDRV
*     DATA KBASIS/1H$,1HB,1HA,1HS,1HI,1HS/,KLABEL/1HL,1HA,1HB,1HE,1HL/, GENDRV
*    + KCTR/1HC,1HE,1HN,1HT,1HE,1HR/,KEND/1H$,1HE,1HN,1HD/              GENDRV
C                                                                       GENDRV
C  Search LFNIN for $BASIS datalist:                                    GENDRV
C                                                                       GENDRV
*     REWIND(LFNIN)                                                     GENDRV
*  10 CALL STRTIN(LFNIN)                                                GENDRV
*     LEN = 6                                                           GENDRV
*     CALL HFLD(KEYWD,LEN,END)                                          GENDRV
*     IF(LEN.EQ.0.AND.END) STOP 'No $BASIS datalist in the input file'  GENDRV
*     IF(.NOT.EQUAL(KEYWD,KBASIS,6)) GOTO 10                            GENDRV
C                                                                       GENDRV
C  Read in BOTH LCTR and LANG arrays:                                   GENDRV
C                                                                       GENDRV
*     MCTR = 0                                                          GENDRV
*     MANG = 0                                                          GENDRV
*  20 LEN = 6                                                           GENDRV
*     CALL HFLD(KEYWD,LEN,END)                                          GENDRV
*     IF(END) STOP 'End encountered while reading $BASIS datalist'      GENDRV
*     IF(EQUAL(KEYWD,KEND,4)) GOTO 100                                  GENDRV
C                                                                       GENDRV
C  Keyword CENTER -- basis function centers:                            GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KCTR,6)) THEN                                      GENDRV
*       DO 30 I = 1,NBAS                                                GENDRV
*         CALL IFLD(LCTR(I),ERROR)                                      GENDRV
*         IF(ERROR) STOP 'Error reading orbital centers in $BASIS'      GENDRV
*  30   CONTINUE                                                        GENDRV
*       MCTR = 1                                                        GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Keyword LABEL -- basis orbital symmetries:                           GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KLABEL,5)) THEN                                    GENDRV
*       DO 40 I = 1,NBAS                                                GENDRV
*         CALL IFLD(LANG(I),ERROR)                                      GENDRV
*         IF(ERROR) STOP 'Error reading orbital labels in $BASIS'       GENDRV
*  40   CONTINUE                                                        GENDRV
*       MANG = 1                                                        GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Unknown keyword -- halt program:                                     GENDRV
C                                                                       GENDRV
*     WRITE(LFNPR,900) KEYWD                                            GENDRV
*     STOP                                                              GENDRV
C                                                                       GENDRV
C  Make sure that both the orbital centers and symmetries are read:     GENDRV
C                                                                       GENDRV
* 100 CONTINUE                                                          GENDRV
*     IF(MCTR.EQ.0) STOP 'Missing orbital centers in $BASIS datalist'   GENDRV
*     IF(MANG.EQ.0) STOP 'Missing orbital labels in $BASIS datalist'    GENDRV
*     RETURN                                                            GENDRV
C                                                                       GENDRV
* 900 FORMAT(1X,'Unrecognized keyword >',6A1,'<')                       GENDRV
*     END                                                               GENDRV
C***********************************************************************GENDRV
*     SUBROUTINE CONINP(CORE,ICORE)                                     GENDRV
C***********************************************************************GENDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GENDRV
*     LOGICAL ERROR,END,EQUAL                                           GENDRV
C                                                                       GENDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
*    +           LFNDAF,LFNDEF                                          GENDRV
C                                                                       GENDRV
*     DIMENSION CORE(1),ICORE(1)                                        GENDRV
*     DIMENSION KEYWD(6),KCONTR(6),KNSHLL(6),KNEXP(4),KNCOMP(5),        GENDRV
*    + KNPRIM(5),KNPTR(4),KEXP(3),KCS(2),KCP(2),KCD(2),KCF(2),KEND(4)   GENDRV
C                                                                       GENDRV
*     DATA KCONTR/1H$,1HC,1HO,1HN,1HT,1HR/,KNEXP/1HN,1HE,1HX,1HP/,      GENDRV
*    +     KNSHLL/1HN,1HS,1HH,1HE,1HL,1HL/,KNCOMP/1HN,1HC,1HO,1HM,1HP/, GENDRV
*    +     KNPRIM/1HN,1HP,1HR,1HI,1HM/,KEXP/1HE,1HX,1HP/,KCS/1HC,1HS/,  GENDRV
*    +     KCP/1HC,1HP/,KCD/1HC,1HD/,KCF/1HC,1HF/,KEND/1H$,1HE,1HN,1HD/,GENDRV
*    +     KNPTR/1HN,1HP,1HT,1HR/                                       GENDRV
*     DATA ZERO/0.0D0/                                                  GENDRV
C                                                                       GENDRV
C  Search LFNIN for the $CONTRACT datalist:                             GENDRV
C                                                                       GENDRV
*     REWIND(LFNIN)                                                     GENDRV
*  10 CALL STRTIN(LFNIN)                                                GENDRV
*     LEN = 6                                                           GENDRV
*     CALL HFLD(KEYWD,LEN,END)                                          GENDRV
*     IF(LEN.EQ.0.AND.END) RETURN                                       GENDRV
*     IF(.NOT.EQUAL(KEYWD,KCONTR,6)) GOTO 10                            GENDRV
C                                                                       GENDRV
*     MSHELL = 0                                                        GENDRV
*     MEXP   = 0                                                        GENDRV
*     MCOMP  = 0                                                        GENDRV
*     MPRIM  = 0                                                        GENDRV
*     MPTR   = 0                                                        GENDRV
*     MEXP   = 0                                                        GENDRV
*  20 LEN = 6                                                           GENDRV
*     CALL HFLD(KEYWD,LEN,END)                                          GENDRV
*     IF(END) STOP 'End encountered while reading $CONTRACT datalist'   GENDRV
C                                                                       GENDRV
C  Keyword NSHELL -- number of shells of basis functions:               GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KNSHLL,6)) THEN                                    GENDRV
*       CALL IFLD(NSHELL,ERROR)                                         GENDRV
*       IF(ERROR) STOP 'Error reading number of shells in $CONTRACT'    GENDRV
*       MSHELL = 1                                                      GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Keyword NEXP -- number of orbital exponents in basis:                GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KNEXP,4)) THEN                                     GENDRV
*       CALL IFLD(NEXP,ERROR)                                           GENDRV
*       IF(ERROR) STOP 'Error reading number of exponents in $CONTRACT' GENDRV
*       MEXP = 1                                                        GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  If NSHELL and NEXP are not specified before the remainder of the     GENDRV
C  datalist, abort:                                                     GENDRV
C                                                                       GENDRV
*     IF(MSHELL.EQ.0.OR.MEXP.EQ.0) THEN                                 GENDRV
*       WRITE(LFNPR,900)                                                GENDRV
*       STOP                                                            GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  If NSHELL and NEXP have been specified, partition the scratch vector:GENDRV
C                                                                       GENDRV
C  ICORE(I1) : NCOMP(1..NSHELL)                                         GENDRV
C  ICORE(I2) : NPRIM(1..NSHELL)                                         GENDRV
C  ICORE(I3) : NPTR(1..NSHELL)                                          GENDRV
C  CORE(I4)  : EXP(1..NEXP)                                             GENDRV
C  CORE(I5)  : CS(1..NEXP)                                              GENDRV
C  CORE(I6)  : CP(1..NEXP)                                              GENDRV
C  CORE(I7)  : CD(1..NEXP)                                              GENDRV
C  CORE(I8)  : CF(1..NEXP)                                              GENDRV
C                                                                       GENDRV
*     IF(MSHELL.EQ.1.AND.MEXP.EQ.1) THEN                                GENDRV
*       I1   = 3                                                        GENDRV
*       I2   = I1 + NSHELL                                              GENDRV
*       I3   = I2 + NSHELL                                              GENDRV
*       I4   = I3 + NSHELL                                              GENDRV
*       I5   = I4 + NEXP                                                GENDRV
*       I6   = I5 + NEXP                                                GENDRV
*       I7   = I6 + NEXP                                                GENDRV
*       I8   = I7 + NEXP                                                GENDRV
*       IEND = I8 + NEXP                                                GENDRV
*       DO 30 I = 1,IEND-1                                              GENDRV
*         CORE(I) = ZERO                                                GENDRV
*  30   CONTINUE                                                        GENDRV
*       II = 0                                                          GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II) = NSHELL                                              GENDRV
*       II = II + 1                                                     GENDRV
*       ICORE(II) = NEXP                                                GENDRV
*       MSHELL = 2                                                      GENDRV
*       MEXP   = 2                                                      GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Keyword NCOMP -- number of components in each shell:                 GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KNCOMP,5)) THEN                                    GENDRV
*       DO 40 I = I1,I1+NSHELL-1                                        GENDRV
*         CALL IFLD(ICORE(I),ERROR)                                     GENDRV
*         IF(ERROR) STOP 'Error reading components in $CONTRACT'        GENDRV
*  40   CONTINUE                                                        GENDRV
*       MCOMP = 1                                                       GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Keyword NPRIM -- number of primitives in each shell:                 GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KNPRIM,5)) THEN                                    GENDRV
*       DO 50 I = I2,I2+NSHELL-1                                        GENDRV
*         CALL IFLD(ICORE(I),ERROR)                                     GENDRV
*         IF(ERROR) STOP 'Error reading primitives in $CONTRACT'        GENDRV
*  50   CONTINUE                                                        GENDRV
*       MPRIM = 1                                                       GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Keyword NPTR -- pointer array into exponents and coefficients:       GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KNPTR,4)) THEN                                     GENDRV
*       DO 60 I = I3,I3+NSHELL-1                                        GENDRV
*         CALL IFLD(ICORE(I),ERROR)                                     GENDRV
*         IF(ERROR) STOP 'Error reading pointers in $CONTRACT'          GENDRV
*  60   CONTINUE                                                        GENDRV
*       MPTR = 1                                                        GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Keyword EXP -- orbital exponents:                                    GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KEXP,3)) THEN                                      GENDRV
*       DO 70 I = I4,I4+NEXP-1                                          GENDRV
*         CALL RFLD(CORE(I),ERROR)                                      GENDRV
*         IF(ERROR) STOP 'Error reading exponents in $CONTRACT'         GENDRV
*  70   CONTINUE                                                        GENDRV
*       MEXP = 1                                                        GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Keyword CS -- s orbital coefficients:                                GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KCS,2)) THEN                                       GENDRV
*       DO 80 I = I5,I5+NEXP-1                                          GENDRV
*         CALL RFLD(CORE(I),ERROR)                                      GENDRV
*         IF(ERROR) STOP 'Error reading s coefficients in $CONTRACT'    GENDRV
*  80   CONTINUE                                                        GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Keyword CP -- p orbital coefficients:                                GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KCP,2)) THEN                                       GENDRV
*       DO 90 I = I6,I6+NEXP-1                                          GENDRV
*         CALL RFLD(CORE(I),ERROR)                                      GENDRV
*         IF(ERROR) STOP 'Error reading p coefficients in $CONTRACT'    GENDRV
*  90   CONTINUE                                                        GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Keyword CD -- d orbital coefficients:                                GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KCD,2)) THEN                                       GENDRV
*       DO 100 I = I7,I7+NEXP-1                                         GENDRV
*         CALL RFLD(CORE(I),ERROR)                                      GENDRV
*         IF(ERROR) STOP 'Error reading d coefficients in $CONTRACT'    GENDRV
* 100   CONTINUE                                                        GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Keyword CF -- f orbital coefficients:                                GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KCF,2)) THEN                                       GENDRV
*       DO 110 I = I8,I8+NEXP-1                                         GENDRV
*         CALL RFLD(CORE(I),ERROR)                                      GENDRV
*         IF(ERROR) STOP 'Error reading f coefficients in $CONTRACT'    GENDRV
* 110   CONTINUE                                                        GENDRV
*       GOTO 20                                                         GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  $END -- $CONTRACT datalist complete:                                 GENDRV
C                                                                       GENDRV
*     IF(EQUAL(KEYWD,KEND,4)) THEN                                      GENDRV
*       IF(MCOMP.EQ.0) STOP 'Missing NCOMP array in $CONTRACT'          GENDRV
*       IF(MPRIM.EQ.0) STOP 'Missing NPRIM array in $CONTRACT'          GENDRV
*       IF(MPTR.EQ.0)  STOP 'Missing NPTR array in $CONTRACT'           GENDRV
*       IF(MEXP.EQ.0)  STOP 'Missing EXP array in $CONTRACT'            GENDRV
C                                                                       GENDRV
C  Write info obtained in the datalist on the NBO DAF:                  GENDRV
C                                                                       GENDRV
*       LEN = IEND - 1                                                  GENDRV
*       NFILE = 5                                                       GENDRV
*       CALL NBWRIT(CORE,LEN,NFILE)                                     GENDRV
*       RETURN                                                          GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Unknown keyword -- halt program:                                     GENDRV
C                                                                       GENDRV
*     WRITE(LFNPR,910) KEYWD                                            GENDRV
*     STOP                                                              GENDRV
C                                                                       GENDRV
* 900 FORMAT(/1X,'NSHELL and NEXP should appear at the beginning of ',  GENDRV
*    + 'the $CONTRACT datalist')                                        GENDRV
* 910 FORMAT(1X,'Unrecognized keyword >',6A1,'<')                       GENDRV
*     END                                                               GENDRV
C***********************************************************************GENDRV
*     SUBROUTINE SINP(CORE,UPPER)                                       GENDRV
C***********************************************************************GENDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GENDRV
*     DIMENSION CORE(1)                                                 GENDRV
*     DIMENSION KEYWD(6),KOVER(5)                                       GENDRV
*     LOGICAL UPPER,ERROR,END,EQUAL                                     GENDRV
C                                                                       GENDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       GENDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
*    +           LFNDAF,LFNDEF                                          GENDRV
C                                                                       GENDRV
*     DATA KOVER/1H$,1HO,1HV,1HE,1HR/                                   GENDRV
C                                                                       GENDRV
C  Search LFNIN for $OVERLAP datalist:                                  GENDRV
C                                                                       GENDRV
*     REWIND(LFNIN)                                                     GENDRV
*  10 CALL STRTIN(LFNIN)                                                GENDRV
*     LEN = 6                                                           GENDRV
*     CALL HFLD(KEYWD,LEN,END)                                          GENDRV
*     IF(LEN.EQ.0.AND.END) STOP 'No $OVERLAP found in the input file'   GENDRV
*     IF(.NOT.EQUAL(KEYWD,KOVER,5)) GOTO 10                             GENDRV
C                                                                       GENDRV
C  Number of elements to read in:                                       GENDRV
C                                                                       GENDRV
*     NEL = NDIM*NDIM                                                   GENDRV
*     IF(UPPER) NEL = NDIM*(NDIM+1)/2                                   GENDRV
C                                                                       GENDRV
C  Read in the AO overlap matrix:                                       GENDRV
C                                                                       GENDRV
*     DO 20 I = 1,NEL                                                   GENDRV
*       CALL RFLD(CORE(I),ERROR)                                        GENDRV
*       IF(ERROR) STOP 'Error reading AO overlap matrix'                GENDRV
*  20 CONTINUE                                                          GENDRV
*     NEL = NDIM*(NDIM+1)/2                                             GENDRV
*     IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL)                      GENDRV
C                                                                       GENDRV
C  Store the overlap matrix on the NBO DAF:                             GENDRV
C                                                                       GENDRV
*     NFILE = 10                                                        GENDRV
*     CALL NBWRIT(CORE,NEL,NFILE)                                       GENDRV
*     RETURN                                                            GENDRV
*     END                                                               GENDRV
C***********************************************************************GENDRV
*     SUBROUTINE DMINP(CORE,UPPER)                                      GENDRV
C***********************************************************************GENDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GENDRV
*     DIMENSION CORE(1)                                                 GENDRV
*     DIMENSION KEYWD(6),KDENS(5)                                       GENDRV
*     LOGICAL UPPER,ERROR,END,EQUAL                                     GENDRV
C                                                                       GENDRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       GENDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       GENDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
*    +           LFNDAF,LFNDEF                                          GENDRV
C                                                                       GENDRV
*     DATA KDENS/1H$,1HD,1HE,1HN,1HS/                                   GENDRV
C                                                                       GENDRV
C  Search LFNIN for $DENSITY datalist:                                  GENDRV
C                                                                       GENDRV
*     REWIND(LFNIN)                                                     GENDRV
*  10 CALL STRTIN(LFNIN)                                                GENDRV
*     LEN = 6                                                           GENDRV
*     CALL HFLD(KEYWD,LEN,END)                                          GENDRV
*     IF(LEN.EQ.0.AND.END) STOP 'No $DENSITY found in the input file'   GENDRV
*     IF(.NOT.EQUAL(KEYWD,KDENS,5)) GOTO 10                             GENDRV
C                                                                       GENDRV
C  Number of elements to read in:                                       GENDRV
C                                                                       GENDRV
*     NEL = NDIM*NDIM                                                   GENDRV
*     IF(UPPER) NEL = NDIM*(NDIM+1)/2                                   GENDRV
C                                                                       GENDRV
C  Read in the AO density matrix:                                       GENDRV
C                                                                       GENDRV
*     DO 20 I = 1,NEL                                                   GENDRV
*       CALL RFLD(CORE(I),ERROR)                                        GENDRV
*       IF(ERROR) STOP 'Error reading AO density matrix'                GENDRV
*  20 CONTINUE                                                          GENDRV
*     NEL = NDIM*(NDIM+1)/2                                             GENDRV
*     IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL)                      GENDRV
C                                                                       GENDRV
C  Store the density matrix on the NBO DAF:                             GENDRV
C                                                                       GENDRV
*     NFILE = 20                                                        GENDRV
*     CALL NBWRIT(CORE,NEL,NFILE)                                       GENDRV
C                                                                       GENDRV
C  Read in and store the beta density matrix if this is open shell:     GENDRV
C                                                                       GENDRV
*     IF(OPEN) THEN                                                     GENDRV
*       NEL = NDIM*NDIM                                                 GENDRV
*       IF(UPPER) NEL = NDIM*(NDIM+1)/2                                 GENDRV
*       DO 30 I = 1,NEL                                                 GENDRV
*         CALL RFLD(CORE(I),ERROR)                                      GENDRV
*         IF(ERROR) STOP 'Error reading beta AO density matrix'         GENDRV
*  30   CONTINUE                                                        GENDRV
*       NEL = NDIM*(NDIM+1)/2                                           GENDRV
*       IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL)                    GENDRV
*       NFILE = 21                                                      GENDRV
*       CALL NBWRIT(CORE,NEL,NFILE)                                     GENDRV
*     END IF                                                            GENDRV
*     RETURN                                                            GENDRV
*     END                                                               GENDRV
C***********************************************************************GENDRV
*     SUBROUTINE FINP(CORE,UPPER,END)                                   GENDRV
C***********************************************************************GENDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GENDRV
*     DIMENSION CORE(1)                                                 GENDRV
*     DIMENSION KEYWD(6),KFOCK(5)                                       GENDRV
*     LOGICAL UPPER,ERROR,END,EQUAL                                     GENDRV
C                                                                       GENDRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       GENDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       GENDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
*    +           LFNDAF,LFNDEF                                          GENDRV
C                                                                       GENDRV
*     DATA KFOCK/1H$,1HF,1HO,1HC,1HK/                                   GENDRV
C                                                                       GENDRV
C  Search LFNIN for $FOCK datalist:                                     GENDRV
C                                                                       GENDRV
*     REWIND(LFNIN)                                                     GENDRV
*  10 CALL STRTIN(LFNIN)                                                GENDRV
*     LEN = 6                                                           GENDRV
*     CALL HFLD(KEYWD,LEN,END)                                          GENDRV
*     IF(LEN.EQ.0.AND.END) RETURN                                       GENDRV
*     IF(.NOT.EQUAL(KEYWD,KFOCK,5)) GOTO 10                             GENDRV
C                                                                       GENDRV
C  Number of elements to read in:                                       GENDRV
C                                                                       GENDRV
*     NEL = NDIM*NDIM                                                   GENDRV
*     IF(UPPER) NEL = NDIM*(NDIM+1)/2                                   GENDRV
C                                                                       GENDRV
C  Read in the AO Fock matrix:                                          GENDRV
C                                                                       GENDRV
*     DO 20 I = 1,NEL                                                   GENDRV
*       CALL RFLD(CORE(I),ERROR)                                        GENDRV
*       IF(ERROR) STOP 'Error reading AO Fock matrix'                   GENDRV
*  20 CONTINUE                                                          GENDRV
*     NEL = NDIM*(NDIM+1)/2                                             GENDRV
*     IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL)                      GENDRV
C                                                                       GENDRV
C  Store the Fock matrix on the NBO DAF:                                GENDRV
C                                                                       GENDRV
*     NFILE = 30                                                        GENDRV
*     CALL NBWRIT(CORE,NEL,NFILE)                                       GENDRV
C                                                                       GENDRV
C  Read in and store the beta Fock matrix if this is open shell:        GENDRV
C                                                                       GENDRV
*     IF(OPEN) THEN                                                     GENDRV
*       NEL = NDIM*NDIM                                                 GENDRV
*       IF(UPPER) NEL = NDIM*(NDIM+1)/2                                 GENDRV
*       DO 30 I = 1,NEL                                                 GENDRV
*         CALL RFLD(CORE(I),ERROR)                                      GENDRV
*         IF(ERROR) STOP 'Error reading beta AO Fock matrix'            GENDRV
*  30   CONTINUE                                                        GENDRV
*       NEL = NDIM*(NDIM+1)/2                                           GENDRV
*       IF(.NOT.UPPER) CALL PACK(CORE,NBAS,NBAS,NEL)                    GENDRV
*       NFILE = 31                                                      GENDRV
*       CALL NBWRIT(CORE,NEL,NFILE)                                     GENDRV
*     END IF                                                            GENDRV
*     END = .FALSE.                                                     GENDRV
*     RETURN                                                            GENDRV
*     END                                                               GENDRV
C***********************************************************************GENDRV
*     SUBROUTINE TINP(CORE)                                             GENDRV
C***********************************************************************GENDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GENDRV
*     DIMENSION CORE(1)                                                 GENDRV
*     DIMENSION KEYWD(6),KAOMO(7)                                       GENDRV
*     LOGICAL ERROR,END,EQUAL                                           GENDRV
C                                                                       GENDRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GENDRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       GENDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       GENDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
*    +           LFNDAF,LFNDEF                                          GENDRV
C                                                                       GENDRV
*     DATA KAOMO/1H$,1HL,1HC,1HA,1HO,1HM,1HO/                           GENDRV
C                                                                       GENDRV
C  Search LFNIN for $LCAOMO datalist:                                   GENDRV
C                                                                       GENDRV
*     REWIND(LFNIN)                                                     GENDRV
*  10 CALL STRTIN(LFNIN)                                                GENDRV
*     LEN = 6                                                           GENDRV
*     CALL HFLD(KEYWD,LEN,END)                                          GENDRV
*     IF(LEN.EQ.0.AND.END) RETURN                                       GENDRV
*     IF(.NOT.EQUAL(KEYWD,KAOMO,6)) GOTO 10                             GENDRV
C                                                                       GENDRV
C  Read in the AO to MO transformation matrix:                          GENDRV
C                                                                       GENDRV
*     NEL = NDIM*NDIM                                                   GENDRV
*     DO 20 I = 1,NEL                                                   GENDRV
*       CALL RFLD(CORE(I),ERROR)                                        GENDRV
*       IF(ERROR) STOP 'Error reading AO to MO transformation matrix'   GENDRV
*  20 CONTINUE                                                          GENDRV
C                                                                       GENDRV
C  Store the transformation matrix on the NBO DAF:                      GENDRV
C                                                                       GENDRV
*     NFILE = 40                                                        GENDRV
*     CALL NBWRIT(CORE,NEL,NFILE)                                       GENDRV
C                                                                       GENDRV
C  Read in and store the beta transformation matrix if this is an open  GENDRV
C  shell wavevfunction:                                                 GENDRV
C                                                                       GENDRV
*     IF(OPEN) THEN                                                     GENDRV
*       DO 30 I = 1,NEL                                                 GENDRV
*         CALL RFLD(CORE(I),ERROR)                                      GENDRV
*         IF(ERROR) STOP 'Error reading beta AO to MO trans. matrix'    GENDRV
*  30   CONTINUE                                                        GENDRV
*       NFILE = 41                                                      GENDRV
*       CALL NBWRIT(CORE,NEL,NFILE)                                     GENDRV
*     END IF                                                            GENDRV
*     RETURN                                                            GENDRV
*     END                                                               GENDRV
C***********************************************************************GENDRV
*     SUBROUTINE DIPINP(CORE,UPPER,BOHR)                                GENDRV
C***********************************************************************GENDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GENDRV
*     DIMENSION CORE(1)                                                 GENDRV
*     DIMENSION KEYWD(6),KDIPOL(6)                                      GENDRV
*     LOGICAL UPPER,ERROR,END,EQUAL,BOHR                                GENDRV
C                                                                       GENDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       GENDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GENDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GENDRV
*    +           LFNDAF,LFNDEF                                          GENDRV
C                                                                       GENDRV
*     DATA KDIPOL/1H$,1HD,1HI,1HP,1HO,1HL/                              GENDRV
*     DATA TOANG/0.529177249/                                           GENDRV
C                                                                       GENDRV
C  Search LFNIN for $DIPOLE datalist:                                   GENDRV
C                                                                       GENDRV
*     REWIND(LFNIN)                                                     GENDRV
*  10 CALL STRTIN(LFNIN)                                                GENDRV
*     LEN = 6                                                           GENDRV
*     CALL HFLD(KEYWD,LEN,END)                                          GENDRV
*     IF(LEN.EQ.0.AND.END) RETURN                                       GENDRV
*     IF(.NOT.EQUAL(KEYWD,KDIPOL,6)) GOTO 10                            GENDRV
C                                                                       GENDRV
C  Number of elements to read in:                                       GENDRV
C                                                                       GENDRV
*     NEL = NDIM*NDIM                                                   GENDRV
*     IF(UPPER) NEL = NDIM*(NDIM+1)/2                                   GENDRV
C                                                                       GENDRV
C  Read in the x dipole integral matrix:                                GENDRV
C                                                                       GENDRV
*     DO 20 I = 1,NEL                                                   GENDRV
*       CALL RFLD(CORE(I),ERROR)                                        GENDRV
*       IF(ERROR) STOP 'Error reading x dipole integral matrix'         GENDRV
*  20 CONTINUE                                                          GENDRV
*     IF(.NOT.UPPER) THEN                                               GENDRV
*       NEL = NDIM*(NDIM+1)/2                                           GENDRV
*       CALL PACK(CORE,NBAS,NBAS,NEL)                                   GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Convert to angstroms, if necessary:                                  GENDRV
C                                                                       GENDRV
*     IF(BOHR) THEN                                                     GENDRV
*       DO 30 I = 1,NEL                                                 GENDRV
*         CORE(I) = CORE(I) * TOANG                                     GENDRV
*  30   CONTINUE                                                        GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Store the dipole integral matrix on the NBO DAF:                     GENDRV
C                                                                       GENDRV
*     NFILE = 50                                                        GENDRV
*     CALL NBWRIT(CORE,NEL,NFILE)                                       GENDRV
C                                                                       GENDRV
C  Read in the y dipole integral matrix:                                GENDRV
C                                                                       GENDRV
*     DO 40 I = 1,NEL                                                   GENDRV
*       CALL RFLD(CORE(I),ERROR)                                        GENDRV
*       IF(ERROR) STOP 'Error reading y dipole integral matrix'         GENDRV
*  40 CONTINUE                                                          GENDRV
*     IF(.NOT.UPPER) THEN                                               GENDRV
*       NEL = NDIM*(NDIM+1)/2                                           GENDRV
*       CALL PACK(CORE,NBAS,NBAS,NEL)                                   GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Convert to angstroms, if necessary:                                  GENDRV
C                                                                       GENDRV
*     IF(BOHR) THEN                                                     GENDRV
*       DO 50 I = 1,NEL                                                 GENDRV
*         CORE(I) = CORE(I) * TOANG                                     GENDRV
*  50   CONTINUE                                                        GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
*     NFILE = 51                                                        GENDRV
*     CALL NBWRIT(CORE,NEL,NFILE)                                       GENDRV
C                                                                       GENDRV
C  Read in the z dipole integral matrix:                                GENDRV
C                                                                       GENDRV
*     DO 60 I = 1,NEL                                                   GENDRV
*       CALL RFLD(CORE(I),ERROR)                                        GENDRV
*       IF(ERROR) STOP 'Error reading z dipole integral matrix'         GENDRV
*  60 CONTINUE                                                          GENDRV
*     IF(.NOT.UPPER) THEN                                               GENDRV
*       NEL = NDIM*(NDIM+1)/2                                           GENDRV
*       CALL PACK(CORE,NBAS,NBAS,NEL)                                   GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
C  Convert to angstroms, if necessary:                                  GENDRV
C                                                                       GENDRV
*     IF(BOHR) THEN                                                     GENDRV
*       DO 70 I = 1,NEL                                                 GENDRV
*         CORE(I) = CORE(I) * TOANG                                     GENDRV
*  70   CONTINUE                                                        GENDRV
*     END IF                                                            GENDRV
C                                                                       GENDRV
*     NFILE = 52                                                        GENDRV
*     CALL NBWRIT(CORE,NEL,NFILE)                                       GENDRV
C                                                                       GENDRV
*     RETURN                                                            GENDRV
*     END                                                               GENDRV
C***********************************************************************GENDRV
C                                                                       GENDRV
C           E N D    O F    G E N N B O    R O U T I N E S              GENDRV
C                                                                       GENDRV
C***********************************************************************GENDRV
C***********************************************************************G90DRV
C                                                                       G90DRV
C                                                                       G90DRV
C                          G  9  0  N  B  O                             G90DRV
C                                                                       G90DRV
C                                                                       G90DRV
C                 GAUSSIAN 90 VERSION OF NBO PROGRAM                    G90DRV
C                                                                       G90DRV
C                                                                       G90DRV
C  DRIVER ROUTINES:                                                     G90DRV
C                                                                       G90DRV
C      SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR)                        G90DRV
C      SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                             G90DRV
C      SUBROUTINE DELSCF(CORE,ICORE,NBOOPT)                             G90DRV
C                                                                       G90DRV
C***********************************************************************G90DRV
*     SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR)                         G90DRV
C***********************************************************************G90DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G90DRV
C                                                                       G90DRV
*     PARAMETER (MAXFIL = 40)                                           G90DRV
C                                                                       G90DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G90DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G90DRV
*    +           LFNDAF,LFNDEF                                          G90DRV
*     COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)                          G90DRV
*     CHARACTER*80 FILENM                                               G90DRV
C                                                                       G90DRV
*     DIMENSION CORE(MEMORY),IOP(50)                                    G90DRV
*     DIMENSION NBOOPT(10)                                              G90DRV
C                                                                       G90DRV
*     DATA TENTH/0.1D0/                                                 G90DRV
C                                                                       G90DRV
*     LFNIN = 5                                                         G90DRV
*     LFNPR = 6                                                         G90DRV
C                                                                       G90DRV
C  Set NBO options.                                                     G90DRV
C                                                                       G90DRV
*     DO 10 I = 1,9                                                     G90DRV
*       NBOOPT(I) = IOP(I+39)                                           G90DRV
*  10 CONTINUE                                                          G90DRV
*     NBOOPT(10) = 90                                                   G90DRV
C                                                                       G90DRV
C  --- G90 patch ---                                                    G90DRV
C                                                                       G90DRV
*     IF(NBOOPT(1).EQ.0) THEN                                           G90DRV
*       NBOOPT(1) = 1                                                   G90DRV
*     ELSE IF(NBOOPT(1).EQ.1) THEN                                      G90DRV
*       NBOOPT(1) = 0                                                   G90DRV
*     END IF                                                            G90DRV
C                                                                       G90DRV
C  --- NBO analysis ---                                                 G90DRV
C                                                                       G90DRV
*     ICONTR = 0                                                        G90DRV
*     IF(ABS(NBOOPT(1)).LT.2) THEN                                      G90DRV
*       CALL CHARPN(4HNBO )                                             G90DRV
*       CALL NBO(CORE,MEMORY,NBOOPT)                                    G90DRV
C                                                                       G90DRV
C  Store the name of the NBO direct access file on the RWFiles          G90DRV
C                                                                       G90DRV
*       DO 20 I = 1,80                                                  G90DRV
*         CORE(I) = ICHAR(FILENM(I:I))                                  G90DRV
*  20   CONTINUE                                                        G90DRV
*       CORE(81) = LFNDAF                                               G90DRV
*       CALL TWRITE(636,CORE,81,1,81,1,0)                               G90DRV
C                                                                       G90DRV
C  --- NBO energetic analysis ---                                       G90DRV
C                                                                       G90DRV
*     ELSE IF(NBOOPT(1).EQ.2) THEN                                      G90DRV
C                                                                       G90DRV
C  Retrieve the name of the NBO direct access file from the RWFiles     G90DRV
C                                                                       G90DRV
*       CALL TREAD(636,CORE,81,1,81,1,0)                                G90DRV
*       DO 30 I = 1,80                                                  G90DRV
*         FILENM(I:I) = CHAR(INT(CORE(I) + TENTH))                      G90DRV
*  30   CONTINUE                                                        G90DRV
*       LFNDAF = INT(ABS(CORE(81)) + TENTH)                             G90DRV
*       CALL CHARPN(4HDELE)                                             G90DRV
*       CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE)                           G90DRV
*       IF(IDONE.NE.0) ICONTR = 1                                       G90DRV
*       IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT)                    G90DRV
C                                                                       G90DRV
*     ELSE IF(NBOOPT(1).EQ.3) THEN                                      G90DRV
*       CALL TREAD(636,CORE,81,1,81,1,0)                                G90DRV
*       DO 40 I = 1,80                                                  G90DRV
*         FILENM(I:I) = CHAR(INT(CORE(I) + TENTH))                      G90DRV
*  40   CONTINUE                                                        G90DRV
*       LFNDAF = INT(ABS(CORE(81)) + TENTH)                             G90DRV
*       CALL CHARPN(4HEDEL)                                             G90DRV
*       CALL DELSCF(CORE,CORE,NBOOPT)                                   G90DRV
*       CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE)                           G90DRV
*     END IF                                                            G90DRV
C                                                                       G90DRV
*     RETURN                                                            G90DRV
*     END                                                               G90DRV
C***********************************************************************G90DRV
*     SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                              G90DRV
C***********************************************************************G90DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G90DRV
*     LOGICAL GOTDEN                                                    G90DRV
C-----------------------------------------------------------------------G90DRV
C                                                                       G90DRV
C  Routine FEAOIN accesses the following records of the RWFs:           G90DRV
C                                                                       G90DRV
C        501  ---   Total energy                                        G90DRV
C        502  ---   Job title                                           G90DRV
C        506  ---   Basis set information                               G90DRV
C        512  ---   Effective core potential information                G90DRV
C        514  ---   AO overlap matrix                                   G90DRV
C        518  ---   AO dipole integrals                                 G90DRV
C        524  ---   MO coefficients (alpha)                             G90DRV
C        526  ---   MO coefficients (beta)                              G90DRV
C        536  ---   AO Fock matrix (alpha)                              G90DRV
C        538  ---   AO Fock matrix (beta)                               G90DRV
C        603  ---   AO density matrix                                   G90DRV
C                                                                       G90DRV
C ----------------------------------------------------------------------G90DRV
C                                                                       G90DRV
C  NBO Common blocks                                                    G90DRV
C                                                                       G90DRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               G90DRV
C                                                                       G90DRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G90DRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       G90DRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       G90DRV
*     COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,        G90DRV
*    + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    G90DRV
*    + JCORE,JPRINT(60)                                                 G90DRV
*     COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)                             G90DRV
*     COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G90DRV
*    +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)                     G90DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G90DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G90DRV
*    +           LFNDAF,LFNDEF                                          G90DRV
C                                                                       G90DRV
C  GAUSSIAN 90 Common blocks                                            G90DRV
C                                                                       G90DRV
*     COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(401),        G90DRV
*    *           ATMCHG(400),C(1200)                                    G90DRV
*     COMMON/LP2/NLP(1600),CLP(1600),ZLP(1600),KFIRST(400,5),           G90DRV
*    *  KLAST(400,5),LMAX(400),LPSKIP(400),NFroz(400)                   G90DRV
*     COMMON/B/EXX(6000),C1(6000),C2(6000),C3(6000),X(2000),Y(2000),    G90DRV
*    *     Z(2000),JAN(2000),SHELLA(2000),SHELLN(2000),SHELLT(2000),    G90DRV
*    *     SHELLC(2000),AOS(2000),AON(2000),NSHELL,MAXTYP               G90DRV
*     INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON                G90DRV
*     DIMENSION C4(2000),SHLADF(2000)                                   G90DRV
*     EQUIVALENCE(C4(1),C3(2001)),(SHLADF(1),C3(4001))                  G90DRV
C                                                                       G90DRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             G90DRV
*     DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2)                         G90DRV
C                                                                       G90DRV
C  Obtain the following information:                                    G90DRV
C                                                                       G90DRV
C    ROHF        =.TRUE. If RHF open shell wavefunction                 G90DRV
C                =.FALSE. otherwise                                     G90DRV
C                                                                       G90DRV
C    UHF         =.TRUE. If UHF wavefunction                            G90DRV
C                =.FALSE. otherwise                                     G90DRV
C                                                                       G90DRV
C    AUHF        =.TRUE. If spin-annihilated UHF wavefunction           G90DRV
C                =.FALSE. otherwise                                     G90DRV
C                                                                       G90DRV
C    CI          =.TRUE. If CI wavefunction                             G90DRV
C                =.FALSE. otherwise                                     G90DRV
C                                                                       G90DRV
C    OPEN        =.TRUE. If open shell wavefunction                     G90DRV
C                =.FALSE. otherwise                                     G90DRV
C                                                                       G90DRV
C    COMPLX      =.TRUE. If complex wavefunction                        G90DRV
C                =.FALSE. otherwise                                     G90DRV
C                (Note: The program is not capable of handling this.)   G90DRV
C                                                                       G90DRV
C    NATOMS      Number of atomic centers                               G90DRV
C                                                                       G90DRV
C    NDIM        Dimension of matrices (overlap and density)            G90DRV
C                                                                       G90DRV
C    NBAS        Number of basis functions (.le.NDIM)                   G90DRV
C                                                                       G90DRV
C    IPSEUD      Set to one if pseudopotentials are used.               G90DRV
C                                                                       G90DRV
C    IWCUBF      This pertains only basis sets with F functions.        G90DRV
C                                                                       G90DRV
C                If cartesian F functions are input, set IWCUBF to:     G90DRV
C                    0,  if these are to be transformed to the          G90DRV
C                        standard set of pure F functions               G90DRV
C                    1,  if these are to be transformed to the          G90DRV
C                        cubic set of pure F functions                  G90DRV
C                                                                       G90DRV
C                If pure F functions are input, set to IWCUBF to:       G90DRV
C                    0,  if these are standard F functions              G90DRV
C                    1,  if these are cubic F functions                 G90DRV
C                                                                       G90DRV
C    IATNO(I),I=1,NATOMS                                                G90DRV
C                List of atomic numbers                                 G90DRV
C                                                                       G90DRV
C    LCTR(I),I=1,NBAS                                                   G90DRV
C                List of atomic centers of the basis functions          G90DRV
C                (LCTR(3)=2 if basis function 3 is on atom 2)           G90DRV
C                                                                       G90DRV
C    LANG(I),I=1,NBAS                                                   G90DRV
C                List of angular symmetry information for the AO basis  G90DRV
C                                                                       G90DRV
*     DATA LISTS/   1/                                                  G90DRV
*     DATA LISTP/ 101, 102, 103/                                        G90DRV
*     DATA LISTD/ 255, 252, 253, 254, 251,   0,                         G90DRV
*    +            201, 204, 206, 202, 203, 205/                         G90DRV
*     DATA LISTF/ 351, 352, 353, 354, 355, 356, 357,   0,   0,   0,     G90DRV
*    +            301, 307, 310, 304, 302, 303, 306, 309, 308, 305/     G90DRV
*     DATA ZERO/0.0D0/                                                  G90DRV
*     DATA TOANG/0.529177249/                                           G90DRV
C                                                                       G90DRV
C  Store job title on NBODAF:                                           G90DRV
C                                                                       G90DRV
*     LEN = INTOWP(4000+100)                                            G90DRV
*     CALL TREAD(502,ICORE,LEN,1,LEN,1,0)                               G90DRV
*     NFILE = 2                                                         G90DRV
*     CALL NBWRIT(ICORE(4001),10,NFILE)                                 G90DRV
C                                                                       G90DRV
C  Get the number of atoms from NAT and store the atomic numbers in     G90DRV
C  IATNO and nuclear charges in IZNUC.  (NOTE: atomic numbers and       G90DRV
C  nuclear charges may not be equivalent if effective core potentials   G90DRV
C  (ECP) are used.)                                                     G90DRV
C                                                                       G90DRV
*     LEN = 0                                                           G90DRV
*     IEXIST = ITQRY(512)                                               G90DRV
*     IF(IEXIST.GT.0) THEN                                              G90DRV
*       LEN = 8 * 400 + 17 * INTOWP(400)                                G90DRV
*       CALL TREAD(512,NLP,LEN,1,LEN,1,0)                               G90DRV
*     END IF                                                            G90DRV
*     NATOMS = NATOM                                                    G90DRV
*     DO 20 I = 1,NATOMS                                                G90DRV
*       IATNO(I) = IAN(I)                                               G90DRV
*       IF(IEXIST.GT.0) THEN                                            G90DRV
*         IZNUC(I) = IATNO(I) - NFROZ(I)                                G90DRV
*         IF(NFROZ(I).NE.0) IPSEUD = 1                                  G90DRV
*       ELSE                                                            G90DRV
*         IZNUC(I) = IATNO(I)                                           G90DRV
*       END IF                                                          G90DRV
*  20 CONTINUE                                                          G90DRV
C                                                                       G90DRV
C  Restore the basis set to COMMON/B/:                                  G90DRV
C                                                                       G90DRV
*     LEN = 30000 + INTOWP(14002)                                       G90DRV
*     CALL TREAD(506,EXX,LEN,1,LEN,1,0)                                 G90DRV
C                                                                       G90DRV
C  The Gaussian programs do not use cubic f basis functions.            G90DRV
C  Determine which set of d and f functions are being used,             G90DRV
C  Cartesian or pure):                                                  G90DRV
C                                                                       G90DRV
*     IWCUBF = 0                                                        G90DRV
*     CALL ILSW(2,2,I5D6D)                                              G90DRV
*     CALL ILSW(2,16,I7F10F)                                            G90DRV
C                                                                       G90DRV
C  Construct the AO information lists: LCTR and LANG                    G90DRV
C                                                                       G90DRV
*     IBAS = 0                                                          G90DRV
*     DO 90 ISHELL = 1,2000                                             G90DRV
*       IF(IBAS.EQ.NBASIS) GOTO 100                                     G90DRV
*       NCTR   = JAN(ISHELL)                                            G90DRV
*       MAXL   = SHELLT(ISHELL)                                         G90DRV
*       ICNSTR = SHELLC(ISHELL)                                         G90DRV
C                                                                       G90DRV
C  Is an s orbital in the shell?                                        G90DRV
C                                                                       G90DRV
*       KS = 0                                                          G90DRV
*       IF(MAXL.EQ.0) KS = 1                                            G90DRV
*       IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1                            G90DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1                            G90DRV
*       IF(KS.EQ.0) GOTO 30                                             G90DRV
C                                                                       G90DRV
C  s orbital:                                                           G90DRV
C                                                                       G90DRV
*         IBAS = IBAS + 1                                               G90DRV
*         LCTR(IBAS) = NCTR                                             G90DRV
*         LANG(IBAS) = LISTS                                            G90DRV
C                                                                       G90DRV
C  Is a set of p orbitals in the shell?                                 G90DRV
C                                                                       G90DRV
*  30   CONTINUE                                                        G90DRV
*       KP = 0                                                          G90DRV
*       IF(MAXL.EQ.0) GOTO 90                                           G90DRV
*       IF(MAXL.EQ.1) KP = 1                                            G90DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1                            G90DRV
*       IF(KP.EQ.0) GOTO 50                                             G90DRV
C                                                                       G90DRV
C  p orbitals:                                                          G90DRV
C                                                                       G90DRV
*       DO 40 I = 1,3                                                   G90DRV
*         IBAS = IBAS + 1                                               G90DRV
*         LCTR(IBAS) = NCTR                                             G90DRV
*         LANG(IBAS) = LISTP(I)                                         G90DRV
*  40   CONTINUE                                                        G90DRV
C                                                                       G90DRV
C  d orbitals:                                                          G90DRV
C                                                                       G90DRV
*  50   IF(MAXL.NE.2) GOTO 70                                           G90DRV
*         IMAX = I5D6D + 5                                              G90DRV
*         KD = I5D6D + 1                                                G90DRV
*         DO 60 I = 1,IMAX                                              G90DRV
*           IBAS = IBAS + 1                                             G90DRV
*           LCTR(IBAS) = NCTR                                           G90DRV
*           LANG(IBAS) = LISTD(I,KD)                                    G90DRV
*  60     CONTINUE                                                      G90DRV
*         GO TO 90                                                      G90DRV
C                                                                       G90DRV
C  f orbitals:                                                          G90DRV
C                                                                       G90DRV
*  70   IF(MAXL.NE.3) GOTO 90                                           G90DRV
*         IMAX = 7                                                      G90DRV
*         IF(I7F10F.EQ.1) IMAX = 10                                     G90DRV
*         KF = I7F10F + 1                                               G90DRV
*         DO 80 I = 1,IMAX                                              G90DRV
*           IBAS = IBAS + 1                                             G90DRV
*           LCTR(IBAS) = NCTR                                           G90DRV
*           LANG(IBAS) = LISTF(I,KF)                                    G90DRV
*  80     CONTINUE                                                      G90DRV
*  90 CONTINUE                                                          G90DRV
* 100 CONTINUE                                                          G90DRV
*     NDIM = NBASIS                                                     G90DRV
*     NBAS = NBASIS                                                     G90DRV
C                                                                       G90DRV
C  Determine the type of wave function the density matrix is from:      G90DRV
C                                                                       G90DRV
*     IF(MULTIP.GT.1) OPEN = .TRUE.                                     G90DRV
*     IF(NBOOPT(2).NE.0) THEN                                           G90DRV
*       CI = .TRUE.                                                     G90DRV
*     ELSE                                                              G90DRV
*       CALL ILSW(2,1,ISCF)                                             G90DRV
*       CALL ILSW(2,22,IROHF)                                           G90DRV
*       IF(ISCF.EQ.1)  UHF    = .TRUE.                                  G90DRV
*       IF(UHF)        OPEN   = .TRUE.                                  G90DRV
*       IF(IROHF.EQ.1) ROHF   = .TRUE.                                  G90DRV
*       IF(IROHF.EQ.2) ROHF   = .TRUE.                                  G90DRV
*       IF(IROHF.EQ.3) MCSCF  = .TRUE.                                  G90DRV
*       IF(ISCF.GT.1)  COMPLX = .TRUE.                                  G90DRV
*       IF(COMPLX) GOTO 900                                             G90DRV
*     END IF                                                            G90DRV
*     IF(NBOOPT(5).EQ.1) AUHF = .TRUE.                                  G90DRV
*     ORTHO = .FALSE.                                                   G90DRV
C                                                                       G90DRV
C  No Fock matrices for ROHF, MCSCF, or CI wavefunctions:               G90DRV
C                                                                       G90DRV
*     IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0                                G90DRV
C                                                                       G90DRV
C  Expectation values of the Fock operator are in atomic units:         G90DRV
C                                                                       G90DRV
*     MUNIT = 0                                                         G90DRV
C                                                                       G90DRV
C  Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:         G90DRV
C                                                                       G90DRV
*     ICORE(1)  = NATOMS                                                G90DRV
*     ICORE(2)  = NDIM                                                  G90DRV
*     ICORE(3)  = NBAS                                                  G90DRV
*     ICORE(4)  = MUNIT                                                 G90DRV
*     ICORE(5)  = 0                                                     G90DRV
*     IF(ROHF)  ICORE(5)  = 1                                           G90DRV
*     ICORE(6)  = 0                                                     G90DRV
*     IF(UHF)   ICORE(6)  = 1                                           G90DRV
*     ICORE(7)  = 0                                                     G90DRV
*     IF(CI)    ICORE(7)  = 1                                           G90DRV
*     ICORE(8)  = 0                                                     G90DRV
*     IF(OPEN)  ICORE(8)  = 1                                           G90DRV
*     ICORE(9)  = 0                                                     G90DRV
*     IF(MCSCF) ICORE(9)  = 1                                           G90DRV
*     ICORE(10) = 0                                                     G90DRV
*     IF(AUHF)  ICORE(10)  = 1                                          G90DRV
*     ICORE(11) = 0                                                     G90DRV
*     IF(ORTHO) ICORE(11) = 1                                           G90DRV
*     ICORE(12) = 1                                                     G90DRV
*     NFILE = 3                                                         G90DRV
*     CALL NBWRIT(ICORE,12,NFILE)                                       G90DRV
C                                                                       G90DRV
C  Store IATNO, IZNUC, LCTR, and LANG on NBO DAF:                       G90DRV
C                                                                       G90DRV
*     II = 0                                                            G90DRV
*     DO 120 I = 1,NATOMS                                               G90DRV
*       II = II + 1                                                     G90DRV
*       ICORE(II) = IATNO(I)                                            G90DRV
* 120 CONTINUE                                                          G90DRV
*     DO 130 I = 1,NATOMS                                               G90DRV
*       II = II + 1                                                     G90DRV
*       ICORE(II) = IZNUC(I)                                            G90DRV
* 130 CONTINUE                                                          G90DRV
*     DO 140 I = 1,NBAS                                                 G90DRV
*       II = II + 1                                                     G90DRV
*       ICORE(II) = LCTR(I)                                             G90DRV
* 140 CONTINUE                                                          G90DRV
*     DO 150 I = 1,NBAS                                                 G90DRV
*       II = II + 1                                                     G90DRV
*       ICORE(II) = LANG(I)                                             G90DRV
* 150 CONTINUE                                                          G90DRV
*     NFILE = 4                                                         G90DRV
*     CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE)                          G90DRV
C                                                                       G90DRV
C  Fetch the total energy from the RWF and store it on the NBODAF:      G90DRV
C                                                                       G90DRV
*     CALL TREAD(501,CORE,32,1,32,1,0)                                  G90DRV
*     CORE(1) = CORE(32)                                                G90DRV
*     CORE(2) = CORE(32)                                                G90DRV
*     NFILE = 8                                                         G90DRV
*     CALL NBWRIT(CORE,2,NFILE)                                         G90DRV
C                                                                       G90DRV
C  Store the atomic coordinates on the NBO DAF: (Note that these        G90DRV
C  coordinates are used in the calculation of dipole moments.)          G90DRV
C                                                                       G90DRV
*     DO 160 I = 1,3*NATOMS                                             G90DRV
*       CORE(I) = C(I) * TOANG                                          G90DRV
* 160 CONTINUE                                                          G90DRV
*     NFILE = 9                                                         G90DRV
*     CALL NBWRIT(CORE,3*NATOMS,NFILE)                                  G90DRV
C                                                                       G90DRV
C  Store the overlap matrix on the NBODAF:                              G90DRV
C                                                                       G90DRV
*     L2 = NDIM*(NDIM+1)/2                                              G90DRV
*     CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1)                        G90DRV
*     CALL PACK(CORE,NDIM,NBAS,L2)                                      G90DRV
*     NFILE = 10                                                        G90DRV
*     CALL NBWRIT(CORE,L2,NFILE)                                        G90DRV
C                                                                       G90DRV
C  Store the density matrices on the NBODAF:                            G90DRV
C                                                                       G90DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.0) WRITE(LFNPR,1000)              G90DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.1) WRITE(LFNPR,1010)              G90DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.2) WRITE(LFNPR,1020)              G90DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.3) WRITE(LFNPR,1030)              G90DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.4) WRITE(LFNPR,1040)              G90DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.5) WRITE(LFNPR,1050)              G90DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.6) WRITE(LFNPR,1060)              G90DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.7) WRITE(LFNPR,1070)              G90DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.8) WRITE(LFNPR,1080)              G90DRV
C                                                                       G90DRV
*     L2  = NDIM*(NDIM+1)/2                                             G90DRV
*     LEN = L2                                                          G90DRV
*     IF(OPEN) LEN = 2 * LEN                                            G90DRV
*     CALL DENGET(LFNPR,603,NBOOPT(2),LEN,GOTDEN,CORE)                  G90DRV
*     IF(.NOT.GOTDEN) STOP 'Missing density matrix'                     G90DRV
*     NFILE = 20                                                        G90DRV
*     CALL NBWRIT(CORE,L2,NFILE)                                        G90DRV
C                                                                       G90DRV
*     IF(OPEN) THEN                                                     G90DRV
*       NFILE = 21                                                      G90DRV
*       CALL NBWRIT(CORE(L2+1),L2,NFILE)                                G90DRV
*     END IF                                                            G90DRV
C                                                                       G90DRV
C  Store the Fock matrices on the NBODAF:                               G90DRV
C                                                                       G90DRV
*     IF(IWFOCK.NE.0) THEN                                              G90DRV
*       IEXIST = ITQRY(536)                                             G90DRV
*       IF(IEXIST.GT.0) THEN                                            G90DRV
*         L2 = NDIM*(NDIM+1)/2                                          G90DRV
*         CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1)                    G90DRV
*         CALL PACK(CORE,NDIM,NBAS,L2)                                  G90DRV
*         NFILE = 30                                                    G90DRV
*         CALL NBWRIT(CORE,L2,NFILE)                                    G90DRV
*       END IF                                                          G90DRV
C                                                                       G90DRV
*       IF(OPEN) THEN                                                   G90DRV
*         IEXIST = ITQRY(538)                                           G90DRV
*         IF(IEXIST.GT.0) THEN                                          G90DRV
*           L2 = NDIM*(NDIM+1)/2                                        G90DRV
*           CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1)                  G90DRV
*           CALL PACK(CORE,NDIM,NBAS,L2)                                G90DRV
*           NFILE = 31                                                  G90DRV
*           CALL NBWRIT(CORE,L2,NFILE)                                  G90DRV
*         END IF                                                        G90DRV
*       END IF                                                          G90DRV
*     END IF                                                            G90DRV
C                                                                       G90DRV
C  Store the AO to MO transformation matrices on the NBODAF:            G90DRV
C                                                                       G90DRV
*     IEXIST = ITQRY(524)                                               G90DRV
*     IF(IEXIST.GT.0) THEN                                              G90DRV
*       L3 = NDIM*NDIM                                                  G90DRV
*       CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0)                      G90DRV
*       NFILE = 40                                                      G90DRV
*       CALL NBWRIT(CORE,L3,NFILE)                                      G90DRV
*     END IF                                                            G90DRV
C                                                                       G90DRV
*     IF(OPEN) THEN                                                     G90DRV
*       IEXIST = ITQRY(526)                                             G90DRV
*       IF(IEXIST.GT.0) THEN                                            G90DRV
*         L3 = NDIM*NDIM                                                G90DRV
*         CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0)                    G90DRV
*         NFILE = 41                                                    G90DRV
*         CALL NBWRIT(CORE,L3,NFILE)                                    G90DRV
*       END IF                                                          G90DRV
*     END IF                                                            G90DRV
C                                                                       G90DRV
C  Store the x,y,z dipole integrals on the NBODAF:                      G90DRV
C                                                                       G90DRV
*     IEXIST = ITQRY(518)                                               G90DRV
*     IF(IEXIST.GT.0) THEN                                              G90DRV
*       L2 = NDIM*(NDIM+1)/2                                            G90DRV
*       LEN = 3 * L2                                                    G90DRV
*       CALL TREAD(518,CORE,LEN,1,LEN,1,0)                              G90DRV
*       DO 170 I = 1,LEN                                                G90DRV
*         CORE(I) = CORE(I) * TOANG                                     G90DRV
* 170   CONTINUE                                                        G90DRV
*       NFILE = 50                                                      G90DRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      G90DRV
*       NFILE = 51                                                      G90DRV
*       CALL NBWRIT(CORE(L2+1),L2,NFILE)                                G90DRV
*       NFILE = 52                                                      G90DRV
*       CALL NBWRIT(CORE(2*L2+1),L2,NFILE)                              G90DRV
*     END IF                                                            G90DRV
C                                                                       G90DRV
C  Store the AO basis set info on the NBO DAF:  (Note that two integers G90DRV
C  and three integer arrays are stored first.  Also remember that ICORE G90DRV
C  and CORE occupy the same memory.)                                    G90DRV
C                                                                       G90DRV
*     NEXP = 0                                                          G90DRV
*     DO 180 I = 1,6000                                                 G90DRV
*       IF(EXX(I).EQ.ZERO) GOTO 180                                     G90DRV
*       NEXP = I                                                        G90DRV
* 180 CONTINUE                                                          G90DRV
*     DO 190 I = 1,2+3*NSHELL+5*NEXP                                    G90DRV
*       CORE(I) = ZERO                                                  G90DRV
* 190 CONTINUE                                                          G90DRV
*     ICORE(1) = NSHELL                                                 G90DRV
*     ICORE(2) = NEXP                                                   G90DRV
C                                                                       G90DRV
C  Determine if Cartesian or pure D and F functions are used:           G90DRV
C                                                                       G90DRV
*     CALL ILSW(2,2,I5D6D)                                              G90DRV
*     CALL ILSW(2,16,I7F10F)                                            G90DRV
C                                                                       G90DRV
C  NCOMP(I) -- the number of components in the Ith shell:               G90DRV
C                                                                       G90DRV
*     II = 2                                                            G90DRV
*     DO 420 I = 1,NSHELL                                               G90DRV
*       II = II + 1                                                     G90DRV
*       ICORE(II) = 0                                                   G90DRV
*       MAXL = SHELLT(I)                                                G90DRV
*       ICNSTR = SHELLC(I)                                              G90DRV
C                                                                       G90DRV
C  Determine if an S orbital is in the shell:                           G90DRV
C                                                                       G90DRV
*       KS = 0                                                          G90DRV
*       IF(MAXL.EQ.0) KS = 1                                            G90DRV
*       IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1                            G90DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1                            G90DRV
*       IF(KS.EQ.0) GO TO 310                                           G90DRV
C                                                                       G90DRV
C  S orbital:                                                           G90DRV
C                                                                       G90DRV
*       ICORE(II) = ICORE(II) + 1                                       G90DRV
C                                                                       G90DRV
C  Determine if a set of P orbitals is in the shell:                    G90DRV
C                                                                       G90DRV
* 310   CONTINUE                                                        G90DRV
*       KP = 0                                                          G90DRV
*       IF(MAXL.EQ.0) GO TO 400                                         G90DRV
*       IF(MAXL.EQ.1) KP = 1                                            G90DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1                            G90DRV
*       IF(KP.EQ.0) GO TO 340                                           G90DRV
C                                                                       G90DRV
C  P orbital:                                                           G90DRV
C                                                                       G90DRV
*       ICORE(II) = ICORE(II) + 3                                       G90DRV
C                                                                       G90DRV
C  If MAXL is less than 2 then there are no D or F orbitals:            G90DRV
C  If MAXL is greater than 2 then there must be F orbitals:             G90DRV
C                                                                       G90DRV
* 340   IF(MAXL.LT.2) GO TO 400                                         G90DRV
*       IF(MAXL.GT.2) GO TO 370                                         G90DRV
C                                                                       G90DRV
C  D orbital:                                                           G90DRV
C                                                                       G90DRV
*       IMAX = I5D6D + 5                                                G90DRV
*       ICORE(II) = ICORE(II) + IMAX                                    G90DRV
C                                                                       G90DRV
C  If MAXL is less than 3 then there are no F orbitals:                 G90DRV
C                                                                       G90DRV
* 370   IF(MAXL.LT.3) GO TO 400                                         G90DRV
C                                                                       G90DRV
C  F orbital:                                                           G90DRV
C                                                                       G90DRV
*       IMAX=7                                                          G90DRV
*       IF(I7F10F.EQ.1) IMAX=10                                         G90DRV
*       ICORE(II) = ICORE(II) + IMAX                                    G90DRV
C                                                                       G90DRV
C  Skip here when no more orbitals are found:                           G90DRV
C                                                                       G90DRV
* 400   CONTINUE                                                        G90DRV
* 420 CONTINUE                                                          G90DRV
C                                                                       G90DRV
C  NPRIM(I) -- the number of gaussian primitives in the Ith shell:      G90DRV
C                                                                       G90DRV
*     DO 480 I = 1,NSHELL                                               G90DRV
*       II = II + 1                                                     G90DRV
*       ICORE(II) = SHELLN(I)                                           G90DRV
* 480 CONTINUE                                                          G90DRV
C                                                                       G90DRV
C  NPTR(I) -- pointer for the Ith shell into the gaussian parameters,   G90DRV
C             EXP, CS, CP, etc.:                                        G90DRV
C                                                                       G90DRV
*     DO 490 I = 1,NSHELL                                               G90DRV
*       II = II + 1                                                     G90DRV
*       ICORE(II) = SHELLA(I)                                           G90DRV
* 490 CONTINUE                                                          G90DRV
C                                                                       G90DRV
C  EXP(I) -- orbital exponents indexed by NPTR:                         G90DRV
C                                                                       G90DRV
*     DO 500 I = 1,NEXP                                                 G90DRV
*       II = II + 1                                                     G90DRV
*       CORE(II) = EXX(I)                                               G90DRV
* 500 CONTINUE                                                          G90DRV
C                                                                       G90DRV
C  CS,CP -- orbital coefficients:                                       G90DRV
C                                                                       G90DRV
*     DO 510 I = 1,NEXP                                                 G90DRV
*       II = II + 1                                                     G90DRV
*       CORE(II) = C1(I)                                                G90DRV
* 510 CONTINUE                                                          G90DRV
*     DO 520 I = 1,NEXP                                                 G90DRV
*       II = II + 1                                                     G90DRV
*       CORE(II) = C2(I)                                                G90DRV
* 520 CONTINUE                                                          G90DRV
C                                                                       G90DRV
C  Zero CD and CF arrays:                                               G90DRV
C                                                                       G90DRV
*     IHOLD = II                                                        G90DRV
*     DO 550 I = 1,2*NEXP                                               G90DRV
*       II = II + 1                                                     G90DRV
*       CORE(II) = ZERO                                                 G90DRV
* 550 CONTINUE                                                          G90DRV
C                                                                       G90DRV
C  Build CD and CF from C3 and C4:                                      G90DRV
C                                                                       G90DRV
*     DO 570 I = 1,NSHELL                                               G90DRV
*       IPTR = SHLADF(I)                                                G90DRV
*       IF(IPTR.GT.0) THEN                                              G90DRV
*         DO 560 J = 1,SHELLN(I)                                        G90DRV
*           LPTR = J + SHELLA(I) + IHOLD - 1                            G90DRV
*           MPTR = J + IPTR - 1                                         G90DRV
*           CORE(LPTR) = C3(MPTR)                                       G90DRV
*           CORE(LPTR+NEXP) = C4(MPTR)                                  G90DRV
* 560     CONTINUE                                                      G90DRV
*       END IF                                                          G90DRV
* 570 CONTINUE                                                          G90DRV
*     NFILE = 5                                                         G90DRV
*     CALL NBWRIT(CORE,II,NFILE)                                        G90DRV
*     RETURN                                                            G90DRV
C                                                                       G90DRV
* 900 WRITE(LFNPR,990)                                                  G90DRV
*     RETURN                                                            G90DRV
C                                                                       G90DRV
* 990 FORMAT(/1X,'The NBO program is not set up to handle complex ',    G90DRV
*    + 'wave functions')                                                G90DRV
*1000 FORMAT(/1X,'Analyzing the SCF density')                           G90DRV
*1010 FORMAT(/1X,'Analyzing the MP first order density')                G90DRV
*1020 FORMAT(/1X,'Analyzing the MP2 density')                           G90DRV
*1030 FORMAT(/1X,'Analyzing the MP3 density')                           G90DRV
*1040 FORMAT(/1X,'Analyzing the MP4 density')                           G90DRV
*1050 FORMAT(/1X,'Analyzing the CI one-particle density')               G90DRV
*1060 FORMAT(/1X,'Analyzing the CI density')                            G90DRV
*1070 FORMAT(/1X,'Analyzing the QCI/CC density')                        G90DRV
*1080 FORMAT(/1X,'Analyzing the density correct to second order')       G90DRV
*     END                                                               G90DRV
C***********************************************************************G90DRV
*     SUBROUTINE DELSCF(CORE,ICORE,NBOOPT)                              G90DRV
C***********************************************************************G90DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G90DRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             G90DRV
*     LOGICAL NEW,ERROR,SEQ                                             G90DRV
C                                                                       G90DRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G90DRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       G90DRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       G90DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G90DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G90DRV
*    +           LFNDAF,LFNDEF                                          G90DRV
C                                                                       G90DRV
C  If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO  G90DRV
C  DAF to the RWFs.                                                     G90DRV
C                                                                       G90DRV
*     IF(NBOOPT(1).EQ.2) THEN                                           G90DRV
*       NEW = .FALSE.                                                   G90DRV
*       CALL NBOPEN(NEW,ERROR)                                          G90DRV
*       IF(ERROR) THEN                                                  G90DRV
*         WRITE(LFNPR,900)                                              G90DRV
*         STOP                                                          G90DRV
*       END IF                                                          G90DRV
*       L2 = NDIM * (NDIM + 1)/2                                        G90DRV
*       IF(OPEN) THEN                                                   G90DRV
*         ALPHA = .TRUE.                                                G90DRV
*         BETA  = .FALSE.                                               G90DRV
*         CALL FENEWD(CORE)                                             G90DRV
*         CALL TWRITE(528,CORE,L2,1,L2,1,0)                             G90DRV
*         ALPHA = .FALSE.                                               G90DRV
*         BETA  = .TRUE.                                                G90DRV
*         CALL FENEWD(CORE)                                             G90DRV
*         CALL TWRITE(530,CORE,L2,1,L2,1,0)                             G90DRV
*       ELSE                                                            G90DRV
*         ALPHA = .FALSE.                                               G90DRV
*         BETA  = .FALSE.                                               G90DRV
*         CALL FENEWD(CORE)                                             G90DRV
*         CALL TWRITE(528,CORE,L2,1,L2,1,0)                             G90DRV
*       END IF                                                          G90DRV
*       SEQ = .FALSE.                                                   G90DRV
*       CALL NBCLOS(SEQ)                                                G90DRV
*     END IF                                                            G90DRV
C                                                                       G90DRV
C  If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF:      G90DRV
C                                                                       G90DRV
*     IF(NBOOPT(1).EQ.3) THEN                                           G90DRV
*       NEW = .FALSE.                                                   G90DRV
*       CALL NBOPEN(NEW,ERROR)                                          G90DRV
*       IF(ERROR) THEN                                                  G90DRV
*         WRITE(LFNPR,900)                                              G90DRV
*         STOP                                                          G90DRV
*       END IF                                                          G90DRV
*       CALL TREAD(501,CORE,32,1,32,1,0)                                G90DRV
*       CALL SVE0(CORE(32))                                             G90DRV
*       SEQ = .FALSE.                                                   G90DRV
*       CALL NBCLOS(SEQ)                                                G90DRV
*     END IF                                                            G90DRV
*     RETURN                                                            G90DRV
C                                                                       G90DRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ',        G90DRV
*    + 'subroutine DELSCF.')                                            G90DRV
*     END                                                               G90DRV
C***********************************************************************G90DRV
C                                                                       G90DRV
C           E N D    O F    G 9 0 N B O    R O U T I N E S              G90DRV
C                                                                       G90DRV
C***********************************************************************G90DRV
C***********************************************************************G88DRV
C                                                                       G88DRV
C                                                                       G88DRV
C                          G  8  8  N  B  O                             G88DRV
C                                                                       G88DRV
C                                                                       G88DRV
C                 GAUSSIAN 88 VERSION OF NBO PROGRAM                    G88DRV
C                                                                       G88DRV
C                                                                       G88DRV
C  DRIVER ROUTINES:                                                     G88DRV
C                                                                       G88DRV
C      SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR)                        G88DRV
C      SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                             G88DRV
C      SUBROUTINE DELSCF(CORE,ICORE,NBOOPT)                             G88DRV
C                                                                       G88DRV
C***********************************************************************G88DRV
*     SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR)                         G88DRV
C***********************************************************************G88DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G88DRV
C                                                                       G88DRV
*     PARAMETER (MAXFIL = 40)                                           G88DRV
C                                                                       G88DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G88DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G88DRV
*    +           LFNDAF,LFNDEF                                          G88DRV
*     COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)                          G88DRV
*     CHARACTER*80 FILENM                                               G88DRV
C                                                                       G88DRV
*     DIMENSION CORE(1),IOP(50)                                         G88DRV
*     DIMENSION NBOOPT(10)                                              G88DRV
C                                                                       G88DRV
*     LFNIN = 5                                                         G88DRV
*     LFNPR = 6                                                         G88DRV
C                                                                       G88DRV
*     DATA TENTH/0.1D0/                                                 G88DRV
C                                                                       G88DRV
C  Set NBO options.                                                     G88DRV
C                                                                       G88DRV
*     DO 10 I = 1,9                                                     G88DRV
*       NBOOPT(I) = IOP(I+39)                                           G88DRV
*  10 CONTINUE                                                          G88DRV
*     NBOOPT(10) = 88                                                   G88DRV
C                                                                       G88DRV
C  --- NBO analysis ---                                                 G88DRV
C                                                                       G88DRV
*     ICONTR = 0                                                        G88DRV
*     IF(ABS(NBOOPT(1)).LT.2) THEN                                      G88DRV
*       CALL CHARPN(4HNBO )                                             G88DRV
*       CALL NBO(CORE,MEMORY,NBOOPT)                                    G88DRV
C                                                                       G88DRV
C  Store the name of the NBO direct access file on the RWFiles          G88DRV
C                                                                       G88DRV
*       DO 20 I = 1,80                                                  G88DRV
*         CORE(I) = ICHAR(FILENM(I:I))                                  G88DRV
*  20   CONTINUE                                                        G88DRV
*       CORE(81) = LFNDAF                                               G88DRV
*       CALL TWRITE(636,CORE,81,1,81,1,0)                               G88DRV
C                                                                       G88DRV
C  --- NBO energetic analysis ---                                       G88DRV
C                                                                       G88DRV
*     ELSE IF(NBOOPT(1).EQ.2) THEN                                      G88DRV
C                                                                       G88DRV
C  Retrieve the name of the NBO direct access file from the RWFiles     G88DRV
C                                                                       G88DRV
*       CALL TREAD(636,CORE,81,1,81,1,0)                                G88DRV
*       DO 30 I = 1,80                                                  G88DRV
*         FILENM(I:I) = CHAR(INT(CORE(I) + TENTH))                      G88DRV
*  30   CONTINUE                                                        G88DRV
*       LFNDAF = INT(ABS(CORE(81)) + TENTH)                             G88DRV
*       CALL CHARPN(4HDELE)                                             G88DRV
*       CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE)                           G88DRV
*       IF(IDONE.NE.0) ICONTR = 1                                       G88DRV
*       IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT)                    G88DRV
C                                                                       G88DRV
*     ELSE IF(NBOOPT(1).EQ.3) THEN                                      G88DRV
*       CALL TREAD(636,CORE,81,1,81,1,0)                                G88DRV
*       DO 40 I = 1,80                                                  G88DRV
*         FILENM(I:I) = CHAR(INT(CORE(I) + TENTH))                      G88DRV
*  40   CONTINUE                                                        G88DRV
*       LFNDAF = INT(ABS(CORE(81)) + TENTH)                             G88DRV
*       CALL CHARPN(4HEDEL)                                             G88DRV
*       CALL DELSCF(CORE,CORE,NBOOPT)                                   G88DRV
*       CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE)                           G88DRV
*     END IF                                                            G88DRV
C                                                                       G88DRV
*     RETURN                                                            G88DRV
*     END                                                               G88DRV
C***********************************************************************G88DRV
*     SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                              G88DRV
C***********************************************************************G88DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G88DRV
*     LOGICAL GOTDEN                                                    G88DRV
C-----------------------------------------------------------------------G88DRV
C                                                                       G88DRV
C  Routine FEAOIN accesses the following records of the RWFs:           G88DRV
C                                                                       G88DRV
C        501  ---   Total energy                                        G88DRV
C        502  ---   Job title                                           G88DRV
C        506  ---   Basis set information                               G88DRV
C        512  ---   Effective core potential information                G88DRV
C        514  ---   AO overlap matrix                                   G88DRV
C        518  ---   AO dipole integrals                                 G88DRV
C        524  ---   MO coefficients (alpha)                             G88DRV
C        526  ---   MO coefficients (beta)                              G88DRV
C        536  ---   AO Fock matrix (alpha)                              G88DRV
C        538  ---   AO Fock matrix (beta)                               G88DRV
C        603  ---   AO density matrix                                   G88DRV
C                                                                       G88DRV
C ----------------------------------------------------------------------G88DRV
C                                                                       G88DRV
C  NBO Common blocks                                                    G88DRV
C                                                                       G88DRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               G88DRV
C                                                                       G88DRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G88DRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       G88DRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       G88DRV
*     COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,        G88DRV
*    + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    G88DRV
*    + JCORE,JPRINT(60)                                                 G88DRV
*     COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)                             G88DRV
*     COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G88DRV
*    +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)                     G88DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G88DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G88DRV
*    +           LFNDAF,LFNDEF                                          G88DRV
C                                                                       G88DRV
C  GAUSSIAN 88 Common blocks                                            G88DRV
C                                                                       G88DRV
*     COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(401),        G88DRV
*    *           ATMCHG(400),C(1200)                                    G88DRV
*     COMMON/LP2/NLP(1600),CLP(1600),ZLP(1600),KFIRST(400,5),           G88DRV
*    *  KLAST(400,5),LMAX(400),LPSKIP(400),NFroz(400)                   G88DRV
*     COMMON/B/EXX(6000),C1(6000),C2(6000),C3(6000),X(2000),Y(2000),    G88DRV
*    *     Z(2000),JAN(2000),SHELLA(2000),SHELLN(2000),SHELLT(2000),    G88DRV
*    *     SHELLC(2000),AOS(2000),AON(2000),NSHELL,MAXTYP               G88DRV
*     INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON                G88DRV
*     DIMENSION C4(2000),SHLADF(2000)                                   G88DRV
*     EQUIVALENCE(C4(1),C3(2001)),(SHLADF(1),C3(4001))                  G88DRV
C                                                                       G88DRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             G88DRV
*     DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2)                         G88DRV
C                                                                       G88DRV
C  Obtain the following information:                                    G88DRV
C                                                                       G88DRV
C    ROHF        =.TRUE. If RHF open shell wavefunction                 G88DRV
C                =.FALSE. otherwise                                     G88DRV
C                                                                       G88DRV
C    UHF         =.TRUE. If UHF wavefunction                            G88DRV
C                =.FALSE. otherwise                                     G88DRV
C                                                                       G88DRV
C    AUHF        =.TRUE. If spin-annihilated UHF wavefunction           G88DRV
C                =.FALSE. otherwise                                     G88DRV
C                                                                       G88DRV
C    CI          =.TRUE. If CI wavefunction                             G88DRV
C                =.FALSE. otherwise                                     G88DRV
C                                                                       G88DRV
C    OPEN        =.TRUE. If open shell wavefunction                     G88DRV
C                =.FALSE. otherwise                                     G88DRV
C                                                                       G88DRV
C    COMPLX      =.TRUE. If complex wavefunction                        G88DRV
C                =.FALSE. otherwise                                     G88DRV
C                (Note: The program is not capable of handling this.)   G88DRV
C                                                                       G88DRV
C    NATOMS      Number of atomic centers                               G88DRV
C                                                                       G88DRV
C    NDIM        Dimension of matrices (overlap and density)            G88DRV
C                                                                       G88DRV
C    NBAS        Number of basis functions (.le.NDIM)                   G88DRV
C                                                                       G88DRV
C    IPSEUD      Set to one if pseudopotentials are used.               G88DRV
C                                                                       G88DRV
C    IWCUBF      This pertains only basis sets with F functions.        G88DRV
C                                                                       G88DRV
C                If cartesian F functions are input, set IWCUBF to:     G88DRV
C                    0,  if these are to be transformed to the          G88DRV
C                        standard set of pure F functions               G88DRV
C                    1,  if these are to be transformed to the          G88DRV
C                        cubic set of pure F functions                  G88DRV
C                                                                       G88DRV
C                If pure F functions are input, set to IWCUBF to:       G88DRV
C                    0,  if these are standard F functions              G88DRV
C                    1,  if these are cubic F functions                 G88DRV
C                                                                       G88DRV
C    IATNO(I),I=1,NATOMS                                                G88DRV
C                List of atomic numbers                                 G88DRV
C                                                                       G88DRV
C    LCTR(I),I=1,NBAS                                                   G88DRV
C                List of atomic centers of the basis functions          G88DRV
C                (LCTR(3)=2 if basis function 3 is on atom 2)           G88DRV
C                                                                       G88DRV
C    LANG(I),I=1,NBAS                                                   G88DRV
C                List of angular symmetry information for the AO basis  G88DRV
C                                                                       G88DRV
*     DATA LISTS/   1/                                                  G88DRV
*     DATA LISTP/ 101, 102, 103/                                        G88DRV
*     DATA LISTD/ 255, 252, 253, 254, 251,   0,                         G88DRV
*    +            201, 204, 206, 202, 203, 205/                         G88DRV
*     DATA LISTF/ 351, 352, 353, 354, 355, 356, 357,   0,   0,   0,     G88DRV
*    +            301, 307, 310, 304, 302, 303, 306, 309, 308, 305/     G88DRV
*     DATA ZERO/0.0D0/                                                  G88DRV
*     DATA TOANG/0.529177249/                                           G88DRV
C                                                                       G88DRV
C  Store job title on NBODAF:                                           G88DRV
C                                                                       G88DRV
*     LEN = INTOWP(4000+100)                                            G88DRV
*     CALL TREAD(502,ICORE,LEN,1,LEN,1,0)                               G88DRV
*     NFILE = 2                                                         G88DRV
*     CALL NBWRIT(ICORE(4001),10,NFILE)                                 G88DRV
C                                                                       G88DRV
C  Get the number of atoms from NAT and store the atomic numbers in     G88DRV
C  IATNO and nuclear charges in IZNUC.  (NOTE: atomic numbers and       G88DRV
C  nuclear charges may not be equivalent if effective core potentials   G88DRV
C  (ECP) are used.)                                                     G88DRV
C                                                                       G88DRV
*     LEN = 0                                                           G88DRV
*     IEXIST = ITQRY(512)                                               G88DRV
*     IF(IEXIST.GT.0) THEN                                              G88DRV
*       LEN = 8 * 400 + 17 * INTOWP(400)                                G88DRV
*       CALL TREAD(512,NLP,LEN,1,LEN,1,0)                               G88DRV
*     END IF                                                            G88DRV
*     NATOMS = NATOM                                                    G88DRV
*     DO 20 I = 1,NATOMS                                                G88DRV
*       IATNO(I) = IAN(I)                                               G88DRV
*       IF(IEXIST.GT.0) THEN                                            G88DRV
*         IZNUC(I) = IATNO(I) - NFROZ(I)                                G88DRV
*         IF(NFROZ(I).NE.0) IPSEUD = 1                                  G88DRV
*       ELSE                                                            G88DRV
*         IZNUC(I) = IATNO(I)                                           G88DRV
*       END IF                                                          G88DRV
*  20 CONTINUE                                                          G88DRV
C                                                                       G88DRV
C  Restore the basis set to COMMON/B/:                                  G88DRV
C                                                                       G88DRV
*     LEN = 30000 + INTOWP(14002)                                       G88DRV
*     CALL TREAD(506,EXX,LEN,1,LEN,1,0)                                 G88DRV
C                                                                       G88DRV
C  The Gaussian programs do not use cubic f basis functions.            G88DRV
C  Determine which set of d and f functions are being used,             G88DRV
C  Cartesian or pure):                                                  G88DRV
C                                                                       G88DRV
*     IWCUBF = 0                                                        G88DRV
*     CALL ILSW(2,2,I5D6D)                                              G88DRV
*     CALL ILSW(2,16,I7F10F)                                            G88DRV
C                                                                       G88DRV
C  Construct the AO information lists: LCTR and LANG                    G88DRV
C                                                                       G88DRV
*     IBAS = 0                                                          G88DRV
*     DO 90 ISHELL = 1,2000                                             G88DRV
*       IF(IBAS.EQ.NBASIS) GOTO 100                                     G88DRV
*       NCTR   = JAN(ISHELL)                                            G88DRV
*       MAXL   = SHELLT(ISHELL)                                         G88DRV
*       ICNSTR = SHELLC(ISHELL)                                         G88DRV
C                                                                       G88DRV
C  Is an s orbital in the shell?                                        G88DRV
C                                                                       G88DRV
*       KS = 0                                                          G88DRV
*       IF(MAXL.EQ.0) KS = 1                                            G88DRV
*       IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1                            G88DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1                            G88DRV
*       IF(KS.EQ.0) GOTO 30                                             G88DRV
C                                                                       G88DRV
C  s orbital:                                                           G88DRV
C                                                                       G88DRV
*         IBAS = IBAS + 1                                               G88DRV
*         LCTR(IBAS) = NCTR                                             G88DRV
*         LANG(IBAS) = LISTS                                            G88DRV
C                                                                       G88DRV
C  Is a set of p orbitals in the shell?                                 G88DRV
C                                                                       G88DRV
*  30   CONTINUE                                                        G88DRV
*       KP = 0                                                          G88DRV
*       IF(MAXL.EQ.0) GOTO 90                                           G88DRV
*       IF(MAXL.EQ.1) KP = 1                                            G88DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1                            G88DRV
*       IF(KP.EQ.0) GOTO 50                                             G88DRV
C                                                                       G88DRV
C  p orbitals:                                                          G88DRV
C                                                                       G88DRV
*       DO 40 I = 1,3                                                   G88DRV
*         IBAS = IBAS + 1                                               G88DRV
*         LCTR(IBAS) = NCTR                                             G88DRV
*         LANG(IBAS) = LISTP(I)                                         G88DRV
*  40   CONTINUE                                                        G88DRV
C                                                                       G88DRV
C  d orbitals:                                                          G88DRV
C                                                                       G88DRV
*  50   IF(MAXL.NE.2) GOTO 70                                           G88DRV
*         IMAX = I5D6D + 5                                              G88DRV
*         KD = I5D6D + 1                                                G88DRV
*         DO 60 I = 1,IMAX                                              G88DRV
*           IBAS = IBAS + 1                                             G88DRV
*           LCTR(IBAS) = NCTR                                           G88DRV
*           LANG(IBAS) = LISTD(I,KD)                                    G88DRV
*  60     CONTINUE                                                      G88DRV
*         GO TO 90                                                      G88DRV
C                                                                       G88DRV
C  f orbitals:                                                          G88DRV
C                                                                       G88DRV
*  70   IF(MAXL.NE.3) GOTO 90                                           G88DRV
*         IMAX = 7                                                      G88DRV
*         IF(I7F10F.EQ.1) IMAX = 10                                     G88DRV
*         KF = I7F10F + 1                                               G88DRV
*         DO 80 I = 1,IMAX                                              G88DRV
*           IBAS = IBAS + 1                                             G88DRV
*           LCTR(IBAS) = NCTR                                           G88DRV
*           LANG(IBAS) = LISTF(I,KF)                                    G88DRV
*  80     CONTINUE                                                      G88DRV
*  90 CONTINUE                                                          G88DRV
* 100 CONTINUE                                                          G88DRV
*     NDIM = NBASIS                                                     G88DRV
*     NBAS = NBASIS                                                     G88DRV
C                                                                       G88DRV
C  Determine the type of wave function the density matrix is from:      G88DRV
C                                                                       G88DRV
*     IF(MULTIP.GT.1) OPEN = .TRUE.                                     G88DRV
*     IF(NBOOPT(2).NE.0) THEN                                           G88DRV
*       CI = .TRUE.                                                     G88DRV
*     ELSE                                                              G88DRV
*       CALL ILSW(2,1,ISCF)                                             G88DRV
*       CALL ILSW(2,22,IROHF)                                           G88DRV
*       IF(ISCF.EQ.1)  UHF    = .TRUE.                                  G88DRV
*       IF(UHF)        OPEN   = .TRUE.                                  G88DRV
*       IF(IROHF.EQ.1) ROHF   = .TRUE.                                  G88DRV
*       IF(IROHF.EQ.2) ROHF   = .TRUE.                                  G88DRV
*       IF(IROHF.EQ.3) MCSCF  = .TRUE.                                  G88DRV
*       IF(ISCF.GT.1)  COMPLX = .TRUE.                                  G88DRV
*       IF(COMPLX) GOTO 900                                             G88DRV
*     END IF                                                            G88DRV
*     IF(NBOOPT(5).EQ.1) AUHF = .TRUE.                                  G88DRV
*     ORTHO = .FALSE.                                                   G88DRV
C                                                                       G88DRV
C  No Fock matrices for ROHF, MCSCF, or CI wavefunctions:               G88DRV
C                                                                       G88DRV
*     IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0                                G88DRV
C                                                                       G88DRV
C  Expectation values of the Fock operator are in atomic units:         G88DRV
C                                                                       G88DRV
*     MUNIT = 0                                                         G88DRV
C                                                                       G88DRV
C  Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:         G88DRV
C                                                                       G88DRV
*     ICORE(1)  = NATOMS                                                G88DRV
*     ICORE(2)  = NDIM                                                  G88DRV
*     ICORE(3)  = NBAS                                                  G88DRV
*     ICORE(4)  = MUNIT                                                 G88DRV
*     ICORE(5)  = 0                                                     G88DRV
*     IF(ROHF)  ICORE(5)  = 1                                           G88DRV
*     ICORE(6)  = 0                                                     G88DRV
*     IF(UHF)   ICORE(6)  = 1                                           G88DRV
*     ICORE(7)  = 0                                                     G88DRV
*     IF(CI)    ICORE(7)  = 1                                           G88DRV
*     ICORE(8)  = 0                                                     G88DRV
*     IF(OPEN)  ICORE(8)  = 1                                           G88DRV
*     ICORE(9)  = 0                                                     G88DRV
*     IF(MCSCF) ICORE(9)  = 1                                           G88DRV
*     ICORE(10) = 0                                                     G88DRV
*     IF(AUHF)  ICORE(10)  = 1                                          G88DRV
*     ICORE(11) = 0                                                     G88DRV
*     IF(ORTHO) ICORE(11) = 1                                           G88DRV
*     ICORE(12) = 1                                                     G88DRV
*     NFILE = 3                                                         G88DRV
*     CALL NBWRIT(ICORE,12,NFILE)                                       G88DRV
C                                                                       G88DRV
C  Store IATNO, IZNUC, LCTR, and LANG on NBO DAF:                       G88DRV
C                                                                       G88DRV
*     II = 0                                                            G88DRV
*     DO 120 I = 1,NATOMS                                               G88DRV
*       II = II + 1                                                     G88DRV
*       ICORE(II) = IATNO(I)                                            G88DRV
* 120 CONTINUE                                                          G88DRV
*     DO 130 I = 1,NATOMS                                               G88DRV
*       II = II + 1                                                     G88DRV
*       ICORE(II) = IZNUC(I)                                            G88DRV
* 130 CONTINUE                                                          G88DRV
*     DO 140 I = 1,NBAS                                                 G88DRV
*       II = II + 1                                                     G88DRV
*       ICORE(II) = LCTR(I)                                             G88DRV
* 140 CONTINUE                                                          G88DRV
*     DO 150 I = 1,NBAS                                                 G88DRV
*       II = II + 1                                                     G88DRV
*       ICORE(II) = LANG(I)                                             G88DRV
* 150 CONTINUE                                                          G88DRV
*     NFILE = 4                                                         G88DRV
*     CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE)                          G88DRV
C                                                                       G88DRV
C  Fetch the total energy from the RWF and store it on the NBODAF:      G88DRV
C                                                                       G88DRV
*     CALL TREAD(501,CORE,32,1,32,1,0)                                  G88DRV
*     CORE(1) = CORE(32)                                                G88DRV
*     CORE(2) = CORE(32)                                                G88DRV
*     NFILE = 8                                                         G88DRV
*     CALL NBWRIT(CORE,2,NFILE)                                         G88DRV
C                                                                       G88DRV
C  Store the atomic coordinates on the NBO DAF: (Note that these        G88DRV
C  coordinates are used in the calculation of dipole moments.)          G88DRV
C                                                                       G88DRV
*     DO 160 I = 1,3*NATOMS                                             G88DRV
*       CORE(I) = C(I) * TOANG                                          G88DRV
* 160 CONTINUE                                                          G88DRV
*     NFILE = 9                                                         G88DRV
*     CALL NBWRIT(CORE,3*NATOMS,NFILE)                                  G88DRV
C                                                                       G88DRV
C  Store the overlap matrix on the NBODAF:                              G88DRV
C                                                                       G88DRV
*     L2 = NDIM*(NDIM+1)/2                                              G88DRV
*     CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1)                        G88DRV
*     CALL PACK(CORE,NDIM,NBAS,L2)                                      G88DRV
*     NFILE = 10                                                        G88DRV
*     CALL NBWRIT(CORE,L2,NFILE)                                        G88DRV
C                                                                       G88DRV
C  Store the density matrices on the NBODAF:                            G88DRV
C                                                                       G88DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.0) WRITE(LFNPR,1000)              G88DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.1) WRITE(LFNPR,1010)              G88DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.2) WRITE(LFNPR,1020)              G88DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.3) WRITE(LFNPR,1030)              G88DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.4) WRITE(LFNPR,1040)              G88DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.5) WRITE(LFNPR,1050)              G88DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.6) WRITE(LFNPR,1060)              G88DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.7) WRITE(LFNPR,1070)              G88DRV
*     IF(IPRINT.NE.0.AND.NBOOPT(2).EQ.8) WRITE(LFNPR,1080)              G88DRV
C                                                                       G88DRV
*     L2  = NDIM*(NDIM+1)/2                                             G88DRV
*     LEN = L2                                                          G88DRV
*     IF(OPEN) LEN = 2 * LEN                                            G88DRV
*     CALL DENGET(LFNPR,603,NBOOPT(2),LEN,GOTDEN,CORE)                  G88DRV
*     IF(.NOT.GOTDEN) STOP 'Missing density matrix'                     G88DRV
*     NFILE = 20                                                        G88DRV
*     CALL NBWRIT(CORE,L2,NFILE)                                        G88DRV
C                                                                       G88DRV
*     IF(OPEN) THEN                                                     G88DRV
*       NFILE = 21                                                      G88DRV
*       CALL NBWRIT(CORE(L2+1),L2,NFILE)                                G88DRV
*     END IF                                                            G88DRV
C                                                                       G88DRV
C  Store the Fock matrices on the NBODAF:                               G88DRV
C                                                                       G88DRV
*     IF(IWFOCK.NE.0) THEN                                              G88DRV
*       IEXIST = ITQRY(536)                                             G88DRV
*       IF(IEXIST.GT.0) THEN                                            G88DRV
*         L2 = NDIM*(NDIM+1)/2                                          G88DRV
*         CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1)                    G88DRV
*         CALL PACK(CORE,NDIM,NBAS,L2)                                  G88DRV
*         NFILE = 30                                                    G88DRV
*         CALL NBWRIT(CORE,L2,NFILE)                                    G88DRV
*       END IF                                                          G88DRV
C                                                                       G88DRV
*       IF(OPEN) THEN                                                   G88DRV
*         IEXIST = ITQRY(538)                                           G88DRV
*         IF(IEXIST.GT.0) THEN                                          G88DRV
*           L2 = NDIM*(NDIM+1)/2                                        G88DRV
*           CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1)                  G88DRV
*           CALL PACK(CORE,NDIM,NBAS,L2)                                G88DRV
*           NFILE = 31                                                  G88DRV
*           CALL NBWRIT(CORE,L2,NFILE)                                  G88DRV
*         END IF                                                        G88DRV
*       END IF                                                          G88DRV
*     END IF                                                            G88DRV
C                                                                       G88DRV
C  Store the AO to MO transformation matrices on the NBODAF:            G88DRV
C                                                                       G88DRV
*     IEXIST = ITQRY(524)                                               G88DRV
*     IF(IEXIST.GT.0) THEN                                              G88DRV
*       L3 = NDIM*NDIM                                                  G88DRV
*       CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0)                      G88DRV
*       NFILE = 40                                                      G88DRV
*       CALL NBWRIT(CORE,L3,NFILE)                                      G88DRV
*     END IF                                                            G88DRV
C                                                                       G88DRV
*     IF(OPEN) THEN                                                     G88DRV
*       IEXIST = ITQRY(526)                                             G88DRV
*       IF(IEXIST.GT.0) THEN                                            G88DRV
*         L3 = NDIM*NDIM                                                G88DRV
*         CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0)                    G88DRV
*         NFILE = 41                                                    G88DRV
*         CALL NBWRIT(CORE,L3,NFILE)                                    G88DRV
*       END IF                                                          G88DRV
*     END IF                                                            G88DRV
C                                                                       G88DRV
C  Store the x,y,z dipole integrals on the NBODAF:                      G88DRV
C                                                                       G88DRV
*     IEXIST = ITQRY(518)                                               G88DRV
*     IF(IEXIST.GT.0) THEN                                              G88DRV
*       L2 = NDIM*(NDIM+1)/2                                            G88DRV
*       LEN = 3 * L2                                                    G88DRV
*       CALL TREAD(518,CORE,LEN,1,LEN,1,0)                              G88DRV
*       DO 170 I = 1,LEN                                                G88DRV
*         CORE(I) = CORE(I) * TOANG                                     G88DRV
* 170   CONTINUE                                                        G88DRV
*       NFILE = 50                                                      G88DRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      G88DRV
*       NFILE = 51                                                      G88DRV
*       CALL NBWRIT(CORE(L2+1),L2,NFILE)                                G88DRV
*       NFILE = 52                                                      G88DRV
*       CALL NBWRIT(CORE(2*L2+1),L2,NFILE)                              G88DRV
*     END IF                                                            G88DRV
C                                                                       G88DRV
C  Store the AO basis set info on the NBO DAF:  (Note that two integers G88DRV
C  and three integer arrays are stored first.  Also remember that ICORE G88DRV
C  and CORE occupy the same memory.)                                    G88DRV
C                                                                       G88DRV
*     NEXP = 0                                                          G88DRV
*     DO 180 I = 1,6000                                                 G88DRV
*       IF(EXX(I).EQ.ZERO) GOTO 180                                     G88DRV
*       NEXP = I                                                        G88DRV
* 180 CONTINUE                                                          G88DRV
*     DO 190 I = 1,2+3*NSHELL+5*NEXP                                    G88DRV
*       CORE(I) = ZERO                                                  G88DRV
* 190 CONTINUE                                                          G88DRV
*     ICORE(1) = NSHELL                                                 G88DRV
*     ICORE(2) = NEXP                                                   G88DRV
C                                                                       G88DRV
C  Determine if Cartesian or pure D and F functions are used:           G88DRV
C                                                                       G88DRV
*     CALL ILSW(2,2,I5D6D)                                              G88DRV
*     CALL ILSW(2,16,I7F10F)                                            G88DRV
C                                                                       G88DRV
C  NCOMP(I) -- the number of components in the Ith shell:               G88DRV
C                                                                       G88DRV
*     II = 2                                                            G88DRV
*     DO 420 I = 1,NSHELL                                               G88DRV
*       II = II + 1                                                     G88DRV
*       ICORE(II) = 0                                                   G88DRV
*       MAXL = SHELLT(I)                                                G88DRV
*       ICNSTR = SHELLC(I)                                              G88DRV
C                                                                       G88DRV
C  Determine if an S orbital is in the shell:                           G88DRV
C                                                                       G88DRV
*       KS = 0                                                          G88DRV
*       IF(MAXL.EQ.0) KS = 1                                            G88DRV
*       IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1                            G88DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1                            G88DRV
*       IF(KS.EQ.0) GO TO 310                                           G88DRV
C                                                                       G88DRV
C  S orbital:                                                           G88DRV
C                                                                       G88DRV
*       ICORE(II) = ICORE(II) + 1                                       G88DRV
C                                                                       G88DRV
C  Determine if a set of P orbitals is in the shell:                    G88DRV
C                                                                       G88DRV
* 310   CONTINUE                                                        G88DRV
*       KP = 0                                                          G88DRV
*       IF(MAXL.EQ.0) GO TO 400                                         G88DRV
*       IF(MAXL.EQ.1) KP = 1                                            G88DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1                            G88DRV
*       IF(KP.EQ.0) GO TO 340                                           G88DRV
C                                                                       G88DRV
C  P orbital:                                                           G88DRV
C                                                                       G88DRV
*       ICORE(II) = ICORE(II) + 3                                       G88DRV
C                                                                       G88DRV
C  If MAXL is less than 2 then there are no D or F orbitals:            G88DRV
C  If MAXL is greater than 2 then there must be F orbitals:             G88DRV
C                                                                       G88DRV
* 340   IF(MAXL.LT.2) GO TO 400                                         G88DRV
*       IF(MAXL.GT.2) GO TO 370                                         G88DRV
C                                                                       G88DRV
C  D orbital:                                                           G88DRV
C                                                                       G88DRV
*       IMAX = I5D6D + 5                                                G88DRV
*       ICORE(II) = ICORE(II) + IMAX                                    G88DRV
C                                                                       G88DRV
C  If MAXL is less than 3 then there are no F orbitals:                 G88DRV
C                                                                       G88DRV
* 370   IF(MAXL.LT.3) GO TO 400                                         G88DRV
C                                                                       G88DRV
C  F orbital:                                                           G88DRV
C                                                                       G88DRV
*       IMAX=7                                                          G88DRV
*       IF(I7F10F.EQ.1) IMAX=10                                         G88DRV
*       ICORE(II) = ICORE(II) + IMAX                                    G88DRV
C                                                                       G88DRV
C  Skip here when no more orbitals are found:                           G88DRV
C                                                                       G88DRV
* 400   CONTINUE                                                        G88DRV
* 420 CONTINUE                                                          G88DRV
C                                                                       G88DRV
C  NPRIM(I) -- the number of gaussian primitives in the Ith shell:      G88DRV
C                                                                       G88DRV
*     DO 480 I = 1,NSHELL                                               G88DRV
*       II = II + 1                                                     G88DRV
*       ICORE(II) = SHELLN(I)                                           G88DRV
* 480 CONTINUE                                                          G88DRV
C                                                                       G88DRV
C  NPTR(I) -- pointer for the Ith shell into the gaussian parameters,   G88DRV
C             EXP, CS, CP, etc.:                                        G88DRV
C                                                                       G88DRV
*     DO 490 I = 1,NSHELL                                               G88DRV
*       II = II + 1                                                     G88DRV
*       ICORE(II) = SHELLA(I)                                           G88DRV
* 490 CONTINUE                                                          G88DRV
C                                                                       G88DRV
C  EXP(I) -- orbital exponents indexed by NPTR:                         G88DRV
C                                                                       G88DRV
*     DO 500 I = 1,NEXP                                                 G88DRV
*       II = II + 1                                                     G88DRV
*       CORE(II) = EXX(I)                                               G88DRV
* 500 CONTINUE                                                          G88DRV
C                                                                       G88DRV
C  CS,CP -- orbital coefficients:                                       G88DRV
C                                                                       G88DRV
*     DO 510 I = 1,NEXP                                                 G88DRV
*       II = II + 1                                                     G88DRV
*       CORE(II) = C1(I)                                                G88DRV
* 510 CONTINUE                                                          G88DRV
*     DO 520 I = 1,NEXP                                                 G88DRV
*       II = II + 1                                                     G88DRV
*       CORE(II) = C2(I)                                                G88DRV
* 520 CONTINUE                                                          G88DRV
C                                                                       G88DRV
C  Zero CD and CF arrays:                                               G88DRV
C                                                                       G88DRV
*     IHOLD = II                                                        G88DRV
*     DO 550 I = 1,2*NEXP                                               G88DRV
*       II = II + 1                                                     G88DRV
*       CORE(II) = ZERO                                                 G88DRV
* 550 CONTINUE                                                          G88DRV
C                                                                       G88DRV
C  Build CD and CF from C3 and C4:                                      G88DRV
C                                                                       G88DRV
*     DO 570 I = 1,NSHELL                                               G88DRV
*       IPTR = SHLADF(I)                                                G88DRV
*       IF(IPTR.GT.0) THEN                                              G88DRV
*         DO 560 J = 1,SHELLN(I)                                        G88DRV
*           LPTR = J + SHELLA(I) + IHOLD - 1                            G88DRV
*           MPTR = J + IPTR - 1                                         G88DRV
*           CORE(LPTR) = C3(MPTR)                                       G88DRV
*           CORE(LPTR+NEXP) = C4(MPTR)                                  G88DRV
* 560     CONTINUE                                                      G88DRV
*       END IF                                                          G88DRV
* 570 CONTINUE                                                          G88DRV
*     NFILE = 5                                                         G88DRV
*     CALL NBWRIT(CORE,II,NFILE)                                        G88DRV
*     RETURN                                                            G88DRV
C                                                                       G88DRV
* 900 WRITE(LFNPR,990)                                                  G88DRV
*     RETURN                                                            G88DRV
C                                                                       G88DRV
* 990 FORMAT(/1X,'The NBO program is not set up to handle complex ',    G88DRV
*    + 'wave functions')                                                G88DRV
*1000 FORMAT(/1X,'Analyzing the SCF density')                           G88DRV
*1010 FORMAT(/1X,'Analyzing the MP first order density')                G88DRV
*1020 FORMAT(/1X,'Analyzing the MP2 density')                           G88DRV
*1030 FORMAT(/1X,'Analyzing the MP3 density')                           G88DRV
*1040 FORMAT(/1X,'Analyzing the MP4 density')                           G88DRV
*1050 FORMAT(/1X,'Analyzing the CI one-particle density')               G88DRV
*1060 FORMAT(/1X,'Analyzing the CI density')                            G88DRV
*1070 FORMAT(/1X,'Analyzing the QCI/CC density')                        G88DRV
*1080 FORMAT(/1X,'Analyzing the density correct to second order')       G88DRV
*     END                                                               G88DRV
C***********************************************************************G88DRV
*     SUBROUTINE DELSCF(CORE,ICORE,NBOOPT)                              G88DRV
C***********************************************************************G88DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G88DRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             G88DRV
*     LOGICAL NEW,ERROR,SEQ                                             G88DRV
C                                                                       G88DRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G88DRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       G88DRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       G88DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G88DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G88DRV
*    +           LFNDAF,LFNDEF                                          G88DRV
C                                                                       G88DRV
C  If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO  G88DRV
C  DAF to the RWFs.                                                     G88DRV
C                                                                       G88DRV
*     IF(NBOOPT(1).EQ.2) THEN                                           G88DRV
*       NEW = .FALSE.                                                   G88DRV
*       CALL NBOPEN(NEW,ERROR)                                          G88DRV
*       IF(ERROR) THEN                                                  G88DRV
*         WRITE(LFNPR,900)                                              G88DRV
*         STOP                                                          G88DRV
*       END IF                                                          G88DRV
*       L2 = NDIM * (NDIM + 1)/2                                        G88DRV
*       IF(OPEN) THEN                                                   G88DRV
*         ALPHA = .TRUE.                                                G88DRV
*         BETA  = .FALSE.                                               G88DRV
*         CALL FENEWD(CORE)                                             G88DRV
*         CALL TWRITE(528,CORE,L2,1,L2,1,0)                             G88DRV
*         ALPHA = .FALSE.                                               G88DRV
*         BETA  = .TRUE.                                                G88DRV
*         CALL FENEWD(CORE)                                             G88DRV
*         CALL TWRITE(530,CORE,L2,1,L2,1,0)                             G88DRV
*       ELSE                                                            G88DRV
*         ALPHA = .FALSE.                                               G88DRV
*         BETA  = .FALSE.                                               G88DRV
*         CALL FENEWD(CORE)                                             G88DRV
*         CALL TWRITE(528,CORE,L2,1,L2,1,0)                             G88DRV
*       END IF                                                          G88DRV
*       SEQ = .FALSE.                                                   G88DRV
*       CALL NBCLOS(SEQ)                                                G88DRV
*     END IF                                                            G88DRV
C                                                                       G88DRV
C  If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF:      G88DRV
C                                                                       G88DRV
*     IF(NBOOPT(1).EQ.3) THEN                                           G88DRV
*       NEW = .FALSE.                                                   G88DRV
*       CALL NBOPEN(NEW,ERROR)                                          G88DRV
*       IF(ERROR) THEN                                                  G88DRV
*         WRITE(LFNPR,900)                                              G88DRV
*         STOP                                                          G88DRV
*       END IF                                                          G88DRV
*       CALL TREAD(501,CORE,32,1,32,1,0)                                G88DRV
*       CALL SVE0(CORE(32))                                             G88DRV
*       SEQ = .FALSE.                                                   G88DRV
*       CALL NBCLOS(SEQ)                                                G88DRV
*     END IF                                                            G88DRV
*     RETURN                                                            G88DRV
C                                                                       G88DRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ',        G88DRV
*    + 'subroutine DELSCF.')                                            G88DRV
*     END                                                               G88DRV
C***********************************************************************G88DRV
C                                                                       G88DRV
C           E N D    O F    G 8 8 N B O    R O U T I N E S              G88DRV
C                                                                       G88DRV
C***********************************************************************G88DRV
C***********************************************************************G86DRV
C                                                                       G86DRV
C                                                                       G86DRV
C                          G  8  6  N  B  O                             G86DRV
C                                                                       G86DRV
C                                                                       G86DRV
C                 GAUSSIAN 86 VERSION OF NBO PROGRAM                    G86DRV
C                                                                       G86DRV
C                                                                       G86DRV
C  DRIVER ROUTINES:                                                     G86DRV
C                                                                       G86DRV
C      SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR)                        G86DRV
C      SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                             G86DRV
C      SUBROUTINE DELSCF(CORE,ICORE,NBOOPT)                             G86DRV
C                                                                       G86DRV
C***********************************************************************G86DRV
*     SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR)                         G86DRV
C***********************************************************************G86DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G86DRV
C                                                                       G86DRV
*     PARAMETER (MAXFIL = 40)                                           G86DRV
C                                                                       G86DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G86DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G86DRV
*    +           LFNDAF,LFNDEF                                          G86DRV
*     COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)                          G86DRV
*     CHARACTER*80 FILENM                                               G86DRV
C                                                                       G86DRV
*     DIMENSION CORE(1),IOP(50)                                         G86DRV
*     DIMENSION NBOOPT(10)                                              G86DRV
C                                                                       G86DRV
*     LFNIN = 5                                                         G86DRV
*     LFNPR = 6                                                         G86DRV
C                                                                       G86DRV
*     DATA TENTH/0.1D0/                                                 G86DRV
C                                                                       G86DRV
C  Set NBO options.                                                     G86DRV
C                                                                       G86DRV
*     DO 10 I = 1,9                                                     G86DRV
*       NBOOPT(I) = IOP(I+39)                                           G86DRV
*  10 CONTINUE                                                          G86DRV
*     NBOOPT(10) = 86                                                   G86DRV
C                                                                       G86DRV
C  --- NBO analysis ---                                                 G86DRV
C                                                                       G86DRV
*     ICONTR = 0                                                        G86DRV
*     IF(ABS(NBOOPT(1)).LT.2) THEN                                      G86DRV
*       CALL CHARPN(4HNBO )                                             G86DRV
*       CALL NBO(CORE,MEMORY,NBOOPT)                                    G86DRV
C                                                                       G86DRV
C  Store the name of the NBO direct access file on the RWFiles          G86DRV
C                                                                       G86DRV
*       DO 20 I = 1,80                                                  G86DRV
*         CORE(I) = ICHAR(FILENM(I:I))                                  G86DRV
*  20   CONTINUE                                                        G86DRV
*       CORE(81) = LFNDAF                                               G86DRV
*       CALL TWRITE(636,CORE,81,1,81,1,0)                               G86DRV
C                                                                       G86DRV
C  --- NBO energetic analysis ---                                       G86DRV
C                                                                       G86DRV
*     ELSE IF(NBOOPT(1).EQ.2) THEN                                      G86DRV
C                                                                       G86DRV
C  Retrieve the name of the NBO direct access file from the RWFiles     G86DRV
C                                                                       G86DRV
*       CALL TREAD(636,CORE,81,1,81,1,0)                                G86DRV
*       DO 30 I = 1,80                                                  G86DRV
*         FILENM(I:I) = CHAR(INT(CORE(I) + TENTH))                      G86DRV
*  30   CONTINUE                                                        G86DRV
*       LFNDAF = INT(ABS(CORE(81)) + TENTH)                             G86DRV
*       CALL CHARPN(4HDELE)                                             G86DRV
*       CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE)                           G86DRV
*       IF(IDONE.NE.0) ICONTR = 1                                       G86DRV
*       IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT)                    G86DRV
C                                                                       G86DRV
*     ELSE IF(NBOOPT(1).EQ.3) THEN                                      G86DRV
*       CALL TREAD(636,CORE,81,1,81,1,0)                                G86DRV
*       DO 40 I = 1,80                                                  G86DRV
*         FILENM(I:I) = CHAR(INT(CORE(I) + TENTH))                      G86DRV
*  40   CONTINUE                                                        G86DRV
*       LFNDAF = INT(ABS(CORE(81)) + TENTH)                             G86DRV
*       CALL CHARPN(4HEDEL)                                             G86DRV
*       CALL DELSCF(CORE,CORE,NBOOPT)                                   G86DRV
*       CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE)                           G86DRV
*     END IF                                                            G86DRV
C                                                                       G86DRV
*     RETURN                                                            G86DRV
*     END                                                               G86DRV
C***********************************************************************G86DRV
*     SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                              G86DRV
C***********************************************************************G86DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G86DRV
C-----------------------------------------------------------------------G86DRV
C                                                                       G86DRV
C  Routine FEAOIN accesses the following records of the RWFs:           G86DRV
C                                                                       G86DRV
C        203  ---   CI density matrix (alpha)                           G86DRV
C        204  ---   CI density matrix (beta)                            G86DRV
C        501  ---   Total energy                                        G86DRV
C        502  ---   Job title                                           G86DRV
C        506  ---   Basis set information                               G86DRV
C        512  ---   Effective core potential information                G86DRV
C        514  ---   AO overlap matrix                                   G86DRV
C        518  ---   AO dipole integrals                                 G86DRV
C        524  ---   MO coefficients (alpha)                             G86DRV
C        526  ---   MO coefficients (beta)                              G86DRV
C        528  ---   SCF density matrix (alpha)                          G86DRV
C        530  ---   SCF density matrix (beta)                           G86DRV
C        536  ---   AO Fock matrix (alpha)                              G86DRV
C        538  ---   AO Fock matrix (beta)                               G86DRV
C                                                                       G86DRV
C ----------------------------------------------------------------------G86DRV
C                                                                       G86DRV
C  NBO Common blocks                                                    G86DRV
C                                                                       G86DRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               G86DRV
C                                                                       G86DRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G86DRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       G86DRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       G86DRV
*     COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,        G86DRV
*    + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    G86DRV
*    + JCORE,JPRINT(60)                                                 G86DRV
*     COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)                             G86DRV
*     COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G86DRV
*    +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)                     G86DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G86DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G86DRV
*    +           LFNDAF,LFNDEF                                          G86DRV
C                                                                       G86DRV
C  GAUSSIAN 86 Common blocks                                            G86DRV
C                                                                       G86DRV
*     COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(401),        G86DRV
*    *           ATMCHG(400),C(1200)                                    G86DRV
*     COMMON/LP2/NLP(1600),CLP(1600),ZLP(1600),KFIRST(400,5),           G86DRV
*    *  KLAST(400,5),LMAX(400),LPSKIP(400),NFroz(400)                   G86DRV
*     COMMON/B/EXX(1200),C1(1200),C2(1200),C3(1200),X(400),Y(400),      G86DRV
*    *     Z(400),JAN(400),SHELLA(400),SHELLN(400),SHELLT(400),         G86DRV
*    *     SHELLC(400),AOS(400),AON(400),NSHELL,MAXTYP                  G86DRV
*     INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON                G86DRV
*     DIMENSION C4(400),SHLADF(400)                                     G86DRV
*     EQUIVALENCE(C4(1),C3(401)),(SHLADF(1),C3(801))                    G86DRV
C                                                                       G86DRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             G86DRV
*     DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2)                         G86DRV
C                                                                       G86DRV
C  Obtain the following information:                                    G86DRV
C                                                                       G86DRV
C    ROHF        =.TRUE. If RHF open shell wavefunction                 G86DRV
C                =.FALSE. otherwise                                     G86DRV
C                                                                       G86DRV
C    UHF         =.TRUE. If UHF wavefunction                            G86DRV
C                =.FALSE. otherwise                                     G86DRV
C                                                                       G86DRV
C    AUHF        =.TRUE. If spin-annihilated UHF wavefunction           G86DRV
C                =.FALSE. otherwise                                     G86DRV
C                                                                       G86DRV
C    CI          =.TRUE. If CI wavefunction                             G86DRV
C                =.FALSE. otherwise                                     G86DRV
C                                                                       G86DRV
C    OPEN        =.TRUE. If open shell wavefunction                     G86DRV
C                =.FALSE. otherwise                                     G86DRV
C                                                                       G86DRV
C    COMPLX      =.TRUE. If complex wavefunction                        G86DRV
C                =.FALSE. otherwise                                     G86DRV
C                (Note: The program is not capable of handling this.)   G86DRV
C                                                                       G86DRV
C    NATOMS      Number of atomic centers                               G86DRV
C                                                                       G86DRV
C    NDIM        Dimension of matrices (overlap and density)            G86DRV
C                                                                       G86DRV
C    NBAS        Number of basis functions (.le.NDIM)                   G86DRV
C                                                                       G86DRV
C    IPSEUD      Set to one if pseudopotentials are used.               G86DRV
C                                                                       G86DRV
C    IWCUBF      This pertains only basis sets with F functions.        G86DRV
C                                                                       G86DRV
C                If cartesian F functions are input, set IWCUBF to:     G86DRV
C                    0,  if these are to be transformed to the          G86DRV
C                        standard set of pure F functions               G86DRV
C                    1,  if these are to be transformed to the          G86DRV
C                        cubic set of pure F functions                  G86DRV
C                                                                       G86DRV
C                If pure F functions are input, set to IWCUBF to:       G86DRV
C                    0,  if these are standard F functions              G86DRV
C                    1,  if these are cubic F functions                 G86DRV
C                                                                       G86DRV
C    IATNO(I),I=1,NATOMS                                                G86DRV
C                List of atomic numbers                                 G86DRV
C                                                                       G86DRV
C    LCTR(I),I=1,NBAS                                                   G86DRV
C                List of atomic centers of the basis functions          G86DRV
C                (LCTR(3)=2 if basis function 3 is on atom 2)           G86DRV
C                                                                       G86DRV
C    LANG(I),I=1,NBAS                                                   G86DRV
C                List of angular symmetry information for the AO basis  G86DRV
C                                                                       G86DRV
*     DATA LISTS/   1/                                                  G86DRV
*     DATA LISTP/ 101, 102, 103/                                        G86DRV
*     DATA LISTD/ 255, 252, 253, 254, 251,   0,                         G86DRV
*    +            201, 204, 206, 202, 203, 205/                         G86DRV
*     DATA LISTF/ 351, 352, 353, 354, 355, 356, 357,   0,   0,   0,     G86DRV
*    +            301, 307, 310, 304, 302, 303, 306, 309, 308, 305/     G86DRV
*     DATA ZERO/0.0D0/                                                  G86DRV
*     DATA TOANG/0.529177249/                                           G86DRV
C                                                                       G86DRV
C  Store job title on NBODAF:                                           G86DRV
C                                                                       G86DRV
*     LEN = INTOWP(400+100)                                             G86DRV
*     CALL TREAD(502,ICORE,LEN,1,LEN,1,0)                               G86DRV
*     NFILE = 2                                                         G86DRV
*     CALL NBWRIT(ICORE(401),10,NFILE)                                  G86DRV
C                                                                       G86DRV
C  Get the number of atoms from NAT and store the atomic numbers in     G86DRV
C  IATNO and nuclear charges in IZNUC.  (NOTE: atomic numbers and       G86DRV
C  nuclear charges may not be equivalent if effective core potentials   G86DRV
C  (ECP) are used.)                                                     G86DRV
C                                                                       G86DRV
*     LEN = 0                                                           G86DRV
*     IEXIST = ITQRY(512)                                               G86DRV
*     IF(IEXIST.GT.0) THEN                                              G86DRV
*       LEN = 8 * 400 + 17 * INTOWP(400)                                G86DRV
*       CALL TREAD(512,NLP,LEN,1,LEN,1,0)                               G86DRV
*     END IF                                                            G86DRV
*     NATOMS = NATOM                                                    G86DRV
*     DO 20 I = 1,NATOMS                                                G86DRV
*       IATNO(I) = IAN(I)                                               G86DRV
*       IF(IEXIST.GT.0) THEN                                            G86DRV
*         IZNUC(I) = IATNO(I) - NFROZ(I)                                G86DRV
*         IF(NFROZ(I).NE.0) IPSEUD = 1                                  G86DRV
*       ELSE                                                            G86DRV
*         IZNUC(I) = IATNO(I)                                           G86DRV
*       END IF                                                          G86DRV
*  20 CONTINUE                                                          G86DRV
C                                                                       G86DRV
C  Restore the basis set to COMMON/B/:                                  G86DRV
C                                                                       G86DRV
*     LEN = 6000 + INTOWP(2802)                                         G86DRV
*     CALL TREAD(506,EXX,LEN,1,LEN,1,0)                                 G86DRV
C                                                                       G86DRV
C  The Gaussian programs do not use cubic f basis functions.            G86DRV
C  Determine which set of d and f functions are being used,             G86DRV
C  Cartesian or pure):                                                  G86DRV
C                                                                       G86DRV
*     IWCUBF = 0                                                        G86DRV
*     CALL ILSW(2,2,I5D6D)                                              G86DRV
*     CALL ILSW(2,16,I7F10F)                                            G86DRV
C                                                                       G86DRV
C  Construct the AO information lists: LCTR and LANG                    G86DRV
C                                                                       G86DRV
*     IBAS = 0                                                          G86DRV
*     DO 90 ISHELL = 1,400                                              G86DRV
*       IF(IBAS.EQ.NBASIS) GOTO 100                                     G86DRV
*       NCTR   = JAN(ISHELL)                                            G86DRV
*       MAXL   = SHELLT(ISHELL)                                         G86DRV
*       ICNSTR = SHELLC(ISHELL)                                         G86DRV
C                                                                       G86DRV
C  Is an s orbital in the shell?                                        G86DRV
C                                                                       G86DRV
*       KS = 0                                                          G86DRV
*       IF(MAXL.EQ.0) KS = 1                                            G86DRV
*       IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1                            G86DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1                            G86DRV
*       IF(KS.EQ.0) GOTO 30                                             G86DRV
C                                                                       G86DRV
C  s orbital:                                                           G86DRV
C                                                                       G86DRV
*         IBAS = IBAS + 1                                               G86DRV
*         LCTR(IBAS) = NCTR                                             G86DRV
*         LANG(IBAS) = LISTS                                            G86DRV
C                                                                       G86DRV
C  Is a set of p orbitals in the shell?                                 G86DRV
C                                                                       G86DRV
*  30   CONTINUE                                                        G86DRV
*       KP = 0                                                          G86DRV
*       IF(MAXL.EQ.0) GOTO 90                                           G86DRV
*       IF(MAXL.EQ.1) KP = 1                                            G86DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1                            G86DRV
*       IF(KP.EQ.0) GOTO 50                                             G86DRV
C                                                                       G86DRV
C  p orbitals:                                                          G86DRV
C                                                                       G86DRV
*       DO 40 I = 1,3                                                   G86DRV
*         IBAS = IBAS + 1                                               G86DRV
*         LCTR(IBAS) = NCTR                                             G86DRV
*         LANG(IBAS) = LISTP(I)                                         G86DRV
*  40   CONTINUE                                                        G86DRV
C                                                                       G86DRV
C  d orbitals:                                                          G86DRV
C                                                                       G86DRV
*  50   IF(MAXL.NE.2) GOTO 70                                           G86DRV
*         IMAX = I5D6D + 5                                              G86DRV
*         KD = I5D6D + 1                                                G86DRV
*         DO 60 I = 1,IMAX                                              G86DRV
*           IBAS = IBAS + 1                                             G86DRV
*           LCTR(IBAS) = NCTR                                           G86DRV
*           LANG(IBAS) = LISTD(I,KD)                                    G86DRV
*  60     CONTINUE                                                      G86DRV
*         GO TO 90                                                      G86DRV
C                                                                       G86DRV
C  f orbitals:                                                          G86DRV
C                                                                       G86DRV
*  70   IF(MAXL.NE.3) GOTO 90                                           G86DRV
*         IMAX = 7                                                      G86DRV
*         IF(I7F10F.EQ.1) IMAX = 10                                     G86DRV
*         KF = I7F10F + 1                                               G86DRV
*         DO 80 I = 1,IMAX                                              G86DRV
*           IBAS = IBAS + 1                                             G86DRV
*           LCTR(IBAS) = NCTR                                           G86DRV
*           LANG(IBAS) = LISTF(I,KF)                                    G86DRV
*  80     CONTINUE                                                      G86DRV
*  90 CONTINUE                                                          G86DRV
* 100 CONTINUE                                                          G86DRV
*     NDIM = NBASIS                                                     G86DRV
*     NBAS = NBASIS                                                     G86DRV
C                                                                       G86DRV
C  Determine the type of wave function the density matrix is from:      G86DRV
C                                                                       G86DRV
*     IF(MULTIP.GT.1) OPEN = .TRUE.                                     G86DRV
*     IF(NBOOPT(2).NE.0) THEN                                           G86DRV
*       CI = .TRUE.                                                     G86DRV
*     ELSE                                                              G86DRV
*       CALL ILSW(2,1,ISCF)                                             G86DRV
*       CALL ILSW(2,22,IROHF)                                           G86DRV
*       IF(ISCF.EQ.1)  UHF    = .TRUE.                                  G86DRV
*       IF(UHF)        OPEN   = .TRUE.                                  G86DRV
*       IF(IROHF.EQ.1) ROHF   = .TRUE.                                  G86DRV
*       IF(IROHF.EQ.2) ROHF   = .TRUE.                                  G86DRV
*       IF(IROHF.EQ.3) MCSCF  = .TRUE.                                  G86DRV
*       IF(ISCF.GT.1)  COMPLX = .TRUE.                                  G86DRV
*       IF(COMPLX) GOTO 900                                             G86DRV
*     END IF                                                            G86DRV
*     IF(NBOOPT(5).EQ.1) AUHF = .TRUE.                                  G86DRV
*     ORTHO = .FALSE.                                                   G86DRV
C                                                                       G86DRV
C  No Fock matrices for ROHF, MCSCF, or CI wavefunctions:               G86DRV
C                                                                       G86DRV
*     IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0                                G86DRV
C                                                                       G86DRV
C  Expectation values of the Fock operator are in atomic units:         G86DRV
C                                                                       G86DRV
*     MUNIT = 0                                                         G86DRV
C                                                                       G86DRV
C  Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:         G86DRV
C                                                                       G86DRV
*     ICORE(1)  = NATOMS                                                G86DRV
*     ICORE(2)  = NDIM                                                  G86DRV
*     ICORE(3)  = NBAS                                                  G86DRV
*     ICORE(4)  = MUNIT                                                 G86DRV
*     ICORE(5)  = 0                                                     G86DRV
*     IF(ROHF)  ICORE(5)  = 1                                           G86DRV
*     ICORE(6)  = 0                                                     G86DRV
*     IF(UHF)   ICORE(6)  = 1                                           G86DRV
*     ICORE(7)  = 0                                                     G86DRV
*     IF(CI)    ICORE(7)  = 1                                           G86DRV
*     ICORE(8)  = 0                                                     G86DRV
*     IF(OPEN)  ICORE(8)  = 1                                           G86DRV
*     ICORE(9)  = 0                                                     G86DRV
*     IF(MCSCF) ICORE(9)  = 1                                           G86DRV
*     ICORE(10) = 0                                                     G86DRV
*     IF(AUHF)  ICORE(10)  = 1                                          G86DRV
*     ICORE(11) = 0                                                     G86DRV
*     IF(ORTHO) ICORE(11) = 1                                           G86DRV
*     ICORE(12) = 1                                                     G86DRV
*     NFILE = 3                                                         G86DRV
*     CALL NBWRIT(ICORE,12,NFILE)                                       G86DRV
C                                                                       G86DRV
C  Store IATNO, IZNUC, LCTR, and LANG on NBO DAF:                       G86DRV
C                                                                       G86DRV
*     II = 0                                                            G86DRV
*     DO 120 I = 1,NATOMS                                               G86DRV
*       II = II + 1                                                     G86DRV
*       ICORE(II) = IATNO(I)                                            G86DRV
* 120 CONTINUE                                                          G86DRV
*     DO 130 I = 1,NATOMS                                               G86DRV
*       II = II + 1                                                     G86DRV
*       ICORE(II) = IZNUC(I)                                            G86DRV
* 130 CONTINUE                                                          G86DRV
*     DO 140 I = 1,NBAS                                                 G86DRV
*       II = II + 1                                                     G86DRV
*       ICORE(II) = LCTR(I)                                             G86DRV
* 140 CONTINUE                                                          G86DRV
*     DO 150 I = 1,NBAS                                                 G86DRV
*       II = II + 1                                                     G86DRV
*       ICORE(II) = LANG(I)                                             G86DRV
* 150 CONTINUE                                                          G86DRV
*     NFILE = 4                                                         G86DRV
*     CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE)                          G86DRV
C                                                                       G86DRV
C  Fetch the total energy from the RWF and store it on the NBODAF:      G86DRV
C                                                                       G86DRV
*     CALL TREAD(501,CORE,32,1,32,1,0)                                  G86DRV
*     CORE(1) = CORE(32)                                                G86DRV
*     CORE(2) = CORE(32)                                                G86DRV
*     NFILE = 8                                                         G86DRV
*     CALL NBWRIT(CORE,2,NFILE)                                         G86DRV
C                                                                       G86DRV
C  Store the atomic coordinates on the NBO DAF: (Note that these        G86DRV
C  coordinates are used in the calculation of dipole moments.)          G86DRV
C                                                                       G86DRV
*     DO 160 I = 1,3*NATOMS                                             G86DRV
*       CORE(I) = C(I) * TOANG                                          G86DRV
* 160 CONTINUE                                                          G86DRV
*     NFILE = 9                                                         G86DRV
*     CALL NBWRIT(CORE,3*NATOMS,NFILE)                                  G86DRV
C                                                                       G86DRV
C  Store the overlap matrix on the NBODAF:                              G86DRV
C                                                                       G86DRV
*     L2 = NDIM*(NDIM+1)/2                                              G86DRV
*     CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1)                        G86DRV
*     CALL PACK(CORE,NDIM,NBAS,L2)                                      G86DRV
*     NFILE = 10                                                        G86DRV
*     CALL NBWRIT(CORE,L2,NFILE)                                        G86DRV
C                                                                       G86DRV
C  Store the density matrices on the NBODAF:                            G86DRV
C                                                                       G86DRV
*     L2  = NDIM*(NDIM+1)/2                                             G86DRV
*     IF(CI) THEN                                                       G86DRV
*       CALL TREAD(203,CORE,NDIM,NDIM,NBAS,NBAS,1)                      G86DRV
*       CALL PACK(CORE,NDIM,NBAS,L2)                                    G86DRV
*       NFILE = 20                                                      G86DRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      G86DRV
*       IF(OPEN) THEN                                                   G86DRV
*         CALL TREAD(204,CORE,NDIM,NDIM,NBAS,NBAS,1)                    G86DRV
*         CALL PACK(CORE,NDIM,NBAS,L2)                                  G86DRV
*         NFILE = 21                                                    G86DRV
*         CALL NBWRIT(CORE,L2,NFILE)                                    G86DRV
*       END IF                                                          G86DRV
*     ELSE                                                              G86DRV
*       CALL TREAD(528,CORE,NDIM,NDIM,NBAS,NBAS,1)                      G86DRV
*       CALL PACK(CORE,NDIM,NBAS,L2)                                    G86DRV
*       NFILE = 20                                                      G86DRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      G86DRV
*       IF(OPEN) THEN                                                   G86DRV
*         CALL TREAD(530,CORE,NDIM,NDIM,NBAS,NBAS,1)                    G86DRV
*         CALL PACK(CORE,NDIM,NBAS,L2)                                  G86DRV
*         NFILE = 21                                                    G86DRV
*         CALL NBWRIT(CORE,L2,NFILE)                                    G86DRV
*       END IF                                                          G86DRV
*     END IF                                                            G86DRV
C                                                                       G86DRV
C  Store the Fock matrices on the NBODAF:                               G86DRV
C                                                                       G86DRV
*     IF(IWFOCK.NE.0) THEN                                              G86DRV
*       IEXIST = ITQRY(536)                                             G86DRV
*       IF(IEXIST.GT.0) THEN                                            G86DRV
*         L2 = NDIM*(NDIM+1)/2                                          G86DRV
*         CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1)                    G86DRV
*         CALL PACK(CORE,NDIM,NBAS,L2)                                  G86DRV
*         NFILE = 30                                                    G86DRV
*         CALL NBWRIT(CORE,L2,NFILE)                                    G86DRV
*       END IF                                                          G86DRV
C                                                                       G86DRV
*       IF(OPEN) THEN                                                   G86DRV
*         IEXIST = ITQRY(538)                                           G86DRV
*         IF(IEXIST.GT.0) THEN                                          G86DRV
*           L2 = NDIM*(NDIM+1)/2                                        G86DRV
*           CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1)                  G86DRV
*           CALL PACK(CORE,NDIM,NBAS,L2)                                G86DRV
*           NFILE = 31                                                  G86DRV
*           CALL NBWRIT(CORE,L2,NFILE)                                  G86DRV
*         END IF                                                        G86DRV
*       END IF                                                          G86DRV
*     END IF                                                            G86DRV
C                                                                       G86DRV
C  Store the AO to MO transformation matrices on the NBODAF:            G86DRV
C                                                                       G86DRV
*     IEXIST = ITQRY(524)                                               G86DRV
*     IF(IEXIST.GT.0) THEN                                              G86DRV
*       L3 = NDIM*NDIM                                                  G86DRV
*       CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0)                      G86DRV
*       NFILE = 40                                                      G86DRV
*       CALL NBWRIT(CORE,L3,NFILE)                                      G86DRV
*     END IF                                                            G86DRV
C                                                                       G86DRV
*     IF(OPEN) THEN                                                     G86DRV
*       IEXIST = ITQRY(526)                                             G86DRV
*       IF(IEXIST.GT.0) THEN                                            G86DRV
*         L3 = NDIM*NDIM                                                G86DRV
*         CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0)                    G86DRV
*         NFILE = 41                                                    G86DRV
*         CALL NBWRIT(CORE,L3,NFILE)                                    G86DRV
*       END IF                                                          G86DRV
*     END IF                                                            G86DRV
C                                                                       G86DRV
C  Store the x,y,z dipole integrals on the NBODAF:                      G86DRV
C                                                                       G86DRV
*     IEXIST = ITQRY(518)                                               G86DRV
*     IF(IEXIST.GT.0) THEN                                              G86DRV
*       L2 = NDIM*(NDIM+1)/2                                            G86DRV
*       LEN = 3 * L2                                                    G86DRV
*       CALL TREAD(518,CORE,LEN,1,LEN,1,0)                              G86DRV
*       DO 170 I = 1,LEN                                                G86DRV
*         CORE(I) = CORE(I) * TOANG                                     G86DRV
* 170   CONTINUE                                                        G86DRV
*       NFILE = 50                                                      G86DRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      G86DRV
*       NFILE = 51                                                      G86DRV
*       CALL NBWRIT(CORE(L2+1),L2,NFILE)                                G86DRV
*       NFILE = 52                                                      G86DRV
*       CALL NBWRIT(CORE(2*L2+1),L2,NFILE)                              G86DRV
*     END IF                                                            G86DRV
C                                                                       G86DRV
C  Store the AO basis set info on the NBO DAF:  (Note that two integers G86DRV
C  and three integer arrays are stored first.  Also remember that ICORE G86DRV
C  and CORE occupy the same memory.)                                    G86DRV
C                                                                       G86DRV
*     NEXP = 0                                                          G86DRV
*     DO 180 I = 1,1200                                                 G86DRV
*       IF(EXX(I).EQ.ZERO) GOTO 180                                     G86DRV
*       NEXP = I                                                        G86DRV
* 180 CONTINUE                                                          G86DRV
*     DO 190 I = 1,2+3*NSHELL+5*NEXP                                    G86DRV
*       CORE(I) = ZERO                                                  G86DRV
* 190 CONTINUE                                                          G86DRV
*     ICORE(1) = NSHELL                                                 G86DRV
*     ICORE(2) = NEXP                                                   G86DRV
C                                                                       G86DRV
C  Determine if Cartesian or pure D and F functions are used:           G86DRV
C                                                                       G86DRV
*     CALL ILSW(2,2,I5D6D)                                              G86DRV
*     CALL ILSW(2,16,I7F10F)                                            G86DRV
C                                                                       G86DRV
C  NCOMP(I) -- the number of components in the Ith shell:               G86DRV
C                                                                       G86DRV
*     II = 2                                                            G86DRV
*     DO 420 I = 1,NSHELL                                               G86DRV
*       II = II + 1                                                     G86DRV
*       ICORE(II) = 0                                                   G86DRV
*       MAXL = SHELLT(I)                                                G86DRV
*       ICNSTR = SHELLC(I)                                              G86DRV
C                                                                       G86DRV
C  Determine if an S orbital is in the shell:                           G86DRV
C                                                                       G86DRV
*       KS = 0                                                          G86DRV
*       IF(MAXL.EQ.0) KS = 1                                            G86DRV
*       IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1                            G86DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1                            G86DRV
*       IF(KS.EQ.0) GO TO 310                                           G86DRV
C                                                                       G86DRV
C  S orbital:                                                           G86DRV
C                                                                       G86DRV
*       ICORE(II) = ICORE(II) + 1                                       G86DRV
C                                                                       G86DRV
C  Determine if a set of P orbitals is in the shell:                    G86DRV
C                                                                       G86DRV
* 310   CONTINUE                                                        G86DRV
*       KP = 0                                                          G86DRV
*       IF(MAXL.EQ.0) GO TO 400                                         G86DRV
*       IF(MAXL.EQ.1) KP = 1                                            G86DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1                            G86DRV
*       IF(KP.EQ.0) GO TO 340                                           G86DRV
C                                                                       G86DRV
C  P orbital:                                                           G86DRV
C                                                                       G86DRV
*       ICORE(II) = ICORE(II) + 3                                       G86DRV
C                                                                       G86DRV
C  If MAXL is less than 2 then there are no D or F orbitals:            G86DRV
C  If MAXL is greater than 2 then there must be F orbitals:             G86DRV
C                                                                       G86DRV
* 340   IF(MAXL.LT.2) GO TO 400                                         G86DRV
*       IF(MAXL.GT.2) GO TO 370                                         G86DRV
C                                                                       G86DRV
C  D orbital:                                                           G86DRV
C                                                                       G86DRV
*       IMAX = I5D6D + 5                                                G86DRV
*       ICORE(II) = ICORE(II) + IMAX                                    G86DRV
C                                                                       G86DRV
C  If MAXL is less than 3 then there are no F orbitals:                 G86DRV
C                                                                       G86DRV
* 370   IF(MAXL.LT.3) GO TO 400                                         G86DRV
C                                                                       G86DRV
C  F orbital:                                                           G86DRV
C                                                                       G86DRV
*       IMAX=7                                                          G86DRV
*       IF(I7F10F.EQ.1) IMAX=10                                         G86DRV
*       ICORE(II) = ICORE(II) + IMAX                                    G86DRV
C                                                                       G86DRV
C  Skip here when no more orbitals are found:                           G86DRV
C                                                                       G86DRV
* 400   CONTINUE                                                        G86DRV
* 420 CONTINUE                                                          G86DRV
C                                                                       G86DRV
C  NPRIM(I) -- the number of gaussian primitives in the Ith shell:      G86DRV
C                                                                       G86DRV
*     DO 480 I = 1,NSHELL                                               G86DRV
*       II = II + 1                                                     G86DRV
*       ICORE(II) = SHELLN(I)                                           G86DRV
* 480 CONTINUE                                                          G86DRV
C                                                                       G86DRV
C  NPTR(I) -- pointer for the Ith shell into the gaussian parameters,   G86DRV
C             EXP, CS, CP, etc.:                                        G86DRV
C                                                                       G86DRV
*     DO 490 I = 1,NSHELL                                               G86DRV
*       II = II + 1                                                     G86DRV
*       ICORE(II) = SHELLA(I)                                           G86DRV
* 490 CONTINUE                                                          G86DRV
C                                                                       G86DRV
C  EXP(I) -- orbital exponents indexed by NPTR:                         G86DRV
C                                                                       G86DRV
*     DO 500 I = 1,NEXP                                                 G86DRV
*       II = II + 1                                                     G86DRV
*       CORE(II) = EXX(I)                                               G86DRV
* 500 CONTINUE                                                          G86DRV
C                                                                       G86DRV
C  CS,CP -- orbital coefficients:                                       G86DRV
C                                                                       G86DRV
*     DO 510 I = 1,NEXP                                                 G86DRV
*       II = II + 1                                                     G86DRV
*       CORE(II) = C1(I)                                                G86DRV
* 510 CONTINUE                                                          G86DRV
*     DO 520 I = 1,NEXP                                                 G86DRV
*       II = II + 1                                                     G86DRV
*       CORE(II) = C2(I)                                                G86DRV
* 520 CONTINUE                                                          G86DRV
C                                                                       G86DRV
C  Zero CD and CF arrays:                                               G86DRV
C                                                                       G86DRV
*     IHOLD = II                                                        G86DRV
*     DO 550 I = 1,2*NEXP                                               G86DRV
*       II = II + 1                                                     G86DRV
*       CORE(II) = ZERO                                                 G86DRV
* 550 CONTINUE                                                          G86DRV
C                                                                       G86DRV
C  Build CD and CF from C3 and C4:                                      G86DRV
C                                                                       G86DRV
*     DO 570 I = 1,NSHELL                                               G86DRV
*       IPTR = SHLADF(I)                                                G86DRV
*       IF(IPTR.GT.0) THEN                                              G86DRV
*         DO 560 J = 1,SHELLN(I)                                        G86DRV
*           LPTR = J + SHELLA(I) + IHOLD - 1                            G86DRV
*           MPTR = J + IPTR - 1                                         G86DRV
*           CORE(LPTR) = C3(MPTR)                                       G86DRV
*           CORE(LPTR+NEXP) = C4(MPTR)                                  G86DRV
* 560     CONTINUE                                                      G86DRV
*       END IF                                                          G86DRV
* 570 CONTINUE                                                          G86DRV
*     NFILE = 5                                                         G86DRV
*     CALL NBWRIT(CORE,II,NFILE)                                        G86DRV
*     RETURN                                                            G86DRV
C                                                                       G86DRV
* 900 WRITE(LFNPR,1000)                                                 G86DRV
*     RETURN                                                            G86DRV
C                                                                       G86DRV
*1000 FORMAT(/1X,'The NBO program is not set up to handle complex ',    G86DRV
*    + 'wave functions')                                                G86DRV
*     END                                                               G86DRV
C***********************************************************************G86DRV
*     SUBROUTINE DELSCF(CORE,ICORE,NBOOPT)                              G86DRV
C***********************************************************************G86DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G86DRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             G86DRV
*     LOGICAL NEW,ERROR,SEQ                                             G86DRV
C                                                                       G86DRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G86DRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       G86DRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       G86DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G86DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G86DRV
*    +           LFNDAF,LFNDEF                                          G86DRV
C                                                                       G86DRV
C  If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO  G86DRV
C  DAF to the RWFs.                                                     G86DRV
C                                                                       G86DRV
*     IF(NBOOPT(1).EQ.2) THEN                                           G86DRV
*       NEW = .FALSE.                                                   G86DRV
*       CALL NBOPEN(NEW,ERROR)                                          G86DRV
*       IF(ERROR) THEN                                                  G86DRV
*         WRITE(LFNPR,900)                                              G86DRV
*         STOP                                                          G86DRV
*       END IF                                                          G86DRV
*       L2 = NDIM * (NDIM + 1)/2                                        G86DRV
*       IF(OPEN) THEN                                                   G86DRV
*         ALPHA = .TRUE.                                                G86DRV
*         BETA  = .FALSE.                                               G86DRV
*         CALL FENEWD(CORE)                                             G86DRV
*         CALL TWRITE(528,CORE,L2,1,L2,1,0)                             G86DRV
*         ALPHA = .FALSE.                                               G86DRV
*         BETA  = .TRUE.                                                G86DRV
*         CALL FENEWD(CORE)                                             G86DRV
*         CALL TWRITE(530,CORE,L2,1,L2,1,0)                             G86DRV
*       ELSE                                                            G86DRV
*         ALPHA = .FALSE.                                               G86DRV
*         BETA  = .FALSE.                                               G86DRV
*         CALL FENEWD(CORE)                                             G86DRV
*         CALL TWRITE(528,CORE,L2,1,L2,1,0)                             G86DRV
*       END IF                                                          G86DRV
*       SEQ = .FALSE.                                                   G86DRV
*       CALL NBCLOS(SEQ)                                                G86DRV
*     END IF                                                            G86DRV
C                                                                       G86DRV
C  If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF:      G86DRV
C                                                                       G86DRV
*     IF(NBOOPT(1).EQ.3) THEN                                           G86DRV
*       NEW = .FALSE.                                                   G86DRV
*       CALL NBOPEN(NEW,ERROR)                                          G86DRV
*       IF(ERROR) THEN                                                  G86DRV
*         WRITE(LFNPR,900)                                              G86DRV
*         STOP                                                          G86DRV
*       END IF                                                          G86DRV
*       CALL TREAD(501,CORE,32,1,32,1,0)                                G86DRV
*       CALL SVE0(CORE(32))                                             G86DRV
*       SEQ = .FALSE.                                                   G86DRV
*       CALL NBCLOS(SEQ)                                                G86DRV
*     END IF                                                            G86DRV
*     RETURN                                                            G86DRV
C                                                                       G86DRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ',        G86DRV
*    + 'subroutine DELSCF.')                                            G86DRV
*     END                                                               G86DRV
C***********************************************************************G86DRV
C                                                                       G86DRV
C           E N D    O F    G 8 6 N B O    R O U T I N E S              G86DRV
C                                                                       G86DRV
C***********************************************************************G86DRV
C***********************************************************************G82DRV
C                                                                       G82DRV
C                                                                       G82DRV
C                          G  8  2  N  B  O                             G82DRV
C                                                                       G82DRV
C                                                                       G82DRV
C                 GAUSSIAN 82 VERSION OF NBO PROGRAM                    G82DRV
C                                                                       G82DRV
C                                                                       G82DRV
C  DRIVER ROUTINES:                                                     G82DRV
C                                                                       G82DRV
C      SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR)                        G82DRV
C      SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                             G82DRV
C      SUBROUTINE DELSCF(CORE,ICORE,NBOOPT)                             G82DRV
C                                                                       G82DRV
C***********************************************************************G82DRV
*     SUBROUTINE RUNNBO(CORE,MEMORY,IOP,ICONTR)                         G82DRV
C***********************************************************************G82DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G82DRV
C                                                                       G82DRV
*     PARAMETER (MAXFIL = 40)                                           G82DRV
C                                                                       G82DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G82DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G82DRV
*    +           LFNDAF,LFNDEF                                          G82DRV
*     COMMON/NBNAME/FILENM,NFILE,IFILE(MAXFIL)                          G82DRV
*     CHARACTER*80 FILENM                                               G82DRV
C                                                                       G82DRV
*     DIMENSION CORE(1),IOP(50)                                         G82DRV
*     DIMENSION NBOOPT(10)                                              G82DRV
C                                                                       G82DRV
*     LFNIN = 5                                                         G82DRV
*     LFNPR = 6                                                         G82DRV
C                                                                       G82DRV
*     DATA TENTH/0.1D0/                                                 G82DRV
C                                                                       G82DRV
C  Set NBO options.                                                     G82DRV
C                                                                       G82DRV
*     DO 10 I = 1,9                                                     G82DRV
*       NBOOPT(I) = IOP(I+39)                                           G82DRV
*  10 CONTINUE                                                          G82DRV
*     NBOOPT(10) = 82                                                   G82DRV
C                                                                       G82DRV
C  --- NBO analysis ---                                                 G82DRV
C                                                                       G82DRV
*     ICONTR = 0                                                        G82DRV
*     IF(ABS(NBOOPT(1)).LT.2) THEN                                      G82DRV
*       CALL CHARPN(4HNBO )                                             G82DRV
*       CALL NBO(CORE,MEMORY,NBOOPT)                                    G82DRV
C                                                                       G82DRV
C  Store the name of the NBO direct access file on the RWFiles          G82DRV
C                                                                       G82DRV
*       DO 20 I = 1,80                                                  G82DRV
*         CORE(I) = ICHAR(FILENM(I:I))                                  G82DRV
*  20   CONTINUE                                                        G82DRV
*       CORE(81) = LFNDAF                                               G82DRV
*       CALL TWRITE(636,CORE,81,1,81,1,0)                               G82DRV
C                                                                       G82DRV
C  --- NBO energetic analysis ---                                       G82DRV
C                                                                       G82DRV
*     ELSE IF(NBOOPT(1).EQ.2) THEN                                      G82DRV
C                                                                       G82DRV
C  Retrieve the name of the NBO direct access file from the RWFiles     G82DRV
C                                                                       G82DRV
*       CALL TREAD(636,CORE,81,1,81,1,0)                                G82DRV
*       DO 30 I = 1,80                                                  G82DRV
*         FILENM(I:I) = CHAR(INT(CORE(I) + TENTH))                      G82DRV
*  30   CONTINUE                                                        G82DRV
*       LFNDAF = INT(ABS(CORE(81)) + TENTH)                             G82DRV
*       CALL CHARPN(4HDELE)                                             G82DRV
*       CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE)                           G82DRV
*       IF(IDONE.NE.0) ICONTR = 1                                       G82DRV
*       IF(IDONE.EQ.0) CALL DELSCF(CORE,CORE,NBOOPT)                    G82DRV
C                                                                       G82DRV
*     ELSE IF(NBOOPT(1).EQ.3) THEN                                      G82DRV
*       CALL TREAD(636,CORE,81,1,81,1,0)                                G82DRV
*       DO 40 I = 1,80                                                  G82DRV
*         FILENM(I:I) = CHAR(INT(CORE(I) + TENTH))                      G82DRV
*  40   CONTINUE                                                        G82DRV
*       LFNDAF = INT(ABS(CORE(81)) + TENTH)                             G82DRV
*       CALL CHARPN(4HEDEL)                                             G82DRV
*       CALL DELSCF(CORE,CORE,NBOOPT)                                   G82DRV
*       CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE)                           G82DRV
*     END IF                                                            G82DRV
C                                                                       G82DRV
*     RETURN                                                            G82DRV
*     END                                                               G82DRV
C***********************************************************************G82DRV
*     SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                              G82DRV
C***********************************************************************G82DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G82DRV
C-----------------------------------------------------------------------G82DRV
C                                                                       G82DRV
C  Routine FEAOIN accesses the following records of the RWFs:           G82DRV
C                                                                       G82DRV
C        203  ---   CI density matrix (alpha)                           G82DRV
C        204  ---   CI density matrix (beta)                            G82DRV
C        501  ---   Total energy                                        G82DRV
C        502  ---   Job title                                           G82DRV
C        506  ---   Basis set information                               G82DRV
C        512  ---   Effective core potential information                G82DRV
C        514  ---   AO overlap matrix                                   G82DRV
C        518  ---   x dipole integrals                                  G82DRV
C        519  ---   y dipole integrals                                  G82DRV
C        520  ---   z dipole integrals                                  G82DRV
C        524  ---   MO coefficients (alpha)                             G82DRV
C        526  ---   MO coefficients (beta)                              G82DRV
C        528  ---   SCF density matrix (alpha)                          G82DRV
C        530  ---   SCF density matrix (beta)                           G82DRV
C        536  ---   AO Fock matrix (alpha)                              G82DRV
C        538  ---   AO Fock matrix (beta)                               G82DRV
C                                                                       G82DRV
C ----------------------------------------------------------------------G82DRV
C                                                                       G82DRV
C  NBO Common blocks                                                    G82DRV
C                                                                       G82DRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               G82DRV
C                                                                       G82DRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G82DRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       G82DRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       G82DRV
*     COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,        G82DRV
*    + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    G82DRV
*    + JCORE,JPRINT(60)                                                 G82DRV
*     COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)                             G82DRV
*     COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), G82DRV
*    +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)                     G82DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G82DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G82DRV
*    +           LFNDAF,LFNDEF                                          G82DRV
C                                                                       G82DRV
C  GAUSSIAN 82 Common blocks                                            G82DRV
C                                                                       G82DRV
*     COMMON/MOL/NATOM,ICHARG,MULTIP,NAE,NBE,NE,NBASIS,IAN(101),        G82DRV
*    *           ATMCHG(100),C(300)                                     G82DRV
*     COMMON/LP2/NLP(400),CLP(400),ZLP(400),KFIRST(100,5),              G82DRV
*    *  KLAST(100,5),LMAX(100),LPSKIP(100),NFroz(100)                   G82DRV
*     COMMON/B/EXX(240),C1(240),C2(240),C3(240),X(80),Y(80),            G82DRV
*    *     Z(80),JAN(80),SHELLA(80),SHELLN(80),SHELLT(80),              G82DRV
*    *     SHELLC(80),AOS(80),AON(80),NSHELL,MAXTYP                     G82DRV
*     INTEGER SHELLA,SHELLN,SHELLT,SHELLC,SHLADF,AOS,AON                G82DRV
*     DIMENSION C4(80),SHLADF(80)                                       G82DRV
*     EQUIVALENCE(C4(1),C3(81)),(SHLADF(1),C3(161))                     G82DRV
C                                                                       G82DRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             G82DRV
*     DIMENSION LISTP(3),LISTD(6,2),LISTF(10,2)                         G82DRV
C                                                                       G82DRV
C  Obtain the following information:                                    G82DRV
C                                                                       G82DRV
C    ROHF        =.TRUE. If RHF open shell wavefunction                 G82DRV
C                =.FALSE. otherwise                                     G82DRV
C                                                                       G82DRV
C    UHF         =.TRUE. If UHF wavefunction                            G82DRV
C                =.FALSE. otherwise                                     G82DRV
C                                                                       G82DRV
C    AUHF        =.TRUE. If spin-annihilated UHF wavefunction           G82DRV
C                =.FALSE. otherwise                                     G82DRV
C                                                                       G82DRV
C    CI          =.TRUE. If CI wavefunction                             G82DRV
C                =.FALSE. otherwise                                     G82DRV
C                                                                       G82DRV
C    OPEN        =.TRUE. If open shell wavefunction                     G82DRV
C                =.FALSE. otherwise                                     G82DRV
C                                                                       G82DRV
C    COMPLX      =.TRUE. If complex wavefunction                        G82DRV
C                =.FALSE. otherwise                                     G82DRV
C                (Note: The program is not capable of handling this.)   G82DRV
C                                                                       G82DRV
C    NATOMS      Number of atomic centers                               G82DRV
C                                                                       G82DRV
C    NDIM        Dimension of matrices (overlap and density)            G82DRV
C                                                                       G82DRV
C    NBAS        Number of basis functions (.le.NDIM)                   G82DRV
C                                                                       G82DRV
C    IPSEUD      Set to one if pseudopotentials are used.               G82DRV
C                                                                       G82DRV
C    IWCUBF      This pertains only basis sets with F functions.        G82DRV
C                                                                       G82DRV
C                If cartesian F functions are input, set IWCUBF to:     G82DRV
C                    0,  if these are to be transformed to the          G82DRV
C                        standard set of pure F functions               G82DRV
C                    1,  if these are to be transformed to the          G82DRV
C                        cubic set of pure F functions                  G82DRV
C                                                                       G82DRV
C                If pure F functions are input, set to IWCUBF to:       G82DRV
C                    0,  if these are standard F functions              G82DRV
C                    1,  if these are cubic F functions                 G82DRV
C                                                                       G82DRV
C    IATNO(I),I=1,NATOMS                                                G82DRV
C                List of atomic numbers                                 G82DRV
C                                                                       G82DRV
C    LCTR(I),I=1,NBAS                                                   G82DRV
C                List of atomic centers of the basis functions          G82DRV
C                (LCTR(3)=2 if basis function 3 is on atom 2)           G82DRV
C                                                                       G82DRV
C    LANG(I),I=1,NBAS                                                   G82DRV
C                List of angular symmetry information for the AO basis  G82DRV
C                                                                       G82DRV
*     DATA LISTS/   1/                                                  G82DRV
*     DATA LISTP/ 101, 102, 103/                                        G82DRV
*     DATA LISTD/ 255, 252, 253, 254, 251,   0,                         G82DRV
*    +            201, 204, 206, 202, 203, 205/                         G82DRV
*     DATA LISTF/ 351, 352, 353, 354, 355, 356, 357,   0,   0,   0,     G82DRV
*    +            301, 307, 310, 304, 302, 303, 306, 309, 308, 305/     G82DRV
*     DATA ZERO/0.0D0/                                                  G82DRV
*     DATA TOANG/0.529177249/                                           G82DRV
C                                                                       G82DRV
C  Store job title on NBODAF:                                           G82DRV
C                                                                       G82DRV
*     LEN = INTOWP(500)                                                 G82DRV
*     CALL TREAD(502,ICORE,LEN,1,LEN,1,0)                               G82DRV
*     NFILE = 2                                                         G82DRV
*     CALL NBWRIT(ICORE(401),10,NFILE)                                  G82DRV
C                                                                       G82DRV
C  Get the number of atoms from NAT and store the atomic numbers in     G82DRV
C  IATNO and nuclear charges in IZNUC.  (NOTE: atomic numbers and       G82DRV
C  nuclear charges may not be equivalent if effective core potentials   G82DRV
C  (ECP) are used.)                                                     G82DRV
C                                                                       G82DRV
*     LEN = 0                                                           G82DRV
*     IEXIST = ITQRY(512)                                               G82DRV
*     IF(IEXIST.GT.0) THEN                                              G82DRV
*       LEN = 2 * 400 + 17 * INTOWP(100)                                G82DRV
*       CALL TREAD(512,NLP,LEN,1,LEN,1,0)                               G82DRV
*     END IF                                                            G82DRV
*     NATOMS = NATOM                                                    G82DRV
*     DO 20 I = 1,NATOMS                                                G82DRV
*       IATNO(I) = IAN(I)                                               G82DRV
*       IF(IEXIST.GT.0) THEN                                            G82DRV
*         IZNUC(I) = IATNO(I) - NFROZ(I)                                G82DRV
*         IF(NFROZ(I).NE.0) IPSEUD = 1                                  G82DRV
*       ELSE                                                            G82DRV
*         IZNUC(I) = IATNO(I)                                           G82DRV
*       END IF                                                          G82DRV
*  20 CONTINUE                                                          G82DRV
C                                                                       G82DRV
C  Restore the basis set to COMMON/B/:                                  G82DRV
C                                                                       G82DRV
*     LEN = 1200 + INTOWP(562)                                          G82DRV
*     CALL TREAD(506,EXX,LEN,1,LEN,1,0)                                 G82DRV
C                                                                       G82DRV
C  The Gaussian programs do not use cubic f basis functions.            G82DRV
C  Determine which set of d and f functions are being used,             G82DRV
C  Cartesian or pure):                                                  G82DRV
C                                                                       G82DRV
*     IWCUBF = 0                                                        G82DRV
*     CALL ILSW(2,2,I5D6D)                                              G82DRV
*     CALL ILSW(2,16,I7F10F)                                            G82DRV
C                                                                       G82DRV
C  Construct the AO information lists: LCTR and LANG                    G82DRV
C                                                                       G82DRV
*     IBAS = 0                                                          G82DRV
*     DO 90 ISHELL = 1,80                                               G82DRV
*       IF(IBAS.EQ.NBASIS) GOTO 100                                     G82DRV
*       NCTR   = JAN(ISHELL)                                            G82DRV
*       MAXL   = SHELLT(ISHELL)                                         G82DRV
*       ICNSTR = SHELLC(ISHELL)                                         G82DRV
C                                                                       G82DRV
C  Is an s orbital in the shell?                                        G82DRV
C                                                                       G82DRV
*       KS = 0                                                          G82DRV
*       IF(MAXL.EQ.0) KS = 1                                            G82DRV
*       IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1                            G82DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1                            G82DRV
*       IF(KS.EQ.0) GOTO 30                                             G82DRV
C                                                                       G82DRV
C  s orbital:                                                           G82DRV
C                                                                       G82DRV
*         IBAS = IBAS + 1                                               G82DRV
*         LCTR(IBAS) = NCTR                                             G82DRV
*         LANG(IBAS) = LISTS                                            G82DRV
C                                                                       G82DRV
C  Is a set of p orbitals in the shell?                                 G82DRV
C                                                                       G82DRV
*  30   CONTINUE                                                        G82DRV
*       KP = 0                                                          G82DRV
*       IF(MAXL.EQ.0) GOTO 90                                           G82DRV
*       IF(MAXL.EQ.1) KP = 1                                            G82DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1                            G82DRV
*       IF(KP.EQ.0) GOTO 50                                             G82DRV
C                                                                       G82DRV
C  p orbitals:                                                          G82DRV
C                                                                       G82DRV
*       DO 40 I = 1,3                                                   G82DRV
*         IBAS = IBAS + 1                                               G82DRV
*         LCTR(IBAS) = NCTR                                             G82DRV
*         LANG(IBAS) = LISTP(I)                                         G82DRV
*  40   CONTINUE                                                        G82DRV
C                                                                       G82DRV
C  d orbitals:                                                          G82DRV
C                                                                       G82DRV
*  50   IF(MAXL.NE.2) GOTO 70                                           G82DRV
*         IMAX = I5D6D + 5                                              G82DRV
*         KD = I5D6D + 1                                                G82DRV
*         DO 60 I = 1,IMAX                                              G82DRV
*           IBAS = IBAS + 1                                             G82DRV
*           LCTR(IBAS) = NCTR                                           G82DRV
*           LANG(IBAS) = LISTD(I,KD)                                    G82DRV
*  60     CONTINUE                                                      G82DRV
*         GO TO 90                                                      G82DRV
C                                                                       G82DRV
C  f orbitals:                                                          G82DRV
C                                                                       G82DRV
*  70   IF(MAXL.NE.3) GOTO 90                                           G82DRV
*         IMAX = 7                                                      G82DRV
*         IF(I7F10F.EQ.1) IMAX = 10                                     G82DRV
*         KF = I7F10F + 1                                               G82DRV
*         DO 80 I = 1,IMAX                                              G82DRV
*           IBAS = IBAS + 1                                             G82DRV
*           LCTR(IBAS) = NCTR                                           G82DRV
*           LANG(IBAS) = LISTF(I,KF)                                    G82DRV
*  80     CONTINUE                                                      G82DRV
*  90 CONTINUE                                                          G82DRV
* 100 CONTINUE                                                          G82DRV
*     NDIM = NBASIS                                                     G82DRV
*     NBAS = NBASIS                                                     G82DRV
C                                                                       G82DRV
C  Determine the type of wave function the density matrix is from:      G82DRV
C                                                                       G82DRV
*     IF(MULTIP.GT.1) OPEN = .TRUE.                                     G82DRV
*     IF(NBOOPT(2).NE.0) THEN                                           G82DRV
*       CI = .TRUE.                                                     G82DRV
*     ELSE                                                              G82DRV
*       CALL ILSW(2,1,ISCF)                                             G82DRV
*       CALL ILSW(2,22,IROHF)                                           G82DRV
*       IF(ISCF.EQ.1)  UHF    = .TRUE.                                  G82DRV
*       IF(UHF)        OPEN   = .TRUE.                                  G82DRV
*       IF(IROHF.EQ.1) ROHF   = .TRUE.                                  G82DRV
*       IF(IROHF.EQ.2) ROHF   = .TRUE.                                  G82DRV
*       IF(IROHF.EQ.3) MCSCF  = .TRUE.                                  G82DRV
*       IF(ISCF.GT.1)  COMPLX = .TRUE.                                  G82DRV
*       IF(COMPLX) GOTO 900                                             G82DRV
*     END IF                                                            G82DRV
*     IF(NBOOPT(5).EQ.1) AUHF = .TRUE.                                  G82DRV
*     ORTHO = .FALSE.                                                   G82DRV
C                                                                       G82DRV
C  No Fock matrices for ROHF, MCSCF, or CI wavefunctions:               G82DRV
C                                                                       G82DRV
*     IF(ROHF.OR.MCSCF.OR.CI) IWFOCK = 0                                G82DRV
C                                                                       G82DRV
C  Expectation values of the Fock operator are in atomic units:         G82DRV
C                                                                       G82DRV
*     MUNIT = 0                                                         G82DRV
C                                                                       G82DRV
C  Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:         G82DRV
C                                                                       G82DRV
*     ICORE(1)  = NATOMS                                                G82DRV
*     ICORE(2)  = NDIM                                                  G82DRV
*     ICORE(3)  = NBAS                                                  G82DRV
*     ICORE(4)  = MUNIT                                                 G82DRV
*     ICORE(5)  = 0                                                     G82DRV
*     IF(ROHF)  ICORE(5)  = 1                                           G82DRV
*     ICORE(6)  = 0                                                     G82DRV
*     IF(UHF)   ICORE(6)  = 1                                           G82DRV
*     ICORE(7)  = 0                                                     G82DRV
*     IF(CI)    ICORE(7)  = 1                                           G82DRV
*     ICORE(8)  = 0                                                     G82DRV
*     IF(OPEN)  ICORE(8)  = 1                                           G82DRV
*     ICORE(9)  = 0                                                     G82DRV
*     IF(MCSCF) ICORE(9)  = 1                                           G82DRV
*     ICORE(10) = 0                                                     G82DRV
*     IF(AUHF)  ICORE(10)  = 1                                          G82DRV
*     ICORE(11) = 0                                                     G82DRV
*     IF(ORTHO) ICORE(11) = 1                                           G82DRV
*     ICORE(12) = 1                                                     G82DRV
*     NFILE = 3                                                         G82DRV
*     CALL NBWRIT(ICORE,12,NFILE)                                       G82DRV
C                                                                       G82DRV
C  Store IATNO, IZNUC, LCTR, and LANG on NBO DAF:                       G82DRV
C                                                                       G82DRV
*     II = 0                                                            G82DRV
*     DO 120 I = 1,NATOMS                                               G82DRV
*       II = II + 1                                                     G82DRV
*       ICORE(II) = IATNO(I)                                            G82DRV
* 120 CONTINUE                                                          G82DRV
*     DO 130 I = 1,NATOMS                                               G82DRV
*       II = II + 1                                                     G82DRV
*       ICORE(II) = IZNUC(I)                                            G82DRV
* 130 CONTINUE                                                          G82DRV
*     DO 140 I = 1,NBAS                                                 G82DRV
*       II = II + 1                                                     G82DRV
*       ICORE(II) = LCTR(I)                                             G82DRV
* 140 CONTINUE                                                          G82DRV
*     DO 150 I = 1,NBAS                                                 G82DRV
*       II = II + 1                                                     G82DRV
*       ICORE(II) = LANG(I)                                             G82DRV
* 150 CONTINUE                                                          G82DRV
*     NFILE = 4                                                         G82DRV
*     CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE)                          G82DRV
C                                                                       G82DRV
C  Fetch the total energy from the RWF and store it on the NBODAF:      G82DRV
C                                                                       G82DRV
*     CALL TREAD(501,CORE,32,1,32,1,0)                                  G82DRV
*     CORE(1) = CORE(32)                                                G82DRV
*     CORE(2) = CORE(32)                                                G82DRV
*     NFILE = 8                                                         G82DRV
*     CALL NBWRIT(CORE,2,NFILE)                                         G82DRV
C                                                                       G82DRV
C  Store the atomic coordinates on the NBO DAF: (Note that these        G82DRV
C  coordinates are used in the calculation of dipole moments.)          G82DRV
C                                                                       G82DRV
*     DO 160 I = 1,3*NATOMS                                             G82DRV
*       CORE(I) = C(I) * TOANG                                          G82DRV
* 160 CONTINUE                                                          G82DRV
*     NFILE = 9                                                         G82DRV
*     CALL NBWRIT(CORE,3*NATOMS,NFILE)                                  G82DRV
C                                                                       G82DRV
C  Store the overlap matrix on the NBODAF:                              G82DRV
C                                                                       G82DRV
*     L2 = NDIM*(NDIM+1)/2                                              G82DRV
*     CALL TREAD(514,CORE,NDIM,NDIM,NBAS,NBAS,1)                        G82DRV
*     CALL PACK(CORE,NDIM,NBAS,L2)                                      G82DRV
*     NFILE = 10                                                        G82DRV
*     CALL NBWRIT(CORE,L2,NFILE)                                        G82DRV
C                                                                       G82DRV
C  Store the density matrices on the NBODAF:                            G82DRV
C                                                                       G82DRV
*     L2  = NDIM*(NDIM+1)/2                                             G82DRV
*     IF(CI) THEN                                                       G82DRV
*       CALL TREAD(203,CORE,NDIM,NDIM,NBAS,NBAS,1)                      G82DRV
*       CALL PACK(CORE,NDIM,NBAS,L2)                                    G82DRV
*       NFILE = 20                                                      G82DRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      G82DRV
*       IF(OPEN) THEN                                                   G82DRV
*         CALL TREAD(204,CORE,NDIM,NDIM,NBAS,NBAS,1)                    G82DRV
*         CALL PACK(CORE,NDIM,NBAS,L2)                                  G82DRV
*         NFILE = 21                                                    G82DRV
*         CALL NBWRIT(CORE,L2,NFILE)                                    G82DRV
*       END IF                                                          G82DRV
*     ELSE                                                              G82DRV
*       CALL TREAD(528,CORE,NDIM,NDIM,NBAS,NBAS,1)                      G82DRV
*       CALL PACK(CORE,NDIM,NBAS,L2)                                    G82DRV
*       NFILE = 20                                                      G82DRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      G82DRV
*       IF(OPEN) THEN                                                   G82DRV
*         CALL TREAD(530,CORE,NDIM,NDIM,NBAS,NBAS,1)                    G82DRV
*         CALL PACK(CORE,NDIM,NBAS,L2)                                  G82DRV
*         NFILE = 21                                                    G82DRV
*         CALL NBWRIT(CORE,L2,NFILE)                                    G82DRV
*       END IF                                                          G82DRV
*     END IF                                                            G82DRV
C                                                                       G82DRV
C  Store the Fock matrices on the NBODAF:                               G82DRV
C                                                                       G82DRV
*     IF(IWFOCK.NE.0) THEN                                              G82DRV
*       IEXIST = ITQRY(536)                                             G82DRV
*       IF(IEXIST.GT.0) THEN                                            G82DRV
*         L2 = NDIM*(NDIM+1)/2                                          G82DRV
*         CALL TREAD(536,CORE,NDIM,NDIM,NBAS,NBAS,1)                    G82DRV
*         CALL PACK(CORE,NDIM,NBAS,L2)                                  G82DRV
*         NFILE = 30                                                    G82DRV
*         CALL NBWRIT(CORE,L2,NFILE)                                    G82DRV
*       END IF                                                          G82DRV
C                                                                       G82DRV
*       IF(OPEN) THEN                                                   G82DRV
*         IEXIST = ITQRY(538)                                           G82DRV
*         IF(IEXIST.GT.0) THEN                                          G82DRV
*           L2 = NDIM*(NDIM+1)/2                                        G82DRV
*           CALL TREAD(538,CORE,NDIM,NDIM,NBAS,NBAS,1)                  G82DRV
*           CALL PACK(CORE,NDIM,NBAS,L2)                                G82DRV
*           NFILE = 31                                                  G82DRV
*           CALL NBWRIT(CORE,L2,NFILE)                                  G82DRV
*         END IF                                                        G82DRV
*       END IF                                                          G82DRV
*     END IF                                                            G82DRV
C                                                                       G82DRV
C  Store the AO to MO transformation matrices on the NBODAF:            G82DRV
C                                                                       G82DRV
*     IEXIST = ITQRY(524)                                               G82DRV
*     IF(IEXIST.GT.0) THEN                                              G82DRV
*       L3 = NDIM*NDIM                                                  G82DRV
*       CALL TREAD(524,CORE,NDIM,NDIM,NBAS,NBAS,0)                      G82DRV
*       NFILE = 40                                                      G82DRV
*       CALL NBWRIT(CORE,L3,NFILE)                                      G82DRV
*     END IF                                                            G82DRV
C                                                                       G82DRV
*     IF(OPEN) THEN                                                     G82DRV
*       IEXIST = ITQRY(526)                                             G82DRV
*       IF(IEXIST.GT.0) THEN                                            G82DRV
*         L3 = NDIM*NDIM                                                G82DRV
*         CALL TREAD(526,CORE,NDIM,NDIM,NBAS,NBAS,0)                    G82DRV
*         NFILE = 41                                                    G82DRV
*         CALL NBWRIT(CORE,L3,NFILE)                                    G82DRV
*       END IF                                                          G82DRV
*     END IF                                                            G82DRV
C                                                                       G82DRV
C  Store the x,y,z dipole integrals on the NBODAF:                      G82DRV
C                                                                       G82DRV
*     IEXIST = ITQRY(518)                                               G82DRV
*     IEXIST = MIN(IEXIST,ITQRY(519))                                   G82DRV
*     IEXIST = MIN(IEXIST,ITQRY(520))                                   G82DRV
*     IF(IEXIST.GT.0) THEN                                              G82DRV
*       L2 = NDIM*(NDIM+1)/2                                            G82DRV
*       CALL TREAD(518,CORE(1),L2,1,L2,1,0)                             G82DRV
*       CALL TREAD(519,CORE(L2+1),L2,1,L2,1,0)                          G82DRV
*       CALL TREAD(520,CORE(2*L2+1),L2,1,L2,1,0)                        G82DRV
*       DO 170 I = 1,3*L2                                               G82DRV
*         CORE(I) = CORE(I) * TOANG                                     G82DRV
* 170   CONTINUE                                                        G82DRV
*       NFILE = 50                                                      G82DRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      G82DRV
*       NFILE = 51                                                      G82DRV
*       CALL NBWRIT(CORE(L2+1),L2,NFILE)                                G82DRV
*       NFILE = 52                                                      G82DRV
*       CALL NBWRIT(CORE(2*L2+1),L2,NFILE)                              G82DRV
*     END IF                                                            G82DRV
C                                                                       G82DRV
C  Store the AO basis set info on the NBO DAF:  (Note that two integers G82DRV
C  and three integer arrays are stored first.  Also remember that ICORE G82DRV
C  and CORE occupy the same memory.)                                    G82DRV
C                                                                       G82DRV
*     NEXP = 0                                                          G82DRV
*     DO 180 I = 1,240                                                  G82DRV
*       IF(EXX(I).EQ.ZERO) GOTO 180                                     G82DRV
*       NEXP = I                                                        G82DRV
* 180 CONTINUE                                                          G82DRV
*     DO 190 I = 1,2+3*NSHELL+5*NEXP                                    G82DRV
*       CORE(I) = ZERO                                                  G82DRV
* 190 CONTINUE                                                          G82DRV
*     ICORE(1) = NSHELL                                                 G82DRV
*     ICORE(2) = NEXP                                                   G82DRV
C                                                                       G82DRV
C  Determine if Cartesian or pure D and F functions are used:           G82DRV
C                                                                       G82DRV
*     CALL ILSW(2,2,I5D6D)                                              G82DRV
*     CALL ILSW(2,16,I7F10F)                                            G82DRV
C                                                                       G82DRV
C  NCOMP(I) -- the number of components in the Ith shell:               G82DRV
C                                                                       G82DRV
*     II = 2                                                            G82DRV
*     DO 420 I = 1,NSHELL                                               G82DRV
*       II = II + 1                                                     G82DRV
*       ICORE(II) = 0                                                   G82DRV
*       MAXL = SHELLT(I)                                                G82DRV
*       ICNSTR = SHELLC(I)                                              G82DRV
C                                                                       G82DRV
C  Determine if an S orbital is in the shell:                           G82DRV
C                                                                       G82DRV
*       KS = 0                                                          G82DRV
*       IF(MAXL.EQ.0) KS = 1                                            G82DRV
*       IF(MAXL.EQ.1.AND.ICNSTR.NE.1) KS = 1                            G82DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KS = 1                            G82DRV
*       IF(KS.EQ.0) GO TO 310                                           G82DRV
C                                                                       G82DRV
C  S orbital:                                                           G82DRV
C                                                                       G82DRV
*       ICORE(II) = ICORE(II) + 1                                       G82DRV
C                                                                       G82DRV
C  Determine if a set of P orbitals is in the shell:                    G82DRV
C                                                                       G82DRV
* 310   CONTINUE                                                        G82DRV
*       KP = 0                                                          G82DRV
*       IF(MAXL.EQ.0) GO TO 400                                         G82DRV
*       IF(MAXL.EQ.1) KP = 1                                            G82DRV
*       IF(MAXL.EQ.2.AND.ICNSTR.EQ.0) KP = 1                            G82DRV
*       IF(KP.EQ.0) GO TO 340                                           G82DRV
C                                                                       G82DRV
C  P orbital:                                                           G82DRV
C                                                                       G82DRV
*       ICORE(II) = ICORE(II) + 3                                       G82DRV
C                                                                       G82DRV
C  If MAXL is less than 2 then there are no D or F orbitals:            G82DRV
C  If MAXL is greater than 2 then there must be F orbitals:             G82DRV
C                                                                       G82DRV
* 340   IF(MAXL.LT.2) GO TO 400                                         G82DRV
*       IF(MAXL.GT.2) GO TO 370                                         G82DRV
C                                                                       G82DRV
C  D orbital:                                                           G82DRV
C                                                                       G82DRV
*       IMAX = I5D6D + 5                                                G82DRV
*       ICORE(II) = ICORE(II) + IMAX                                    G82DRV
C                                                                       G82DRV
C  If MAXL is less than 3 then there are no F orbitals:                 G82DRV
C                                                                       G82DRV
* 370   IF(MAXL.LT.3) GO TO 400                                         G82DRV
C                                                                       G82DRV
C  F orbital:                                                           G82DRV
C                                                                       G82DRV
*       IMAX=7                                                          G82DRV
*       IF(I7F10F.EQ.1) IMAX=10                                         G82DRV
*       ICORE(II) = ICORE(II) + IMAX                                    G82DRV
C                                                                       G82DRV
C  Skip here when no more orbitals are found:                           G82DRV
C                                                                       G82DRV
* 400   CONTINUE                                                        G82DRV
* 420 CONTINUE                                                          G82DRV
C                                                                       G82DRV
C  NPRIM(I) -- the number of gaussian primitives in the Ith shell:      G82DRV
C                                                                       G82DRV
*     DO 480 I = 1,NSHELL                                               G82DRV
*       II = II + 1                                                     G82DRV
*       ICORE(II) = SHELLN(I)                                           G82DRV
* 480 CONTINUE                                                          G82DRV
C                                                                       G82DRV
C  NPTR(I) -- pointer for the Ith shell into the gaussian parameters,   G82DRV
C             EXP, CS, CP, etc.:                                        G82DRV
C                                                                       G82DRV
*     DO 490 I = 1,NSHELL                                               G82DRV
*       II = II + 1                                                     G82DRV
*       ICORE(II) = SHELLA(I)                                           G82DRV
* 490 CONTINUE                                                          G82DRV
C                                                                       G82DRV
C  EXP(I) -- orbital exponents indexed by NPTR:                         G82DRV
C                                                                       G82DRV
*     DO 500 I = 1,NEXP                                                 G82DRV
*       II = II + 1                                                     G82DRV
*       CORE(II) = EXX(I)                                               G82DRV
* 500 CONTINUE                                                          G82DRV
C                                                                       G82DRV
C  CS,CP -- orbital coefficients:                                       G82DRV
C                                                                       G82DRV
*     DO 510 I = 1,NEXP                                                 G82DRV
*       II = II + 1                                                     G82DRV
*       CORE(II) = C1(I)                                                G82DRV
* 510 CONTINUE                                                          G82DRV
*     DO 520 I = 1,NEXP                                                 G82DRV
*       II = II + 1                                                     G82DRV
*       CORE(II) = C2(I)                                                G82DRV
* 520 CONTINUE                                                          G82DRV
C                                                                       G82DRV
C  Zero CD and CF arrays:                                               G82DRV
C                                                                       G82DRV
*     IHOLD = II                                                        G82DRV
*     DO 550 I = 1,2*NEXP                                               G82DRV
*       II = II + 1                                                     G82DRV
*       CORE(II) = ZERO                                                 G82DRV
* 550 CONTINUE                                                          G82DRV
C                                                                       G82DRV
C  Build CD and CF from C3 and C4:                                      G82DRV
C                                                                       G82DRV
*     DO 570 I = 1,NSHELL                                               G82DRV
*       IPTR = SHLADF(I)                                                G82DRV
*       IF(IPTR.GT.0) THEN                                              G82DRV
*         DO 560 J = 1,SHELLN(I)                                        G82DRV
*           LPTR = J + SHELLA(I) + IHOLD - 1                            G82DRV
*           MPTR = J + IPTR - 1                                         G82DRV
*           CORE(LPTR) = C3(MPTR)                                       G82DRV
*           CORE(LPTR+NEXP) = C4(MPTR)                                  G82DRV
* 560     CONTINUE                                                      G82DRV
*       END IF                                                          G82DRV
* 570 CONTINUE                                                          G82DRV
*     NFILE = 5                                                         G82DRV
*     CALL NBWRIT(CORE,II,NFILE)                                        G82DRV
*     RETURN                                                            G82DRV
C                                                                       G82DRV
* 900 WRITE(LFNPR,1000)                                                 G82DRV
*     RETURN                                                            G82DRV
C                                                                       G82DRV
*1000 FORMAT(/1X,'The NBO program is not set up to handle complex ',    G82DRV
*    + 'wave functions')                                                G82DRV
*     END                                                               G82DRV
C***********************************************************************G82DRV
*     SUBROUTINE DELSCF(CORE,ICORE,NBOOPT)                              G82DRV
C***********************************************************************G82DRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         G82DRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             G82DRV
*     LOGICAL NEW,ERROR,SEQ                                             G82DRV
C                                                                       G82DRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO G82DRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       G82DRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       G82DRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, G82DRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, G82DRV
*    +           LFNDAF,LFNDEF                                          G82DRV
C                                                                       G82DRV
C  If NBOOPT(1) = 2, then copy modified AO density matrix from the NBO  G82DRV
C  DAF to the RWFs.                                                     G82DRV
C                                                                       G82DRV
*     IF(NBOOPT(1).EQ.2) THEN                                           G82DRV
*       NEW = .FALSE.                                                   G82DRV
*       CALL NBOPEN(NEW,ERROR)                                          G82DRV
*       IF(ERROR) THEN                                                  G82DRV
*         WRITE(LFNPR,900)                                              G82DRV
*         STOP                                                          G82DRV
*       END IF                                                          G82DRV
*       L2 = NDIM * (NDIM + 1)/2                                        G82DRV
*       IF(OPEN) THEN                                                   G82DRV
*         ALPHA = .TRUE.                                                G82DRV
*         BETA  = .FALSE.                                               G82DRV
*         CALL FENEWD(CORE)                                             G82DRV
*         CALL TWRITE(528,CORE,L2,1,L2,1,0)                             G82DRV
*         ALPHA = .FALSE.                                               G82DRV
*         BETA  = .TRUE.                                                G82DRV
*         CALL FENEWD(CORE)                                             G82DRV
*         CALL TWRITE(530,CORE,L2,1,L2,1,0)                             G82DRV
*       ELSE                                                            G82DRV
*         ALPHA = .FALSE.                                               G82DRV
*         BETA  = .FALSE.                                               G82DRV
*         CALL FENEWD(CORE)                                             G82DRV
*         CALL TWRITE(528,CORE,L2,1,L2,1,0)                             G82DRV
*       END IF                                                          G82DRV
*       SEQ = .FALSE.                                                   G82DRV
*       CALL NBCLOS(SEQ)                                                G82DRV
*     END IF                                                            G82DRV
C                                                                       G82DRV
C  If NBOOPT(1) = 3, then copy the deletion energy to the NBO DAF:      G82DRV
C                                                                       G82DRV
*     IF(NBOOPT(1).EQ.3) THEN                                           G82DRV
*       NEW = .FALSE.                                                   G82DRV
*       CALL NBOPEN(NEW,ERROR)                                          G82DRV
*       IF(ERROR) THEN                                                  G82DRV
*         WRITE(LFNPR,900)                                              G82DRV
*         STOP                                                          G82DRV
*       END IF                                                          G82DRV
*       CALL TREAD(501,CORE,32,1,32,1,0)                                G82DRV
*       CALL SVE0(CORE(32))                                             G82DRV
*       SEQ = .FALSE.                                                   G82DRV
*       CALL NBCLOS(SEQ)                                                G82DRV
*     END IF                                                            G82DRV
*     RETURN                                                            G82DRV
C                                                                       G82DRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ',        G82DRV
*    + 'subroutine DELSCF.')                                            G82DRV
*     END                                                               G82DRV
C***********************************************************************G82DRV
C                                                                       G82DRV
C           E N D    O F    G 8 2 N B O    R O U T I N E S              G82DRV
C                                                                       G82DRV
C***********************************************************************G82DRV
C***********************************************************************GMSDRV
C                                                                       GMSDRV
C                                                                       GMSDRV
C                          G  M  S  N  B  O                             GMSDRV
C                                                                       GMSDRV
C                                                                       GMSDRV
C                    GAMESS VERSION OF NBO PROGRAM                      GMSDRV
C                                                                       GMSDRV
C                                                                       GMSDRV
C  DRIVER ROUTINES:                                                     GMSDRV
C                                                                       GMSDRV
C      SUBROUTINE RUNNBO                                                GMSDRV
C      SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                             GMSDRV
C      SUBROUTINE DELSCF(A,IA)                                          GMSDRV
C                                                                       GMSDRV
C***********************************************************************GMSDRV
*     SUBROUTINE RUNNBO                                                 GMSDRV
C***********************************************************************GMSDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GMSDRV
*     DIMENSION NBOOPT(10)                                              GMSDRV
C                                                                       GMSDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GMSDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GMSDRV
*    +           LFNDAF,LFNDEF                                          GMSDRV
C                                                                       GMSDRV
C  GAMESS Common Block:                                                 GMSDRV
C                                                                       GMSDRV
*     COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(99)                 GMSDRV
*     COMMON /FMCOM/ CORE(1)                                            GMSDRV
C                                                                       GMSDRV
*     LFNIN = IR                                                        GMSDRV
*     LFNPR = IW                                                        GMSDRV
C                                                                       GMSDRV
C  Determine the amount of available memory for the NBO analysis.       GMSDRV
C                                                                       GMSDRV
*     CALL VALFM(ICUR)                                                  GMSDRV
*     CALL GOTFM(MEMORY)                                                GMSDRV
C                                                                       GMSDRV
C  Set NBO options.                                                     GMSDRV
C                                                                       GMSDRV
*     NBOOPT(1)  =  0                                                   GMSDRV
*     NBOOPT(2)  =  0                                                   GMSDRV
*     NBOOPT(3)  =  0                                                   GMSDRV
*     NBOOPT(4)  =  0                                                   GMSDRV
*     NBOOPT(5)  =  0                                                   GMSDRV
*     NBOOPT(6)  =  0                                                   GMSDRV
*     NBOOPT(7)  =  0                                                   GMSDRV
*     NBOOPT(8)  =  0                                                   GMSDRV
*     NBOOPT(9)  =  0                                                   GMSDRV
*     NBOOPT(10) =  6                                                   GMSDRV
C                                                                       GMSDRV
C  Perform the NPA/NBO/NLMO analyses.                                   GMSDRV
C                                                                       GMSDRV
*     CALL NBO(CORE(ICUR+1),MEMORY,NBOOPT)                              GMSDRV
C                                                                       GMSDRV
C  Perform the energetic analysis.                                      GMSDRV
C                                                                       GMSDRV
*  10 NBOOPT(1) = 2                                                     GMSDRV
*     CALL NBOEAN(CORE(ICUR+1),MEMORY,NBOOPT,IDONE)                     GMSDRV
*     IF(IDONE.NE.0) GOTO 20                                            GMSDRV
*     CALL DELSCF(CORE(ICUR+1),CORE(ICUR+1))                            GMSDRV
*     NBOOPT(1) = 3                                                     GMSDRV
*     CALL NBOEAN(CORE(ICUR+1),MEMORY,NBOOPT,IDONE)                     GMSDRV
*     GOTO 10                                                           GMSDRV
C                                                                       GMSDRV
*  20 RETURN                                                            GMSDRV
*     END                                                               GMSDRV
C***********************************************************************GMSDRV
*     SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                              GMSDRV
C***********************************************************************GMSDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GMSDRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             GMSDRV
C                                                                       GMSDRV
C ----------------------------------------------------------------------GMSDRV
C                                                                       GMSDRV
C   This routine fetchs basis set information from the GAMESS common    GMSDRV
C  blocks and stores it in the NBO common blocks and direct access file GMSDRV
C  (DAF) for use by the NBO analysis.                                   GMSDRV
C                                                                       GMSDRV
C ----------------------------------------------------------------------GMSDRV
C                                                                       GMSDRV
C  Routine FEAOIN accesses the following records of the dictionary file:GMSDRV
C                                                                       GMSDRV
C          2  ---   Total energy                                        GMSDRV
C         12  ---   AO overlap matrix                                   GMSDRV
C         14  ---   AO Fock matrix (alpha)                              GMSDRV
C         15  ---   AO to MO transformation matrix (alpha)              GMSDRV
C         16  ---   AO density matrix (bond order matrix) (alpha)       GMSDRV
C         18  ---   AO Fock matrix (beta)                               GMSDRV
C         19  ---   AO to MO transformation matrix (beta)               GMSDRV
C         20  ---   AO density matrix (bond order matrix) (beta)        GMSDRV
C         23  ---   X dipole integrals                                  GMSDRV
C         24  ---   Y dipole integrals                                  GMSDRV
C         25  ---   Z dipole integrals                                  GMSDRV
C                                                                       GMSDRV
C ----------------------------------------------------------------------GMSDRV
C                                                                       GMSDRV
C  NBO Common blocks                                                    GMSDRV
C                                                                       GMSDRV
C                                                                       GMSDRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               GMSDRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GMSDRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       GMSDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       GMSDRV
*     COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,        GMSDRV
*    + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    GMSDRV
*    + JCORE,JPRINT(60)                                                 GMSDRV
*     COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)                             GMSDRV
*     COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), GMSDRV
*    +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)                     GMSDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GMSDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GMSDRV
*    +           LFNDAF,LFNDEF                                          GMSDRV
C                                                                       GMSDRV
*     DIMENSION LABELS(20),WFNS(6)                                      GMSDRV
*     LOGICAL WSTATE(6,6)                                               GMSDRV
C                                                                       GMSDRV
C  GAMESS Common blocks                                                 GMSDRV
C                                                                       GMSDRV
*     PARAMETER (MXGTOT=5000, MXSH=1000, MXATM=50)                      GMSDRV
*     COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(2047)           GMSDRV
*     COMMON /XYZPRP/ X(3),PAD(35)                                      GMSDRV
*     COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(99)                 GMSDRV
*     COMMON /INFOA / NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(MXATM),C(3,MXATM) GMSDRV
*     COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),      GMSDRV
*    *                CF(MXGTOT),CG(MXGTOT),                            GMSDRV
*    *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),   GMSDRV
*    *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL           GMSDRV
*     COMMON /SCFOPT/ SCFTYP,BLKTYP,MAXIT,MCONV,NCONV,NPUNCH            GMSDRV
*     COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),       GMSDRV
*    *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),         GMSDRV
*    *                IZCORE(MXATM)                                     GMSDRV
C                                                                       GMSDRV
C  Obtain the following information:                                    GMSDRV
C                                                                       GMSDRV
C    ROHF        =.TRUE. If RHF open shell wavefunction                 GMSDRV
C                =.FALSE. otherwise                                     GMSDRV
C                                                                       GMSDRV
C    UHF         =.TRUE. If UHF wavefunction                            GMSDRV
C                =.FALSE. otherwise                                     GMSDRV
C                                                                       GMSDRV
C    AUHF        =.TRUE. If spin-annihilated UHF wavefunction           GMSDRV
C                =.FALSE. otherwise                                     GMSDRV
C                                                                       GMSDRV
C    CI          =.TRUE. If CI wavefunction                             GMSDRV
C                =.FALSE. otherwise                                     GMSDRV
C                                                                       GMSDRV
C    OPEN        =.TRUE. If open shell wavefunction                     GMSDRV
C                =.FALSE. otherwise                                     GMSDRV
C                                                                       GMSDRV
C    COMPLX      =.TRUE. If complex wavefunction                        GMSDRV
C                =.FALSE. otherwise                                     GMSDRV
C                (Note: The program is not capable of handling this.)   GMSDRV
C                                                                       GMSDRV
C    NATOMS      Number of atomic centers                               GMSDRV
C                                                                       GMSDRV
C    NDIM        Dimension of matrices (overlap and density)            GMSDRV
C                                                                       GMSDRV
C    NBAS        Number of basis functions (.le.NDIM)                   GMSDRV
C                                                                       GMSDRV
C    IPSEUD      Set to one if pseudopotentials are used.               GMSDRV
C                                                                       GMSDRV
C    IWCUBF      This pertains only basis sets with F functions.        GMSDRV
C                                                                       GMSDRV
C                If cartesian F functions are input, set IWCUBF to:     GMSDRV
C                    0,  if these are to be transformed to the          GMSDRV
C                        standard set of pure F functions               GMSDRV
C                    1,  if these are to be transformed to the          GMSDRV
C                        cubic set of pure F functions                  GMSDRV
C                                                                       GMSDRV
C                If pure F functions are input, set to IWCUBF to:       GMSDRV
C                    0,  if these are standard F functions              GMSDRV
C                    1,  if these are cubic F functions                 GMSDRV
C                                                                       GMSDRV
C    IATNO(I),I=1,NATOMS                                                GMSDRV
C                List of atomic numbers                                 GMSDRV
C                                                                       GMSDRV
C    LCTR(I),I=1,NBAS                                                   GMSDRV
C                List of atomic centers of the basis functions          GMSDRV
C                (LCTR(3)=2 if basis function 3 is on atom 2)           GMSDRV
C                                                                       GMSDRV
C    LANG(I),I=1,NBAS                                                   GMSDRV
C                List of angular symmetry information for the basis     GMSDRV
C                functions                                              GMSDRV
C                                                                       GMSDRV
C LABELS array contains NBO labels for the atomic orbitals              GMSDRV
C                                                                       GMSDRV
*     DATA LABELS /                                                     GMSDRV
C                                                                       GMSDRV
C          s                                                            GMSDRV
C          ---                                                          GMSDRV
*    +     1,                                                           GMSDRV
C                                                                       GMSDRV
C          px    py    pz                                               GMSDRV
C          ---   ---   ---                                              GMSDRV
*    +     101,  102,  103,                                             GMSDRV
C                                                                       GMSDRV
C          dxx   dyy   dzz   dxy   dxz   dyz                            GMSDRV
C          ---   ---   ---   ---   ---   ---                            GMSDRV
*    +     201,  204,  206,  202,  203,  205,                           GMSDRV
C                                                                       GMSDRV
C          fxxx  fyyy  fzzz  fxxy  fxxz  fxyy  fxyz  fxzz  fyyz  fyzz   GMSDRV
C          ----  ----  ----  ----  ----  ----  ----  ----  ----  ----   GMSDRV
*    +     301,  307,  310,  302,  303,  304,  305,  306,  308,  309 /  GMSDRV
C                                                                       GMSDRV
C                                                                       GMSDRV
C  WSTATE array contains the values which should be set in the NBO      GMSDRV
C  common block /NBFLAG/ depending on wavefunction.                     GMSDRV
C                                                                       GMSDRV
*     DATA WSTATE /                                                     GMSDRV
C                     logical variable in common NBFLAG                 GMSDRV
C                ROHF      UHF      CI      OPEN     MCSCF    AUHF      GMSDRV
C              -------   -------  ------   ------   ------   ------     GMSDRV
C Wavefunction                                                          GMSDRV
C        RHF                                                            GMSDRV
*    +         .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE.,    GMSDRV
C        UHF                                                            GMSDRV
*    +         .FALSE., .TRUE. , .FALSE., .TRUE. , .FALSE., .FALSE.,    GMSDRV
C        ROHF                                                           GMSDRV
*    +         .TRUE. , .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE.,    GMSDRV
C        GVB                                                            GMSDRV
*    +         .TRUE.,  .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE.,    GMSDRV
C        MCSCF                                                          GMSDRV
*    +         .FALSE., .FALSE., .FALSE., .FALSE., .TRUE. , .FALSE.,    GMSDRV
C        CI                                                             GMSDRV
*    +         .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., .FALSE./    GMSDRV
C                                                                       GMSDRV
C                                                                       GMSDRV
C  Wavefunction types:                                                  GMSDRV
C                                                                       GMSDRV
*     DATA WFNS  /8HRHF     ,                                           GMSDRV
*    +            8HUHF     ,                                           GMSDRV
*    +            8HROHF    ,                                           GMSDRV
*    +            8HGVB     ,                                           GMSDRV
*    +            8HMCSCF   ,                                           GMSDRV
*    +            8HCI      /                                           GMSDRV
C                                                                       GMSDRV
*     DATA ZERO/0.0D0/                                                  GMSDRV
*     DATA TOANG/0.529177249/                                           GMSDRV
C                                                                       GMSDRV
C  Store job title on NBODAF:                                           GMSDRV
C                                                                       GMSDRV
*     DO 5 I = 1,10                                                     GMSDRV
*       CORE(I) = TITLE(I)                                              GMSDRV
*   5 CONTINUE                                                          GMSDRV
*     NFILE = 2                                                         GMSDRV
*     CALL NBWRIT(CORE,10,NFILE)                                        GMSDRV
C                                                                       GMSDRV
C  Get the number of atoms from NAT and store the atomic numbers in     GMSDRV
C  IATNO and nuclear charges in IZNUC.  (NOTE: atomic numbers and       GMSDRV
C  nuclear charges may not be equivalent if effective core potentials   GMSDRV
C  (ECP) are used.)                                                     GMSDRV
C                                                                       GMSDRV
*     NATOMS = NAT                                                      GMSDRV
*     DO 10 I = 1,NAT                                                   GMSDRV
*       IATNO(I) = ZAN(I) + IZCORE(I)                                   GMSDRV
*       IZNUC(I) = ZAN(I)                                               GMSDRV
*       IF(IZCORE(I).NE.0) IPSEUD = 1                                   GMSDRV
*  10 CONTINUE                                                          GMSDRV
C                                                                       GMSDRV
C  KATOM array contains which atom the shell is on, KMIN and KMAX       GMSDRV
C  determine the components in the shell by pointing to a range in the  GMSDRV
C  LABELS array:                                                        GMSDRV
C                                                                       GMSDRV
*     II = 0                                                            GMSDRV
*     DO 30 I = 1,NSHELL                                                GMSDRV
*       IATOM = KATOM(I)                                                GMSDRV
*       MIN   = KMIN(I)                                                 GMSDRV
*       MAX   = KMAX(I)                                                 GMSDRV
*       DO 20 J = MIN,MAX                                               GMSDRV
*         II = II + 1                                                   GMSDRV
*         LCTR(II) = IATOM                                              GMSDRV
*         LANG(II) = LABELS(J)                                          GMSDRV
*  20   CONTINUE                                                        GMSDRV
*  30 CONTINUE                                                          GMSDRV
C                                                                       GMSDRV
*     NBAS  = II                                                        GMSDRV
*     NDIM  = NBAS                                                      GMSDRV
C                                                                       GMSDRV
C  Inititialize various NBO options depending upon the wavefunction     GMSDRV
C  type and basis set type.                                             GMSDRV
C                                                                       GMSDRV
C  First, turn off the complex orbitals, indicate that the pure set     GMSDRV
C  of F functions is desired when transforming from the cartesian set.  GMSDRV
C                                                                       GMSDRV
*     COMPLX = .FALSE.                                                  GMSDRV
*     IWCUBF = 0                                                        GMSDRV
*     ORTHO  = .FALSE.                                                  GMSDRV
C                                                                       GMSDRV
C  Next set up the wavefunction flags.                                  GMSDRV
C                                                                       GMSDRV
*     DO 50 I = 1,6                                                     GMSDRV
*       ISTATE = I                                                      GMSDRV
*       IF (SCFTYP.EQ.WFNS(I)) GOTO 60                                  GMSDRV
*  50 CONTINUE                                                          GMSDRV
*     STOP 'Unknown WFNTYP'                                             GMSDRV
C                                                                       GMSDRV
*  60 ROHF  = WSTATE(1,ISTATE)                                          GMSDRV
*     UHF   = WSTATE(2,ISTATE)                                          GMSDRV
*     CI    = WSTATE(3,ISTATE)                                          GMSDRV
*     OPEN  = WSTATE(4,ISTATE)                                          GMSDRV
*     MCSCF = WSTATE(5,ISTATE)                                          GMSDRV
*     AUHF  = WSTATE(6,ISTATE)                                          GMSDRV
C                                                                       GMSDRV
C  No Fock matrices for ROHF, MCSCF, or CI wavefunctions:               GMSDRV
C                                                                       GMSDRV
*     IF (ROHF.OR.MCSCF.OR.CI) IWFOCK = 0                               GMSDRV
C                                                                       GMSDRV
C  Expectation values of the Fock operator are in atomic units:         GMSDRV
C                                                                       GMSDRV
*     MUNIT = 0                                                         GMSDRV
C                                                                       GMSDRV
C  Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:         GMSDRV
C                                                                       GMSDRV
*     ICORE(1)  = NATOMS                                                GMSDRV
*     ICORE(2)  = NDIM                                                  GMSDRV
*     ICORE(3)  = NBAS                                                  GMSDRV
*     ICORE(4)  = MUNIT                                                 GMSDRV
*     ICORE(5)  = 0                                                     GMSDRV
*     IF(ROHF)  ICORE(5)  = 1                                           GMSDRV
*     ICORE(6)  = 0                                                     GMSDRV
*     IF(UHF)   ICORE(6)  = 1                                           GMSDRV
*     ICORE(7)  = 0                                                     GMSDRV
*     IF(CI)    ICORE(7)  = 1                                           GMSDRV
*     ICORE(8)  = 0                                                     GMSDRV
*     IF(OPEN)  ICORE(8)  = 1                                           GMSDRV
*     ICORE(9)  = 0                                                     GMSDRV
*     IF(MCSCF) ICORE(9)  = 1                                           GMSDRV
*     ICORE(10) = 0                                                     GMSDRV
*     IF(AUHF)  ICORE(10)  = 1                                          GMSDRV
*     ICORE(11) = 0                                                     GMSDRV
*     IF(ORTHO) ICORE(11) = 1                                           GMSDRV
*     ICORE(12) = 1                                                     GMSDRV
*     NFILE = 3                                                         GMSDRV
*     CALL NBWRIT(ICORE,12,NFILE)                                       GMSDRV
C                                                                       GMSDRV
C  Store IATNO, IZNUC, LCTR, and LANG on NBO DAF:                       GMSDRV
C                                                                       GMSDRV
*     II = 0                                                            GMSDRV
*     DO 70 I = 1,NATOMS                                                GMSDRV
*       II = II + 1                                                     GMSDRV
*       ICORE(II) = IATNO(I)                                            GMSDRV
*  70 CONTINUE                                                          GMSDRV
*     DO 80 I = 1,NATOMS                                                GMSDRV
*       II = II + 1                                                     GMSDRV
*       ICORE(II) = IZNUC(I)                                            GMSDRV
*  80 CONTINUE                                                          GMSDRV
*     DO 90 I = 1,NBAS                                                  GMSDRV
*       II = II + 1                                                     GMSDRV
*       ICORE(II) = LCTR(I)                                             GMSDRV
*  90 CONTINUE                                                          GMSDRV
*     DO 95 I = 1,NBAS                                                  GMSDRV
*       II = II + 1                                                     GMSDRV
*       ICORE(II) = LANG(I)                                             GMSDRV
*  95 CONTINUE                                                          GMSDRV
*     NFILE = 4                                                         GMSDRV
*     CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE)                          GMSDRV
C                                                                       GMSDRV
C  Fetch the total energy from the dictionary file and store it on the  GMSDRV
C  NBO DAF:                                                             GMSDRV
C                                                                       GMSDRV
*     NFILE = 2                                                         GMSDRV
*     CALL DAREAD(IDAF,IODA,CORE,3,NFILE,NAV)                           GMSDRV
*     CORE(1) = CORE(3)                                                 GMSDRV
*     CORE(2) = CORE(3)                                                 GMSDRV
*     NFILE = 8                                                         GMSDRV
*     CALL NBWRIT(CORE,2,NFILE)                                         GMSDRV
C                                                                       GMSDRV
C  Store the atomic coordinates on the NBO DAF: (Note that these        GMSDRV
C  coordinates are used in the calculation of dipole moments. GAMESS    GMSDRV
C  requires the Cartesian origin to be at the center of mass!!)         GMSDRV
C                                                                       GMSDRV
*     I = 0                                                             GMSDRV
*     DO 110 IAT = 1,NATOMS                                             GMSDRV
*       DO 100 K = 1,3                                                  GMSDRV
*         I = I + 1                                                     GMSDRV
*         CORE(I) = (C(K,IAT) - X(K)) * TOANG                           GMSDRV
* 100   CONTINUE                                                        GMSDRV
* 110 CONTINUE                                                          GMSDRV
*     NFILE = 9                                                         GMSDRV
*     CALL NBWRIT(CORE,3*NATOMS,NFILE)                                  GMSDRV
C                                                                       GMSDRV
C  Store the overlap matrix on the NBODAF:                              GMSDRV
C                                                                       GMSDRV
*     NFILE = 12                                                        GMSDRV
*     L2 = NDIM*(NDIM+1)/2                                              GMSDRV
*     CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV)                          GMSDRV
*     NFILE = 10                                                        GMSDRV
*     CALL NBWRIT(CORE,L2,NFILE)                                        GMSDRV
C                                                                       GMSDRV
C  Store the density matrices on the NBODAF:                            GMSDRV
C                                                                       GMSDRV
*     NFILE = 16                                                        GMSDRV
*     L2 = NDIM*(NDIM+1)/2                                              GMSDRV
*     CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV)                          GMSDRV
*     NFILE = 20                                                        GMSDRV
*     CALL NBWRIT(CORE,L2,NFILE)                                        GMSDRV
C                                                                       GMSDRV
*     IF(OPEN) THEN                                                     GMSDRV
*       NFILE = 20                                                      GMSDRV
*       CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV)                        GMSDRV
*       NFILE = 21                                                      GMSDRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      GMSDRV
*     END IF                                                            GMSDRV
C                                                                       GMSDRV
C  Store the Fock matrices on the NBODAF:                               GMSDRV
C                                                                       GMSDRV
*     IF(IWFOCK.NE.0) THEN                                              GMSDRV
*       NFILE = 14                                                      GMSDRV
*       L2 = NDIM*(NDIM+1)/2                                            GMSDRV
*       IF(IODA(NFILE).GT.0) THEN                                       GMSDRV
*         CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV)                      GMSDRV
*         NFILE = 30                                                    GMSDRV
*         CALL NBWRIT(CORE,L2,NFILE)                                    GMSDRV
*       END IF                                                          GMSDRV
C                                                                       GMSDRV
*       IF(OPEN) THEN                                                   GMSDRV
*         NFILE = 18                                                    GMSDRV
*         IF(IODA(NFILE).GT.0) THEN                                     GMSDRV
*           CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV)                    GMSDRV
*           NFILE = 31                                                  GMSDRV
*           CALL NBWRIT(CORE,L2,NFILE)                                  GMSDRV
*         END IF                                                        GMSDRV
*       END IF                                                          GMSDRV
*     END IF                                                            GMSDRV
C                                                                       GMSDRV
C  Store the AO to MO transformation matrices on the NBODAF:            GMSDRV
C                                                                       GMSDRV
*     IF(IODA(15).NE.0) THEN                                            GMSDRV
*       NFILE = 15                                                      GMSDRV
*       L3 = NDIM*NDIM                                                  GMSDRV
*       CALL DAREAD(IDAF,IODA,CORE,L3,NFILE,NAV)                        GMSDRV
*       NFILE = 40                                                      GMSDRV
*       CALL NBWRIT(CORE,L3,NFILE)                                      GMSDRV
*       IF(OPEN) THEN                                                   GMSDRV
*         NFILE = 19                                                    GMSDRV
*         CALL DAREAD(IDAF,IODA,CORE,L3,NFILE,NAV)                      GMSDRV
*         NFILE = 41                                                    GMSDRV
*         CALL NBWRIT(CORE,L3,NFILE)                                    GMSDRV
*       END IF                                                          GMSDRV
*     END IF                                                            GMSDRV
C                                                                       GMSDRV
C  Store the x,y,z dipole integrals on the NBODAF:                      GMSDRV
C                                                                       GMSDRV
*     IF(IODA(23).NE.0.AND.IODA(24).NE.0.AND.IODA(25).NE.0) THEN        GMSDRV
*       L2 = NDIM*(NDIM+1)/2                                            GMSDRV
*       NFILE = 23                                                      GMSDRV
*       CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV)                        GMSDRV
*       DO 120 I = 1,L2                                                 GMSDRV
*         CORE(I) = CORE(I) * TOANG                                     GMSDRV
* 120   CONTINUE                                                        GMSDRV
*       NFILE = 50                                                      GMSDRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      GMSDRV
*       NFILE = 24                                                      GMSDRV
*       CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV)                        GMSDRV
*       DO 130 I = 1,L2                                                 GMSDRV
*         CORE(I) = CORE(I) * TOANG                                     GMSDRV
* 130   CONTINUE                                                        GMSDRV
*       NFILE = 51                                                      GMSDRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      GMSDRV
*       NFILE = 25                                                      GMSDRV
*       CALL DAREAD(IDAF,IODA,CORE,L2,NFILE,NAV)                        GMSDRV
*       DO 140 I = 1,L2                                                 GMSDRV
*         CORE(I) = CORE(I) * TOANG                                     GMSDRV
* 140   CONTINUE                                                        GMSDRV
*       NFILE = 52                                                      GMSDRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      GMSDRV
*     END IF                                                            GMSDRV
C                                                                       GMSDRV
C  Store the AO basis set info on the NBO DAF:  (Note that two integers GMSDRV
C  and three integer arrays are stored first.  Also remember that ICORE GMSDRV
C  and CORE occupy the same memory.)                                    GMSDRV
C                                                                       GMSDRV
*     NEXP = 0                                                          GMSDRV
*     DO 150 I = 1,MXGTOT                                               GMSDRV
*       IF(EX(I).EQ.ZERO) GOTO 150                                      GMSDRV
*       NEXP = I                                                        GMSDRV
* 150 CONTINUE                                                          GMSDRV
*     DO 160 I = 1,2+3*NSHELL+5*NEXP                                    GMSDRV
*       CORE(I) = ZERO                                                  GMSDRV
* 160 CONTINUE                                                          GMSDRV
*     ICORE(1) = NSHELL                                                 GMSDRV
*     ICORE(2) = NEXP                                                   GMSDRV
C                                                                       GMSDRV
C  NCOMP(I) -- the number of components in the Ith shell:               GMSDRV
C                                                                       GMSDRV
*     II = 2                                                            GMSDRV
*     DO 170 I = 1,NSHELL                                               GMSDRV
*       II = II + 1                                                     GMSDRV
*       ICORE(II) = KMAX(I) - KMIN(I) + 1                               GMSDRV
* 170 CONTINUE                                                          GMSDRV
C                                                                       GMSDRV
C  NPRIM(I) -- the number of gaussian primitives in the Ith shell:      GMSDRV
C                                                                       GMSDRV
*     DO 180 I = 1,NSHELL                                               GMSDRV
*       II = II + 1                                                     GMSDRV
*       ICORE(II) = KNG(I)                                              GMSDRV
* 180 CONTINUE                                                          GMSDRV
C                                                                       GMSDRV
C  NPTR(I) -- pointer for the Ith shell into the gaussian parameters,   GMSDRV
C             EXP, CS, CP, etc.:                                        GMSDRV
C                                                                       GMSDRV
*     DO 190 I = 1,NSHELL                                               GMSDRV
*       II = II + 1                                                     GMSDRV
*       ICORE(II) = KSTART(I)                                           GMSDRV
* 190 CONTINUE                                                          GMSDRV
C                                                                       GMSDRV
C  EXP(I) -- orbital exponents indexed by NPTR:                         GMSDRV
C                                                                       GMSDRV
*     DO 200 I = 1,NEXP                                                 GMSDRV
*       II = II + 1                                                     GMSDRV
*       CORE(II) = EX(I)                                                GMSDRV
* 200 CONTINUE                                                          GMSDRV
C                                                                       GMSDRV
C  CS,CP,CD,CF -- orbital coefficients:                                 GMSDRV
C                                                                       GMSDRV
*     DO 210 I = 1,NEXP                                                 GMSDRV
*       II = II + 1                                                     GMSDRV
*       CORE(II) = CS(I)                                                GMSDRV
* 210 CONTINUE                                                          GMSDRV
*     DO 220 I = 1,NEXP                                                 GMSDRV
*       II = II + 1                                                     GMSDRV
*       CORE(II) = CP(I)                                                GMSDRV
* 220 CONTINUE                                                          GMSDRV
*     DO 230 I = 1,NEXP                                                 GMSDRV
*       II = II + 1                                                     GMSDRV
*       CORE(II) = CD(I)                                                GMSDRV
* 230 CONTINUE                                                          GMSDRV
*     DO 240 I = 1,NEXP                                                 GMSDRV
*       II = II + 1                                                     GMSDRV
*       CORE(II) = ZERO                                                 GMSDRV
* 240 CONTINUE                                                          GMSDRV
*     NFILE = 5                                                         GMSDRV
*     CALL NBWRIT(CORE,II,NFILE)                                        GMSDRV
C                                                                       GMSDRV
*     RETURN                                                            GMSDRV
*     END                                                               GMSDRV
C***********************************************************************GMSDRV
*     SUBROUTINE DELSCF(A,IA)                                           GMSDRV
C***********************************************************************GMSDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         GMSDRV
*     LOGICAL NEW,ERROR,SEQ                                             GMSDRV
C                                                                       GMSDRV
C  NBO common blocks:                                                   GMSDRV
C                                                                       GMSDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       GMSDRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO GMSDRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       GMSDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, GMSDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, GMSDRV
*    +           LFNDAF,LFNDEF                                          GMSDRV
C                                                                       GMSDRV
C  GAMESS common blocks:                                                GMSDRV
C                                                                       GMSDRV
*     PARAMETER (MXGTOT=5000, MXSH=1000, MXATM=50)                      GMSDRV
*     COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(99)                 GMSDRV
*     COMMON /INFOA / NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(MXATM),C(3,MXATM) GMSDRV
*     COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK                 GMSDRV
*     COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTG76                   GMSDRV
*     LOGICAL PACK2E                                                    GMSDRV
C                                                                       GMSDRV
*     DIMENSION A(1),IA(NDIM)                                           GMSDRV
C                                                                       GMSDRV
*     DATA TWO/2.0D0/                                                   GMSDRV
C                                                                       GMSDRV
C-----------------------------------------------------------------------GMSDRV
C                                                                       GMSDRV
C  SET POINTERS:                                                        GMSDRV
C                                                                       GMSDRV
*     NTRI = NDIM*(NDIM+1)/2                                            GMSDRV
*     NSQ  = NDIM*NDIM                                                  GMSDRV
C                                                                       GMSDRV
C  A(IPT1)   ---   Density matrix (alpha)                               GMSDRV
C  A(IPT2)   ---   Density matrix (beta)                                GMSDRV
C  A(IPT3)   ---   Fock matrix (alpha)                                  GMSDRV
C  A(IPT4)   ---   Fock matrix (beta)                                   GMSDRV
C  A(IPT5)   ---   Core Hamiltonian matrix                              GMSDRV
C  A(IPT6)   ---   Integral buffer, scratch                             GMSDRV
C  A(IPT7)   ---   Integral buffer                                      GMSDRV
C  A(IPT8)   ---   Integral buffer                                      GMSDRV
C                                                                       GMSDRV
*     IPT1 = 1    + NDIM                                                GMSDRV
*     IPT2 = IPT1 + NTRI                                                GMSDRV
*     IPT3 = IPT2 + NTRI                                                GMSDRV
*     IPT4 = IPT3 + NTRI                                                GMSDRV
*     IPT5 = IPT4 + NTRI                                                GMSDRV
*     IPT6 = IPT5 + NTRI                                                GMSDRV
*     IPT7 = IPT6 + NINTMX                                              GMSDRV
*     IPT8 = IPT7 + NINTMX                                              GMSDRV
C                                                                       GMSDRV
C  SET UP ADDRESSING ARRAY:                                             GMSDRV
C                                                                       GMSDRV
*     DO 50 I = 1,NDIM                                                  GMSDRV
*       IA(I) = (I*(I-1))/2                                             GMSDRV
*  50 CONTINUE                                                          GMSDRV
C                                                                       GMSDRV
C  REWIND INTEGRAL FILE:                                                GMSDRV
C                                                                       GMSDRV
*     REWIND IS                                                         GMSDRV
C                                                                       GMSDRV
C  OPEN THE NBO DIRECT ACCESS FILE                                      GMSDRV
C                                                                       GMSDRV
*     NEW = .FALSE.                                                     GMSDRV
*     CALL NBOPEN(NEW,ERROR)                                            GMSDRV
*     IF(ERROR) THEN                                                    GMSDRV
*       WRITE(LFNPR,900)                                                GMSDRV
*       STOP                                                            GMSDRV
*     END IF                                                            GMSDRV
C                                                                       GMSDRV
C  CALCULATE NUCLEAR REPULSION ENERGY:                                  GMSDRV
C                                                                       GMSDRV
*     EN = ENUC(NAT,ZAN,C)                                              GMSDRV
*     IF(UHF) THEN                                                      GMSDRV
C                                                                       GMSDRV
C  UHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTGMSDRV
C      AND SYMMETRIZE THE SKELETON FOCK MATRIX:                         GMSDRV
C                                                                       GMSDRV
*       ALPHA = .TRUE.                                                  GMSDRV
*       BETA = .FALSE.                                                  GMSDRV
*       CALL FENEWD(A(IPT1))                                            GMSDRV
*       ALPHA = .FALSE.                                                 GMSDRV
*       BETA = .TRUE.                                                   GMSDRV
*       CALL FENEWD(A(IPT2))                                            GMSDRV
*       CALL HSTARU(A(IPT1),A(IPT3),A(IPT2),A(IPT4),A(IPT7),A(IPT8),    GMSDRV
*    +              A(IPT6),A(IPT7),A(IPT8),NINTMX,IA,NOPK)             GMSDRV
*       CALL SYMH(A(IPT3),A(IPT6),IA)                                   GMSDRV
*       CALL SYMH(A(IPT4),A(IPT6),IA)                                   GMSDRV
C                                                                       GMSDRV
C  READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY:         GMSDRV
C                                                                       GMSDRV
*       CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11,NAV)                      GMSDRV
*       CALL VADD(A(IPT3),1,A(IPT5),1,A(IPT3),1,NTRI)                   GMSDRV
*       CALL VADD(A(IPT4),1,A(IPT5),1,A(IPT4),1,NTRI)                   GMSDRV
*       EHFA = TRACEP(A(IPT1),A(IPT5),NBAS) +                           GMSDRV
*    +         TRACEP(A(IPT1),A(IPT3),NBAS)                             GMSDRV
*       EHFB = TRACEP(A(IPT2),A(IPT5),NBAS) +                           GMSDRV
*    +         TRACEP(A(IPT2),A(IPT4),NBAS)                             GMSDRV
*       EHF = (EHFA + EHFB)/TWO                                         GMSDRV
*       EDEL = EHF + EN                                                 GMSDRV
C                                                                       GMSDRV
C  RHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTGMSDRV
C      AND SYMMETRIZE THE SKELETON FOCK MATRIX:                         GMSDRV
C                                                                       GMSDRV
*     ELSE                                                              GMSDRV
*       CALL FENEWD(A(IPT1))                                            GMSDRV
*       CALL HSTAR(A(IPT1),A(IPT3),A(IPT6),A(IPT7),NINTMX,IA,NOPK)      GMSDRV
*       CALL SYMH(A(IPT3),A(IPT6),IA)                                   GMSDRV
C                                                                       GMSDRV
C  READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY:         GMSDRV
C                                                                       GMSDRV
*       CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11,NAV)                      GMSDRV
*       CALL VADD(A(IPT3),1,A(IPT5),1,A(IPT3),1,NTRI)                   GMSDRV
*       EHF1 = TRACEP(A(IPT1),A(IPT5),NDIM)                             GMSDRV
*       EHF2 = TRACEP(A(IPT1),A(IPT3),NDIM)                             GMSDRV
*       EHF = (EHF1 + EHF2)/TWO                                         GMSDRV
*       EDEL = EHF + EN                                                 GMSDRV
*     END IF                                                            GMSDRV
C                                                                       GMSDRV
C  SAVE THE DELETION ENERGY ON THE NBO DIRECT ACCESS FILE AND CLOSE THE GMSDRV
C  FILE:                                                                GMSDRV
C                                                                       GMSDRV
*     CALL SVE0(EDEL)                                                   GMSDRV
*     SEQ = .FALSE.                                                     GMSDRV
*     CALL NBCLOS(SEQ)                                                  GMSDRV
*     RETURN                                                            GMSDRV
C                                                                       GMSDRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ',        GMSDRV
*    + 'subroutine DELSCF.')                                            GMSDRV
*     END                                                               GMSDRV
C***********************************************************************GMSDRV
C                                                                       GMSDRV
C           E N D    O F    G M S N B O    R O U T I N E S              GMSDRV
C                                                                       GMSDRV
C***********************************************************************GMSDRV
C***********************************************************************HNDDRV
C                                                                       HNDDRV
C                                                                       HNDDRV
C                          H  N  D  N  B  O                             HNDDRV
C                                                                       HNDDRV
C                                                                       HNDDRV
C                     HONDO VERSION OF NBO PROGRAM                      HNDDRV
C                                                                       HNDDRV
C                                                                       HNDDRV
C  DRIVER ROUTINES:                                                     HNDDRV
C                                                                       HNDDRV
C      SUBROUTINE RUNNBO                                                HNDDRV
C      SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                             HNDDRV
C      SUBROUTINE DELSCF(A)                                             HNDDRV
C                                                                       HNDDRV
C***********************************************************************HNDDRV
*     SUBROUTINE RUNNBO                                                 HNDDRV
C***********************************************************************HNDDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         HNDDRV
*     DIMENSION NBOOPT(10)                                              HNDDRV
C                                                                       HNDDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, HNDDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, HNDDRV
*    +           LFNDAF,LFNDEF                                          HNDDRV
C                                                                       HNDDRV
C  HONDO Common Block:                                                  HNDDRV
C                                                                       HNDDRV
*     COMMON/IOFILE/IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(99)                  HNDDRV
*     COMMON/MEMORY/MAXCOR,MAXLCM                                       HNDDRV
*     COMMON/SCM/CORE(1)                                                HNDDRV
C                                                                       HNDDRV
*     LFNIN = IR                                                        HNDDRV
*     LFNPR = IW                                                        HNDDRV
C                                                                       HNDDRV
C  Set NBO options.                                                     HNDDRV
C                                                                       HNDDRV
*     NBOOPT(1)  =  0                                                   HNDDRV
*     NBOOPT(2)  =  0                                                   HNDDRV
*     NBOOPT(3)  =  0                                                   HNDDRV
*     NBOOPT(4)  =  0                                                   HNDDRV
*     NBOOPT(5)  =  0                                                   HNDDRV
*     NBOOPT(6)  =  0                                                   HNDDRV
*     NBOOPT(7)  =  0                                                   HNDDRV
*     NBOOPT(8)  =  0                                                   HNDDRV
*     NBOOPT(9)  =  0                                                   HNDDRV
*     NBOOPT(10) =  7                                                   HNDDRV
C                                                                       HNDDRV
C  Perform the NPA/NBO/NLMO analyses.                                   HNDDRV
C                                                                       HNDDRV
*     CALL NBO(CORE,MAXCOR,NBOOPT)                                      HNDDRV
C                                                                       HNDDRV
C  Perform the energetic analysis.                                      HNDDRV
C                                                                       HNDDRV
*  10 NBOOPT(1) = 2                                                     HNDDRV
*     CALL NBOEAN(CORE,MAXCOR,NBOOPT,IDONE)                             HNDDRV
*     IF(IDONE.NE.0) GOTO 20                                            HNDDRV
*     CALL DELSCF(CORE)                                                 HNDDRV
*     NBOOPT(1) = 3                                                     HNDDRV
*     CALL NBOEAN(CORE,MAXCOR,NBOOPT,IDONE)                             HNDDRV
*     GOTO 10                                                           HNDDRV
C                                                                       HNDDRV
*  20 RETURN                                                            HNDDRV
*     END                                                               HNDDRV
C***********************************************************************HNDDRV
*     SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                              HNDDRV
C***********************************************************************HNDDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         HNDDRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             HNDDRV
C                                                                       HNDDRV
C ----------------------------------------------------------------------HNDDRV
C                                                                       HNDDRV
C   This routine fetchs basis set information from the HONDO common     HNDDRV
C  blocks and stores it in the NBO common blocks and direct access file HNDDRV
C  (DAF) for use by the NBO analysis.                                   HNDDRV
C                                                                       HNDDRV
C ----------------------------------------------------------------------HNDDRV
C                                                                       HNDDRV
C  Routine FEAOIN accesses the following records of the dictionary file:HNDDRV
C                                                                       HNDDRV
C          2  ---   Total energy                                        HNDDRV
C         12  ---   AO overlap matrix                                   HNDDRV
C         14  ---   AO Fock matrix (alpha)                              HNDDRV
C         15  ---   AO to MO transformation matrix (alpha)              HNDDRV
C         16  ---   AO density matrix (bond order matrix) (alpha)       HNDDRV
C         18  ---   AO Fock matrix (beta)                               HNDDRV
C         19  ---   AO to MO transformation matrix (beta)               HNDDRV
C         20  ---   AO density matrix (bond order matrix) (beta)        HNDDRV
C         33  ---   X dipole integrals                                  HNDDRV
C         34  ---   Y dipole integrals                                  HNDDRV
C         35  ---   Z dipole integrals                                  HNDDRV
C                                                                       HNDDRV
C ----------------------------------------------------------------------HNDDRV
C                                                                       HNDDRV
C  NBO Common blocks                                                    HNDDRV
C                                                                       HNDDRV
C                                                                       HNDDRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               HNDDRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO HNDDRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       HNDDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       HNDDRV
*     COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,        HNDDRV
*    + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    HNDDRV
*    + JCORE,JPRINT(60)                                                 HNDDRV
*     COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)                             HNDDRV
*     COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), HNDDRV
*    +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)                     HNDDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, HNDDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, HNDDRV
*    +           LFNDAF,LFNDEF                                          HNDDRV
C                                                                       HNDDRV
C  HONDO Common blocks                                                  HNDDRV
C                                                                       HNDDRV
*     COMMON/IOFILE/IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(99)                  HNDDRV
*     COMMON/INFOA/NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(50),C(3,50)          HNDDRV
*     COMMON/MOLNUC/NUC(50)                                             HNDDRV
*     COMMON/NSHEL/EX(440),CS(440),CP(440),CD(440),CF(440),CG(440),     HNDDRV
*    *             KSTART(120),KATOM(120),KTYPE(120),KNG(120),          HNDDRV
*    *             KLOC(120),KMIN(120),KMAX(120),NSHELL                 HNDDRV
*     COMMON/RUNLAB/TITLE(10),ANAM(50),BNAM(50),BFLAB(512)              HNDDRV
*     COMMON/SCFOPT/SCFTYP                                              HNDDRV
*     COMMON/WFNOPT/WFNTYP                                              HNDDRV
C                                                                       HNDDRV
*     DIMENSION LABELS(20),WFNS(6)                                      HNDDRV
*     LOGICAL WSTATE(6,6),SOME                                          HNDDRV
*     DIMENSION CM(3)                                                   HNDDRV
C                                                                       HNDDRV
C  Obtain the following information:                                    HNDDRV
C                                                                       HNDDRV
C    ROHF        =.TRUE. If RHF open shell wavefunction                 HNDDRV
C                =.FALSE. otherwise                                     HNDDRV
C                                                                       HNDDRV
C    UHF         =.TRUE. If UHF wavefunction                            HNDDRV
C                =.FALSE. otherwise                                     HNDDRV
C                                                                       HNDDRV
C    AUHF        =.TRUE. If spin-annihilated UHF wavefunction           HNDDRV
C                =.FALSE. otherwise                                     HNDDRV
C                                                                       HNDDRV
C    CI          =.TRUE. If CI wavefunction                             HNDDRV
C                =.FALSE. otherwise                                     HNDDRV
C                                                                       HNDDRV
C    OPEN        =.TRUE. If open shell wavefunction                     HNDDRV
C                =.FALSE. otherwise                                     HNDDRV
C                                                                       HNDDRV
C    COMPLX      =.TRUE. If complex wavefunction                        HNDDRV
C                =.FALSE. otherwise                                     HNDDRV
C                (Note: The program is not capable of handling this.)   HNDDRV
C                                                                       HNDDRV
C    NATOMS      Number of atomic centers                               HNDDRV
C                                                                       HNDDRV
C    NDIM        Dimension of matrices (overlap and density) passed to pHNDDRV
C                                                                       HNDDRV
C    NBAS        Number of basis functions (.le.NDIM)                   HNDDRV
C                                                                       HNDDRV
C    IPSEUD      Set to zero if no pseudopotentials are used.           HNDDRV
C                Set to one if pseudopotentials are used.               HNDDRV
C                                                                       HNDDRV
C    IWCUBF      This pertains only basis sets with F functions.        HNDDRV
C                                                                       HNDDRV
C                If cartesian F functions are input, set IWCUBF to:     HNDDRV
C                    0,  if these are to be transformed to the          HNDDRV
C                        standard set of pure F functions               HNDDRV
C                    1,  if these are to be transformed to the          HNDDRV
C                        cubic set of pure F functions                  HNDDRV
C                                                                       HNDDRV
C                If pure F functions are input, set to IWCUBF to:       HNDDRV
C                    0,  if these are standard F functions              HNDDRV
C                    1,  if these are cubic F functions                 HNDDRV
C                                                                       HNDDRV
C    IATNO(I),I=1,NATOMS                                                HNDDRV
C                List of atomic numbers                                 HNDDRV
C                                                                       HNDDRV
C    LCTR(I),I=1,NBAS                                                   HNDDRV
C                List of atomic centers of the basis functions          HNDDRV
C                (LCTR(3)=2 if basis function 3 is on atom 2)           HNDDRV
C                                                                       HNDDRV
C    LANG(I),I=1,NBAS                                                   HNDDRV
C                List of angular symmetry information for the basis funcHNDDRV
C                                                                       HNDDRV
C LABELS array contains NBO labels for the atomic orbitals              HNDDRV
C                                                                       HNDDRV
*     DATA LABELS /                                                     HNDDRV
C                                                                       HNDDRV
C          S                                                            HNDDRV
C          ---                                                          HNDDRV
*    +     1,                                                           HNDDRV
C                                                                       HNDDRV
C          Px    Py    Pz                                               HNDDRV
C          ---   ---   ---                                              HNDDRV
*    +     101,  102,  103,                                             HNDDRV
C                                                                       HNDDRV
C          Dxx   Dyy   Dzz   Dxy   Dxz   Dyz                            HNDDRV
C          ---   ---   ---   ---   ---   ---                            HNDDRV
*    +     201,  204,  206,  202,  203,  205,                           HNDDRV
C                                                                       HNDDRV
C          Fxxx  Fyyy  Fzzz  Fxxy  Fxxz  Fxyy  Fxyz  Fxzz  Fyyz  Fyzz   HNDDRV
C          ----  ----  ----  ----  ----  ----  ----  ----  ----  ----   HNDDRV
*    +     301,  307,  310,  302,  303,  304,  305,  306,  308,  309 /  HNDDRV
C                                                                       HNDDRV
C                                                                       HNDDRV
C  WSTATE array contains the values which should be set in the NBO commoHNDDRV
C  NBFLAG depending on wavefunction.                                    HNDDRV
C                                                                       HNDDRV
*     DATA WSTATE /                                                     HNDDRV
C                ROHF      UHF      CI      OPEN     MCSCF    AUHF      HNDDRV
C              -------   -------  ------   ------   ------   ------     HNDDRV
C Wavefunction                                                          HNDDRV
C        RHF                                                            HNDDRV
*    +         .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE.,    HNDDRV
C        UHF                                                            HNDDRV
*    +         .FALSE., .TRUE. , .FALSE., .TRUE. , .FALSE., .FALSE.,    HNDDRV
C        ROHF                                                           HNDDRV
*    +         .TRUE. , .FALSE., .FALSE., .FALSE., .FALSE., .FALSE.,    HNDDRV
C        GVB                                                            HNDDRV
*    +         .TRUE.,  .FALSE., .FALSE., .FALSE., .FALSE., .FALSE.,    HNDDRV
C        MCSCF                                                          HNDDRV
*    +         .FALSE., .FALSE., .FALSE., .FALSE., .TRUE. , .FALSE.,    HNDDRV
C        CI                                                             HNDDRV
*    +         .FALSE., .FALSE., .TRUE. , .FALSE., .FALSE., .FALSE./    HNDDRV
C                                                                       HNDDRV
C                                                                       HNDDRV
*     NAMELIST /WFN/ WFNFLG                                             HNDDRV
*     DATA WFNFLG /0/                                                   HNDDRV
*     DATA ZERO/0.0D0/                                                  HNDDRV
*     DATA TOANG/0.529177249/                                           HNDDRV
C                                                                       HNDDRV
C  Wavefunction types:                                                  HNDDRV
C                                                                       HNDDRV
*     DATA SCFWFN,CIWFN/'SCF     ','MCCI    '/                          HNDDRV
*     DATA WFNS  /8HRHF     ,                                           HNDDRV
*    +            8HUHF     ,                                           HNDDRV
*    +            8HROHF    ,                                           HNDDRV
*    +            8HGVB     ,                                           HNDDRV
*    +            8HMCSCF   ,                                           HNDDRV
*    +            8HCI      /                                           HNDDRV
C                                                                       HNDDRV
C  Read in type of wavefunction from the $WFN namelist.                 HNDDRV
C                                                                       HNDDRV
*     REWIND IR                                                         HNDDRV
*     READ(IR,WFN,END=3)                                                HNDDRV
*     GO TO 4                                                           HNDDRV
*   3 CONTINUE                                                          HNDDRV
*     WRITE(IW,900)                                                     HNDDRV
*     STOP                                                              HNDDRV
*   4 CONTINUE                                                          HNDDRV
C                                                                       HNDDRV
C  Store job title on NBODAF:                                           HNDDRV
C                                                                       HNDDRV
*     DO 5 I = 1,10                                                     HNDDRV
*       CORE(I) = TITLE(I)                                              HNDDRV
*   5 CONTINUE                                                          HNDDRV
*     NFILE = 2                                                         HNDDRV
*     CALL NBWRIT(CORE,10,NFILE)                                        HNDDRV
C                                                                       HNDDRV
C  Get the number of atoms from NAT and store the atomic numbers in     HNDDRV
C  IATNO and nuclear charges in IZNUC.  (NOTE: atomic numbers and       HNDDRV
C  nuclear charges may not be equivalent if effective core potentials   HNDDRV
C  (ECP) are used.)                                                     HNDDRV
C                                                                       HNDDRV
*     NATOMS = NAT                                                      HNDDRV
*     DO 10 I = 1,NAT                                                   HNDDRV
*       IATNO(I) = NUC(I)                                               HNDDRV
*       IZNUC(I) = ZAN(I)                                               HNDDRV
*       IF(IATNO(I).NE.IZNUC(I)) IPSEUD = 1                             HNDDRV
*  10 CONTINUE                                                          HNDDRV
C                                                                       HNDDRV
C  KATOM array contains which atom the shell is on, KMIN and KMAX       HNDDRV
C  determine the components in the shell by pointing to a range in the  HNDDRV
C  LABELS array:                                                        HNDDRV
C                                                                       HNDDRV
*     II = 0                                                            HNDDRV
*     DO 30 I = 1,NSHELL                                                HNDDRV
*       IATOM = KATOM(I)                                                HNDDRV
*       MIN   = KMIN(I)                                                 HNDDRV
*       MAX   = KMAX(I)                                                 HNDDRV
*       DO 20 J = MIN,MAX                                               HNDDRV
*         II = II + 1                                                   HNDDRV
*         LCTR(II) = IATOM                                              HNDDRV
*         LANG(II) = LABELS(J)                                          HNDDRV
*  20   CONTINUE                                                        HNDDRV
*  30 CONTINUE                                                          HNDDRV
C                                                                       HNDDRV
*     NBAS  = II                                                        HNDDRV
*     NDIM  = NBAS                                                      HNDDRV
C                                                                       HNDDRV
C  Inititialize various NBO options depending upon the wavefunction     HNDDRV
C  type and basis set type.                                             HNDDRV
C                                                                       HNDDRV
C  First, turn off the complex orbitals, indicate that the pure set     HNDDRV
C  of F functions is desired when transforming from the cartesian set.  HNDDRV
C                                                                       HNDDRV
*     COMPLX = .FALSE.                                                  HNDDRV
*     IWCUBF = 0                                                        HNDDRV
*     ORTHO  = .FALSE.                                                  HNDDRV
C                                                                       HNDDRV
C  Next set up the wavefunction switches.                               HNDDRV
C                                                                       HNDDRV
*     IF(WFNTYP.EQ.SCFWFN) THEN                                         HNDDRV
*       IF(WFNFLG.EQ.0) THEN                                            HNDDRV
*         IF(SCFTYP.EQ.WFNS(1)) ISTATE = 1                              HNDDRV
*         IF(SCFTYP.EQ.WFNS(2)) ISTATE = 2                              HNDDRV
*         IF(SCFTYP.EQ.WFNS(4)) ISTATE = 4                              HNDDRV
*         IF(SCFTYP.EQ.WFNS(1).AND.MUL.GE.2) ISTATE = 3                 HNDDRV
*         GOTO 60                                                       HNDDRV
*       END IF                                                          HNDDRV
*       IF(WFNFLG.EQ.5) THEN                                            HNDDRV
*         ISTATE = 6                                                    HNDDRV
*         GOTO 60                                                       HNDDRV
*       END IF                                                          HNDDRV
*       IF(WFNFLG.EQ.6) THEN                                            HNDDRV
*         ISTATE = 6                                                    HNDDRV
*         GOTO 60                                                       HNDDRV
*       END IF                                                          HNDDRV
*     END IF                                                            HNDDRV
*     IF(WFNTYP.EQ.CIWFN) THEN                                          HNDDRV
*       IF(WFNFLG.EQ.1) ISTATE = 5                                      HNDDRV
*       IF(WFNFLG.EQ.2) ISTATE = 6                                      HNDDRV
*       IF(WFNFLG.EQ.3) ISTATE = 6                                      HNDDRV
*       IF(WFNFLG.EQ.4) ISTATE = 6                                      HNDDRV
*       GOTO 60                                                         HNDDRV
*     END IF                                                            HNDDRV
*     STOP 'Unknown WFNTYP'                                             HNDDRV
C                                                                       HNDDRV
*  60 ROHF  = WSTATE(1,ISTATE)                                          HNDDRV
*     UHF   = WSTATE(2,ISTATE)                                          HNDDRV
*     CI    = WSTATE(3,ISTATE)                                          HNDDRV
*     OPEN  = WSTATE(4,ISTATE)                                          HNDDRV
*     MCSCF = WSTATE(5,ISTATE)                                          HNDDRV
*     AUHF  = WSTATE(6,ISTATE)                                          HNDDRV
C                                                                       HNDDRV
C  No Fock matrices for ROHF, MCSCF, or CI wavefunctions:               HNDDRV
C                                                                       HNDDRV
*     IF (ROHF.OR.MCSCF.OR.CI) IWFOCK = 0                               HNDDRV
C                                                                       HNDDRV
C  Expectation values of the Fock operator are in atomic units:         HNDDRV
C                                                                       HNDDRV
*     MUNIT = 0                                                         HNDDRV
C                                                                       HNDDRV
C  Store NATOMS, NDIM, NBAS, MUNIT, wavefunction flags, ISWEAN:         HNDDRV
C                                                                       HNDDRV
*     ICORE(1)  = NATOMS                                                HNDDRV
*     ICORE(2)  = NDIM                                                  HNDDRV
*     ICORE(3)  = NBAS                                                  HNDDRV
*     ICORE(4)  = MUNIT                                                 HNDDRV
*     ICORE(5)  = 0                                                     HNDDRV
*     IF(ROHF)  ICORE(5)  = 1                                           HNDDRV
*     ICORE(6)  = 0                                                     HNDDRV
*     IF(UHF)   ICORE(6)  = 1                                           HNDDRV
*     ICORE(7)  = 0                                                     HNDDRV
*     IF(CI)    ICORE(7)  = 1                                           HNDDRV
*     ICORE(8)  = 0                                                     HNDDRV
*     IF(OPEN)  ICORE(8)  = 1                                           HNDDRV
*     ICORE(9)  = 0                                                     HNDDRV
*     IF(MCSCF) ICORE(9)  = 1                                           HNDDRV
*     ICORE(10) = 0                                                     HNDDRV
*     IF(AUHF)  ICORE(10) = 1                                           HNDDRV
*     ICORE(11) = 0                                                     HNDDRV
*     IF(ORTHO) ICORE(11) = 1                                           HNDDRV
*     ICORE(12) = 1                                                     HNDDRV
*     NFILE = 3                                                         HNDDRV
*     CALL NBWRIT(ICORE,12,NFILE)                                       HNDDRV
C                                                                       HNDDRV
C  Store IATNO, IZNUC, LCTR, and LANG on NBO DAF:                       HNDDRV
C                                                                       HNDDRV
*     II = 0                                                            HNDDRV
*     DO 70 I = 1,NATOMS                                                HNDDRV
*       II = II + 1                                                     HNDDRV
*       ICORE(II) = IATNO(I)                                            HNDDRV
*  70 CONTINUE                                                          HNDDRV
*     DO 80 I = 1,NATOMS                                                HNDDRV
*       II = II + 1                                                     HNDDRV
*       ICORE(II) = IZNUC(I)                                            HNDDRV
*  80 CONTINUE                                                          HNDDRV
*     DO 90 I = 1,NBAS                                                  HNDDRV
*       II = II + 1                                                     HNDDRV
*       ICORE(II) = LCTR(I)                                             HNDDRV
*  90 CONTINUE                                                          HNDDRV
*     DO 95 I = 1,NBAS                                                  HNDDRV
*       II = II + 1                                                     HNDDRV
*       ICORE(II) = LANG(I)                                             HNDDRV
*  95 CONTINUE                                                          HNDDRV
*     NFILE = 4                                                         HNDDRV
*     CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE)                          HNDDRV
C                                                                       HNDDRV
C  Fetch the total energy from the dictionary file and store it on the  HNDDRV
C  NBO DAF:                                                             HNDDRV
C                                                                       HNDDRV
*     NFILE = 2                                                         HNDDRV
*     CALL DAREAD(IDAF,IODA,CORE,3,NFILE)                               HNDDRV
*     CORE(1) = CORE(3)                                                 HNDDRV
*     CORE(2) = CORE(3)                                                 HNDDRV
*     NFILE = 8                                                         HNDDRV
*     CALL NBWRIT(CORE,2,NFILE)                                         HNDDRV
C                                                                       HNDDRV
C  Find the center of mass for this molecule:                           HNDDRV
C                                                                       HNDDRV
*     NCALL = 1                                                         HNDDRV
*     SOME = .FALSE.                                                    HNDDRV
*     CALL DIPAMS(CORE,NCALL,NCODE,SOME)                                HNDDRV
*     SUM = ZERO                                                        HNDDRV
*     DO 96 I = 1,3                                                     HNDDRV
*       CM(I) = ZERO                                                    HNDDRV
*  96 CONTINUE                                                          HNDDRV
*     DO 98 IAT = 1,NATOMS                                              HNDDRV
*       SUM = SUM + CORE(IAT)                                           HNDDRV
*       DO 97 I = 1,3                                                   HNDDRV
*         CM(I) = CM(I) + CORE(IAT) * C(I,IAT)                          HNDDRV
*  97   CONTINUE                                                        HNDDRV
*  98 CONTINUE                                                          HNDDRV
*     IF(ABS(SUM).GT.1.0D-5) THEN                                       HNDDRV
*       DO 99 I = 1,3                                                   HNDDRV
*         CM(I) = CM(I) / SUM                                           HNDDRV
*  99   CONTINUE                                                        HNDDRV
*     END IF                                                            HNDDRV
C                                                                       HNDDRV
C  Store the atomic coordinates on the NBO DAF: (Note that these        HNDDRV
C  coordinates are used in the calculation of dipole moments.)          HNDDRV
C                                                                       HNDDRV
*     I = 0                                                             HNDDRV
*     DO 110 IAT = 1,NATOMS                                             HNDDRV
*       DO 100 K = 1,3                                                  HNDDRV
*         I = I + 1                                                     HNDDRV
*         CORE(I) = (C(K,IAT) - CM(K)) * TOANG                          HNDDRV
* 100   CONTINUE                                                        HNDDRV
* 110 CONTINUE                                                          HNDDRV
*     NFILE = 9                                                         HNDDRV
*     CALL NBWRIT(CORE,3*NATOMS,NFILE)                                  HNDDRV
C                                                                       HNDDRV
C  Store the overlap matrix on the NBODAF:                              HNDDRV
C                                                                       HNDDRV
*     NFILE = 12                                                        HNDDRV
*     L2 = NDIM*(NDIM+1)/2                                              HNDDRV
*     CALL DAREAD(IDAF,IODA,CORE,L2,NFILE)                              HNDDRV
*     NFILE = 10                                                        HNDDRV
*     CALL NBWRIT(CORE,L2,NFILE)                                        HNDDRV
C                                                                       HNDDRV
C  Store the density matrices on the NBODAF:                            HNDDRV
C                                                                       HNDDRV
*     NFILE = 16                                                        HNDDRV
*     L2 = NDIM*(NDIM+1)/2                                              HNDDRV
*     CALL DAREAD(IDAF,IODA,CORE,L2,NFILE)                              HNDDRV
*     NFILE = 20                                                        HNDDRV
*     CALL NBWRIT(CORE,L2,NFILE)                                        HNDDRV
C                                                                       HNDDRV
*     IF(OPEN) THEN                                                     HNDDRV
*       NFILE = 20                                                      HNDDRV
*       CALL DAREAD(IDAF,IODA,CORE,L2,NFILE)                            HNDDRV
*       NFILE = 21                                                      HNDDRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      HNDDRV
*     END IF                                                            HNDDRV
C                                                                       HNDDRV
C  Store the Fock matrices on the NBODAF:                               HNDDRV
C                                                                       HNDDRV
*     IF(IWFOCK.NE.0) THEN                                              HNDDRV
*       NFILE = 14                                                      HNDDRV
*       L2 = NDIM*(NDIM+1)/2                                            HNDDRV
*       IF(IODA(NFILE).GT.0) THEN                                       HNDDRV
*         CALL DAREAD(IDAF,IODA,CORE,L2,NFILE)                          HNDDRV
*         NFILE = 30                                                    HNDDRV
*         CALL NBWRIT(CORE,L2,NFILE)                                    HNDDRV
*       END IF                                                          HNDDRV
C                                                                       HNDDRV
*       IF(OPEN) THEN                                                   HNDDRV
*         NFILE = 18                                                    HNDDRV
*         IF(IODA(NFILE).GT.0) THEN                                     HNDDRV
*           CALL DAREAD(IDAF,IODA,CORE,L2,NFILE)                        HNDDRV
*           NFILE = 31                                                  HNDDRV
*           CALL NBWRIT(CORE,L2,NFILE)                                  HNDDRV
*         END IF                                                        HNDDRV
*       END IF                                                          HNDDRV
*     END IF                                                            HNDDRV
C                                                                       HNDDRV
C  Store the AO to MO transformation matrices on the NBODAF:            HNDDRV
C                                                                       HNDDRV
*     IF(IODA(15).NE.0) THEN                                            HNDDRV
*       NFILE = 15                                                      HNDDRV
*       L3 = NDIM*NDIM                                                  HNDDRV
*       CALL DAREAD(IDAF,IODA,CORE,L3,NFILE)                            HNDDRV
*       NFILE = 40                                                      HNDDRV
*       CALL NBWRIT(CORE,L3,NFILE)                                      HNDDRV
*       IF(OPEN) THEN                                                   HNDDRV
*         NFILE = 19                                                    HNDDRV
*         CALL DAREAD(IDAF,IODA,CORE,L3,NFILE)                          HNDDRV
*         NFILE = 41                                                    HNDDRV
*         CALL NBWRIT(CORE,L3,NFILE)                                    HNDDRV
*       END IF                                                          HNDDRV
*     END IF                                                            HNDDRV
C                                                                       HNDDRV
C  Store the x,y,z dipole integrals on the NBODAF:                      HNDDRV
C                                                                       HNDDRV
*     IF(IODA(33).NE.0.AND.IODA(34).NE.0.AND.IODA(35).NE.0) THEN        HNDDRV
*       L2 = NDIM*(NDIM+1)/2                                            HNDDRV
*       NFILE = 33                                                      HNDDRV
*       CALL DAREAD(IDAF,IODA,CORE,L2,NFILE)                            HNDDRV
*       DO 120 I = 1,L2                                                 HNDDRV
*         CORE(I) = CORE(I) * TOANG                                     HNDDRV
* 120   CONTINUE                                                        HNDDRV
*       NFILE = 50                                                      HNDDRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      HNDDRV
*       NFILE = 34                                                      HNDDRV
*       CALL DAREAD(IDAF,IODA,CORE,L2,NFILE)                            HNDDRV
*       DO 130 I = 1,L2                                                 HNDDRV
*         CORE(I) = CORE(I) * TOANG                                     HNDDRV
* 130   CONTINUE                                                        HNDDRV
*       NFILE = 51                                                      HNDDRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      HNDDRV
*       NFILE = 35                                                      HNDDRV
*       CALL DAREAD(IDAF,IODA,CORE,L2,NFILE)                            HNDDRV
*       DO 140 I = 1,L2                                                 HNDDRV
*         CORE(I) = CORE(I) * TOANG                                     HNDDRV
* 140   CONTINUE                                                        HNDDRV
*       NFILE = 52                                                      HNDDRV
*       CALL NBWRIT(CORE,L2,NFILE)                                      HNDDRV
*     END IF                                                            HNDDRV
C                                                                       HNDDRV
C  Store the AO basis set info on the NBO DAF:  (Note that two integers HNDDRV
C  and three integer arrays are stored first.  Also remember that ICORE HNDDRV
C  and CORE occupy the same memory.)                                    HNDDRV
C                                                                       HNDDRV
*     NEXP = 0                                                          HNDDRV
*     DO 150 I = 1,440                                                  HNDDRV
*       IF(EX(I).EQ.ZERO) GOTO 150                                      HNDDRV
*       NEXP = I                                                        HNDDRV
* 150 CONTINUE                                                          HNDDRV
*     DO 160 I = 1,2+3*NSHELL+5*NEXP                                    HNDDRV
*       CORE(I) = ZERO                                                  HNDDRV
* 160 CONTINUE                                                          HNDDRV
*     ICORE(1) = NSHELL                                                 HNDDRV
*     ICORE(2) = NEXP                                                   HNDDRV
C                                                                       HNDDRV
C  NCOMP(I) -- the number of components in the Ith shell:               HNDDRV
C                                                                       HNDDRV
*     II = 2                                                            HNDDRV
*     DO 170 I = 1,NSHELL                                               HNDDRV
*       II = II + 1                                                     HNDDRV
*       ICORE(II) = KMAX(I) - KMIN(I) + 1                               HNDDRV
* 170 CONTINUE                                                          HNDDRV
C                                                                       HNDDRV
C  NPRIM(I) -- the number of gaussian primitives in the Ith shell:      HNDDRV
C                                                                       HNDDRV
*     DO 180 I = 1,NSHELL                                               HNDDRV
*       II = II + 1                                                     HNDDRV
*       ICORE(II) = KNG(I)                                              HNDDRV
* 180 CONTINUE                                                          HNDDRV
C                                                                       HNDDRV
C  NPTR(I) -- pointer for the Ith shell into the gaussian parameters,   HNDDRV
C             EXP, CS, CP, etc.:                                        HNDDRV
C                                                                       HNDDRV
*     DO 190 I = 1,NSHELL                                               HNDDRV
*       II = II + 1                                                     HNDDRV
*       ICORE(II) = KSTART(I)                                           HNDDRV
* 190 CONTINUE                                                          HNDDRV
C                                                                       HNDDRV
C  EXP(I) -- orbital exponents indexed by NPTR:                         HNDDRV
C                                                                       HNDDRV
*     DO 200 I = 1,NEXP                                                 HNDDRV
*       II = II + 1                                                     HNDDRV
*       CORE(II) = EX(I)                                                HNDDRV
* 200 CONTINUE                                                          HNDDRV
C                                                                       HNDDRV
C  CS,CP,CD,CF -- orbital coefficients:                                 HNDDRV
C                                                                       HNDDRV
*     DO 210 I = 1,NEXP                                                 HNDDRV
*       II = II + 1                                                     HNDDRV
*       CORE(II) = CS(I)                                                HNDDRV
* 210 CONTINUE                                                          HNDDRV
*     DO 220 I = 1,NEXP                                                 HNDDRV
*       II = II + 1                                                     HNDDRV
*       CORE(II) = CP(I)                                                HNDDRV
* 220 CONTINUE                                                          HNDDRV
*     DO 230 I = 1,NEXP                                                 HNDDRV
*       II = II + 1                                                     HNDDRV
*       CORE(II) = CD(I)                                                HNDDRV
* 230 CONTINUE                                                          HNDDRV
*     DO 240 I = 1,NEXP                                                 HNDDRV
*       II = II + 1                                                     HNDDRV
*       CORE(II) = CF(I)                                                HNDDRV
* 240 CONTINUE                                                          HNDDRV
*     NFILE = 5                                                         HNDDRV
*     CALL NBWRIT(CORE,II,NFILE)                                        HNDDRV
C                                                                       HNDDRV
* 900 FORMAT(/1X,'No namelist /WFN/ found.  Stop. ')                    HNDDRV
*     RETURN                                                            HNDDRV
*     END                                                               HNDDRV
C***********************************************************************HNDDRV
*     SUBROUTINE DELSCF(A)                                              HNDDRV
C***********************************************************************HNDDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         HNDDRV
*     LOGICAL NEW,ERROR,SEQ                                             HNDDRV
C                                                                       HNDDRV
C  NBO common blocks:                                                   HNDDRV
C                                                                       HNDDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       HNDDRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO HNDDRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       HNDDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, HNDDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, HNDDRV
*    +           LFNDAF,LFNDEF                                          HNDDRV
C                                                                       HNDDRV
C  HONDO common blocks:                                                 HNDDRV
C                                                                       HNDDRV
*     COMMON/IJPAIR/IA(1)                                               HNDDRV
*     COMMON/IOFILE/IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(99)                  HNDDRV
*     COMMON/INFOA/NAT,ICH,MUL,NUM,NX,NE,NA,NB,ZAN(50),C(3,50)          HNDDRV
*     COMMON/INTFIL/NOPK,NOK,NOSQUR,NINTMX,NHEX,NTUPL,PACK2E            HNDDRV
*     LOGICAL PACK2E                                                    HNDDRV
C                                                                       HNDDRV
*     DIMENSION A(1)                                                    HNDDRV
C                                                                       HNDDRV
C-----------------------------------------------------------------------HNDDRV
C                                                                       HNDDRV
C  SET POINTERS:                                                        HNDDRV
C                                                                       HNDDRV
*     NTRI = NDIM*(NDIM+1)/2                                            HNDDRV
*     NSQ  = NDIM*NDIM                                                  HNDDRV
C                                                                       HNDDRV
C  A(IPT1)   ---   Density matrix (alpha)                               HNDDRV
C  A(IPT2)   ---   Density matrix (beta)                                HNDDRV
C  A(IPT3)   ---   Fock matrix (alpha)                                  HNDDRV
C  A(IPT4)   ---   Fock matrix (beta)                                   HNDDRV
C  A(IPT5)   ---   Core Hamiltonian matrix                              HNDDRV
C  A(IPT6)   ---   Integral buffer, scratch                             HNDDRV
C  A(IPT7)   ---   Integral buffer                                      HNDDRV
C  A(IPT8)   ---   Integral buffer                                      HNDDRV
C                                                                       HNDDRV
*     IPT1 = 1                                                          HNDDRV
*     IPT2 = IPT1 + NTRI                                                HNDDRV
*     IPT3 = IPT2 + NTRI                                                HNDDRV
*     IPT4 = IPT3 + NTRI                                                HNDDRV
*     IPT5 = IPT4 + NTRI                                                HNDDRV
*     IPT6 = IPT5 + NTRI                                                HNDDRV
*     IPT7 = IPT6 + NINTMX                                              HNDDRV
*     IPT8 = IPT7 + NINTMX                                              HNDDRV
C                                                                       HNDDRV
C  OPEN THE NBO DIRECT ACCESS FILE                                      HNDDRV
C                                                                       HNDDRV
*     NEW = .FALSE.                                                     HNDDRV
*     CALL NBOPEN(NEW,ERROR)                                            HNDDRV
*     IF(ERROR) THEN                                                    HNDDRV
*       WRITE(LFNPR,900)                                                HNDDRV
*       STOP                                                            HNDDRV
*     END IF                                                            HNDDRV
C                                                                       HNDDRV
C  CALCULATE NUCLEAR REPULSION ENERGY:                                  HNDDRV
C                                                                       HNDDRV
*     EN = ENUC(NAT,ZAN,C)                                              HNDDRV
*     IF(UHF) THEN                                                      HNDDRV
C                                                                       HNDDRV
C  UHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTHNDDRV
C      AND SYMMETRIZE THE SKELETON FOCK MATRIX:                         HNDDRV
C                                                                       HNDDRV
*       ALPHA = .TRUE.                                                  HNDDRV
*       BETA = .FALSE.                                                  HNDDRV
*       CALL FENEWD(A(IPT1),NTRI)                                       HNDDRV
*       ALPHA = .FALSE.                                                 HNDDRV
*       BETA = .TRUE.                                                   HNDDRV
*       CALL FENEWD(A(IPT2),NTRI)                                       HNDDRV
*       CALL HSTARU(A(IPT1),A(IPT3),A(IPT2),A(IPT4),A(IPT7),A(IPT8),    HNDDRV
*    +              A(IPT6),A(IPT7),A(IPT8),NINTMX,IA,NOPK)             HNDDRV
*       CALL SYMFCK(A(IPT3),A(IPT6),IA)                                 HNDDRV
*       CALL SYMFCK(A(IPT4),A(IPT6),IA)                                 HNDDRV
C                                                                       HNDDRV
C  READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY:         HNDDRV
C                                                                       HNDDRV
*       CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11)                          HNDDRV
*       DO 100 I = 1,NX                                                 HNDDRV
*         A(I-1+IPT3) = A(I-1+IPT3) + A(I-1+IPT5)                       HNDDRV
* 100     A(I-1+IPT4) = A(I-1+IPT4) + A(I-1+IPT5)                       HNDDRV
*       EHFA = DOTTRI(A(IPT1),A(IPT5),NBAS) +                           HNDDRV
*    +         DOTTRI(A(IPT1),A(IPT3),NBAS)                             HNDDRV
*       EHFB = DOTTRI(A(IPT2),A(IPT5),NBAS) +                           HNDDRV
*    +         DOTTRI(A(IPT2),A(IPT4),NBAS)                             HNDDRV
*       EHF = (EHFA + EHFB)/2.0                                         HNDDRV
*       EDEL = EHF + EN                                                 HNDDRV
C                                                                       HNDDRV
C  RHF WAVEFUNCTION: FETCH THE NBO DELETION DENSITY MATRIX AND CONSTRUCTHNDDRV
C      AND SYMMETRIZE THE SKELETON FOCK MATRIX:                         HNDDRV
C                                                                       HNDDRV
*     ELSE                                                              HNDDRV
*       CALL FENEWD(A(IPT1),NTRI)                                       HNDDRV
*       CALL HSTAR(A(IPT1),A(IPT3),A(IPT6),A(IPT7),NINTMX,IA,NOPK)      HNDDRV
*       CALL SYMFCK(A(IPT3),A(IPT6),IA)                                 HNDDRV
C                                                                       HNDDRV
C  READ IN CORE HAMILTONIAN MATRIX AND CALCULATE THE HF ENERGY:         HNDDRV
C                                                                       HNDDRV
*       CALL DAREAD(IDAF,IODA,A(IPT5),NTRI,11)                          HNDDRV
*       DO 200 I = 1,NX                                                 HNDDRV
* 200     A(I-1+IPT3) = A(I-1+IPT3) + A(I-1+IPT5)                       HNDDRV
*       EHF1 = DOTTRI(A(IPT1),A(IPT5),NBAS)                             HNDDRV
*       EHF2 = DOTTRI(A(IPT1),A(IPT3),NBAS)                             HNDDRV
*       EHF = (EHF1 + EHF2)/2.0                                         HNDDRV
*       EDEL = EHF + EN                                                 HNDDRV
*     END IF                                                            HNDDRV
C                                                                       HNDDRV
C  SAVE THE DELETION ENERGY ON THE NBO DIRECT ACCESS FILE AND CLOSE THE HNDDRV
C  FILE:                                                                HNDDRV
C                                                                       HNDDRV
*     CALL SVE0(EDEL)                                                   HNDDRV
*     SEQ = .FALSE.                                                     HNDDRV
*     CALL NBCLOS(SEQ)                                                  HNDDRV
*     RETURN                                                            HNDDRV
C                                                                       HNDDRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ',        HNDDRV
*    + 'subroutine DELSCF.')                                            HNDDRV
*     END                                                               HNDDRV
C***********************************************************************HNDDRV
C                                                                       HNDDRV
C           E N D    O F    H N D N B O    R O U T I N E S              HNDDRV
C                                                                       HNDDRV
C***********************************************************************HNDDRV
C***********************************************************************AMPDRV
C                                                                       AMPDRV
C                                                                       AMPDRV
C                          A  M  P  N  B  O                             AMPDRV
C                                                                       AMPDRV
C                                                                       AMPDRV
C                    AMPAC VERSION OF NBO PROGRAM                       AMPDRV
C                                                                       AMPDRV
C                                                                       AMPDRV
C  DRIVER ROUTINES:                                                     AMPDRV
C                                                                       AMPDRV
C      SUBROUTINE RUNNBO                                                AMPDRV
C      SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                             AMPDRV
C      SUBROUTINE DELSCF(CORE,ICORE)                                    AMPDRV
C                                                                       AMPDRV
C***********************************************************************AMPDRV
*     SUBROUTINE RUNNBO                                                 AMPDRV
C***********************************************************************AMPDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         AMPDRV
C                                                                       AMPDRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               AMPDRV
*     PARAMETER(MEMORY = 4*MAXBAS*MAXBAS)                               AMPDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, AMPDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, AMPDRV
*    +           LFNDAF,LFNDEF                                          AMPDRV
C                                                                       AMPDRV
*     DIMENSION CORE(MEMORY),NBOOPT(10)                                 AMPDRV
C                                                                       AMPDRV
*     LFNIN = 5                                                         AMPDRV
*     LFNPR = 6                                                         AMPDRV
C                                                                       AMPDRV
C  Set NBO options.                                                     AMPDRV
C                                                                       AMPDRV
*     NBOOPT(1)  =  0                                                   AMPDRV
*     NBOOPT(2)  =  0                                                   AMPDRV
*     NBOOPT(3)  =  0                                                   AMPDRV
*     NBOOPT(4)  =  0                                                   AMPDRV
*     NBOOPT(5)  =  0                                                   AMPDRV
*     NBOOPT(6)  =  0                                                   AMPDRV
*     NBOOPT(7)  =  0                                                   AMPDRV
*     NBOOPT(8)  =  0                                                   AMPDRV
*     NBOOPT(9)  =  0                                                   AMPDRV
*     NBOOPT(10) =  1                                                   AMPDRV
C                                                                       AMPDRV
C  Perform the NPA/NBO/NLMO analyses.                                   AMPDRV
C                                                                       AMPDRV
*     CALL NBO(CORE,MEMORY,NBOOPT)                                      AMPDRV
C                                                                       AMPDRV
C  Perform the energetic analysis.                                      AMPDRV
C                                                                       AMPDRV
*  10 NBOOPT(1) = 2                                                     AMPDRV
*     CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE)                             AMPDRV
*     IF(IDONE.NE.0) GOTO 20                                            AMPDRV
*     CALL DELSCF(CORE,CORE)                                            AMPDRV
*     NBOOPT(1) = 3                                                     AMPDRV
*     CALL NBOEAN(CORE,MEMORY,NBOOPT,IDONE)                             AMPDRV
*     GOTO 10                                                           AMPDRV
C                                                                       AMPDRV
*  20 RETURN                                                            AMPDRV
*     END                                                               AMPDRV
C***********************************************************************AMPDRV
*     SUBROUTINE FEAOIN(CORE,ICORE,NBOOPT)                              AMPDRV
C***********************************************************************AMPDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         AMPDRV
*     DIMENSION CORE(1),ICORE(1),NBOOPT(10)                             AMPDRV
*     DIMENSION LIST(9),NCORE(12)                                       AMPDRV
C                                                                       AMPDRV
*     INCLUDE 'SIZES'                                                   AMPDRV
C                                                                       AMPDRV
C  NBO COMMON BLOCKS                                                    AMPDRV
C                                                                       AMPDRV
*     PARAMETER(MAXATM = 99,MAXBAS = 500)                               AMPDRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO AMPDRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       AMPDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       AMPDRV
*     COMMON/NBOPT/IWDM,IW3C,IWAPOL,IWHYBS,IWPNAO,IWTNAO,IWTNAB,        AMPDRV
*    + IWTNBO,IWFOCK,IWCUBF,IPSEUD,KOPT,IPRINT,IWDETL,IWMULP,ICHOOS,    AMPDRV
*    + JCORE,JPRINT(60)                                                 AMPDRV
*     COMMON/NBAO/LCTR(MAXBAS),LANG(MAXBAS)                             AMPDRV
*     COMMON/NBATOM/IATNO(MAXATM),INO(MAXATM),NORBS(MAXATM),LL(MAXATM), AMPDRV
*    +       LU(MAXATM),IZNUC(MAXATM),IATCR(MAXATM)                     AMPDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, AMPDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, AMPDRV
*    +           LFNDAF,LFNDEF                                          AMPDRV
C                                                                       AMPDRV
C  AMPAC COMMON BLOCKS:                                                 AMPDRV
C                                                                       AMPDRV
*     COMMON /NATORB/ NATORB(107)                                       AMPDRV
*     COMMON /TITLES/ COMENT(10),TITLE(10)                              AMPDRV
*     COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK)                      AMPDRV
*     COMMON /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB)   AMPDRV
*     COMMON /FOKMAT/ F(MPACK), FB(MPACK)                               AMPDRV
*     COMMON /GEOM  / GEO(3,NUMATM)                                     AMPDRV
*     COMMON /GEOKST/ NATOM,LABELS(NUMATM),                             AMPDRV
*    *                NA(NUMATM), NB(NUMATM), NC(NUMATM)                AMPDRV
*     COMMON /KEYWRD/ KEYWRD                                            AMPDRV
*     CHARACTER*80 KEYWRD                                               AMPDRV
C                                                                       AMPDRV
*     DATA LIST/51,151,152,153,254,251,255,253,252/                     AMPDRV
*     DATA NCORE/2,10,18,28,36,46,54,68,78,86,100,110/                  AMPDRV
C                                                                       AMPDRV
C  FEAOIN:   (FETCH AO BASIS AND WAVE FUNCTION TYPE INFORMATION)        AMPDRV
C                                                                       AMPDRV
C   OBTAIN THE FOLLOWING INFORMATION:                                   AMPDRV
C                                                                       AMPDRV
C    ROHF        =.TRUE. IF RHF OPEN SHELL WAVE FUNCTION                AMPDRV
C                =.FALSE. OTHERWISE                                     AMPDRV
C                                                                       AMPDRV
C    UHF         =.TRUE. IF UHF WAVE FUNCTION                           AMPDRV
C                =.FALSE. OTHERWISE                                     AMPDRV
C                                                                       AMPDRV
C    CI          =.TRUE. IF UHF WAVE FUNCTION                           AMPDRV
C                =.FALSE. OTHERWISE                                     AMPDRV
C                                                                       AMPDRV
C    OPEN        =.TRUE. IF OPEN SHELL WAVE FUNCTION                    AMPDRV
C                =.FALSE. OTHERWISE                                     AMPDRV
C                                                                       AMPDRV
C    COMPLX      =.TRUE. IF COMPLEX WAVE FUNCTION                       AMPDRV
C                =.FALSE. OTHERWISE                                     AMPDRV
C                (NOTE: THE PROGRAM IS NOT SET UP TO HANDLE THIS CASE)  AMPDRV
C                                                                       AMPDRV
C    ORTHO       =.TRUE. ORTHOGONAL AO BASIS SET                        AMPDRV
C                                                                       AMPDRV
C    NATOMS      NUMBER OF ATOMIC CENTERS                               AMPDRV
C                                                                       AMPDRV
C    NDIM        DIMENSION OF MATRICES (OVERLAP AND DENSITY)            AMPDRV
C                                                                       AMPDRV
C    NBAS        NUMBER OF BASIS FUNCTIONS (.LE.NDIM)                   AMPDRV
C                                                                       AMPDRV
C    IPSEUD      SET TO ZERO IF NO PSEUDOPOTENTIALS ARE USED,           AMPDRV
C                SET TO ONE IF PSEUDOPOTENTIALS ARE USED.               AMPDRV
C                (THE ONLY EFFECT OF THIS IS TO SUPRESS THE LABELLING OFAMPDRV
C                ORBITALS WHEN ONE OR MORE ATOMS HAS A PSEUDOPOTENTIAL) AMPDRV
C                                                                       AMPDRV
C    IWCUBF      THIS PERTAINS ONLY TO BASIS SETS WITH F FUNCTIONS.     AMPDRV
C                                                                       AMPDRV
C                 IF CARTESIAN F FUNCTIONS ARE INPUT, SET IWCUBF TO:    AMPDRV
C                    0,  IF THESE ARE TO BE TRANSFORMED TO THE STANDARD AMPDRV
C                        OF PURE F FUNCTIONS                            AMPDRV
C                    1,  IF THESE ARE TO BE TRANSFORMED TO THE CUBIC    AMPDRV
C                        SET OF PURE F FUNCTIONS                        AMPDRV
C                                                                       AMPDRV
C                 IF PURE F FUNCTIONS ARE INPUT, SET TO IWCUBF TO:      AMPDRV
C                    0,  IF THESE ARE STANDARD F FUNCTIONS              AMPDRV
C                    1,  IF THESE ARE CUBIC F FUNCTIONS                 AMPDRV
C                                                                       AMPDRV
C                                                                       AMPDRV
C    IATNO(I),I=1,NATOMS                                                AMPDRV
C                LIST OF ATOMIC NUMBERS                                 AMPDRV
C                                                                       AMPDRV
C    LCTR(I),I=1,NBAS                                                   AMPDRV
C                LIST OF ATOMIC CENTERS OF THE BASIS FUNCTIONS          AMPDRV
C                    (LCTR(3)=2 IF BASIS FUNCT. 3 IS ON ATOM 2)         AMPDRV
C                                                                       AMPDRV
C    LANG(I),I=1,NBAS                                                   AMPDRV
C                LIST OF ANGULAR SYMMETRY INFORMATION FOR THE BASIS     AMPDRV
C                FUNCTIONS                                              AMPDRV
C                                                                       AMPDRV
*     IWCUBF = 0                                                        AMPDRV
*     IPSEUD = 0                                                        AMPDRV
C                                                                       AMPDRV
C  CONSTRUCT ATOM AND AO BASIS INFORMATION LISTS:                       AMPDRV
C     IATNO(I) = ATOMIC NUMBER OF ATOM "I"                              AMPDRV
C     IZNUC(I) = NUCLEAR CHARGE ON ATOM "I" (IATNO(I)-# OF CORE ELECTRONAMPDRV
C     LCTR(I) = ATOMIC CENTER FOR BASIS FUNCTION "I"                    AMPDRV
C     LANG(I) = ANGULAR SYMMETRY LABEL FOR BASIS FUNCTION "I"           AMPDRV
C                                                                       AMPDRV
*     IBAS = 0                                                          AMPDRV
*     NAT  = 0                                                          AMPDRV
*     DO 200 I = 1,NATOM                                                AMPDRV
*       IF(LABELS(I).EQ.99) GOTO 200                                    AMPDRV
*       NAT = NAT + 1                                                   AMPDRV
*       IATNO(NAT) = LABELS(I)                                          AMPDRV
*       DO 100 J = 1,12                                                 AMPDRV
*         JJ = J                                                        AMPDRV
*         IF(IATNO(NAT)-NCORE(JJ).LT.0) GOTO 110                        AMPDRV
* 100   CONTINUE                                                        AMPDRV
*       STOP 'UNKNOWN ATOM'                                             AMPDRV
C                                                                       AMPDRV
* 110   JJ = JJ - 1                                                     AMPDRV
*       IF(JJ.EQ.0) THEN                                                AMPDRV
*         IZNUC(NAT) = IATNO(NAT)                                       AMPDRV
*       ELSE                                                            AMPDRV
*         IZNUC(NAT) = IATNO(NAT) - NCORE(JJ)                           AMPDRV
*         IPSEUD = 1                                                    AMPDRV
*       END IF                                                          AMPDRV
*       DO 150 J = 1,NATORB(LABELS(I))                                  AMPDRV
*         IBAS = IBAS + 1                                               AMPDRV
*         LCTR(IBAS)  = NAT                                             AMPDRV
*         LANG(IBAS)  = LIST(J)                                         AMPDRV
* 150   CONTINUE                                                        AMPDRV
* 200 CONTINUE                                                          AMPDRV
C                                                                       AMPDRV
C  PUT INFO INTO COMMON/NBINFO/:                                        AMPDRV
C                                                                       AMPDRV
*     NATOMS = NAT                                                      AMPDRV
*     NDIM   = IBAS                                                     AMPDRV
*     NBAS   = IBAS                                                     AMPDRV
C                                                                       AMPDRV
C  EXPECTATION VALUES OF THE FOCK OPERATOR ARE IN ELECTRON VOLTS:       AMPDRV
C                                                                       AMPDRV
*     MUNIT = 1                                                         AMPDRV
C                                                                       AMPDRV
C  DETERMINE TYPE OF WAVE FUNCTION DENSITY MATRIX IS FROM:              AMPDRV
C                                                                       AMPDRV
*     ORTHO = .TRUE.                                                    AMPDRV
*     IF(INDEX(KEYWRD,'C.I.').NE.0)    CI   = .TRUE.                    AMPDRV
*     IF(INDEX(KEYWRD,'UHF').NE.0)     UHF  = .TRUE.                    AMPDRV
*     IF(INDEX(KEYWRD,'OPEN').NE.0)    OPEN = .TRUE.                    AMPDRV
*     IF(INDEX(KEYWRD,'DOUBLE').NE.0)  OPEN = .TRUE.                    AMPDRV
*     IF(INDEX(KEYWRD,'TRIPLET').NE.0) OPEN = .TRUE.                    AMPDRV
*     IF(INDEX(KEYWRD,'QUARTET').NE.0) OPEN = .TRUE.                    AMPDRV
*     IF(INDEX(KEYWRD,'QUINTET').NE.0) OPEN = .TRUE.                    AMPDRV
*     IF(INDEX(KEYWRD,'SEXTET').NE.0)  OPEN = .TRUE.                    AMPDRV
*     IF(UHF) OPEN = .TRUE.                                             AMPDRV
*     IF(OPEN) UHF = .TRUE.                                             AMPDRV
C                                                                       AMPDRV
*     IF(ROHF.OR.CI) IWFOCK = 0                                         AMPDRV
C                                                                       AMPDRV
C  STORE THE JOB TITLE ON THE NBO DAF:                                  AMPDRV
C                                                                       AMPDRV
*     DO 210 I = 1,10                                                   AMPDRV
*       CORE(I) = TITLE(I)                                              AMPDRV
* 210 CONTINUE                                                          AMPDRV
*     NFILE = 2                                                         AMPDRV
*     CALL NBWRIT(CORE,10,NFILE)                                        AMPDRV
C                                                                       AMPDRV
C  STORE NATOMS, NDIM, NBAS, MUNIT, WAVEFUNCTION FLAGS, ISWEAN:         AMPDRV
C                                                                       AMPDRV
*     ICORE(1)  = NATOMS                                                AMPDRV
*     ICORE(2)  = NDIM                                                  AMPDRV
*     ICORE(3)  = NBAS                                                  AMPDRV
*     ICORE(4)  = MUNIT                                                 AMPDRV
*     ICORE(5)  = 0                                                     AMPDRV
*     IF(ROHF)  ICORE(5)  = 1                                           AMPDRV
*     ICORE(6)  = 0                                                     AMPDRV
*     IF(UHF)   ICORE(6)  = 1                                           AMPDRV
*     ICORE(7)  = 0                                                     AMPDRV
*     IF(CI)    ICORE(7)  = 1                                           AMPDRV
*     ICORE(8)  = 0                                                     AMPDRV
*     IF(OPEN)  ICORE(8)  = 1                                           AMPDRV
*     ICORE(9)  = 0                                                     AMPDRV
*     IF(MCSCF) ICORE(9)  = 1                                           AMPDRV
*     ICORE(10) = 0                                                     AMPDRV
*     IF(AUHF)  ICORE(10) = 1                                           AMPDRV
*     ICORE(11) = 0                                                     AMPDRV
*     IF(ORTHO) ICORE(11) = 1                                           AMPDRV
*     ICORE(12) = 1                                                     AMPDRV
*     NFILE = 3                                                         AMPDRV
*     CALL NBWRIT(ICORE,12,NFILE)                                       AMPDRV
C                                                                       AMPDRV
C  STORE IATNO, IZNUC, LCTR, AND LANG ON NBO DAF:                       AMPDRV
C                                                                       AMPDRV
*     II = 0                                                            AMPDRV
*     DO 220 I = 1,NATOMS                                               AMPDRV
*       II = II + 1                                                     AMPDRV
*       ICORE(II) = IATNO(I)                                            AMPDRV
* 220 CONTINUE                                                          AMPDRV
*     DO 230 I = 1,NATOMS                                               AMPDRV
*       II = II + 1                                                     AMPDRV
*       ICORE(II) = IZNUC(I)                                            AMPDRV
* 230 CONTINUE                                                          AMPDRV
*     DO 240 I = 1,NBAS                                                 AMPDRV
*       II = II + 1                                                     AMPDRV
*       ICORE(II) = LCTR(I)                                             AMPDRV
* 240 CONTINUE                                                          AMPDRV
*     DO 250 I = 1,NBAS                                                 AMPDRV
*       II = II + 1                                                     AMPDRV
*       ICORE(II) = LANG(I)                                             AMPDRV
* 250 CONTINUE                                                          AMPDRV
*     NFILE = 4                                                         AMPDRV
*     CALL NBWRIT(ICORE,2*NATOMS+2*NBAS,NFILE)                          AMPDRV
C                                                                       AMPDRV
C  STORE ATOMIC COORDINATES ON THE NBO DAF:                             AMPDRV
C                                                                       AMPDRV
*     CALL GMETRY(GEO,CORE)                                             AMPDRV
*     NFILE = 9                                                         AMPDRV
*     CALL NBWRIT(CORE,3*NATOMS,NFILE)                                  AMPDRV
C                                                                       AMPDRV
C  STORE THE DENSITY MATRICES ON THE NBO DAF:                           AMPDRV
C                                                                       AMPDRV
*     IWDM = 0                                                          AMPDRV
*     L2 = NDIM*(NDIM+1)/2                                              AMPDRV
*     IF(OPEN) THEN                                                     AMPDRV
*       NFILE = 20                                                      AMPDRV
*       CALL NBWRIT(PA,L2,NFILE)                                        AMPDRV
*       NFILE = 21                                                      AMPDRV
*       CALL NBWRIT(PB,L2,NFILE)                                        AMPDRV
*     ELSE                                                              AMPDRV
*       NFILE = 20                                                      AMPDRV
*       CALL NBWRIT(P,L2,NFILE)                                         AMPDRV
*     END IF                                                            AMPDRV
C                                                                       AMPDRV
C  STORE THE FOCK MATRICES ON THE NBO DAF:                              AMPDRV
C                                                                       AMPDRV
*     IF(.NOT.ROHF.AND..NOT.CI) THEN                                    AMPDRV
*       NFILE = 30                                                      AMPDRV
*       CALL NBWRIT(F,L2,NFILE)                                         AMPDRV
*       IF(OPEN) THEN                                                   AMPDRV
*         NFILE = 31                                                    AMPDRV
*         CALL NBWRIT(FB,L2,NFILE)                                      AMPDRV
*       END IF                                                          AMPDRV
*     END IF                                                            AMPDRV
C                                                                       AMPDRV
C  STORE THE AO TO MO TRANSFORMATIONS ON THE NBO DAF:                   AMPDRV
C                                                                       AMPDRV
*     L3 = NDIM*NDIM                                                    AMPDRV
*     NFILE = 40                                                        AMPDRV
*     CALL NBWRIT(C,L3,NFILE)                                           AMPDRV
*     IF(OPEN) THEN                                                     AMPDRV
*       NFILE = 41                                                      AMPDRV
*       CALL NBWRIT(CBETA,L3,NFILE)                                     AMPDRV
*     END IF                                                            AMPDRV
C                                                                       AMPDRV
*     RETURN                                                            AMPDRV
*     END                                                               AMPDRV
C***********************************************************************AMPDRV
*     SUBROUTINE DELSCF(CORE,ICORE)                                     AMPDRV
C***********************************************************************AMPDRV
*     IMPLICIT REAL*8 (A-H,O-Z)                                         AMPDRV
*     LOGICAL NEW,ERROR,SEQ                                             AMPDRV
C                                                                       AMPDRV
C  NBO common blocks:                                                   AMPDRV
C                                                                       AMPDRV
*     COMMON/NBINFO/ISPIN,NATOMS,NDIM,NBAS,MXBO,MXAO,MXAOLM,MUNIT       AMPDRV
*     COMMON/NBFLAG/ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO AMPDRV
*     LOGICAL ROHF,UHF,CI,OPEN,COMPLX,ALPHA,BETA,MCSCF,AUHF,ORTHO       AMPDRV
*     COMMON/NBIO/LFNIN,LFNPR,LFNAO,LFNPNA,LFNNAO,LFNPNH,LFNNHO,LFNPNB, AMPDRV
*    +           LFNNBO,LFNPNL,LFNNLM,LFNMO,LFNDM,LFNNAB,LFNPPA,LFNARC, AMPDRV
*    +           LFNDAF,LFNDEF                                          AMPDRV
C                                                                       AMPDRV
C  AMPAC COMMON blocks:                                                 AMPDRV
C                                                                       AMPDRV
*     INCLUDE 'SIZES'                                                   AMPDRV
C                                                                       AMPDRV
*     COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),  AMPDRV
*    +                NLAST(NUMATM), NORBS, NELECS,                     AMPDRV
*    +                NALPHA, NBETA, NCLOSE, NOPEN, NDUMY, FRACT        AMPDRV
*     COMMON /HMATRX/ H(MPACK)                                          AMPDRV
*     COMMON /WMATRX/ WJ(N2ELEC), WK(N2ELEC)                            AMPDRV
*     COMMON /FOKMAT/ F(MPACK), FB(MPACK)                               AMPDRV
*     COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK)                    AMPDRV
*     COMMON /ATHEAT/ ATHEAT                                            AMPDRV
*     COMMON /ENUCLR/ ENUCLR                                            AMPDRV
*     COMMON /GEOM  / GEO(3,NUMATM)                                     AMPDRV
C                                                                       AMPDRV
*     DIMENSION CORE(1),ICORE(1),W(N2ELEC)                              AMPDRV
*     EQUIVALENCE (W(1),WJ(1))                                          AMPDRV
C                                                                       AMPDRV
*     DATA TWO,TOKCAL/2.0D0,23.061D0/                                   AMPDRV
C                                                                       AMPDRV
C  Open the NBO direct access file:                                     AMPDRV
C                                                                       AMPDRV
*     NEW = .FALSE.                                                     AMPDRV
*     CALL NBOPEN(NEW,ERROR)                                            AMPDRV
*     IF(ERROR) THEN                                                    AMPDRV
*       WRITE(LFNPR,900)                                                AMPDRV
*       STOP                                                            AMPDRV
*     END IF                                                            AMPDRV
C                                                                       AMPDRV
C  Compute the one-electron and two-electron integrals, given the atomicAMPDRV
C  coordinates.  Also compute the nuclear repulsion contribution to the AMPDRV
C  SCF energy:                                                          AMPDRV
C                                                                       AMPDRV
*     CALL GMETRY(GEO,CORE)                                             AMPDRV
*     CALL HCORE(CORE,H,W,WJ,WK,ENUCLR)                                 AMPDRV
C                                                                       AMPDRV  
C  Compute the SCF and deletion energies for UHF wavefunctions:         AMPDRV
C                                                                       AMPDRV
*     LEN = NBAS * (NBAS + 1) / 2                                       AMPDRV
*     IF(UHF) THEN                                                      AMPDRV
C                                                                       AMPDRV
C  Read the spin densities from the NBO direct access file and calculateAMPDRV
C  to total density:                                                    AMPDRV
C                                                                       AMPDRV
*       ALPHA = .TRUE.                                                  AMPDRV
*       BETA  = .FALSE.                                                 AMPDRV
*       CALL FEDRAW(PA,CORE)                                            AMPDRV
*       CALL PACK(PA,NDIM,NBAS,LEN)                                     AMPDRV
*       ALPHA = .FALSE.                                                 AMPDRV
*       BETA  = .TRUE.                                                  AMPDRV
*       CALL FEDRAW(PB,CORE)                                            AMPDRV
*       CALL PACK(PB,NDIM,NBAS,LEN)                                     AMPDRV
*       DO 10 I = 1,LEN                                                 AMPDRV
*         P(I) = PA(I) + PB(I)                                          AMPDRV
*  10   CONTINUE                                                        AMPDRV
C                                                                       AMPDRV
C  Alpha spin: construct the alpha Fock matrix:                         AMPDRV
C                                                                       AMPDRV
*       CALL COPY(H,F,LEN,LEN,1)                                        AMPDRV
*       CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST)            AMPDRV
*       CALL FOCK1(F,P,PA,PB)                                           AMPDRV
C                                                                       AMPDRV
C  Alpha spin: construct the alpha Fock matrix:                         AMPDRV
C                                                                       AMPDRV
*       CALL COPY(H,FB,LEN,LEN,1)                                       AMPDRV
*       CALL FOCK2(FB,P,PB,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST)           AMPDRV
*       CALL FOCK1(FB,P,PB,PA)                                          AMPDRV
C                                                                       AMPDRV
C  Determine the SCF energy:                                            AMPDRV
C                                                                       AMPDRV
*       EE   = HELECT(NBAS,PA,H,F) + HELECT(NBAS,PB,H,FB)               AMPDRV
*       ESCF = (EE + ENUCLR) * TOKCAL + ATHEAT                          AMPDRV
C                                                                       AMPDRV
C  Repeat process for the deletion energy:                              AMPDRV
C                                                                       AMPDRV
*       ALPHA = .TRUE.                                                  AMPDRV
*       BETA  = .FALSE.                                                 AMPDRV
*       CALL FENEWD(PA)                                                 AMPDRV
*       ALPHA = .FALSE.                                                 AMPDRV
*       BETA  = .TRUE.                                                  AMPDRV
*       CALL FENEWD(PB)                                                 AMPDRV
*       DO 20 I = 1,LEN                                                 AMPDRV
*         P(I) = PA(I) + PB(I)                                          AMPDRV
*  20   CONTINUE                                                        AMPDRV
*       CALL COPY(H,F,LEN,LEN,1)                                        AMPDRV
*       CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST)            AMPDRV
*       CALL FOCK1(F,P,PA,PB)                                           AMPDRV
*       CALL COPY(H,FB,LEN,LEN,1)                                       AMPDRV
*       CALL FOCK2(FB,P,PB,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST)           AMPDRV
*       CALL FOCK1(FB,P,PB,PA)                                          AMPDRV
*       EE   = HELECT(NBAS,PA,H,F) + HELECT(NBAS,PB,H,FB)               AMPDRV
*       EDEL = (EE + ENUCLR) * TOKCAL + ATHEAT                          AMPDRV
C                                                                       AMPDRV
C  Compute the SCF and deletion energies for RHF wavefunctions:         AMPDRV
C                                                                       AMPDRV
*     ELSE                                                              AMPDRV
*       ALPHA = .FALSE.                                                 AMPDRV
*       BETA  = .FALSE.                                                 AMPDRV
*       CALL FEDRAW(P,CORE)                                             AMPDRV
*       CALL PACK(P,NDIM,NBAS,LEN)                                      AMPDRV
*       DO 30 I = 1,LEN                                                 AMPDRV
*         PA(I) = P(I) / TWO                                            AMPDRV
*         PB(I) = P(I) / TWO                                            AMPDRV
*  30   CONTINUE                                                        AMPDRV
C                                                                       AMPDRV
C  Construct the Fock matrix:                                           AMPDRV
C                                                                       AMPDRV
*       CALL COPY(H,F,LEN,LEN,1)                                        AMPDRV
*       CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST)            AMPDRV
*       CALL FOCK1(F,P,PA,PB)                                           AMPDRV
C                                                                       AMPDRV
C  Determine the SCF energy:                                            AMPDRV
C                                                                       AMPDRV
*       EE   = HELECT(NBAS,PA,H,F) * TWO                                AMPDRV
*       ESCF = (EE + ENUCLR) * TOKCAL + ATHEAT                          AMPDRV
C                                                                       AMPDRV
C  Repeat process for the deletion energy:                              AMPDRV
C                                                                       AMPDRV
*       CALL FENEWD(P)                                                  AMPDRV
*       DO 40 I = 1,LEN                                                 AMPDRV
*         PA(I) = P(I) / TWO                                            AMPDRV
*         PB(I) = P(I) / TWO                                            AMPDRV
*  40   CONTINUE                                                        AMPDRV
*       CALL COPY(H,F,LEN,LEN,1)                                        AMPDRV
*       CALL FOCK2(F,P,PA,W,WJ,WK,NUMAT,NFIRST,NMIDLE,NLAST)            AMPDRV
*       CALL FOCK1(F,P,PA,PB)                                           AMPDRV
*       EE   = HELECT(NBAS,PA,H,F) * TWO                                AMPDRV
*       EDEL = (EE + ENUCLR) * TOKCAL + ATHEAT                          AMPDRV
*     END IF                                                            AMPDRV
C                                                                       AMPDRV
C  Save these energies on the direct access file:                       AMPDRV
C                                                                       AMPDRV
*     CORE(1) = EDEL                                                    AMPDRV
*     CORE(2) = ESCF                                                    AMPDRV
*     NFILE = 8                                                         AMPDRV
*     CALL NBWRIT(CORE,2,NFILE)                                         AMPDRV
C                                                                       AMPDRV
C  Note that these energies are in units of kcal/mol!!                  AMPDRV
C                                                                       AMPDRV
*     MUNIT = 2                                                         AMPDRV
*     NFILE = 3                                                         AMPDRV
*     CALL NBREAD(ICORE,12,NFILE)                                       AMPDRV
*     ICORE(4) = MUNIT                                                  AMPDRV
*     CALL NBWRIT(ICORE,12,NFILE)                                       AMPDRV
C                                                                       AMPDRV
C  Close the NBO direct access file:                                    AMPDRV
C                                                                       AMPDRV
*     SEQ = .FALSE.                                                     AMPDRV
*     CALL NBCLOS(SEQ)                                                  AMPDRV
*     RETURN                                                            AMPDRV
C                                                                       AMPDRV
* 900 FORMAT(/1X,'Error opening the NBO direct access file in ',        AMPDRV
*    + 'subroutine DELSCF.')                                            AMPDRV
*     END                                                               AMPDRV
C***********************************************************************AMPDRV
C                                                                       AMPDRV
C           E N D    O F    A M P N B O    R O U T I N E S              AMPDRV
C                                                                       AMPDRV
C***********************************************************************AMPDRV
