c ********************************************************************
c *                                                                  *
c *  routines to support crack growth by smcs criterion              *
c *                                                                  *
c ********************************************************************
c
c
c     ****************************************************************
c     *                                                              *
c     *                      subroutine dam_print_elem3              *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 04/18/96                   *
c     *                                                              *
c     *     This routine prints out the status of SMCS elements      *
c     *     marked as killable at the beginning of a load step       *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine dam_print_elem3( step, iter )
      use global_data ! old common.main
      use elem_extinct_data, only : dam_state, dam_print_list,
     &     old_plast_strain
      use main_data, only : output_packets, packet_file_no
      use damage_data
      implicit integer (a-z)
c
      double precision
     &    dummy, eps_plas, eps_crit, sig_mean, sig_mises, eps_plas_tol,
     &    d_eps_plas, max_d_eps_plas, ddummy1, ddummy2, ddummy3
      logical ldummy, debug, ldummy2
      data zero, debug, eps_plas_tol / 0.0, .false., 1.0e-9 /
c
      max_d_eps_plas = zero
c
c           print the header
c
      write(out,*) ' '
      write(out,*) ' ********************************************* '
      write(out,*) ' ***         Killable element status       *** '
      write(out,*) ' ********************************************* '
c
      write(out,*)
      if ( load_size_control_crk_grth ) then
         write(out,9020)
      else
         write(out,9030)
      end if
c
c          parse the order list
c
      local_count = 0
      do elem_loop = 1, num_print_list
         element  = dam_print_list(elem_loop)
         elem_ptr = dam_ptr(element)
c
c             check if element is a killable element and/or if it has
c             already been killed.
c
         if ( dam_ptr(element) .eq. 0 ) cycle
         if ( dam_state(elem_ptr) .ne. 0 ) cycle
c
c             get current smcs parameters for element and print.
c
         ldummy2 = .false.
         call dam_param( element, ldummy, debug, dummy, eps_plas,
     &                   eps_crit, sig_mean, sig_mises,
     &                   ldummy2, ddummy2, ddummy3 )
         if ( eps_plas .gt. eps_plas_tol ) then
            if ( load_size_control_crk_grth ) then
               d_eps_plas = eps_plas -
     &             old_plast_strain(dam_ptr(element))
               max_d_eps_plas = max(max_d_eps_plas, d_eps_plas)
               write(out,9000) element, eps_plas, eps_crit, sig_mean,
     &              sig_mises, d_eps_plas
            else
               write(out,9000) element, eps_plas, eps_crit, sig_mean,
     &              sig_mises
            endif
            local_count = local_count + 1
         end if
      end do
c
c
c
c
c          packet output section
c
c
c
      if ( output_packets .and. local_count .ne. 0 )then
c
c
         if (load_size_control_crk_grth) then
           write( packet_file_no ) 23, local_count, step, iter
         else
           write( packet_file_no ) 22, local_count, step, iter
         end if
c
c
c
      do elem_loop = 1, num_print_list
         element  = dam_print_list(elem_loop)
         elem_ptr = dam_ptr(element)
c
c             check if element is a killable element and/or if it has
c             already been killed.
c
         if ( dam_ptr(element) .eq. 0 ) cycle
         if ( dam_state(elem_ptr) .ne. 0 ) cycle
c
c             get current smcs parameters for element and print.
c
         ldummy2 = .false.
         call dam_param( element, ldummy, debug, dummy, eps_plas,
     &                   eps_crit, sig_mean, sig_mises,
     &                   ldummy2, ddummy2, ddummy3 )
         if ( eps_plas .gt. eps_plas_tol ) then
            if ( load_size_control_crk_grth ) then
               d_eps_plas = eps_plas -
     &             old_plast_strain(dam_ptr(element))
               max_d_eps_plas = max(max_d_eps_plas, d_eps_plas)
               write(packet_file_no) element, eps_plas, eps_crit,
     &              sig_mean, sig_mises, d_eps_plas
            else
               write(packet_file_no) element, eps_plas, eps_crit,
     &              sig_mean, sig_mises
            endif
         end if
      end do
c
c
      end if
c
c
c         end of packet output section
c
c
c
c
      if ( load_size_control_crk_grth ) then
         write (out,9010) max_d_eps_plas
      else
         write (out,*) ' '
      end if
c
      return
c
 9000 format(1x,i7,5(1x,e14.6))
 9010 format(/,5x,'>> Maximum change in plastic strain for this step:',
     &     e13.6,/)
 9020 format(1x,'element   eps-pls        eps-crit      ',
     &       'sig-mean       sig-mises       d(eps-pls)',/,1x,
     &       '-------   -------        --------      ',
     &       '--------       ---------       ----------')
 9030 format(1x,'element   eps-pls        eps-crit      ',
     &       'sig-mean       sig-mises',/,1x,
     &       '-------   -------        --------      ',
     &       '--------       ---------')
c
      end


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  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 registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

!    Date:       22 Oct 1992
!    Time:       21:16
!    Program:    SOLVEX.FOR
!    Version:    6.00.00
!    Programmer: Nicolaas M de Rooij
!
      subroutine solvex(k1,str6)
      include  'char1.inc'
      logical done,done2
      character*6 str6
      if(intitl .ne. 846342) then
        write(*,1233)
1233    format(' corrupt module ')
        call chexit
      endif
      done  = .false.
      done2 = .false.
      kk = k1
1     if(kk.eq.0) then
! second order wanted
        call solve2(kk)
        if(ierror .eq. 3) call solve2(kk)
        if(ierror .eq. 1) go to 999
        if(ierror .eq. 8) then
!          write(not,1234)kk
!1234      format(' second order failed ',i4)
! change to projection
          kk  = 1
        endif
      endif
      if(kk .eq. 1)then
! projection wanted, or second order failed
        call solve2(kk)
        if(ierror .eq. 3) call solve2(kk)
        if(ierror .eq. 1) go to 999
        if(ierror .eq. 8) then
          if(done) go to 90
!          write(not,1235)kk
!1235      format(' projection failed ',i4)
! if simplex already done go to sec order
          if(kk .eq. 2) then
            done = .true.
            kk = 0
            go to 1
          endif
! change to simplex
          kk  = 2
        endif
      endif
! simplex wanted or projection failed
      if(kk .eq. 2)then
        call solve2(kk)
        if(ierror .eq. 3) call solve2(kk)
        if(ierror .eq. 1) go to 999
        write(not,1236)kk
1236    format(' simplex failed ',i4)
!        write(not,1237)str6
!1237    format('****warning:  solve could not find a solution in ',a6)
        if(.not.done) then
! simplex failed, try once projection
          done = .true.
          kk = 1
          go to 1
        endif
      endif
! all failed
90    if(done2) go to 99
      if(ierror .ne. 8) go to 99
      do 92 i=1,m
      b(i) = b(i) * 1.00000001
92    continue
      done2 = .true.
      kk = 0
      go to 1
99    write(not,1201) ierror,str6,(nr(i,1),b(i),i=1,m),
     2   (kn(j),c(j),j=1,ntot),(kn(j),x(j),j=1,ntot)
1201  format(' error in solve, ierror is: ',i4, /,'called by: ',a6,/,
     2  '  b,c,x is: ',/,999(a6,6x,e18.10,/))
999   continue
      call phcalc
      call ehcalc
      call ceccal
      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.
!**************************************************************
  !//  MOLECULE_VAR_MOD - THIS MODULE IS USED TO PASS AROUND INFORMATION
  !//  REGARDING THE MOLECULE.  IT INCLUDES THINGS LIKE THE SPIN, THE
  !//  NUMBER OF ATOMS, THE NUMBER OF ELECTRONS, ETC. WE ALSO PASS AROUND
  !//  ANY RELEVANT BASIS SET INFORMATION THAT WE MAY NEED.
  !//
  !//  WRITTEN BY DEREK WALTER, 1999
  ! WARNING: THIS CODE DOES NOT CONFORM TO Y2K STANDARDS!!
!**************************************************************

module molecule_var_mod
  use global_var_mod, ONLY: real8
  implicit none

  integer::num_elec        !// NUMBER OF ELECTRONS
  integer::num_atoms       !// NUMBER OF ATOMS
  integer::spinM           !// SPIN MULTIPLICITY
  integer::num_internal    !// NUMBER OF INTERNAL ORBITALS (OCCUPIED IN A REFERENCE)
  integer::num_external    !// NUMBER OF EXTERNAL ORBITALS (UNOCCUPIED IN REFERENCES)
  integer::num_active      !// NUMBER OF ACTIVE ORBITALS (SINGLY OR VARIABLY OCCUPIED IN REFERENCES)
  integer::num_inactive    !// NUMBER OF INACTIVE ORBITALS (DOUBLE OCCUPIED IN REFERENCES; NUM_ACTIVE + NUM_INACTIVE =
  			             !// NUM_INTERNAL)
  integer::num_frozen      !// NUMBER OF FROZEN ORBITALS
  integer::nm2csfs         !// TOTAL NUMBER OF N-2 CSFS (DOUBLY EXCITED)
  integer::num_extC2       !// NUMBER OF EXTERNALS CHOOSE 2
  integer::num_orbitals    !// TOTAL NUMBER OF ORBITALS (NUM_ORBITALS = NUM_ACTIVE + NUM_INACTVE + NUM_EXTERNAL
  			             !//                                        = NUM_INTERNAL + NUM_EXTERNAL
  			             !//                                        = NUMBER_BAS)

  integer::num_orbitalsC2  !// TOTAL NUMBER OF ORBITALS CHOOSE TWO

  integer::number_bas      !// NUMBER OF BASIS FUNCTIONS. SHOULD EQUAL NUM_ORBITALS, OR WE HAVE A PROBLEM.
  integer::number_basC2    !// NUMBER OF BASIS FUNCTIONS CHOOSE TWO
  integer::num_ref         !// NUMBER OF REFERENCES

  integer::numcho          !// MAXIMUM RANK OF CHOLESKY VECTORS

  integer, dimension(:,:), allocatable::references  !// THIS ARRAY SHOULD BE DIMENSIONED TO HAVE NUM_REF COLUMNS AND
  						  !// NUM_ORBITALS ROWS.  THE ELEMENTS OF EACH COLUMN WILL THEN
  						  !// CONTAIN THE OCCUPATION PATTERN FOR EACH REFERENCE.
  Real(kind=real8),dimension(:,:),allocatable::ci_guess     !// USER INPUT WEIGHT AND CI COEFFICIENTS

end module molecule_var_mod


	subroutine wrtphi
c
cNB uses phimap3 as a temp storage for phimap in case
c want to write not potentials bu salt concentraions
c
	include "qdiffpar4.h"
	include "qlog.h"
        parameter (mgrid=65)
c
      real phimap(igrid,igrid,igrid)
	character*80 filnam
	character*10 nxtlbl
      character*20 uplbl
      character*16 botlbl
c b+++++++++++++++++++++++++++for back compatibility with single precision phi readers
      real*4 phimap4(1),phimap3(ngp)
	real*4 scalesingle,scalesingle1,oldmidsingle(3),oldmidsingle1(3)
	real*4 minim,maxim,somma,average
      integer igrid1

	scalesingle=scale
      oldmidsingle(1)=oldmid(1)
      oldmidsingle(2)=oldmid(2)
      oldmidsingle(3)=oldmid(3)

      if (realsiz.ne.4.and.phifrm.ne.2) then
	   i_phimap4=memalloc(i_phimap4,realsiz,igrid*igrid*igrid)
	   i=1
         do iz=1,igrid
         do iy=1,igrid
         do ix=1,igrid
            phimap4(i)=phimap(ix,iy,iz)
	      i=i+1
         end do
         end do
         end do
      end if
	  write(6,*) phimap(5,5,5)
	  write(6,*) phimap4(5+(5-1)*igrid+(5-1)*igrid*igrid)

c e++++++++++++++++++++++++++++
c
	if(iconc) then
        i_phimap3= memalloc(i_phimap3,realsiz,ngp)
	i=1
	do iz=1,igrid
	do iy=1,igrid
	do ix=1,igrid
	phimap3(i)=phimap(ix,iy,iz)
	i=i+1
	end do
	end do
	end do
	call phicon
	end if
c
	if(ibios) then
c
c write phimap in insight format
c

	  open(14,file=phinam(:philen),form="unformatted")
	  filnam = ' '
	  inquire(14,name = filnam)
	  write(6,*)'potential map written in INSIGHT format to file'
	  write(6,*)filnam
	  write(6,*)'  '
	  ivary = 0
	  nbyte = 4
	  intdat = 0
	  xang = 90.
	  yang = 90.
	  zang = 90.
	  intx = igrid - 1
	  inty = igrid - 1
	  intz = igrid - 1
	  xmax = 0.
	  do 9040 k = 1,3
	    temp = abs(oldmid(k))
	    xmax = max(xmax,temp)
9040	  continue
	  range = (igrid-1.)/(2.*scale)
	  extent = range + xmax
	  xstart = (oldmid(1)-range)/extent
	  ystart = (oldmid(2)-range)/extent
	  zstart = (oldmid(3)-range)/extent
	  xend = (oldmid(1)+range)/extent
	  yend = (oldmid(2)+range)/extent
	  zend = (oldmid(3)+range)/extent
        write(14)toplbl
	  write(14)ivary,nbyte,intdat,extent,extent,extent,
     1  xang,yang,zang,xstart,xend,ystart,yend,zstart,
     1  zend,intx,inty,intz
         print*,' in wrtphi, realsiz,toplbl=', realsiz,toplbl
	  if (realsiz.ne.4) then
          call wrtphimap(igrid,phimap4,1)
	  else
	    do 9044 k = 1,igrid
	    do 9043 j = 1,igrid
		  write(14)(phimap(i,j,k),i=1,igrid)
9043	    continue
9044	    continue
	  end if

c
	elseif(phifrm.eq.2)then
c GRASP phimap - output a 65^3 grid and leave out ngrid spec.
c
          write(6,*)'  '
          write(6,*)'writing potential map in GRASP format'
          write(6,*)'  '
c
          i_phimap4=memalloc(i_phimap4,realsiz,mgrid*mgrid*mgrid)
          call expand(mgrid)
          open(14,file=phinam(:philen),form="unformatted")
          filnam = ' '
          inquire(14,name = filnam)
          write(6,*)'potential map written to file'
          write(6,*)filnam
          write(6,*)'  '
          if(iconc.and.(rionst.ne.0)) then
          nxtlbl="concentrat"
          else
          nxtlbl="potential "
          end if
        write(14)'now starting phimap '
        write(14)nxtlbl,toplbl
c        write(14)phimap4
        call wrtphimap(mgrid,phimap4,0)
        write(14)' end of phimap  '
        write(14)scalesingle,oldmidsingle
        close(14)
          i_phimap4=memalloc(i_phimap4,0,0)
