quantum-espresso/GWW/gww/green_function.f90

!
! Copyright (C) 2001-2013 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!


  MODULE green_function
!this module descibes the green function in imaginary time/frequency 
!and contains subroutine to read/write from disk and to create 
   
    USE kinds, ONLY : DP

      TYPE green
!this structure describe a generic green function
!usually in the space of wanniers
        INTEGER :: label!label to read/write to disk
        LOGICAL :: ontime!if .true. is on imaginary time, otherwise frequency
        REAL(kind=DP) :: time!imaginary time or frequency
        INTEGER :: nums!number of states
        LOGICAL :: zero_time_neg!if .true. the green function at t=0 is calculated as a negative time one
        COMPLEX(kind=DP), DIMENSION(:,:,:), POINTER :: gf!green function
        LOGICAL :: l_part!if true the matrix is written as a real matrix times a sign
        REAL(kind=DP), DIMENSION(:,:,:), POINTER :: gf_p!green function
        COMPLEX(kind=DP) :: factor !complex factor for gf_p
        INTEGER ::nspin!spin multiplicity
     END TYPE green
  CONTAINS

    SUBROUTINE initialize_green(gr)
      implicit none
      TYPE(green) gr
       nullify(gr%gf)
       nullify(gr%gf_p)
      return
    END SUBROUTINE


 
    SUBROUTINE free_memory_green(gr)
!this subroutine deallocates the green descriptor
      implicit none
      TYPE(green) gr
      if(associated(gr%gf)) deallocate(gr%gf)
      nullify(gr%gf)
      if(associated(gr%gf_p)) deallocate(gr%gf_p)
      nullify(gr%gf_p)
      return 
    END SUBROUTINE 
      
    SUBROUTINE create_green(gr,wu,time,debug,zero_time_neg,l_hf_energies,ene_hf)
!this subroutine creates a green function on imagynary time
!on the basis of wanniers:
!the KS energies are fixed so that the fermi level is at 0
!  G_{i,j}=i*\sum_v U^{+}_{v,i}*U_{j,v}*exp(e_v*t)  t>=0
!         =-i*\sum_c U^{+}_{c,i}*U_{j,c}*exp(e_c*t) t<0 
!if required uses HF energies


      USE kinds, ONLY : DP
      USE io_global, ONLY : stdout
      USE basic_structures, ONLY : wannier_u

      implicit none
 
      TYPE(green) :: gr!the green function on output
      TYPE(wannier_u) :: wu!data on U and e_i
      REAL(kind=DP) :: time!imaginary time
      LOGICAL :: debug!if true print debug informations on stdout
      LOGICAL :: zero_time_neg!if true and time==0, the negative form is forced
      LOGICAL, INTENT(in) :: l_hf_energies!if true uses HF energies
      REAL(kind=DP), INTENT(in) :: ene_hf(:)


      INTEGER iw,jw,kw
      REAL(kind=DP) :: offset

!calculates energy offset
      
      gr%nspin=wu%nspin

      if(gr%nspin==1) then
         if(.not.l_hf_energies) then
            if(wu%nums > wu%nums_occ(1)) then
               offset=-(wu%ene(wu%nums_occ(1)+1,1)+wu%ene(wu%nums_occ(1),1))/2.d0
            else
               offset=-wu%ene(wu%nums_occ(1),1)
            endif
         else
            if(wu%nums > wu%nums_occ(1)) then
               offset=-(ene_hf(wu%nums_occ(1)+1)+ene_hf(wu%nums_occ(1)))/2.d0
            else
               offset=-ene_hf(wu%nums_occ(1))
            endif
         endif
      else
          if(wu%nums > max(wu%nums_occ(1),wu%nums_occ(2))) then
             offset=-(min(wu%ene(wu%nums_occ(1)+1,1),wu%ene(wu%nums_occ(2)+1,2))+&
                  &max(wu%ene(wu%nums_occ(1),1), wu%ene(wu%nums_occ(2),2)))/2.d0
          else
             offset=-max(wu%ene(wu%nums_occ(1),1), wu%ene(wu%nums_occ(2),2))
          endif
      endif
!sets data and allocate 
!      call free_memory_green(gr)
      gr%nums=wu%nums
      allocate(gr%gf(gr%nums,gr%nums,gr%nspin))
      gr%gf(:,:,:)=(0.d0,0.d0)
      gr%ontime=.TRUE.
      gr%time=time
      gr%zero_time_neg = zero_time_neg

      if((time < 0.d0).or. (time==0.d0 .and. zero_time_neg )) then
