SUBROUTINE SetParameters

USE Params
USE Globals
USE Procedures
USE Funcs

IMPLICIT NONE

double precision::VzyJwork,rhopow,blimfrac,r_real_free_annual,junk,omegatemp,thettemp,meankap
double precision::lb(0:3)
integer::rebc,ij,ib
character(len=100) ParamOutputDir
character(len=100) ParamOutputDirSims

!ParamOutputDir = "/Users/kmitm/Dropbox/Dev/ConsHouse/Rev6/Output/PhYD995/"
!ParamOutputDirSims = "/Users/kmitm/Dropbox/Dev/ConsHouse/Rev6/Output/PhYD995/sims/"
ParamOutputDir = "/scratch/km2277/GETest/Results/"
ParamOutputDirSims = "/scratch/km2277/GETest/Results/sims/"
NoBankBelief = 0
OnlyBankBelief = 0
NoRentalBelief =0
beliefshock=1
HDX=0.10d0
HDY=0.10d0
HDZ=0.50d0
liquid=0.0d0 !0.025d0
DoSims=0
DoRf=0
DoMqm=0
rent_tax = 0.3
!DoInterestCap=1
!InterestCap=0.95d0
HELOCVal=1
payextra=4
AdjustCostModel=0
GeRent=0
mjscale=1.0d0
mjprob=0.04d0
Ar=1.0d0/0.045d0
hservices=0.01d0
Goldminevals=(/-0.3d0,-0.15d0,-0.05d0,0.0d0,0.05d0,0.15d0,0.30d0/)
!bet_h=0.97d0
adjval=0.07d0
!TARGET CAPITAL INCOME RATIO
MortDeduct=0.75d0 !1.0d0 !0.75d0
GSE=0
GSElim=0.80d0
rf=0.025d0
!rm=100000.0d0
rm=0.03d0
rl=0.04d0
HELOCmax=0.95d0
LTVmax=1.0d0
bmin = -1.0d0 !-1.0d0
beqlev=2360.0d0/20.0d0
beqmin=273000.0d0/DataAvAnnualEarns
tautax=0.151d0
ltax=0.75d0 !*((1.0d0+dble(BiAnnual))**(tautax))
mortfc=2000.0d0/DataAvAnnualEarns
rent_elas=0.4d0
ph_pers=1.0d0
ph_std=0.075d0 !0.025d0
!For fernald use 0.0125d0
ay_std=0.035d0 !   0.035d0

ph_nstd=3
epsprph=0.89d0
epsphy=0.0d0

alph=-6.66d0
!nu=50000d0 !1.0d-5
nu=1.0d0/50001.0d0

alph=0.5d0
nu=0.86d0
inithouse=0

bet=0.95d0
xi=3.0d0
omega=1.0d0
phi=1.0d0
sig=2.0d0
!sig=8.0d0
thet=0.05d0

phi_h=0.075d0 !Baseline
!phi_h=1.d0 !No Rent
!phi_h = 0.0d0 !beta_h case
deltah=0.0148d0
alpha_h=0.375d0
HMRate=deltah+0.01d0 !0.01d0
ALLOCATE(initliq(ngpzy+ngpfylev-1))
ALLOCATE(initill(ngpzy+ngpfylev-1))
ALLOCATE(initnw(ngpzy+ngpfylev-1))
ALLOCATE(initliqdist(ngpzy+ngpfylev-1,2))
ALLOCATE(initilldist(ngpzy+ngpfylev-1,2))
ALLOCATE(initnwdist(ngpzy+ngpfylev-1,2))

popsize(1:Jtot)=1.0d0
popdist=popsize/sum(popsize)

!EARNINGS PROCESS
SELECT CASE (WhichStochModel)

        CASE(-1) !Uemp only
                Vepsy   = 0.0d0
                Vfey    = 0.0d0 !var fix effect
                Vzy0    = 0.0d0 !initial var persistent
                Vetay   = 0.0d0 !0.0 !var pers shocks
                rhoy    = 0.0d0 !0.99d0 !0.99
                lambday = 0.0   !probability of switch at quarterly level: only active if StaySwitchModelForzy=1
                rholevslo = 0.0d0
                                Vphy    = 0.0d0

        CASE(0)
                Vepsy   = 0.0
                Vfey    = 0.2723 !var fix effect
                Vzy0    = 0.0d0 !initial var persistent
                Vetay   = 0.0d0 !0.0 !var pers shocks
                rhoy    = 0.999d0 !0.99d0 !0.99
                lambday = 0.0   !probability of switch at quarterly level: only active if StaySwitchModelForzy=1
                rholevslo = 0.0d0
                Vphy    = 0.00002199574

        CASE(1) !AR only
                Vepsy   = 0.0d0 !(0.005d0)**2
                Vfey    = 0.0
                Vzy0    = 0.18d0
                rhoy    = (0.97d0)**(1.0d0+dble(BiAnnual))
                lambday = 1.0d0/1.0d0   !probability of switch at quarterly level: only active if StaySwitchModelForzy=1
                IF( rhoy .LT. 1.0d0 ) THEN
                        rhopow  = rhoy**(2.0d0*(real(Jwork)-1.0d0))
                        Vetay   = (Jwork*4.0d0*0.003d0*(1.0d0+dble(BiAnnual))+(1.0d0-rhoy**(2.0d0*real(Jwork)))*Vzy0)*(1.0d0-rhoy**(2.0d0))/(1.0d0-rhopow)
                ELSE
                        Vetay   = (1.0d0+dble(BiAnnual))*4.0d0*0.003d0
                ENDIF

                rholevslo = 0.0d0
                Vphy    = 0.0d0

        CASE(2) !FE + AR(1)
                Vepsy   = 0.0
                Vfey    = 0.1105
                Vzy0    = 0.0 !initial var persistent
                Vetay   = 0.00959 !var pers shocks
                rhoy    = 0.99d0
                lambday = 0.0   !probability of switch at quarterly level: only active if StaySwitchModelForzy=1
        CASE(3) !FE + AR(1) + IID
                Vepsy   = 0.34
                Vfey    = 0.11
                Vzy0    = 0.0 !initial var persistent
                Vetay   = 0.01 !var pers shocks
                rhoy    = 0.9902
                lambday = 0.0   !probability of switch at quarterly level: only active if StaySwitchModelForzy=1

END SELECT

print*,'Vetay: ',Vetay

IF (FlatEarningsProfile==1) THEN
        kappay = 0.0
ELSE
        SELECT CASE (WhichStochModel)

                CASE(0)
                lb(0) = -2.06665738921957d0
                lb(1) = 0.00858498077162529d0
                lb(2) = -4.09994229331142e-005
                lb(3) = -1.14130361947752e-007

                CASE(1)
!                lb(0) = -2.26672876755943d0
!                lb(1) = 0.01535062662749d0
!                lb(2) = -1.26657491105105e-004
!                lb(3) = 1.943843618504977e-007
                lb(0) = 5.080779897862075d0
                lb(1) = 0.354212100578216d0
                lb(2) = -0.006568425066786
                lb(3) = 0.000039013352423

!age^3: 0.000039013352423
!age^2: -0.006568425066786
!age: 0.354212100578216
!constant:  5.080779897862075

        END SELECT
        meankap=0.0d0
        DO ij = 1,Jwork
                kappay(ij) = lb(0)
                DO ib = 1,3
                        kappay(ij) = kappay(ij) + ((dble(ij-1)*2.0d0+22.5d0)**ib)*lb(ib)
!                        kappay(ij) = kappay(ij) + ((dble(ij-1)*8.0d0+4.50d0-12.0d0)**ib)*lb(ib)
                END DO
                meankap=meankap+exp(kappay(ij))/dble(Jwork)
!                print*,kappay(ij),exp(kappay(ij))
!                kappay(ij) = kappay(ij) + log(1.0d0+dble(BiAnnual))
        END DO
        kappay = kappay-log(meankap)
!        print*,kappay,exp(kappay)
!        pause
END IF
!DO ij = 1, Jwork
!   print*,ij,exp(kappay(ij))
!ENDDO
!pause
aa0=0.0d0 !log(0.5d0)*(0.1d0)
aa1=1.0d0 !0.9d0
aa2=0.0d0

bb0=0.0d0 !log(0.1d0)*(0.1d0)
bb1=0.0d0 !0.9d0
bb2=1.0d0