c b++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	elseif(phifrm.eq.3)then
c CCP4 phimap - output
c
	  write(6,*)'  '
	  write(6,*)'writing potential map in CCP4 format'
	  write(6,*)'  '
c       '(A20)'
	  open(14,file=phinam(:philen),form="unformatted")
	    filnam = ' '
	    inquire(14,name = filnam)
	    write(6,*)'potential map written to file'
	    write(6,*)filnam
  	    write(6,*)'  '
c NC,NR,NS,MODE,NCSTART,NRSTART,NSSTART,NX,NY,NZ
          write(14)igrid,igrid,igrid,2,1,1,1,igrid-1,igrid-1,igrid-1
c X Y Z lengths, alpha
	    write(14)(igrid-1)/scale,(igrid-1)/scale,(igrid-1)/scale,90.0
c beta, gamma,MAPC,MAPR,MAPS
		write(14)90.0,90.0,1,2,3
c
		minim=10000.0
	    maxim=-10000.0
	    if (realsiz.ne.4) then
	        i=1
			do iz=1,igrid
			do iy=1,igrid
			do ix=1,igrid
			  if (phimap4(i).lt.minim) minim=phimap4(i)
			  if (phimap4(i).gt.maxim) maxim=phimap4(i)
			  somma=somma+phimap4(i)
	          i=i+1
			end do
			end do
			end do
	        average=somma/(igrid*igrid*igrid)
	    else
			do iz=1,igrid
			do iy=1,igrid
			do ix=1,igrid
				if (phimap(ix,iy,iz).lt.minim) minim=phimap(ix,iy,iz)
				if (phimap(ix,iy,iz).gt.maxim) maxim=phimap(ix,iy,iz)
				somma=somma+phimap(ix,iy,iz)
			end do
			end do
			end do
              average=somma/(igrid*igrid*igrid)
	    end if
c amin, amax, amean,ispg,nsymbt,LSKFLG
		write(14)minim,maxim,average,1,1,0
c skwmat(3,3)
          write(14)0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0
c skwtrn(3),future use
          write(14)0.0,0.0,0.0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
          write(14)'MAP '
c MACHST,ARMS,NLABL
          write(14)1,0.0,0
	    do ii=1,200
	      write(14)0
	    end do
	    if (realsiz.ne.4) then
	      call wrtphimap(igrid,phimap4,0)
	    else
             write(14)phimap
	    end if
          close(14)

	elseif(phifrm.eq.4)then
c diffrential phimap -
c
          write(6,*)'  '
          write(6,*)'reading previous.phi file'
	    write(6,*) realsiz, phimap(5,5,5)
	    write(6,*) phimap4(5+(5-1)*igrid+(5-1)*igrid*igrid)
          write(6,*)'  '
c
          open(14,file="previous.phi",form="unformatted")
             read(14)uplbl
	       read(14)nxtlbl,toplbl
             write(6,*)uplbl,nxtlbl,toplbl
             call rdphimap(igrid,phimap4)
	       read(14)botlbl
		   read(14)scalesingle1,oldmidsingle1,igrid1
	       write(6,*)botlbl,scalesingle1,oldmidsingle1
          close(14)
          if ((scalesingle1.ne.scalesingle).or.(oldmidsingle1(1).ne.
     &      oldmidsingle(1)).or.(oldmidsingle1(2).ne.oldmidsingle(2)).
     &      or.(oldmidsingle1(3).ne.oldmidsingle(3)).or.(igrid1.ne.
     &      igrid)) then
	        write(6,*) 'Error: the two potential maps do not mach'
	        return
	    endif
          write(6,*)phimap4(5+(5-1)*igrid+(5-1)*igrid*igrid)
	    if (realsiz.ne.4) then
             call submaps(igrid,phimap,phimap4,2)
	    else
             call submaps(igrid,phimap,phimap4,1)
	    end if

	    open(14,file=phinam(:philen),form="unformatted")
	    filnam = ' '
	    inquire(14,name = filnam)
	    write(6,*)'potential map written to file'
	    write(6,*)filnam
  	    write(6,*)'  '
  	    if(iconc.and.(rionst.ne.0)) then
  	      nxtlbl="concentrat"
  	    else
	      nxtlbl="potential "
	    end if
c         the following is uplabel, 20 char
          write(14)'now starting phimap '
          write(14)nxtlbl,toplbl
	    if (realsiz.ne.4) then
             call wrtphimap(igrid,phimap4,0)
	    else
             write(14)phimap
	    end if
c         this is botlbl
          write(14)' end of phimap  '
          write(14)scalesingle,oldmidsingle,igrid
          close(14)

c e++++++++++++++++++++++++++++++++++++++++++++++++++++
c
      else
	  write(6,*)'  '
	  write(6,*)'writing potential map in DELPHI format'
	  write(6,*) realsiz, phimap(5,5,5)
	  write(6,*) phimap4(5+(5-1)*igrid+(5-1)*igrid*igrid)
	  write(6,*)'  '
c
	  open(14,file=phinam(:philen), form='formatted')
	    filnam = ' '
	    inquire(14,name = filnam)
	    write(6,*)'potential map written to file'
	    write(6,*)filnam
  	    write(6,*)'  '
  	    if(iconc.and.(rionst.ne.0)) then
  	      nxtlbl="concentrat"
  	    else
	      nxtlbl="potential "
	    end if
c         the following is uplabel, 20 char
          write(14,'(a20)')'now starting phimap '
          write(14,'(a10,a60)')nxtlbl,toplbl
             write(14,'(7f15.7)')phimap
c         this is botlbl
          write(14,'(a16)')' end of phimap  '
          write(14,'(f15.7,3f15.7,i10)')scalesingle,oldmidsingle,igrid
          close(14)
	end if

      if(realsiz.ne.4.and.phifrm.ne.2) i_phimap4=memalloc(i_phimap4,0,0)
c
c b ++++++debug++++++++++++
c       open(52,FILE='phiwalt')
c       do ix=1,65
c            do iz=1,65
c              write(52,*)phimap(ix,33,iz)
c            end do
c       end do
c       close (52)
c  e +++++++++++++++++++++++

	if(iconc) then
	i=1
	do iz=1,igrid
	do iy=1,igrid
	do ix=1,igrid
	phimap(ix,iy,iz)=phimap3(i)
	i=i+1
	end do
	end do
	end do
        i_phimap3= memalloc(i_phimap3,0,0)
	end if
c
	return
	end

      subroutine wrtphimap(mgrid,phimap,opt)
      real*4 phimap(mgrid,mgrid,mgrid)
	integer opt

	 if (opt.eq.1) then
	   do 9041 k = 1,mgrid
	   do 9042 j = 1,mgrid
	     write(14)(phimap(i,j,k),i=1,mgrid)
9042	   continue
9041	   continue
       else
         write(14)phimap
	 endif
       return
      end

      subroutine rdphimap(mgrid,phimap)
      real phimap(mgrid,mgrid,mgrid)
         read(14)phimap
	   write(6,*) 'inside rdphimap',phimap(5,5,5)
       return
      end

      subroutine submaps(mgrid,phimap,phimap4,opt)
      integer mgrid,opt
	real phimap(mgrid,mgrid,mgrid)
      real phimap4(mgrid,mgrid,mgrid)

      if(opt.eq.1) then
	  do iz=1,mgrid
	  do iy=1,mgrid
	  do ix=1,mgrid
	    phimap(ix,iy,iz)=phimap(ix,iy,iz)-phimap4(ix,iy,iz)
	  end do
	  end do
	  end do
	else
	  do iz=1,mgrid
	  do iy=1,mgrid
	  do ix=1,mgrid
	    phimap4(ix,iy,iz)=phimap(ix,iy,iz)-phimap4(ix,iy,iz)
	  end do
	  end do
	  end do
	endif

        return
      end

        subroutine wrtphiForGUI
c
        include "qdiffpar4.h"
        include "qlog.h"
c
        real phimap(igrid,igrid,igrid)
c b++++++++++++++walter++++write potential map for the GUI
c       open(52,FILE="phimap",form='unformatted')
c       write(52)phimap
c       close(52)
c e+++++++++++++++++++++++++++++++++++++++++++++++++++++++
        return
        end


!
!MIT License
!
!Copyright (c) 2020 flavianowilliams
!
!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 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.
!
module interaction_module
  !*******************************************************************************
  !*******************************************************************************

  use neighbourlist_module
  use bonds_module
  use angles_module
  use coulomb_module
  use dihedrals_module
  use vanderwaals_module

  implicit none

  private
  public :: interaction

  type, extends(neighbourlist) :: interaction
     type(bonds)                   :: bnd
     type(angles)                  :: tht
     type(coulomb)                 :: coul
     type(dihedrals)               :: dih
     type(vanderwaals)             :: vdw
     real(8), private              :: eintra
     real(8), private              :: einter
     real(8), private              :: enpot
     real(8), private              :: virtot
     real(8), private              :: encorr
     real(8), private              :: vircorr
     real(8), private              :: fbi(3)
     real(8), private              :: fbj(3)
     real(8), private              :: fbk(3)
     real(8), private              :: fbl(3)
   contains
     procedure :: interaction_init
     procedure :: set_forcefield
     procedure :: set_intraff
     procedure :: set_interff
     procedure :: set_force2
     procedure :: set_force3
     procedure :: set_force4
     generic   :: set_force => set_force2, set_force3, set_force4
     procedure :: set_enpot
     procedure :: get_enpot
     procedure :: set_eintra
     procedure :: get_eintra
     procedure :: set_einter
     procedure :: get_einter
     procedure :: set_virtot
     procedure :: get_virtot
     procedure :: set_vdwcorr
     procedure :: get_encorr
     procedure :: get_vircorr
  end type interaction

contains

  subroutine interaction_init(this)
    implicit none
    class(interaction), intent(inout) :: this
    if(this%get_coulop().eq.'fscs')call this%coul%coulomb_init&
         (this%get_coulop(),this%get_fscsalpha(),this%get_rcutoff(),this%get_pi())
  end subroutine interaction_init

  subroutine set_forcefield(this)
    implicit none
    class(interaction), intent(inout) :: this
    integer                           :: i
    do i=1,this%get_natom()
       this%fax(i)=0.d0
       this%fay(i)=0.d0
       this%faz(i)=0.d0
    end do
    call this%set_virtot(this%get_vircorr())
    call this%set_intraff()
    call this%set_interff()
    call this%set_enpot()
  end subroutine set_forcefield

  subroutine set_intraff(this)
    implicit none
    class(interaction), intent(inout) :: this
    integer                           :: i,j,k,l,m,n,o,ni,nj,nk,nl,nx
    real(8)                           :: xvz,yvz,zvz,dr,virtot,theta,dr1,dr2
    real(8)                           :: eintra
    real(8)                           :: prm(3),drij(3),drik(3),drjk(3)
    real(8)                           :: drkl(3),ri(3),rj(3)
    real(8)                           :: rk(3),rl(3)
    real(8)                           :: vc1x,vc1y,vc1z,vc2x,vc2y,vc2z,phi
    character(7)                      :: ptrm
    nx=0
    eintra=0.d0
    virtot=0.d0
    do i=1,this%get_nmol()
       do j=1,this%ntmol(i)
          do k=1,this%bondscnt(i)
             ni=nx+this%molbond(i,k,1)
             nj=nx+this%molbond(i,k,2)
             call this%mic(ni,nj,xvz,yvz,zvz)
             dr=sqrt(xvz**2+yvz**2+zvz**2)
             do l=1,2
                prm(l)=this%parbnd(i,k,l)
             end do
             ptrm=this%tbonds(i,k)
             call this%bnd%set_bonds(dr,prm,ptrm)
             call this%set_force(ni,nj,xvz,yvz,zvz,this%bnd%get_force())
             call this%bnd%set_virbond(this%bnd%get_force(),dr)
             eintra=eintra+this%bnd%get_enbond()
             virtot=virtot+this%bnd%get_virbond()
          end do
          do k=1,this%bendscnt(i)
             ni=nx+this%molbend(i,k,2)
             nj=nx+this%molbend(i,k,1)
             nk=nx+this%molbend(i,k,3)
             call this%mic(ni,nj,drij(1),drij(2),drij(3))
             call this%mic(ni,nk,drik(1),drik(2),drik(3))
             dr1=sqrt(drij(1)**2+drij(2)**2+drij(3)**2)
             dr2=sqrt(drik(1)**2+drik(2)**2+drik(3)**2)
             theta=acos((drij(1)*drik(1)+drij(2)*drik(2)+drij(3)*drik(3))/(dr1*dr2))
             do l=1,2
                prm(l)=this%parbend(i,k,l)
             end do
             ptrm=this%tbends(i,k)
             call this%tht%set_angles(theta,prm,ptrm)
             call this%set_force&
                  (ni,nj,nk,drij,drik,dr1,dr2,theta,this%tht%get_force())
             call this%tht%set_virbend(this%fbj,this%fbk,drij,drik)
             eintra=eintra+this%tht%get_enbend()
             virtot=virtot+this%tht%get_virbend()
          end do
          do k=1,this%torscnt(i)
             ni=nx+this%moltors(i,k,1)
             nj=nx+this%moltors(i,k,2)
             nk=nx+this%moltors(i,k,3)
             nl=nx+this%moltors(i,k,4)
             call this%mic(ni,nj,drij(1),drij(2),drij(3))
             call this%mic(nj,nk,drjk(1),drjk(2),drjk(3))
             call this%mic(nk,nl,drkl(1),drkl(2),drkl(3))
             vc1x=drij(2)*drjk(3)-drij(3)*drjk(2)
             vc1y=drij(3)*drjk(1)-drij(1)*drjk(3)
             vc1z=drij(1)*drjk(2)-drij(2)*drjk(1)
             vc2x=drjk(2)*drkl(3)-drjk(3)*drkl(2)
             vc2y=drjk(3)*drkl(1)-drjk(1)*drkl(3)
             vc2z=drjk(1)*drkl(2)-drjk(2)*drkl(1)
             dr1=sqrt(vc1x**2+vc1y**2+vc1z**2) !-|rij x rjk|
             dr2=sqrt(vc2x**2+vc2y**2+vc2z**2) !-|rjk x rkn|
             phi=acos((vc1x*vc2x+vc1y*vc2y+vc1z*vc2z)/(dr1*dr2))
             do l=1,3
                prm(l)=this%partors(i,k,l)
             end do
             ptrm=this%ttors(i,k)
             call this%dih%set_dihedrals(phi,prm,ptrm)
             call this%set_force&
                  (ni,nj,nk,nl,drij,drjk,drkl,dr1,dr2,phi,this%dih%get_force())
             ri(1)=this%xa(ni)
             ri(2)=this%ya(ni)
             ri(3)=this%za(ni)
             rj(1)=this%xa(nj)
             rj(2)=this%ya(nj)
             rj(3)=this%za(nj)
             rk(1)=this%xa(nk)
             rk(2)=this%ya(nk)
             rk(3)=this%za(nk)
             rl(1)=this%xa(nl)
             rl(2)=this%ya(nl)
             rl(3)=this%za(nl)
             call this%dih%set_virtors(this%fbi,this%fbj,this%fbk,this%fbl,ri,rj,rk,rl)
             virtot=virtot+this%dih%get_virtors()
          end do
          nx=nx+this%nxmol(i)
       end do
       nx=0
       if(this%nxmol(i).lt.4)goto 2
       do j=1,this%ntmol(i)
          do k=1,this%nxmol(i)
             ni=nx+k
             do l=k+1,this%nxmol(i)
                nj=nx+l
                do m=1,this%bendscnt(i)
                   do n=1,3
                      do o=n+1,3
                         if(ni.eq.this%molbend(i,m,n).and.nj.eq.this%molbend(i,m,o))goto 1
                         if(ni.eq.this%molbend(i,m,o).and.nj.eq.this%molbend(i,m,n))goto 1
                      end do
                   end do
                end do
                call this%mic(ni,nj,xvz,yvz,zvz)
                dr=sqrt(xvz**2+yvz**2+zvz**2)
                if(abs(this%qat(ni)*this%qat(nj)).gt.1.d-8)then
                   call this%coul%set_coulomb(dr,this%qat(ni),this%qat(nj))
                   call this%set_force&
                        (ni,nj,xvz,yvz,zvz,this%coul%get_force()*this%sf_coul(i))
                   call this%coul%set_vircoul(this%coul%get_force()*this%sf_coul(i),dr)
                   eintra=eintra+this%coul%get_encoul()*this%sf_coul(i)
                   virtot=virtot+this%coul%get_vircoul()
                end if
                do m=1,this%get_nvdw()
                   if(this%tpa(ni).eq.this%spcvdw(m,1).and.&
                        this%tpa(nj).eq.this%spcvdw(m,2).or.&
                        this%tpa(ni).eq.this%spcvdw(m,2).and.&
                        this%tpa(nj).eq.this%spcvdw(m,1))then
                      do n=1,2
                         prm(n)=this%parvdw(m,n)
                      end do
                      ptrm='charmm'
                      call this%vdw%set_vanderwaals(dr,prm,ptrm)
                      call this%set_force&
                           (ni,nj,xvz,yvz,zvz,this%vdw%get_force()*this%sf_vdw(i))
                      call this%vdw%set_virvdw(this%vdw%get_force()*this%sf_vdw(i),dr)
                      eintra=eintra+this%vdw%get_envdw()*this%sf_vdw(i)
                      virtot=virtot+this%vdw%get_virvdw()
                   end if
                end do