! only conduction states
        do iw=1,gr%nums
          do jw=iw,gr%nums
             do  kw=wu%nums_occ(1)+1,wu%nums
                if(.not.l_hf_energies) then
                   gr%gf(iw,jw,1)=gr%gf(iw,jw,1)+wu%umat(kw,iw,1)*conjg(wu%umat(kw,jw,1))* &
                        & exp((wu%ene(kw,1)+offset)*time)
                else
                   gr%gf(iw,jw,1)=gr%gf(iw,jw,1)+wu%umat(kw,iw,1)*conjg(wu%umat(kw,jw,1))* &
                        & exp((ene_hf(kw)+offset)*time)
                endif
                 if(debug) then
                   write(stdout,*) 'Create green:' ,time,iw,jw,wu%ene(kw,1),wu%nums_occ(1)+1,wu%umat(jw,kw,1)
                 endif
             enddo
             gr%gf(jw,iw,1)=conjg(gr%gf(iw,jw,1))
             gr%gf(iw,jw,1)=(0.d0,-1.d0)*gr%gf(iw,jw,1)
             if(iw /= jw) gr%gf(jw,iw,1)=(0.d0,-1.d0)*gr%gf(jw,iw,1)
          enddo
        enddo
      else
! only valence states
        do iw=1,gr%nums
          do jw=iw,gr%nums
             do  kw=1,wu%nums_occ(1)
                if(.not. l_hf_energies) then
                   gr%gf(iw,jw,1)=gr%gf(iw,jw,1)+wu%umat(kw,iw,1)*conjg(wu%umat(kw,jw,1))* &
                        & exp((wu%ene(kw,1)+offset)*time)
                else
                   gr%gf(iw,jw,1)=gr%gf(iw,jw,1)+wu%umat(kw,iw,1)*conjg(wu%umat(kw,jw,1))* &
                        & exp((ene_hf(kw)+offset)*time)
                endif
                 if(debug) then
                   write(stdout,*) 'Create green:' ,time,iw,jw,wu%ene(kw,1),wu%umat(kw,iw,1),wu%umat(kw,jw,1) 
                 endif
             enddo
             gr%gf(jw,iw,1)=conjg(gr%gf(iw,jw,1))
             gr%gf(iw,jw,1)=(0.d0,1.d0)*gr%gf(iw,jw,1)
             if(iw /= jw) gr%gf(jw,iw,1)=(0.d0,1.d0)*gr%gf(jw,iw,1)
             if(debug) write(stdout,*) 'Create green2:', iw,jw, gr%gf(iw,jw,1), offset
          enddo
        enddo

      endif
      

      return

   END SUBROUTINE

    SUBROUTINE create_green_part(gr,wu,time,debug,zero_time_neg,l_hf_energies,ene_hf)
!this subroutine creates a green function on imagynary time
!on the basis of wanniers:
!the KS energies are fixed so that the fermi level is at 0
!  G_{i,j}=i*\sum_v U^{+}_{v,i}*U_{j,v}*exp(e_v*t)  t>=0
!         =-i*\sum_c U^{+}_{c,i}*U_{j,c}*exp(e_c*t) t<0
!if required uses HF energies
!it uses consider a real part plus a factor


      USE kinds, ONLY : DP
      USE io_global, ONLY : stdout
      USE basic_structures, ONLY : wannier_u

      implicit none

      TYPE(green) :: gr!the green function on output
      TYPE(wannier_u) :: wu!data on U and e_i
      REAL(kind=DP) :: time!imaginary time
      LOGICAL :: debug!if true print debug informations on stdout
      LOGICAL :: zero_time_neg!if true and time==0, the negative form is forced
      LOGICAL, INTENT(in) :: l_hf_energies!if true uses HF energies
      REAL(kind=DP), INTENT(in) :: ene_hf(:)


      INTEGER iw,jw,kw
      REAL(kind=DP) :: offset


      call free_memory_green(gr)

      gr%nspin=wu%nspin
      gr%l_part=.true.
     
!calculates energy offset
 if(gr%nspin==1) then
         if(.not.l_hf_energies) then
            if(wu%nums > wu%nums_occ(1)) then
               offset=-(wu%ene(wu%nums_occ(1)+1,1)+wu%ene(wu%nums_occ(1),1))/2.d0
            else
               offset=-wu%ene(wu%nums_occ(1),1)
            endif
         else
            if(wu%nums > wu%nums_occ(1)) then
               offset=-(ene_hf(wu%nums_occ(1)+1)+ene_hf(wu%nums_occ(1)))/2.d0
            else
               offset=-ene_hf(wu%nums_occ(1))
            endif
         endif
      else
          if(wu%nums > max(wu%nums_occ(1),wu%nums_occ(2))) then
             offset=-(min(wu%ene(wu%nums_occ(1)+1,1),wu%ene(wu%nums_occ(2)+1,2))+&
                  &max(wu%ene(wu%nums_occ(1),1), wu%ene(wu%nums_occ(2),2)))/2.d0
          else
             offset=-max(wu%ene(wu%nums_occ(1),1), wu%ene(wu%nums_occ(2),2))
          endif
      endif


