internal_find_u_gamma Subroutine

public subroutine internal_find_u_gamma(a_matrix, u_matrix, u_matrix_opt, ndimwin, num_wann, timing_level, stdout, timer, error, comm)

Uses

  • proc~~internal_find_u_gamma~~UsesGraph proc~internal_find_u_gamma internal_find_u_gamma module~w90_constants w90_constants proc~internal_find_u_gamma->module~w90_constants module~w90_error w90_error proc~internal_find_u_gamma->module~w90_error module~w90_io w90_io proc~internal_find_u_gamma->module~w90_io module~w90_types w90_types proc~internal_find_u_gamma->module~w90_types module~w90_comms w90_comms module~w90_error->module~w90_comms module~w90_error_base w90_error_base module~w90_error->module~w90_error_base module~w90_io->module~w90_constants module~w90_types->module~w90_constants module~w90_comms->module~w90_constants module~w90_comms->module~w90_error_base

Make initial u_matrix real Must be the case when gamma_only = .true.

Arguments

Type IntentOptional Attributes Name
complex(kind=dp), intent(in) :: a_matrix(:,:,:)
complex(kind=dp), intent(inout) :: u_matrix(:,:,:)
complex(kind=dp), intent(inout) :: u_matrix_opt(:,:,:)
integer, intent(in) :: ndimwin(:)
integer, intent(in) :: num_wann
integer, intent(in) :: timing_level
integer, intent(in) :: stdout
type(timer_list_type), intent(inout) :: timer
type(w90_error_type), intent(out), allocatable :: error
type(w90_comm_type), intent(in) :: comm

Calls

proc~~internal_find_u_gamma~~CallsGraph proc~internal_find_u_gamma internal_find_u_gamma dgemm dgemm proc~internal_find_u_gamma->dgemm dgesvd dgesvd proc~internal_find_u_gamma->dgesvd proc~io_stopwatch_start io_stopwatch_start proc~internal_find_u_gamma->proc~io_stopwatch_start proc~io_stopwatch_stop io_stopwatch_stop proc~internal_find_u_gamma->proc~io_stopwatch_stop proc~set_error_alloc set_error_alloc proc~internal_find_u_gamma->proc~set_error_alloc proc~set_error_dealloc set_error_dealloc proc~internal_find_u_gamma->proc~set_error_dealloc proc~set_error_fatal set_error_fatal proc~internal_find_u_gamma->proc~set_error_fatal proc~comms_sync_error comms_sync_error proc~set_error_alloc->proc~comms_sync_error proc~set_base_error set_base_error proc~set_error_alloc->proc~set_base_error proc~set_error_dealloc->proc~comms_sync_error proc~set_error_dealloc->proc~set_base_error proc~set_error_fatal->proc~comms_sync_error proc~set_error_fatal->proc~set_base_error

Called by

proc~~internal_find_u_gamma~~CalledByGraph proc~internal_find_u_gamma internal_find_u_gamma proc~dis_main dis_main proc~dis_main->proc~internal_find_u_gamma proc~w90_disentangle~2 w90_disentangle proc~w90_disentangle~2->proc~dis_main proc~w90_disentangle w90_disentangle proc~w90_disentangle->proc~w90_disentangle~2 program~wannier wannier program~wannier->proc~w90_disentangle~2