1               continue
             end do
          end do
          nx=nx+this%nxmol(i)
       end do
2      continue
    end do
    call this%set_eintra(eintra)
    call this%set_virtot(virtot+this%get_virtot())
  end subroutine set_intraff

  subroutine set_interff(this)
    implicit none
    class(interaction), intent(inout) :: this
    integer                           :: i,j,k,l,ni,nj
    real(8)                           :: xvz,yvz,zvz,dr,virtot,einter
    real(8)                           :: prm(3)
    character(7)                      :: ptrm
    einter=0.d0
    virtot=0.d0
    do i=1,this%get_natom()
       do j=1,this%nlist(i)
          ni=i
          nj=this%ilist(i,j)
          call this%mic(ni,nj,xvz,yvz,zvz)
          dr=sqrt(xvz**2+yvz**2+zvz**2)
          if(abs(this%qat(ni)*this%qat(nj)).gt.1.d-8)then
             call this%coul%set_coulomb(dr,this%qat(ni),this%qat(nj))
             call this%set_force(ni,nj,xvz,yvz,zvz,this%coul%get_force())
             call this%coul%set_vircoul(this%coul%get_force(),dr)
             einter=einter+this%coul%get_encoul()
             virtot=virtot+this%coul%get_vircoul()
          end if
          do k=1,this%get_nvdw()
             if(this%tpa(ni).eq.this%spcvdw(k,1).and.this%tpa(nj).eq.this%spcvdw(k,2).or.&
                  this%tpa(ni).eq.this%spcvdw(k,2).and.this%tpa(nj).eq.this%spcvdw(k,1))then
                do l=1,2
                   prm(l)=this%parvdw(k,l)
                end do
                ptrm=this%tvdw(k)
                call this%vdw%set_vanderwaals(dr,prm,ptrm)
                call this%set_force(ni,nj,xvz,yvz,zvz,this%vdw%get_force())
                call this%vdw%set_virvdw(this%vdw%get_force(),dr)
                einter=einter+this%vdw%get_envdw()
                virtot=virtot+this%vdw%get_virvdw()
             end if
          end do
       end do
    end do
    call this%set_einter(einter)
    call this%set_virtot(virtot+this%get_virtot())
  end subroutine set_interff

  subroutine set_force2(this,ni,nj,xvz,yvz,zvz,fr)
    implicit none
    class(interaction), intent(inout) :: this
    integer, intent(in)               :: ni,nj
    real(8), intent(in)               :: fr,xvz,yvz,zvz
    this%fbi(1)=-fr*xvz
    this%fbi(2)=-fr*yvz
    this%fbi(3)=-fr*zvz
    this%fbj(1)=+fr*xvz
    this%fbj(2)=+fr*yvz
    this%fbj(3)=+fr*zvz
    this%fax(ni)=this%fax(ni)+this%fbi(1)
    this%fay(ni)=this%fay(ni)+this%fbi(2)
    this%faz(ni)=this%faz(ni)+this%fbi(3)
    this%fax(nj)=this%fax(nj)+this%fbj(1)
    this%fay(nj)=this%fay(nj)+this%fbj(2)
    this%faz(nj)=this%faz(nj)+this%fbj(3)
  end subroutine set_force2

  subroutine set_force3(this,i1,i2,i3,drij,drik,dr1,dr2,theta,fa)
    implicit none
    class(interaction), intent(inout) :: this
    integer, intent(in)               :: i1,i2,i3
    integer                           :: ix(3),i,j
    real(8), intent(in)               :: fa,dr1,dr2,theta
    real(8), intent(in)               :: drij(3),drik(3)
    real(8)                           :: derij(3,3)
    ix(1)=i1
    ix(2)=i2
    ix(3)=i3
    do j=1,3
       do i=1,3
          derij(i,j)=(kronij(ix(i),ix(2))-kronij(ix(i),ix(1)))*drik(j)/(dr1*dr2) &
               +(kronij(ix(i),ix(3))-kronij(ix(i),ix(1)))*drij(j)/(dr1*dr2) &
               -cos(theta)*((kronij(ix(i),ix(2))-kronij(ix(i),ix(1)))*drij(j)/dr1**2 &
               +(kronij(ix(i),ix(3))-kronij(ix(i),ix(1)))*drik(j)/dr2**2)
       end do
    end do
    this%fbi(1)=fa*derij(1,1)/sin(theta)
    this%fbi(2)=fa*derij(1,2)/sin(theta)
    this%fbi(3)=fa*derij(1,3)/sin(theta)
    this%fbj(1)=fa*derij(2,1)/sin(theta)
    this%fbj(2)=fa*derij(2,2)/sin(theta)
    this%fbj(3)=fa*derij(2,3)/sin(theta)
    this%fbk(1)=fa*derij(3,1)/sin(theta)
    this%fbk(2)=fa*derij(3,2)/sin(theta)
    this%fbk(3)=fa*derij(3,3)/sin(theta)
    this%fax(i1)=this%fax(i1)+this%fbi(1)
    this%fay(i1)=this%fay(i1)+this%fbi(2)
    this%faz(i1)=this%faz(i1)+this%fbi(3)
    this%fax(i2)=this%fax(i2)+this%fbj(1)
    this%fay(i2)=this%fay(i2)+this%fbj(2)
    this%faz(i2)=this%faz(i2)+this%fbj(3)
    this%fax(i3)=this%fax(i3)+this%fbk(1)
    this%fay(i3)=this%fay(i3)+this%fbk(2)
    this%faz(i3)=this%faz(i3)+this%fbk(3)
  end subroutine set_force3

  subroutine set_force4(this,i1,i2,i3,i4,drij,drjk,drkl,dr1,dr2,phi,fd)
    implicit none
    class(interaction), intent(inout) :: this
    integer, intent(in)               :: i1,i2,i3,i4
    integer                           :: ix(4),i,j
    real(8)                           :: dvc(4,3),phi2
    real(8), intent(in)               :: fd,dr1,dr2,phi
    real(8), intent(in)               :: drij(3),drjk(3),drkl(3)
    phi2=max(phi,1.d-8)
    ix(1)=i1 !-i
    ix(2)=i2 !-j
    ix(3)=i3 !-k
    ix(4)=i4 !-n
    do i=1,4
       do j=1,3
          dvc(i,j)=dfunc1(i1,i2,i3,i4,drij,drjk,drkl,ix(i),j)/(dr1*dr2) &
               -0.5d0*cos(phi2)*(dfunc2(i1,i2,i3,drij,drjk,ix(i),j)/dr1**2 &
               +dfunc2(i2,i3,i4,drjk,drkl,ix(i),j)/dr2**2)
       end do
    end do
    this%fbi(1)=fd*dvc(1,1)/sin(phi2)
    this%fbi(2)=fd*dvc(1,2)/sin(phi2)
    this%fbi(3)=fd*dvc(1,3)/sin(phi2)
    this%fbj(1)=fd*dvc(2,1)/sin(phi2)
    this%fbj(2)=fd*dvc(2,2)/sin(phi2)
    this%fbj(3)=fd*dvc(2,3)/sin(phi2)
    this%fbk(1)=fd*dvc(3,1)/sin(phi2)
    this%fbk(2)=fd*dvc(3,2)/sin(phi2)
    this%fbk(3)=fd*dvc(3,3)/sin(phi2)
    this%fbl(1)=fd*dvc(4,1)/sin(phi2)
    this%fbl(2)=fd*dvc(4,2)/sin(phi2)
    this%fbl(3)=fd*dvc(4,3)/sin(phi2)
    this%fax(i1)=this%fax(i1)+this%fbi(1)
    this%fay(i1)=this%fay(i1)+this%fbi(2)
    this%faz(i1)=this%faz(i1)+this%fbi(3)
    this%fax(i2)=this%fax(i2)+this%fbj(1)
    this%fay(i2)=this%fay(i2)+this%fbj(2)
    this%faz(i2)=this%faz(i2)+this%fbj(3)
    this%fax(i3)=this%fax(i3)+this%fbk(1)
    this%fay(i3)=this%fay(i3)+this%fbk(2)
    this%faz(i3)=this%faz(i3)+this%fbk(3)
    this%fax(i4)=this%fax(i4)+this%fbl(1)
    this%fay(i4)=this%fay(i4)+this%fbl(2)
    this%faz(i4)=this%faz(i4)+this%fbl(3)
  end subroutine set_force4

  subroutine set_enpot(this)
    implicit none
    class(interaction), intent(inout) :: this
    this%enpot=this%get_eintra()+this%get_einter()+this%get_encorr()
  end subroutine set_enpot

  double precision function get_enpot(this)
    implicit none
    class(interaction), intent(in) :: this
    get_enpot=this%enpot
  end function get_enpot

  subroutine set_eintra(this,eintra)
    implicit none
    class(interaction), intent(inout) :: this
    real(8), intent(in)               :: eintra
    this%eintra=eintra
  end subroutine set_eintra

  double precision function get_eintra(this)
    implicit none
    class(interaction), intent(in) :: this
    get_eintra=this%eintra
  end function get_eintra

  subroutine set_einter(this,einter)
    implicit none
    class(interaction), intent(inout) :: this
    real(8), intent(in)               :: einter
    this%einter=einter
  end subroutine set_einter

  double precision function get_einter(this)
    implicit none
    class(interaction), intent(in) :: this
    get_einter=this%einter
  end function get_einter

  subroutine set_virtot(this,virtot)
    implicit none
    class(interaction), intent(inout) :: this
    real(8), intent(in)               :: virtot
    this%virtot=virtot
  end subroutine set_virtot

  double precision function get_virtot(this)
    implicit none
    class(interaction), intent(in) :: this
    get_virtot=this%virtot
  end function get_virtot

  subroutine set_vdwcorr(this)
    implicit none
    class(interaction), intent(inout) :: this
    integer                           :: natp1,natp2,i,j
    real(8)                           :: envdw_corr,virvdw_corr,es,vs
    real(8)                           :: prm(2)
    envdw_corr=0.d0
    virvdw_corr=0.d0
    do i=1,this%get_nvdw()
       select case(this%tvdw(i))
       case('charmm')
          do j=1,2
             prm(j)=this%parvdw(i,j)
          end do
          es=prm(1)*&
               (prm(2)**12-6.d0*(this%get_rcutoff()*prm(2))**6)/(9.d0*this%get_rcutoff()**9)
          vs=12.d0*prm(1)*&
               (prm(2)**12-3.d0*(this%get_rcutoff()*prm(2))**6)/(9.d0*this%get_rcutoff()**9)
       case('lj')
          do j=1,2
             prm(j)=this%parvdw(i,j)
          end do
          es=4.d0*prm(1)*&
               (prm(2)**12-3.d0*(this%get_rcutoff()*prm(2))**6)/(9.d0*this%get_rcutoff()**9)
          vs=24.d0*prm(1)*(2.d0*prm(2)**12-3.d0*(this%get_rcutoff()*prm(2))**6)/&
               (9.d0*this%get_rcutoff()**9)
       end select
       natp1=0
       natp2=0
       do j=1,this%get_natom()
          if(this%tpa(j).eq.this%spcvdw(i,1))natp1=natp1+1
          if(this%tpa(j).eq.this%spcvdw(i,2))natp2=natp2+1
       end do
       envdw_corr=envdw_corr+es*natp1*natp2
       virvdw_corr=virvdw_corr+vs*natp1*natp2
    end do
    this%encorr=2.0d0*this%get_pi()*envdw_corr/this%get_volume()
    this%vircorr=-2.0d0*this%get_pi()*virvdw_corr/this%get_volume()
  end subroutine set_vdwcorr

  double precision function get_encorr(this)
    implicit none
    class(interaction), intent(in) :: this
    get_encorr=this%encorr
  end function get_encorr

  double precision function get_vircorr(this)
    implicit none
    class(interaction), intent(in) :: this
    get_vircorr=this%vircorr
  end function get_vircorr

  integer function kronij(i,j)
    integer, intent(in)               :: i,j
    kronij=int((float(i+j)-abs(i-j))/(float(i+j)+abs(i-j)))
  end function kronij

  double precision function dfunc1(i1,i2,i3,i4,drij,drjk,drkn,i,j)
    implicit none
    integer i,j,i1,i2,i3,i4
    real(8) drij(3),drjk(3),drkn(3)
    dfunc1=drij(j)*acomt(drjk,drjk,j)*(kronij(i,i3)-kronij(i,i4)) &
         +drij(j)*acomt(drjk,drkn,j)*(kronij(i,i3)-kronij(i,i2)) &
         +drjk(j)*acomt(drij,drjk,j)*(kronij(i,i4)-kronij(i,i3)) &
         +drjk(j)*acomt(drjk,drkn,j)*(kronij(i,i2)-kronij(i,i1)) &
         +drkn(j)*acomt(drij,drjk,j)*(kronij(i,i3)-kronij(i,i2)) &
         +drkn(j)*acomt(drjk,drjk,j)*(kronij(i,i1)-kronij(i,i2)) &
         +2.d0*drjk(j)*acomt(drij,drkn,j)*(kronij(i,i2)-kronij(i,i3))
  end function dfunc1

  double precision function dfunc2(i1,i2,i3,dri1,dri2,i,j)
    implicit none
    integer i,j,i1,i2,i3
    real(8) dri1(3),dri2(3)
    dfunc2=dri1(j)*acomt(dri2,dri2,j)*(kronij(i,i2)-kronij(i,i1)) &
         +dri1(j)*acomt(dri1,dri2,j)*(kronij(i,i2)-kronij(i,i3)) &
         +dri2(j)*acomt(dri1,dri1,j)*(kronij(i,i3)-kronij(i,i2)) &
         +dri2(j)*acomt(dri1,dri2,j)*(kronij(i,i1)-kronij(i,i2))
    dfunc2=2.d0*dfunc2
  end function dfunc2

  double precision function acomt(x1,x2,k)
    implicit none
    integer i,k
    real(8) sum,x1(3),x2(3)
    sum=0.d0
    do i=1,3
       sum=sum+(1.d0-kronij(i,k))*x1(i)*x2(i)
    end do
    acomt=sum
  end function acomt

