! @Copyright 2007 Kristjan Haule

SUBROUTINE Cmp_Optics(fenergy, fUdmft, fsymop, fh_m, fhb, ommax, Temperature_, delta, Nd, gammac, gamma, alphaV, Ndirection, Qsym, Qsimple, nom, nat, iso, norbitals, ncix, natom, nkpt, nmat, nume, Qcomplex, lmax2, maxdim2, maxdim, maxsize, dwindow, InterbandOnly)
  USE com_mpi, ONLY: nprocs, myrank, master, Reduce_MPI, Reduce_MPI_dos
  IMPLICIT NONE
  CHARACTER*100, intent(in) :: fenergy, fUdmft, fsymop!, fmommat
  REAL*8, intent(in)  :: ommax, delta, gammac, gamma, alphaV(3,3,Ndirection), dwindow, Temperature_
  INTEGER, intent(in) :: Nd, Ndirection, fh_m
  LOGICAL, intent(in) :: Qsym, Qsimple
  INTEGER, intent(in) :: fhb, nom, nat, iso, norbitals, ncix, natom, nkpt, nmat, nume
  LOGICAL, intent(in) :: Qcomplex
  INTEGER, intent(in) :: lmax2, maxdim2, maxdim, maxsize
  LOGICAL, intent(in) :: InterbandOnly
  ! Functions
  !COMPLEX*16 :: Opt_Inside_Simple, Opt_Inside, Opt_Noncorrelated
  interface
     REAL*8 Function ferm(x)
       REAL*8, intent(in):: x
     end function ferm
  end interface
  ! locals
  COMPLEX*16 :: ctmp(Ndirection), ctmp2(Ndirection), copt(Ndirection)
  CHARACTER*10:: skii
  LOGICAL :: Tcompute, pform
  INTEGER :: ios, pr_proc
  INTEGER :: itape, i, j, k, l, is, N, nemin, nemax, ikp, iikp, ip, iq, NE, nb_min, nb_max, dir, n_min, n_max
  REAL*8  :: EF, VOL, EMIST, renorm_wgh, wommax, wdelta, wgamma, wdwindow, Ek(nume), wgh(nkpt), womega, eps_p, eps_m, ferm_factors, Temperature
  integer :: fh_p, fh_s, fh_d, fh_o!, fh_m
  integer :: numk, nsymop, nbands, isym, ddi, iw, istart, iend, ix, iw_p, iw_m
  integer :: iorb, wkii, wkis, iom, iband, nord, N0, Nw, Nsymw, icix, tnorbitals
  integer :: nindo(norbitals), csize(ncix), tnindo(norbitals), cixdim(ncix), nl(natom), ll(natom,4)
  INTEGER :: cix(natom,4), iorbital(natom,4), nind(natom,4), iSx(maxdim2,norbitals), Sigind(maxdim,maxdim,ncix)
  INTEGER,    ALLOCATABLE :: amesh(:), bandind(:)
  REAL*8,     ALLOCATABLE :: zomega(:), conduc(:,:), opimat(:,:,:), omega(:)
  COMPLEX*16, ALLOCATABLE :: STrans(:,:,:,:), DMFTU(:,:,:), gc(:)
  COMPLEX*16, ALLOCATABLE :: sigma(:,:,:), wsigma(:,:), gij(:,:), zekw(:,:), Al(:,:,:), Ar(:,:,:)
  COMPLEX*16, ALLOCATABLE :: Cv(:,:,:), Dv(:,:,:), Vel(:,:,:), Ve(:,:,:), Cv0(:,:,:)
  COMPLEX*16, ALLOCATABLE :: L1(:,:,:), L2(:,:,:), L3(:,:,:), L4(:,:,:), Ltmp(:,:)
  COMPLEX*16, ALLOCATABLE :: lg_q(:), lg_p(:)
  LOGICAL,    ALLOCATABLE :: Qinside(:)
  ! constants
  REAL*8, PARAMETER      :: Ry2eV = 13.60569193
  REAL*8, PARAMETER      :: elresunit = 2.173985e-5  ! [ aBohr*hbar/ecoul^2 ] in units of Ohm*cm !!! Natural unit for electrical resistivity: [ aBohr*hbar/ecoul^2 ]
  REAL*8, PARAMETER      :: PI = 3.14159265358979
  COMPLEX*16, PARAMETER  :: IMAG = (0.0D0,1.0D0)
  REAL*8 :: COmega(2*Nd+1)

  ! Converting to Rydbergs
  wommax = ommax/Ry2eV
  wdelta = delta/Ry2eV
  wgamma = gamma/Ry2eV
  wdwindow = dwindow/Ry2eV
  Temperature = Temperature_/Ry2eV

  fh_p = 399 ! file for DMFT transformation UDMFT

  ! Logarithmic frequency mesh for integration
  N0 = int(log((wommax/wdelta)/Nd)/log(2.) + 1 + 0.5) ! Number of different logarithmic intervals
  if (N0 .LT. 1) N0=1 ! should not be zero
  Nw = (N0+1)*Nd/2   ! Number of all points in the logarithmic mesh
  ALLOCATE ( amesh(2*Nd+1), zomega(2*Nw), conduc(Nw,Ndirection), gc(2*Nw) )
  gc=0
  print *, 'Number of logarithmic intervals=', N0, 'Number of all points in the logarithmic mesh=', Nw

  ! Many index arrays are imported from DMFT
  CALL Read_The_Rest_Basic_Arrays(fhb, nindo, cixdim, nl, ll, iorbital, cix, nind, csize, iSx, Sigind, EF, VOL, norbitals, ncix, natom, maxdim, maxdim2)

  ! Reading the self-energy for all orbitals
  ALLOCATE( sigma(nom,maxsize,ncix), omega(nom), wsigma(maxsize,ncix) )
  do icix=1,ncix
     itape = 80+icix
     WRITE(skii,fmt='(I2)') icix
     open(itape, file=TRIM('sig.inp')//ADJUSTL(TRIM(skii)), status='old', form='formatted')
     CALL ReadSelfenergy(itape, sigma(:,:,icix), omega, gammac, csize(icix), nom, maxsize)
  enddo
  ! Self-energy was in eV -> transform to Ry
  omega(:) = omega(:)/Ry2eV
  sigma(:,:,:) = sigma(:,:,:)/Ry2eV

  ! Kohn-Sham eigenvalues from the file
  open (59, file=fenergy, status='old', form='formatted')

  ! Reading symmetrization for matrix elements. It is used to transform from an irreducible k-point to general k-point.
  fh_s = 98
  open(fh_s, file=fsymop, status='old')
  READ(fh_s, fmt='(I6)') nord
  ALLOCATE( opimat(3,3,nord) )
  DO k=1,nord
     READ(fh_s, fmt='(3(3f8.5/))') ((opimat(j,i,k),i=1,3),j=1,3)
  END DO

  !! Reading linearization energies in Energy file
  itape=59
  do i=1,nat
     READ(itape, fmt='(f9.5)') EMIST !---- At the beginninge we have linearization energies --!
     READ(itape, fmt='(f9.5)') EMIST !---- We just skip them ---------------------------------!
  enddo

  wkis=0 ! DMFT transofmration might be in many files. Starting by the first.
  ! DMFT transformation
  WRITE(skii,fmt='(I2)') wkis

  !pform = .true.
  pform = .false.
  if (pform) then
     open(fh_p, file=TRIM(fUdmft)//ADJUSTL(TRIM(skii)), status='old',form='formatted')
  else
     open(fh_p, file=TRIM(fUdmft)//ADJUSTL(TRIM(skii)), status='old',form='unformatted')
  endif

  if (pform) then
     READ(fh_p,*) numk, nsymop, tnorbitals
     READ(fh_p,*) (tnindo(iorb), iorb=1,norbitals)
  else
     READ(fh_p) numk, nsymop, tnorbitals
     READ(fh_p) (tnindo(iorb), iorb=1,norbitals)
  endif

  ! optics matrix elements
  !open(fh_m, file=fmommat, status='old')
  READ(fh_m,*)

  COmega=0

!!! ---------- Preparation of arrays for paralel executaion --------------
  pr_proc  = floor(nkpt/DBLE(nprocs)+0.999)  ! The maximum number of points calculated per processor
  WRITE(6,'(A,I4,2x,A,I4)') 'pr_proc=', pr_proc, 'tot-k=', nkpt

  wgh=0
  conduc = 0
  wkii=0
  DO ikp=1,nkpt   ! over all irreducible k-points
     !--- We need to go over all k-points even though we will compute only some of them on this processor.
     !--- This is because we need to read vector file sequentially.
     iikp = ikp-myrank*pr_proc            ! The index of the point to compute. If negative, do not compute!
     if (iikp.GT.pr_proc) EXIT            ! Processor finished. The rest of the points will be taken care of by the other processors.
     Tcompute=.FALSE.
     if (iikp.gt.0) Tcompute=.TRUE.       ! If Tcompute is true, the point needs to be computed.
     ! Reading band energies from energy file
     CALL ReadEnergiesK(Ek, wgh, NE, ikp, nkpt, nume)
     ! Start reading DMFT transformation
     CALL ReadDMFT_TransK_Outside(nsymop, nbands, nemin, numk, wkii, wkis, fUdmft, fh_p, pform, ikp)
     nemax = nemin+nbands-1

     ALLOCATE( bandind(NE) )

     DO ip=1,NE
        bandind(ip)=ip
     ENDDO
     DO ip=1,NE
        do iq=ip+1,NE
           if (abs(Ek(ip)-Ek(iq)).LT.1e-11) then
              bandind(iq)=bandind(ip)
           endif
        enddo
     ENDDO

     ALLOCATE( Qinside(NE) )
     Qinside=.FALSE.
     do ip=1,nbands
        Qinside(ip+nemin-1) = .TRUE.
     enddo

     ALLOCATE ( DMFTU(nbands,maxdim2,norbitals) )
     ALLOCATE ( Vel(NE,NE,3) )
     IF (Tcompute) THEN
        ALLOCATE( STrans(maxsize,ncix,nbands,nbands) )
        allocate( gij(nbands,nbands), zekw(NE,2*Nd+1), Al(nbands,nbands,2*Nd+1), Ar(nbands,nbands,2*Nd+1))
        ALLOCATE( Ve(NE,NE,3), Cv0(NE,NE,Ndirection) )
        ALLOCATE( Cv(NE,NE,Ndirection), Dv(NE,NE,Ndirection) )
        ALLOCATE( L1(NE,NE,3), L2(NE,NE,3), L3(NE,NE,3), L4(NE,NE,3), Ltmp(nbands,nbands) )
        ALLOCATE( lg_q(NE), lg_p(NE) )
     ELSE
        wgh(ikp)=0
     ENDIF

     CALL ReadVelocityK(Vel, NE, fh_m, nb_min, nb_max) !nemin, nbands)

     if (Qsym) then
        Nsymw = nsymop  ! Over all reducible k-points (all group transformations)
     else
        Nsymw = 1       ! Only irreducible k-points needed
     endif

     DO isym=1, nsymop

        ! Continuing reading DMFT transformation
        CALL ReadDMFT_TransK_Inside(DMFTU, fh_p, pform, isym, nindo, nbands, norbitals, maxdim2)

        if (isym.GT.Nsymw .OR. .NOT.Tcompute) CYCLE ! If only the average optics is needed, we can go over the irreducible BZ only.

        !print *, ikp, isym

        ! For more efficient transformation of self-energy, we create special array of transformation STrans
        CALL CompressSigmaTransformation2(STrans, DMFTU, Sigind, iSx, cix, csize, iorbital, ll, nl, natom, iso, ncix, maxdim, maxdim2, lmax2, norbitals, nbands, maxsize)

        ! Changing matrix elements to general k-point
        CALL Transform_To_Reducible(Ve, isym, Vel, opimat, NE, nord)

        !!!! For non-correlated
        L1 = Ve
        L2 = Ve
        L3 = Ve
        L4 = Ve
        DO ip=nb_min,nb_max
           DO iq=nb_min,nb_max
              ctmp=0
              DO dir=1,Ndirection
                 DO j=1,3
                    DO l=1,3
                       ctmp(dir) = ctmp(dir) + Ve(ip,iq,j)*Ve(iq,ip,l)*alphaV(l,j,dir)
                    ENDDO
                 ENDDO
              ENDDO
              Cv0(ip,iq,:) = ctmp
              Cv(ip,iq,:) = ctmp
              Dv(ip,iq,:) = ctmp
           ENDDO
        ENDDO
        ! For non-correlated
        do i=1,2*Nd+1
           zekw(:,i) = Ek(:)
        enddo

        iw=1
        ddi = 1
        do j=1,N0
           ! The algoritm for the frequency mesh is the following:
           ! We start with Nd negative and Nd positive points of equidistant mesh. Incluing zero, we have 2*Nd+1 points.
           ! The points are [-Nd,-Nd+1,...0, 1,.., Nd]*wdelta
           ! With this mesh, we can compute all integrals up to frequency Nd*wdelta, where wdelta is the distance between the points
           ! In the second step, we keep every second point: [-Nd,-Nd+2,...0,2,...Nd]*wdelta
           ! and we add additional points, so that we have again 2*Nd+1 points. We thus have the following points
           ! [-2*Nd, -2*Nd+2,...0,2,..2*Nd]*wdelta.
           ! The old points (one half of all the points) do not need to be recomputed. Only the new points are recomputed.
           ! The interval is doubles N0 times. N0 depends on the cutoff ommax.
           if (j.EQ.1) then
              ix=1
              do i=-Nd,Nd
                 amesh(i+Nd+1) = ddi*i
                 CALL FindEigsys(zekw(nemin:nemax,i+Nd+1), Al(:,:,i+Nd+1), Ar(:,:,i+Nd+1), ix, wsigma, gij, amesh(i+Nd+1)*wdelta, omega, STrans, Ek, nom, ncix, nbands, nemin, maxsize, nume, csize, sigma)
              enddo
           else
              do i=1,Nd/2 ! These points were computed in previous step. Just reshuffle them into the right place.
                 amesh( i+Nd+1) = amesh( 2*i+Nd+1)
                 zekw(nemin:nemax,i+Nd+1) = zekw(nemin:nemax,2*i+Nd+1)
                 Al(:,:,i+Nd+1) = Al(:,:,2*i+Nd+1)
                 Ar(:,:,i+Nd+1) = Ar(:,:,2*i+Nd+1)
              enddo
              do i=-1,-Nd/2,-1 ! These points were computed in previous step. Just reshuffle them into the right place.
                 amesh( i+Nd+1) = amesh( 2*i+Nd+1)
                 zekw(nemin:nemax,i+Nd+1) = zekw(nemin:nemax,2*i+Nd+1)
                 Al(:,:,i+Nd+1) = Al(:,:,2*i+Nd+1)
                 Ar(:,:,i+Nd+1) = Ar(:,:,2*i+Nd+1)
              enddo
              do i=-Nd,-Nd/2-1 ! These points are new. Need to compute eigensystem for them.
                 amesh(i+Nd+1) = ddi*i
                 CALL FindEigsys(zekw(nemin:nemax,i+Nd+1), Al(:,:,i+Nd+1), Ar(:,:,i+Nd+1), ix, wsigma, gij, amesh(i+Nd+1)*wdelta, omega, STrans, Ek, nom, ncix, nbands, nemin, maxsize, nume, csize, sigma)
              enddo
              do i=Nd/2+1,Nd,1 ! These points are new. Need to compute eigensystem for them.
                 amesh(i+Nd+1) = ddi*i
                 CALL FindEigsys(zekw(nemin:nemax,i+Nd+1), Al(:,:,i+Nd+1), Ar(:,:,i+Nd+1), ix, wsigma, gij, amesh(i+Nd+1)*wdelta, omega, STrans, Ek, nom, ncix, nbands, nemin, maxsize, nume, csize, sigma)
              enddo
           endif

           if (j.EQ.1) then
              istart=1
              iend=Nd
           else
              istart=Nd/2+1
              iend=Nd
           endif
           if (Temperature.NE.0.0) then
              istart=1
              iend=Nd-4*Temperature/wdelta
              if (iend<1) iend=1
           endif
           WRITE(*,'(A,I4,1x,A,I3,1x,A,I3,1x,A,I3,1x,A,I4,1x,A,I4,1x,A,F10.3)') 'ikp=', ikp, 'isym=', isym, 'j=', j, 'istart=', istart, 'iend=', iend, 'Nd=', Nd, '4*T/d=', 4*Temperature/wdelta

           ix=1
           do k=istart,iend
              ! Frequency mesh for printing
              zomega(Nw+iw)   = amesh(k+Nd+1)*wdelta ! positive frequencies
              zomega(Nw-iw+1) = amesh(Nd-k+1)*wdelta ! negative frequencies
              ! For Density of state
              do ip=1,nbands
                 iband = ip+nemin-1
                 gc(Nw+iw)   = gc(Nw+iw)   + wgh(ikp)/(zomega(Nw+iw)  +EF-zekw(iband,Nd+k+1)+wgamma*IMAG)
                 gc(Nw-iw+1) = gc(Nw-iw+1) + wgh(ikp)/(zomega(Nw-iw+1)+EF-zekw(iband,Nd-k+1)+wgamma*IMAG)
              enddo

              womega = amesh(k+Nd+1)*wdelta

              n_min = nb_min
              n_max = nb_max
              do ip=nb_min,nb_max
                 if ( (Ek(ip)-EF).LT.(-womega-wdwindow) ) n_min = ip
              enddo
              do ip=nb_max,nb_min,-1
                 if ( (Ek(ip)-EF).GT.(womega+wdwindow) ) n_max = ip
              enddo

              ctmp=0  ! integration over epsilon=[0,omega]
              if (Temperature.NE.0.0) then !! FINITE TEMPERATURE
                 ! !$OMP PARALLEL DO SHARED(COmega,amesh,Al,Ar,Ve,alphaV) PRIVATE(iw_p,iw_m,eps_p,eps_m,ferm_factors,Cv,Dv,L1,L2,L3,L4,Ltmp,copt) SCHEDULE(STATIC) &
                 ! !$OMP& REDUCTION(+:ctmp)
                 do l=k+1-Nd,Nd+1
                    iw_p = Nd+l                 ! eps
                    iw_m = Nd-k+l               ! eps-omega

                    eps_p = amesh(iw_p)*wdelta    ! eps
                    eps_m = amesh(iw_m)*wdelta    ! eps-omega
                    ferm_factors = ferm(eps_m/Temperature)-ferm(eps_p/Temperature)

                    CALL cmp_C_and_D(Cv, Dv, Al(:,:,iw_p), Ar(:,:,iw_p), Al(:,:,iw_m), Ar(:,:,iw_m), Ve, alphaV, Ndirection, L1, L2, L3, L4, Ltmp, Qinside, nbands, NE, nemin, nemax, n_min, n_max)

                    if (Qsimple) then
                       CALL Opt_Inside_Simple(copt, Cv, Dv, zekw, k, -10000, amesh, iw_p, iw_m, wdelta, wgamma, EF, nbands, Nd, bandind, Qinside, nume, Ndirection, NE, nemin, n_min, n_max, InterbandOnly)
                       ctmp = ctmp + copt*ferm_factors
                    else
                       CALL Opt_Inside(copt, Cv, Dv, zekw, k, -10000, amesh, iw_p, iw_m, wdelta, wgamma, EF, lg_q, lg_p, nbands, Nd, bandind, Qinside, nume, Ndirection, NE, nemin, n_min, n_max, InterbandOnly)
                       ctmp = ctmp + copt*ferm_factors
                    endif

                    !if (k.eq.1) WRITE(*,'(A,I3,1x,A,F12.6,1x,A,I3,1x,A,F12.6,1x,A,F12.6,1x,A,F12.6)') 'iw_p=', iw_p, 'eps_p=', eps_p/Temperature, 'iw_m=', iw_m, 'eps_m=', eps_m/Temperature, 'ferm=', ferm_factors, 'opt=', -dble(copt(1))
                    if (k.eq.1) then
                       COmega(iw_p) = COmega(iw_p) - dreal(copt(1))*wgh(ikp)*(4*pi)/(2*pi**2*elresunit*VOL)
                    endif
                 enddo
                 ! !$OMP END PARALLEL DO
              else
                 do l=1,k+1
                    iw_p = Nd+l                 ! eps
                    iw_m = Nd-k+l               ! eps-omega

                    CALL cmp_C_and_D(Cv, Dv, Al(:,:,iw_p), Ar(:,:,iw_p), Al(:,:,iw_m), Ar(:,:,iw_m), Ve, alphaV, Ndirection, L1, L2, L3, L4, Ltmp, Qinside, nbands, NE, nemin, nemax, n_min, n_max)

                    if (Qsimple) then
                       CALL Opt_Inside_Simple(copt, Cv, Dv, zekw, k, l, amesh, iw_p, iw_m, wdelta, wgamma, EF, nbands, Nd, bandind, Qinside, nume, Ndirection, NE, nemin, n_min, n_max, InterbandOnly)
                       ctmp = ctmp + copt
                    else
                       CALL Opt_Inside(copt, Cv, Dv, zekw, k, l, amesh, iw_p, iw_m, wdelta, wgamma, EF, lg_q, lg_p, nbands, Nd, bandind, Qinside, nume, Ndirection, NE, nemin, n_min, n_max, InterbandOnly)
                       ctmp = ctmp + copt
                    endif
                 enddo
              endif

              !!! For non-correlated
              !womega = amesh(k+Nd+1)*wdelta ! omega
              CALL Opt_Noncorrelated(copt,Cv0,Ek,womega,EF,wgamma,nb_min,nb_max,nemin,nemax,nume,Qinside,NE,Ndirection,InterbandOnly)
              ctmp2 = copt

              DO dir=1,Ndirection
                 ! We add proper dimension to optics
                 conduc(iw,dir) = conduc(iw,dir) - dreal(ctmp(dir) + ctmp2(dir))*wgh(ikp)*(4*pi)/(2*pi**2*elresunit*VOL)
              ENDDO
              iw = iw + 1
           enddo
           ddi = ddi * 2
        enddo
     ENDDO
     DEALLOCATE( bandind )
     DEALLOCATE( Qinside )
     DEALLOCATE( DMFTU, Vel )
     IF (Tcompute) THEN
        DEALLOCATE( lg_q, lg_p )
        DEALLOCATE( L1, L2, L3, L4, Ltmp )
        DEALLOCATE( Cv, Dv, Ve, Cv0 )
        DEALLOCATE( gij, zekw, Al, Ar)
        DEALLOCATE( STrans )
     ENDIF
  ENDDO

  ! k-points weights are not normalized. Need to normalize at the end!
  renorm_wgh=0
  DO ikp=1,nkpt
     renorm_wgh = renorm_wgh + wgh(ikp)
  ENDDO

  CALL Reduce_MPI(conduc, COmega, Nw, Ndirection, renorm_wgh, Nd)
  CALL Reduce_MPI_dos(gc,Nw)

  IF (myrank.EQ.master) THEN

     ! Normalization over irreducible k-points and over symmetrization (all k-points)
     gc = gc/(renorm_wgh*Nsymw)
     conduc = conduc/(renorm_wgh*Nsymw) * (2.0/iso)  ! changed in 2019. Needs to be multiplied by 2 due to spin, except if spin-orbit is included

     ! Output of total DOS and optics
     fh_d = 501
     open(fh_d, file='optdos.dat', status='unknown', form='formatted')
     WRITE(fh_d,*) '# omega[eV]   DOS[1/eV]'
     DO iom=1,2*Nw
        if (zomega(iom).NE.0) WRITE(fh_d,*) zomega(iom)*Ry2eV, -aimag(gc(iom))/PI/Ry2eV
     ENDDO
     close(fh_d)

     fh_o = 502
     open(fh_o, file='optics.dat', status='unknown', form='formatted')
     WRITE(fh_o,*) '# omega[eV]   sigma[1/(Ohm*cm)]'
     DO iom=1,Nw
        if (zomega(Nw+iom).GT.0.0) then
           WRITE(fh_o, '(f14.10,2x)', advance='no') zomega(Nw+iom)*Ry2eV
           DO dir=1,Ndirection
              WRITE(fh_o, '(f20.5,1x)', advance='no') conduc(iom,dir)/(zomega(Nw+iom))
           ENDDO
           WRITE(fh_o,*)
        endif
     ENDDO

     if (Temperature.NE.0.0) then
        COmega = COmega/(renorm_wgh*Nsymw)
        fh_d = 503
        open(fh_d, file='what_we_integrate.dat', status='unknown', form='formatted')
        WRITE(fh_d,*) '# omega[eV]   OMEGA[1/eV]'
        DO iom=2,2*Nd+1
           WRITE(fh_d,*) (iom-Nd-1)*wdelta*Ry2eV, COmega(iom)/wdelta
        ENDDO
        close(fh_d)
     endif

  ENDIF

998 CONTINUE

  close(fh_s)
  close(fh_p)
  close(59)
  close(60)
  DEALLOCATE( amesh, zomega, conduc, gc )
  DEALLOCATE( opimat )
  DEALLOCATE( sigma, omega, wsigma )
9010 FORMAT(/,2X,' KP:',I6,' NEMIN NEMAX : ',2I5, ' dE:',2f5.2,' K:',a10 /)
9040 FORMAT(3X,2I4,6E13.6,F13.8)
END SUBROUTINE Cmp_Optics

SUBROUTINE ReadVelocityK(Vel, NE, fh_m, nb_min, nb_max)!, nemin, nbands)
  IMPLICIT NONE
  COMPLEX*16, intent(out) :: Vel(NE,NE,3)
  INTEGER, intent(out) :: nb_min, nb_max
  INTEGER, intent(in) :: fh_m, NE!, nemin, nbands
  ! locals
  INTEGER      :: iikp, i1, i2, ib1, ib2, ixyz
  REAL*8       :: wEmin, wEmax, dE
  CHARACTER*10 :: kname
  COMPLEX*16   :: O(3)

  Vel = 0
!!! Reading optics matrix elements
  READ(fh_m,9010) iikp,nb_min,nb_max,wEmin,wEmax,kname
  do i1=nb_min,nb_max
     do i2=i1,nb_max
        READ(fh_m, 9040) ib1,ib2, O(1), O(2), O(3), dE
        if (i1.ne.ib1 .or. i2.ne.ib2) then
           print *, 'ERROR', i1, ib1, i2, ib2
        endif
        !if (i1.GE.nemin .AND. i1.LT.nemin+nbands .AND. i2.GE.nemin .AND. i2.LT.nemin+nbands) then
        if (i1.LE.NE .and. i2.LE.NE) then
           DO ixyz=1,3
              Vel(i1,i2,ixyz) = O(ixyz)
              if (i2.NE.i1) then
                 Vel(i2,i1,ixyz) = conjg(O(ixyz))
              endif
           ENDDO
        endif
     enddo
  enddo
  if (nb_max.GT.NE) nb_max = NE
!9010 FORMAT(/,2X,' KP:',I6,' NEMIN NEMAX : ',2I5, ' dE:',2f5.2,' K:',a10 /)
9010 FORMAT(/,2X,4X,I6,15X,2I5,4X,2f5.2,3X,a10 /)
9040 FORMAT(3X,2I4,6E13.6,F13.8)
END SUBROUTINE ReadVelocityK

SUBROUTINE ReadEnergiesK(Ek, wgh, NE, ikp, nkpt, nume)
  IMPLICIT NONE
!!!! Reading band energies from energy file
  REAL*8, intent(out) :: wgh(nkpt), Ek(nume)
  INTEGER, intent(out):: NE
  INTEGER, intent(in) :: ikp, nkpt, nume
  ! locals
  INTEGER :: is, ios, itape, ii, NUM
  REAL*8  :: S, T, Z, WG, E1
  CHARACTER*10 :: KNAME
  INTEGER :: N
  itape=59
  READ(itape,'(3e19.12,a10,2i6,e19.12)',IOSTAT=ios) S,T,Z,KNAME,N,NE,WG
  wgh(ikp) = WG
  DO ii=1,NE
     READ(itape,*) NUM, E1
     Ek(NUM)=E1
  ENDDO
END SUBROUTINE ReadEnergiesK

SUBROUTINE ReadDMFT_TransK_Outside(nsymop, nbands, nemin, numk, wkii, wkis, fUdmft, fh_p, pform, ikp)
!!! Start reading DMFT transformation
  IMPLICIT NONE
  INTEGER, intent(out)   :: nsymop, nbands, nemin
  INTEGER, intent(inout) :: numk, wkii, wkis
  CHARACTER*100, intent(in) :: fUdmft
  INTEGER, intent(in)    :: fh_p, ikp
  LOGICAL, intent(in)    :: pform
  ! locals
  CHARACTER*10 :: skii
  INTEGER :: tnorbitals, iikp, tmaxdim2
  if (wkii==numk) then ! There are many udmfile's because of parallel execution! Need to read one after the other.
     wkii=0
     wkis = wkis + 1
     WRITE(skii,fmt='(I2)') wkis
     close(fh_p)
     if (pform) then
        open(fh_p, file=TRIM(fUdmft)//ADJUSTL(TRIM(skii)), status='old', form='formatted')
        READ(fh_p,*) numk, nsymop, tnorbitals
     else
        open(fh_p, file=TRIM(fUdmft)//ADJUSTL(TRIM(skii)), status='old', form='unformatted')
        READ(fh_p) numk, nsymop, tnorbitals
     endif
  endif

  if (pform) then
     READ(fh_p,*) iikp, nbands, tmaxdim2, tnorbitals, nemin
  else
     READ(fh_p) iikp, nbands, tmaxdim2, tnorbitals, nemin
  endif

  if (iikp.NE.ikp) print *, 'ERROR: ikp and iikp=', ikp, iikp

  wkii = wkii + 1
END SUBROUTINE ReadDMFT_TransK_Outside

SUBROUTINE ReadDMFT_TransK_Inside(DMFTU, fh_p, pform, isym, nindo, nbands, norbitals, maxdim2)
  ! Continuing reading DMFT transformation
  IMPLICIT NONE
  COMPLEX*16, intent(out) :: DMFTU(nbands,maxdim2,norbitals)
  INTEGER, intent(in)     :: fh_p, isym, nindo(norbitals), nbands, norbitals, maxdim2
  LOGICAL, intent(in)     :: pform
  ! local
  INTEGER :: iisym, iorb, ind, i
  if (pform) then
     READ(fh_p,*) iisym
  else
     READ(fh_p) iisym
  endif
  if (iisym.NE.isym) print *, 'ERROR: isym and iisym=', isym, iisym
  DO iorb=1,norbitals
     DO ind=1,nindo(iorb)
        if (pform) then
           !READ(fh_p,*) (DMFTU(i,ind,iorb),i=1,nbands)
           DO i=1,nbands
              READ(fh_p,'(f16.9,1x,f16.9,3x)',advance='no') DMFTU(i,ind,iorb)
           ENDDO
           READ(fh_p,*)
        else
           READ(fh_p) (DMFTU(i,ind,iorb),i=1,nbands)
        endif
     ENDDO
  ENDDO
  !DO iorb=1,norbitals
  !   DO ind=1,nindo(iorb)
  !      DO i=1,nbands
  !         WRITE(6,'(I2,1x,I2,1x,I2,1x,I3,1x,2f14.9)') iisym,iorb,ind,i,DMFTU(i,ind,iorb)
  !      ENDDO
  !   ENDDO
  !ENDDO
END SUBROUTINE ReadDMFT_TransK_Inside

SUBROUTINE Read_The_Rest_Basic_Arrays(fhb, nindo, cixdim, nl, ll, iorbital, cix, nind, csize, iSx, Sigind, EF, VOL, norbitals, ncix, natom, maxdim, maxdim2)
  IMPLICIT NONE
  INTEGER, intent(in)  :: fhb
  INTEGER, intent(out) :: nindo(norbitals), cixdim(ncix), nl(natom)
  INTEGER, intent(out) :: ll(natom,4), iorbital(natom,4), cix(natom,4), nind(natom,4)
  INTEGER, intent(out) :: csize(ncix), iSx(maxdim2,norbitals), Sigind(maxdim,maxdim,ncix)
  REAL*8, intent(out)  :: EF, VOL
  INTEGER, intent(in)  :: norbitals, ncix, natom, maxdim, maxdim2
  ! locals
  character*100 :: STR
  INTEGER :: iorb, icix, icase, lcase, ip, iq, ip1
  !!! ReadBasicArrays
  READ(fhb, *) STR ! 'nindo'
  READ(fhb, *) (nindo(iorb),iorb=1,norbitals)
  READ(fhb, *) STR ! 'cidim'
  READ(fhb, *) (cixdim(icix),icix=1,ncix)
  READ(fhb, *) STR ! 'nl'
  READ(fhb, *) (nl(icase), icase=1,natom)
  READ(fhb, *) STR ! 'll, iorbital, cix, nind'
  do icase=1,natom
     do lcase=1,nl(icase)
        READ(fhb, *) ll(icase,lcase)
        READ(fhb, *) iorbital(icase,lcase)
        READ(fhb, *) cix(icase,lcase)
        READ(fhb, *) nind(icase,lcase)          ! nind
     enddo
  enddo

  READ(fhb, *) STR ! csize
  READ(fhb, *) (csize(icix), icix=1,ncix)
  READ(fhb, *) STR ! 'iSx'
  do iorb=1,norbitals
     do ip1=1,nindo(iorb)
        READ(fhb, *) iSx(ip1,iorb)
     enddo
  enddo
  READ(fhb, *) STR ! 'Sigind'
  DO icix=1,ncix
     DO ip=1,cixdim(icix)
        DO iq=1,cixdim(icix)
           READ(fhb, *) Sigind(ip,iq,icix)
        ENDDO
     ENDDO
  ENDDO
  READ(fhb, *) STR ! EF
  READ(fhb, *) EF, VOL
END SUBROUTINE Read_The_Rest_Basic_Arrays

SUBROUTINE Transform_To_Reducible(Ve, isym, Vel, opimat, NE, nord)
  IMPLICIT NONE
  COMPLEX*16, intent(out) :: Ve(NE,NE,3)
  INTEGER, intent(in)     :: isym
  COMPLEX*16, intent(in)  :: Vel(NE,NE,3)
  REAL*8, intent(in)      :: opimat(3,3,nord)
  INTEGER, intent(in)     :: NE, nord
  ! locals
  INTEGER    :: ip, iq, i, ii
  COMPLEX*16 :: osm
  ! Changing matrix elements to general k-point
  DO ip=1,NE
     DO iq=1,NE
        do i=1,3
           osm=0
           do ii=1,3
              osm = osm + Vel(ip,iq,ii)*opimat(ii,i,isym)
           end do
           Ve(ip,iq,i) = osm
        end do
     ENDDO
  ENDDO
END SUBROUTINE Transform_To_Reducible

SUBROUTINE Opt_Inside_Simple(copt, Cv, Dv, zekw, k, l, amesh, iw_p, iw_m, wdelta, wgamma, EF, nbands, Nd, bandind, Qinside, nume, Ndirection, NE, nemin, nb_min, nb_max, InterbandOnly)
  IMPLICIT NONE
  COMPLEX*16, intent(out):: copt(Ndirection)
  COMPLEX*16, intent(in) :: Cv(NE,NE,Ndirection), Dv(NE,NE,Ndirection), zekw(NE,2*Nd+1)
  INTEGER, intent(in) :: k, l, amesh(2*Nd+1), iw_p, iw_m, Ndirection
  REAL*8, intent(in)  :: wdelta, wgamma, EF
  INTEGER, intent(in) :: nbands, Nd, bandind(NE), nume, NE, nemin, nb_min, nb_max
  LOGICAL, intent(in) :: InterbandOnly, Qinside(NE)
  ! locals
  REAL*8  :: dx, wdx
  INTEGER :: p, q, dir
  COMPLEX*16  :: eps_p, eps_m, womega, IMAG
  !------------------------------------------------------------------
  DATA IMAG/(0.0D0,1.0D0)/

  eps_p = amesh(iw_p)*wdelta    ! eps
  eps_m = amesh(iw_m)*wdelta    ! eps-omega
  womega = amesh(k+Nd+1)*wdelta ! omega

  dx = womega/k
  !dx=(amesh(Nd+2)-amesh(Nd+1))*wdelta
  wdx=dx
  if (l.EQ.1 .or. l.EQ.k+1) wdx=0.5*dx ! Trapezoid rule integration: the first and last interval has 1/2 of the integration weight
  copt = 0
  DO dir=1,Ndirection
     DO p=nb_min,nb_max
        DO q=nb_min,nb_max
           if (InterbandOnly .and. bandind(p).eq.bandind(q)) CYCLE
           if (.NOT.Qinside(p) .AND. .NOT.Qinside(q) ) CYCLE  !! both p and q are outside the window -> non-interacting problem computed outside
           copt(dir) = copt(dir) + wdx*Cv(p,q,dir)/(     (eps_p+EF-zekw(p,iw_p)+wgamma*IMAG)*(eps_m+EF-zekw(q,iw_m)+wgamma*IMAG))
           copt(dir) = copt(dir) - wdx*Dv(p,q,dir)/(conjg(eps_p+EF-zekw(p,iw_p)+wgamma*IMAG)*(eps_m+EF-zekw(q,iw_m)+wgamma*IMAG))
        ENDDO
     ENDDO
  ENDDO
END SUBROUTINE Opt_Inside_Simple

SUBROUTINE Opt_Inside(copt, Cv, Dv, zekw, k, l, amesh, iw_p, iw_m, wdelta, wgamma, EF, lg_q, lg_p, nbands, Nd, bandind, Qinside, nume, Ndirection, NE, nemin, nb_min, nb_max, InterbandOnly)
  ! Function computes:
  !          Cv(ip,iq)*wes - Dv(ip,iq)*wos
  !          where wes and wos are appropraite weights obtained by integrating over frequency
  !          in a small interval of frequency. Frequency points are given by amesh(:)*wdelta
  IMPLICIT NONE
  COMPLEX*16, intent(out)   :: copt(Ndirection)
  COMPLEX*16, intent(in)    :: Cv(NE,NE,Ndirection), Dv(NE,NE,Ndirection), zekw(NE,2*Nd+1)
  INTEGER, intent(in)       :: k, l, amesh(2*Nd+1), iw_p, iw_m
  REAL*8, intent(in)        :: wdelta, wgamma, EF
  COMPLEX*16, intent(inout) :: lg_q(NE), lg_p(NE)
  INTEGER, intent(in)       :: nbands, Nd, bandind(NE), NE, nume, Ndirection, nb_min, nb_max, nemin
  LOGICAL, intent(in)       :: InterbandOnly, Qinside(NE)
  ! locals
  REAL*8  :: dx, wdx, a, b, womega, eps_p, eps_m, big
  INTEGER :: p, q, dir
  COMPLEX*16 :: denom_es, denom_os, wes, wos
  COMPLEX*16 :: IMAG
  !------------------------------------------------------------------
  DATA IMAG/(0.0D0,1.0D0)/

  big = 1e6

  eps_p = amesh(iw_p)*wdelta    ! eps
  eps_m = amesh(iw_m)*wdelta    ! eps-omega
  womega = amesh(k+Nd+1)*wdelta ! omega

  if (l.EQ.1 .or. iw_p.EQ.1) then        ! The first interval to integrate is smaller
     a=amesh(iw_p)*wdelta
  else
     a=0.5*(amesh(iw_p-1)+amesh(iw_p))*wdelta
  endif
  if (l.eq.k+1 .or. iw_p.EQ.2*Nd+1) then ! The last interval to integrate is smaller
     b=amesh(iw_p)*wdelta
  else                    ! The rest of the intervals are the same
     b=0.5*(amesh(iw_p)+amesh(iw_p+1))*wdelta
  endif

  DO p=nb_min,nb_max
     lg_q(p) = log(b+EF-womega-zekw(p,iw_m)+wgamma*IMAG) - log(a+EF-womega-zekw(p,iw_m)+wgamma*IMAG)
     lg_p(p) = log(b+EF-       zekw(p,iw_p)+wgamma*IMAG) - log(a+EF-       zekw(p,iw_p)+wgamma*IMAG)
  ENDDO

  copt=0
  DO dir=1,Ndirection
     DO p=nb_min,nb_max
        DO q=nb_min,nb_max
           if (InterbandOnly .and. bandind(p).eq.bandind(q)) CYCLE
           if (.NOT.Qinside(p) .AND. .NOT.Qinside(q) ) CYCLE  !! both p and q are outside the window -> non-interacting problem computed outside
           denom_es = womega -       zekw(p,iw_p)  + zekw(q,iw_m)
           denom_os = womega - conjg(zekw(p,iw_p)) + zekw(q,iw_m) -2*wgamma*IMAG
           wes = (lg_q(q)-      lg_p(p)) /denom_es
           wos = (lg_q(q)-conjg(lg_p(p)))/denom_os
           if (abs(wes).gt.big) then
              print *, 'Warning: the weightes is very big at ', womega, eps_p, p, q, wes
              wes=0
           endif
           if (abs(wos).gt.big) then
              print *, 'Warning: the weightos is very big at ', womega, eps_p, p, q, wos
              wos=0
           endif
           copt(dir) = copt(dir) + Cv(p,q,dir)*wes - Dv(p,q,dir)*wos
        ENDDO
     ENDDO
  ENDDO
  RETURN
END SUBROUTINE Opt_Inside

SUBROUTINE FindEigsys(zek, Al, Ar, ix, wsigma, gij, womega, omega, STrans, Ek, nom, ncix, nbands, nemin, maxsize, nume, csize, sigma)
  IMPLICIT NONE
  COMPLEX*16, intent(out)   :: zek(nbands), Al(nbands,nbands), Ar(nbands, nbands)
  INTEGER, intent(inout)    :: ix
  COMPLEX*16, intent(inout) :: wsigma(maxsize, ncix)
  COMPLEX*16, intent(inout) :: gij(nbands,nbands)
  REAL*8, intent(in)     :: womega
  REAL*8, intent(in)     :: omega(nom)
  COMPLEX*16, intent(in) :: STrans(maxsize,ncix,nbands,nbands)
  REAL*8, intent(in)     :: Ek(nume)
  INTEGER, intent(in)    :: nom, ncix, nbands, nemin, maxsize, nume, csize(ncix)
  COMPLEX*16, intent(in) :: sigma(nom, maxsize, ncix)
  ! locals
  INTEGER :: icix, ind, i

  gij=0
  DO i=1,nbands
     gij(i,i) = Ek(i+nemin-1)  !-----  g^-1 of the LDA part in band representation ----!
  ENDDO
  CALL findNext(womega, ix, omega, nom)
  do icix=1,ncix
     do ind=1,csize(icix)
        CALL interp(wsigma(ind,icix), sigma(:,ind,icix), womega, ix, omega, nom)
     enddo
  enddo
  CALL AddSigma_optimized2(gij, wsigma, STrans, csize, 1, nbands, ncix, maxsize)
  CALL eigsys(gij, zek, Al, Ar, nbands)
END SUBROUTINE FindEigsys

SUBROUTINE cmp_C_and_D(Cv, Dv, Al_p, Ar_p, Al_m, Ar_m, Ve, alphaV, Ndirection, L1, L2, L3, L4, Ltmp, Qinside, ndim, NE, nemin, nemax, nb_min, nb_max)
  !--------------------------------------
  IMPLICIT NONE
  !---------- Passed variables ----------
  COMPLEX*16, intent(out)   :: Cv(NE,NE,Ndirection), Dv(NE,NE,Ndirection)
  COMPLEX*16, intent(in)    :: Al_p(ndim,ndim), Ar_p(ndim,ndim), Al_m(ndim,ndim), Ar_m(ndim,ndim)
  COMPLEX*16, intent(in)    :: Ve(NE,NE,3)
  REAL*8, intent(in)        :: alphaV(3,3,Ndirection)
  COMPLEX*16, intent(inout) :: L1(NE,NE,3), L2(NE,NE,3), L3(NE,NE,3), L4(NE,NE,3), Ltmp(ndim,ndim)
  INTEGER, intent(in)       :: ndim, Ndirection, NE, nb_min, nb_max, nemin, nemax
  LOGICAL, intent(in)       :: Qinside(NE)
  !---------- Local variables -----------
  COMPLEX*16 :: Al_p_c(ndim,ndim), Ar_p_c(ndim,ndim)
  COMPLEX*16 :: c1tmp, c2tmp
  INTEGER    :: p,q, i,j,l, dir

  ! Calculation of matrices C and D that are multiplied to the double denominator
  ! C is for equal sign and D for opposite sign
  Al_p_c = conjg(transpose(Al_p))
  Ar_p_c = conjg(transpose(Ar_p))

  DO i=1,3
     ! inside the small window
     Ltmp = matmul(Al_m, Ve(nemin:nemax,nemin:nemax,i))
     L1(nemin:nemax,   nemin:nemax,   i) = matmul(Ltmp, Ar_p)
     L3(nemin:nemax,   nemin:nemax,   i) = matmul(Ltmp, Al_p_c)

     ! cross terms, where one index is inside window, and one is outside
     if (nb_min.LT.nemin) then
        L1(nb_min:nemin-1,nemin:nemax,   i) = matmul(Ve(nb_min:nemin-1,nemin:nemax,i),Ar_p)
        L1(nemin:nemax,   nb_min:nemin-1,i) = matmul(Al_m, Ve(nemin:nemax,nb_min:nemin-1,i))
        L3(nb_min:nemin-1,nemin:nemax,   i) = matmul(Ve(nb_min:nemin-1,nemin:nemax,i), Al_p_c)
        L3(nemin:nemax,   nb_min:nemin-1,i) = L1(nemin:nemax,nb_min:nemin-1,i)
     endif
     if (nb_max.GT.nemax) then
        L1(nemax+1:nb_max,nemin:nemax,   i) = matmul(Ve(nemax+1:nb_max,nemin:nemax,i),Ar_p)
        L1(nemin:nemax,   nemax+1:nb_max,i) = matmul(Al_m, Ve(nemin:nemax,nemax+1:nb_max,i))
        L3(nemax+1:nb_max,nemin:nemax,   i) = matmul(Ve(nemax+1:nb_max,nemin:nemax,i), Al_p_c)
        L3(nemin:nemax,nemax+1:nb_max,   i) = L1(nemin:nemax,nemax+1:nb_max,i)
     endif

     ! inside the small window
     Ltmp = matmul(Ve(nemin:nemax,nemin:nemax,i), Ar_m)
     L2(nemin:nemax,   nemin:nemax,   i) = matmul(Al_p, Ltmp)
     L4(nemin:nemax,nemin:nemax,i) = matmul(Ar_p_c, Ltmp)

     ! cross terms, where one index is inside window, and one is outside
     if (nb_min.LT.nemin) then
        L2(nb_min:nemin-1,nemin:nemax,   i) = matmul(Ve(nb_min:nemin-1,nemin:nemax,i),Ar_m)
        L2(nemin:nemax,   nb_min:nemin-1,i) = matmul(Al_p, Ve(nemin:nemax,nb_min:nemin-1,i))
        L4(nb_min:nemin-1,nemin:nemax,   i) = L2(nb_min:nemin-1,nemin:nemax,   i)
        L4(nemin:nemax,   nb_min:nemin-1,i) = matmul(Al_p_c, Ve(nemin:nemax,nb_min:nemin-1,i))
     endif
     if (nb_max.GT.nemax) then
        L2(nemax+1:nb_max,nemin:nemax,   i) = matmul(Ve(nemax+1:nb_max,nemin:nemax,i),Ar_m)
        L2(nemin:nemax,   nemax+1:nb_max,i) = matmul(Al_p, Ve(nemin:nemax,nemax+1:nb_max,i))
        L4(nemax+1:nb_max,nemin:nemax,   i) = L2(nemax+1:nb_max,nemin:nemax,   i)
        L4(nemin:nemax,   nemax+1:nb_max,i) = matmul(Al_p_c, Ve(nemin:nemax,nemax+1:nb_max,i))
     endif
  ENDDO

  DO p=nb_min,nb_max
     DO q=nb_min,nb_max
        ! When both p and q are outside, we do not need to update Cv and Dv, because they
        ! are equal to v^2.
        if (.NOT.Qinside(p) .AND. .NOT.Qinside(q) ) CYCLE
        DO dir=1,Ndirection
           c1tmp=0
           c2tmp=0
           DO j=1,3
              DO l=1,3
                 c1tmp = c1tmp + L2(p,q,j)*L1(q,p,l)*alphaV(l,j,dir)
                 c2tmp = c2tmp + L4(p,q,j)*L3(q,p,l)*alphaV(l,j,dir)
              ENDDO
           ENDDO
           Cv(p,q,dir) = c1tmp
           Dv(p,q,dir) = c2tmp
        ENDDO
     ENDDO
  ENDDO
END SUBROUTINE cmp_C_and_D

SUBROUTINE cmp_C_and_D_old(Cv, Dv, Al_p, Ar_p, Al_m, Ar_m, Ve, alphaV, Ndirection, L1, L2, L3, L4, Ltmp, ndim)
  !--------------------------------------
  IMPLICIT NONE
  !---------- Passed variables ----------
  COMPLEX*16, intent(out)   :: Cv(ndim,ndim,Ndirection), Dv(ndim,ndim,Ndirection)
  COMPLEX*16, intent(in)    :: Al_p(ndim,ndim), Ar_p(ndim,ndim), Al_m(ndim,ndim), Ar_m(ndim,ndim)
  COMPLEX*16, intent(in)    :: Ve(ndim,ndim,3)
  REAL*8, intent(in)        :: alphaV(3,3,Ndirection)
  COMPLEX*16, intent(inout) :: L1(ndim,ndim,3), L2(ndim,ndim,3), L3(ndim,ndim,3), L4(ndim,ndim,3), Ltmp(ndim,ndim)
  INTEGER, intent(in)       :: ndim, Ndirection
  !---------- Local variables -----------
  COMPLEX*16 :: c1tmp, c2tmp
  INTEGER    :: p,q, i,j,l, dir

  ! Calculation of matrices C and D that are multiplied to the double denominator
  ! C is for equal sign and D for opposite sign
  DO i=1,3
     Ltmp = matmul(Al_m, Ve(:,:,i))
     L1(:,:,i) = matmul(Ltmp, Ar_p)
     L3(:,:,i) = matmul(Ltmp, conjg(transpose(Al_p)))
     Ltmp = matmul(Ve(:,:,i), Ar_m)
     L2(:,:,i) = matmul(Al_p, Ltmp)
     L4(:,:,i) = matmul(conjg(transpose(Ar_p)), Ltmp)
  ENDDO
  Cv = 0
  Dv = 0
  DO p=1,ndim
     DO q=1,ndim
        DO dir=1,Ndirection
           c1tmp=0
           c2tmp=0
           DO j=1,3
              DO l=1,3
                 c1tmp = c1tmp + L2(p,q,j)*L1(q,p,l)*alphaV(l,j,dir)
                 c2tmp = c2tmp + L4(p,q,j)*L3(q,p,l)*alphaV(l,j,dir)
              ENDDO
           ENDDO
           Cv(p,q,dir) = Cv(p,q,dir) + c1tmp
           Dv(p,q,dir) = Dv(p,q,dir) + c2tmp
        ENDDO
     ENDDO
  ENDDO

END SUBROUTINE cmp_C_and_D_old

SUBROUTINE Opt_Noncorrelated(copt, Cv0, Ek, womega, EF, wgamma,nb_min, nb_max, nemin, nemax, nume, Qinside, NE, Ndirection, InterbandOnly)
!!! Add non-correlated bands !!!
  IMPLICIT NONE
!!! For non-correlated
  COMPLEX*16, intent(out) :: copt(Ndirection)
  COMPLEX*16, intent(in) :: Cv0(NE,NE,Ndirection)
  REAL*8, intent(in)     :: Ek(nume)
  REAL*8, intent(in)  :: womega, EF
  REAL*8, intent(in)  :: wgamma
  INTEGER, intent(in) :: nb_min, nb_max, nemin, nemax, nume, NE, Ndirection
  LOGICAL, intent(in) :: InterbandOnly, Qinside(NE)
  ! local variables
  REAL*8     :: aw, bw
  INTEGER    :: ip, iq, dir
  COMPLEX*16 :: denom_es, denom_os, wes, wos
  COMPLEX*16, ALLOCATABLE :: lg_p(:), lg_q(:)
  COMPLEX*16, PARAMETER  :: IMAG = (0.0D0,1.0D0)

  ALLOCATE( lg_p(nb_max), lg_q(nb_max) )

  aw=0.0
  bw=womega
  DO ip=nb_min,nb_max
     if (Qinside(ip)) CYCLE ! These bands were taken into account in DMFT part
     lg_q(ip) = log(bw+EF-womega-Ek(ip)+wgamma*IMAG) - log(aw+EF-womega-Ek(ip)+wgamma*IMAG)
     lg_p(ip) = log(bw+EF-       Ek(ip)+wgamma*IMAG) - log(aw+EF-       Ek(ip)+wgamma*IMAG)
  ENDDO
  copt=0
  DO ip=nb_min,nb_max

     !if (InterbandOnly .OR. (ip.GE.nemin .and.ip.LE.nemax)) CYCLE ! These bands were taken into account in DMFT part
     DO iq=nb_min,nb_max

        if ( Qinside(ip) .or. Qinside(iq) ) CYCLE ! These bands were taken into account in DMFT part

        denom_es = womega - Ek(ip) + Ek(iq)
        denom_os = womega - Ek(ip) + Ek(iq) -2*wgamma*IMAG
        wes = (lg_q(iq)-      lg_p(ip)) /denom_es
        wos = (lg_q(iq)-conjg(lg_p(ip)))/denom_os
        DO dir=1,Ndirection
           copt(dir) = copt(dir) + Cv0(ip,iq,dir)*(wes - wos)
        ENDDO
     ENDDO
  ENDDO
  DEALLOCATE( lg_p, lg_q )
END SUBROUTINE Opt_Noncorrelated

program read_optm
  USE com_mpi, ONLY: start_MPI, stop_MPI
  IMPLICIT NONE
  ! functions
  INTEGER :: CountSelfenergy
  ! variables
  CHARACTER*100 :: case, fmommat, fsymop, fUdmft, fenergy, fbasicArrays, fsigname
  CHARACTER*2   :: updn, dnup, so
  INTEGER :: fhb, fhi, fh_m
  CHARACTER*100 :: STR
  INTEGER :: nom, nk, iso, nat, norbitals, ncix, natom, nkpt, nmat, nume, lmax2, maxdim2, maxdim, maxsize
  LOGICAL :: Qsym, Qsimple, Qcomplex, InterbandOnly, ProjectToCorrelated
  REAL*8  :: gamma, gammac, ommax, delta, dwindow, Temperature
  INTEGER :: Nd, Nd0, i, j, l
  CHARACTER*5 :: adum
  INTEGER :: Ndirection
  LOGICAL :: file_exists
  REAL*8, ALLOCATABLE :: alphaV(:,:,:)

  CALL start_MPI()

  Qsimple = .False.
  updn=''
  fhi = 995
  open(fhi, file='dmftopt.in', status='old', form='formatted')
  READ(fhi, *) Temperature
  READ(fhi, *) case
  READ(fhi, *) gamma
  READ(fhi, *) gammac
  READ(fhi, *) ommax
  READ(fhi, *) delta
  READ(fhi, *) Nd0
  READ(fhi, *) Qsym
  READ(fhi, *) InterbandOnly
  READ(fhi, *) dwindow
  READ(fhi, *) Ndirection
  print *, 'Ndirection=', Ndirection
  ALLOCATE( alphaV(3,3,Ndirection) )
  do l=1,Ndirection
     READ(fhi, *) alphaV(1,1,l), alphaV(1,2,l), alphaV(1,3,l)
     READ(fhi, *) alphaV(2,1,l), alphaV(2,2,l), alphaV(2,3,l)
     READ(fhi, *) alphaV(3,1,l), alphaV(3,2,l), alphaV(3,3,l)
  enddo
  close(fhi)

  !if (.NOT.(updn.EQ.'up' .OR.updn.EQ.'dn')) updn=''
  !!
  !dnup='dn'
  !IF (updn.EQ.'dn') THEN
  !   dnup = 'up'
  !ELSEIF (updn.EQ.'up') THEN
  !   dnup = 'dn'
  !ELSE
  !   updn = ''
  !ENDIF
  !!

  !!! Counting the number of frequency points in self-energy
  fsigname = 'sig.inp'//TRIM(updn)//'1'
  print *, 'fsigname=', fsigname
  open(81, file=fsigname, status='old', form='formatted')
  nom = CountSelfenergy(81, 1)-1 !--- How many frequency point exists in the input file? ---!
  close(81)

  fbasicArrays = 'BasicArrays.dat'
  !!! Reading the first part of the header file to get dimensions
  fhb=996
  open(fhb,file=fbasicArrays,status='old', form='formatted')
  READ(fhb, *) STR ! 'nat, iso, norbitals, ncix, natom'
  READ(fhb, *) nat, iso, norbitals, ncix, natom
  READ(fhb, *) STR ! nkpt, nmat, nume
  READ(fhb, *) nkpt, nmat, nume
  READ(fhb, *) STR ! Qcomplex
  READ(fhb, *) Qcomplex
  READ(fhb, *) STR ! 'lmax2, maxdim2, maxdim, maxsize'
  READ(fhb, *) lmax2, maxdim2, maxdim, maxsize

  so = ''
  IF (iso.EQ.2) so='so'
  fenergy = TRIM(case)//'.energy'//TRIM(so)//TRIM(updn)
  fmommat = TRIM(case)//'.mommat'//TRIM(updn)
  fsymop = TRIM(case)//'.symop'
  fUdmft = 'Udmft'//TRIM(updn)//'.'

  fh_m = 99  ! file for velocity matrix elements

  INQUIRE(file=fmommat, exist=file_exists)
  if (.not. file_exists) then
     fmommat = TRIM(case)//'.mommat2'//TRIM(updn)
     INQUIRE(file=fmommat, exist=file_exists)
     if (.not. file_exists) WRITE(*,*) 'ERROR File not found: Expecting that ', fmommat, 'exists.'
  endif
  open(fh_m, file=fmommat, status='old')

  if (Temperature.NE.0.0) then
     ! We will use linear mesh only. We need to set very large Nd, so that
     ! cutoff >=4*T, and ommax/(2*delta)=Nd
     if (Nd0 .LT. int(2*Temperature/Delta+1.)) Nd0=int(2*Temperature/Delta+1.)
     if (ommax.LT.2*Nd0*delta) then
        ommax=2*Nd0*delta
     else
        Nd0 = ommax/(2*delta)
     endif
  endif

  WRITE(*,'(A,A)') 'case=', TRIM(case)
  WRITE(*,'(A,f10.7,1x,A,f10.7)') 'gamma=', gamma, 'gammac=', gammac
  WRITE(*,'(A,f10.3,1x,A,f14.10,1x,A,I4)') 'ommax=', ommax, 'delta=', delta, 'Nd=', Nd0
  WRITE(*,'(A,L)') 'Qsym=', Qsym
  WRITE(*, '(A)') 'alphaV='
  WRITE(*,*) (((alphaV(j,i,l), i=1,3), j=1,3),l=1,Ndirection)
  WRITE(*,'(A,A)') 'fmommat=', fmommat
  WRITE(*,'(A,A)') 'fenergy=', fenergy
  WRITE(*,'(A,A)') 'fUdmft=', fUdmft
  WRITE(*,'(A,A)') 'fsymop=', fsymop
  WRITE(*,'(A,L)') 'InterbandOnly=', InterbandOnly
  WRITE(*,'(A,f10.7)') 'dwindow=', dwindow
  WRITE(*,'(A,f10.7)') 'Temperature=', Temperature

  Nd = 2*Nd0
  CALL Cmp_Optics(fenergy, fUdmft, fsymop, fh_m, fhb, ommax, Temperature, delta, Nd, gammac, gamma, alphaV, Ndirection, Qsym, Qsimple, nom, nat, iso, norbitals, ncix, natom, nkpt, nmat, nume, Qcomplex, lmax2, maxdim2, maxdim, maxsize, dwindow, InterbandOnly)

  close(fh_m)
  DEALLOCATE( alphaV )
  CALL stop_MPI()

end program read_optm

REAL*8 Function ferm(x)
  IMPLICIT NONE
  REAL*8, intent(in):: x
  if (x.gt.100) then
     ferm=0.0
     return
  endif
  if (x.lt.-100) then
     ferm=1.0
     return
  endif
  ferm = 1./(1.+exp(x))
  return
end function ferm


!**********************************************************************************************************************************
! LICENSING
! Copyright (C) 2015-2016  National Renewable Energy Laboratory
! Copyright (C) 2016-2017  Envision Energy USA, LTD
!
!    This file is part of the NWTC Subroutine Library.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!**********************************************************************************************************************************
PROGRAM BeamDyn_Driver_Program

   USE BeamDyn_driver_subs  ! all other modules inherited through this one
   USE VersionInfo

   IMPLICIT NONE

   ! global glue-code-specific variables

   INTEGER(IntKi)                   :: ErrStat          ! Error status of the operation
   CHARACTER(1024)                  :: ErrMsg           ! Error message if ErrStat /= ErrID_None
   REAL(DbKi)                       :: dt_global        ! fixed/constant global time step
   REAL(DbKi)                       :: t_global         ! global-loop time marker
   INTEGER(IntKi)                   :: n_t_final        ! total number of time steps
   INTEGER(IntKi)                   :: n_t_global       ! global-loop time counter
   INTEGER(IntKi), parameter        :: BD_interp_order = 1  ! order of interpolation/extrapolation

   ! Module1 Derived-types variables; see Registry_Module1.txt for details

   TYPE(BD_InitInputType)           :: BD_InitInput
   TYPE(BD_ParameterType)           :: BD_Parameter
   TYPE(BD_ContinuousStateType)     :: BD_ContinuousState
   TYPE(BD_InitOutputType)          :: BD_InitOutput
   TYPE(BD_DiscreteStateType)       :: BD_DiscreteState
   TYPE(BD_ConstraintStateType)     :: BD_ConstraintState
   TYPE(BD_OtherStateType)          :: BD_OtherState
   TYPE(BD_MiscVarType)             :: BD_MiscVar
   TYPE(BD_InputType) ,ALLOCATABLE  :: BD_Input(:)
   REAL(DbKi),         ALLOCATABLE  :: BD_InputTimes(:)
   TYPE(BD_OutputType)              :: BD_Output
   INTEGER(IntKi)                   :: DvrOut

   TYPE(BD_DriverInternalType)      :: DvrData

   ! local variables

   CHARACTER(256)                   :: DvrInputFile
   CHARACTER(256)                   :: RootName
   INTEGER(IntKi)                   :: j             ! counter for various loops
   INTEGER(IntKi)                   :: i             ! counter for various loops
   INTEGER(IntKi)                   :: max_ld_step=8 ! maximum load steps for static runs.
   REAL(DbKi)                       :: TiLstPrn      ! The simulation time of the last print (to file) [(s)]
   REAL(ReKi)                       :: PrevClockTime ! Clock time at start of simulation in seconds [(s)]
   REAL(ReKi)                       :: UsrTime1      ! User CPU time for simulation initialization [(s)]
   REAL(ReKi)                       :: UsrTime2      ! User CPU time for simulation (without intialization) [(s)]
   INTEGER(IntKi) , DIMENSION(1:8)  :: StrtTime      ! Start time of simulation (including intialization) [-]
   INTEGER(IntKi) , DIMENSION(1:8)  :: SimStrtTime   ! Start time of simulation (after initialization) [-]
   CHARACTER(200)                   :: git_commit    ! String containing the current git commit hash

   TYPE(ProgDesc), PARAMETER        :: version   = ProgDesc( 'BeamDyn Driver', '', '' )  ! The version number of this program.

   ! -------------------------------------------------------------------------
   ! Initialization of library (especially for screen output)
   ! -------------------------------------------------------------------------

   CALL DATE_AND_TIME ( Values=StrtTime )                 ! Let's time the whole simulation
   CALL CPU_TIME ( UsrTime1 )                             ! Initial time (this zeros the start time when used as a MATLAB function)
   UsrTime1 = MAX( 0.0_ReKi, UsrTime1 )                   ! CPU_TIME: If a meaningful time cannot be returned, a processor-dependent negative value is returned

   CALL NWTC_Init()
      ! Display the copyright notice
   CALL DispCopyrightLicense( version%Name )
      ! Obtain OpenFAST git commit hash
   git_commit = QueryGitVersion()
      ! Tell our users what they're running
   CALL WrScr( ' Running '//TRIM( version%Name )//' a part of OpenFAST - '//TRIM(git_Commit)//NewLine//' linked with '//TRIM( NWTC_Ver%Name )//NewLine )

   ! -------------------------------------------------------------------------
   ! Initialization of glue-code time-step variables
   ! -------------------------------------------------------------------------

   CALL GET_COMMAND_ARGUMENT(1,DvrInputFile)
   CALL GetRoot(DvrInputFile,RootName)
   CALL BD_ReadDvrFile(DvrInputFile,dt_global,BD_InitInput,DvrData,ErrStat,ErrMsg)
      CALL CheckError()

      ! initialize the BD_InitInput values not in the driver input file
   BD_InitInput%RootName = TRIM(BD_Initinput%InputFile)
   BD_InitInput%RootDisp = matmul(transpose(BD_InitInput%RootOri),BD_InitInput%GlbPos) - BD_InitInput%GlbPos
   BD_InitInput%RootVel(1:3) = matmul(BD_InitInput%RootOri, Cross_Product( BD_InitInput%RootVel(4:6), BD_InitInput%GlbPos ))  ! set translational velocities based on rotation and GlbPos.
   BD_InitInput%DynamicSolve = DvrData%DynamicSolve      ! QuasiStatic options handled within the BD code.

   t_global = DvrData%t_initial
   n_t_final = ((DvrData%t_final - DvrData%t_initial) / dt_global )

   !Module1: allocate Input and Output arrays; used for interpolation and extrapolation
   ALLOCATE(BD_Input(BD_interp_order + 1))
   ALLOCATE(BD_InputTimes(BD_interp_order + 1))

   CALL BD_Init(BD_InitInput             &
                   , BD_Input(1)         &
                   , BD_Parameter        &
                   , BD_ContinuousState  &
                   , BD_DiscreteState    &
                   , BD_ConstraintState  &
                   , BD_OtherState       &
                   , BD_Output           &
                   , BD_MiscVar          &
                   , dt_global           &
                   , BD_InitOutput       &
                   , ErrStat             &
                   , ErrMsg )
      CALL CheckError()

      ! If the Quasi-Static solve is in use, rerun the initialization with loads at t=0
      ! (HACK: set in the driver only because computing Jacobians with this option [as in FAST glue code] is problematic)
   BD_OtherState%RunQuasiStaticInit = BD_Parameter%analysis_type == BD_DYN_SSS_ANALYSIS

     ! Set the Initial root orientation
   BD_Input(1)%RootMotion%Orientation(1:3,1:3,1) = DvrData%RootRelInit

   call Init_RotationCenterMesh(DvrData, BD_InitInput, BD_Input(1)%RootMotion, ErrStat, ErrMsg)
      CALL CheckError()

   call CreateMultiPointMeshes(DvrData,BD_InitInput,BD_InitOutput,BD_Parameter, BD_Output, BD_Input(1), ErrStat, ErrMsg)
   call Transfer_MultipointLoads(DvrData, BD_Output, BD_Input(1), ErrStat, ErrMsg)

   CALL Dvr_InitializeOutputFile(DvrOut,BD_InitOutput,RootName,ErrStat,ErrMsg)
      CALL CheckError()

      ! initialize BD_Input and BD_InputTimes
   BD_InputTimes(1) = DvrData%t_initial
   CALL BD_InputSolve( BD_InputTimes(1), BD_Input(1), DvrData, ErrStat, ErrMsg)

   DO j = 2,BD_interp_order+1
         ! create new meshes
      CALL BD_CopyInput (BD_Input(1) , BD_Input(j) , MESH_NEWCOPY, ErrStat, ErrMsg)
         CALL CheckError()

         ! solve for inputs at previous time steps
      BD_InputTimes(j) = DvrData%t_initial - (j - 1) * dt_global
      CALL BD_InputSolve( BD_InputTimes(j), BD_Input(j), DvrData, ErrStat, ErrMsg)
         CALL CheckError()
   END DO

      !.........................
      ! calculate outputs at t=0
      !.........................
   CALL SimStatus_FirstTime( TiLstPrn, PrevClockTime, SimStrtTime, UsrTime2, t_global, DvrData%t_final )

   CALL BD_CalcOutput( t_global, BD_Input(1), BD_Parameter, BD_ContinuousState, BD_DiscreteState, &
                           BD_ConstraintState, BD_OtherState,  BD_Output, BD_MiscVar, ErrStat, ErrMsg)
      CALL CheckError()

   CALL Dvr_WriteOutputLine(t_global,DvrOut,BD_Parameter%OutFmt,BD_Output)

      !.........................
      ! time marching
      !.........................

   DO n_t_global = 0, n_t_final

      ! Shift "window" of BD_Input
      DO j = BD_interp_order, 1, -1
         CALL BD_CopyInput (BD_Input(j),  BD_Input(j+1),  MESH_UPDATECOPY, Errstat, ErrMsg)
            CALL CheckError()
         BD_InputTimes(j+1) = BD_InputTimes(j)
      END DO

      BD_InputTimes(1)  = t_global + dt_global
      CALL BD_InputSolve( BD_InputTimes(1), BD_Input(1), DvrData, ErrStat, ErrMsg)
         CALL CheckError()

     IF(BD_Parameter%analysis_type .EQ. BD_STATIC_ANALYSIS .AND. n_t_global > max_ld_step) EXIT

      ! update states from n_t_global to n_t_global + 1
     CALL BD_UpdateStates( t_global, n_t_global, BD_Input, BD_InputTimes, BD_Parameter, &
                               BD_ContinuousState, &
                               BD_DiscreteState, BD_ConstraintState, &
                               BD_OtherState, BD_MiscVar, ErrStat, ErrMsg )
        CALL CheckError()

      ! advance time
     t_global = (n_t_global+1) * dt_global + DvrData%t_initial

      ! calculate outputs at n_t_global + 1
     CALL BD_CalcOutput( t_global, BD_Input(1), BD_Parameter, BD_ContinuousState, BD_DiscreteState, &
                             BD_ConstraintState, BD_OtherState,  BD_Output, BD_MiscVar, ErrStat, ErrMsg)
        CALL CheckError()

     CALL Dvr_WriteOutputLine(t_global,DvrOut,BD_Parameter%OutFmt,BD_Output)

     if ( MOD( n_t_global + 1, 100 ) == 0 ) call SimStatus( TiLstPrn, PrevClockTime, t_global, DvrData%t_final )
   ENDDO

   CALL RunTimes( StrtTime, UsrTime1, SimStrtTime, UsrTime2, t_global )

   CALL Dvr_End()

CONTAINS
!----------------------------------------------------------------------------------------------------------------------------------
   SUBROUTINE Dvr_End()

      character(ErrMsgLen)                          :: errMsg2                 ! temporary Error message if ErrStat /=
      integer(IntKi)                                :: errStat2                ! temporary Error status of the operation
      character(*), parameter                       :: RoutineName = 'Dvr_End'

      IF(DvrOut >0) CLOSE(DvrOut)

      IF ( ALLOCATED(BD_Input) ) THEN
         CALL BD_End( BD_Input(1), BD_Parameter, BD_ContinuousState, BD_DiscreteState, &
               BD_ConstraintState, BD_OtherState, BD_Output, BD_MiscVar, ErrStat2, ErrMsg2 )
            call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )

         DO i=2,BD_interp_order + 1
            CALL BD_DestroyInput( BD_Input(i), ErrStat2, ErrMsg2 )
            call SetErrStat( errStat2, errMsg2, errStat, errMsg, RoutineName )
         ENDDO

         DEALLOCATE(BD_Input)
      END IF

      IF(ALLOCATED(BD_InputTimes )) DEALLOCATE(BD_InputTimes )
      if(allocated(DvrData%MultiPointLoad)) deallocate(DvrData%MultiPointLoad)

      if (ErrStat >= AbortErrLev) then
         CALL ProgAbort( 'BeamDyn Driver encountered simulation error level: '&
             //TRIM(GetErrStr(ErrStat)), TrapErrors=.FALSE., TimeWait=3._ReKi )  ! wait 3 seconds (in case they double-clicked and got an error)
      else
         call NormStop()
      end if
   END SUBROUTINE Dvr_End
!----------------------------------------------------------------------------------------------------------------------------------
   subroutine CheckError()

      if (ErrStat /= ErrID_None) then
         call WrScr(TRIM(ErrMsg))

         if (ErrStat >= AbortErrLev) then
            call Dvr_End()
         end if
      end if

   end subroutine CheckError

END PROGRAM BeamDyn_Driver_Program


      PROGRAM MAKPOS
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1996 Oliver Smart & Birkbeck College,                        *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date  Author          Modification
C 11/96 O.S. Smart        Original version
C 28/02/97 O.S.S.	Release HOLE2 beta001
C
C Reads a special file produced by HOLE to
C produce a pretty residue number/ chain id post map in surfer

C screen, keyboard
      INTEGER                   NIN
      PARAMETER(                NIN = 5)
      INTEGER                   NOUT
      PARAMETER(                NOUT= 6)
C input/output file stream
      INTEGER                   SIN, SOUT

C filename
      CHARACTER*200             FNAME

C abort indicator
      LOGICAL                   LABORT

C array limits for the storage of the chain id/resid matrix
      INTEGER			SAXMAX, SAYMAX
      PARAMETER(			SAXMAX = 75)
      PARAMETER(			SAYMAX = 300)

C the number of elements, x and y
      INTEGER			SAXNUM, SAYNUM

C the value of real variable (angle and channel coord)
      DOUBLE PRECISION		SAXLOW, SAXHIG,
     &  				SAYLOW, SAYHIG

C the storage arrays (n.b. must preserve edge)
      INTEGER			SARNO( 0:SAXMAX+1, 0:SAYMAX+1)
      CHARACTER*1			SACHN( 0:SAXMAX+1, 0:SAYMAX+1)
      DOUBLE PRECISION		SADIS( SAXMAX, SAYMAX)

C string for read
      CHARACTER*80		LINE

C loop count for x and y, inner loop x and y
      INTEGER			XCOUNT, YCOUNT, JCOUNT, ICOUNT
C loop count for working list and direction
      INTEGER			WCOUNT, UCOUNT

C scale factor between x and y in "distance" calc.
      DOUBLE PRECISION		YSCALE

C big store i.e store for which label is the one furthest from
C a neighbouring field
      DOUBLE PRECISION		BIGX, BIGY, BIGVAL

C vble for distance calc
      DOUBLE PRECISION		DIST

C test point
      DOUBLE PRECISION		TESTP(2)

C working list for connecting residues
C array bound limit
      INTEGER			WNMAX
      PARAMETER(		WNMAX = 2000)
      INTEGER			WORKXY(2,WNMAX), NEWPXY(2,WNMAX)
      INTEGER			WORKNO, NEWPNO

C end of decs ******************

C write greeting
      WRITE( NOUT, '(A)')
     &' *** Program make_post_map ***',
     &' ',
     &' Copyright 1997 by Oliver Smart and Birkbeck College',
     &' Copyright 2004 by Oliver Smart ',
     &' Program modification number 2.2 001'

C write link time of program to screen
      CALL VERTIM( NOUT)
      WRITE( NOUT, *)

C use s/r lastf to find latest file of
C type in the directory.  N.b. only works on unix machines
      CALL LASTF( FNAME, '.hole')
      IF (FNAME(1:4).EQ.'none') FNAME = 'input'

C get input filename
      LABORT = .TRUE.
C (input stream, output, oldfile?, file_stream, file_type, name,
C  allow abort?, default extension)
C N.B. as file_type includes 'BINARY' then will open as binary
      CALL INTERF( NIN, NOUT, .TRUE., SIN,
     &  'input hole format', FNAME, LABORT, '.hole')
      IF (LABORT) GOTO 55555

C get output filename
      LABORT = .TRUE.
      CALL INTERF( NIN, NOUT, .FALSE., SOUT,
     &  'output SURFER posting format ', FNAME, LABORT, '.dat')
      IF (LABORT) GOTO 55555

C write header in output file
      WRITE( SOUT, '(A,A)')
     & '"Ca angle" "Ca disp" "labRNO"',
     &  ' "labCHN" "labRNOCHN" "labelRNO:CHN" "size-of-patch"'

C read input
C first blank lines
      READ( SIN, '(A)') LINE

C read array sizes
      READ( SIN, '(BN,2I10)') SAXNUM, SAYNUM

C check array sizes
      IF (SAXNUM.GT.SAXMAX) THEN
        WRITE( NOUT, '(A/ A,I5/ A,I5,A/ A)')
     &' Error in make_post_map '//CHAR(7),
     &'   Array bound SAXMAX exceeded  increase from ', SAXMAX,
     &'   to above ', SAXNUM, ' recompile and link etc. ',
     &' Cannot proceed********************'
        GOTO 55555
      ENDIF
      IF (SAYNUM.GT.SAYMAX) THEN
        WRITE( NOUT, '(A/ A,I5/ A,I5,A/ A)')
     &' Error in make_post_map '//CHAR(7),
     &'   Array bound SAYMAX exceeded  increase from ', SAYMAX,
     &'   to above ', SAYNUM, ' recompile and link etc. ',
     &' Cannot proceed********************'
        GOTO 55555
      ENDIF

C read x and y limits
      READ( SIN, '(BN,2F6.1)') SAXLOW, SAXHIG
      READ( SIN, '(BN,2F12.5)') SAYLOW, SAYHIG

C tell user info
      WRITE( NOUT, '(/A,2(I6,A)/ 2(A,2F10.3:/))')
     &' input file has info for', SAXNUM, ' rows and',
     &				SAYNUM, ' columns ',
     &' Data limits X= ', SAXLOW, SAXHIG,
     &' Data limits Y= ', SAYLOW, SAYHIG

C read in the data - go thru rows
      DO 10 YCOUNT = 1, SAYNUM
C now go thru columns
C zeroth element set to be default - different to all others
        SACHN(0,YCOUNT) = ']'
        SARNO(0,YCOUNT) = -7676
        DO 20 XCOUNT = 1, SAXNUM
C read element from input file
          READ( SIN, '(A1,I6)', END= 900, ERR=900)
     &      SACHN(XCOUNT,YCOUNT), SARNO(XCOUNT,YCOUNT)
C end of read for column XCOUNT
20      CONTINUE
C last element set to be default - different to all others
        SACHN(SAXNUM+1,YCOUNT) = ']'
        SARNO(SAXNUM+1,YCOUNT) = -7676
C end of read for row YCOUNT
10    CONTINUE

C set upper and lower edge to different values
      DO 30 XCOUNT = 0, SAXNUM+1
        SACHN(XCOUNT,0)        = ']'
        SARNO(XCOUNT,0)        = -7676
        SACHN(XCOUNT,SAYNUM+1) = ']'
        SARNO(XCOUNT,SAYNUM+1) = -7676
30    CONTINUE

C everthing set up - shut input file
      CLOSE( SIN)

C work out scale factor between y and xcoords -
C assume final map will be square (could get scale
C factor from user but probably not worth it)
       YSCALE = FLOAT(SAXNUM)/FLOAT(SAYNUM)

C work out the closest distance matrix
      DO 40 YCOUNT = 1, SAYNUM
        DO 50 XCOUNT = 1, SAXNUM
C need to find element sadis(xcount,ycount)
C the distance of the closest element of the matrix which is
C different from this residue
C Q: do we have to be sophisticated - i.e. is it o.k. just to work out all
C distances - n**4 calc? Or do we need to be clever?
C takes about 30 sec cpu - not too bad
           SADIS(XCOUNT,YCOUNT) = 1E10
C must include edges in consideration
           DO 60 ICOUNT = 0, SAYNUM+1
             DO 70 JCOUNT = 0, SAXNUM+1
C is the element the same as (xcount,ycount)?
                IF ((SACHN(JCOUNT,ICOUNT).EQ.SACHN(XCOUNT,YCOUNT)).AND.
     &              (SARNO(JCOUNT,ICOUNT).EQ.SARNO(XCOUNT,YCOUNT))
     &		    					         ) THEN
C yes - do nothing
                  CONTINUE
                ELSE
C no - ask the question is it the closest different element
C work out distance between element (xcount,ycount) and (jcount,icount)
C DO NOT DO SQRT - no need just compare squares
                  DIST = (XCOUNT-JCOUNT)**2 +
     &                   (YSCALE*(YCOUNT-ICOUNT))**2
C smallest yet?
                  IF (DIST.LT.SADIS(XCOUNT,YCOUNT))
     &              SADIS(XCOUNT,YCOUNT) = DIST
                ENDIF
70           CONTINUE
60         CONTINUE
C have found element sadis(xcount,ycount) - look for next!

50      CONTINUE
40    CONTINUE
C have filled SADIS

C will jump back here after each label written
8989  CONTINUE

C find biggest element in sadis
        BIGVAL = -1e10
        DO 140 YCOUNT = 1, SAYNUM
          DO 150 XCOUNT = 1, SAXNUM
            IF (SADIS(XCOUNT,YCOUNT).GT.BIGVAL) THEN
              BIGVAL = SADIS(XCOUNT,YCOUNT)
              BIGX = XCOUNT
              BIGY = YCOUNT
            ENDIF
150       CONTINUE
140     CONTINUE

C have we labelled all patches?
        IF (BIGVAL.LT.0) GOTO 55555

C for current matrix BIGVAL is the biggest value label - write it out
        WRITE( SOUT, '(2F8.3,I6,A1,A1, I6,A1, I6,A1,A1, F8.2)')
     &    SAXLOW + ((SAXHIG-SAXLOW)*BIGX)/FLOAT(SAXNUM),
     &    SAYLOW + ((SAYHIG-SAYLOW)*BIGY)/FLOAT(SAYNUM),
     &    SARNO(BIGX,BIGY), ' ', SACHN(BIGX,BIGY),
     &    SARNO(BIGX,BIGY),  SACHN(BIGX,BIGY),
     &    SARNO(BIGX,BIGY), ':', SACHN(BIGX,BIGY), SQRT(BIGVAL)

C o.k. we have written a label for a particular - must eliminate
C whole connected patch from consideration
C first cancel the point itself
        SADIS( BIGX, BIGY) = -1e10
C
C use routine - have "working points" which we have to examine all 4 points
C which surround (above, below, left and right) to see whether
C these (a) have the same resid as bigx, bigy point AND
C       (b) have not already been canceled
C when a point is canceled should be added to  "new points"
C at the end of a cycle "new points" overwrite "working points"
C and we repeat until no "new points" are found
        WORKNO = 1
        WORKXY(1,1) = BIGX
        WORKXY(2,1) = BIGY

C do until workno=0
345     CONTINUE
        IF (WORKNO.EQ.0) THEN
          CONTINUE

        ELSE

C have some points to work on
C initialize new arrays
          NEWPNO =0
C          write(*,*) ' number of working points ', workno

C go thru the working list
          DO 880 WCOUNT = 1, WORKNO
C look above below, left and right of the working point
            DO 890 UCOUNT = 1, 4
               IF     (UCOUNT.EQ.1) THEN
C up
                 TESTP(1) = WORKXY(1,WCOUNT)
                 TESTP(2) = WORKXY(2,WCOUNT) + 1
               ELSEIF (UCOUNT.EQ.2) THEN
C down
                 TESTP(1) = WORKXY(1,WCOUNT)
                 TESTP(2) = WORKXY(2,WCOUNT) - 1
               ELSEIF (UCOUNT.EQ.3) THEN
C right
                 TESTP(1) = WORKXY(1,WCOUNT) + 1
                 TESTP(2) = WORKXY(2,WCOUNT)
               ELSE
C left
                 TESTP(1) = WORKXY(1,WCOUNT) - 1
                 TESTP(2) = WORKXY(2,WCOUNT)
               ENDIF
C look above the current point i.e. at point workxy(1,wcount), workxy(2,wcount)+1
C is it already cancelled?
               IF (SADIS(TESTP(1),TESTP(2)) .GT. 0) THEN
C no!
C does it have the relevant id?
                 IF ( (SARNO(TESTP(1),TESTP(2)).EQ.SARNO(BIGX,BIGY))
     &                                                          .AND.
     &                (SACHN(TESTP(1),TESTP(2)).EQ.SACHN(BIGX,BIGY))
     &						       	       ) THEN
C has the relevant id so (a) cancel it and
C (b) add it to the new-points list
                   SADIS(TESTP(1),TESTP(2)) =  -1e10
C put a check on array bound here
                   NEWPNO = NEWPNO + 1
                   NEWPXY(1,NEWPNO) = TESTP(1)
                   NEWPXY(2,NEWPNO) = TESTP(2)
                 ENDIF
		   ENDIF
890         CONTINUE
880       CONTINUE

C have gone through the working list - now copy new-point list to the working
          WORKNO = NEWPNO
          DO 770 WCOUNT = 1, WORKNO
             WORKXY(1,WCOUNT) = NEWPXY(1,WCOUNT)
             WORKXY(2,WCOUNT) = NEWPXY(2,WCOUNT)
770       CONTINUE

C do until workno=0 jump up to 345
          GOTO 345
        ENDIF

C do until no more labels
      GOTO 8989

55555 CONTINUE
      WRITE( NOUT, '(A)') 'STOP - make_post_map normal completion.'
      CALL EXIT(0)

C error statements
900   CONTINUE
        WRITE( NOUT, '(2(A,I5)/A)')
     &' Error reading elements row', XCOUNT, '  column', YCOUNT,
     &' Aborting**************'//CHAR(7)
      GOTO 55555

      END


MODULE ED_IO
  USE ED_INPUT_VARS
  USE ED_VARS_GLOBAL
  USE ED_AUX_FUNX
  USE ED_BATH
  USE ED_BATH_FUNCTIONS
  USE SF_LINALG
  USE SF_ARRAYS, only: linspace,arange
  USE SF_IOTOOLS, only: str,reg,free_unit,splot,sread
  implicit none
  private

  !Retrieve self-energy through routines:
  interface ed_get_sigma_matsubara
     module procedure ed_get_sigma_matsubara_1
     module procedure ed_get_sigma_matsubara_2
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure ed_get_sigma_matsubara_lattice_1
#endif
     !     module procedure ed_get_sigma_matsubara_lattice_2
  end interface ed_get_sigma_matsubara

  interface ed_get_sigma_realaxis
     module procedure ed_get_sigma_real_1
     module procedure ed_get_sigma_real_2
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure ed_get_sigma_real_lattice_1
#endif
     !     module procedure ed_get_sigma_real_lattice_2
  end interface ed_get_sigma_realaxis

  !Retrieve imp GF through routines.
  interface ed_get_gimp_matsubara
     module procedure ed_get_gimp_matsubara_1
     module procedure ed_get_gimp_matsubara_2
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure ed_get_gimp_matsubara_lattice_1
#endif
     !     module procedure ed_get_gimp_matsubara_lattice_2
  end interface ed_get_gimp_matsubara

  interface ed_get_gimp_realaxis
     module procedure ed_get_gimp_real_1
     module procedure ed_get_gimp_real_2
#if __GFORTRAN__ &&  __GNUC__ > 8
     procedure ed_get_gimp_real_lattice_1
#endif
     !module procedure ed_get_gimp_real_lattice_2
  end interface ed_get_gimp_realaxis

  !Retrieve imp GF_0 (G0_and) through routines.
  interface ed_get_g0imp_matsubara
     module procedure ed_get_g0imp_matsubara_1
     module procedure ed_get_g0imp_matsubara_2
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure ed_get_g0imp_matsubara_lattice_1
#endif
     !     module procedure ed_get_g0imp_matsubara_lattice_2
  end interface ed_get_g0imp_matsubara

  interface ed_get_g0imp_realaxis
     module procedure ed_get_g0imp_real_1
     module procedure ed_get_g0imp_real_2
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure ed_get_g0imp_real_lattice_1
#endif
     !     module procedure ed_get_g0imp_real_lattice_2
  end interface ed_get_g0imp_realaxis

  interface ed_get_delta_matsubara
     module procedure delta_bath_main_
  end interface ed_get_delta_matsubara

  interface ed_get_delta_realaxis
     module procedure delta_bath_main_ !mats is the same as real
  end interface ed_get_delta_realaxis

  interface ed_get_g0and_matsubara
     module procedure g0and_bath_main_
  end interface ed_get_g0and_matsubara

  interface ed_get_g0and_realaxis
     module procedure g0and_bath_main_
  end interface ed_get_g0and_realaxis

  interface ed_get_invg0and_matsubara
     module procedure invg0_bath_main_
  end interface ed_get_invg0and_matsubara

  interface ed_get_invg0and_realaxis
     module procedure invg0_bath_main_
  end interface ed_get_invg0and_realaxis

  !Retrieve custom observable
  interface ed_get_custom_observable
     module procedure ed_get_custom_observable_1
  end interface ed_get_custom_observable

  !Retrieve static common observables
  interface ed_get_dens
     module procedure ed_get_dens_1
     module procedure ed_get_dens_2
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure ed_get_dens_lattice_1
#endif
     !     module procedure ed_get_dens_lattice_2
  end interface ed_get_dens

  interface ed_get_mag
     module procedure ed_get_mag_1
     module procedure ed_get_mag_2
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure ed_get_mag_lattice_1
#endif
     !     module procedure ed_get_mag_lattice_2
  end interface ed_get_mag

  interface ed_get_docc
     module procedure ed_get_docc_1
     module procedure ed_get_docc_2
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure ed_get_docc_lattice_1
#endif
     !     module procedure ed_get_docc_lattice_2
  end interface ed_get_docc

  interface ed_get_epot
     module procedure :: ed_get_epot_
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure :: ed_get_epot_lattice
#endif
  end interface ed_get_epot

  interface ed_get_eint
     module procedure :: ed_get_eint_
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure :: ed_get_eint_lattice
#endif
  end interface ed_get_eint

  interface ed_get_ehartree
     module procedure :: ed_get_ehartree_
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure :: ed_get_ehartree_lattice
#endif
  end interface ed_get_ehartree

  interface ed_get_eknot
     module procedure :: ed_get_eknot_
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure :: ed_get_eknot_lattice
#endif
  end interface ed_get_eknot

  interface ed_get_dust
     module procedure :: ed_get_dust_
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure :: ed_get_dust_lattice
#endif
  end interface ed_get_dust

  interface ed_get_dund
     module procedure :: ed_get_dund_
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure :: ed_get_dund_lattice
#endif
  end interface ed_get_dund

  interface ed_get_dse
     module procedure :: ed_get_dse_
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure :: ed_get_dse_lattice
#endif
  end interface ed_get_dse

  interface ed_get_dph
     module procedure :: ed_get_dph_
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure :: ed_get_dph_lattice
#endif
  end interface ed_get_dph

   interface ed_get_density_matrix
      module procedure :: ed_get_density_matrix_single
#if __GFORTRAN__ &&  __GNUC__ > 8
      module procedure :: ed_get_density_matrix_lattice
#endif
   end interface ed_get_density_matrix

  interface ed_gf_cluster
     module procedure :: ed_gf_cluster_scalar
     module procedure :: ed_gf_cluster_array
  end interface ed_gf_cluster

  interface ed_read_impsigma
     module procedure :: ed_read_impsigma_single
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure :: ed_read_impsigma_lattice
#endif
  end interface ed_read_impsigma

  interface ed_read_impG
     module procedure :: ed_read_impG_single
#if __GFORTRAN__ &&  __GNUC__ > 8
     module procedure :: ed_read_impG_lattice
#endif
  end interface ed_read_impG

  public :: ed_get_custom_observable

  public :: ed_get_sigma_matsubara
  public :: ed_get_sigma_realaxis

  public :: ed_get_gimp_matsubara
  public :: ed_get_gimp_realaxis

  public :: ed_get_g0imp_matsubara
  public :: ed_get_g0imp_realaxis

  public :: ed_get_delta_matsubara
  public :: ed_get_delta_realaxis

  public :: ed_get_g0and_matsubara
  public :: ed_get_g0and_realaxis

  public :: ed_get_invG0and_matsubara
  public :: ed_get_invG0and_realaxis

  public :: ed_gf_cluster

  public :: ed_get_dens
  public :: ed_get_mag
  public :: ed_get_docc

  public :: ed_get_epot
  public :: ed_get_eint
  public :: ed_get_ehartree
  public :: ed_get_eknot

  public :: ed_get_dust
  public :: ed_get_dund
  public :: ed_get_dse
  public :: ed_get_dph

  public :: ed_get_density_matrix

  public :: ed_read_impSigma
  public :: ed_read_impG

  !****************************************************************************************!
  !****************************************************************************************!

  public :: ed_print_impSigma
  public :: ed_print_impG
  public :: ed_print_impG0
  ! public :: ed_print_impChi

  !****************************************************************************************!
  !****************************************************************************************!

  !Frequency and time arrays:
  !=========================================================
  real(8),dimension(:),allocatable :: wm,tau,wr,vm
  character(len=64)                :: suffix

contains

  !+--------------------------------------------------------------------------+!
  ! PURPOSE: Retrieve measured values of the impurity functions
  !+--------------------------------------------------------------------------+!
  include "ED_IO/get_sigma_matsubara.f90"
  include "ED_IO/get_sigma_realaxis.f90"
  include "ED_IO/get_gimp_matsubara.f90"
  include "ED_IO/get_gimp_realaxis.f90"
  include "ED_IO/get_g0imp_matsubara.f90"
  include "ED_IO/get_g0imp_realaxis.f90"
  include "ED_IO/get_Gand_all.f90"
  include "ED_IO/gf_cluster.f90"

#if __GFORTRAN__ &&  __GNUC__ > 8
  include "ED_IO/lattice/get_sigma_matsubara.f90"
  include "ED_IO/lattice/get_sigma_realaxis.f90"
  include "ED_IO/lattice/get_gimp_matsubara.f90"
  include "ED_IO/lattice/get_gimp_realaxis.f90"
  include "ED_IO/lattice/get_g0imp_matsubara.f90"
  include "ED_IO/lattice/get_g0imp_realaxis.f90"
#endif

  !+--------------------------------------------------------------------------+!
  ! PURPOSE: Retrieve measured values of the local observables
  !+--------------------------------------------------------------------------+!
  include "ED_IO/get_custom_observable.f90"
  include "ED_IO/get_dens.f90"
  include "ED_IO/get_mag.f90"
  include "ED_IO/get_docc.f90"
  include "ED_IO/get_eimp.f90"
  include "ED_IO/get_doubles.f90"
  include "ED_IO/get_imp_dm.f90"

#if __GFORTRAN__ &&  __GNUC__ > 8
  include "ED_IO/lattice/get_dens.f90"
  include "ED_IO/lattice/get_mag.f90"
  include "ED_IO/lattice/get_docc.f90"
  include "ED_IO/lattice/get_eimp.f90"
  include "ED_IO/lattice/get_doubles.f90"
  include "ED_IO/lattice/get_imp_dm.f90"
#endif

  !+------------------------------------------------------------------+
  !                         PRINT SIGMA:
  !+------------------------------------------------------------------+
  subroutine ed_print_impSigma
    character(len=64) :: suffix
    integer           :: ilat,jlat,iorb,jorb,ispin
    !
    if(.not.allocated(wm))allocate(wm(Lmats))
    if(.not.allocated(wr))allocate(wr(Lreal))
    wm     = pi/beta*real(2*arange(1,Lmats)-1,8)
    wr     = linspace(wini,wfin,Lreal)
    !Print the impurity Sigma:
    do ilat=1,Nlat
       do jlat=1,Nlat
          do iorb=1,Norb
             do jorb=1,Norb
                do ispin=1,Nspin
                   suffix="_Isite"//str(ilat,4)//"_Jsite"//str(jlat,4)//"_l"//str(iorb)//str(jorb)//"_s"//str(ispin)
                   call splot("impSigma"//reg(suffix)//"_iw"//reg(ed_file_suffix)//".ed"   ,wm,impSmats(ilat,jlat,ispin,ispin,iorb,jorb,:))
                   call splot("impSigma"//reg(suffix)//"_realw"//reg(ed_file_suffix)//".ed",wr,impSreal(ilat,jlat,ispin,ispin,iorb,jorb,:))
                enddo
             enddo
          enddo
       enddo
    enddo
    !
    if(allocated(wm))deallocate(wm)
    if(allocated(wr))deallocate(wr)
  end subroutine ed_print_impSigma

  !+------------------------------------------------------------------+
  !                         PRINT G
  !+------------------------------------------------------------------+
  subroutine ed_print_impG
    character(len=64) :: suffix
    integer           :: ilat,jlat,iorb,ispin,jorb
    !
    !
    if(.not.allocated(wm))allocate(wm(Lmats))
    if(.not.allocated(wr))allocate(wr(Lreal))
    wm     = pi/beta*real(2*arange(1,Lmats)-1,8)
    wr     = linspace(wini,wfin,Lreal)
    !
    do ilat=1,Nlat
       do jlat=1,Nlat
          do iorb=1,Norb
             do jorb=1,Norb
                do ispin=1,Nspin
                   suffix="_Isite"//str(ilat,4)//"_Jsite"//str(jlat,4)//"_l"//str(iorb)//str(jorb)//"_s"//str(ispin)
                   call splot("impG"//reg(suffix)//"_iw"//reg(ed_file_suffix)//".ed"   ,wm,impGmats(ilat,jlat,ispin,ispin,iorb,jorb,:))
                   call splot("impG"//reg(suffix)//"_realw"//reg(ed_file_suffix)//".ed",wr,impGreal(ilat,jlat,ispin,ispin,iorb,jorb,:))
                enddo
             enddo
          enddo
       enddo
    enddo
    !
    if(allocated(wm))deallocate(wm)
    if(allocated(wr))deallocate(wr)
    !
  end subroutine ed_print_impG

  !+------------------------------------------------------------------+
  !                         PRINT G0
  !+------------------------------------------------------------------+
  subroutine ed_print_impG0
    character(len=64) :: suffix
    integer           :: ilat,jlat,iorb,ispin,jorb
    !
    if(.not.allocated(wm))allocate(wm(Lmats))
    if(.not.allocated(wr))allocate(wr(Lreal))
    wm     = pi/beta*real(2*arange(1,Lmats)-1,8)
    wr     = linspace(wini,wfin,Lreal)
    !
    do ilat=1,Nlat
       do jlat=1,Nlat
          do iorb=1,Norb
             do jorb=1,Norb
                do ispin=1,Nspin
                   suffix="_Isite"//str(ilat,4)//"_Jsite"//str(jlat,4)//"_l"//str(iorb)//str(jorb)//"_s"//str(ispin)
                   call splot("impG0"//reg(suffix)//"_iw"//reg(ed_file_suffix)//".ed"   ,wm,impG0mats(ilat,jlat,ispin,ispin,iorb,jorb,:))
                   call splot("impG0"//reg(suffix)//"_realw"//reg(ed_file_suffix)//".ed",wr,impG0real(ilat,jlat,ispin,ispin,iorb,jorb,:))
                enddo
             enddo
          enddo
       enddo
    enddo
    !
    if(allocated(wm))deallocate(wm)
    if(allocated(wr))deallocate(wr)
    !
  end subroutine ed_print_impG0

  !+------------------------------------------------------------------+
  ! !                         PRINT CHI:
  ! !+------------------------------------------------------------------+
  ! subroutine ed_print_impChi
  !   call print_chi_spin
  !   call print_chi_dens
  !   call print_chi_dens_mix
  !   call print_chi_dens_tot
  !   call print_chi_pair
  ! end subroutine ed_print_impChi

  ! !                         SPIN-SPIN
  ! subroutine print_chi_spin
  !   integer                               :: i,iorb
  !   integer                               :: unit(3)
  !   do iorb=1,Norb
  !      call splot("spinChi_l"//str(iorb)//"_tau"//reg(ed_file_suffix)//".ed",tau,spinChi_tau(iorb,0:))
  !      call splot("spinChi_l"//str(iorb)//"_realw"//reg(ed_file_suffix)//".ed",wr,spinChi_w(iorb,:))
  !      call splot("spinChi_l"//str(iorb)//"_iw"//reg(ed_file_suffix)//".ed",vm,spinChi_iv(iorb,:))
  !   enddo
  !   if(Norb>1)then
  !      iorb=Norb+1
  !      call splot("spinChi_tot"//str(iorb)//"_tau"//reg(ed_file_suffix)//".ed",tau,spinChi_tau(iorb,0:))
  !      call splot("spinChi_tot"//str(iorb)//"_realw"//reg(ed_file_suffix)//".ed",wr,spinChi_w(iorb,:))
  !      call splot("spinChi_tot"//str(iorb)//"_iw"//reg(ed_file_suffix)//".ed",vm,spinChi_iv(iorb,:))
  !   endif
  ! end subroutine print_chi_spin

  ! !                     DENSITY-DENSITY
  ! subroutine print_chi_dens
  !   integer                               :: i,j,iorb,jorb
  !   integer                               :: unit(3),unit_mix
  !   do iorb=1,Norb
  !      do jorb=iorb,Norb
  !         call splot("densChi_l"//str(iorb)//str(jorb)//"_tau"//reg(ed_file_suffix)//".ed",tau,densChi_tau(iorb,jorb,0:))
  !         call splot("densChi_l"//str(iorb)//str(jorb)//"_realw"//reg(ed_file_suffix)//".ed",wr,densChi_w(iorb,jorb,:))
  !         call splot("densChi_l"//str(iorb)//str(jorb)//"_iw"//reg(ed_file_suffix)//".ed",vm,densChi_iv(iorb,jorb,:))
  !      enddo
  !   enddo
  ! end subroutine print_chi_dens

  ! subroutine print_chi_dens_mix
  !   integer                               :: i,j,iorb,jorb
  !   integer                               :: unit(3),unit_mix
  !   do iorb=1,Norb
  !      do jorb=1,Norb
  !         call splot("densChi_mix_l"//str(iorb)//str(jorb)//"_tau"//reg(ed_file_suffix)//".ed",tau,densChi_mix_tau(iorb,jorb,0:))
  !         call splot("densChi_mix_l"//str(iorb)//str(jorb)//"_realw"//reg(ed_file_suffix)//".ed",wr,densChi_mix_w(iorb,jorb,:))
  !         call splot("densChi_mix_l"//str(iorb)//str(jorb)//"_iw"//reg(ed_file_suffix)//".ed",vm,densChi_mix_iv(iorb,jorb,:))
  !      enddo
  !   enddo
  ! end subroutine print_chi_dens_mix

  ! subroutine print_chi_dens_tot
  !   integer                               :: i,j,iorb,jorb
  !   integer                               :: unit(3),unit_mix
  !   call splot("densChi_tot_tau"//reg(ed_file_suffix)//".ed",tau,densChi_tot_tau(0:))
  !   call splot("densChi_tot_realw"//reg(ed_file_suffix)//".ed",wr,densChi_tot_w(:))
  !   call splot("densChi_tot_iw"//reg(ed_file_suffix)//".ed",vm,densChi_tot_iv(:))
  ! end subroutine print_chi_dens_tot

  ! !                             PAIR
  ! subroutine print_chi_pair
  !   integer                               :: i,iorb
  !   integer                               :: unit(3)
  !   do iorb=1,Norb
  !      call splot("pairChi_orb"//str(iorb)//"_tau"//reg(ed_file_suffix)//".ed",tau,pairChi_tau(iorb,0:))
  !      call splot("pairChi_orb"//str(iorb)//"_realw"//reg(ed_file_suffix)//".ed",wr,pairChi_w(iorb,:))
  !      call splot("pairChi_orb"//str(iorb)//"_iw"//reg(ed_file_suffix)//".ed",vm,pairChi_iv(iorb,:))
  !   enddo
  ! end subroutine print_chi_pair

   ! PURPOSE: Read self-energy function(s) - also for inequivalent sites.
   !+-----------------------------------------------------------------------------+!
   subroutine ed_read_impSigma_single
     integer                                           :: i,ispin,isign,unit(2),iorb,jorb,ilat,jlat
     character(len=30)                                 :: suffix
     integer,dimension(:),allocatable                  :: getIorb,getJorb
     integer                                           :: totNorb,l
     !
     if(.not.allocated(wm))allocate(wm(Lmats))
     if(.not.allocated(wr))allocate(wr(Lreal))
     wm     = pi/beta*real(2*arange(1,Lmats)-1,8)
     wr     = linspace(wini,wfin,Lreal)
     !
     !!
     !Print the impurity functions:
     do ispin=1,Nspin
      do ilat=1,Nlat
        do jlat=1,Nlat
          do iorb=1,Norb
            do jorb=1,Norb
              suffix="_Isite"//str(ilat,4)//"_Jsite"//str(jlat,4)//"_l"//str(iorb)//str(jorb)//"_s"//str(ispin)
              call sread("impSigma"//reg(suffix)//"_iw"//reg(ed_file_suffix)//".ed"   ,wm,impSmats(ilat,jlat,ispin,ispin,iorb,jorb,:))
              call sread("impSigma"//reg(suffix)//"_realw"//reg(ed_file_suffix)//".ed",wr,impSreal(ilat,jlat,ispin,ispin,iorb,jorb,:))
            enddo
          enddo
        enddo
      enddo
     enddo
     !
     if(allocated(wm))deallocate(wm)
     if(allocated(wr))deallocate(wr)
     !
   end subroutine ed_read_impSigma_single

#if __GFORTRAN__ &&  __GNUC__ > 8

   subroutine ed_read_impSigma_lattice(Nineq)
    integer :: Nineq
    integer :: isites
    !
    if(allocated(Smats_ineq))deallocate(Smats_ineq)
    if(allocated(Sreal_ineq))deallocate(Sreal_ineq)
    !
    allocate(Smats_ineq(Nineq,Nlat,Nlat,Nspin,Nspin,Norb,Norb,Lmats))
    allocate(Sreal_ineq(Nineq,Nlat,Nlat,Nspin,Nspin,Norb,Norb,Lreal))
    !
    Smats_ineq  = zero
    Sreal_ineq  = zero
    !
    do isites=1,Nineq
       ed_file_suffix=reg(ineq_site_suffix)//str(isites,site_indx_padding)
       call ed_read_impSigma_single
       Smats_ineq(isites,:,:,:,:,:,:,:)  = impSmats
       Sreal_ineq(isites,:,:,:,:,:,:,:)  = impSreal
    enddo
    ed_file_suffix=""
  end subroutine ed_read_impSigma_lattice

#endif

   subroutine ed_read_impG_single
     integer                                           :: i,ispin,isign,unit(2),iorb,jorb,ilat,jlat
     character(len=30)                                 :: suffix
     integer,dimension(:),allocatable                  :: getIorb,getJorb
     integer                                           :: totNorb,l
     !
     if(.not.allocated(wm))allocate(wm(Lmats))
     if(.not.allocated(wr))allocate(wr(Lreal))
     wm     = pi/beta*real(2*arange(1,Lmats)-1,8)
     wr     = linspace(wini,wfin,Lreal)
     !
     !Print the impurity functions:
     do ispin=1,Nspin
      do ilat=1,Nlat
        do jlat=1,Nlat
          do iorb=1,Norb
            do jorb=1,Norb
              suffix="_Isite"//str(ilat,4)//"_Jsite"//str(jlat,4)//"_l"//str(iorb)//str(jorb)//"_s"//str(ispin)
              call sread("impG"//reg(suffix)//"_iw"//reg(ed_file_suffix)//".ed"   ,wm,impGmats(ilat,jlat,ispin,ispin,iorb,jorb,:))
              call sread("impG"//reg(suffix)//"_realw"//reg(ed_file_suffix)//".ed",wr,impGreal(ilat,jlat,ispin,ispin,iorb,jorb,:))
            enddo
          enddo
        enddo
      enddo
     enddo
     !
     if(allocated(wm))deallocate(wm)
     if(allocated(wr))deallocate(wr)
     !
   end subroutine ed_read_impG_single

#if __GFORTRAN__ &&  __GNUC__ > 8

   subroutine ed_read_impG_lattice(Nineq)
    integer :: Nineq
    integer :: isites
    !
    if(allocated(Gmats_ineq))deallocate(Gmats_ineq)
    if(allocated(Greal_ineq))deallocate(Greal_ineq)
    !
    allocate(Gmats_ineq(Nineq,Nlat,Nlat,Nspin,Nspin,Norb,Norb,Lmats))
    allocate(Greal_ineq(Nineq,Nlat,Nlat,Nspin,Nspin,Norb,Norb,Lreal))
    !
    Gmats_ineq  = zero
    Greal_ineq  = zero
    !
    do isites=1,Nineq
       ed_file_suffix=reg(ineq_site_suffix)//str(isites,site_indx_padding)
       call ed_read_impG_single
       Gmats_ineq(isites,:,:,:,:,:,:,:)  = impGmats
       Greal_ineq(isites,:,:,:,:,:,:,:)  = impGreal
    enddo
    ed_file_suffix=""
  end subroutine ed_read_impG_lattice

#endif

END MODULE ED_IO