!sets data and allocate
!      call free_memory_green(gr)
      gr%nums=wu%nums
      allocate(gr%gf_p(gr%nums,gr%nums,gr%nspin))
      gr%gf_p(:,:,:)=0.d0
      gr%ontime=.TRUE.
      gr%time=time
      gr%zero_time_neg = zero_time_neg

      if((time < 0.d0).or. (time==0.d0 .and. zero_time_neg )) then
! only conduction states
        do iw=1,gr%nums
          do jw=iw,gr%nums
             do  kw=wu%nums_occ(1)+1,wu%nums
                if(.not.l_hf_energies) then
                   gr%gf_p(iw,jw,1)=gr%gf_p(iw,jw,1)+dble(wu%umat(kw,iw,1))*dble(wu%umat(kw,jw,1))* &
                        & exp((wu%ene(kw,1)+offset)*time)
                  ! if(abs(aimag(wu%umat(kw,iw)) >=1.d-6)) write(stdout,*) 'PROBLEMA'
                else
                   gr%gf_p(iw,jw,1)=gr%gf_p(iw,jw,1)+dble(wu%umat(kw,iw,1))*dble(wu%umat(kw,jw,1))* &
                        & exp((ene_hf(kw)+offset)*time)
                endif
                 if(debug) then
                   write(stdout,*) 'Create green:' ,time,iw,jw,wu%ene(kw,1),wu%nums_occ+1,wu%umat(jw,kw,1)
                 endif
             enddo
             gr%gf_p(jw,iw,1)=gr%gf_p(iw,jw,1)
             gr%factor=(0.d0,-1.d0)
          enddo
        enddo
      else
! only valence states
        do iw=1,gr%nums
          do jw=iw,gr%nums
             do  kw=1,wu%nums_occ(1)
                if(.not. l_hf_energies) then
                   gr%gf_p(iw,jw,1)=gr%gf_p(iw,jw,1)+dble(wu%umat(kw,iw,1))*dble(wu%umat(kw,jw,1))* &
                        & exp((wu%ene(kw,1)+offset)*time)
                else
                   gr%gf_p(iw,jw,1)=gr%gf_p(iw,jw,1)+dble(wu%umat(kw,iw,1))*dble(wu%umat(kw,jw,1))* &
                        & exp((ene_hf(kw)+offset)*time)
                endif
                 if(debug) then
                   write(stdout,*) 'Create green:' ,time,iw,jw,wu%ene(kw,1),wu%umat(kw,iw,1),wu%umat(kw,jw,1)
                 endif
             enddo
             gr%gf_p(jw,iw,1)=gr%gf_p(iw,jw,1)
             gr%factor=(0.d0,1.d0)
             if(debug) write(stdout,*) 'Create green2:', iw,jw, gr%gf_p(iw,jw,1), offset
          enddo
        enddo

      endif


      return

    END SUBROUTINE create_green_part






   SUBROUTINE write_green(gr, debug)
!this subroutine writes the green function on disk
!the file name is taken from the label

    USE io_files,             ONLY : prefix,tmp_dir
    implicit none

    INTEGER, EXTERNAL :: find_free_unit

    TYPE(green) :: gr!the green function to be written
    LOGICAL :: debug!if true print formatted file

    INTEGER :: iw, jw, iung,is
    CHARACTER(5) :: nfile
    if(gr%label > 0 .or. (gr%label == 0 .and. .not.gr%zero_time_neg)) then
      write(nfile,'(5i1)') &
         & gr%label/10000,mod(gr%label,10000)/1000,mod(gr%label,1000)/100,mod(gr%label,100)/10,mod(gr%label,10)
      iung = find_free_unit()
      if(.not. debug) then
        open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.'// nfile, status='unknown',form='unformatted')
      else
        open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.'// nfile, status='unknown',form='formatted')
      endif
    else
      write(nfile,'(5i1)') &          
      & -gr%label/10000,mod(-gr%label,10000)/1000,mod(-gr%label,1000)/100,mod(-gr%label,100)/10,mod(-gr%label,10)
      iung = find_free_unit()
      if(.not.debug) then
        open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.-'// nfile, status='unknown',form='unformatted')
      else
        open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.-'// nfile, status='unknown',form='formatted')
      endif
    endif
    if(.not.debug) then
      write(iung) gr%label
      write(iung) gr%ontime
      write(iung) gr%time
      write(iung) gr%nspin
      write(iung) gr%nums
      write(iung) gr%zero_time_neg
      write(iung) gr%l_part
      write(iung) gr%factor
      do is=1,gr%nspin
         if(.not.gr%l_part) then
            do iw=1,gr%nums
               write(iung)  gr%gf(1:gr%nums,iw,is)  
            enddo
         else
            do iw=1,gr%nums
               write(iung)  gr%gf_p(1:gr%nums,iw,is)
            enddo
         endif
      enddo
   else
      write(iung,*) gr%label
      write(iung,*) gr%ontime
      write(iung,*) gr%time
      write(iung,*) gr%nspin
      write(iung,*) gr%nums
      write(iung,*) gr%zero_time_neg
      write(iung,*) gr%l_part
      write(iung,*) gr%factor
      do is=1,gr%nspin
         if(.not.gr%l_part) then
            do iw=1,gr%nums
               do jw=1,gr%nums
                  write(iung,*)  gr%gf(jw,iw,is)
               enddo
            enddo
         else
            do iw=1,gr%nums
               do jw=1,gr%nums
                  write(iung,*)  gr%gf_p(jw,iw,is)
               enddo
            enddo
         endif
      enddo
   endif
   close(iung)
   return
 END SUBROUTINE write_green
   
   SUBROUTINE  read_green(label, gr, debug,zero_time_neg)
