c--- ancillary array that is used for fragmentation
c--- contributions in gmgmjt process
      double precision msqbits(12)
      common/msqbits/msqbits
      integer
     & ddb_ddb,ddb_ssb,ddb_uub,
     & uub_uub,uub_ccb,uub_ddb,
     & dbd_ddb,dbd_ssb,dbd_uub,
     & ubu_uub,ubu_ccb,ubu_ddb
      parameter(
     & ddb_ddb=1,ddb_ssb=2,ddb_uub=3,
     & uub_uub=4,uub_ccb=5,uub_ddb=6,
     & dbd_ddb=7,dbd_ssb=8,dbd_uub=9,
     & ubu_uub=10,ubu_ccb=11,ubu_ddb=12)

!$omp threadprivate(/msqbits/)


! --- This group of modules takes on the role of data declarations and
! --- included common files;  initializations are also done here using
! --- data statements much like a BLOCK DATA structure.
! --- Individual modules are:
!      module mroad1
!      module mroad2
!      module mqscale

!-----------------------------------------------------------------------
      module mroad1
!-----------------------------------------------------------------------
! --- CALPUFF    Version: 7.2.1       Level: 141201           |MROAD1|
! ---            Constant/Scaled Road-source data
!-----------------------------------------------------------------------
      integer              :: nrd1,nrdseg1,nsfrds
      integer, allocatable :: nptrd1(:)                                 ! (nrd1)
      integer, allocatable :: iroad1(:),newrd1(:)                       ! (nrdse
      integer, allocatable :: idsfrds(:,:)                              ! (mxspe
      integer, allocatable :: ixrefrds(:)                               ! (nsfrd

      character(len=16), allocatable :: srcnamrd1(:)                    ! (nrd1)
      character(len=40), allocatable :: csfrds(:)                       ! (nsfrd

      real, allocatable    :: htrd1(:),sz0rd1(:),sy0rd1(:)              ! (nrd1)
      real, allocatable    :: qrd1(:,:)                                 ! (mxspe
      real, allocatable    :: rdlen1(:)                                 ! (nrdse
      real, allocatable    :: xrd1grd(:,:),yrd1grd(:,:),elrd1(:,:)      ! (2,nrd

! --- Variables:
! ---------------
!
! --- Variables for named roads
!                     NRD1 - integer - Number of roads
!          SRCNAMRD1(nrd1) - char*16 - Road names
!              HTRD1(nrd1) - real    - Effective release height (m)
!             SZ0RD1(nrd1) - real    - Initial sigma z (m)
!             SY0RD1(nrd1) - real    - Initial sigma y (m)
!        QRD1(mxspec,nrd1) - real    - Emission rate (g/s/m) for each
!                                      pollutant
!             NPTRD1(nrd1) - real    - Number of points defining road
!
! --- Variables for road-species pairs with scaled emissions
!                   NSFRDS - integer - Number of road-species pairs
!                                      with emissions scaling factors
!     IDSFRDS(mxspec,nrd1) - integer - Pointer to road-species pair
!                                      index, 0 to NSFRDS
!                                      (0 if no scaling)
!           CSFRDS(nsfrds) - char*40 - List of scale-factor table names
!                                      for road-species pairs
!         IXREFRDS(nsfrds) - integer - Cross-reference pointer from
!                                      road-species pairs to
!                                      scale-factor tables
!
! --- Variables for road segments that emit puffs/slugs
!                  NRDSEG1 - integer - Number of emitting road segments
!                                      (Total over all roads)
!          IROAD1(nrdseg1) - integer - Road number for this segment
!          RDLEN1(nrdseg1) - real    - Road length (m) for this segment
!       XRD1GRD(2,nrdseg1) - real    - X coordinate of the ends of road
!                                      segments in grid units
!                                      (i.e., origin at (0.0,0.0))
!       YRD1GRD(2,nrdseg1) - real    - Y coordinate of the ends of road
!                                      segments in grid units
!                                      (i.e., origin at (0.0,0.0))
!         ELRD1(2,nrdseg1) - real    - Ground elevation of the ends of
!                                      road segments (m MSL)
!          NEWRD1(nrdseg1) - integer - Number of puffs/slugs released
!                                      by each road during the current
!                                      step
!-----------------------------------------------------------------------
      end module mroad1
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
      module mroad2
!-----------------------------------------------------------------------
! --- CALPUFF    Version: TNG-7.1.0    Level: 141201           |MROAD2|
! ---            Time-varying Road-source data
!-----------------------------------------------------------------------
      integer              :: nrd2,nrdseg2,nse7,nrddat

      integer, allocatable :: ixrem7(:)                                 ! (mxspe
      integer, allocatable :: nptrd2(:)                                 ! (nrd2)
      integer, allocatable :: iroad2(:),newrd2(:)                       ! (nrdse

      character(len=12), allocatable :: cslst7(:)                       ! (mxspe
      character(len=16), allocatable :: cid7(:)                         ! (nrd2)

      real,    allocatable :: xmwem7(:)                                 ! (mxspe
      real,    allocatable :: rdlen2(:)                                 ! (nrdse
      real,    allocatable :: xrd2grd(:,:),yrd2grd(:,:),elrd2(:,:)      ! (2,nrd
      real,    allocatable :: htrd2(:,:),sz0rd2(:,:),sy0rd2(:,:)        ! (mxqst
      real,    allocatable :: qrd2(:,:,:)                               ! (mxspe

! --- Arrays for data stored for each RDEMARB.DAT file (nrddat files)

      integer, allocatable :: ibsrc7(:),iesrc7(:),ibdathr7(:),ibsec7(:) ! (nrdda
      integer, allocatable :: iedathr7(:),iesec7(:)                     ! (nrdda
      integer, allocatable :: iutmznrd2(:)                              ! (nrdda
      integer, allocatable :: nstep7(:),mfrd2(:)                        ! (nrdda
      integer, allocatable :: ndhrqb7(:,:),nsecqb7(:,:)                 ! (mxqst
      integer, allocatable :: ndhrqe7(:,:),nsecqe7(:,:)                 ! (mxqst

      real,    allocatable :: xtz7(:),t2btz7(:)                         ! (nrdda
      real,    allocatable :: feastrd2(:),fnorthrd2(:)                  ! (nrdda
      real,    allocatable :: rnlat0rd2(:),relon0rd2(:)                 ! (nrdda
      real,    allocatable :: rnlat1rd2(:),rnlat2rd2(:)                 ! (nrdda

      character(len=8),  allocatable :: pmaprd2(:),datumrd2(:)          ! (nrdda
      character(len=4),  allocatable :: utmhemrd2(:),xyunitrd2(:)       ! (nrdda
      character(len=12), allocatable :: datenrd2(:)                     ! (nrdda
      character(len=16), allocatable :: verrdarb(:)                     ! (nrdda
      character(len=132),allocatable :: rddat(:)                        ! (nrdda

! --- Variables:
! ---------------
!
! --- Variables for named roads
!             NSE7 - integer  - Number of emitted species
!   CSLST7(mxspec) - char*12  - Species identifiers
!   XMWEM7(mxspec) - real     - Molecular weight for each species
!   IXREM7(mxspec) - integer  - Cross referencing array of NSE7
!                               values relating species ordering
!                               in the emissions file to the
!                               ordering in the main conc. array
!             NRD2 - integer  - Total number of roads
!       CID7(nrd2) - char*16  - Road names
!     NPTRD2(nrd2) - real     - Number of points defining road
!
! --- Variables for each file
!           NRDDAT - integer  - Total number of RDEMARB.DAT files
!    RDDAT(nrddat) - char*132 - Path & filename for the input CALPUFF
!                               file(s) containing ROAD sources with
!                               arbitrarily-varying location and
!                               emissions
!                               (default: RDEMARB.DAT, for 1 file)
!    MFRD2(nrddat) - integer  - Flag for file type
!                                 0: UNFORMATTED (not supported!)
!                                 1: FORMATTED
! VERRDARB(nrddat) - char*16  - Version of the input CALPUFF
!                               file(s) containing road sources
!                               with arbitrarily-varying location and
!                               emissions
!                               (RDEMARB.DAT)
!   IBSRC7(nrddat) - integer  - Index for first source in a RDEMARB.DAT
!                               file
!   IESRC7(nrddat) - integer  - Index for last source in a RDEMARB.DAT
!                               file
!  IBDATHR7(nrddat)- integer  - Date/hour at beginning of period for
!                               the first data record in the file
!                               (YYYYJJJHH, where YYYY=year,
!                               JJJ=Julian day, HH=hour [00-23 LST])
!   IBSEC7(nrddat) - integer  - Seconds of the first data record in the
!                               file  (0000-3599)
!  IEDATHR7(nrddat)- integer  - Date/hour at end of period for
!                               the last data record in the file
!                               (YYYYJJJHH, where YYYY=year,
!                               JJJ=Julian day, HH=hour [00-23 LST])
!   IESEC7(nrddat) - integer  - Seconds of the last data record in the
!                               file  (0000-3599)
!     XTZ7(nrddat) - real     - Time zone (UTC=LST+XTZ7)
!   T2BTZ7(nrddat) - real     - Hours to ADD to Local Time to obtain
!                               Base Time (xtz7-xbtz)
!
! --- MAP Projection
!   PMAPRD2(nrddat) -char*8    - Character code for map projection
!                                 UTM :  Universal Transverse Mercator
!                                 LCC :  Lambert Conformal Conic
!                                 PS  :  Polar Stereographic
!                                 EM  :  Equatorial Mercator
!                                 LAZA:  Lambert Azimuthal Equal Area
!                                 TTM :  Tangential Transverse Mercator
! UTMHEMRD2(nrddat) -char*4    - Base hemisphere for UTM projection
!                                (S=southern, N=northern)
!  DATUMRD2(nrddat) -char*8    - Datum-Region for grid coordinates
!  DATENRD2(nrddat) -char*12   - NIMA date for datum parameters
!                                 (MM-DD-YYYY  )
! XYUNITRD2(nrddat) -char*4    - Units for coordinates (e.g., KM)
!
!  IUTMZNRD2(nrddat) -integer  - UTM zone for UTM projection
!  FEASTRD2(nrddat)  -real     - False Easting (km) at projection origin
!  FNORTHRD2(nrddat) -real     - False Northing (km) at projection origin
!  RNLAT0RD2(nrddat) -real     - N. latitude & E. longitude of x=0 and y=0
!  RELON0RD2(nrddat)  (deg)      of map projection (Used only if PMAP =
!                                LCC, PS, EM, TTM or LAZA)
!                                NOTE: longitude neg in western hemisphere
!  RNLAT1RD2(nrddat) - real    - Matching N. latitude(s) for projection
!  RNLAT2RD2(nrddat)  (deg)      (Used only if PMAP3= LCC, PS, or EM)
!                            LCC :  Projection cone slices through
!                                   Earth's surface at XLAT1 and XLAT2
!                            PS  :  Projection plane slices through
!                                   Earth at XLAT1
!                            EM  :  Projection cylinder slices through
!                                   Earth at [+/-] XLAT1
!
! --- Variables for road-segments that emit puffs/slugs
! --- (other properties are taken from the (nrd2) arrays)
!                  NRDSEG2 - integer - Number of emitting road segments
!                                      (Total over all roads)
!          IROAD2(nrdseg2) - integer - Road number for this segment
!          RDLEN2(nrdseg2) - real    - Road length (m) for this segment
!       XRD2GRD(2,nrdseg2) - real    - X coordinate of the ends of road
!                                      segments in grid units
!                                      (i.e., origin at (0.0,0.0))
!       YRD2GRD(2,nrdseg2) - real    - Y coordinate of the ends of road
!                                      segments in grid units
!                                      (i.e., origin at (0.0,0.0))
!         ELRD2(2,nrdseg2) - real    - Ground elevation of the ends of
!                                      road segments (m MSL)
!
! ---  Variable data  ---
!
!    NSTEP7(nrddat)  - integer  - Number of emission steps in
!                                 current timestep for each file
! NDHRQB7(mxqstep,nrddat) & NSECQB7(mxqstep,nrddat)
!                    - integer  - Starting time for which
!                                 emissions data in current set of
!                                 records is valid
!                                 (YYYYJJJHH & SSSS)
! NDHRQE7(mxqstep,nrddat) & NSECQE7(mxqstep,nrddat)
!                    - integer  - Ending time for which
!                                 emissions data in current set of
!                                 records is valid
!                                 (YYYYJJJHH & SSSS)
!    HTRD2(mxqstep,nrd2) - real - Effective height (mAGL)
!   SY0RD2(mxqstep,nrd2) - real - Initial sigma y (m)
!   SZ0RD2(mxqstep,nrd2) - real - Initial sigma z (m)
!  QRD2(mxspec,mxqstep,nrd2)
!                        - real - Emission rate (g/m/s) for each
!                                 pollutant
!    NEWRD2(nrdseg2) - integer  - Number of puffs/slugs released
!                                 by each road during the current
!                                 step
!
!-----------------------------------------------------------------------
      end module mroad2
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
      module mqscale
!-----------------------------------------------------------------------
! --- CALPUFF    Version: TNG-7.1.0    Level: 141201          |MQSCALE|
! ---            Emission-Rate Scaling Factors (control file sources)
!-----------------------------------------------------------------------
      integer, parameter   :: nqsftype = 9
      integer              :: nqsfval(nqsftype)
      integer              :: nqsfcol(nqsftype),nqsfrow(nqsftype)
      integer              :: mapivary(6)
      character(len=24)    :: cqsftype(nqsftype)
      real                 :: wqsf(5,13),tqsf(11,13)

      integer              :: nqsftab
      integer, allocatable :: iqsftype(:)                                ! (nqsf
      real, allocatable    :: qsftab(:,:)                                ! (mxqs
      character(len=40), allocatable :: cqsfname(:)                      ! (nqsf

! --- Assignments:
! -----------------
      data nqsfval/1,   12,   7,                                               &
     &             24, 168, 288,                                               &
     &             6,   36,  12/
      data nqsfcol/1,   12,   7,                                               &
     &             24,  24,  24,                                               &
     &             6,    6,  12/
      data nqsfrow/1,    1,   1,                                               &
     &             1,    7,  12,                                               &
     &             1,    6,   1/
      data mapivary/1, 4, 2, 6, 8, 9/
      data cqsftype/                'CONSTANT1               ',                &
     &   'MONTH12                 ','DAY7                    ',                &
     &   'HOUR24                  ','HOUR24_DAY7             ',                &
     &   'HOUR24_MONTH12          ','WSP6                    ',                &
     &   'WSP6_PGCLASS6           ','TEMPERATURE12           '/
! --- NOTE ---------
!           CONSTANT1        1   scaling factor
!           MONTH12          12  scaling factors: months 1-12
!           DAY7             7   scaling factors: days 1-7
!                              [SUNDAY,MONDAY, ... FRIDAY,SATURDAY]
!           HOUR24           24  scaling factors: hours 1-24
!           HOUR24_DAY7      168 scaling factors: hours 1-24,
!                              repeated  7 times:
!                              [SUNDAY,MONDAY, ... FRIDAY,SATURDAY]
!           HOUR24_MONTH12   288 scaling factors: hours 1-24,
!                              repeated 12 times: months 1-12
!           WSP6             6   scaling factors: wind speed classes 1-6
!                              [speed classes (WSCAT)]
!           WSP6_PGCLASS6    36  scaling factors: wind speed classes 1-6
!                              repeated  6 times: PG classes A,B,C,D,E,F
!                              [speed classes (WSCAT)]
!           TEMPERATURE12    12  scaling factors: temp(K) classes 1-12
!                              [temperature classes (TKCAT)]
! -----------------
!
! --- Variables:
! ---------------
!
! --- Variables for defining emission-rate scaling factors
!                 NQSFTAB - integer - Number of tables of
!                                     emissions scaling factors
!       IQSFTYPE(nqsftab) - integer - Index of scale-factor type of
!                                     each table
!       CQSFNAME(nqsftab) - char*40 - Name of each scale-factor table
!   QSFTAB(mxqsf,nqsftab) - real    - Emission scale-factors
!                NQSFTYPE - integer - Number of types of
!                                     emissions scaling factors
!      CQSFTYPE(nqsftype) - char*24 - Name of each scale-factor type
!             MAPIVARY(6) - integer - Map pointer from the 6 IVARY
!                                     choices to the corresponding
!                                     CQSFTYPE() index
!       NQSFVAL(nqsftype) - integer - Number of scaling factors for
!                                     each type
!                                     (Max must = MXQSF in /params/)
!       NQSFCOL(nqsftype) - integer - Number of print columns for each
!       NQSFROW(nqsftype) - integer - Number of print rows for each
!
! --- Temperature and wind speed classes by source type (13)
!              WQSF(5,13) - real    - Wind speed class boundaries (m/s)
!                                     (boundary is upper limit of class)
!             TQSF(11,13) - real    - Temperature class boundaries (K)
!                                     (boundary is upper limit of class)
!     Source Types are:
!            1 = Point         Constant Emissions
!            2 = Point         Variable Emissions (no WS/T class used)
!            3 = Poly. Area    Constant Emissions
!            4 = Poly. Area    Variable Emissions (no WS/T class used)
!            5 = Line          Constant Emissions
!            6 = Line          Variable Emissions (no WS/T class used)
!            7 = Volume        Constant Emissions
!            8 = Grid Volume   Variable Emissions (no WS/T class used)
!            9 = Boundary Condition
!          (10)= Flare         Constant Emissions
!           11 = Flare         Variable Emissions (no WS/T class used)
!           12 = Road          Constant Emissions
!           13 = Road          Variable Emissions (no WS/T class used)
!
!-----------------------------------------------------------------------
      end module mqscale
!-----------------------------------------------------------------------


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     Subroutine supdot performs a matrix vector addtion
!     operation needed for LDBFS geometry optimization
!
!     part of EVB
!

subroutine supdot(s,h,g,n,ig)
implicit real(kind=8) (a-h,o-z)
real(kind=8):: s(*),h(*),g(*)

call DSPMV ( 'U', N, 1.0d0, h, g, 1, 0.0d0, s, 1 )

return

end subroutine supdot


SUBROUTINE rsvgthr(kc,jc,ic,cneq,sdcf,rsv,fsv)

!-------------------------------------------------------------
!
! Gathers rsv vectors and puts solution into sv(:,v+1)
!
!-------------------------------------------------------------

USE invar
IMPLICIT NONE
INTEGER, INTENT(IN) :: kc, jc, ic, cneq
INTEGER :: kt, jt, it, k, j, i, ix1, jx1, ix2, jx2, ieq, sdi
INTEGER :: kcc, jcc, icc, ijc, tz, ty, tx, ii, jj, kk
REAL*8, INTENT(IN) :: sdcf
REAL*8, DIMENSION(cneq,nsdp), INTENT(IN) :: rsv
REAL*8, DIMENSION(neq), INTENT(OUT) :: fsv
REAL*8, DIMENSION(:,:,:), ALLOCATABLE :: tv

kcc = zcf(0)
jcc = ycf(0)
icc = xcf(0)

! Set up the temporary matrix
tz = sdnz
ty = sdny
tx = sdnx
IF (kcc > sdnz) tz = kcc
IF (jcc > sdny) ty = jcc
IF (icc > sdnx) tx = icc
ALLOCATE(tv(tx,ty,tz))
ijc = ic*jc

! Copy all the rsv's to one large matrix tv
sdi = 0
DO kk = 1, kcc
   kt = (kk-1)*sdnz/kc
   DO jj = 1, jcc
      jt = (jj-1)*sdny/jc
      DO ii = 1, icc
         it = (ii-1)*sdnx/ic
         sdi = sdi + 1
         DO k = kt + 1, kt + sdnz/kc
            ix1 = (k-kt-1)*xys/ijc
            DO j = jt + 1, jt + sdny/jc
               ix2 = ix1 + (j-jt-1)*sdnx/ic
               DO i = it + 1, it + sdnx/ic
                  ieq = ix2 + i-it
                  tv(i,j,k) = rsv(ieq,sdi)
               END DO
            END DO
         END DO
      END DO
   END DO
END DO

! Reinitialize fsv using tv
fsv = 0.0
! Now compute average for combined cells/sub-domains
DO k = 1, tz
   ix1 = (k-1)*xys
   IF (kcc > sdnz) ix1 = ((k-1+kcc/sdnz)*sdnz/kcc-1)*xys
   DO j = 1, ty
      ix2 = ix1 + (j-1)*sdnx
      IF (jcc > sdny) ix2 = ix1 + ((j-1+jcc/sdny)*sdny/jcc-1)*sdnx
      DO i = 1, tx
         ieq = ix2 + i
         IF (icc > sdnx) ieq = ix2 + (i-1+icc/sdnx)*sdnx/icc
         fsv(ieq) = fsv(ieq) + tv(i,j,k)*sdcf
      END DO
   END DO
END DO

DEALLOCATE(tv)

RETURN
END SUBROUTINE rsvgthr


subroutine asc(w         ,v0u       ,fr        ,kcmp      ,inaam     , &
             & jdate    ,ierrs     ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: asc.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/io/src/preprocessor/asc.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Determination of FR and V0+U
!              'stripped' VERSION OF MAIN (ASCON)
! Method used:
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    include 'pardef.igd'
!
! Global variables
!
    integer                         :: ierrs  !!  Number of error messages
    integer                         :: kcmp
    integer     , dimension(6)      :: jdate  !!  Date and time
    character(8), dimension(0:kcmp) :: inaam  !!  Name of the referenced components
    real(hp)    , dimension(kcmp)   :: fr     !!  Amplitude factors for the referenced components
    real(hp)    , dimension(kcmp)   :: v0u    !!  Astronomical arguments of the referenced components
    real(hp)    , dimension(kcmp)   :: w      !!  Angular velocity of the referenced components
!
!
! Local variables
!
    integer                           :: i      ! Help var.
    integer                           :: ik     ! Help var.
    integer                           :: il     ! Help var.
    integer                           :: j      ! Help var.
    integer                           :: jaar   ! Present year
    integer      , dimension(16*mxkc) :: jnaam  ! Help var.
    character(8) , dimension(mxkc)    :: knaam  ! Array with the names of all components
    character(80), dimension(mxkc)    :: kombes ! Array with tidal components
    real(hp)                          :: t      ! Time in hours referred to January 1, 00:00 of the year 'JAAR'
    real(hp)     , dimension(15)      :: v      ! Help var. to calculate V0U()
    real(hp)     , dimension(25)      :: f      ! Help var. to calculate FR()
!
!
!! executable statements -------------------------------------------------------
!
    !
    ! Read C0021KOMPBES
    !
    call kompbs(kombes)
    !
    ik = -15
    do i = 1, mxkc
       ik = ik + 16
       il = ik + 15
       read (kombes(i), '(a8,10i3,3(i1,i2))') knaam(i), (jnaam(j), j = ik, il)
    enddo
    !
    ! Loop over the provided times
    !
    jaar = jdate(1)
    !
    call datumi(jaar      ,jdate     ,t         )
    call hulpgr(jaar      ,t         ,v         ,f         )
    call bewvuf(ierrs     ,kcmp      ,mxkc      ,inaam     ,knaam     , &
              & jnaam     ,w         ,v0u       ,fr        ,v         , &
              & f         )
end subroutine asc


	SUBROUTINE SNDCMP  ( nparms, rlevel, nlev, levtyp, lvert,
     +			     sndata, numlev, parms, wavlen, wavspd,
     +			     storm, crdrot, tropht, trpint, cldhgt,
     +			     mxdpth, squall, delz, filtyp, spline,
     +			     nlun, lun, dattim, nlevel, hdata, iret )
C************************************************************************
C* SNDCMP								*
C*									*
C* This subroutine gets the requested sounding data and computes the	*
C* parameters at all the station levels.				*
C*									*
C* SNDCMP  ( NPARMS, RLEVEL, NLEV, LEVTYP, LVERT, SNDATA, NUMLEV, 	*
C*	     PARMS, WAVLEN, WAVSPD, STORM, CRDROT, TROPHT, TRPINT, 	*
C*	     CLDHGT, MXDPTH, SQUALL, DELZ, FILTYP, SPLINE, NLUN, LUN,	*
C*	     DATTIM, NLEVEL, HDATA, IRET )				*
C*									*
C* Input parameters:							*
C*	NPARMS		INTEGER		Number of parameters		*
C*	RLEVEL (LLMXLV)	REAL		Data levels			*
C*	NLEV		INTEGER		Number of levels		*
C*	LEVTYP		INTEGER		Level type			*
C*	LVERT		INTEGER		Vertical coordinate		*
C*	SNDATA (LLMXLV)	REAL		Original sound data		*
C*	NUMLEV		INTEGER		# of original sounding levels	*
C*	PARMS (NPARMS)	CHAR*		Parameters			*
C*	WAVLEN		CHAR*		Length of wave			*
C*	WAVSPD		CHAR*		Speed of wave			*
C*	STORM		CHAR*		Storm speed and direction	*
C*	CRDROT		CHAR*		Coordinate rotations		*
C*	TROPHT		CHAR*		Tropopause height		*
C*	TRPINT		CHAR*		Interval above and below trop	*
C*	CLDHGT		CHAR*		Height of cloud base		*
C*	MXDPTH		CHAR*		Height of mixed layer depth	*
C*	SQUALL		CHAR*		Length of squall line		*
C*	DELZ		CHAR*		Height interval for new sounding*
C*	FILTYP		CHAR*		Filter type			*
C*	SPLINE		LOGICAL		Whether to use splines or not	*
C*	NLUN		INTEGER		Number of file numbers		*
C*	LUN (NLUN)	INTEGER		Output file number		*
C*	DATTIM		CHAR*		Time				*
C*									*
C* Output parameters:							*
C*	NLEVEL		INTEGER		Number of new sounding levels	*
C*	HDATA (LLMXLV)	REAL		New sounding data		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal			*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	 4/92		Copied from SNOCMP		*
C* J. Whistler/SSAI	 4/93		Cleaned up			*
C* J. Whistler/SSAI	 5/93		Filter all of the data		*
C* J. Whistler/SSAI	 6/93		Added check to see if DWPT is	*
C*					interpolated higher than TEMP	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'sndiag.prm'
C*
	PARAMETER	( NUMPTL = 8, NUMPTH = 15 )
	PARAMETER	( NMARL = NUMPTL+1, NMARH = NUMPTH+1 )
C*
	CHARACTER*(*)	wavlen, wavspd, storm, crdrot, tropht, trpint,
     +			cldhgt, mxdpth, squall, delz,  filtyp, parms(*),
     +			dattim
	REAL		rlevel(*), sndata(*), hdata(*)
	LOGICAL		spline
	INTEGER		lun(*)
C*
	CHARACTER	cdata(LLMXDT)
	REAL		hghts(LLMXDT), rdata(LLMXDT),
     +			thtv(LLMXLV), uwnd(LLMXLV), vwnd(LLMXLV),
     +			uabs(LLMXLV), vabs(LLMXLV),
     +			filarl(NMARL), filarh(NMARH)
	LOGICAL		chrflg(MMPARM), cmpflg(MMPARM)
C*
	DATA		filarl /  .3200156553,  .2643210644,
     +				  .1343767864,  .0114831529,
     +				 -.0458900942, -.0377520979,
     +				 -.0064753717,  .0111929411,
     +				  .0087357913 /
C
	DATA		filarh /  .0974726419,  .0954676702,
     +				  .0896329731,  .0804876892,
     +				  .0688283154,  .0556356004,
     +				  .0419626250,  .0288191067,
     +				  .0170670479,  .0073407153,
     +				 0.0000000000, -.0048789007,
     +				 -.0074769889, -.0081766107,
     +				 -.0074864031, -.0059591606 /
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret   = 0
	levout = 0
	knt    = 1
C
C*	Check for list of levels or range.
C
	IF  ( levtyp .eq. 1 )  THEN
C
C*	    Always compute surface data first.
C
	    CALL PC_CMVR  ( 0., lvert, sndata, rdata (knt),
     +			    cdata (knt), ier )
	    IF  ( rlevel (1) .eq. 0. )  THEN
		istart = 2
	      ELSE
		istart = 1
	    END IF
C
C*	    Loop through the list of levels.
C
	    levout = 1
	    knt    = nparms + 1
	    DO  lev = istart, nlev
		CALL PC_CMVR  ( rlevel (lev), lvert, sndata,
     +				rdata (knt), cdata (knt), ier )
		IF  ( .not. ERMISS (rdata (knt) ) )  THEN
		    levout = levout + 1
		    knt    = knt + nparms
		END IF
	    END DO
C
C*	    Check for surface as only data.
C
	    IF  ( ( levout .eq. 1 ) .and. ( rlevel (1) .ne. 0. ) )  THEN
		levout = 0
	    END IF
C
C*	    Check for range with increment.
C
	ELSE IF  ( levtyp .eq. 2 )  THEN
C
C*	    Find bottom level.
C
	    CALL PC_FLVL  ( rlevel (1), lvert, sndata, begin, lvnum1,
     +			    lvnum2, levloc, ier )
	    IF  ( levloc .eq. 1 )  THEN
		ilev = lvnum1
	      ELSE IF  ( levloc .eq. 2 )  THEN
		ilev = lvnum2
	      ELSE IF  ( levloc .eq. 3 )  THEN
		ilev = 1
	      ELSE
		ilev = numlev + 1
	    END IF
C
C*	    Find top level.
C
	    CALL PC_FLVL  ( rlevel (2), lvert, sndata, end, lvnum1,
     +			    lvnum2, levloc, ier )
	    IF  ( levloc .eq. 1 )  THEN
		jlev = lvnum1
	      ELSE IF  ( levloc .eq. 2 )  THEN
		jlev = lvnum1
	      ELSE IF  ( levloc .eq. 4 )  THEN
		jlev = numlev
	      ELSE
		jlev = 0
	    END IF
C
C*	    Always compute surface data first.
C
	    CALL PC_CMVR  ( 0., lvert, sndata, rdata (knt),
     +			    cdata (knt), ier )
	    IF  ( ilev .eq. 1 )  THEN
		iilev = 2
	      ELSE
		iilev = ilev
	    END IF
C
C*	    Compute data at each level.
C
	    levout = 1
	    knt    = nparms + 1
	    DO  lev = iilev, jlev
		CALL PC_CMLV  ( lev, sndata, rdata (knt), cdata (knt),
     +				ier )
		IF  ( .not. ERMISS  ( rdata (knt) ) )  THEN
		    levout = levout + 1
		    knt    = knt + nparms
		END IF
	    END DO
C
C*	    Check for surface as only data.
C
	    IF  ( ( levout .eq. 1 ) .and. ( ilev .ne. 1 ) )  THEN
		levout = 0
	    END IF
	END IF
C
C*	Change missing dewpoints to 40 degrees less than the TEMP.
C
	ll = 1
	DO  n = 1, levout
	    IF  ( ERMISS(rdata((n-1)*nparms+ITEMP)) .and.
     +		  ERMISS(rdata((n-1)*nparms+IDWPT)) )  THEN
	    ELSE
		rdata((ll-1)*nparms+IHGHT) = rdata((n-1)*nparms+IHGHT)
		rdata((ll-1)*nparms+IPRES) = rdata((n-1)*nparms+IPRES)
		rdata((ll-1)*nparms+ITEMP) = rdata((n-1)*nparms+ITEMP)
		rdata((ll-1)*nparms+IDWPT) = rdata((n-1)*nparms+IDWPT)
		rdata((ll-1)*nparms+IUWND) = rdata((n-1)*nparms+IUWND)
		rdata((ll-1)*nparms+IVWND) = rdata((n-1)*nparms+IVWND)
		rdata((ll-1)*nparms+ITHTV) = rdata((n-1)*nparms+ITHTV)
c	write(6,'(7f9.2)' ) rdata((ll-1)*nparms+IHGHT),
c     +			rdata((ll-1)*nparms+IPRES),
c     +			rdata((ll-1)*nparms+ITEMP),
c     +			rdata((ll-1)*nparms+IDWPT),
c     +			rdata((ll-1)*nparms+IUWND),
c     +			rdata((ll-1)*nparms+IVWND),
c     +			rdata((ll-1)*nparms+ITHTV)
	    	IF  ( ERMISS(rdata((ll-1)*nparms+IDWPT)) )
     +		    rdata((ll-1)*nparms+IDWPT) =
     +			rdata((ll-1)*nparms+ITEMP) - 40.
		ll = ll + 1
	    END IF
	END DO
	levout = ll - 1
C
C*	Find average DELZ and put data at these levels.
C*	Also give the user a chance to exit.
C
	CALL SNDARR ( delz, nparms, levout, rdata,
     +		      nlevel, hghts, iret )
	IF  ( iret .ne. 0 )  RETURN
C
C*	Initialize the output array to missing.
C
	DO  i = 1, nlevel*nparms
	    hdata(i) = RMISSD
	END DO
C
	IF  ( spline )  THEN
C
C*	    Fit cubic splines to the data...
C
	    DO  n = 1, ITHTV
		CALL SNDSPL ( nparms, n, levout, rdata,
     +			      nlevel, hghts, hdata, iret )
	    END DO
	    IF  ( nparms .gt. NVAR-2 )  THEN
		CALL SNDSPL ( nparms, ILATI, levout, rdata,
     +			      nlevel, hghts, hdata, iret )
		CALL SNDSPL ( nparms, ILONI, levout, rdata,
     +			      nlevel, hghts, hdata, iret )
	    END IF
	ELSE
C
C*	    ...or interpolate to the new height surfaces.
C
	    CALL SNDINT ( nparms, levout, rdata,
     +			  nlevel, hghts, hdata, iret )
	END IF
C
C*	Check to see if Dewpoint is less than temperature.
C
	DO i = 1, nlevel
	    IF ((( .not. ERMISS ( hdata((i-1)*nparms+IDWPT) )) .and.
     +		 ( .not. ERMISS ( hdata((i-1)*nparms+ITEMP) ))) .and.
     +		( hdata((i-1)*nparms+IDWPT) .gt.
     +		  hdata((i-1)*nparms+ITEMP) ) )
     +		  hdata((i-1)*nparms+IDWPT) = hdata((i-1)*nparms+ITEMP)
	END DO
C
C*	Filter all of the data, if requested. (See below.)
C
	CALL ST_LCUC ( filtyp, filtyp, ier )
	IF  ( filtyp .eq. 'LIGHT' )  THEN
C
C*	    Apply a LIGHT or MESO-PASS filter.
C
C*	    Filter UWND.
C
	    CALL SNDFLT ( NUMPTL, filarl, IUWND, nparms, nlevel,
     +			  hdata, uabs, iret )
C
C*	    Filter VWND.
C
	    CALL SNDFLT ( NUMPTL, filarl, IVWND, nparms, nlevel,
     +			  hdata, vabs, iret )
C
	ELSE IF  ( filtyp .eq. 'HEAVY' )  THEN
C
C*	    Apply a HEAVY or MACRO-PASS filter.
C
C*	    Filter UWND.
C
	    CALL SNDFLT ( NUMPTH, filarh, IUWND, nparms, nlevel,
     +			  hdata, uabs, iret )
C
C*	    Filter VWND.
C
	    CALL SNDFLT ( NUMPTH, filarh, IVWND, nparms, nlevel,
     +			  hdata, vabs, iret )
C
	ELSE
C
C*	    Use NO filter.
C
	    DO  i = 1, nlevel
		uabs(i) = hdata((i-1)*nparms+IUWND)
		vabs(i) = hdata((i-1)*nparms+IVWND)
	    END DO
C
	END IF
	DO  i = 1, nlevel
	    hdata((i-1)*nparms+IUABS) = uabs(i)
	    hdata((i-1)*nparms+IVABS) = vabs(i)
	END DO
C
C*	Calculate the components of the shear for the interpolated
C*	winds, before computing the relative winds.
C
	CALL SNDSHR ( nparms, nlevel, delz, hdata, ier )
C
C*	Calculate relative winds.
C
	CALL SNDWND ( storm, crdrot, nparms, nlevel, hdata, iret )
C
C*	Filter all of the data.
C*	The reference for this procedure is:
C*	    Madden, et al., NCAR Tech note [NCAR-TN/STR-55] (1971).
C
	CALL ST_LCUC ( filtyp, filtyp, ier )
	DO iii = 1, 7
	    IF  ( filtyp .eq. 'LIGHT' )  THEN
C
C*	        Apply a LIGHT or MESO-PASS filter.
C
C*	        Filter THTV.
C
	        CALL SNDFLT ( NUMPTL, filarl, iii, nparms, nlevel,
     +			      hdata, thtv, iret )
	    ELSE IF  ( filtyp .eq. 'HEAVY' )  THEN
C
C*	        Apply a HEAVY or MACRO-PASS filter.
C
C*	        Filter THTV.
C
	        CALL SNDFLT ( NUMPTH, filarh, iii, nparms, nlevel,
     +			      hdata, thtv, iret )
C
	    ELSE
C
C*	        Use NO filter.
C
	        DO  i = 1, nlevel
		    thtv(i) = hdata((i-1)*nparms+iii)
	        END DO
C
	    END IF
C
C*	    Set the data in the large array to the filtered values.
C
	    DO  i = 1, nlevel
	        hdata((i-1)*nparms+iii) = thtv(i)
	    END DO
	END DO
C
C*	Check to see if Dewpoint is less than temperature.
C
	DO i = 1, nlevel
	    IF ((( .not. ERMISS ( hdata((i-1)*nparms+IDWPT) )) .and.
     +		 ( .not. ERMISS ( hdata((i-1)*nparms+ITEMP) ))) .and.
     +		( hdata((i-1)*nparms+IDWPT) .gt.
     +		  hdata((i-1)*nparms+ITEMP) ) )
     +		  hdata((i-1)*nparms+IDWPT) = hdata((i-1)*nparms+ITEMP)
	END DO
C
	jnumlv = nlevel
C
C*	Calculate the:	Intrinsic Frequency		INFQ
C*			Brunt-Vaisala/Intrinsic		BVIN
C*			Scorer Parameter		SCOR
C*			Term 1 of Scorer Parameter	SCR1
C*			Term 2 of Scorer Parameter	SCR2
C
	CALL SNDSCR ( nparms, nlevel, wavlen, wavspd, delz,
     +		      hdata, ier )
C
C*	Compute the mixed layer quantities.
C
	CALL SNDMIX ( nlun, lun, mxdpth, nparms, nlevel, hdata,
     +		      tlcl, plcl, thtwlcl, hlcl, iret )
C
C*	Compute the air and moisture flux.
C
	CALL SNDFLX ( squall, nparms, nlevel, hdata, iret )
C
C*	Compute the wind and lapse rate above and below the trop.
C
	CALL SNDTRP ( tropht, trpint, delz, nlun, lun, nparms, nlevel,
     +		      hdata, iret )
C
C*	Compute the layer properties of the wind.
C
	CALL SNDLYR ( tropht, delz, cldhgt, hlcl, nlun, lun,
     +		      nparms, nlevel, hdata, uabs, vabs, iret )
C
C*	Compute an estimation for the tropopause temp and hght.
C
	CALL SNDEST ( delz, nlun, lun, nparms, nlevel, hdata, iret )
C
C*	Compute the helicity at each level.
C
	CALL SNDHLC ( nparms, nlevel, hdata, iret )
C
C*	Compute the lid strength index, etc.
C
C	CALL SNDLID ( nlun, lun, dattim, nparms, levout, rdata, iret )
C*
	RETURN
	END


! Copyright (c) 1998-2004, University of California, Los Angeles, Emily A. Carter
!                       2004-2016, Princeton University, Emily A. Carter
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this list of
!     conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice, this list
!     of conditions and the following disclaimer in the documentation and/or other
!     materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!     used to endorse or promote products derived from this software without specific
!     prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
! CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
! NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
! STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
! OF THE POSSIBILITY OF SUCH DAMAGE.
!**************************************************************
  !>  \brief THIS MODULE IS RESPONSIBLE FOR COMPUTING THE DIAGONAL
  !>  ELEMENTS OF THE HAMILTONIAN.
  !>  WHEN I SAY DIAGONAL ELEMENTS, I MEAN
  !>  TRULY DIAGONAL ELEMENTS AND ALSO WE COMPUTE THE OFF DIAGONAL
  !>  ELEMENTS CORRESPONDING TO DIFFERENT SPIN FUNCTIONS FOR THE
  !>  SAME SPATIAL CONFIGURATION.  THESE ELEMENTS WILL BE USED FOR
  !>  DAVIDSON PRECONDITIONING AND FORMATION OF THE SIGMA VECTOR HC.
  !>
  !>  FIRST REVISION: 9/1/99 - REWRITTEN TO USE SINGLE TREESEARCH MODULE
  !>  AND DERIVED ORBITAL_PATH DATA TYPE.
  !>
  !>   \date 1999
  !>  \author Derek Walter
!**************************************************************

! Note to reduce the size of symbol names external is abbreviated ext
! add truncation is abbreviated trunc
! David Krisiloff 12/22/2010
!

module diag_element_mod

  use global_var_mod
  use molecule_var_mod
  use locist_mod
  use new_tree_search_mod
  use utilities_mod
  use two_electron_integrals
  implicit none

  integer::test_count=0
  integer, dimension(:), allocatable::head_occupations
  integer, dimension(:), allocatable::tail_occupations
  integer, dimension(:), allocatable::E_vector

  real(real8),allocatable,dimension(:)::diag_head     !// MATRIX TO STORE PARTIAL HAMILTONIAN MATRIX ELEMENTS
  real(real8),allocatable,dimension(:)::diag_tail     !// MATRIX TO STORE PARTIAL HAMILTONIAN MATRIX ELEMENTS

  real(real8), dimension(:), allocatable::diag_ab,full_matrix_ab !// DIAGONAL_AB AND FULL MATRIX ELEMENTS
  real(real8), dimension(:), allocatable::diag_aa,full_matrix_aa !// DIAGONAL_AA AND FULL MATRIX ELEMENTS
  real(real8), dimension(:), allocatable::diag_a,full_matrix_a   !// DIAGONAL_A  AND FULL MATRIX ELEMENTS
  real(real8), dimension(:),allocatable::Hab,Haa,Ha1,Valence

  real(real8), dimension(:), allocatable::diagonal_elements      !// DIAGONAL ELEMENTS OF HAMILTONIAN MATRIX

  contains

subroutine diag_element(cho_data, loc_scr)

  !// THIS SUBROUTINE IS THE MAIN DRIVER ROUTINE FOR COMPUTATION OF THE DIAGONAL ELEMENTS
  !// CALLED BY:                CALLS TO:
  !//    DIAGONALIZE               GETPP
  !//                              GETPPPP
  !//                              GETPPRR
  !//                              GETPRPR
  !//                              OPTIMAL_LEVEL
  !//                              TREE_SEARCH
  !//
  !//   FLOW CHART FOR THIS MODULE:
  !//                      DIAG_ELEMENT
  !//       ___________________|_____________
  !//       |              |                |
  !//    GETPP        OPTIMAL_LEVEL      TREE_SEARCH
  !//    GETPPPP                            |
  !//    GETPPRR                      BUILD_HEAD_ELEMENT
  !//    GETPRPR                            |
  !//                                   TAIL_PATH
  !//                                       |
  !//                                   TREE_SEARCH
  !//                                       |
  !//                                   BUILD_TAIL_ELEMENT
  !//                                       |
  !//                                    JOIN_EM_UP

  use integral_storage_mod                 !// MODULE TO STORE INTEGRALS
  use get_integrals_mod                    !// MODULE FOR OBTAINING INTEGRALS
  use graph_var_mod                        !// GRAPH VARIABLES
  use ci_utilities_mod
  use cholesky_structs
  use locist_var_mod,only:locist_scratch

  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!  VARIABLE DECLARATION !!!!!!!!!!!!!!!!!!!!!!!!!!!
  type(orbital_path)::diag_path
  type(locist_scratch)::loc_scr

  integer::allocatestatus          !// FOR DYNAMIC MEMORY
  integer::deallocatestatus        !// ALSO FOR DYNAMIC MEMORY
  integer::i,j,l                 !// LOOP CONTROL VARIABLES
  integer::matrix_size             !// SIZE OF A MATRIX

  real(real8),parameter::zero = real(0.0,real8)                !// 0.0
  type(cholesky_data)::cho_data
  type(graph_search_state) :: G
  integer :: tmp

  !!!!!!!!!!!!!!!!!!!!!!! VARIABLE INITIALIZATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !// WE NEED TO ALLOCATE THE ARRAYS WHICH MAKE UP THE DERIVED TYPE
  allocate(diag_path%occupations(0:num_orbitals), stat = allocatestatus)
  call allocatecheck(allocatestatus,"%occupat")

  allocate(diag_path%arc_weights(0:num_orbitals), stat = allocatestatus)
  call allocatecheck(allocatestatus,"%arc_wei")

  allocate(diag_path%singles(0:num_orbitals), stat = allocatestatus)
  call allocatecheck(allocatestatus,"%singles")

  tmp = num_orbitals

  !// ALLOCATE THE MODULE WIDE STORAGE ARRAYS
  allocate(head_occupations(num_orbitals + 2), stat = allocatestatus)
  call allocatecheck(allocatestatus,"head_occ")

  allocate(tail_occupations(num_orbitals + 2), stat = allocatestatus)
  call allocatecheck(allocatestatus,"tail_occ")

  !// NOW LETS ALLOCATE ARRAYS FOR STORING MATRIX ELEMENTS
  matrix_size = fsn(open_shells)
  matrix_size = matrix_size*(matrix_size + 1)/2
  allocate(diag_head(matrix_size), stat = allocatestatus)
  call allocatecheck(allocatestatus,"diag_hea")

  allocate(E_vector(fsn(open_shells)),stat = allocatestatus)
  call allocatecheck(allocatestatus,"E_vector")

  allocate(diag_tail(matrix_size), stat = allocatestatus)
  call allocatecheck(allocatestatus,"diag_tai")

  !// NOW ALLOCATE THE ARRAY TO STORE THE DIAGONAL ELEMENTS, WHICH WE WILL
  !// KEEP IN CORE
  if (.not.allocated(diagonal_elements)) then
      allocate(diagonal_elements(total_csfs), stat = allocatestatus)
      call allocatecheck(allocatestatus, "diagonal")
  endif

  write(6,*)"THE MATRIX SIZE IS", matrix_size

  test_count = 0

!  intdebug = 0.0D0

  diagonal_elements = zero  !INITIALIZE

  !!!!!!!!!!!!!!!!!!!!!!!!!!! START OF ROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// NOW WE NEED TO GET THE INTEGRALS WE ARE GOING TO NEED.  WE ARE
  !// GOING TO NEED THE (PP), (PP|PP), (PR|PR), AND (PP|RR).  I HAVE SEPARATE
  !// ROUTINES WHICH ARE RESPONSIBLE FOR GETTING THE INTEGRALS.  THIS WILL MAKE
  !// IT EASIER TO PORT THE CODE FOR USE WITH DIFFERENT PACKAGES THAT HAVE
  !// DIFFERENT ROUTINES FOR GENERATING INTEGRALS

  call getpp

!*****************************************
! Diagonal integrals from Cholesky Vectors
  call getpppp_cho(cho_data)
  call getpprr_cho(cho_data)
  call getprpr_cho(cho_data)
!******************************************

  !!///ARUN ..

  allocate(Haa(matrix_size), stat = allocatestatus)
  call allocatecheck(allocatestatus,"Haa     ")
  Haa = zero

  allocate(Hab(matrix_size), stat = allocatestatus)
  call allocatecheck(allocatestatus,"Hab     ")
  Hab = zero

  allocate(Ha1(matrix_size), stat = allocatestatus)
  call allocatecheck(allocatestatus,"Ha1     ")
  Ha1 = zero

  allocate(Valence(matrix_size), stat = allocatestatus)
  call allocatecheck(allocatestatus,"Valence ")
  Valence = zero

  write(6,*) "Allocated matrix"
  !// REWIND THE DATA FILE
  rewind iodiag1

  !// LOOP OVER THE VERTICES AT THE OPTIMAL LEVEL COMPUTING THE OCCUPATION PATTERNS
  !// AND PARTIAL MATRIX ELEMENTS.  ONCE THIS IS DONE, JOIN THEM
  do i = num_elec-2,num_elec

     !// LETS ZERO OUT THE APPROPRIATE ARRAYS AND INITIALIZE VARIABLES
     diag_path%occupations = 0
     diag_path%arc_weights = 0
     diag_path%singles = 0
     diag_path%num_singles = 0
     diag_path%weight = 0

      !// COMPUTE ALL THE PARTIAL MATRIX ELEMENTS
       call init_tree_search(G, 0, 0, num_internal, i)
       do while ( get_internal_path(diag_path, G))
            call build_head_element(diag_path,loc_scr)
       end do
  enddo

  !// O.K., LETS COMPUTE THE AVERAGE DIAGONAL ELEMENT.  THIS IS A GOOD WAY TO COMPARE
  !// THE RESULTS OF THIS CODE WITH THE RESULTS OF OTHER CODES (LIKE GUGA CODES) BECAUSE
  !// THE TRACE OF THE HAMILTONIAN IS INVARIANT WITH RESPECT TO UNITARY TRANSFORMATIONS

  write(ioOutput,*) "total_csfs diag", total_csfs
  write(ioOutput,500) sum(diagonal_elements)/real(total_csfs, real8)
  write(ioOutput,600) minval(diagonal_elements)
  call flush(ioOutput)
  500 format (1x, "Average Diagonal Element................",f25.13)
  600 format (1x, "Lowest  Diagonal Element ...............",f25.13)

  !// WRITE OUT DIAGONAL ELEMENTS IF REQUESTED
  if (diagprint > 0) then
      write(ioOutput,*) "Diagonal elments printed below."
      j = 1
      do i = 1, total_csfs/10
         write(ioOutput, 510) (diagonal_elements(l), l = j, j+9)
         j = j + 10
      enddo
      write(ioOutput,510) (diagonal_elements(l), l = j,total_csfs)
      510 format(1x,10(f10.3))
      call flush(ioOutput)
  endif

!  write(6,*) "intdebug",intdebug

  !// CLEANUP
  deallocate(diag_path%occupations, stat = deallocatestatus)
  call deallocatecheck(deallocatestatus,"%occupat")

  deallocate(diag_path%arc_weights, stat = deallocatestatus)
  call deallocatecheck(deallocatestatus,"%arc_wei")

  deallocate(diag_path%singles, stat = deallocatestatus)
  call deallocatecheck(deallocatestatus,"%singles")

  deallocate(E_vector, stat = deallocatestatus)
  call deallocatecheck(deallocatestatus,"E_vector")

  deallocate(Haa, Hab, Ha1, Valence, stat = deallocatestatus)
  call deallocatecheck(deallocatestatus,"Hab_aa  ")

end subroutine diag_element

!**************************************************************
subroutine build_head_element(diag_path,loc_scr)

  !// WE NEED TO CALCULATE THE SUMS:
  !// NP(PP) + D(NP,2)(PP|PP) + SUM NP*NR*((PP|RR) - (1/2)(1-D(NP*NR,1))(PR|PR))
  !//                            R
  !// WE WILL STORE THE RESULT IN ELEMENT1 OF THE ORBITAL_PATH DERIVED TYPE

  use graph_var_mod
  use ci_utilities_mod
  use integral_storage_mod
  use utilities_mod
  use locist_var_mod,only:locist_scratch

  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!  VARIABLE DECLARATION !!!!!!!!!!!!!!!!!!!!!!!!!!!
  type(orbital_path)::diag_path
  type(locist_scratch)::loc_scr

  integer::n1,n2              !// KEEPS TRACK OF NUMBER OF SINGLES, DOUBLES
  integer::r                  !// LOOP VARIABLE
  integer::singles, doubles   !// MORE LOOP VARIABLES,MORE DESCRIPTIVE
  integer::p                  !// USED TO HOLD AN ORBITAL LABEL
  integer::number_singles     !// NUMBER OF SINGLES IN THE HEAD PATH
  integer::internal_elec      !// NUMBER OF ELECTRONS IN INTERNALS SPACE

  integer::ab_address,aa_address,a_address,v_address
  integer::i,j,count
  integer::dim0,dim1,dim2             !// SIZE OF A MATRIX
  integer::internal_singles
  integer::internal_weight
  integer::interaction_index
!  integer::allocatestatus
!  integer::deallocatestatus        !// ALSO FOR DYNAMIC MEMORY

  real(real8),parameter::zero = real(0.0,real8),two = real(2.0,real8)       !// 0.0 AND 2.0

  !!!!!!!!!!!!!!!!!!!!!!! VARIABLE INITIALIZATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!
  n1 = 0
  n2 = 0
  number_singles = 0
  diag_path%element1 = zero
  internal_elec = sum(diag_path%occupations(0:num_internal))

  !!!!!!!!!!!!!!!!!!!!!!!!!!! START OF ROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !// FIRST GET NUMBER OF SINGLES IN THE HEAD PATH
  do r = 1,num_internal
      if (diag_path%occupations(r) == 1) number_singles = number_singles + 1
  enddo

  head_occupations(1) = number_singles
  levels: do r = 1,num_internal

      if (diag_path%occupations(r) == 0) then

          cycle levels

      elseif(diag_path%occupations(r) == 1) then

          n1 = n1 + 1
          head_occupations(n1+1) = r
          diag_path%element1 = diag_path%element1 + pp(index2(r,r))

          !// NOW LOOP OVER SINGLES P < R
          do singles = 1, n1-1
              p = head_occupations(1+singles)
              diag_path%element1 = diag_path%element1 + pprr(index2m1(r,p))
          enddo

          !// NOW LOOP OVER DOUBLES
          do doubles = 1, n2
              p = head_occupations(number_singles + 2 + doubles)
              diag_path%element1 = diag_path%element1 + two*pprr(index2m1(r,p)) - prpr(index2m1(r,p))
          enddo

          cycle levels

      elseif(diag_path%occupations(r) == 2) then

          n2 = n2 + 1
          head_occupations(number_singles + 2 + n2) = r
          diag_path%element1 = diag_path%element1 + two*pp(index2(r,r)) + pppp(r)

          !// LOOP OVER SINGLES
          do singles = 1,n1
              p = head_occupations(1 + singles)
              diag_path%element1 = diag_path%element1 + two*pprr(index2m1(r,p)) - prpr(index2m1(r,p))
          enddo

          !// LOOP OVER DOUBLES
          do doubles = 1,n2-1
              p = head_occupations(number_singles + 2 + doubles)
              diag_path%element1 = diag_path%element1 + two*(two*(pprr(index2m1(r,p)))-prpr(index2m1(r,p)))
          enddo

          cycle levels

      endif

  enddo levels

!  intdebug = intdebug + diag_path%element1

  !// LETS RECAP WHAT WE JUST DID HERE.  FOR EACH PARTIAL PATH WE MADE AN ARRAY.  THE FIRST
  !// ELEMENT IN THE ARRAY IS THE NUMBER OF SINGLES IN THE PATH.  FOR EACH SINGLE, THERE
  !// FOLLOWS AN ELEMENT GIVING THE ORBITAL LABEL OF THE FIRST SINGLE, SECOND SINGLE, ETC.
  !// THE NEXT ELEMENT IS GOING TO BE THE NUMBER OF DOUBLES FOLLOWED BY AN ELEMENT FOR EACH
  !// DOUBLE GIVING THE LABEL OF EACH ORBITAL.

  !// LETS PUT IN THE NUMBER OF DOUBLES
  head_occupations(number_singles + 2) = n2

  internal_weight = sum(diag_path%arc_weights(0:num_internal))+1

  !// LETS CALL THIS ROUTINE ELSE WE ARE DONE

  if (internal_elec == num_elec-2) then

!      if (virtual_truncation_flag /=1) then
!          call ext_diag_nm2_aa(diag_path)
!          call ext_diag_nm2_ab(diag_path)
!      else if (virtual_truncation_flag ==1) then
!          if (direct_ci_flag == 933 .and. local_ortho_mos == 0) then
!          call ext_diag_nm2_aa_trunc_direct(diag_path)
!          call ext_diag_nm2_ab_trunc_direct(diag_path)
!          else if (direct_ci_flag == 933 .and. local_ortho_mos == 1) then
          call ext_diag_nm2_aa_trunc_di_lmo(diag_path)
          call ext_diag_nm2_ab_trunc_di_lmo(diag_path,loc_scr)
 !         else
 !         call ext_diag_nm2_aa_truncation(diag_path)
 !         call ext_diag_nm2_ab_truncation(diag_path)
 !         endif
 !     endif

      !// BY THIS TIME I HAVE Hab and Haa for EACH INTERNAL CSF

      internal_weight = sum(diag_path%arc_weights(0:num_internal))+1
      if (skip_this_internal(internal_weight-1,num_elec-2)) then
      else

          interaction_index = 2

          !// GET THE DIMENSION OF SPIN SPACE.
          internal_singles = diag_path%num_singles
          dim2 = fsn(internal_singles+2)

          !// GET THE AB_ADDRESS AND AA_ADDRESS
          ab_address = internal_index_vector2(internal_weight)
          aa_address = internal_index_vector3(internal_weight)

          !// WRITE OUT ALL THE INFO NECESSARY TO DATA FILE
          if (ab_address > 0) then
              count = 0
              do i=1,dim2
                  do j=1,i
                      count = count + 1
                      write(iodiag1) interaction_index
                      write(iodiag1) ab_address,aa_address,internal_weight,i,j, &
                           Hab(count),Haa(count),internal_singles

!                      intdebug = intdebug + Hab(count) + Haa(count)
                  enddo
              enddo

          endif

      endif

  elseif (internal_elec == num_elec-1) then
 !     if (virtual_truncation_flag /=1) then
 !         call ext_diag_nm1(diag_path)
 !     else if (virtual_truncation_flag == 1) then
 !         if (direct_ci_flag == 933 .and. local_ortho_mos == 0) then
!          call ext_diag_nm1_truncation_direct(diag_path)
 !         else if (direct_ci_flag == 933 .and. local_ortho_mos == 1) then
          call ext_diag_nm1_trunc_di_lmo(diag_path,loc_scr)
 !         else
 !         call ext_diag_nm1_truncation(diag_path)
 !         endif
 !     endif

      !// BY THIS TIME I HAVE Ha for EACH INTERNAL CSF
      internal_weight = sum(diag_path%arc_weights(0:num_internal))+1
      if (skip_this_internal(internal_weight-1,num_elec-1)) then
      else

          interaction_index = 1

          !// GET THE DIMENSION OF SPIN SPACE.
          internal_singles = diag_path%num_singles
          dim1 = fsn(internal_singles+1)

          !// GET THE A_ADDRESS
          a_address = internal_index_vector1(internal_weight)

          !// WRITE OUT ALL THE INFO NECESSARY TO DATA FILE
          if (a_address > 0) then
              count = 0
              do i=1,dim1
                  do j=1,i
                      count = count + 1
                      write(iodiag1) interaction_index
                      write(iodiag1) a_address,internal_weight,i,j,Ha1(count),internal_singles

                  enddo
              enddo
          endif
      endif

  elseif (internal_elec == num_elec) then

      call external_diag_valence(diag_path)

      !// BY THIS TIME I HAVE valence for EACH INTERNAL CSF
      internal_weight = sum(diag_path%arc_weights(0:num_internal))+1
      if (skip_this_internal(internal_weight-1,num_elec)) then
      else

          interaction_index = 0

          !// GET THE DIMENSION OF SPIN SPACE.
          internal_singles = diag_path%num_singles
          dim0 = fsn(internal_singles)

          !// GET THE V_ADDRESS
          v_address = internal_index_vector0(internal_weight)

          !// WRITE OUT ALL THE INFO NECESSARY TO DATA FILE
          if (v_address > 0) then
              count = 0
              do i=1,dim0
                  do j=1,i
                      count = count + 1
                      write(iodiag1) interaction_index
                      write(iodiag1) v_address,internal_weight,i,j,Valence(count),internal_singles

                  enddo
              enddo
          endif
      endif
  endif

end subroutine build_head_element

!**************************************************************
subroutine external_diag_valence(diag_path)

  !// WE NEED TO CALCULATE THE SUMS:
  !// NP(PP) + D(NP,2)(PP|PP) + SUM NP*NR*((PP|RR) - (1/2)(1-D(NP*NR,1))(PR|PR))
  !//                            R
  !// HERE WE WILL STORE THE RESULT IN ELEMENT2 OF THE ORBITAL_PATH DERIVED TYPE.
  !// THIS ROUTINE IS FOR VALENCE STATES.

  use graph_var_mod
  use spin_var_mod
  use ci_utilities_mod
  use integral_storage_mod
  use utilities_mod
!  use integral_transform_mod,ONLY: ijij_int

  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!  VARIABLE DECLARATION !!!!!!!!!!!!!!!!!!!!!!!!!!!
  type(orbital_path),intent(in)::diag_path

  integer::r                   !// LOOP VARIABLE
  integer::p                   !// USED TO HOLD AN ORBITAL LABEL
  integer::spin_dim            !// DIMENSION OF THE SPIN SPACE
  integer::internal_weight     !// WEIGHT OF INTERNAL PART OF PATH
  integer::internal_singles    !// NUMBER OF SINGLES IN THE INTERNAL SPACE

  integer::v_address           !// ADDRESS OF VALENCE STATES
  integer::pbar,rbar           !// THE INDICES USED IN REPRESENTATIONS MATRICES US(pbar,rbar)
  integer::sf1,sf2             !// INDEXING SPIN FUNCTIONS
  integer::head_singles        !// HEAD SINGLES
  integer::v_start_1,v_end_1   !// STARTING AND ENDING POSITIONS FOR FIRST SPIN FUNCTION
  integer::v_start_2,v_end_2   !// STARTING AND ENDING POSITIONS FOR SECOND SPIN FUNCTION
  integer::transposition_label !// TRANSPOSITION LABEL
  integer::integral_label      !// INTEGRAL LABEL INDEX
  integer::row_offset          !// ROW OFFSET FOR TRANSPOSITIONS

  integer::count

  real(real8)::full_val        !// FULL ELEMENT FOR VALENCE STATE
  real(real8)::transposition_element  !// TRANSPOSITION ELEMENTS
  real(real8),parameter::zero = real(0.0,real8),two = real(2.0,real8)              !// NUMBERS 0.0 AND 2.0
  !!!!!!!!!!!!!!!!!!!!!!! VARIABLE INITIALIZATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!

  head_singles = head_occupations(1)

  internal_singles = diag_path%num_singles
  internal_weight = sum(diag_path%arc_weights(0:num_internal))+1

  !!!!!!!!!!!!!!!!!!!!!!!!!!! START OF ROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// CHECK TO SEE IF WE SHOULD SKIP THIS INTERNAL......
  if (skip_this_internal(internal_weight-1,num_elec)) return

  v_address = internal_index_vector0(internal_weight)

  if (v_address < 0) return

  !!!!!!!!!!!!!!!!!!!
  !//
  !// VALENCE STATE
  !//
  !!!!!!!!!!!!!!!!!!!

  spin_dim = fsn(internal_singles)

  count = 0

  !// NO PURELY EXTERNAL PART TO THE MATRIX ELEMENT IN THIS CASE,
  !// ALSO, NO INTERNAL/EXTERNAL CROSS TERMS
  do sf1 = 1,spin_dim

      v_start_1 = v_address + (sf1-1)
      v_end_1   = v_start_1

      row_offset = sf1*(sf1-1)/2

      do sf2 = 1,sf1

          v_start_2 = v_address + (sf2-1)
          v_end_2   = v_start_2

          !// ADD THE RELEVANT CONTRIBUTIONS FOR CASES WHERE WE ARE
          !// DIAGONAL IN THE SPIN SPACE

          !// ADD IN THE PURELY INTERNAL PART OF THE TRANSPOSITION
          !// SUM.  WE DO THIS HERE, RATHER THAN IN THE CALLING
          !// ROUTINE BECAUSE WE HAVE ARRAYS ALLOCATED

          full_val = zero
          do rbar = 2, head_singles
             r = head_occupations(1 + rbar)
             do pbar = 1,rbar-1
                p = head_occupations(1 + pbar)
                transposition_label = index2m1(rbar, pbar)
                transposition_element = transpositions(transposition_label,row_offset+sf2)

                     integral_label = index2m1(r,p)
                     full_val = full_val +&
                             transposition_element*prpr(integral_label)

             enddo
          enddo

          !// NO PURELY EXTERNAL TERM FOR THIS CASE

          !// THERE IS NO ADD INTERNAL/EXTERNAL CROSS TERMS FOR
          !// VALENCE STATES

          if (sf1 == sf2) full_val =  full_val + diag_path%element1

          !// STORE FULL DIAGONAL ELEMENTS FOR DAVIDSON
          !// PRECONDITIONING
          if (sf1 == sf2) then
              diagonal_elements(v_start_1) = full_val
          endif

          !// NOW, WRITE MATRIX ELEMENTS TO DISK
          !// CODE TO WRITE GOES HERE....
          !if (virtual_truncation_flag /=1) then
          !   write(iodiag) v_address,sf1,sf2,0
          !   write(iodiag) full_val,v_start_1,v_start_2
          !endif

          !// WE NEED THIS
          count = count + 1
          Valence(count) = full_val

      enddo

  enddo

end subroutine external_diag_valence

!*************************************************************
Subroutine ext_diag_nm2_ab_trunc_di_lmo(diag_path,loc_scr)

  !// WE NEED TO CALCULATE THE SUMS:
  !// NP(PP) + D(NP,2)(PP|PP) + SUM NP*NR*((PP|RR) - (1/2)(1-D(NP*NR,1))(PR|PR))
  !//                            R
  !// HERE WE WILL STORE THE RESULT IN ELEMENT2 OF THE ORBITAL_PATH DERIVED TYPE.
  !// THIS ROUTINE IS FOR STATES HAVING TWO VIRTUALS SINGLY OCCUPIED

  use graph_var_mod
  use spin_var_mod
  use ci_utilities_mod
  use integral_storage_mod
  use utilities_mod
  use locist_var_mod,only:locist_scratch
!  use integral_transform_mod ,ONLY: iijj_int,ijij_int,pprr_new,prpr_new,pppp_new

  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!  VARIABLE DECLARATION !!!!!!!!!!!!!!!!!!!!!!!!!!!
  type(orbital_path),intent(in)::diag_path
  type(locist_scratch),intent(inout)::loc_scr

  integer::p                   !// USED TO HOLD AN ORBITAL LABEL
  integer::r                   !// LOOP VARIABLE
  integer::spin_dim            !// DIMENSION OF THE SPIN SPACE
  integer::internal_weight     !// WEIGHT OF INTERNAL PART OF PATH
  integer::internal_singles    !// NUMBER OF SINGLES IN THE INTERNAL SPACE
  integer::allocatestatus
  integer::deallocatestatus

  integer::ab_address          !// ADDRESS OF AB
  integer::a,b                 !// INDEXING EXTERNAL ORBITALS
  integer::ab_count            !// COUNT FOR EXTERNAL ORBITALS
  integer::pbar,rbar           !// THE INDICES USED IN REPRESENTATIONS MATRICES US(pbar,rbar)
  integer::sf1,sf2             !// INDEXING SPIN FUNCTIONS
  integer::head_singles        !// HEAD SINGLES
  integer::ab_start_1,ab_end_1 !// STARTING AND ENDING POSITIONS FOR FIRST SPIN FUNCTION
  integer::ab_start_2,ab_end_2 !// STARTING AND ENDING POSITIONS FOR SECOND SPIN FUNCTION
  integer::transposition_label !// TRANSPOSITION LABEL
  integer::integral_label      !// INTEGRAL LABEL INDEX
  integer::row_offset          !// ROW OFFSET FOR TRANSPOSITIONS
  integer::count
  integer::num_virtC2
  integer::ione
  integer::idum,idum2
  integer,dimension(num_orbitals)::virt_store

  real(real8)::transposition_element  !// TRANSPOSITION ELEMENTS
  real(real8),parameter::zero = real(0.0,real8),two = real(2.0,real8)               !// NUMBERS 0.0 AND 2.0
  real(real8)::temp_nm2_ab

  !!!!!!!!!!!!!!!!!!!!!!! VARIABLE INITIALIZATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!

  head_singles = head_occupations(1)

  internal_singles = diag_path%num_singles
  internal_weight = sum(diag_path%arc_weights(0:num_internal))+1

  !!!!!!!!!!!!!!!!!!!!!!!!!!! START OF ROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// CHECK TO SEE IF WE SHOULD SKIP THIS INTERNAL......

  if (skip_this_internal(internal_weight-1,num_elec-2)) return

  ab_address = internal_index_vector2(internal_weight)

  if (ab_address < 0) return

  !// NOTE THE CHANGE BELOW
  loc_scr%num_virt = num_allowed_virtuals(internal_weight,"d")
  virt_store = 0
  call get_virtuals(internal_weight,"d",virt_store)

  num_virtC2 = loc_scr%num_virt*(loc_scr%num_virt-1)/2
  ione = num_orbitals*(num_orbitals-1)/2

!  write(6,*)"I'm into ext_diag_nm2_ab_trunc_direct"

  allocate(diag_ab(num_virtC2),stat=allocatestatus)
  call allocatecheck(allocatestatus,"diag_ab ")

  allocate(full_matrix_ab(num_virtC2),stat=allocatestatus)
  call allocatecheck(allocatestatus,"full_ab ")
! NOTICE FULL_MATRIX_AB AND DIAG_AB ARE OF THE SAME DIMENSION

  !!!!!!!!!!!!!!!!!!!
  !//
  !// TWO VIRTUALS SINGLY OCCUPIED
  !//
  !!!!!!!!!!!!!!!!!!!

  spin_dim = fsn(internal_singles + 2)

  !// BUILD PURELY EXTERNAL PART OF THE MATRIX ELEMENTS
  !// WHICH DOESN'T DEPEND ON SPIN INDEX
  ab_count = 0
  do a = 1,loc_scr%num_virt
     idum = virt_store(a)
     do b = 1,a-1
        idum2 = virt_store(b)
        ab_count = ab_count + 1
        integral_label = index2m1(idum,idum2)

!call check_integral(pprr(integral_label),idum,idum,idum2,idum2)

        diag_ab(ab_count) = pprr(integral_label) + pp(index2(idum,idum)) + pp(index2(idum2,idum2))
      enddo
  enddo

  !// SET UP DIAGONAL PARTS OF Uss(S-1,S)
  !E_vector(1:spin_dim) = E_matrix_as_vector(diag_path%num_singles + 2)

  count = 0

  do sf1 = 1,spin_dim

      ab_start_1 = ab_address + (sf1-1)*num_virtC2
      ab_end_1   = ab_start_1 + num_virtC2 - 1

      row_offset = sf1*(sf1-1)/2

      do sf2 = 1,sf1

          ab_start_2 = ab_address + (sf2-1)*num_virtC2
          ab_end_2   = ab_start_2 + num_virtC2 - 1

          !// ADD THE RELEVANT CONTRIBUTIONS FOR CASES WHERE WE ARE
          !// DIAGONAL IN THE SPIN SPACE

          !// ADD IN THE PURELY INTERNAL PART OF THE TRANSPOSITION
          !// SUM.  WE DO THIS HERE, RATHER THAN IN THE CALLING
          !// ROUTINE BECAUSE WE HAVE ARRAYS ALLOCATED

          full_matrix_ab = zero
          temp_nm2_ab = zero
             do rbar = 2, head_singles
               r = head_occupations(1 + rbar)
                 do pbar = 1,rbar-1
                    p = head_occupations(1 + pbar)
                transposition_label = index2m1(rbar, pbar)
                transposition_element = transpositions(transposition_label,row_offset+sf2)

                integral_label = index2m1(r,p)

!                call check_integral(prpr(integral_label),p,r,p,r)

                full_matrix_ab = full_matrix_ab +&
                             transposition_element*prpr(integral_label)
                        temp_nm2_ab  = temp_nm2_ab  + &
                             transposition_element*prpr(integral_label)
             enddo
          enddo

          !// ADD PURELY EXTERNAL TERM COMING FROM TRANSPOSITION
          transposition_label = index2m1(internal_singles+1,internal_singles+2)
          transposition_element = transpositions(transposition_label,row_offset+sf2)
          ab_count = 0
          do a = 1,loc_scr%num_virt
             idum = virt_store(a)
             do b = 1,a-1
                idum2 = virt_store(b)
                ab_count = ab_count + 1
                integral_label = index2m1(idum,idum2)

!                call check_integral( prpr(integral_label), idum , idum2, idum, idum2 )

                full_matrix_ab(ab_count) = full_matrix_ab(ab_count) + &
                                           transposition_element*prpr(integral_label)
              enddo
          enddo

          !// NOW ADD INTERNAL/EXTERNAL CROSS TERMS
          call add_ab_int_ext_cross_trunc_lmo(diag_path,row_offset,sf1,sf2,loc_scr%num_virt,virt_store(1:loc_scr%num_virt))

          !// ADD THE CONTRIBUTIONS FROM PURELY EXTERNAL AND PURELY INTERNAL PART.
          if (sf1 == sf2) full_matrix_ab = full_matrix_ab + diag_ab + diag_path%element1
          if (sf1 == sf2) temp_nm2_ab = temp_nm2_ab + diag_path%element1

! DIAG_PATH%ELEMENT1 FROM BUILD_HEAD_ELEMENT

          !// STORE FULL DIAGONAL ELEMENTS FOR DAVIDSON
          !// PRECONDITIONING
          if (sf1 == sf2) then
              diagonal_elements(ab_start_1:ab_end_1) = full_matrix_ab
          endif

          !// LETS STORE Hab
          count = count + 1
          Hab(count) = temp_nm2_ab
! Hab IS OF SPIN DIMENSION
      enddo

  enddo

  deallocate(diag_ab,stat=deallocatestatus)
  call deallocatecheck(deallocatestatus,"diag_ab ")

  deallocate(full_matrix_ab,stat=deallocatestatus)
  call deallocatecheck(deallocatestatus,"full_ab ")

end subroutine ext_diag_nm2_ab_trunc_di_lmo
!*************************************************************
Subroutine add_ab_int_ext_cross_trunc_lmo(diag_path,row_offset,sf1,sf2,num_virt,virt_store)

  !// NOW WE JOIN UP THE INTERNAL AND EXTERNAL SPACE CONTRIBUTIONS.
  !// HERE THE EXTERNAL SPACE IS HAVING TWO VIRTUALS SINGLY OCCUPIED.
  !// TO JOIN THE CONTRIBUTIONS WE NEED TO ADD THE INTERNAL AND
  !// EXTERNAL SPACE DIRECTLY AND WE NEED TO DO THE INTERNAL/
  !// EXTERNAL SPACE CROSS TERMS

  use ci_utilities_mod
  use graph_var_mod
  use spin_var_mod
  use integral_storage_mod
  use utilities_mod
  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!  VARIABLE DECLARATION !!!!!!!!!!!!!!!!!!!!!!!!!!!
  !// ALOT OF VARIABLES HERE.  WE ARE PUTTING TOGETHER ALL THE INFORMATION FRO ALL
  !// THE PREVIOUS ROUTINES

  type(orbital_path),intent(in)::diag_path

  integer::head_singles          !// ALSO A LOOP CONTROL VARIABLE, NUMBER OF SINGLES IN HEAD PATH
  integer::head_doubles          !// NUMBER OF DOUBLES IN A HEAD PATH
  integer::pbar                  !// ORBITAL POSITION INDICES; USED AS LOOP CONTROL VARIABLES
  integer::p                     !// ORBITAL INDICES
  integer::transposition_label   !// LABEL FOR THE TRANSOSITION WE NEED
  integer::integral_label        !// INDEX FOR THE INTEGRAL WE NEED
  integer::internal_singles      !// NUMBER OF SINGLES IN INTERNAL SPACE
  integer::a,b                   !// INDEXING EXTERNAL ORBITALS
  integer::ab_count              !// COUNT FOR EXTERNAL ORBITALS
  integer,intent(in)::sf1,sf2               !// INDEXING SPIN FUNCTIONS
  integer,intent(in)::row_offset            !// ROW OFFSET FOR TRANSPOSITIONS
  integer,intent(in)::num_virt
  integer::idum,idum2
  integer,dimension(num_orbitals),intent(in)::virt_store

  real(real8),parameter::zero = real(0.0, real8),two = real(2.0, real8),four  = real(4.0, real8)    !// NUMBERS 0.0,2.0 and 4.0
  real(real8)::transposition_element !// TRANSPOSITION ELEMENT
  real(real8)::ppaa,ppbb,papa,pbpb   !// INTEGRALS
  !!!!!!!!!!!!!!!!!!!!!!! VARIABLE INITIALIZATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// WE NEED TO REAL QUICKLY GET THE TAIL_SINGLES, TAIL_DOUBLES, ETC.
  head_singles = head_occupations(1)
  head_doubles = head_occupations(2 + head_singles)

  internal_singles = diag_path%num_singles

  !!!!!!!!!!!!!!!!!!!!!!!!!!! START OF ROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// NOW WE DO TAIL SINGLES/HEAD SINGLES FOR NP*NR(PP|RR) AND
  !// US(PBAR,RBAR)(PR|PR)
  do pbar = 1, head_singles
      p = head_occupations(1 + pbar)
      ab_count = 0
      do a = 1,num_virt
         idum = virt_store(a)
         do b = 1,a-1
            idum2 = virt_store(b)
            ab_count = ab_count + 1

              !!!!!!!
              !//
              !// FIRST DO A (A > B)
              !//
              !!!!!!!

              transposition_label = index2m1(internal_singles+2,pbar)
              transposition_element = transpositions(transposition_label,row_offset+sf2)

              integral_label = index2m1(p,idum)

!              call check_integral( prpr(integral_label), p, idum , p , idum)
!              call check_integral( pprr(integral_label), p, p, idum , idum)

              full_matrix_ab(ab_count) = full_matrix_ab(ab_count) +&
                                         transposition_element*prpr(integral_label)
              if (sf1 == sf2) full_matrix_ab(ab_count) = full_matrix_ab(ab_count) + pprr(integral_label)

              !!!!!!!
              !//
              !// NOW DO B  (B < A)
              !//
              !!!!!!!

              transposition_label = index2m1(internal_singles+1,pbar)
              transposition_element = transpositions(transposition_label,row_offset+sf2)

! THIS IS THE PART YOU CAN DO SCREENING.... IF BELOW THRESHOLD ... SKIP...

              integral_label = index2m1(p,idum2)

!              call check_integral( prpr(integral_label), p , idum2, p, idum2)
!              call check_integral( pprr(integral_label), p, p, idum2, idum2)

              full_matrix_ab(ab_count) = full_matrix_ab(ab_count) +&
                                         transposition_element*prpr(integral_label)

              if (sf1 == sf2) full_matrix_ab(ab_count) = full_matrix_ab(ab_count) + &
                                                         pprr(integral_label)
          enddo
      enddo
  enddo

  !// NOW DO THE TAIL SINGLES/HEAD DOUBLES 2(PP|RR) - (PR|PR)
  if (sf1 == sf2) then
      do pbar = 1, head_doubles
          p = head_occupations(2+head_singles+pbar)
          ab_count = 0
          do a = 1,num_virt
             idum = virt_store(a)
             do b = 1,a-1
                idum2 = virt_store(b)
               ab_count = ab_count + 1

                  !!!!!!!
                  !//
                  !// FIRST DO A (A > B)
                  !//
                  !!!!!!!

                  integral_label = index2m1(p,idum)
                  ppaa = pprr(integral_label)
                  papa = prpr(integral_label)

!                  call check_integral(papa, p, idum, p, idum)
!                  call check_integral(ppaa, p, p, idum, idum)

                   full_matrix_ab(ab_count) = full_matrix_ab(ab_count) + two*ppaa - papa

                  !!!!!!!
                  !//
                  !// NOW DO B  (B < A)
                  !//
                  !!!!!!!

                  integral_label = index2m1(p,idum2)
                  ppbb = pprr(integral_label)
                  pbpb = prpr(integral_label)

!                  call check_integral( pbpb, p, idum2, p, idum2)
!                  call check_integral( ppbb, p, p, idum2, idum2)

                  full_matrix_ab(ab_count) = full_matrix_ab(ab_count) + two*ppbb - pbpb

              enddo
          enddo
      enddo
  endif

end subroutine add_ab_int_ext_cross_trunc_lmo
!**************************************************
 subroutine ext_diag_nm2_aa_trunc_di_lmo(diag_path)

  !// WE NEED TO CALCULATE THE SUMS:
  !// NP(PP) + D(NP,2)(PP|PP) + SUM NP*NR*((PP|RR) - (1/2)(1-D(NP*NR,1))(PR|PR))
  !//                            R
  !// HERE WE WILL STORE THE RESULT IN ELEMENT2 OF THE ORBITAL_PATH DERIVED TYPE.
  !// THIS ROUTINE IS FOR STATES HAVING ONE VIRTUAL DOUBLY OCCUPIED

  use graph_var_mod
  use spin_var_mod
  use ci_utilities_mod
  use integral_storage_mod
  use utilities_mod
  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!  VARIABLE DECLARATION !!!!!!!!!!!!!!!!!!!!!!!!!!!
  type(orbital_path),intent(in)::diag_path

  integer::p                   !// USED TO HOLD AN ORBITAL LABEL
  integer::r                   !// LOOP VARIABLE
  integer::spin_dim            !// DIMENSION OF THE SPIN SPACE
  integer::internal_weight     !// WEIGHT OF INTERNAL PART OF PATH
  integer::internal_singles    !// NUMBER OF SINGLES IN THE INTERNAL SPACE
  integer::allocatestatus
  integer::deallocatestatus

  integer::aa_address          !// ADDRESS OF AA
  integer::a                   !// INDEXING EXTERNAL ORBITAL  A
  integer::count             !// COUNT FOR EXTERNAL ORBITAL A
  integer::pbar,rbar           !// THE INDICES USED IN REPRESENTATIONS MATRICES US(pbar,rbar)
  integer::sf1,sf2             !// INDEXING SPIN FUNCTIONS
  integer::head_singles        !// HEAD SINGLES
  integer::aa_start_1,aa_end_1 !// STARTING AND ENDING POSITIONS FOR FIRST SPIN FUNCTION
  integer::aa_start_2,aa_end_2 !// STARTING AND ENDING POSITIONS FOR SECOND SPIN FUNCTION
  integer::transposition_label !// TRANSPOSITION LABEL
  integer::integral_label      !// INTEGRAL LABEL INDEX
  integer::row_offset          !// ROW OFFSET FOR TRANSPOSITIONS
  integer::num_virt,num_virtC2
  integer::idum
  integer,dimension(num_orbitals)::virt_store

  real(real8)::transposition_element  !// TRANSPOSITION ELEMENTS
  real(real8),parameter::zero = real(0.0,real8),two = real(2.0,real8)               !// NUMBERS 0.0 AND 2.0
  real(real8)::temp_nm2_aa

  !!!!!!!!!!!!!!!!!!!!!!! VARIABLE INITIALIZATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!

  head_singles = head_occupations(1)

  internal_singles = diag_path%num_singles
  internal_weight = sum(diag_path%arc_weights(0:num_internal))+1

  !!!!!!!!!!!!!!!!!!!!!!!!!!! START OF ROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// CHECK TO SEE IF WE SHOULD SKIP THIS INTERNAL......

  if (skip_this_internal(internal_weight-1,num_elec-2)) return

  aa_address = internal_index_vector3(internal_weight)

  if (aa_address < 0) return

  !// LETS DO THIS FOR TRUNCATION TO GET THE RIGHT INTEGRALS
  !// COMPUTE TOTAL NUMBER OF ORBITALS .. THIS NEED NOT BE THE SAME AS IT DEPENDS ON TRUNCATION

  num_virt = num_allowed_virtuals(internal_weight,"d")
  virt_store = 0
  call  get_virtuals(internal_weight,"d",virt_store)
  num_virtC2 = num_virt*(num_virt-1)/2
  !ione = num_orbitals*(num_orbitals-1)/2

  if (num_virt <= 0) return

  allocate(diag_aa(num_virt),stat=allocatestatus)
  call allocatecheck(allocatestatus,"diag_aa ")

  allocate(full_matrix_aa(num_virt),stat=allocatestatus)
  call allocatecheck(allocatestatus,"full_aa ")

  !!!!!!!!!!!!!!!!!!!
  !//
  !// ONE VIRTUAL DOUBLY OCCUPIED
  !//
  !!!!!!!!!!!!!!!!!!!

  spin_dim = fsn(internal_singles)

  count = 0

  !// BUILD PURELY EXTERNAL PART OF THE MATRIX ELEMENTS
  !// WHICH DOESN'T DEPEND ON SPIN INDEX
  do a = 1,num_virt
     idum = virt_store(a)

!     call check_integral( pppp(idum), idum, idum, idum, idum)

     diag_aa(a) = two*pp(index2(idum,idum)) + pppp(idum)
  enddo

!          write(*,*) "Diagonal elements before this particular step = ", diagonal_elements

  do sf1 = 1,spin_dim

      aa_start_1 = aa_address + (sf1-1)*num_virt
      aa_end_1   = aa_start_1 + num_virt - 1

      row_offset = sf1*(sf1-1)/2

      do sf2 = 1,sf1

          aa_start_2 = aa_address + (sf2-1)*num_virt
          aa_end_2   = aa_start_2 + num_virt - 1

          !// ADD THE RELEVANT CONTRIBUTIONS FOR CASES WHERE WE ARE
          !// DIAGONAL IN THE SPIN SPACE

          !// ADD IN THE PURELY INTERNAL PART OF THE TRANSPOSITION
          !// SUM.  WE DO THIS HERE, RATHER THAN IN THE CALLING
          !// ROUTINE BECAUSE WE HAVE ARRAYS ALLOCATED

          full_matrix_aa = zero
          temp_nm2_aa = zero

          do rbar = 2, head_singles
              r = head_occupations(1 + rbar)
              do pbar = 1,rbar-1
                  p = head_occupations(1 + pbar)
                  transposition_label = index2m1(rbar, pbar)
                  transposition_element = transpositions(transposition_label,row_offset+sf2)

                  integral_label = index2m1(r,p)

!                  call check_integral(prpr(integral_label), r,p,r,p)

                  full_matrix_aa = full_matrix_aa +&
                       transposition_element*prpr(integral_label)
                  temp_nm2_aa = temp_nm2_aa +   &
                       transposition_element*prpr(integral_label)
!                  write(*,*) "Full matrix aa = ", full_matrix_aa
                  flush(6)
              enddo
          enddo

 !         write(*,*) "Full matrix aa (prepost) = ", full_matrix_aa

          !// NO PURELY EXTERNAL TERM FOR USs

          !// NOW ADD INTERNAL/EXTERNAL CROSS TERMS

          call add_aa_int_ext_cross_trunc_lmo(diag_path,sf1,sf2,num_virt,virt_store(1:num_virt))

          !// ADD THE CONTRIBUTIONS FROM PURELY EXTERNAL AND PURELY INTERNAL
          if (sf1 == sf2) full_matrix_aa = full_matrix_aa + diag_aa + diag_path%element1
          if (sf1 == sf2) temp_nm2_aa = temp_nm2_aa +  diag_path%element1

!          write(*,*) "Diag aa = ", diag_aa
 !         write(*,*) "Diag path = ", diag_path%element1

  !        write(*,*) "Full matrix aa (post) = ", full_matrix_aa

          !// STORE FULL DIAGONAL ELEMENTS FOR DAVIDSON
          !// PRECONDITIONING
          if (sf1 == sf2) then
              diagonal_elements(aa_start_1:aa_end_1) = full_matrix_aa
          endif

!          write(*,*) "Diagonal elements at this particular step = ", diagonal_elements

          !// LETS STORE Haa
          count = count + 1
          Haa(count) = temp_nm2_aa

      enddo

  enddo

  deallocate(diag_aa,stat=deallocatestatus)
  call deallocatecheck(deallocatestatus,"diag_aa ")

  deallocate(full_matrix_aa,stat=deallocatestatus)
  call deallocatecheck(deallocatestatus,"full_aa ")

end subroutine ext_diag_nm2_aa_trunc_di_lmo
!*************************************************************
Subroutine add_aa_int_ext_cross_trunc_lmo(diag_path,sf1,sf2,num_virt,virt_store)

  !// NOW WE JOIN UP THE INTERNAL AND EXTERNAL SPACE CONTRIBUTIONS.
  !// HERE THE EXTERNAL SPACE IS HAVING ONE VIRTUAL DOUBLY OCCUPIED.
  !// TO JOIN THE CONTRIBUTIONS WE NEED TO ADD THE INTERNAL AND
  !// EXTERNAL SPACE DIRECTLY AND WE NEED TO DO THE INTERNAL/
  !// EXTERNAL SPACE CROSS TERMS

  use ci_utilities_mod
  use graph_var_mod
  use spin_var_mod
  use integral_storage_mod
  use utilities_mod
  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!  VARIABLE DECLARATION !!!!!!!!!!!!!!!!!!!!!!!!!!!
  !// ALOT OF VARIABLES HERE.  WE ARE PUTTING TOGETHER ALL THE INFORMATION FRO ALL
  !// THE PREVIOUS ROUTINES

  type(orbital_path),intent(in)::diag_path

  integer::head_singles          !// ALSO A LOOP CONTROL VARIABLE, NUMBER OF SINGLES IN HEAD PATH
  integer::head_doubles          !// NUMBER OF DOUBLES IN A HEAD PATH
  integer::pbar                  !// ORBITAL POSITION INDICES; USED AS LOOP CONTROL VARIABLES
  integer::p                     !// ORBITAL INDICES
  integer::integral_label        !// INDEX FOR THE INTEGRAL WE NEED
  integer::internal_singles      !// NUMBER OF SINGLES IN INTERNAL SPACE
  integer::a                     !// INDEXING EXTERNAL ORBITAL A
  integer,intent(in)::sf1,sf2               !// INDEXING SPIN FUNCTIONS
  integer,intent(in)::num_virt
  integer::idum
  integer,dimension(num_orbitals),intent(in)::virt_store
  real(real8)::ppaa,papa

  real(real8),parameter::zero = real(0.0, real8),two = real(2.0, real8),four = real(4.0, real8)         !// NUMBERS 0.0,2.0 and 4.0
  !!!!!!!!!!!!!!!!!!!!!!! VARIABLE INITIALIZATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// WE NEED TO REAL QUICKLY GET THE TAIL_SINGLES, TAIL_DOUBLES, ETC.
  head_singles = head_occupations(1)
  head_doubles = head_occupations(2 + head_singles)

  internal_singles = diag_path%num_singles

  !!!!!!!!!!!!!!!!!!!!!!!!!!! START OF ROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// NOW WE DO TAIL DOUBLES/HEAD SINGLES FOR NP*NR(PP|RR) AND
  !// US(PBAR,RBAR)(PR|PR)
  if (sf1 == sf2) then
  do pbar = 1, head_singles
      p = head_occupations(1 + pbar)
      do a = 1,num_virt
         idum = virt_store(a)

         integral_label = index2m1(p,idum)
         ppaa = pprr(integral_label)
         papa = prpr(integral_label)

!         call check_integral( ppaa, p, p, idum, idum)
!         call check_integral( papa, p, idum, p, idum)

         full_matrix_aa(a) = full_matrix_aa(a)+ two*ppaa - papa
      enddo
  enddo
  endif

  !// NOW DO THE TAIL DOUBLES/HEAD DOUBLES 2(PP|RR) - (PR|PR)
  if (sf1 == sf2) then
      do pbar = 1, head_doubles
          p = head_occupations(2+head_singles+pbar)
          do a = 1,num_virt
             idum = virt_store(a)

             integral_label = index2m1(p,idum)
             ppaa = pprr(integral_label)
             papa = prpr(integral_label)

!             call check_integral( ppaa, p, p, idum, idum)
!             call check_integral( papa, p, idum ,p, idum)

             full_matrix_aa(a) = full_matrix_aa(a) + four*ppaa - two*papa

          enddo
      enddo
  endif

end subroutine add_aa_int_ext_cross_trunc_lmo
!*************************************************************
subroutine ext_diag_nm1_trunc_di_lmo(diag_path,loc_scr)

  !// WE NEED TO CALCULATE THE SUMS:
  !// NP(PP) + D(NP,2)(PP|PP) + SUM NP*NR*((PP|RR) - (1/2)(1-D(NP*NR,1))(PR|PR))
  !//                            R
  !// HERE WE WILL STORE THE RESULT IN ELEMENT2 OF THE ORBITAL_PATH DERIVED TYPE.
  !// THIS ROUTINE IS FOR STATES HAVING ONE VIRTUAL SINGLY OCCUPIED

  use graph_var_mod
  use spin_var_mod
  use ci_utilities_mod
  use integral_storage_mod
  use utilities_mod
  use locist_var_mod,only:locist_scratch
  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!  VARIABLE DECLARATION !!!!!!!!!!!!!!!!!!!!!!!!!!!
  type(orbital_path),intent(in)::diag_path
  type(locist_scratch),intent(inout)::loc_scr

  integer::p                   !// USED TO HOLD AN ORBITAL LABEL
  integer::r                   !// LOOP VARIABLE
  integer::spin_dim            !// DIMENSION OF THE SPIN SPACE
  integer::internal_weight     !// WEIGHT OF INTERNAL PART OF PATH
  integer::internal_singles    !// NUMBER OF SINGLES IN THE INTERNAL SPACE
  integer::allocatestatus
  integer::deallocatestatus

  integer::a_address           !// ADDRESS OF A
  integer::a                   !// INDEXING EXTERNAL ORBITAL  A
  integer::count               !// COUNT
  integer::pbar,rbar           !// THE INDICES USED IN REPRESENTATIONS MATRICES US(pbar,rbar)
  integer::sf1,sf2             !// INDEXING SPIN FUNCTIONS
  integer::head_singles        !// HEAD SINGLES
  integer::a_start_1,a_end_1   !// STARTING AND ENDING POSITIONS FOR FIRST SPIN FUNCTION
  integer::a_start_2,a_end_2   !// STARTING AND ENDING POSITIONS FOR SECOND SPIN FUNCTION
  integer::transposition_label !// TRANSPOSITION LABEL
  integer::integral_label      !// INTEGRAL LABEL INDEX
  integer::row_offset          !// ROW OFFSET FOR TRANSPOSITIONS
  integer::idum
  integer,dimension(num_orbitals) :: virt_store

  real(real8)::transposition_element  !// TRANSPOSITION ELEMENTS
  real(real8),parameter::zero = real(0.0,real8),two = real(2.0,real8)               !// NUMBERS 0.0 AND 2.0

  real(real8)::temp_nm1

  !!!!!!!!!!!!!!!!!!!!!!! VARIABLE INITIALIZATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!

  head_singles = head_occupations(1)

  internal_singles = diag_path%num_singles
  internal_weight = sum(diag_path%arc_weights(0:num_internal))+1

  !!!!!!!!!!!!!!!!!!!!!!!!!!! START OF ROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// CHECK TO SEE IF WE SHOULD SKIP THIS INTERNAL......
  if (skip_this_internal(internal_weight-1,num_elec-1)) return

  a_address = internal_index_vector1(internal_weight)

  if (a_address < 0) return

  !// LETS DO THIS FOR TRUNCATION TO GET THE RIGHT INTEGRALS
  !// COMPUTE TOTAL NUMBER OF ORBITALS .. THIS NEED NOT BE THE SAME AS IT DEPENDS ON TRUNCATION

  virt_store = 0
  loc_scr%num_virt = num_allowed_virtuals(internal_weight,"s")
  call get_virtuals(internal_weight,"s",virt_store)

  allocate(diag_a(loc_scr%num_virt),stat=allocatestatus)
  call allocatecheck(allocatestatus,"diag_a  ")

  allocate(full_matrix_a(loc_scr%num_virt),stat=allocatestatus)
  call allocatecheck(allocatestatus,"full_a  ")
  !!!!!!!!!!!!!!!!!!!
  !//
  !// ONE VIRTUAL SINGLY OCCUPIED
  !//
  !!!!!!!!!!!!!!!!!!!

  spin_dim = fsn(internal_singles+1)

  count = 0

  !// BUILD PURELY EXTERNAL PART OF THE MATRIX ELEMENTS
  !// WHICH DOESN'T DEPEND ON SPIN INDEX
  diag_a = zero
  do a = 1,loc_scr%num_virt
     idum = virt_store(a)
     diag_a(a) = pp(index2(idum,idum))
  enddo

  do sf1 = 1,spin_dim

      a_start_1 = a_address + (sf1-1)*loc_scr%num_virt
      a_end_1   = a_start_1 + loc_scr%num_virt - 1

      row_offset = sf1*(sf1-1)/2

      do sf2 = 1,sf1

          a_start_2 = a_address + (sf2-1)*loc_scr%num_virt
          a_end_2   = a_start_2 + loc_scr%num_virt - 1

          !// ADD THE RELEVANT CONTRIBUTIONS FOR CASES WHERE WE ARE
          !// DIAGONAL IN THE SPIN SPACE

          !// ADD IN THE PURELY INTERNAL PART OF THE TRANSPOSITION
          !// SUM.

          full_matrix_a = zero
          temp_nm1 = zero
          do rbar = 2, head_singles
             r = head_occupations(1 + rbar)
             do pbar = 1,rbar-1
                p = head_occupations(1 + pbar)
                transposition_label = index2m1(rbar, pbar)
                transposition_element = transpositions(transposition_label,row_offset+sf2)

                integral_label = index2m1(r,p)

!                call check_integral( prpr(integral_label), r,p,r,p)

                        full_matrix_a = full_matrix_a + transposition_element*prpr(integral_label)
                        temp_nm1 = temp_nm1 + transposition_element*prpr(integral_label)

             enddo
          enddo

          !// ADD THE FOLLOWING CONTRIBUTIONS FOR DIAGONAL IN SPIN SPACE
          if (sf1 == sf2) temp_nm1 = temp_nm1 + diag_path%element1
          !// TEMP_NM1 CONTAINS ONLY CONRIBUTIONS NOW INVOLVING INTERNAL TERMS

          !// NO PURELY EXTERNAL TERM FOR THIS CASE INVOLVING TRANSPOSITIONS (USs)

          !// NOW ADD INTERNAL/EXTERNAL CROSS TERMS
          call add_nm1_int_ext_cross_trunc_lmo(diag_path,row_offset,sf1,sf2,loc_scr%num_virt,virt_store(1:loc_scr%num_virt) )

          !// ADD THE CONTRIBUTIONS FROM PURELY EXTERNAL AND PURELY PART
          if (sf1 == sf2) full_matrix_a = full_matrix_a + diag_a + diag_path%element1

          !// STORE FULL DIAGONAL ELEMENTS FOR DAVIDSON
          !// PRECONDITIONING

          if (sf1 == sf2) then
              diagonal_elements(a_start_1:a_end_1) = full_matrix_a
          endif

          !// COPY TEMP_NM1 TO Ha1
          count = count + 1
          Ha1(count) = temp_nm1

!          intdebug = intdebug + temp_nm1 + sum(diag_a(:))

      enddo
  enddo

  deallocate(diag_a,stat=deallocatestatus)
  call deallocatecheck(deallocatestatus,"diag_a  ")

  deallocate(full_matrix_a,stat=deallocatestatus)
  call deallocatecheck(deallocatestatus,"full_a  ")

end subroutine ext_diag_nm1_trunc_di_lmo
!**************************************************************
Subroutine add_nm1_int_ext_cross_trunc_lmo(diag_path,row_offset,sf1,sf2,num_virt,virt_store)

  !// NOW WE JOIN UP THE INTERNAL AND EXTERNAL SPACE CONTRIBUTIONS.
  !// HERE THE EXTERNAL SPACE IS HAVING ONE VIRTUAL SINGLY OCCUPIED.
  !// TO JOIN THE CONTRIBUTIONS WE NEED TO ADD THE INTERNAL AND
  !// EXTERNAL SPACE DIRECTLY AND WE NEED TO DO THE INTERNAL/
  !// EXTERNAL SPACE CROSS TERMS

  use ci_utilities_mod
  use graph_var_mod
  use spin_var_mod
  use integral_storage_mod
  use utilities_mod
!  use integral_transform_mod ,ONLY: iijj_int,ijij_int,pprr_new,prpr_new,pppp_new

  implicit none

  !!!!!!!!!!!!!!!!!!!!!!!!!!!  VARIABLE DECLARATION !!!!!!!!!!!!!!!!!!!!!!!!!!!
  !// ALOT OF VARIABLES HERE.  WE ARE PUTTING TOGETHER ALL THE INFORMATION FRO ALL
  !// THE PREVIOUS ROUTINES

  type(orbital_path),intent(in)::diag_path

  integer::head_singles          !// ALSO A LOOP CONTROL VARIABLE, NUMBER OF SINGLES IN HEAD PATH
  integer::head_doubles          !// NUMBER OF DOUBLES IN A HEAD PATH
  integer::pbar                  !// ORBITAL POSITION INDICES; USED AS LOOP CONTROL VARIABLES
  integer::p                     !// ORBITAL INDICES
  integer::transposition_label   !// LABEL FOR THE TRANSOSITION WE NEED
  integer::integral_label        !// INDEX FOR THE INTEGRAL WE NEED
  integer::internal_singles      !// NUMBER OF SINGLES IN INTERNAL SPACE
  integer::a                     !// INDEXING EXTERNAL ORBITALS
  integer,intent(in)::sf1,sf2               !// INDEXING SPIN FUNCTIONS
  integer,intent(in)::row_offset            !// ROW OFFSET FOR TRANSPOSITIONS
  integer,intent(in)::num_virt
  integer::idum
  integer,dimension(num_orbitals),intent(in)::virt_store

  real(real8),parameter::zero = real(0.0, real8),two = real(2.0, real8),four = real(4.0, real8)         !// NUMBERS 0.0,2.0 and 4.0
  real(real8)::transposition_element !// TRANSPOSITION ELEMENT
  real(real8)::ppaa,papa             !// INTEGRALS
  !!!!!!!!!!!!!!!!!!!!!!! VARIABLE INITIALIZATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// WE NEED TO REAL QUICKLY GET THE TAIL_SINGLES, TAIL_DOUBLES, ETC.
  head_singles = head_occupations(1)
  head_doubles = head_occupations(2 + head_singles)

  internal_singles = diag_path%num_singles

  !!!!!!!!!!!!!!!!!!!!!!!!!!! START OF ROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !// NOW WE DO TAIL SINGLES/HEAD SINGLES FOR NP*NR(PP|RR) AND
  !// US(PBAR,RBAR)(PR|PR)

  do pbar = 1, head_singles
      p = head_occupations(1 + pbar)
      do a = 1,num_virt
         idum = virt_store(a)

         transposition_label = index2m1(internal_singles+1,pbar)
         transposition_element = transpositions(transposition_label,row_offset+sf2)

         integral_label = index2m1(idum,p)
         ppaa = pprr(integral_label)

!         call check_integral(ppaa, idum,idum,p,p)
!         call check_integral( prpr(integral_label), idum, p, idum, p)

         full_matrix_a(a) = full_matrix_a(a) +&
         transposition_element*prpr(integral_label)

         if (sf1 == sf2) full_matrix_a(a) = full_matrix_a(a) + ppaa

      enddo
  enddo

  !// NOW DO THE TAIL SINGLES/HEAD DOUBLES 2(PP|RR) - (PR|PR)
  if (sf1 == sf2) then
      do pbar = 1, head_doubles
         p = head_occupations(2+head_singles+pbar)
         do a = 1,num_virt
            idum = virt_store(a)

            integral_label = index2m1(p,idum)
            ppaa = pprr(integral_label)
            papa = prpr(integral_label)

!            call check_integral( ppaa, p, p, idum, idum)
!            call check_integral( papa, p, idum, p, idum)

            full_matrix_a(a) = full_matrix_a(a) + two*ppaa - papa
          enddo
      enddo
  endif

end subroutine add_nm1_int_ext_cross_trunc_lmo

!*************************************************************
  !> \brief Clears the current diagonal elements
  subroutine delete_diagonal_elements()
      implicit none
      ! we don't include diagonal_elements here as we usually deallocate immediately after use
      ! since its the size of the wavefunction

      call try_deallocate_int_1D(head_occupations, "head_occ")
      call try_deallocate_int_1D(tail_occupations, "tail_occ")
      call try_deallocate_int_1D(E_vector, "E_vector")

      call try_deallocate_real_1D(diag_head, "diag_head")
      call try_deallocate_real_1D(diag_tail, "diag_tail")
      call try_deallocate_real_1D(diag_ab, "diag_ab")
      call try_deallocate_real_1D(full_matrix_ab, "full_matrix_ab")
      call try_deallocate_real_1D(diag_aa, "diag_aa")
      call try_deallocate_real_1D(full_matrix_aa, "full_matrix_aa")
      call try_deallocate_real_1D(diag_a, "diag_a")
      call try_deallocate_real_1D(full_matrix_a, "full_matrix_a")
      call try_deallocate_real_1D(Hab, "Hab")
      call try_deallocate_real_1D(Haa, "Haa")
      call try_deallocate_real_1D(Ha1, "Ha1")
      call try_deallocate_real_1D(Valence, "Valence")

      rewind(iodiag1)
  end subroutine

end module diag_element_mod