end module interaction_module


! Using equation J^2 = J-J+ + Jz^2 + Jz
subroutine av1_gspci_j2_npzway(lambda_j2,cm_n,cm_z,v1,v2)
    use gprec
    use gspci
    use sparse
    implicit none
    real(q),intent(in)::lambda_j2
    complex(q),intent(in)::cm_n(dmem%norb,dmem%norb),cm_z(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(*)
    complex(q),intent(inout)::v2(*)

    if(abs(lambda_j2)>1.d-10)then
        call av1_gspci_jz2_pjz(lambda_j2,cm_z,v1,v2)
        call av1_gspci_jnjp(lambda_j2,cm_n,v1,v2)
    endif
    return

end subroutine av1_gspci_j2_npzway

! For physical subspace.
subroutine set_full_fock_states_r_spci()
    use gprec
    use gspci
    implicit none
    integer i

    if(dmem%ngp>0)then
        call set_dmem_phy()
    else
        dmem%bs_r=>dmem%bs; dmem%ibs_r=>dmem%ibs
        dmem%idx_r=>dmem%idx
    endif
    return

end subroutine set_full_fock_states_r_spci

! For variational subspace.
subroutine set_full_fock_states_l_spci()
    use gprec
    use gspci
    implicit none
    integer i

    if(dmem%norb_mott>0.or.dmem%ngp>0)then
        call set_dmem_mott()
    else
        dmem%bs_l=>dmem%bs; dmem%ibs_l=>dmem%ibs
        dmem%idx_l=>dmem%idx
    endif

    dmem%nstates=0
    do i=dmem%nval_bot,dmem%nval_top
        dmem%nstates=dmem%nstates+ &
                &(dmem%idx_r(i+1)-dmem%idx_r(i))* &
                &(dmem%idx_l(dmem%norb-i+1)-dmem%idx_l(dmem%norb-i))
    enddo
    write(0,'(" dim_phi = ",I0)')dmem%nstates
    return

end subroutine set_full_fock_states_l_spci

! setup the "physical" part of the embedding hamiltonian basis.
subroutine set_dmem_phy()
    use gprec
    use gspci
    use gutil
    implicit none
    integer i,n,nbs,isum,sume,ig

    nbs=ishft(1,dmem%norb)
    allocate(dmem%idx_r(0:dmem%norb+1),dmem%bs_r(nbs),dmem%ibs_r(0:nbs-1))
    dmem%ibs_r=0
    dmem%idx_r(0)=1; isum=1
    do n=0,dmem%norb
        fs: do i=dmem%idx(n),dmem%idx(n+1)-1
            do ig=1,dmem%ngp

                call sum_empty_slots_fs(dmem%bs(i),dmem%ngpm(ig), &
                        &dmem%gpm_list(1:dmem%ngpm(ig),ig),sume)
                sume=dmem%ngpm(ig)-sume
                if(sume<dmem%nval_gp(1,1,ig).or. &
                        &sume>dmem%nval_gp(2,1,ig))then
                    cycle fs
                endif
            enddo
            dmem%bs_r(isum)=dmem%bs(i)
            dmem%ibs_r(dmem%bs(i))=isum
            isum=isum+1
        enddo fs
        dmem%idx_r(n+1)=isum
    enddo
    return

end subroutine set_dmem_phy

! setup the "variational" part of the embedding hamiltonian basis.
subroutine set_dmem_mott()
    use gprec
    use gspci
    use gutil
    implicit none
    integer i,n,nbs,isum,sume,ig

    nbs=ishft(1,dmem%norb)
    allocate(dmem%idx_l(0:dmem%norb+1),dmem%bs_l(nbs),dmem%ibs_l(0:nbs-1))
    dmem%ibs_l=0
    dmem%idx_l(0)=1; isum=1
    do n=0,dmem%norb
        if(n<=dmem%norb-dmem%nelect_mott)then
            fs: do i=dmem%idx(n),dmem%idx(n+1)-1
                if(dmem%nelect_mott>0)then
                    call sum_empty_slots_fs(dmem%bs(i),dmem%norb_mott, &
                            &dmem%iorb_mott,sume)
                    if(sume/=dmem%nelect_mott)continue
                endif
                do ig=1,dmem%ngp
                    call sum_empty_slots_fs(dmem%bs(i),dmem%ngpm(ig), &
                            &dmem%gpm_list(1:dmem%ngpm(ig),ig),sume)
                    if(sume<dmem%nval_gp(1,2,ig).or. &
                            &sume>dmem%nval_gp(2,2,ig))then
                        cycle fs
                    endif
                enddo
                dmem%bs_l(isum)=dmem%bs(i)
                dmem%ibs_l(dmem%bs(i))=isum
                isum=isum+1
            enddo fs
        endif
        dmem%idx_l(n+1)=isum
    enddo
    return

end subroutine set_dmem_mott

subroutine solve_hembed_spci_drive()
    use gprec
    use gspci
    implicit none
    real(q) w(dmem%norb2)

    if(.not.associated(dmem%v))then
        allocate(dmem%v(dmem%nstates))
        w(1)=0
    else
        w(1)=1
    endif
    call solve_hembed_spci(w(1:2))
    dmem%etot=w(1)
    return

end subroutine solve_hembed_spci_drive

subroutine solve_hembed_spci(w)
    use gprec
    use gspci
    use gutil
    implicit none
    real(q),intent(inout)::w(2)
    external::av_gspci

    call primme_diag(dmem%v,dmem%nstates,w,av_gspci)
    return

end subroutine solve_hembed_spci

! <v1|c_i^\dagger c_j)|v1>
subroutine expval_gspci_npij(v1,npij)
    use gprec
    use gspci
    use gutil
    implicit none
    complex(q),intent(inout)::npij(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(*)

    integer ival,i1,i,j,nbase,itmp,isgn1,ibs1,nfs_r,nfs_l
    complex(q),external::zdotc

    nbase=0
    do ival=dmem%nval_bot,dmem%nval_top
        nfs_r=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l=dmem%idx_l(dmem%norb-ival+1)- &
                &dmem%idx_l(dmem%norb-ival)
        if(nfs_l<=0)cycle
        do i1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
            do i=1,dmem%norb; do j=1,i
                itmp=dmem%bs_r(i1)
                isgn1=1
                call act_state(itmp,j-1,.false.,isgn1)
                if(isgn1==0)cycle
                call act_state(itmp,i-1,.true.,isgn1)
                if(isgn1==0)cycle
                ibs1=dmem%ibs_r(itmp)
                if(ibs1==0)cycle
                npij(i,j)=npij(i,j)+ &
                        &zdotc(nfs_l, &
                        &v1(nbase+(ibs1-dmem%idx_r(ival))*nfs_l+1), &
                        &1,v1(nbase+(i1-dmem%idx_r(ival))*nfs_l+1),1) &
                        &*isgn1
            enddo; enddo
        enddo
        nbase=nbase+nfs_r*nfs_l
    enddo

    ! Complex conjugate part
    do i=1,dmem%norb; do j=1+i,dmem%norb
        npij(i,j)=conjg(npij(j,i))
    enddo; enddo
    return

end subroutine expval_gspci_npij

! <v2| \sum_ij cij c_i^\dagger c_j + cji c_j^\dagger c_i)|v1>
subroutine expval_gspci_npij2(cm,v1,v2,zes)
    use gprec
    use gspci
    use gutil
    implicit none
    complex(q),intent(in)::cm(dmem%norb,dmem%norb)
    complex(q),intent(inout)::zes
    complex(q),intent(in)::v1(*),v2(*)

    integer ival,i1,i,j,nbase,itmp,isgn1,ibs1,nfs_r,nfs_l
    complex(q),external::zdotc

    nbase=0
    do ival=dmem%nval_bot,dmem%nval_top
        nfs_r=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l=dmem%idx_l(dmem%norb-ival+1)- &
                &dmem%idx_l(dmem%norb-ival)
        if(nfs_l<=0)cycle
        do i1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
            do i=1,dmem%norb; do j=1,i
                if(abs(cm(i,j))<1.d-10.and.abs(cm(j,i))<1.d-10)cycle
                itmp=dmem%bs_r(i1)
                isgn1=1
                call act_state(itmp,j-1,.false.,isgn1)
                if(isgn1==0)cycle
                call act_state(itmp,i-1,.true.,isgn1)
                if(isgn1==0)cycle
                ibs1=dmem%ibs_r(itmp)
                if(ibs1==0)cycle
                if(abs(cm(i,j))>1.d-10)then
                    zes=zes+zdotc(nfs_l, &
                            &v2(nbase+(ibs1-dmem%idx_r(ival))*nfs_l+1), &
                            &1,v1(nbase+(i1-dmem%idx_r(ival))*nfs_l+1),1) &
                            &*isgn1*cm(i,j)
                endif
                if(i==j)cycle
                if(abs(cm(j,i))>1.d-10)then
                    zes=zes+zdotc(nfs_l, &
                            &v2(nbase+(i1-dmem%idx_r(ival))*nfs_l+1), &
                            &1,v1(nbase+(ibs1-dmem%idx_r(ival))*nfs_l+1),1) &
                            &*isgn1*cm(j,i)
                endif
            enddo; enddo
        enddo
        nbase=nbase+nfs_r*nfs_l
    enddo
    return

end subroutine expval_gspci_npij2