!this subroutine reads the green function from disk
!the file name is taken from the label

    USE io_files,             ONLY : prefix,tmp_dir
    implicit none

    INTEGER, EXTERNAL :: find_free_unit

    TYPE(green) :: gr!the green function to be read
    INTEGER :: label! the label identifing the required green function
    LOGICAL :: debug!if true print formatted file
    LOGICAL :: zero_time_neg !if true and time == 0, a negative kind of green function is considered

    INTEGER :: iw, jw, iung,is
    CHARACTER(5) :: nfile

!first deallocate
    call free_memory_green(gr)
    if(label > 0 .or. (label == 0 .and. .not.zero_time_neg))  then
      write(nfile,'(5i1)') label/10000,mod(label,10000)/1000,mod(label,1000)/100,mod(label,100)/10,mod(label,10)  
      iung = find_free_unit()
      if(.not.debug) then
        open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.'// nfile, status='old',form='unformatted')
      else
        open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.'// nfile, status='old',form='formatted')
      endif
    else
      write(nfile,'(5i1)') -label/10000,mod(-label,10000)/1000,mod(-label,1000)/100,mod(-label,100)/10,mod(-label,10)
      iung = find_free_unit()
      if(.not.debug) then
        open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.-'// nfile, status='old',form='unformatted')
      else
        open( unit=iung, file=trim(tmp_dir)//trim(prefix)//'-'//'green.-'// nfile, status='old',form='formatted')
      endif
    endif
    if(.not.debug) then
      read(iung) gr%label
      read(iung) gr%ontime
      read(iung) gr%time
      read(iung) gr%nspin
      read(iung) gr%nums
      read(iung) gr%zero_time_neg
      read(iung) gr%l_part
      read(iung) gr%factor

!now allocate
      if(.not. gr%l_part) then
         allocate(gr%gf(gr%nums,gr%nums,gr%nspin))
         nullify(gr%gf_p)
      else
         allocate(gr%gf_p(gr%nums,gr%nums,gr%nspin))
         nullify(gr%gf)
      endif
      do is=1,gr%nspin
         if(.not. gr%l_part) then
            do iw=1,gr%nums
               read(iung)  gr%gf(1:gr%nums,iw,is)
            enddo
         else
            do iw=1,gr%nums
               read(iung)  gr%gf_p(1:gr%nums,iw,is)
            enddo
         endif
      enddo
   else
      read(iung,*) gr%label
      read(iung,*) gr%ontime
      read(iung,*) gr%time
      read(iung,*) gr%nspin
      read(iung,*) gr%nums
      read(iung,*) gr%zero_time_neg
      read(iung,*) gr%l_part
      read(iung,*) gr%factor

!now allocate
     
      if(.not. gr%l_part) then
         allocate(gr%gf(gr%nums,gr%nums,gr%nspin))
         nullify(gr%gf_p)
      else
         allocate(gr%gf_p(gr%nums,gr%nums,gr%nspin))
         nullify(gr%gf)
      endif
        
      do is=1,gr%nspin
         if(.not. gr%l_part) then
            do iw=1,gr%nums
               do jw=1,gr%nums
                  read(iung,*)  gr%gf(jw,iw,is)
               enddo
            enddo
         else
            do iw=1,gr%nums
               do jw=1,gr%nums
                  read(iung,*)  gr%gf_p(jw,iw,is)
               enddo
            enddo
         endif
      enddo
   endif
   close(iung)
   return
 END SUBROUTINE read_green


  END MODULE green_function