Source Code

  subroutine internal_find_u_gamma(a_matrix, u_matrix, u_matrix_opt, ndimwin, num_wann, &
                                   timing_level, stdout, timer, error, comm)
    !================================================!
    !
    !! Make initial u_matrix real
    !! Must be the case when gamma_only = .true.
    !
    !================================================!
    use w90_constants, only: dp
    use w90_error
    use w90_io, only: io_stopwatch_start, io_stopwatch_stop
    use w90_types, only: timer_list_type

    implicit none

    ! arguments
    type(timer_list_type), intent(inout) :: timer
    type(w90_comm_type), intent(in) :: comm
    type(w90_error_type), allocatable, intent(out) :: error

    integer, intent(in) :: ndimwin(:)
    integer, intent(in) :: stdout
    integer, intent(in) :: timing_level, num_wann

    complex(kind=dp), intent(in) :: a_matrix(:, :, :)
    complex(kind=dp), intent(inout) :: u_matrix(:, :, :)
    complex(kind=dp), intent(inout) :: u_matrix_opt(:, :, :)

    ! local variables
    integer :: info, ierr

    real(kind=dp), allocatable :: a_matrix_r(:, :)
    real(kind=dp), allocatable :: raa(:, :)
    real(kind=dp), allocatable :: u_opt_r(:, :)
    ! for dgesvd
    real(kind=dp), allocatable :: rv(:, :)
    real(kind=dp), allocatable :: rz(:, :)
    real(kind=dp), allocatable :: svals(:)
    real(kind=dp), allocatable :: work(:)

    if (timing_level > 1) call io_stopwatch_start('dis: main: find_u_gamma', timer)

    ! Allocate arrays needed for getting a_matrix_r
    allocate (u_opt_r(ndimwin(1), num_wann), stat=ierr)
    if (ierr /= 0) then
      call set_error_alloc(error, 'Error in allocating u_opt_r in dis_main: find_u_gamma', comm)
      return
    end if
    allocate (a_matrix_r(ndimwin(1), num_wann), stat=ierr)
    if (ierr /= 0) then
      call set_error_alloc(error, 'Error in allocating a_matrix_r in dis_main: find_u_gamma', comm)
      return
    end if

    ! Allocate arrays needed for dgesvd
    allocate (svals(num_wann), stat=ierr)
    if (ierr /= 0) then
      call set_error_alloc(error, 'Error in allocating svals in dis_main: find_u_gamma', comm)
      return
    end if
    allocate (work(5*num_wann), stat=ierr)
    if (ierr /= 0) then
      call set_error_alloc(error, 'Error in allocating rwork in dis_main: find_u_gamma', comm)
      return
    end if
    allocate (rv(num_wann, num_wann), stat=ierr)
    if (ierr /= 0) then
      call set_error_alloc(error, 'Error in allocating cv in dis_main: find_u_gamma', comm)
      return
    end if
    allocate (rz(num_wann, num_wann), stat=ierr)
    if (ierr /= 0) then
      call set_error_alloc(error, 'Error in allocating cz in dis_main: find_u_gamma', comm)
      return
    end if
    allocate (raa(num_wann, num_wann), stat=ierr)
    if (ierr /= 0) then
      call set_error_alloc(error, 'Error in allocating raa in dis_main: find_u_gamma', comm)
      return
    end if

    u_opt_r(:, :) = real(u_matrix_opt(1:ndimwin(1), 1:num_wann, 1), dp)

    a_matrix_r(:, :) = real(a_matrix(1:ndimwin(1), 1:num_wann, 1), kind=dp)

    call dgemm('T', 'N', num_wann, num_wann, ndimwin(1), 1.0_dp, u_opt_r, ndimwin(1), a_matrix_r, &
               ndimwin(1), 0.0_dp, raa, num_wann)
    ! Singular-value decomposition
    call dgesvd('A', 'A', num_wann, num_wann, raa, num_wann, svals, rz, num_wann, rv, num_wann, &
                work, 5*num_wann, info)
    if (info .ne. 0) then
      write (stdout, *) ' ERROR: IN DGESVD IN dis_main'
      write (stdout, *) 'K-POINT = Gamma', ' INFO=', info
      if (info .lt. 0) then
        write (stdout, *) 'THE ', -info, '-TH ARGUMENT HAD ILLEGAL VALUE'
      end if
      call set_error_fatal(error, 'dis_main: find_u_gamma: problem in DGESVD 1', comm)
      return
    end if
    ! u_matrix is the initial guess for the unitary rotation of the
    ! basis states given by the subroutine extract
    call dgemm('N', 'N', num_wann, num_wann, num_wann, 1.0_dp, rz, num_wann, rv, num_wann, 0.0_dp, &
               raa, num_wann)

    u_matrix(:, :, 1) = cmplx(raa(:, :), 0.0_dp, dp)

    ! Deallocate arrays for DGESVD
    deallocate (raa, stat=ierr)
    if (ierr /= 0) then
      call set_error_dealloc(error, 'Error deallocating raa in dis_main: find_u_gamma', comm)
      return
    end if
    deallocate (rz, stat=ierr)
    if (ierr /= 0) then
      call set_error_dealloc(error, 'Error deallocating rz in dis_main: find_u_gamma', comm)
      return
    end if
    deallocate (rv, stat=ierr)
    if (ierr /= 0) then
      call set_error_dealloc(error, 'Error deallocating rv in dis_main: find_u_gamma', comm)
      return
    end if
    deallocate (work, stat=ierr)
    if (ierr /= 0) then
      call set_error_dealloc(error, 'Error deallocating work in dis_main: find_u_gamma', comm)
      return
    end if
    deallocate (svals, stat=ierr)
    if (ierr /= 0) then
      call set_error_dealloc(error, 'Error deallocating svals in dis_main: find_u_gamma', comm)
      return
    end if

    ! Deallocate arrays for a_matrix_r
    deallocate (a_matrix_r, stat=ierr)
    if (ierr /= 0) then
      call set_error_dealloc(error, 'Error in deallocating a_matrix_r in dis_main: find_u_gamma', comm)
      return
    end if
    deallocate (u_opt_r, stat=ierr)
    if (ierr /= 0) then
      call set_error_dealloc(error, 'Error in deallocating u_opt_r in dis_main: find_u_gamma', comm)
      return
    end if

    if (timing_level > 1) call io_stopwatch_stop('dis: main: find_u_gamma: find_u_gamma', timer)

    return
    !================================================!
  end subroutine internal_find_u_gamma