! |v2> += (\sum_ij cij c_i^\dagger c_j|v1>
subroutine av1_gspci_npij(cm,v1,v2)
    use gprec
    use gspci
    use gutil
    implicit none
    complex(q),intent(in)::cm(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(*)
    complex(q),intent(inout)::v2(*)

    integer ival,i1,i,j,nbase,itmp,isgn1,ibs1,nfs_r,nfs_l

    nbase=0
    do ival=dmem%nval_bot,dmem%nval_top
        nfs_r=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l=dmem%idx_l(dmem%norb-ival+1)- &
                &dmem%idx_l(dmem%norb-ival)
        if(nfs_l<=0)cycle
        do i1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
            do i=1,dmem%norb; do j=1,i
                if(abs(cm(i,j))<1.d-10.and.abs(cm(j,i))<1.d-10)cycle
                itmp=dmem%bs_r(i1)
                isgn1=1
                call act_state(itmp,j-1,.false.,isgn1)
                if(isgn1==0)cycle
                call act_state(itmp,i-1,.true.,isgn1)
                if(isgn1==0)cycle
                ibs1=dmem%ibs_r(itmp)
                if(ibs1==0)cycle
                if(abs(cm(i,j))>1.d-10)then
                    call zaxpy(nfs_l,cm(i,j)*isgn1, &
                            &v1(nbase+(i1-dmem%idx_r(ival))*nfs_l+1),1,&
                            &v2(nbase+(ibs1-dmem%idx_r(ival))*nfs_l+1),1)
                endif
                if(i==j)cycle
                if(abs(cm(j,i))>1.d-10)then
                    call zaxpy(nfs_l,cm(j,i)*isgn1, &
                            &v1(nbase+(ibs1-dmem%idx_r(ival))*nfs_l+1),1,&
                            &v2(nbase+(i1-dmem%idx_r(ival))*nfs_l+1),1)
                endif
            enddo; enddo
        enddo
        nbase=nbase+nfs_r*nfs_l
    enddo
    return

end subroutine av1_gspci_npij

! <v1|f_i^\dagger c_j)|v1>
subroutine expval_gspci_mij(v1,mij)
    use gprec
    use gspci
    use gutil
    implicit none
    complex(q),intent(inout)::mij(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(*)

    integer ival,istate,i1,i2,i,j,jstate,nbase,mbase, &
            &itmp,isgn1,isgn2,ibs1,ibs2, &
            &nfs_r1,nfs_r2,nfs_l1,nfs_l2

    nbase=0
    mbase=(dmem%idx_r(dmem%nval_bot+1)-dmem%idx_r(dmem%nval_bot)) &
            &*(dmem%idx_l(dmem%norb-dmem%nval_bot+1)-&
            & dmem%idx_l(dmem%norb-dmem%nval_bot))
    do ival=dmem%nval_bot+1,dmem%nval_top
        nfs_r1=dmem%idx_r(ival)-dmem%idx_r(ival-1)
        nfs_l1=dmem%idx_l(dmem%norb-ival+2)- &
                &dmem%idx_l(dmem%norb-ival+1)
        nfs_r2=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l2=dmem%idx_l(dmem%norb-ival+1)- &
                &dmem%idx_l(dmem%norb-ival)

        if(nfs_l1*nfs_r1<=0)then
            mbase=mbase+nfs_r2*nfs_l2
            cycle
        endif
        if(nfs_l2*nfs_r2<=0)then
            nbase=nbase+nfs_r1*nfs_l1
            cycle
        endif

        do i1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
            do i=1,dmem%norb; do j=1,dmem%norb
                itmp=dmem%bs_r(i1)
                isgn1=1
                ! c_j |v1>
                call act_state(itmp,j-1,.false.,isgn1)
                if(isgn1==0)cycle
                if(mod(ival-1,2)==1)then
                    isgn1=-isgn1  ! additional sign for f_i^\dagger
                endif
                ibs1=dmem%ibs_r(itmp)
                if(ibs1==0)cycle
                do i2=dmem%idx_l(dmem%norb-ival), &
                        &dmem%idx_l(dmem%norb-ival+1)-1
                    istate=mbase+(i1-dmem%idx_r(ival))*nfs_l2+i2- &
                            &dmem%idx_l(dmem%norb-ival)+1
                    if(abs(v1(istate))<1.d-16)cycle
                    itmp=dmem%bs_l(i2)
                    isgn2=isgn1
                    ! f_i^/dagger c_j |v1>
                    call act_state(itmp,i-1,.true.,isgn2)
                    if(isgn2==0)cycle
                    ibs2=dmem%ibs_l(itmp)
                    if(ibs2==0)cycle
                    jstate=nbase+(ibs1-dmem%idx_r(ival-1))*nfs_l1+ &
                            &ibs2-dmem%idx_l(dmem%norb-ival+1)+1
                    mij(i,j)=mij(i,j)+conjg(v1(jstate))*v1(istate)*isgn2
                enddo
            enddo; enddo
        enddo
        mbase=mbase+nfs_r2*nfs_l2
        nbase=nbase+nfs_r1*nfs_l1
    enddo
    return

end subroutine expval_gspci_mij

! |v2> += \sum_ij (dij^* f_i^\dagger c_j + dij c_j^\dagger f_i)|v1>
subroutine av1_gspci_mij(v1,v2)
    use gprec
    use gspci
    use gutil
    implicit none
    complex(q),intent(in)::v1(*)
    complex(q),intent(inout)::v2(*)

    integer ival,istate,i1,i2,j1,jstate,nbase,nnz,inz,nnz1, &
            &itmp,isgn2,ibs2,nfs_r1,nfs_r2,nfs_l1,nfs_l2
    integer,allocatable::isgn1(:),is(:),js(:),ibs1(:),is1(:)
    complex(q),allocatable::dij(:)

    nnz=count(abs(dmem%daalpha)>=1.d-10)
    allocate(isgn1(nnz),is(nnz),is1(nnz),js(nnz),ibs1(nnz),dij(nnz))

    nnz=0
    do i1=1,dmem%norb; do i2=1,dmem%norb
        if(abs(dmem%daalpha(i1,i2))<1.d-10)cycle
        nnz=nnz+1
        is(nnz)=i1; js(nnz)=i2
    enddo; enddo

    nbase=0
    istate=(dmem%idx_r(dmem%nval_bot+1)-dmem%idx_r(dmem%nval_bot)) &
            &*(dmem%idx_l(dmem%norb-dmem%nval_bot+1)-&
            & dmem%idx_l(dmem%norb-dmem%nval_bot))
    do ival=dmem%nval_bot+1,dmem%nval_top
        nfs_r1=dmem%idx_r(ival)-dmem%idx_r(ival-1)
        nfs_l1=dmem%idx_l(dmem%norb-ival+2)- &
                &dmem%idx_l(dmem%norb-ival+1)
        nfs_r2=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l2=dmem%idx_l(dmem%norb-ival+1)- &
                &dmem%idx_l(dmem%norb-ival)
        if(nfs_l1*nfs_r1<=0)then
            istate=istate+nfs_r2*nfs_l2
            cycle
        endif
        if(nfs_l2*nfs_r2<=0)then
            nbase=nbase+nfs_r1*nfs_l1
            cycle
        endif
        do i1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
            nnz1=1
            do inz=1,nnz
                itmp=dmem%bs_r(i1)
                isgn1(nnz1)=1
                ! c_js |v1>
                call act_state(itmp,js(inz)-1,.false.,isgn1(nnz1))
                if(isgn1(nnz1)==0)cycle
                j1=dmem%ibs_r(itmp)
                if(j1==0)cycle
                ibs1(nnz1)=j1
                is1(nnz1)=is(inz)
                dij(nnz1)=dmem%daalpha(is(inz),js(inz))
                nnz1=nnz1+1
            enddo
            nnz1=nnz1-1
            if(nnz1<=0)then
                istate=istate+nfs_l2
                cycle
            endif
            if(mod(ival-1,2)==1)then
                isgn1=-isgn1  ! additional sign for f_i^\dagger
            endif
            do i2=dmem%idx_l(dmem%norb-ival), &
                    &dmem%idx_l(dmem%norb-ival+1)-1
                istate=istate+1
                if(abs(v1(istate))<1.d-16)cycle
                do inz=1,nnz1
                    itmp=dmem%bs_l(i2)
                    isgn2=isgn1(inz)
                    ! f_is^\dagger c_js |v1>
                    call act_state(itmp,is1(inz)-1,.true.,isgn2)
                    if(isgn2==0)cycle
                    ibs2=dmem%ibs_l(itmp)
                    if(ibs2==0)cycle
                    jstate=nbase+(ibs1(inz)-dmem%idx_r(ival-1))*nfs_l1+ &
                            &ibs2-dmem%idx_l(dmem%norb-ival+1)+1
                    v2(jstate)=v2(jstate)+conjg(dij(inz))*v1(istate)*isgn2
                    v2(istate)=v2(istate)+dij(inz)*v1(jstate)*isgn2
                enddo
            enddo
        enddo
        nbase=nbase+nfs_r1*nfs_l1
    enddo
    deallocate(isgn1,is,is1,js,ibs1,dij)
    return

end subroutine av1_gspci_mij

! |v2> += P |v1>
!      += \sum_k v_k P c_i^\dagger ... f_j^\dagger |0>
!      += \sum_k v_k \sum_n Pn c_i^\dagger Pn^\dagger ...
!                           Pn f_j^\dagger Pn^\dagger |0>
!      += \sum_k v_k \sum_n \sum_i' u_ii' c_i'^\dagger ...
!                           \sum_j' u_jj' f_j'^\dagger |0>
subroutine av1_gspci_pdsym(lambda_p,nsym,plist,v1,v2)
    use gprec
    use gspci
    use gutil
    implicit none
    integer,intent(in)::nsym
    real(q),intent(in)::lambda_p
    complex(q),intent(in)::v1(*),plist(dmem%norb,dmem%norb,nsym)
    complex(q),intent(inout)::v2(*)

    integer ival,istate,i1,i2,jstate,nbase,itmp,nfs_r,nfs_l,ni_skip,nj_skip, &
            &isym,j1,j2,k,ivalp,jbase
    integer ia(dmem%norb),ib(dmem%norb),ib_skip(dmem%norb), &
            &ja(dmem%norb),jb(dmem%norb),jb_skip(dmem%norb)
    complex(q) coef1,coef2
    real(q) lambda_

    lambda_=lambda_p/nsym
    nbase=0
    do ival=dmem%nval_bot,dmem%nval_top
        ivalp=dmem%norb-ival
        nfs_r=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l=dmem%idx_l(ivalp+1)-dmem%idx_l(ivalp)
        if(nfs_l<=0)cycle
        if(ival==0)then
            v2(nbase+1)=v2(nbase+1)+lambda_*v1(nbase+1)*nsym
            nbase=nbase+1
            cycle
        endif
        do i1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
            itmp=dmem%bs_r(i1)
            call set_occupied_orbitals(itmp,ia,dmem%norb)
            do isym=1,nsym
                call set_skip_orbitals(plist(:,:,isym),dmem%norb, &
                        &ia(1:ival),ival,ib_skip,ni_skip)
                lj1: do j1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
                    itmp=dmem%bs_r(j1)
                    do k=1,ni_skip
                        if(btest(itmp,ib_skip(k)-1))cycle lj1
                    enddo
                    coef1=1._q
                    call set_occupied_orbitals(itmp,ib,dmem%norb)
                    call calc_fock_state_coef(plist(:,:,isym),dmem%norb, &
                            &ia,ib,ival,coef1)
                    if(abs(coef1)<1.d-12)cycle lj1
                    istate=nbase+(i1-dmem%idx_r(ival))*nfs_l
                    jbase=nbase+(j1-dmem%idx_r(ival))*nfs_l
                    do i2=dmem%idx_l(ivalp),dmem%idx_l(ivalp+1)-1
                        istate=istate+1
                        if(abs(v1(istate))<1.d-16)cycle
                        itmp=dmem%bs_l(i2)
                        call set_occupied_orbitals(itmp,ja,dmem%norb)
                        call set_skip_orbitals(plist(:,:,isym),dmem%norb, &
                                &ja(1:ivalp),ivalp,jb_skip,nj_skip)
                        lj2: do j2=dmem%idx_l(ivalp),dmem%idx_l(ivalp+1)-1
                            itmp=dmem%bs_l(j2)
                            do k=1,nj_skip
                                if(btest(itmp,jb_skip(k)-1))cycle lj2
                            enddo
                            coef2=coef1
                            call set_occupied_orbitals(itmp,jb,dmem%norb)
                            call calc_fock_state_coef(plist(:,:,isym), &
                                    &dmem%norb,ja,jb,ivalp,coef2)
                            if(abs(coef2)<1.d-16)cycle lj2
                            jstate=jbase+j2-dmem%idx_l(ivalp)+1
                            v2(jstate)=v2(jstate)+coef2*v1(istate)*lambda_
                        enddo lj2
                    enddo
                enddo lj1
            enddo
        enddo
        nbase=nbase+nfs_r*nfs_l
    enddo
    return

end subroutine av1_gspci_pdsym

subroutine expval_gspci_pdsym(plist,nsym,v1,zes)
    use gprec
    use gspci
    use gutil
    implicit none
    integer,intent(in)::nsym
    complex(q),intent(in)::v1(*),plist(dmem%norb,dmem%norb,nsym)
    complex(q),intent(out)::zes

    integer ival,istate,i1,i2,jstate,nbase,itmp, &
            &nfs_r,nfs_l,ni_skip,nj_skip, &
            &isym,j1,j2,k,ivalp,jbase
    integer ia(dmem%norb),ib(dmem%norb),ib_skip(dmem%norb), &
            &ja(dmem%norb),jb(dmem%norb),jb_skip(dmem%norb)
    complex(q) coef1,coef2

    zes=0
    nbase=0
    do ival=dmem%nval_bot,dmem%nval_top
        ivalp=dmem%norb-ival
        nfs_r=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l=dmem%idx_l(ivalp+1)-dmem%idx_l(ivalp)
        if(nfs_l<=0)cycle
        if(ival==0)then
            zes=zes+v1(nbase+1)*conjg(v1(nbase+1))*nsym
            nbase=nbase+1
            cycle
        endif
        do i1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
            itmp=dmem%bs_r(i1)
            call set_occupied_orbitals(itmp,ia,dmem%norb)
            do isym=1,nsym
                call set_skip_orbitals(plist(:,:,isym),dmem%norb, &
                        &ia(1:ival),ival,ib_skip,ni_skip)
                lj1: do j1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
                    itmp=dmem%bs_r(j1)
                    do k=1,ni_skip
                        if(btest(itmp,ib_skip(k)-1))cycle lj1
                    enddo
                    coef1=1._q
                    call set_occupied_orbitals(itmp,ib,dmem%norb)
                    call calc_fock_state_coef(plist(:,:,isym),dmem%norb, &
                            &ia,ib,ival,coef1)
                    if(abs(coef1)<1.d-12)cycle lj1
                    istate=nbase+(i1-dmem%idx_r(ival))*nfs_l
                    jbase=nbase+(j1-dmem%idx_r(ival))*nfs_l
                    do i2=dmem%idx_l(ivalp),dmem%idx_l(ivalp+1)-1
                        istate=istate+1
                        if(abs(v1(istate))<1.d-16)cycle
                        itmp=dmem%bs_l(i2)
                        call set_occupied_orbitals(itmp,ja,dmem%norb)
                        call set_skip_orbitals(plist(:,:,isym),dmem%norb, &
                                &ja(1:ivalp),ivalp,jb_skip,nj_skip)
                        lj2: do j2=dmem%idx_l(ivalp),dmem%idx_l(ivalp+1)-1
                            itmp=dmem%bs_l(j2)
                            do k=1,nj_skip
                                if(btest(itmp,jb_skip(k)-1))cycle lj2
                            enddo
                            coef2=coef1
                            call set_occupied_orbitals(itmp,jb,dmem%norb)
                            call calc_fock_state_coef(plist(:,:,isym), &
                                    &dmem%norb,ja,jb,ivalp,coef2)
                            if(abs(coef2)<1.d-16)cycle lj2
                            jstate=jbase+j2-dmem%idx_l(ivalp)+1
                            zes=zes+coef2*v1(istate)*conjg(v1(jstate))
                        enddo lj2
                    enddo
                enddo lj1
            enddo
        enddo
        nbase=nbase+nfs_r*nfs_l
    enddo
    zes=zes/nsym
    return

end subroutine expval_gspci_pdsym

subroutine chk_expval_gspci_pdsym(plist,nsym,v1)
    use gprec
    use gspci
    implicit none
    integer,intent(in)::nsym
    complex(q),intent(in)::v1(*),plist(dmem%norb,dmem%norb,nsym)

    integer i
    complex(q) ::zes

    do i=1,nsym
        call expval_gspci_pdsym(plist(:,:,i),1,v1,zes)
        write(0,'(" isym = ",i2," <v|pojector_sym|v> =",2f18.10)')i,zes
    enddo
    return

end subroutine chk_expval_gspci_pdsym

! <v1|f_i^\dagger f_j|v1>
subroutine expval_gspci_nvij(v1,nvij)
    use gprec
    use gspci
    use gutil
    implicit none
    complex(q),intent(in)::v1(*)
    complex(q),intent(inout)::nvij(dmem%norb,dmem%norb)

    integer ival,i1,i2,i,j,nbase,itmp,isgn,ibs2,nfs_r,nfs_l,ifsr,ifsl
    complex(q),allocatable::v2(:),v2c(:)
    complex(q),external::zdotc

    itmp=maxval(dmem%idx_r(dmem%nval_bot+1:)- &
            &dmem%idx_r(dmem%nval_bot:dmem%nval_top-1))
    allocate(v2(itmp),v2c(itmp))

    nbase=0
    do ival=dmem%nval_bot,dmem%nval_top
        nfs_r=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l=dmem%idx_l(dmem%norb-ival+1)- &
                &dmem%idx_l(dmem%norb-ival)
        if(nfs_l<=0)then
            cycle
        endif
        do i2=dmem%idx_l(dmem%norb-ival), &
                &dmem%idx_l(dmem%norb-ival+1)-1
            do i=1,dmem%norb; do j=1,i
                itmp=dmem%bs_l(i2)
                isgn=1
                call act_state(itmp,j-1,.false.,isgn)
                if(isgn==0)cycle
                call act_state(itmp,i-1,.true.,isgn)
                if(isgn==0)cycle
                ibs2=dmem%ibs_l(itmp)
                if(ibs2<=0)cycle
                ifsr=nbase+i2  -dmem%idx_l(dmem%norb-ival)+1
                ifsl=nbase+ibs2-dmem%idx_l(dmem%norb-ival)+1
                v2(1:nfs_r)=v1(ifsr:ifsr+(nfs_r-1)*nfs_l:nfs_l)
                if(ibs2==i2)then
                    nvij(i,j)=nvij(i,j)+zdotc(nfs_r,v2(1),1,v2(1),1)*isgn
                else
                    v2c(1:nfs_r)=v1(ifsl:ifsl+(nfs_r-1)*nfs_l:nfs_l)
                    nvij(i,j)=nvij(i,j)+zdotc(nfs_r,v2c(1),1,v2(1),1)*isgn
                endif
            enddo; enddo
        enddo
        nbase=nbase+nfs_r*nfs_l
    enddo
    deallocate(v2,v2c)

    ! Complex conjugate part
    do i=1,dmem%norb; do j=1+i,dmem%norb
        nvij(i,j)=conjg(nvij(j,i))
    enddo; enddo
    return

end subroutine expval_gspci_nvij

! <v2|\sum_ij c_ij f_i^\dagger f_j|v1>
subroutine expval_gspci_nvij2(cm,v1,v2,zes)
    use gprec
    use gspci
    use gutil
    implicit none
    complex(q),intent(in)::cm(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(*),v2(*)
    complex(q),intent(inout)::zes

    integer ival,i1,i2,i,j,nbase,itmp,isgn,ibs2,nfs_r,nfs_l,ifsl,ifsr
    complex(q),allocatable::v1p(:),v2p(:)
    complex(q),external::zdotc

    itmp=maxval(dmem%idx_r(dmem%nval_bot+1:)- &
            &dmem%idx_r(dmem%nval_bot:dmem%nval_top-1))
    allocate(v1p(itmp),v2p(itmp))

    nbase=0
    do ival=dmem%nval_bot,dmem%nval_top
        nfs_r=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l=dmem%idx_l(dmem%norb-ival+1)- &
                &dmem%idx_l(dmem%norb-ival)
        if(nfs_l<=0)then
            cycle
        endif
        do i2=dmem%idx_l(dmem%norb-ival), &
                &dmem%idx_l(dmem%norb-ival+1)-1
            do i=1,dmem%norb; do j=1,i
                if(abs(cm(i,j))<1.d-10.and.abs(cm(j,i))<1.d-10)cycle
                itmp=dmem%bs_l(i2)
                isgn=1
                call act_state(itmp,j-1,.false.,isgn)
                if(isgn==0)cycle
                call act_state(itmp,i-1,.true.,isgn)
                if(isgn==0)cycle
                ibs2=dmem%ibs_l(itmp)
                if(ibs2<=0)cycle
                ifsr=nbase+i2  -dmem%idx_l(dmem%norb-ival)+1
                ifsl=nbase+ibs2-dmem%idx_l(dmem%norb-ival)+1
                if(abs(cm(i,j))>1.d-10)then
                    v1p(1:nfs_r)=v1(ifsr:ifsr+(nfs_r-1)*nfs_l:nfs_l)
                    v2p(1:nfs_r)=v2(ifsl:ifsl+(nfs_r-1)*nfs_l:nfs_l)
                    zes=zes+zdotc(nfs_r,v2p(1),1,v1p(1),1)*isgn*cm(i,j)
                endif
                if(i==j)cycle
                if(abs(cm(j,i))>1.d-10)then
                    v1p(1:nfs_r)=v1(ifsl:ifsl+(nfs_r-1)*nfs_l:nfs_l)
                    v2p(1:nfs_r)=v2(ifsr:ifsr+(nfs_r-1)*nfs_l:nfs_l)
                    zes=zes+zdotc(nfs_r,v2p(1),1,v1p(1),1)*isgn*cm(j,i)
                endif
            enddo; enddo
        enddo
        nbase=nbase+nfs_r*nfs_l
    enddo
    deallocate(v1p,v2p)
    return

end subroutine expval_gspci_nvij2

! |v2> += \sum_{i,j} (cij f_j f_i^\dagger|v1>
subroutine av1_gspci_nvij(cm,v1,v2)
    use gprec
    use gspci
    use gutil
    implicit none
    complex(q),intent(in)::cm(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(*)
    complex(q),intent(inout)::v2(*)

    integer ival,istate,i1,i2,jstate,nbase,nnz,inz,nnz2, &
            &itmp,isgn,nfs_r,nfs_l
    integer,allocatable::is(:),js(:),ibs2(:)
    logical,allocatable::ldiag(:)
    complex(q),allocatable::cij(:),cji(:)

    nnz=0
    do i1=1,dmem%norb; do i2=1,i1
        if(abs(cm(i1,i2))<1.d-10.and.abs(cm(i2,i1))<1.d-10)cycle
        nnz=nnz+1
    enddo; enddo
    allocate(is(nnz),js(nnz),ibs2(nnz),cij(nnz),cji(nnz),ldiag(nnz))
    nnz=0
    do i1=1,dmem%norb; do i2=1,i1
        if(abs(cm(i1,i2))<1.d-10.and.abs(cm(i2,i1))<1.d-10)cycle
        nnz=nnz+1
        is(nnz)=i1; js(nnz)=i2
    enddo; enddo

    nbase=0
    do ival=dmem%nval_bot,dmem%nval_top
        nfs_r=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l=dmem%idx_l(dmem%norb-ival+1)- &
                &dmem%idx_l(dmem%norb-ival)
        if(nfs_l<=0)then
            cycle
        endif
        do i2=dmem%idx_l(dmem%norb-ival), &
                &dmem%idx_l(dmem%norb-ival+1)-1
            nnz2=0
            do inz=1,nnz
                itmp=dmem%bs_l(i2)
                isgn=1
                call act_state(itmp,is(inz)-1,.true.,isgn)
                if(isgn==0)cycle
                call act_state(itmp,js(inz)-1,.false.,isgn)
                if(isgn==0)cycle
                if(dmem%ibs_l(itmp)<=0)cycle
                nnz2=nnz2+1
                ibs2(nnz2)=dmem%ibs_l(itmp)
                cij(nnz2)=cm(is(inz),js(inz))*isgn
                cji(nnz2)=cm(js(inz),is(inz))*isgn
                ldiag(nnz2)=is(inz)==js(inz)
            enddo
            do i1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
                istate=nbase+(i1-dmem%idx_r(ival))*nfs_l+ &
                        &i2-dmem%idx_l(dmem%norb-ival)+1
                if(abs(v1(istate))<1.d-16)cycle
                do inz=1,nnz2
                    jstate=nbase+(i1-dmem%idx_r(ival))*nfs_l+ &
                            &ibs2(inz)-dmem%idx_l(dmem%norb-ival)+1
                    v2(jstate)=v2(jstate)+cij(inz)*v1(istate)
                    if(ldiag(inz))cycle
                    v2(istate)=v2(istate)+cji(inz)*v1(jstate)
                enddo
            enddo
        enddo
        nbase=nbase+nfs_r*nfs_l
    enddo
    deallocate(is,js,ibs2,cij,cji,ldiag)
    return

end subroutine av1_gspci_nvij

subroutine calc_ucsr_spci()
    use gprec, only:dp=>q
    use gspci
    use gutil
    implicit none
    complex(dp) z_row(maxval(dmem%idx_r(dmem%nval_bot+1:dmem%nval_top+1) &
            &-dmem%idx_r(dmem%nval_bot:dmem%nval_top)))
    integer nstates,nnz,irun,ival,istate,i,jstate,j,p,q,r,s, &
            &itmp(4),isgn(4)

    nstates=dmem%idx_r(dmem%nval_top+1)-dmem%idx_r(dmem%nval_bot)
    dmem%ucsr%nrow=nstates
    dmem%ucsr%ncol=nstates
    allocate(dmem%ucsr%i(nstates+1)); dmem%ucsr%i(1)=1

    do irun=1,2
        if(irun==2)then
            allocate(dmem%ucsr%j(nnz),dmem%ucsr%a(nnz))
        endif
        nnz=0; istate=0
        do ival=dmem%nval_bot,dmem%nval_top
            do i=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
                istate=istate+1
                z_row=0
                do p=1,dmem%norb
                    ! <v|p^\dagger
                    isgn(1)=1
                    itmp(1)=dmem%bs_r(i)
                    call act_state(itmp(1),p-1,.false.,isgn(1))
                    if(isgn(1)==0)cycle

                    ! one-body part
                    do q=1,dmem%norb
                        if(abs(dmem%h1e(p,q))<1.d-10)cycle
                        ! <v|p^\dagger q
                        isgn(2)=isgn(1)
                        itmp(2)=itmp(1)
                        call act_state(itmp(2),q-1,.true.,isgn(2))
                        if(isgn(2)==0)cycle
                        jstate=dmem%ibs_r(itmp(2))
                        if(jstate>i.or.jstate==0)cycle
                        jstate=jstate-dmem%idx_r(ival)+1
                        z_row(jstate)=z_row(jstate)+isgn(2)*dmem%h1e(p,q)
                    enddo

                    ! two-body
                    do q=1,p ! take care of factor 1/2
                        ! <v|p^\dagger q^\dagger
                        isgn(2)=isgn(1)
                        itmp(2)=itmp(1)
                        call act_state(itmp(2),q-1,.false.,isgn(2))
                        if(isgn(2)==0)cycle
                        do r=1,dmem%norb
                            ! <v|p^\dagger q^\dagger r
                            isgn(3)=isgn(2)
                            itmp(3)=itmp(2)
                            call act_state(itmp(3),r-1,.true.,isgn(3))
                            if(isgn(3)==0)cycle
                            do s=1,dmem%norb
                                if(abs(dmem%v2e(p,s,q,r))<1.d-10)cycle
                                ! <v|p^\dagger q^\dagger r s
                                isgn(4)=isgn(3)
                                itmp(4)=itmp(3)
                                call act_state(itmp(4),s-1,.true.,isgn(4))
                                if(isgn(4)==0)cycle
                                jstate=dmem%ibs_r(itmp(4))
                                if(jstate>i.or.jstate==0)cycle
                                jstate=jstate-dmem%idx_r(ival)+1
                                z_row(jstate)=z_row(jstate)+isgn(4)* &
                                        &dmem%v2e(p,s,q,r)
                            enddo
                        enddo
                    enddo
                enddo
                if(irun==1)then
                    nnz=nnz+count(abs(z_row(1:i-dmem%idx_r(ival)+1))>1.d-10)
                    dmem%ucsr%i(istate+1)=nnz+1
                    cycle
                else
                    do j=dmem%idx_r(ival),i
                        jstate=j-dmem%idx_r(ival)+1
                        if(abs(z_row(jstate))<=1.d-10)cycle
                        nnz=nnz+1
                        dmem%ucsr%j(nnz)=j-dmem%idx_r(dmem%nval_bot)+1
                        dmem%ucsr%a(nnz)=z_row(jstate)
                    enddo
                endif
            enddo
        enddo
    enddo
    return

end subroutine calc_ucsr_spci

subroutine av1_gspci_dlh(v1,v2)
    use gprec
    use gspci
    use sparse
    implicit none
    complex(q),intent(in)::v1(*)
    complex(q),intent(inout)::v2(*)

    integer i,j

    ! D_ij
    call av1_gspci_mij(v1,v2)

    ! lambda_c (la2)
    call av1_gspci_nvij(dmem%lambdac,v1,v2)

    ! h_loc (ucsr)
    call av1_gspci_ucsr(v1,v2)
    return

end subroutine av1_gspci_dlh

subroutine av1_gspci_ucsr(v1,v2)
    use gprec
    use gspci
    implicit none
    complex(q),intent(in)::v1(*)
    complex(q),intent(inout)::v2(*)

    integer nbase,ival,nfs_r,nfs_l,i1,i1_,j1,inz

    nbase=0
    do ival=dmem%nval_bot,dmem%nval_top
        nfs_r=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l=dmem%idx_l(dmem%norb-ival+1)-dmem%idx_l(dmem%norb-ival)
        if(nfs_l<=0)cycle
        do i1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
            i1_=i1-dmem%idx_r(dmem%nval_bot)+1
            do inz=dmem%ucsr%i(i1_),dmem%ucsr%i(i1_+1)-1
                j1=dmem%ucsr%j(inz)+dmem%idx_r(dmem%nval_bot)-1
                call zaxpy(nfs_l,dmem%ucsr%a(inz), &
                        &v1(nbase+(j1-dmem%idx_r(ival))*nfs_l+1),1,&
                        &v2(nbase+(i1-dmem%idx_r(ival))*nfs_l+1),1)
                if(i1==j1)cycle
                call zaxpy(nfs_l,conjg(dmem%ucsr%a(inz)), &
                        &v1(nbase+(i1-dmem%idx_r(ival))*nfs_l+1),1,&
                        &v2(nbase+(j1-dmem%idx_r(ival))*nfs_l+1),1)
            enddo
        enddo
        nbase=nbase+nfs_r*nfs_l
    enddo
    return

end subroutine av1_gspci_ucsr

subroutine calc_dm_spci()
    use gprec
    use gspci
    use sparse
    implicit none
    complex(q) dm(dmem%norb,dmem%norb)

    ! c_i^\dagger c_j
    dm=0
    call expval_gspci_npij(dmem%v,dm)
    dmem%dm(1:dmem%norb,1:dmem%norb)=dm

    ! f_i^\dagger f_j
    dm=0
    call expval_gspci_nvij(dmem%v,dm)
    dmem%dm(1+dmem%norb:,1+dmem%norb:)=dm

    ! c_j^\dagger f_i
    dm=0
    call expval_gspci_mij(dmem%v,dm)
    dmem%dm(1+dmem%norb:,1:dmem%norb)=dm
    dmem%dm(1:dmem%norb,1+dmem%norb:)=transpose(conjg(dm))
    return

end subroutine calc_dm_spci

subroutine av_gspci(v1,v2,k,primme)
    use gprec
    use gspci
    use gconstant
    implicit none
    integer,intent(in)::k
    integer(8),intent(in)::primme
    complex(q),intent(in)::v1(*)
    complex(q),intent(out)::v2(*)

    integer n,i

    n=dmem%nstates
    do i=1,k
        v2(n*(i-1)+1:n*i)=0
        call av1_gspci(v1(n*(i-1)+1),v2(n*(i-1)+1))
    enddo
    return

end subroutine av_gspci

! A component of angular momentum vector acting on |v1>
! |v2> += \sum_{a,b}{cm_{a,b} (nc_{a,b} + nf_{a,b})} |v1>
subroutine av1_gspci_jop(cm,v1,v2)
    use gprec
    use gspci
    use sparse
    use gutil
    implicit none
    complex(q),intent(in)::cm(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(dmem%nstates)
    complex(q),intent(inout)::v2(dmem%nstates)

    integer i
    complex(q) cm_(dmem%norb,dmem%norb)

    call av1_gspci_npij(cm ,v1,v2)
    cm_=-cm
    call av1_gspci_nvij(cm_,v1,v2)
    v2=v2+v1*trace_a(cm,dmem%norb)
    return

end subroutine av1_gspci_jop

! Expectation value.
! <v2| \sum_{a,b}{cm_{a,b} (nc_{a,b} + nf_{a,b})} |v1>
subroutine zv2h_gspci_jop_v1(cm,v1,v2,zes)
    use gprec
    use gspci
    use sparse
    implicit none
    complex(q),intent(in)::cm(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(dmem%nstates),v2(dmem%nstates)
    complex(q),intent(inout)::zes
    complex(q),external::zdotc

    call expval_gspci_npij2(cm,v1,v2,zes)
    call expval_gspci_nvij2(cm,v1,v2,zes)
    return

end subroutine zv2h_gspci_jop_v1

! The square of one component of angular momentum operator scting on |v1>
! |v2> += (s/l/j)_{x/y/z}^2 |v1>
subroutine av1_gspci_j2op(cm,v1,v2)
    use gprec
    use gspci
    use sparse
    implicit none
    complex(q),intent(in)::cm(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(dmem%nstates)
    complex(q),intent(inout)::v2(dmem%nstates)

    complex(q) v1p(dmem%nstates)

    v1p=0
    call av1_gspci_jop(cm,v1,v1p)
    call av1_gspci_jop(cm,v1p,v2)
    return

end subroutine av1_gspci_j2op

! |v2> += lambda_j2 * (J_z^2 + Jz) |v1>
subroutine av1_gspci_jz2_pjz(lambda_j2,cm_z,v1,v2)
    use gprec
    use gspci
    use sparse
    implicit none
    real(q),intent(in)::lambda_j2
    complex(q),intent(in)::cm_z(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(dmem%nstates)
    complex(q),intent(inout)::v2(dmem%nstates)

    complex(q) v1p(dmem%nstates)
    complex(q) cm(dmem%norb,dmem%norb)

    v1p=0
    cm=cm_z*sqrt(lambda_j2)
    call av1_gspci_jop(cm,v1,v1p)
    v2=v2+sqrt(lambda_j2)*v1p
    call av1_gspci_jop(cm,v1p,v2)
    return

end subroutine av1_gspci_jz2_pjz

! |v2> += lambda_j2 * (J-J+) |v1>
subroutine av1_gspci_jnjp(lambda_j2,cm_n,v1,v2)
    use gprec
    use gspci
    use sparse
    implicit none
    real(q),intent(in)::lambda_j2
    complex(q),intent(in)::cm_n(dmem%norb,dmem%norb)
    complex(q),intent(in)::v1(dmem%nstates)
    complex(q),intent(inout)::v2(dmem%nstates)

    complex(q) v1p(dmem%nstates)
    complex(q) cm(dmem%norb,dmem%norb)

    v1p=0
    cm=conjg(transpose(cm_n))*sqrt(lambda_j2)
    call av1_gspci_jop(cm,v1,v1p)
    cm=cm_n*sqrt(lambda_j2)
    call av1_gspci_jop(cm,v1p,v2)
    return

end subroutine av1_gspci_jnjp

subroutine chk_eval_j2_sumway(cm_vec,label)
    use gprec
    use gspci
    use sparse
    implicit none
    character(*),intent(in)::label
    complex(q),intent(in)::cm_vec(dmem%norb,dmem%norb,3)

    integer i
    complex(q) eval

    eval=0
    do i=1,3
        call calc_eval_gspci_j2op(cm_vec(:,:,i),dmem%v,eval)
    enddo
    write(0,*) label,"(sum_way) = ", eval
    return

end subroutine chk_eval_j2_sumway

! The expectation value of square of one component of angular momentum
! operator with respect to |v1>, i.e.,
! <v1| (s/l/j)_{x/y/z}^2 |v1>
subroutine calc_eval_gspci_j2op(cm,v1,zes)
    use gprec
    use gspci
    use sparse
    implicit none
    complex(q),intent(in)::cm(dmem%norb,dmem%norb),v1(dmem%nstates)
    complex(q),intent(inout)::zes

    complex(q) v1p(dmem%nstates)

    v1p=0
    call av1_gspci_jop(cm,v1,v1p)
    call zv2h_gspci_jop_v1(cm,v1p,v1,zes)
    return

end subroutine calc_eval_gspci_j2op

subroutine calc_save_rho_cp_blks(imp)
    use gprec
    use sparse
    use gutil
    use ghdf5_base
    use ghdf5
    use gspci
    implicit none
    integer,intent(in)::imp

    integer ival,nstates,i,j
    complex(q),allocatable::rho(:,:)
    type(dcoo_matrix)::npcoo(dmem%norb,dmem%norb)

    call gh5_open_w('EMBED_HAMIL_ANALYSIS_'//trim(int_to_str(imp))//'.h5',f_id)
    do ival=dmem%nval_bot,dmem%nval_top
        nstates=dmem%idx(ival+1)-dmem%idx(ival)
        allocate(rho(nstates,nstates))
        call calc_reduced_rho_nblk(rho,nstates,ival)
        if(maxval(abs(rho))>1.d-16)then
            call gh5_create_group('/valence_block_'// &
                    &trim(int_to_str(ival)),f_id)
            call gh5_write(rho,nstates,nstates,'/valence_block_'// &
                    &trim(int_to_str(ival))//'/RHO',f_id)
            call calc_npcoo_nblk(npcoo,ival)
            do i=1,dmem%norb; do j=1,i
                if(npcoo(i,j)%nnz==0)cycle
                call gh5_write_compound(npcoo(i,j),'/valence_block_'// &
                        &trim(int_to_str(ival))//'/NP_'//trim(int_to_str(i))// &
                        &'_'//trim(int_to_str(j)),f_id)
                call dealloc_dcoo(npcoo(i,j))
            enddo; enddo
        endif
        deallocate(rho)
    enddo
    call gh5_close(f_id)
    return

end subroutine calc_save_rho_cp_blks

subroutine calc_npcoo_nblk(npcoo,ival)
    use gprec
    use gspci
    use sparse
    use gutil
    implicit none
    integer,intent(in)::ival
    type(dcoo_matrix),intent(out)::npcoo(dmem%norb,dmem%norb)

    integer nstates,ia1,ia2,i1,isum,itmp1,isgn,ibs,nbase

    nstates=dmem%idx(ival+1)-dmem%idx(ival)
    nbase=dmem%idx(ival)-1
    do ia1=1,dmem%norb; do ia2=1,ia1
        call alloc_dcoo(npcoo(ia1,ia2),nstates,nstates,nstates)
        isum=0
        ! < state | c_ia1^\dagger c_ia2
        do i1=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
            itmp1=dmem%bs_r(i1)
            isgn=1
            call act_state(itmp1,ia1-1,.false.,isgn)
            if(isgn==0)cycle
            call act_state(itmp1,ia2-1,.true.,isgn)
            if(isgn==0)cycle
            ibs=dmem%ibs_r(itmp1)
            if(ibs==0)cycle
            isum=isum+1
            npcoo(ia1,ia2)%i(isum)=i1-nbase
            npcoo(ia1,ia2)%j(isum)=ibs-nbase
            npcoo(ia1,ia2)%a(isum)=real(isgn,q)
        enddo
        npcoo(ia1,ia2)%nnz=isum
    enddo; enddo
    return

end subroutine calc_npcoo_nblk

! Generate reduced manybody denity matrix in valence block n.
subroutine calc_reduced_rho_nblk(rho,n,ival)
    use gprec
    use gspci
    implicit none
    integer,intent(in)::n,ival
    complex(q),intent(out)::rho(n,n)

    integer i,i_,j,j_,nbase,nfs_l
    complex(q),external::zdotc

    rho=0
    nfs_l=dmem%idx_l(dmem%norb-ival+1)-dmem%idx_l(dmem%norb-ival)
    if(nfs_l<=0)return

    nbase=0
    do i=dmem%nval_bot,ival-1
        nbase=nbase+(dmem%idx_r(i+1)-dmem%idx_r(i))* &
                &(dmem%idx_l(dmem%norb-i+1)-dmem%idx_l(dmem%norb-i))
    enddo
    do i=dmem%idx_r(ival),dmem%idx_r(ival+1)-1
        i_=dmem%ibs(dmem%bs_r(i))-dmem%idx(ival)+1
        do j=dmem%idx_r(ival),i
            j_=dmem%ibs(dmem%bs_r(j))-dmem%idx(ival)+1
            rho(i_,j_)=zdotc(nfs_l,dmem%v(nbase+(j-dmem%idx(ival))*nfs_l+1),&
                    &1,dmem%v(nbase+(i-dmem%idx(ival))*nfs_l+1),1)
            if(i_==j_)cycle
            rho(j_,i_)=conjg(rho(i_,j_))
        enddo
    enddo
    return

end subroutine calc_reduced_rho_nblk

subroutine calc_save_phi_matrix_blks(imp)
    use gprec
    use sparse
    use gutil
    use ghdf5_base
    use ghdf5
    use gspci
    implicit none
    integer,intent(in)::imp

    integer ival,nfs_r,nfs_l,nfs,nbase
    complex(q),allocatable::phi(:,:)

    call gh5_open_w('EMBED_HAMIL_PHIMAT_'//trim(int_to_str(imp))//'.h5',f_id)
    nbase=0
    do ival=dmem%nval_bot,dmem%nval_top
        nfs=dmem%idx(ival+1)-dmem%idx(ival)
        nfs_r=dmem%idx_r(ival+1)-dmem%idx_r(ival)
        nfs_l=dmem%idx_l(dmem%norb-ival+1)-dmem%idx_l(dmem%norb-ival)
        allocate(phi(nfs,nfs))
        call phi_vec_to_mat(dmem%v(nbase+1:nbase+nfs_r*nfs_l),phi,nfs, &
                &dmem%bs_r(dmem%idx_r(ival):dmem%idx_r(ival+1)-1), &
                &nfs_r, &
                &dmem%bs_l(dmem%idx_l(dmem%norb-ival): &
                &dmem%idx_l(dmem%norb-ival+1)-1), &
                &nfs_l,dmem%norb,dmem%ibs,dmem%idx(ival))
        if(maxval(abs(phi))>1.d-16)then
            call gh5_create_group('/valence_block_'// &
                    &trim(int_to_str(ival)),f_id)
            call gh5_write(phi,nfs,nfs,'/valence_block_'// &
                    &trim(int_to_str(ival))//'/PHI',f_id)
        endif
        deallocate(phi)
        nbase=nbase+nfs_r*nfs_l
    enddo
    call gh5_close(f_id)
    return

end subroutine calc_save_phi_matrix_blks


      SUBROUTINE DRAW (GPLST,X,U,S,DISP,STEREO,OPCOR,BUF1)
C
      EXTERNAL        ANDF
      LOGICAL         DISP
      INTEGER         ANDF,AXIS(3),BUF1,DAXIS,ELSET,GP,GPLST(1),OPCOR,
     1                PCON,PEDGE,PEN,PLABEL,PLTNUM,PORIG,PPEN,PRJECT,
     2                PSET,PSHAPE,PSYMBL,PSYMM,PVECTR,STEREO,SYM(2),
     3                SUCOR,V,VEC(3),COLOR,DEFM
      REAL            A(3),MAXDEF,S(2,1),SIGN(3),U(3,1),X(3,1),MIN,MAX
      DOUBLE PRECISION DR,SUM
      COMMON /BLANK / NGP,SKP11(3),PLTNUM,NGPSET,SKP12(4),SKP21(2),ELSET
      COMMON /XXPARM/ PBUFSZ,CAMERA(5),NOPENS,PAPSIZ(2),PENPAP(27),
     1                SCALE,OBJMOD,SKPSCL,MAXDEF,DEFMAX,AXES(3),
     2                DAXIS(3),VIEW(9),VANTX1,R0,VANTX2(3),D0,VANTX3(2),
     3                PRJECT,VANTX4,ORIGX1(14),EDGE(11,4),XY(11,3),
     4                NCNTR(51),ICNTVL,SKP24(24),COLOR
      COMMON /PLTDAT/ MODEL,PLOTER,REG(4),AXYMAX(14)
      COMMON /RSTXXX/ CSTM(3,3),MIN(3),MAX(3)
      COMMON /DRWDAT/ PSET,PLABEL,PORIG,PPEN,PSHAPE,PSYMBL(2),PSYMM(6),
     1                PVECTR,PCON,PEDGE
C
C     /DRWDAT/ CONTROLS THIS ROUTINE
C     PLABEL - LABELING GRIDS, ELEMENTS...
C            -N = NONE
C             0 = GID             3 = EID          6 = EID + GID
C             1 = GID + SPC       4 = EID + PID
C             2 = UNDEFINED.      5 = UNDEFINED
C     PSHAPE - WHICH SHAPE OR OUTLINE OPTION TO DRAW...
C             1 = UNDEFORMED      2 = DEFORMED     3 = BOTH
C     PSYMBL(2) - DRAW SYMBOLS IF PSYMBL(1).NE.0
C     PSYMM (6) - SYMMETRY FLAGS...
C           (1) = X AXIS SIGN CHANGE   (4) = X DEFORMATION SIGN CHANGE
C           (2) = Y                    (5) = Y
C           (3) = Z                    (6) = Z
C     PVECTR - DEFORMATION VECTORS DRAWN (AS INTERPRETED BY INTVEC)...
C             0 = NONE
C             1 = X     4 = Z     7 = XYZ        10 = RY    13 = RXZ
C             2 = Y     5 = ZX    8 = UNDEFINED  11 = RXY   14 = RYZ
C             3 = XY    6 = ZY    9 = RX         12 = RZ    15 = RXYZ
C             THE NEGATIVE OF ABOVE, DO NOT DRAW SHAPE.
C    PCON   - NONZERO MEANS CONTOUR PLOT...
C    PEDGE  - 0 = SHAPE DRAWN,
C             1 = OUTLINE (BORDER) DRAWN ACCORDING TO PSHAPE-S
C             2 = HIDDEN LINE PLOT
C             3 = OFFSET PLOT
C             4 THRU N = SHRINK PLOT, ELEMENT SHRUNK BY THIS PERCENT
C             200 +  N = HIDDEN LINE AND SHRINK PLOT, N.GT.2
C             100 = FILL ?
C
C     OPCOR = NO. OF OPEN CORE WORDS AVAILABLE IN S
C             IT IS NOT A POINTER TO S, NOR A OPEN CORE ARRAY IN S
C     BUF1  = BUFFER AVAILABLE AT END OF CORE W.R.T. GPLST = BUFSIZ+1
C
C     OPEN CORE /ZZPLOT/
C     SETID NSETS NDOF      NGP 3*NGPSET 3*NGPSET  OPCOR   N
C     -----+-----+----+----+---+--------+--------+-------+--+--+-+-+-+-+
C          !          N1   N2  I1 (X)   I2 (U)   I3  (S)   DEFBUF..BUF..
C          !(DEFLST)       !
C                          !(GPLST)                      N=2*NGPSET
C
C     NGP    = TOTAL NO. OF GRID POINTS IN THE STRUCTURE
C     NGPSET = NO. OF GRID POINTS USED IN CURRENT SET OF PLOTTING
C     GPLST  = TABLE OF NGP IN LENGTH,
C              GPLST(I) = 0 IF THIS I-TH GRID POINT IS NOT USED FOR THE
C              CURRENT PLOT. OTHERWISE GPLST(I) IS NON-ZERO.
C     X      = X,Y,Z COORDINATES OF THE GRID POINTS CORRESPONDING TO THE
C              NON-ZERO GRID POINTS IN THE GPLST TABLE
C              TOTALLY, THERE ARE NGPSET GRID POINTS IN X
C     U      = X,Y,Z DISPLACEMENTS, ARRANGED SIMILARLY TO X
C     S      = SCRATCH AREA
C
      SCALEX = 1.0
      IF (PRJECT .EQ. 3) SCALEX = OBJMOD
C
C     SETUP THE PLOTTER REGION.
C
      IF (PSYMM(1).LT.0 .OR. PSYMM(2).LT.0 .OR. PSYMM(3).LT.0) GO TO 10
      REG(1) = EDGE(PORIG,1)*AXYMAX(1)
      REG(2) = EDGE(PORIG,2)*AXYMAX(2)
      REG(3) = EDGE(PORIG,3)*AXYMAX(1)
      REG(4) = EDGE(PORIG,4)*AXYMAX(2)
      GO TO 20
   10 REG(1) = 0.0
      REG(2) = 0.0
      REG(3) = AXYMAX(1)
      REG(4) = AXYMAX(2)
C
C     REDUCE THE GRID POINT CO-ORDINATES TO PLOT SIZE + TRANSLATE TO
C     THE SELECTED ORIGIN.
C
   20 DO 40 I = 1,3
      MIN(I) = +1.E+20
      MAX(I) = -1.E+20
      IF (PSYMM(I) .GE. 0) GO TO 40
      DO 30 GP = 1,NGPSET
   30 X(I,GP) = -X(I,GP)
   40 CONTINUE
      CALL PROCES (X)
      CALL PERPEC (X,STEREO)
      XORIG = XY(PORIG,1)
      IF (STEREO .NE. 0) XORIG = XY(PORIG,2)
      DO 50 GP = 1,NGPSET
      X(2,GP) = SCALE*X(2,GP) - XORIG
      X(3,GP) = SCALE*X(3,GP) - XY(PORIG,3)
   50 CONTINUE
C
      IF (.NOT.DISP .OR. MAXDEF.EQ.0 .OR. DEFMAX.EQ.0) GO TO 120
C
C     PROCESS THE DEFORMATIONS.
C     EXCHANGE AXES, REDUCE THE MAXIMUM DEFORMATION TO -MAXDEF-.
C
      DO 100 I = 1,3
      AXIS(I) = IABS(DAXIS(I))
      SIGN(I) = 1.
      IF (DAXIS(I) .LT. 0) SIGN(I) = -1.
  100 CONTINUE
      I = AXIS(1)
      J = AXIS(2)
      K = AXIS(3)
      D = MAXDEF/DEFMAX
      DO 110 GP = 1,NGPSET
      IF (PSYMM(4) .LT. 0) U(1,GP) = -U(1,GP)
      IF (PSYMM(5) .LT. 0) U(2,GP) = -U(2,GP)
      IF (PSYMM(6) .LT. 0) U(3,GP) = -U(3,GP)
      A(1) = U(I,GP)
      A(2) = U(J,GP)
      A(3) = U(K,GP)
      U(1,GP) = A(1)*SIGN(1)*D
      U(2,GP) = A(2)*SIGN(2)*D
      U(3,GP) = A(3)*SIGN(3)*D
  110 CONTINUE
      CALL INTVEC (PVECTR)
C
C     IF PVECTR .LT. 0 NO SHAPE WILL BE DRAWN
C     ATTEMPT TO REMOVE DUPLICATE LINES
C
  120 IOPT = -1
      SUCOR = 2*NGPSET + 1
      IF (.NOT.DISP) SUCOR = 1
C
C     FIRST DETERMINE OPTIONS - UNIQUE LINES FOR PSHAPE=3 MAY ONLY BE
C     FOR THE UNDERLAY.  ISHAPE = 0 MEANS DRAW THE SHAPE..
C
      ISHAPE = -1
      LATER  = 0
      IF (PVECTR.LT.0 .OR. (PEDGE.NE.0 .AND. PEDGE.NE.3)) GO TO 130
      ISHAPE = 0
      IF (OPCOR .LT. NGPSET+NGP+1) GO TO 130
      IOPT = 0
      DEFM = 0
      IF (PSHAPE .GE. 2) DEFM = 1
      CALL LINEL (S(SUCOR,1),IPTL,OPCOR,IOPT,X,PPEN,DEFM,GPLST)
      IF (PEDGE .EQ. 3) GO TO 500
      IF (IPTL  .LE. 0) IOPT = -1
      CALL BCKREC (ELSET)
  130 IF (PSHAPE.EQ.2 .AND. DISP) GO TO 260
C
C     DRAW UNDEFORMED SHAPE (USE PEN1 + SYMBOL 2 IF THE DEFORMED SHAPE
C     OR DEFORMATION VECTORS ARE ALSO TO BE DRAWN).
C
      PEN = PPEN
      IF (DISP .AND. PSHAPE.GT.2) PEN = 1
      IF (ISHAPE .EQ. 0)
     1    CALL SHAPE (*500,GPLST,X,0,PEN,0,IOPT,IPTL,S(SUCOR,1),OPCOR)
      IF (PEDGE .LT. 2) GO TO 140
      CALL HDSURF (GPLST,X,0,PEN,0,NMAX,MAXSF,S(SUCOR,1),BUF1,PEDGE,
     1             OPCOR)
      IF (PEDGE.NE.2 .AND. PEDGE.LT.200) GO TO 140
      CALL HDPLOT (GPLST,NMAX,MAXSF,OPCOR,BUF1)
      GO TO 220
  140 IF (PCON .EQ. 0) GO TO 200
      IF (.NOT.DISP .OR. PSHAPE.LT.3) GO TO 210
      LATER = PCON
      PCON  = 0
  200 IF (PEDGE.EQ.0 .OR. PEDGE.GE.2) GO TO 220
  210 IOPT = -1
      CALL CONTOR (GPLST,X,0,U,S(SUCOR,1),S(SUCOR,1),PEN,0,BUF1,OPCOR)
      IF (PEDGE .EQ. 1) CALL BORDER (GPLST,X,0,S(SUCOR,1),0,BUF1,OPCOR)
      IF (PEDGE.EQ.1 .OR. COLOR.GE.0) GO TO 220
      CALL GOPEN (ELSET,GPLST(BUF1),0)
      CALL SHAPE (*500,GPLST,X,0,1,0,IOPT,IPTL,S(SUCOR,1),OPCOR)
  220 PCON = MAX0(PCON,LATER)
      IF (PPEN .GT. 31)
     1    CALL SHAPE (*500,GPLST,X,0,1,0,IOPT,IPTL,S(SUCOR,1),OPCOR)
      IF (PSHAPE .EQ. 1) PCON = 0
      IF (PSYMBL(1) .EQ. 0) GO TO 250
      IF (DISP) GO TO 230
      SYM(1) = PSYMBL(1)
      SYM(2) = PSYMBL(2)
      GO TO 240
  230 SYM(1) = 2
      SYM(2) = 0
  240 CALL GPTSYM (GPLST,X,0,SYM,0)
  250 IF (PLABEL .LT. 0) GO TO 260
      I = PLABEL/3
      IF (I .NE. 1) CALL GPTLBL (GPLST,X,0,0,BUF1)
      IF (I .LT. 1) GO TO 260
      CALL ELELBL (GPLST,X,0,0,BUF1)
      CALL BCKREC (ELSET)
  260 IF (.NOT.DISP .OR. MAXDEF.EQ.0.0 .OR. DEFMAX.EQ.0.0) GO TO 500
      IF (PEDGE .EQ. 3) GO TO 500
      IF (PSHAPE.LT.2 .AND. LATER.EQ.0) GO TO 350
C
C     ROTATE THE DEFORMATIONS
C
      DO 290 GP = 1,NGPSET
      DO 280 J  = 1,3
      SUM = CSTM(J,1)*U(1,GP) + CSTM(J,2)*U(2,GP) + CSTM(J,3)*U(3,GP)
      IF (J .NE. 1) GO TO 270
      IF (PRJECT .NE. 1) DR = D0/(R0-SCALEX*(X(1,GP)+SUM))
      GO TO 280
  270 IF (PRJECT .NE. 1) SUM = SCALEX*DR*SUM
      S(J-1,GP) = X(J,GP) + SCALE*SUM
  280 CONTINUE
  290 CONTINUE
C
C     DRAW THE DEFORMED SHAPE
C
      IF (PVECTR .LT. 0) GO TO 300
      PEN = PPEN
      IF (PSHAPE.EQ.2 .AND. PVECTR.NE.0) PEN = 1
      IF (PEDGE .EQ. 0)
     1    CALL SHAPE (*500,GPLST,X,S,PEN,1,IOPT,IPTL,S(SUCOR,1),OPCOR)
      IF (PEDGE .LT. 2) GO TO 300
      CALL HDSURF (GPLST,X,S,PEN,1,NMAX,MAXSF,S(SUCOR,1),BUF1,PEDGE,
     1             OPCOR)
      IF (PEDGE.EQ.2 .OR. PEDGE.GT.200)
     1    CALL HDPLOT (GPLST,NMAX,MAXSF,OPCOR,BUF1)
  300 IF (PCON.EQ.0 .OR. PEDGE.EQ.2 .OR. PEDGE.GT.200) GO TO 310
      IF (ICNTVL.LE. 9 .AND. PSHAPE.EQ.1) GO TO 310
      IF (ICNTVL.GT.13 .AND. PSHAPE.EQ.1) GO TO 310
      CALL CONTOR (GPLST,X,S,U,S(SUCOR,1),S(SUCOR,1),PEN,0,BUF1,OPCOR)
      IF (PEDGE.EQ.1 .OR. COLOR.GE.0) GO TO 310
      CALL GOPEN (ELSET,GPLST(BUF1),0)
      CALL SHAPE (*500,GPLST,X,0,1,0,IOPT,IPTL,S(SUCOR,1),OPCOR)
  310 IF (PEDGE.EQ.  1) CALL BORDER (GPLST,X,S,S(SUCOR,1),1,BUF1,OPCOR)
      IF (PPEN .GT. 31)
     1    CALL SHAPE  (*500,GPL,X,0,1,0,IOPT,IPTL,S(SUCOR,1),OPCOR)
      IF (PSYMBL(1) .EQ. 0) GO TO 340
      IF (PSHAPE.EQ.2 .AND. PVECTR.NE.0) GO TO 320
      SYM(1) = PSYMBL(1)
      SYM(2) = PSYMBL(2)
      GO TO 330
  320 SYM(1) = 2
      SYM(2) = 0
  330 CALL GPTSYM (GPLST,X,S,SYM,1)
  340 IF (PLABEL.LT.0 .OR. PSHAPE.NE.2) GO TO 350
      I = PLABEL/3
      IF (I .NE. 1) CALL GPTLBL (GPLST,X,S,1,BUF1)
      IF (I .LT. 1) GO TO 350
      CALL ELELBL (GPLST,X,S,1,BUF1)
  350 IF (PVECTR .EQ. 0) GO TO 500
      PVECTR = IABS(PVECTR)
C
C     PROCESS THE DEFORMATION VECTORS
C
      IF (PVECTR .LE. 7) GO TO 410
      NV = 1
      VEC(1) = 0
      VEC(2) = 0
      VEC(3) = 0
      DO 400 V = 1,3
      IF (ANDF(PVECTR,2**(V-1)) .EQ. 0) GO TO 400
      IF (AXIS(1).EQ.V) VEC(1) = 1
      IF (AXIS(2).EQ.V) VEC(2) = 1
      IF (AXIS(3).EQ.V) VEC(3) = 1
  400 CONTINUE
      GO TO 420
  410 NV = 3
  420 DO 490 V = 1,NV
      IF (PVECTR .GT. 7) GO TO 440
      IF (ANDF(PVECTR,2**(V-1)) .EQ. 0) GO TO 490
      DO 430 I = 1,3
      VEC(I) = 0
      IF (AXIS(I) .EQ. V) VEC(I) = 1
  430 CONTINUE
C
C     ROTATE THE DEFORMATIONS (VEC = VECTOR DIRECTION TO BE DRAWN)
C
  440 DO 480 GP = 1,NGPSET
      DO 470 J  = 1,3
      SUM = 0.D0
      DO 450 I = 1,3
      IF (VEC(I) .NE. 0) SUM = SUM + CSTM(J,I)*U(I,GP)
  450 CONTINUE
      IF (J .NE. 1) GO TO 460
      IF (PRJECT .NE. 1) DR = D0/(R0-SCALEX*(X(1,GP)+SUM))
      GO TO 470
  460 IF (PRJECT .NE. 1) SUM = SCALEX*DR*SUM
      S(J-1,GP) = X(J,GP) + SCALE*SUM
  470 CONTINUE
  480 CONTINUE
C
C     DRAW THE DEFORMATION VECTOR
C
      CALL DVECTR (GPLST,X,S,PPEN)
      IF (PSYMBL(1).EQ.0 .OR. PSHAPE.EQ.3) GO TO 490
      J = 0
      IF (PSHAPE .EQ. 1) J = 1
      CALL GPTSYM (GPLST,X,S,PSYMBL,J)
  490 CONTINUE
C
C     END OF PLOT
C
C     IF NOT CONTOUR PLOT, CALL PCOORD TO DRAW A SMALL X-Y-Z COORDINATE
C     TRIAD AT THE LOWER RIGHT CORNER OF PLOT
C
  500 IF (PEDGE .NE. 1) CALL PCOORD (PEN)
      RETURN
      END