OPEN(1, FILE = InputDir // "nchild.txt")
DO ij=1,Jtot*2-1
    Read(1,*) nchild(ij)
ENDDO
CLOSE(1)
OPEN(1, FILE = InputDir // "adults.txt")
DO ij=1,Jtot*2-1
    Read(1,*) adults(ij)
ENDDO
CLOSE(1)
OPEN(1, FILE = InputDir // "equiv.txt")
DO ij=1,Jtot*2-1
    Read(1,*) nchild(ij)
ENDDO
CLOSE(1)
!adults=2.0d0
initliqdist=0.0d0
initnwdist=0.0d0
initnw=0.0d0
OPEN(1, FILE = InputDir // 'initwbroad.txt')
DO ij=1,ngpzy-DoMJ
   READ(1,*) initliqdist(ij,1),initliqdist(ij,2),initliq(ij),initilldist(ij,1),initilldist(ij,2),initill(ij),initnwdist(ij,1),initnwdist(ij,2),initnw(ij)
END DO
CLOSE(1)

initliq=initliq/(DataAvAnnualEarns/(Numeraire))
initill=initill/(DataAvAnnualEarns/(Numeraire))
initnw=initnw/(DataAvAnnualEarns/(Numeraire))

!initnw=initnw/sum(initnwdist(:,2)*initnw)

phi=1.0d0
DO ij=1,Jwork
!    phi(ij)=(0.25d0*nchild(1+2*(ij-1))+0.61d0+(adults(1+2*(ij-1))-1.0d0)*0.39d0)
!    phi(ij)=(0.25d0*nchild(1+2*(ij-1))+1.0d0)
   phi(ij)=nchild(1+2*(ij-1))+1.0d0
!    phi(ij)=1.0d0
!    print*,phi(ij)
ENDDO

OPEN(1, FILE = InputDir // "nhr.txt")
Read(1,*) nhr
CLOSE(1)
ALLOCATE(GridHR(nhr))
OPEN(1, FILE = InputDir // "nhrvals.txt")
DO ij=1,nhr
    Read(1,*) GridHR(ij)
ENDDO
CLOSE(1)

!READ IN PARAMETERS FROM TEXT FILE
IF (ReadParameters==1) THEN
    OPEN(1, FILE = InputDir // trim(InputParamFile))
    READ(1,*) OutputDir
    READ(1,*) OutputDirSims
    READ(1,*) bet
    READ(1,*) xi
    READ(1,*) omegatemp
    READ(1,*) alph
    READ(1,*) nu
    READ(1,*) thettemp
    READ(1,*) rf_base
    READ(1,*) mortmarkup
    READ(1,*) helocmarkup
    READ(1,*) HELOCmax
    READ(1,*) LTVmax
    READ(1,*) beqlev
    READ(1,*) beqmin
    READ(1,*) mortfc
    READ(1,*) GeRent
    READ(1,*) rent_elas
    READ(1,*) HMRate
    READ(1,*) alpha_h
    READ(1,*) deltah
    READ(1,*) demmodel
    READ(1,*) rent_tax
    CLOSE(1)

!    HMRate=HMRate+deltah
    omega=omegatemp

    if(thettemp .gt. 0.0d0) then

!       do ij=1,Jwork
!          thet(ij)=0.01d0*dble(Jwork-ij)
!       enddo
       thet=thettemp
    endif

    mortfc = mortfc / (DataAvAnnualEarns/Numeraire)
    beqmin=beqmin / (DataAvAnnualEarns/Numeraire)
    if(demmodel .eq. 0) phi=1.0d0
    if(1 .eq. 1) then
    if(Benchmark .eq. 0) then
       OPEN(1, FILE = trim(OutputDir) // "a0.txt")
       DO ij=1,ngpAgg
          DO giAgg=1,ngpAgg
             Read(1,*) aa0(ij,giAgg)
          ENDDO
       ENDDO
       CLOSE(1)
       OPEN(1, FILE = trim(OutputDir) // "a1.txt")
       DO ij=1,ngpAgg
          DO giAgg=1,ngpAgg
             Read(1,*) aa1(ij,giAgg)
          ENDDO
       ENDDO
       CLOSE(1)
       OPEN(1, FILE = trim(OutputDir) // "a2.txt")
       DO ij=1,ngpAgg
          DO giAgg=1,ngpAgg
             Read(1,*) aa2(ij,giAgg)
          ENDDO
       ENDDO
       CLOSE(1)
              OPEN(1, FILE = trim(OutputDir) // "b0.txt")
       DO ij=1,ngpAgg
          DO giAgg=1,ngpAgg
             Read(1,*) bb0(ij,giAgg)
          ENDDO
       ENDDO
       CLOSE(1)
       OPEN(1, FILE = trim(OutputDir) // "b1.txt")
       DO ij=1,ngpAgg
          DO giAgg=1,ngpAgg
             Read(1,*) bb1(ij,giAgg)
          ENDDO
       ENDDO
       CLOSE(1)
       OPEN(1, FILE = trim(OutputDir) // "b2.txt")
       DO ij=1,ngpAgg
          DO giAgg=1,ngpAgg
             Read(1,*) bb2(ij,giAgg)
          ENDDO
       ENDDO
       CLOSE(1)

    elseif(Benchmark .eq. 1) then
!       OPEN(1, FILE = trim(InputDir) // "a0.txt")
!       DO ij=1,ngpAgg
!          DO giAgg=1,ngpAgg
!             Read(1,*) aa0(ij,giAgg)
!          ENDDO
!       ENDDO
!       CLOSE(1)
!       OPEN(1, FILE = trim(InputDir) // "a1.txt")
!       DO ij=1,ngpAgg
!          DO giAgg=1,ngpAgg
!             Read(1,*) aa1(ij,giAgg)
!          ENDDO
!       ENDDO
!       CLOSE(1)
    endif
    endif

ELSE
   OutputDir=ParamOutputDir
   OutputDirSims=ParamOutputDirSims

END IF

bet_h=bet !0.95d0 !1.0d0-rf_base-mortmarkup
zbar=((0.0266d0/(alpha_h**alpha_h))**(1.0d0-alpha_h))/alpha_h
zbar=((3.0d0*deltah)**(0.625d0))/(0.375d0**0.375d0)
zbar=((0.75d0*deltah)**(1.0d0-alpha_h))/(alpha_h**alpha_h)

if(GeRent .eq. 0) then
 !  zbar=exp((1.0d0-alpha_h)*(log(deltah*2.8d0*0.64d0))-log(0.5d0)-alpha_h*log(alpha_h))
!   zbar=exp((1.0d0-alpha_h)*(log(deltah*2.4d0*0.64d0))-log(0.55d0)-alpha_h*log(alpha_h))
   zbar=exp((1.0d0-alpha_h)*(log(deltah*1.8d0*0.64d0))-log(0.55d0)-alpha_h*log(alpha_h))
else
   zbar=exp((1.0d0-alpha_h)*(log(deltah*(2.4d0*0.64d0+0.36d0*1.2d0)))-alpha_h*log(0.55d0)-alpha_h*log(alpha_h))
!   zbar=exp((1.0d0-alpha_h)*(log(deltah*(2.4d0*0.64d0+0.36d0*1.2d0)))-log(0.5d0)-alpha_h*log(alpha_h))
!   zbar=exp((1.0d0-alpha_h)*(log(deltah*(2.8d0*0.64d0+0.36d0*1.5d0)))-log(0.5d0)-alpha_h*log(alpha_h))
endif
adjust=0.25d0
!kappa=(1.0d0/deltah)*(0.5d0**alpha_h)/sqrt(2.4d0*0.64d0+0.36d0*1.2d0)
kappa=(1.0d0/deltah)*(0.7d0**alpha_h)/(2.4d0*0.64d0+0.36d0*1.2d0)**(adjust)
print*,'Kappa: ',kappa
!zbar=((3.0d0*deltah)**(1.0d0-alpha_h))/(0.375d0**alpha_h)

END SUBROUTINE SetParameters


c
c
c     ############################################################
c     ##  COPYRIGHT (C) 1995 by Yong Kong & Jay William Ponder  ##
c     ##                  All Rights Reserved                   ##
c     ############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine rotpole  --  rotate multipoles to global frame  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "rotpole" constructs the set of atomic multipoles in the global
c     frame by applying the correct rotation matrix for each site
c
c
      subroutine rotpole
      implicit none
      include 'sizes.i'
      include 'mpole.i'
      integer i
      real*8 a(3,3)
c
c
c     rotate the atomic multipoles at each site in turn
c
      do i = 1, npole
         call rotmat (i,a)
         call rotsite (i,a)
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine rotmat  --  find global frame rotation matrix  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "rotmat" finds the rotation matrix that converts from the local
c     coordinate system to the global frame at a multipole site
c
c
      subroutine rotmat (i,a)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'mpole.i'
      integer i,ii
      integer ix,iy,iz
      real*8 r,dot
      real*8 random
      real*8 xi,yi,zi
      real*8 dx,dy,dz
      real*8 dx1,dy1,dz1
      real*8 dx2,dy2,dz2
      real*8 dx3,dy3,dz3
      real*8 a(3,3)
c
c
c     get coordinates and frame definition for the multipole site
c
      ii = ipole(i)
      xi = x(ii)
      yi = y(ii)
      zi = z(ii)
      ix = xaxis(i)
      iy = yaxis(i)
      iz = zaxis(i)
c
c     use the identity matrix as the default rotation matrix
c
      a(1,1) = 1.0d0
      a(2,1) = 0.0d0
      a(3,1) = 0.0d0
      a(1,3) = 0.0d0
      a(2,3) = 0.0d0
      a(3,3) = 1.0d0
c
c     Z-Only method rotation matrix elements for z-axis only
c
      if (polaxe(i) .eq. 'Z-Only') then
         dx = x(iz) - xi
         dy = y(iz) - yi
         dz = z(iz) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,3) = dx / r
         a(2,3) = dy / r
         a(3,3) = dz / r
         dx = random ()
         dy = random ()
         dz = random ()
         dot = dx*a(1,3) + dy*a(2,3) + dz*a(3,3)
         dx = dx - dot*a(1,3)
         dy = dy - dot*a(2,3)
         dz = dz - dot*a(3,3)
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,1) = dx / r
         a(2,1) = dy / r
         a(3,1) = dz / r
c
c     Z-then-X method rotation matrix elements for z- and x-axes
c
      else if (polaxe(i) .eq. 'Z-then-X') then
         dx = x(iz) - xi
         dy = y(iz) - yi
         dz = z(iz) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,3) = dx / r
         a(2,3) = dy / r
         a(3,3) = dz / r
         dx = x(ix) - xi
         dy = y(ix) - yi
         dz = z(ix) - zi
         dot = dx*a(1,3) + dy*a(2,3) + dz*a(3,3)
         dx = dx - dot*a(1,3)
         dy = dy - dot*a(2,3)
         dz = dz - dot*a(3,3)
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,1) = dx / r
         a(2,1) = dy / r
         a(3,1) = dz / r
c
c     Bisector method rotation matrix elements for z- and x-axes
c
      else if (polaxe(i) .eq. 'Bisector') then
         dx = x(iz) - xi
         dy = y(iz) - yi
         dz = z(iz) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx1 = dx / r
         dy1 = dy / r
         dz1 = dz / r
         dx = x(ix) - xi
         dy = y(ix) - yi
         dz = z(ix) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx2 = dx / r
         dy2 = dy / r
         dz2 = dz / r
         dx = dx1 + dx2
         dy = dy1 + dy2
         dz = dz1 + dz2
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,3) = dx / r
         a(2,3) = dy / r
         a(3,3) = dz / r
         dot = dx2*a(1,3) + dy2*a(2,3) + dz2*a(3,3)
         dx = dx2 - dot*a(1,3)
         dy = dy2 - dot*a(2,3)
         dz = dz2 - dot*a(3,3)
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,1) = dx / r
         a(2,1) = dy / r
         a(3,1) = dz / r
c
c     Z-Bisect method rotation matrix elements for z- and x-axes
c
      else if (polaxe(i) .eq. 'Z-Bisect') then
         dx = x(iz) - xi
         dy = y(iz) - yi
         dz = z(iz) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,3) = dx / r
         a(2,3) = dy / r
         a(3,3) = dz / r
         dx = x(ix) - xi
         dy = y(ix) - yi
         dz = z(ix) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx1 = dx / r
         dy1 = dy / r
         dz1 = dz / r
         dx = x(iy) - xi
         dy = y(iy) - yi
         dz = z(iy) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx2 = dx / r
         dy2 = dy / r
         dz2 = dz / r
         dx = dx1 + dx2
         dy = dy1 + dy2
         dz = dz1 + dz2
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx = dx / r
         dy = dy / r
         dz = dz / r
         dot = dx*a(1,3) + dy*a(2,3) + dz*a(3,3)
         dx = dx - dot*a(1,3)
         dy = dy - dot*a(2,3)
         dz = dz - dot*a(3,3)
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,1) = dx / r
         a(2,1) = dy / r
         a(3,1) = dz / r
c
c     3-Fold method rotation matrix elements for z- and x-axes
c
      else if (polaxe(i) .eq. '3-Fold') then
         dx = x(iz) - xi
         dy = y(iz) - yi
         dz = z(iz) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx1 = dx / r
         dy1 = dy / r
         dz1 = dz / r
         dx = x(ix) - xi
         dy = y(ix) - yi
         dz = z(ix) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx2 = dx / r
         dy2 = dy / r
         dz2 = dz / r
         dx = x(iy) - xi
         dy = y(iy) - yi
         dz = z(iy) - zi
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx3 = dx / r
         dy3 = dy / r
         dz3 = dz / r
         dx = dx1 + dx2 + dx3
         dy = dy1 + dy2 + dy3
         dz = dz1 + dz2 + dz3
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,3) = dx / r
         a(2,3) = dy / r
         a(3,3) = dz / r
         dot = dx2*a(1,3) + dy2*a(2,3) + dz2*a(3,3)
         dx = dx2 - dot*a(1,3)
         dy = dy2 - dot*a(2,3)
         dz = dz2 - dot*a(3,3)
         r = sqrt(dx*dx + dy*dy + dz*dz)
         a(1,1) = dx / r
         a(2,1) = dy / r
         a(3,1) = dz / r
      end if
c
c     finally, find rotation matrix elements for the y-axis
c
      a(1,2) = a(3,1)*a(2,3) - a(2,1)*a(3,3)
      a(2,2) = a(1,1)*a(3,3) - a(3,1)*a(1,3)
      a(3,2) = a(2,1)*a(1,3) - a(1,1)*a(2,3)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine rotsite  --  rotate multipoles at single site  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "rotsite" computes the atomic multipoles at a specified site
c     in the global coordinate frame by applying a rotation matrix
c
c
      subroutine rotsite (isite,a)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'mpole.i'
      integer i,j,k,m
      integer isite
      real*8 a(3,3)
      real*8 m2(3,3)
      real*8 r2(3,3)
c
c
c     monopoles have the same value in any coordinate frame
c
      rpole(1,isite) = pole(1,isite)
c
c     rotate the dipoles to the global coordinate frame
c
      do i = 2, 4
         rpole(i,isite) = 0.0d0
         do j = 2, 4
            rpole(i,isite) = rpole(i,isite) + pole(j,isite)*a(i-1,j-1)
         end do
      end do
c
c     rotate the quadrupoles to the global coordinate frame
c
      k = 5
      do i = 1, 3
         do j = 1, 3
            m2(i,j) = pole(k,isite)
            r2(i,j) = 0.0d0
            k = k + 1
         end do
      end do
      do i = 1, 3
         do j = 1, 3
            if (j .lt. i) then
               r2(i,j) = r2(j,i)
            else
               do k = 1, 3
                  do m = 1, 3
                     r2(i,j) = r2(i,j) + a(i,k)*a(j,m)*m2(k,m)
                  end do
               end do
            end if
         end do
      end do
      k = 5
      do i = 1, 3
         do j = 1, 3
            rpole(k,isite) = r2(i,j)
            k = k + 1
         end do
      end do
      return
      end


!*******************************************************************
!                                                                  *
      SUBROUTINE RUMTJJ(KNT,JJ,LQ,LV,L)
!                                                                  *
!   ---------------  SECTION SQJJ  SUBPROGRAM 16  --------------   *
!                                                                  *
!     NO SUBROUTINE CALLED                                         *
!                                                                  *
!   Written by  G. Gaigalas                                        *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE mtjj_C
      USE mtjj2_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE jthn_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN)  :: JJ, KNT
      INTEGER, INTENT(OUT) :: LQ, LV, L
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: KT, KNTMIN
!-----------------------------------------------

      IF(JJ < 9) THEN
        KT=MT(KNT)
      ELSE IF(JJ == 9) THEN
        IF(KNT > 300) THEN
          KNTMIN=KNT-300
          KT=MT9(KNTMIN)
        ELSE
          PRINT*, "ERROR in RUMTJJ"
          STOP
!GG          CALL RUMT67(KNT,NR,LQ,LS,L)
!GG          RETURN
        ENDIF
      ELSE
        KT=MT11(KNT)
      ENDIF
      LQ=JTHN(KT,3,100)
      LV=JTHN(KT,2,100)
      L=JTHN(KT,1,100)
      RETURN
      END SUBROUTINE RUMTJJ


      subroutine  heatloc
!***********************************************************************
! Copyright 2014. Los Alamos National Security, LLC.  This material was
! produced under U.S. Government contract DE-AC52-06NA25396 for Los
! Alamos National Laboratory (LANL), which is operated by Los Alamos
! National Security, LLC for the U.S. Department of Energy. The U.S.
! Government has rights to use, reproduce, and distribute this software.
! Neither the U.S. Government nor Los Alamos National Security, LLC or
! persons acting on their behalf, make any warranty, express or implied,
! or assumes any liability for the accuracy, completeness, or usefulness
! of the software, any information pertaining to the software, or
! represents that its use would not infringe privately owned rights.
!
! The software being licensed may be Export Controlled.   It may not be
! distributed or used by individuals or entities prohibited from having
! access to the software package, pursuant to United States export
! control laws and regulations.  An export control review and
! determination must be completed before LANS will provide access to the
! identified Software.
!***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  This subroutine calculates heat fluxes.
CD1   patterned after veloc.f
CD1 currently (7/7/14) doing liquid water oinly, single porosity only
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2
CD2 7-July-2014 S. Kelkar
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  Not Applicable.  See Special Comments.
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4  This is a general utility routine used in the code as needed.
CD4
C***********************************************************************

      use comai
      use combi
      use comci
      use comdi
      use comji
      use comflow
      use comdti
      use davidi
      implicit none

      integer i, ij, iq, jj, kb, neqp1, iwd, iw_max
      real*8 adv_x_out,adv_y_out,adv_z_out
      real*8 cond_x_out,cond_y_out,cond_z_out
      real*8 e_cond, e_adv
      real*8 e_cond_area, e_adv_area
      real*8 area_t, dis
      real*8 fid, fid1
      real*8 vld_in, vld_out
      real(8) :: vld = 0., vvd = 0.
      real*8 xdis_cos, ydis_cos, zdis_cos
      real*8 tol, dis_tol
      parameter(iw_max = 10000000)
      parameter(tol=1.d-30, dis_tol=1.d-20)
c gaz 11-09-2001 added dis_tol so a velocity can be calculated at
c coincident mdnode nodes

c ************
c     return for anisotropy
c
      if(ianpe.ne.0) return
c
      vlmax  =  0.0
      neqp1  =  neq+1

c     TAKE CARE OF NODES 1 TO NEQ (ONLY FRACTURES FOR DPDP)
      do i=1,neq
c     zero out heat fluxes
         adv_x_out = 0.
         adv_y_out = 0.
         adv_z_out = 0.
         cond_x_out = 0.
         cond_y_out = 0.
         cond_z_out = 0.
c     calculate lower diagonal geometric coefficient
c     gaz 1-25-03 used abs(iw)
         iq=0
         do ij=nelm(i)+1,nelmdg(i)-1
            kb=nelm(ij)
            do jj=nelmdg(kb)+1,nelm(kb+1)
               if(nelm(jj).eq.i) then
                  iq=iq+1
                  it9(iq)=ij
                  it10(iq)=istrw(jj-neqp1)
                  iw=abs(it10(iq))
                  if (sx(iw,isox)+sx(iw,isoy)+
     &                 sx(iw,isoz) .eq.0.) iq=iq-1
               endif
            enddo
         enddo
         do jj=nelmdg(i)+1,nelm(i+1)
            iq=iq+1
            it9(iq)=jj
            it10(iq)=istrw(jj-neqp1)
            iw=abs(it10(iq))
            if(iw.eq.0.or.iw.gt.iw_max)then
               iq=iq-1
            else
               if (sx(iw,isox)+sx(iw,isoy)+
     &              sx(iw,isoz) .eq.0.) iq=iq-1
            endif
         enddo
         do ij=1,iq
            jj=it9(ij)
            kb=nelm(jj)
            iwd=it10(ij)
            iw = abs(iwd)
c     use internode fluxes already stored
c     s kelkar 7/7/14 for heat flux
            if (idoff .ne. -1) e_adv  = e_axy_adv(jj-neqp1)
            e_cond = e_axy_cond(jj-neqp1)
c................

c     outgoing advective heat flux
            if(e_adv.lt.0.0) then
               if(icnl.ne.0) then
                  dis=sqrt((cord(i,1)-cord(kb,1))**2
     &                 + (cord(i,2)-cord(kb,2))**2)+dis_tol
                  area_t=-(sx(iw,isox)+sx(iw,isoy))*dis
     &                 *0.5*(cord(i,3)+cord(kb,3))
                  if(iwd.lt.0) area_t=area_t*sx_mult
                  area_t=area_t+tol
                  e_adv_area = e_adv/area_t
                  xdis_cos=(cord(kb,1)-cord(i,1))/dis
                  ydis_cos=(cord(kb,2)-cord(i,2))/dis
                  adv_x_out=adv_x_out+xdis_cos*e_adv_area
                  adv_y_out=adv_y_out+ydis_cos*e_adv_area
               else
                  dis=sqrt((cord(i,1)-cord(kb,1))**2
     &                 + (cord(i,2)-cord(kb,2))**2
     &                 + (cord(i,3)-cord(kb,3))**2)+dis_tol
                  area_t=-(sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz))*dis
                  if(iwd.lt.0) area_t=area_t*sx_mult
                  area_t=area_t+tol
                  e_adv_area = e_adv/area_t
                  xdis_cos=(cord(kb,1)-cord(i,1))/dis
                  ydis_cos=(cord(kb,2)-cord(i,2))/dis
                  zdis_cos=(cord(kb,3)-cord(i,3))/dis
                  adv_x_out=adv_x_out+xdis_cos*e_adv_area
                  adv_y_out=adv_y_out+ydis_cos*e_adv_area
                  adv_z_out=adv_z_out+zdis_cos*e_adv_area
               endif
            endif
c     outgoing conductive heat flux
            if(e_cond.lt.0.0) then
               if(icnl.ne.0) then
                  dis=sqrt((cord(i,1)-cord(kb,1))**2
     &                 + (cord(i,2)-cord(kb,2))**2)+dis_tol
                  area_t=-(sx(iw,isox)+sx(iw,isoy))*dis
     &                 *0.5*(cord(i,3)+cord(kb,3))
                  if(iwd.lt.0) area_t=area_t*sx_mult
                  area_t=area_t+tol
                  e_cond_area = e_cond/area_t
                  xdis_cos=(cord(kb,1)-cord(i,1))/dis
                  ydis_cos=(cord(kb,2)-cord(i,2))/dis
                  cond_x_out=cond_x_out+xdis_cos*e_cond_area
                  cond_y_out=cond_y_out+ydis_cos*e_cond_area
               else
                  dis=sqrt((cord(i,1)-cord(kb,1))**2
     &                 + (cord(i,2)-cord(kb,2))**2
     &                 + (cord(i,3)-cord(kb,3))**2)+dis_tol
                  area_t=-(sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz))*dis
                  if(iwd.lt.0) area_t=area_t*sx_mult
                  area_t=area_t+tol
                  e_cond_area = e_cond/area_t
                  xdis_cos=(cord(kb,1)-cord(i,1))/dis
                  ydis_cos=(cord(kb,2)-cord(i,2))/dis
                  zdis_cos=(cord(kb,3)-cord(i,3))/dis
                  cond_x_out=cond_x_out+xdis_cos*e_cond_area
                  cond_y_out=cond_y_out+ydis_cos*e_cond_area
                  cond_z_out=cond_z_out+zdis_cos*e_cond_area
               endif
            endif
         enddo
c
         if (idoff .ne. -1) then
            e_adv_nodal(i,1) = adv_x_out
            e_adv_nodal(i,2) = adv_y_out
            e_adv_nodal(i,3) = adv_z_out
         end if
         e_cond_nodal(i,1) = cond_x_out
         e_cond_nodal(i,2) = cond_y_out
         e_cond_nodal(i,3) = cond_z_out

      enddo

      return
      end subroutine heatloc


!===========================================================================
!  This code uses LAPACK ROUTINES
!
!  LAPACK copyright statements and license
!
!Copyright (c) 1992-2013 The University of Tennessee and The University
!                        of Tennessee Research Foundation.  All rights
!                        reserved.
!Copyright (c) 2000-2013 The University of California Berkeley. All
!                        rights reserved.
!Copyright (c) 2006-2013 The University of Colorado Denver.  All rights
!                        reserved.

!Additional copyrights may follow

!Redistribution and use in source and binary forms, with or without
!modification, are permitted provided that the following conditions are
!met:
!
!- Redistributions of source code must retain the above copyright
!  notice, this list of conditions and the following disclaimer.
!
!- Redistributions in binary form must reproduce the above copyright
!  notice, this list of conditions and the following disclaimer listed
!  in this license in the documentation and/or other materials
!  provided with the distribution.
!
!- Neither the name of the copyright holders nor the names of its
!  contributors may be used to endorse or promote products derived from
!  this software without specific prior written permission.
!
!The copyright holders provide no reassurances that the source code
!provided does not infringe any patent, copyright, or any other
!intellectual property rights of third parties.  The copyright holders
!disclaim any liability to any recipient for claims brought against
!recipient by any third party for infringement of that parties
!intellectual property rights.
!
!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
!OWNER 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.
!===== END OF LACK COPYRIGHT STATEMENT ========================

! for preconditioning of Lanczos pivot via self-consistent mean-field
! added Dec 2011 CWJ @ 2011
! NOTE: preconditioning removed in 7.5.5
!       restored in 7.7.2, as potentially part of LOBPCG
!
module shampoo
  use precisions
  implicit none
  logical, parameter :: ask_precondition = .true.
  logical :: precondition
  logical :: fasth     ! does only part of the Hamiltonian
  integer :: nprecond    ! # of preconditioning iterations
  real, parameter :: betamin = 1.0e-4    ! minimum size for beta; stop if this is reached

!..... SOME TEMPORARY ARRAYS FOR LANCZOS..... in 7.7.6...
!  eventually these should be replaced by the structures and routines in breorthog.f90
!  However I cannot seem to make those work

  real(kind=lanc_prec), allocatable :: templancvecs(:,:)

contains
!
      subroutine makepnHFpot

      use verbosity
      use spstate
      use sporbit
      use haiku_info
      use system_parameters
      use interaction
      use coupledmatrixelements
      use nodeinfo
      use ntuple_info
      use onebodypot
      use densities
      use butil_mod

      implicit none

      integer dpair,cpair
      integer Jtot,jmin,jmax
      integer T
      integer M
      integer par
      integer ik,il
      integer ii,ij

      integer i,j,k,l
      integer ith,jth,kth,lth
      integer isps,jsps,ksps,lsps
      integer itr,jtr,ktr,ltr

      integer nk,nl,ni,nj
      integer jk,jl,ji,jj
      integer mk,ml,mi,mj

      integer iref,istart
      integer itbme,itbmetr
      integer a,b,c,d
      integer ia,ib,ic,id
      integer pair1,pair2
      integer pair11,pair22
      integer ppar,pcref,pcstart
      integer phasekl,phaseij

      integer indx
      integer itmp
      real vtmp

      !! function in btbme_mod:  real zeta   ! zeta(i,j) = sqrt(1+delta(i,j))
      real cleb
      logical first
      integer nsection
      integer ipair,pairstart
      integer cindx,dindx  ! creation/destruction indices
      integer gi,gj,gk,gl ! group indices
      integer n0,n0j,n0k,nsumk
      integer kmin,kmax

      n0 = 0
      n0j = 0
      n0k = 0
      nsumk = 0
      if(Np(1)*Np(2) < 1)return

      vmatpn => hmatpn

	  ! initialize to prevent compiler warnings
      m = -9999
      par = 0
      nsection = 0
      pairstart = -1

      do dpair = 1,npairpn       ! loop over destruction pairs
!---------- FIND OUT IF THERE IS A CHANGE IN M OR PARITY
        if(par /= PN2%pair(dpair)%par .or. m /= PN2%pair(dpair)%m)then

!------------- ADD TO TOTAL THOSE FROM LAST TIME

!---------IF SO, THEN COUNT UP HOW MANY HAVE THE SAME M, PARITY
          m = PN2%pair(dpair)%m
          par = PN2%pair(dpair)%par
          pairstart = dpair

          do ipair = dpair,npairpn  ! loop upwards until M, PARITY change
                                      ! pairs have previously been sorted
             if(par == PN2%pair(ipair)%par .and. m == PN2%pair(ipair)%m)then
!------------ NSECTION IS HOW MANY PAIRS HAVE SAME M, PARITY
                nsection = ipair -dpair+1
             else
                exit
             endif
          enddo
          pairstart = dpair
          do ipair = dpair,1,-1  ! loop downwards until M, PARITY change
                                      ! pairs have previously been sorted
             if(par == PN2%pair(ipair)%par .and. m == PN2%pair(ipair)%m)then
!------------ NSECTION IS HOW MANY PAIRS HAVE SAME M, PARITY
                pairstart = ipair
             else
                exit
             endif
          enddo

        endif

!---------------- FROM NOW ON, UNCOUPLING -------------------------

!-------------- EXTRACT QUANTUM NUMBERS OF DESTRUCTION PAIR--------
        k = PN2%pair(dpair)%ia
        l = PN2%pair(dpair)%ib
        if( k < 0)then
          ksps = -k
          kth = -1
        else
          ksps = k
          kth  = 1
        endif
        ia = hspsqn(kth,ksps)%orb
        jk = hspsqn(kth,ksps)%j
        mk = hspsqn(kth,ksps)%m
        gk = hspsqn(kth,ksps)%group

        if( l < 0)then
          lsps = -l
          lth = -2
        else
          lsps = l
          lth  = 2
        endif
        ib = hspsqn(lth,lsps)%orb
        jl = hspsqn(lth,lsps)%j
        ml = hspsqn(lth,lsps)%m
        gl = hspsqn(lth,lsps)%group
        phasekl = 1

!-------------- FIND INDEX "PAIR1" used to find coupled tbme

        pair1 = numorb(2)*(ia-1)+ib
        pair1 = PNcouplemap(pair1)
        if(pair1 == -1)then
            print*,' uh problem pn map boss 1 '
            stop
        endif

!----------------- LOOP OVER CREATION PAIRS--------------
        cindx = 0
        do cpair = pairstart,pairstart+nsection-1

!-------------- EXTRACT QUANTUM NUMBERS OF CREATION PAIR--------

           i = PN2%pair(cpair)%ia
           j = PN2%pair(cpair)%ib

           if( i < 0)then
             isps = -i
             ith = -1
           else
             isps = i
             ith  = 1
           endif
           ic = hspsqn(ith,isps)%orb
           ji = hspsqn(ith,isps)%j
           mi = hspsqn(ith,isps)%m
           gi = hspsqn(ith,isps)%group
          if( j < 0)then
             jsps = -j
            jth = -2
          else
            jsps = j
            jth  = 2
          endif
          id = hspsqn(jth,jsps)%orb
          jj = hspsqn(jth,jsps)%j
          mj = hspsqn(jth,jsps)%m
          gj = hspsqn(jth,jsps)%group

!------------- PUT INTO "STANDARD" ORDER; MAY GET PHASE -------

          phaseij = 1

          pair2 = numorb(2)*(ic-1)+id
          pair2 = PNcouplemap(pair2)
          if(pair2==-1)then
           print*,' oh boy should not have gotten that '
           stop
          endif

!-------------- ALSO MUST HAVE STANDARD ORDERING OF PAIRS -----------

          if(pair1 < pair2)then
            pair11 = pair2
            pair22 = pair1
          else
           pair11 = pair1
           pair22 = pair2
          endif

          ppar = PNcouples%pairc(pair1)%par
          pcref = PNcouples%meref(ppar)
          pcstart = PNcouples%mestart(ppar)

          indx = (pair11-pcref)*(pair11-pcref-1)/2+pair22-pcref +pcstart
          if(indx <= 0)then
             print*,' problem indx ',indx,pair11,pair22
             print*,ia,ib,ic,id
             print*,cpair,dpair
             stop
          endif

!-------------FIND JMIN,JMAX ALLOWED ----------------

          jmax = MIN( jk+jl,ji+jj) /2
          jmin = MAX( abs(jk-jl),abs(ji-jj))/2
          jmin = MAX(jmin,abs(m))

!-------------NOW EXTRACT FROM TBMEs ---------------
!-------      NOTE FACTOR ZETA = SQRT(1+DELTA(A,B)) INCLUDED
          vtmp = 0.

          do jtot = jmin,jmax
                vtmp = vtmp+ pnme(indx)%v(jtot) &
              * cleb(jk,mk,jl,ml,2*jtot,mk+ml)*cleb(ji,mi,jj,mj,2*jtot,mi+mj)
          enddo    ! jtot
!          print*, i,k,' ... ',j,l
          ppot_h(i,k) = ppot_h(i,k) + vtmp*n1bopme(j,l)
          npot_h(j,l) = npot_h(j,l) + vtmp*p1bopme(i,k)

        enddo  ! loop over cpair

      enddo  ! loop over dpair

      return
      end subroutine makepnHFpot

!==========================================================
!
!      subroutine uncoupleXXtbme
!
!  uncouples the T =1 matrix elements for pp, nn
!  includes the factor zeta = sqrt(1+delta(a,b)) etc.
!
!  IMPORTANT: How pp/nn matrix elements are encoded;
!  needed for setting up the operator arrays for
!  two-body "jumps"
!
!  INPUT:
!   it = species, 1 = proton, 2 = neutrons

!
      subroutine makeXXHFpot(it)

      use verbosity
      use spstate
      use haiku_info
      use system_parameters
      use interaction
      use coupledmatrixelements
      use onebodypot
      use densities
      use butil_mod
      use btbme_mod

      implicit none
      integer it      ! which species

      integer(kind=8) :: dpair,cpair
      integer Jtot,jmin,jmax
      integer T
      integer M
      integer par
      integer ik,il
      integer ii,ij

      integer i,j,k,l
      integer ith,jth,kth,lth
      integer isps,jsps,ksps,lsps

      integer nk,nl,ni,nj
      integer jk,jl,ji,jj
      integer mk,ml,mi,mj

      integer(kind=8) :: iref,istart
      integer(kind=8) :: itbme

      integer ia,ib,ic,id
      integer(kind=8) :: pair1,pair2
      integer(kind=8) :: pair11,pair22
      integer phasekl,phaseij

      integer(kind=8) :: indx
      integer itmp
      real vtmp

      ! function in module btbme_mod:   real zeta   ! zeta(i,j) = sqrt(1+delta(i,j))
      real cleb
      real hfactor  ! FOR HERMICIITY
      real,pointer :: v(:)

      type (vjs), pointer :: tbme(:)
      integer pcref, pcstart, ppar
      integer,pointer :: xxmap(:)

      if(Np(it) < 2)return

      if(it == 1)then
        tbme => ppme
        xxmap => ppcouplemap

      else
        tbme =>   nnme
        xxmap => nncouplemap

      endif

      T = 1        ! for pp, nn matrix elements

      do dpair = 1,npairXX(it)        ! loop over destruction pair

        m = XX2(it)%pair(dpair)%m     ! find Jz, parity of pair
        par = XX2(it)%pair(dpair)%par

        iref = XX2(it)%meref(m,par)      ! iref, istart used to encode index for
        istart = XX2(it)%mestart(m,par)  ! the uncoupled matrix element

        if(iref > dpair)then
          print*,' problem with XX iref (d) ',it
          print*,dpair,iref
          print*,m,par
          print*,xx2(it)%mestart(:,1)
          stop
        endif

!---------------------- GET Q#s FOR PARTICLES IN DESTRUCTION PAIR --------
        k = XX2(it)%pair(dpair)%ia
        l = XX2(it)%pair(dpair)%ib
        if( k < 0)then
          ksps = -k
          kth = -it
        else
          ksps = k
          kth  = it
        endif
        ia = hspsqn(kth,ksps)%orb
        jk = hspsqn(kth,ksps)%j
        mk = hspsqn(kth,ksps)%m

        if( l < 0)then
          lsps = -l
          lth = -it
        else
          lsps = l
          lth  = it
        endif
        ib = hspsqn(lth,lsps)%orb
        jl = hspsqn(lth,lsps)%j
        ml = hspsqn(lth,lsps)%m

        phasekl = 1
!-------------- MUST HAVE ia > ib, else swap and pick up a phase ---

        if(ia < ib)then
             itmp = ia
             ia = ib
             ib = itmp

             itmp = jk
             jk = jl
             jl = itmp

             itmp = mk
             mk   = ml
             ml   = itmp

             phasekl = -1  ! the rest of the phase comes from the Clebsch Gordan

        endif

        do cpair = 1,dpair !,npairXX(it)        ! loop over creation pair
          if(cpair == dpair)then
              hfactor = 1.0  ! 0.5  I don't think I am using Hermiticity here
          else
              hfactor = 1.0
          endif
          if(XX2(it)%pair(cpair)%m /=m)cycle       ! enforce quantum numbers
          if(XX2(it)%pair(cpair)%par /= par)cycle

          if(iref > cpair)then
            print*,' problem with XX iref (c) '
            print*,cpair,iref
            stop
          endif

!--------------- GET Q#s FOR CREATION PAIRS ---------------

          i = XX2(it)%pair(cpair)%ia
          j = XX2(it)%pair(cpair)%ib

          if( i < 0)then
            isps = -i
            ith = -it
          else
            isps = i
            ith  = it
          endif
          ic = hspsqn(ith,isps)%orb
          ji = hspsqn(ith,isps)%j
          mi = hspsqn(ith,isps)%m

          if( j < 0)then
            jsps = -j
            jth = -it
          else
            jsps = j
            jth  = it
          endif
          id = hspsqn(jth,jsps)%orb
          jj = hspsqn(jth,jsps)%j
          mj = hspsqn(jth,jsps)%m
!------------- PUT INTO "STANDARD" ORDER; MAY GET PHASE -------

          phaseij = 1

          if(ic < id) then

             itmp = ic
             ic = id
             id = itmp

             itmp = ji
             ji = jj
             jj = itmp
             itmp = mi
             mi   = mj
             mj   = itmp

             phaseij = -1  ! the rest of the phase comes from the Clebsch Gordan

          endif
          pair1 = ia*(ia-1)/2 + ib  ! used to find index of coupled TBME

          pair2 = ic*(ic-1)/2 + id

!-------------- ALSO MUST HAVE STANDARD ORDERING OF PAIRS -----------

          pair1 = xxmap(pair1)
          pair2 = xxmap(pair2)
          if(pair1==-1 .or. pair2 == -1)then
             print*,' hmm strange ...',it
             print*,pair1,pair2
             print*,ia,ib,ic,id
             stop
          endif
          ppar = XXcouples(it)%pairc(pair1)%par
          if(ppar /= XXcouples(it)%pairc(pair2)%par)then
              print*,' sigh parity problem '
              print*,ia,ib,ic,id,ppar,par
              print*,pair1,pair2
              stop
          endif
          if(pair1 < pair2)then
            pair11 = pair2
            pair22 = pair1
          else
           pair11 = pair1
           pair22 = pair2
          endif
          pcref = XXcouples(it)%meref(ppar)
          pcstart = XXcouples(it)%mestart(ppar)

          indx = (pair11-pcref)*(pair11-1-pcref)/2+pair22-pcref+pcstart
          if(indx <= 0)then
             print*,' problem indx ',indx
             stop
          endif

!-------------FIND JMIN,JMAX ALLOWED ----------------

          jmax = MIN( jk+jl,ji+jj) /2
          jmin = MAX( abs(jk-jl),abs(ji-jj))/2
          jmin = MAX(jmin,abs(m))

!-------------NOW EXTRACT FROM TBMEs ---------------
!-------      NOTE FACTOR ZETA = SQRT(1+DELTA(A,B)) INCLUDED
          vtmp = 0.

          do jtot = jmin,jmax

             vtmp = vtmp+ tbme(indx)%v(jtot) * zeta(ia,ib)*zeta(ic,id)   * &
                    cleb(jk,mk,jl,ml,2*jtot,2*m)*cleb(ji,mi,jj,mj,2*jtot,2*m)
          enddo

          if(it == 1)then
             ppot_h(i,k) = ppot_h(i,k) + vtmp*phasekl*phaseij*p1bopme(j,l)
             ppot_h(j,l) = ppot_h(j,l) + vtmp*phasekl*phaseij*p1bopme(i,k)

             if(cpair < dpair)then
                ppot_h(k,i) = ppot_h(k,i) + vtmp*phasekl*phaseij*p1bopme(l,j)
                ppot_h(l,j) = ppot_h(l,j) + vtmp*phasekl*phaseij*p1bopme(k,i)

             end if
          else
             npot_h(i,k) = npot_h(i,k) + vtmp*phasekl*phaseij*n1bopme(j,l)
             npot_h(j,l) = npot_h(j,l) + vtmp*phasekl*phaseij*n1bopme(i,k)

             if(cpair < dpair)then
                npot_h(k,i) = npot_h(k,i) + vtmp*phasekl*phaseij*n1bopme(l,j)
                npot_h(l,j) = npot_h(l,j) + vtmp*phasekl*phaseij*n1bopme(k,i)

             end if
          end if
        enddo  ! loop over cpair

      enddo  ! loop over dpair
!      if(it == 1)then
!        do i = -3,3
!          write(6,'(7f8.3)')(ppot_h(i,j),j=-3,3)
!        enddo
!      end if
      return
      end subroutine makeXXHFpot
!===================================================
subroutine makespHFpot(it)

!    use interaction
    use coupledmatrixelements

    use onebodypot
    use spstate
    use haiku_info
    use system_parameters

    implicit none
    integer it
    integer isps
    integer i
    integer ith
    integer iorb

    if(np(it) < 0)return

    do isps = -nhsps(-it), nhsps(it)
       if(isps == 0)cycle
       if( isps < 0)then
          i = -isps
          ith = -it
       else
          i = isps
          ith = it
       endif
       iorb = hspsqn(ith,i)%orb
       if(it == 1 )then
          pPOT_h(isps,isps) = pPOT_h(isps,isps) + pspe(iorb)
       else
          nPOT_h(isps,isps) = nPOT_h(isps,isps) + nspe(iorb)

       end if

    end do

    return
end subroutine makespHFpot
!===================================================
!
! sets up arrays for self-consistent mean-field
!

subroutine setup4MF
	use densities
	use onebodypot
	use haiku_info
	use spstate
	implicit none
	integer :: aerr

    allocate( p1bopme(-nhspsmax:nhspsmax, -nhspsmax:nhspsmax), stat=aerr )
    if(aerr /= 0) then
       call memerror("setupMF 1")
       stop 5
    end if
    allocate( n1bopme(-nhspsmax:nhspsmax, -nhspsmax:nhspsmax), stat=aerr )
    if(aerr /= 0) then
       call memerror("setupMF 2")
       stop 5
    end if
    allocate(pPOT_h(-nhsps(-1):nhsps(1), -nhsps(-1):nhsps(1)), stat=aerr)
    if(aerr /= 0) call memerror("setupMF 3")
    allocate(nPOT_h(-nhsps(-2):nhsps(2), -nhsps(-2):nhsps(2)), stat=aerr)
    if(aerr /= 0) call memerror("setupMF 4")

	return
end subroutine setup4MF
!===================================================
!  added 7.7.4
!
! routine to create and apply mean-field potential
!

subroutine make_MF
	use densities
	use onebodypot
	use mod_reorthog
	implicit none

!.......... COPY vec1 TO vec2 FOR COMPUTING DENSITY
     call br_load_vec2_from_vec1()
!..........	COMPUTE DENSITY...............
     call master_density1b_bundled

!...........COMPUTE ONE-BODY POTs...........
     pPOT_h(:,:) = 0.0
     nPOT_h(:,:) = 0.0

     call  makepnHFpot
     call  makexxHFpot(1)
     call  makexxHFpot(2)
     call  makespHFpot(1)
     call  makespHFpot(2)

!	 print*,' potential ',nPOT_h(:,:)

    return
end subroutine make_MF

!===================================================
!
!  MASTER subroutine for invoking self-consistent mean-field
!
subroutine scmf_master

	use nodeinfo
	use lanczos_info,only: nkeep
	use lanczos_util
	use bmpi_mod
	use basis, only : dimbasis
	use io
	use fragments
	use localvectors
	use wfn_mod
	use mod_reorthog

	implicit none
	integer :: nloops
	integer :: ierr
	real,allocatable  :: emf(:)
	integer :: ikeep

	logical :: write_out_vectors_special  !

	write_out_vectors_special = .false.

!.............. MENU....................................
    if(iproc==0)then
        print*,' '
        print*,' / ------------------------------------------------------------------------\ '
        print*,' |                                                                         | '
        print*,' |    SELFCONSISTENT MEAN-FIELD OPTIONS (choose one)                       | '
        print*,' |                                                                         | '
		print*,' |    (lf)  Default Lanczos iteration with mean-field potential (standard) | '
		print*,' |    (ex)  Full diagonalization of mean-field (testing only)              | '
        print*,' |                                                                         | '
        print*,' \ ------------------------------------------------------------------------/ '
        print*,' '
        read(5,'(a)')lanczchar

        select case (lanczchar)
		    case('ex','Ex','EX')
			lanczchar = 'ex'

			niter = dimbasis   ! not needed, but this initializes the (unused) variable to prevent warning flags

		    case default

			lanczchar = 'lf'

			print*,' Enter number of Lanczos iterations per selfconsistent loop, number of vectors to print out '
			read*,niter,nkeep

   	    end select

		print*,' Enter # of selfconsistent loops to use '
		read*,nloops

	end if
    call BMPI_BCAST(lanczchar,2,0,icomm,ierr)
    call BMPI_BCAST(niter,1,0,icomm,ierr)
    call BMPI_BCAST(nloops,1,0,icomm,ierr)

	call setup4MF
	call setup_for_lanczos
	allocate(emf(nkeep))
	if(lanczchar == 'ex')then
		call fulldiag_scmf(nloops,emf)
	else
		call lanczos_scmf(nloops,emf)
	end if

!........... WRITE OUT FINAL VECTOR TO A .WFN FILE.................
    call wfn_write_nkeep(nkeep) ! write number of vectors to wfn file

	if(write_out_vectors_special)then
		open(unit=37,file='SCMF_vectors.dat',status='unknown')
		write(37,*)dimbasis,nkeep

	end if

    if(writeout)then
		do ikeep = 1,nkeep

            call br_retrieve_hist(ikeep)
            call br_restore_vec1()
			call wfn_writeeigenvec(wfnfile,frag1, vec1,ikeep,emf(ikeep),0.0,0.0)
			write(6,*)vec1(1),vec1(dimbasis)
			if(write_out_vectors_special)then
				write(37,*)ikeep
				write(37,*)vec1
			end if

		 end do
	 end if
	if(write_out_vectors_special)close(37)

	return

end subroutine scmf_master
!===================================================
!
! modified Lanczos routine for Self-consistent Mean-Field
!
! In this routine:
!   niter = # of Lanczos applications on each loop
!   nloops= # of loops of diagonalization to apply
!

subroutine lanczos_scmf(nloops,emf)
	use nodeinfo
	use mod_reorthog
	use flagger
	use bvectorlib_mod
	use lanczos_util
	use localvectors
	use basis
	use flagger
	use lanczos_info,only:nkeep
	implicit none

	integer :: nloops,iloop
    integer(4) :: ierr

    integer(4) :: iter

    real(kind=8) :: da,db
    integer(4) :: i,j,k
    real(kind=8) :: dnorm, dnorm0
	integer :: aerr
    real(kind=egv_prec), allocatable :: h(:,:)
    real(kind=lanc_prec), allocatable :: vi(:), vf(:)
    real(kind=egv_prec), allocatable :: efull(:), u(:,:), work(:),fullvec(:,:)
	logical :: testham,testlanc,altlanc
	logical :: printham_at_end   ! flag to write SCMF to a file at the end
	integer :: info
	real :: emf(nkeep)
	testham = .false.
    testlanc = .false.
	printham_at_end = .false.
	if(testham)then

	    allocate(h(dimbasis,dimbasis), stat=aerr)
	    if(aerr /= 0) call memerror("fulldiag_scmf 1")

	    allocate( efull(dimbasis), work(dimbasis*3),fullvec(dimbasis,dimbasis), stat=aerr)
	    if(aerr /= 0) call memerror("fulldiag_scmf 2")
	end if

!-----------------------------------------------------------------
	if(.not.allocated(alpha)) allocate( alpha(niter),beta(niter), stat=aerr )

	if(aerr /= 0) then
	     call memerror("lanczos_scmf 1")
	     stop 5
    end if
	if(.not.allocated(e)) allocate( eiglvec(niter,niter),e(niter), stat=aerr )
	if(aerr /= 0) then
	     call memerror("lanczos_scmf 1")
	     stop 5
	end if
!.............. FOR TESTING........
	if(altlanc)then
	   allocate (templancvecs(dimbasis,niter+1))
	   call pushvec1(1)
	   call normalizetemp(1,da)
    end if
!.........................

	if(.not.UseNewReorthog)then
		if(iproc==0)print*,' Not using new reorthog? Something wrong '
		stop

	end if
    call br_grab_vec1()          ! pushes vec1 to br_reg
    call br_normalize(dnorm0)    ! normalizes br_reg
    call br_restore_vec1()       ! pulls (normalized) vec1 from br_reg
    call br_add2hist(1)         ! adds br_reg to history at position 1
	call make_MF

	do iloop = 1,nloops

		call make_MF
!	    call br_normalize(dnorm0)
!		print*,' initial norm ',dnorm0,br_histpos

  	    alpha = 0.0
  	    beta  = 0.0
!............ MORE TESTING....................
		if (testham)then
		    do i = 1, dimbasis
		       vec1(:) = 0.d0
		       vec1(i) = 1.d0
		       vec2(:) = 0.d0
		       if(useVec2Thread) vec2threadflat(:) = 0.0
			   call master_apply1bop
		       do j = 1,dimbasis
		          h(i,j) = real(vec2(j),kind(egv_prec))   ! store as real(4); this can be changed

		       end do  !J
		   end do
		end if
!.............................
		do iter = 1,niter

!.............. TESTING.................
            if(altlanc)then
			   call normalizetemp(iter,db)   ! this seems to be necessary... but why?
			   call pullvec1(iter)
		    end if
!................................

			call initialize_final('n')  ! prepares vec2

			call master_apply1bop  ! H vec1 = vec2

!.............. TESTING.................
			if(altlanc)then
  			   call pushvec2(iter+1)
			   call orthofoot(iter+1,iter,da)
!			print*,iloop,iter,' alpha = ',da ,', norm = ',db
			   if(iter > 1)then
			      do j = iter-1,1,-1
			 	     call orthofoot(iter+1,j,db)
!				write(99,*)iloop,iter+1,j,db
			      end do
   		       end if
			   db = 0.0
			   call normalizetemp(iter+1,db)
		    end if
!..................
		    call br_grab_vec2()   ! pushes vec2 to br_reg
!	        if(alpha_before_orthog) ASSUME THIS
	        call br_remove_prev_overlap(da)   ! projects br_reg against previous in history
	        call br_orthogonalize(1) ! 1 says ignore last history entry (prev)
	        call br_normalize(db)   ! normalize br_reg

	        alpha(iter) = real(da,kind(0.0e0))
	        beta(iter) = real(db, kind(0.0e0))

!..................... TESTING.........
			if(altlanc)call normalizetemp(iter+1,db)

!			write(98,*)iloop,iter,alpha(iter),beta(iter)

!			print*,' alpha beta ',iter, alpha(iter),beta(iter)

!............. IMPORTANT .... TEST FOR RANDOM RESTART................

            if(beta(iter) < restart_tol*5 .and. iter < niter)then
					if(iproc==0)print*,iter, ' restarting, beta = ',beta(iter)
					beta(iter)=0.0
					call random_restart_with_history

			end if
	        ! Finally, add br_reg to history
	        if(iter < niter)then
				 call br_add2hist(iter+1)	! stores br_reg in history as iter+1
	 	        ! Restore back to vec1 for next iteration
	 	        ! This is instead of swap_vchar in older code

	 	        call br_restore_vec1()    ! pulls vec1 from br_reg
			end if

		end do  ! iter

!........ TEST BY CHECKING ORTHONORMALITY....
!print*,' testing orthonormality ',niter
!do iter = 1,niter

!	call br_retrieve_hist(iter)
!    call br_normalize(db)
!	print*,iter,db
!end do
!	call br_restore_vec1()
 !   print*,vec1(1)
!	do j = 1,iter
!		call br_retrieve_hist(j)

!		call br_restore_vec2()
!		dnorm = 0.0
!		do i = 1,dimbasis
!			dnorm = dnorm+vec1(i)*vec2(i)
!		end do
!		print*,iter,j,dnorm
!	end do

!end do
!......... TEST BY CREATING ENTIRE HAMILTONIAN........

if (testham)then
    do i = 1, dimbasis
       vec1(:) = 0.d0
       vec1(i) = 1.d0
       vec2(:) = 0.d0
       if(useVec2Thread) vec2threadflat(:) = 0.0
	   call master_apply1bop
	 !         if(nproc > 1) then
           ! leaves data only on isfragroot nodes
           ! In normal use, would move to vector space (breorthog.f90)
           ! need to broadcast
              ! output in vec2 with input 'n'
!              call BMPI_BCAST(vec2, size(vec2), 0, fcomm2, ierr)
!       end if
       do j = 1,dimbasis
          h(i,j) = real(vec2(j),kind(egv_prec))   ! store as real(4); this can be changed

       end do  !J
   end do

end if

if(testlanc)then
	print*,'testing'
	do i =1,iter
		call pullvec1(i)
		call pullvec2(i+1)
		da = 0.d0
		db = 0.d0
		do j = 1,dimbasis

			do k = 1,dimbasis
				da = da + vec1(j)*h(j,k)*vec1(k)
				db = db + vec1(j)*h(j,k)*vec2(k)

			end do

		end do
		write(99,*)i,alpha(i),da,beta(i),db

	end do

end if
!------------------- RESTART WITH INITIAL VECTOR-----------
!  invoke thick-restart routine to accomplish this
!
!print*,'alphas ',alpha(1),alpha(2),alpha(3),alpha(4)

        call find_lanczos_eigenvalues(niter,.true.,0)
		do i = 1,nkeep
		   emf(i) = e(i)
	    end do
        if(iproc==0)print*,iloop,' lanczos ', e(1)

		if(testham)then
           call DSYEV( 'V','U', dimbasis, h, dimbasis, efull, WORK, 3*dimbasis, INFO )
           if(iproc==0)print*,'exact 2', efull(1),efull(2),efull(3),efull(4),efull(5),efull(6),efull(7),efull(8)
	    end if
        dnorm = 0.d0

		if(altlanc)then
		   call constructvec1
		   call pushvec1(1)
	    endif
	    if(iloop==nloops)then
	        call br_transform_basis(eiglvec,nkeep, niter)    ! only transform initial vector

		else
           call br_transform_basis(eiglvec, 1, niter)    ! only transform initial vector
           call br_retrieve_hist(1)

		   call br_normalize(dnorm0)

        ! init for next iteration.
        ! load vec1 from the top of the history.
!        call br_retrieve_hist(1)

	       call br_restore_vec1()
		   call br_set_histpos(0)
           call br_add2hist(1) ! br_retrieve_hist left in br_reg, put at new head
	   endif

	end do ! iloop
!............... ONLY FOR WRITING OUT SCMF.............
	if(printham_at_end)then
		open(unit=48,file='scmf.dat',status='unknown')
		print*,' opened file scmf.dat '
		write(48,*)dimbasis
	    do i = 1, dimbasis
	       vec1(:) = 0.d0
	       vec1(i) = 1.d0
	       vec2(:) = 0.d0
	       if(useVec2Thread) vec2threadflat(:) = 0.0
		   call master_apply1bop
		 !         if(nproc > 1) then
	           ! leaves data only on isfragroot nodes
	           ! In normal use, would move to vector space (breorthog.f90)
	           ! need to broadcast
	              ! output in vec2 with input 'n'
	!              call BMPI_BCAST(vec2, size(vec2), 0, fcomm2, ierr)
	!       end if

	       do j = 1,i
			   if(vec2(j) /= 0.d0)write(48,*)i,j,vec2(j)
	       end do  !J
	   end do

		close(48)
		print*,' finished writing scmf.dat '

	end if

	return
end subroutine lanczos_scmf

!------------------ SUBROUTINES FOR TESTING LANCZOS-----------
!                  TO BE ELIMINATED IN LATER VERSIONS

subroutine pushvec1(pos)
	use precisions
	use basis,only: dimbasis
	use localvectors

	implicit none

	integer(kind=basis_prec) :: i
	integer pos

	do i = 1,dimbasis
		templancvecs(i,pos)=vec1(i)
	end do
	return

end subroutine pushvec1
!===================================================
subroutine pushvec2(pos)
	use precisions
	use basis,only: dimbasis
	use localvectors

	implicit none

	integer(kind=basis_prec) :: i
	integer pos

	do i = 1,dimbasis
		templancvecs(i,pos)=vec2(i)
	end do
	return

end subroutine pushvec2
!===================================================
subroutine pullvec1(pos)
	use precisions
	use basis,only: dimbasis
	use localvectors

	implicit none

	integer(kind=basis_prec) :: i
	integer pos

	do i = 1,dimbasis
		vec1(i)=templancvecs(i,pos)
	end do
	return

end subroutine pullvec1
!===================================================
subroutine pullvec2(pos)
	use precisions
	use basis,only: dimbasis
	use localvectors

	implicit none

	integer(kind=basis_prec) :: i
	integer pos

	do i = 1,dimbasis
		vec2(i) = templancvecs(i,pos)
	end do
	return

end subroutine pullvec2

!===================================================
subroutine normalizetemp(pos,dnorm)
	use precisions
	use basis,only: dimbasis
	implicit none

	integer(kind=basis_prec) :: i
	integer pos
	real(8) :: dnorm,scale

	dnorm = 0.d0

	do i = 1,dimbasis
		dnorm = dnorm + templancvecs(i,pos)**2

	end do
	dnorm = sqrt(dnorm)
	scale = 1.d0/dnorm

	do i = 1,dimbasis
		templancvecs(i,pos)=templancvecs(i,pos)*scale
	end do

	return
end subroutine normalizetemp

!===================================================
subroutine orthofoot(pos1,pos2,dnorm)
	use precisions
	use basis,only: dimbasis
	implicit none

	integer(kind=basis_prec) :: i
	integer pos1,pos2
	real(8) :: dnorm,scale

	dnorm = 0.d0
!	print*,' dot of ',pos1,pos2
	do i = 1,dimbasis
		dnorm = dnorm + templancvecs(i,pos1)*templancvecs(i,pos2)
!		print*,i,templancvecs(i,pos1),templancvecs(i,pos2)

	end do

	do i = 1,dimbasis
		templancvecs(i,pos1)=templancvecs(i,pos1)-dnorm*templancvecs(i,pos2)
	end do

	return
end subroutine orthofoot

!===================================================
subroutine constructvec1
	use precisions
	use basis,only: dimbasis
	use lanczos_util
	use localvectors
	implicit none
	integer(kind=basis_prec) :: i
	real(8) :: dtmp
	integer :: pos
	do i = 1,dimbasis
		dtmp = 0.d0
		do pos = 1,niter
			dtmp = dtmp + templancvecs(i,pos)*eiglvec(pos,1)

		end do
		vec1(i)=real(dtmp,kind=lanc_prec)

	end do
	return

end subroutine constructvec1
!===================================================
subroutine ersatz_random_restart(pos)

	use precisions
	use basis,only: dimbasis
	use lanczos_util
	use localvectors
	implicit none
	integer(kind=basis_prec) :: i
	real :: rtmp,scale

	integer :: pos

	call random_seed

    scale = 1.0/sqrt(real(dimbasis))
	do i = 1,dimbasis
		call random_number(rtmp)
		vec1(i)=(rtmp-0.5)*scale
	end do

	return
end subroutine ersatz_random_restart

!===================================================

!
!  FOR TESTING ONLY
!
!  version of SCMF with full diagonalization
!
subroutine fulldiag_scmf(nloops,emf)
	use nodeinfo
	use precisions
	use basis, only : dimbasis
	use localvectors
	use bmpi_mod
	use apply_ham
	use lanczos_info,only:nkeep

	implicit none

	integer(4) :: nloops

	integer(4) :: iloops
    integer(4) :: ierr
    real(kind=egv_prec), allocatable :: h(:,:)
    real(kind=lanc_prec), allocatable :: vi(:), vf(:)
    real(kind=egv_prec), allocatable :: e(:), u(:,:), work(:),eiglvec(:,:)
    integer(kind=basis_prec) :: i, j, k
    integer :: vidx
    real :: xj,xt
	integer(4) :: aerr,info
	real :: emf(nkeep)

    allocate(h(dimbasis,dimbasis), stat=aerr)
    if(aerr /= 0) call memerror("fulldiag_scmf 1")

    allocate( e(dimbasis), work(dimbasis*3), stat=aerr)
    if(aerr /= 0) call memerror("fulldiag_scmf 2")
!    call   procOP_clock(0,'set','all')

!---------- INITIAL VECTOR FOR CREATING DENSITIES----------------------
		call make_MF

	do iloops = 1,nloops
		call make_MF
	    do i = 1, dimbasis
	       vec1(:) = 0.d0
	       vec1(i) = 1.d0
	       vec2(:) = 0.d0
	       if(useVec2Thread) vec2threadflat(:) = 0.0
   		   call master_apply1bop
	       if(nproc > 1) then
	           ! leaves data only on isfragroot nodes
	           ! In normal use, would move to vector space (breorthog.f90)
	           ! need to broadcast
	              ! output in vec2 with input 'n'
	              call BMPI_BCAST(vec2, size(vec2), 0, fcomm2, ierr)
	       end if
	       do j = 1,dimbasis
	          h(i,j) = real(vec2(j),kind(egv_prec))   ! store as real(4); this can be changed

	       end do  !J

!		   print*,h(i,:)

	    end do  !i
	    print*,' Finished with creating the Hamiltonian '

!	    close(60)
!------------------ DIAGONALIZE VIA HOUSEHOLDER -------------------

	    if(egv_prec==4)then
	        call SSYEV( 'V','U', dimbasis, h, dimbasis, e, WORK, 3*dimbasis, INFO )
	    else
	        call DSYEV( 'V','U', dimbasis, h, dimbasis, e, WORK, 3*dimbasis, INFO )
	    end if

!------------------- RESTART WITH INITIAL VECTOR-----------
!
        if(iproc == 0 ) print*,e(1),e(2),e(3),e(4)
!		print*,h(:,1)
        do i = 1, dimbasis
			vec1(i)= h(i,1)   !
		end do
!		print*,'vec1 :',vec1(:)

	end do  ! iloops
	emf(1) = e(1)
	return

end subroutine fulldiag_scmf

!===================================================

end module shampoo


linux-library liballegro_acodec

decimal \ important

\ addon: codec
function: al_init_acodec_addon ( -- bool )
function: al_get_allegro_acodec_version ( -- n )

\ addon: audio
#define ALLEGRO_EVENT_AUDIO_STREAM_FRAGMENT  513
#define ALLEGRO_EVENT_AUDIO_STREAM_FINISHED  514

\   /* Sample depth and type, and signedness. Mixers only use 32-bit signed
\    * float (-1..+1). The unsigned value is a bit-flag applied to the depth
\    * value.
\    */
#define ALLEGRO_AUDIO_DEPTH_INT8      $00
#define ALLEGRO_AUDIO_DEPTH_INT16     $01
#define ALLEGRO_AUDIO_DEPTH_INT24     $02
#define ALLEGRO_AUDIO_DEPTH_FLOAT32   $03
#define ALLEGRO_AUDIO_DEPTH_UNSIGNED  $08
ALLEGRO_AUDIO_DEPTH_INT8  ALLEGRO_AUDIO_DEPTH_UNSIGNED or constant ALLEGRO_AUDIO_DEPTH_UINT8
ALLEGRO_AUDIO_DEPTH_INT16 ALLEGRO_AUDIO_DEPTH_UNSIGNED or constant ALLEGRO_AUDIO_DEPTH_UINT16
ALLEGRO_AUDIO_DEPTH_INT24 ALLEGRO_AUDIO_DEPTH_UNSIGNED or constant ALLEGRO_AUDIO_DEPTH_UINT24

#define   ALLEGRO_PLAYMODE_ONCE    $100
#define   ALLEGRO_PLAYMODE_LOOP    $101
#define   ALLEGRO_PLAYMODE_BIDIR   $102
#define   _ALLEGRO_PLAYMODE_STREAM_ONCE    $103   \ /* internal-*/
#define   _ALLEGRO_PLAYMODE_STREAM_ONEDIR  $104   \  /* internal-*/

#define   ALLEGRO_MIXER_QUALITY_POINT    $110
#define   ALLEGRO_MIXER_QUALITY_LINEAR   $111
#define   ALLEGRO_MIXER_QUALITY_CUBIC    $112

#fdefine ALLEGRO_AUDIO_PAN_NONE      -1000.0e

#define    ALLEGRO_CHANNEL_CONF_1   $10
#define    ALLEGRO_CHANNEL_CONF_2   $20
#define    ALLEGRO_CHANNEL_CONF_3   $30
#define    ALLEGRO_CHANNEL_CONF_4   $40
#define    ALLEGRO_CHANNEL_CONF_5_1 $51
#define    ALLEGRO_CHANNEL_CONF_6_1 $61
#define    ALLEGRO_CHANNEL_CONF_7_1 $71

\ general
function: al_reserve_samples ( int-reserve_samples -- bool )
function: al_install_audio ( -- bool )
function: al_uninstall_audio ( -- )
function: al_play_sample ( ALLEGRO_SAMPLE-*data, float-gain, float-pan, float-speed, ALLEGRO_PLAYMODE-loop, ALLEGRO_SAMPLE_ID-*ret_id -- )
function: al_stop_sample ( ALLEGRO_SAMPLE_ID-*spl_id -- )
function: al_stop_samples ( -- )
function: al_destroy_sample ( sample -- )
function: al_load_sample ( const-char-*filename -- ALLEGRO_SAMPLE )
function: al_load_audio_stream ( const-char-*filename, size_t-buffer_count, unsigned-int-samples -- ALLEGRO_AUDIO_STREAM )
function: al_save_sample ( const-char-*filename, ALLEGRO_SAMPLE-*spl -- bool )

\ stream
function: al_create_audio_stream ( size_t-buffer_count, unsigned-int-samples, unsigned-int-freq, ALLEGRO_AUDIO_DEPTH-depth, ALLEGRO_CHANNEL_CONF-chan_conf -- ALLEGRO_AUDIO_STREAM )
function: al_destroy_audio_stream ( ALLEGRO_AUDIO_STREAM-*stream -- )
function: al_drain_audio_stream ( ALLEGRO_AUDIO_STREAM-*stream -- )

\ function: unsigned-int, al_get_audio_stream_frequency ( const-ALLEGRO_AUDIO_STREAM-*stream -- )
\ function: unsigned-int, al_get_audio_stream_length ( const-ALLEGRO_AUDIO_STREAM-*stream -- )
\ function: unsigned-int, al_get_audio_stream_fragments ( const-ALLEGRO_AUDIO_STREAM-*stream -- )
\ function: unsigned-int, al_get_available_audio_stream_fragments ( const-ALLEGRO_AUDIO_STREAM-*stream -- )

\ function: float, al_get_audio_stream_speed ( const-ALLEGRO_AUDIO_STREAM-*stream -- )
\ function: float, al_get_audio_stream_gain ( const-ALLEGRO_AUDIO_STREAM-*stream -- )
\ function: float, al_get_audio_stream_pan ( const-ALLEGRO_AUDIO_STREAM-*stream -- )

\ function: ALLEGRO_CHANNEL_CONF, al_get_audio_stream_channels ( const-ALLEGRO_AUDIO_STREAM-*stream -- )
\ function: ALLEGRO_AUDIO_DEPTH, al_get_audio_stream_depth ( const-ALLEGRO_AUDIO_STREAM-*stream -- )
\ function: ALLEGRO_PLAYMODE, al_get_audio_stream_playmode ( const-ALLEGRO_AUDIO_STREAM-*stream -- )

function: al_get_audio_stream_playing ( stream -- bool )
\ function: al_get_audio_stream_attached ( const-ALLEGRO_AUDIO_STREAM-*spl -- )

function: al_get_audio_stream_fragment ( const-ALLEGRO_AUDIO_STREAM-*stream -- addr )

function: al_set_audio_stream_speed ( ALLEGRO_AUDIO_STREAM-*stream, float-val -- bool )
function: al_set_audio_stream_gain ( ALLEGRO_AUDIO_STREAM-*stream, float-val -- bool )
function: al_set_audio_stream_pan ( ALLEGRO_AUDIO_STREAM-*stream, float-val -- bool )

function: al_set_audio_stream_playmode ( ALLEGRO_AUDIO_STREAM-*stream, ALLEGRO_PLAYMODE-val -- bool )
function: al_set_audio_stream_playing ( ALLEGRO_AUDIO_STREAM-*stream, bool-val -- bool )
\ function: al_detach_audio_stream ( ALLEGRO_AUDIO_STREAM-*stream -- bool )
function: al_set_audio_stream_fragment ( ALLEGRO_AUDIO_STREAM-*stream,-*val -- bool )

function: al_rewind_audio_stream ( ALLEGRO_AUDIO_STREAM-*stream -- bool )
function: al_seek_audio_stream_secs ( ALLEGRO_AUDIO_STREAM-*stream, double time -- bool )
function: al_get_audio_stream_position_secs ( ALLEGRO_AUDIO_STREAM-*stream -- n )
function: al_get_audio_stream_length_secs ( ALLEGRO_AUDIO_STREAM-*stream -- n )
function: al_set_audio_stream_loop_secs ( ALLEGRO_AUDIO_STREAM-*stream, double start, double end -- bool )
\ function: al_get_audio_stream_event_source ( ALLEGRO_AUDIO_STREAM-*stream -- ALLEGRO_EVENT_SOURCE-* )

\ sample instance

function: al_create_sample_instance ( sample -- instance )
function: al_destroy_sample_instance ( instance -- )
function: al_get_sample_instance_position ( sample -- n )
function: al_set_sample ( sample data -- bool )
function: al_get_sample_frequency ( sample -- n )

function: al_set_sample_instance_position ( ALLEGRO_SAMPLE_INSTANCE-*spl, unsigned-int-val -- bool )
function: al_set_sample_instance_length ( ALLEGRO_SAMPLE_INSTANCE-*spl, unsigned-int-val -- bool )
function: al_get_sample_instance_length ( ALLEGRO_SAMPLE_INSTANCE-*spl -- int )

function: al_set_sample_instance_speed ( ALLEGRO_SAMPLE_INSTANCE-*spl, float-val -- bool )
function: al_set_sample_instance_gain ( ALLEGRO_SAMPLE_INSTANCE-*spl, float-val -- bool )
function: al_set_sample_instance_pan ( ALLEGRO_SAMPLE_INSTANCE-*spl, float-val -- bool )
function: al_set_sample_instance_playmode ( ALLEGRO_SAMPLE_INSTANCE-*spl, ALLEGRO_PLAYMODE-val -- bool )
function: al_set_sample_instance_playing ( ALLEGRO_SAMPLE_INSTANCE-*spl, bool-val -- bool )
function: al_get_sample_instance_playing ( ALLEGRO_SAMPLE_INSTANCE-*spl,  -- bool )
function: al_play_sample_instance ( ALLEGRO_SAMPLE_INSTANCE-*spl -- bool )
function: al_stop_sample_instance ( ALLEGRO_SAMPLE_INSTANCE-*spl -- bool )
function: al_get_sample_instance_frequency ( const-ALLEGRO_SAMPLE_INSTANCE-*spl -- int )

\ mixer
function: al_get_default_mixer ( -- mixer )
function: al_set_default_mixer ( mixer -- bool )
function: al_restore_default_mixer ( -- )

function: al_create_mixer ( unsigned-int-freq, ALLEGRO_AUDIO_DEPTH-depth, ALLEGRO_CHANNEL_CONF-chan_conf -- ALLEGRO_MIXER* )
function: al_destroy_mixer ( ALLEGRO_MIXER-*mixer -- )
function: al_attach_sample_instance_to_mixer (  ALLEGRO_SAMPLE_INSTANCE-*stream, ALLEGRO_MIXER-*mixer -- bool )
function: al_attach_audio_stream_to_mixer ( ALLEGRO_AUDIO_STREAM-*stream, ALLEGRO_MIXER-*mixer -- bool )
function: al_attach_mixer_to_mixer ( ALLEGRO_MIXER-*stream, ALLEGRO_MIXER-*mixer -- bool )
function: al_set_mixer_postprocess_callback (  ALLEGRO_MIXER-*mixer, callback[buf,numsamps,userdata--] userdata -- bool )

function: al_get_mixer_frequency ( const-ALLEGRO_MIXER-*mixer -- n )
\ function: ALLEGRO_CHANNEL_CONF, al_get_mixer_channels ( const-ALLEGRO_MIXER-*mixer -- )
function: al_get_mixer_depth ( const-ALLEGRO_MIXER-*mixer -- depth )
\ function: ALLEGRO_MIXER_QUALITY, al_get_mixer_quality ( const-ALLEGRO_MIXER-*mixer -- )
\ function: float, al_get_mixer_gain ( const-ALLEGRO_MIXER-*mixer -- )
\ function: al_get_mixer_playing ( const-ALLEGRO_MIXER-*mixer -- )
\ function: al_get_mixer_attached ( const-ALLEGRO_MIXER-*mixer -- )
function: al_set_mixer_frequency ( ALLEGRO_MIXER-*mixer, unsigned-int-val -- bool )
function: al_set_mixer_quality ( ALLEGRO_MIXER-*mixer, ALLEGRO_MIXER_QUALITY-val -- bool )
function: al_set_mixer_gain ( ALLEGRO_MIXER-*mixer, float-gain -- bool )
function: al_set_mixer_playing ( ALLEGRO_MIXER-*mixer, bool-val -- bool )
function: al_detach_mixer ( ALLEGRO_MIXER-*mixer -- bool )

\ voice
function: al_create_voice ( unsigned-int-freq, ALLEGRO_AUDIO_DEPTH-depth, ALLEGRO_CHANNEL_CONF-chan_conf -- ALLEGRO_VOICE* )
function: al_destroy_voice ( ALLEGRO_VOICE-*voice -- )
function: al_attach_sample_instance_to_voice (  ALLEGRO_SAMPLE_INSTANCE-*stream, ALLEGRO_VOICE-*voice -- bool )
function: al_attach_audio_stream_to_voice (  ALLEGRO_AUDIO_STREAM-*stream, ALLEGRO_VOICE-*voice  -- bool )
function: al_attach_mixer_to_voice ( ALLEGRO_MIXER-*mixer, ALLEGRO_VOICE-*voice -- bool )
\ function: al_detach_voice ( ALLEGRO_VOICE-*voice -- )

function: al_set_voice_position ( ALLEGRO_VOICE-*voice, unsigned-int-val -- bool )
function: al_set_default_voice  ( voice -- bool )
function: al_get_default_voice  ( -- voice )


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

#ifdef HAVE_HYBRID
program test
use libatoms_module
use potential_module
use vacancy_map_module

implicit none
  type(Atoms) at
  type(Potential), target ::pot1, pot2
  type(Potential)         ::hybridpot
  type(inoutput) params, out
  integer :: it
  real(dp) :: e, maxforce, d
  real(dp) :: hybrid_center(3)
  integer :: hybrid_center_i
  real(dp), allocatable :: f(:,:)
  real(dp) :: lat(3,3), virial(3,3)
  character(len=256) arg
  type(MPI_Context) :: mpi
  integer vac_i
  character(len=1024) :: comment, in_file
  type(Dictionary) :: cli_params, comment_params
  logical :: doing_restart
  real(dp) :: eps_guess
  character(len=1024) :: hybrid_args_str

  call system_initialise(enable_timing=.true.)
  ! trace_memory=.true.

  call initialise(cli_params)
  in_file=''
  hybrid_args_str=''
  call param_register(cli_params, 'restart', 'F', doing_restart, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, 'in_file', 'stdin', in_file, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, 'vac_i', '0', vac_i, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, 'hybrid_args_str', '', hybrid_args_str, help_string="No help yet.  This source file was $LastChangedBy$")

  if (.not. param_read_args(cli_params)) then
    call system_abort("Usage: vacancy_map_hybrid_relax [ restart ] [ vac_i ] [ in_file=filename ] [ hybrid_args_str=args ]")
    call system_abort("Confused by CLI argument")
  endif
  call finalise(cli_params)

  call print("in_file = "//trim(in_file))
  call print("restart = "//doing_restart)
  call print("vac_i = "//vac_i)
  call print("hybrid_args_str = "//trim(hybrid_args_str))

  if (doing_restart) then
    eps_guess = 1.0e-2_dp
  else
    eps_guess = 0.0_dp
  endif

  call initialise(mpi)
  call Potential_Initialise_filename(pot1, 'TB NRL-TB label=Aluminum SCF=GLOBAL_U GLOBAL_U=20', 'quip_params_hybrid.xml', mpi_obj=mpi)
  call Potential_Initialise_filename(pot2, 'IP EAM_Ercolessi_Adams', 'quip_params_hybrid.xml', mpi_obj=mpi)

  call init_hybrid(pot1, pot2, hybridpot, hybrid_args_str)

  call initialise(out, 'out.xyz', action=OUTPUT)
  call read_xyz(at, in_file, comment=comment, mpi_comm=mpi%communicator, mpi_id=mpi%my_proc)

  if (vac_i < 0 .or. vac_i > at%N) call system_abort("vac_i " // vac_i // " out of range : 0 or 1 .. N=" // at%N)

  call initialise(comment_params)
  call param_register(comment_params,"hybrid_center_i", "0", hybrid_center_i, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(comment_params,"hybrid_center", "1e38 1e38 1e38", hybrid_center, help_string="No help yet.  This source file was $LastChangedBy$")
  if (.not. param_read_line(comment_params, comment, ignore_unknown=.true.)) then
    call print("Failed to parse hybrid_center_i and hybrid_center from comment line '"//trim(comment)//"'")
  endif
  call finalise(comment_params)

  if (vac_i > 0) then
    call print("Removing atom " // vac_i // " from pos " // at%pos(:,vac_i))
    call remove_atoms(at, vac_i)
  endif

  call print_xyz(at, out, comment=trim(comment)//" Unrelaxed_hybrid_disloc", all_properties=.true.)

  allocate(f(3,at%N))

  call set_cutoff(at, cutoff(pot2)+0.5_dp)
  call calc_connect(at)
  call verbosity_push_increment(5)
  call setup_parallel(pot2, at, e=e, f=f)
  it = minim(hybridpot, at, 'cg', 0.001_dp, 500, 'NR_LINMIN', do_print = .true., print_inoutput = out, &
    do_pos = .true., eps_guess = eps_guess)
  call verbosity_pop()
  call print_xyz(at, out, comment=trim(comment)//" Relaxed_hybrid_disloc", all_properties=.true.)
  call calc_dists(at)

  call calc(hybridpot, at, e=e,f=f)
  maxforce = maxval(norm(f,1))
  deallocate(f)

  call print('Atom '//hybrid_center_i//' position: '//hybrid_center//' Energy: '//e// &
    ' Max force after '//it//' iterations: '//maxforce)

  call system_finalise()
end program
#else
vacancy_map_hybrid_relax without HAVE_HYBRID makes no sense
#endif /* HAVE_HYBRID */


      SUBROUTINE PULSUN
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      COMMON/CONSTS/PI,TWOPI,RAD
C
      COMMON/CSTVAL/TSTART,DUM5(40)
C
      COMMON/ITCNTL/IPULSE,ISPLSE,KPULSE,ITSW,IOTSW,IPLPRP
C
      COMMON/OUTTHR/SMAGB(3)
C
      COMMON/RPOOL1/DUM2(10),TIME,SA(3,3),DUM3(19),OMEG(3),DUM4(83)
C
      COMMON/RMGNTC/SMAGI(3)
C
      COMMON/SENVTR/DIY(3),DL2
C
      COMMON/THRUST/TV(3,2),TLOC(3,2),TTIM(4,2),TPAR(4,2),REF(2)
C
      COMMON/TIMPLS/TMEAN(2),TPULSE(2),TOPLSE(2),TTSTOP(2),DELV(2)
C
C
C
      WS2=DIY(2)
      WS1=DIY(1)
      IF(TIME.GT.TSTART) GO TO 10
      TLAST=TIME
      DL2=WS2
   10 CONTINUE
C
      WS3=WS1*WS1+WS2*WS2
      WS3=DSQRT(WS3)
      IF(WS3.GT.0.01745D0) GO TO 20
      WS3=WS3/RAD
      WRITE(6,1000) WS3
 1000 FORMAT('0',5X,'THE ANGLE BETWEEN THE SUN VECTOR AND THE SPIN
     1      AXIS IS',1PE15.5,'DEG.')
      CALL EXIT
C
   20 CONTINUE
      IF(TIME.LE.TLAST) GO TO 100
      IF(ITSW.EQ.0) GO TO 90
      IF(WS2.LE.0.0D0) GO TO 90
      IF(DL2.GT.0.0D0) GO TO 90
      TDIF=TIME-TLAST
      CDEN=WS2-DL2
      TCROSS=TIME-TDIF*WS2/CDEN
C
      DO 30 I=1,IPLPRP
      TDIF=REF(I)*RAD/OMEG(3)
      TDIF=DABS(TDIF)
      TPULSE(I)=TCROSS+TDIF
      TOPLSE(I)=TPULSE(I)+TMEAN(I)
      TTSTOP(I)=TPULSE(I)+TTIM(4,I)-TTIM(1,I)
   30 CONTINUE
C
      ITSW=0
C
   90 CONTINUE
C
      TLAST=TIME
      DL2=WS2
C
  100 CONTINUE
C
      RETURN
C
      END