get_SS_R Subroutine

public subroutine get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, eigval, wigner_seitz, ws_distance, ws_region, num_bands, num_kpts, num_wann, have_disentangled, seedname, stdout, timer, error, comm)

Uses

  • proc~~get_ss_r~~UsesGraph proc~get_ss_r get_SS_R module~w90_postw90_types w90_postw90_types proc~get_ss_r->module~w90_postw90_types module~w90_types w90_types proc~get_ss_r->module~w90_types module~w90_comms w90_comms module~w90_postw90_types->module~w90_comms module~w90_constants w90_constants module~w90_postw90_types->module~w90_constants module~w90_types->module~w90_constants module~w90_comms->module~w90_constants module~w90_error_base w90_error_base module~w90_comms->module~w90_error_base

Wannier representation of the Pauli matrices: <0n|sigma_a|Rm> (a=x,y,z)

Arguments

Type IntentOptional Attributes Name
type(dis_manifold_type), intent(in) :: dis_manifold
real(kind=dp), intent(in) :: kpt_latt(:,:)
type(print_output_type), intent(in) :: print_output
type(pw90_oper_read_type), intent(in) :: pw90_oper_read
complex(kind=dp), intent(inout), allocatable :: SS_R(:,:,:,:)
complex(kind=dp), intent(in) :: v_matrix(:,:,:)
real(kind=dp), intent(in) :: eigval(:,:)
type(wigner_seitz_type), intent(in) :: wigner_seitz
type(ws_distance_type), intent(in) :: ws_distance
type(ws_region_type), intent(in) :: ws_region
integer, intent(in) :: num_bands
integer, intent(in) :: num_kpts
integer, intent(in) :: num_wann
logical, intent(in) :: have_disentangled
character(len=50), intent(in) :: seedname
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~~get_ss_r~~CallsGraph proc~get_ss_r get_SS_R interface~comms_bcast comms_bcast proc~get_ss_r->interface~comms_bcast proc~fourier_q_to_r fourier_q_to_R proc~get_ss_r->proc~fourier_q_to_r proc~get_gauge_overlap_matrix get_gauge_overlap_matrix proc~get_ss_r->proc~get_gauge_overlap_matrix proc~io_stopwatch_start io_stopwatch_start proc~get_ss_r->proc~io_stopwatch_start proc~io_stopwatch_stop io_stopwatch_stop proc~get_ss_r->proc~io_stopwatch_stop proc~mpirank mpirank proc~get_ss_r->proc~mpirank proc~operator_wigner_setup operator_wigner_setup proc~get_ss_r->proc~operator_wigner_setup proc~set_error_alloc set_error_alloc proc~get_ss_r->proc~set_error_alloc proc~set_error_dealloc set_error_dealloc proc~get_ss_r->proc~set_error_dealloc proc~set_error_fatal set_error_fatal proc~get_ss_r->proc~set_error_fatal proc~set_error_file set_error_file proc~get_ss_r->proc~set_error_file proc~comms_bcast_char comms_bcast_char interface~comms_bcast->proc~comms_bcast_char proc~comms_bcast_cmplx comms_bcast_cmplx interface~comms_bcast->proc~comms_bcast_cmplx proc~comms_bcast_int comms_bcast_int interface~comms_bcast->proc~comms_bcast_int proc~comms_bcast_logical comms_bcast_logical interface~comms_bcast->proc~comms_bcast_logical proc~comms_bcast_real comms_bcast_real interface~comms_bcast->proc~comms_bcast_real proc~get_win_min get_win_min proc~get_gauge_overlap_matrix->proc~get_win_min proc~utility_zgemmm utility_zgemmm proc~get_gauge_overlap_matrix->proc~utility_zgemmm 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 proc~set_error_file->proc~comms_sync_error proc~set_error_file->proc~set_base_error proc~comms_bcast_char->proc~comms_sync_error proc~comms_no_sync_bcast_char comms_no_sync_bcast_char proc~comms_bcast_char->proc~comms_no_sync_bcast_char proc~comms_bcast_cmplx->proc~comms_sync_error proc~comms_no_sync_bcast_cmplx comms_no_sync_bcast_cmplx proc~comms_bcast_cmplx->proc~comms_no_sync_bcast_cmplx proc~comms_bcast_int->proc~comms_sync_error proc~comms_no_sync_bcast_int comms_no_sync_bcast_int proc~comms_bcast_int->proc~comms_no_sync_bcast_int proc~comms_bcast_logical->proc~comms_sync_error proc~comms_no_sync_bcast_logical comms_no_sync_bcast_logical proc~comms_bcast_logical->proc~comms_no_sync_bcast_logical proc~comms_bcast_real->proc~comms_sync_error proc~comms_no_sync_bcast_real comms_no_sync_bcast_real proc~comms_bcast_real->proc~comms_no_sync_bcast_real proc~utility_zgemm_new utility_zgemm_new proc~utility_zgemmm->proc~utility_zgemm_new zgemm zgemm proc~utility_zgemm_new->zgemm

Called by

proc~~get_ss_r~~CalledByGraph proc~get_ss_r get_SS_R proc~berry_main berry_main proc~berry_main->proc~get_ss_r proc~calctdfanddos calcTDFandDOS proc~calctdfanddos->proc~get_ss_r proc~dos_main dos_main proc~dos_main->proc~get_ss_r proc~gyrotropic_main gyrotropic_main proc~gyrotropic_main->proc~get_ss_r proc~k_path k_path proc~k_path->proc~get_ss_r proc~k_slice k_slice proc~k_slice->proc~get_ss_r proc~spin_get_moment spin_get_moment proc~spin_get_moment->proc~get_ss_r proc~boltzwann_main boltzwann_main proc~boltzwann_main->proc~calctdfanddos program~postw90 postw90 program~postw90->proc~berry_main program~postw90->proc~dos_main program~postw90->proc~gyrotropic_main program~postw90->proc~k_path program~postw90->proc~k_slice program~postw90->proc~spin_get_moment program~postw90->proc~boltzwann_main

Source Code

  subroutine get_SS_R(dis_manifold, kpt_latt, print_output, pw90_oper_read, SS_R, v_matrix, &
                      eigval, wigner_seitz, ws_distance, ws_region, num_bands, num_kpts, num_wann, &
                      have_disentangled, seedname, stdout, timer, error, comm)
    !================================================
    !
    !! Wannier representation of the Pauli matrices: <0n|sigma_a|Rm>
    !! (a=x,y,z)
    !
    !================================================

    use w90_postw90_types, only: pw90_oper_read_type, wigner_seitz_type
    use w90_types, only: dis_manifold_type, kmesh_info_type, ws_distance_type, ws_region_type, &
                         print_output_type, timer_list_type

    implicit none

    ! arguments
    type(dis_manifold_type), intent(in) :: dis_manifold
    type(pw90_oper_read_type), intent(in) :: pw90_oper_read
    type(wigner_seitz_type), intent(in) :: wigner_seitz
    type(ws_distance_type), intent(in) :: ws_distance
    type(ws_region_type), intent(in) :: ws_region
    type(print_output_type), intent(in) :: print_output
    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) :: stdout, num_bands, num_kpts, num_wann

    real(kind=dp), intent(in) :: eigval(:, :)
    real(kind=dp), intent(in) :: kpt_latt(:, :)

    complex(kind=dp), intent(in) :: v_matrix(:, :, :)
    complex(kind=dp), allocatable, intent(inout) :: SS_R(:, :, :, :) ! <0n|sigma_x,y,z|Rm>
    complex(kind=dp), allocatable :: SS_R_temp(:, :, :, :)

    character(len=50), intent(in) :: seedname
    logical, intent(in) :: have_disentangled

    ! local variables
    complex(kind=dp), allocatable :: spn_o(:, :, :, :), SS_q(:, :, :, :), spn_temp(:, :)
    real(kind=dp)                 :: s_real, s_img
    integer, allocatable          :: num_states(:)
    integer                       :: m, n, spn_in, ik, is, &
                                     nb_tmp, nkp_tmp, ierr, s, counter
    character(len=60)             :: header
    logical :: on_root = .false.

    if (mpirank(comm) == 0) on_root = .true.

    if (print_output%timing_level > 1 .and. print_output%iprint > 0) &
      call io_stopwatch_start('get_oper: get_SS_R', timer)

    allocate (SS_R_temp(num_wann, num_wann, wigner_seitz%nrpts, 3))

    if (.not. allocated(SS_R)) then
      allocate (SS_R(num_wann, num_wann, wigner_seitz%nrpts_pw90, 3))
    else
      return ! been here before
    end if

    if (on_root) then

      allocate (spn_o(num_bands, num_bands, num_kpts, 3))
      allocate (SS_q(num_wann, num_wann, num_kpts, 3))

      allocate (num_states(num_kpts))
      do ik = 1, num_kpts
        if (have_disentangled) then
          num_states(ik) = dis_manifold%ndimwin(ik)
        else
          num_states(ik) = num_wann
        end if
      end do

      ! Read from .spn file the original spin matrices <psi_nk|sigma_i|psi_mk>
      ! (sigma_i = Pauli matrix) between ab initio eigenstates
      !
      if (pw90_oper_read%spn_formatted) then
        open (newunit=spn_in, file=trim(seedname)//'.spn', form='formatted', &
              status='old', err=109)
        write (stdout, '(/a)', advance='no') &
          ' Reading spin matrices from '//trim(seedname)//'.spn in get_SS_R : '
        read (spn_in, *, err=110, end=110) header
        write (stdout, '(a)') trim(header)
        read (spn_in, *, err=110, end=110) nb_tmp, nkp_tmp
      else
        open (newunit=spn_in, file=trim(seedname)//'.spn', form='unformatted', &
              status='old', err=109)
        write (stdout, '(/a)', advance='no') &
          ' Reading spin matrices from '//trim(seedname)//'.spn in get_SS_R : '
        read (spn_in, err=110, end=110) header
        write (stdout, '(a)') trim(header)
        read (spn_in, err=110, end=110) nb_tmp, nkp_tmp
      end if
      if (nb_tmp .ne. num_bands) then
        call set_error_fatal(error, trim(seedname)//'.spn has wrong number of bands', comm)
        return
      end if
      if (nkp_tmp .ne. num_kpts) then
        call set_error_fatal(error, trim(seedname)//'.spn has wrong number of k-points', comm)
        return
      end if
      if (pw90_oper_read%spn_formatted) then
        do ik = 1, num_kpts
          do m = 1, num_bands
            do n = 1, m
              read (spn_in, *, err=110, end=110) s_real, s_img
              spn_o(n, m, ik, 1) = cmplx(s_real, s_img, dp)
              read (spn_in, *, err=110, end=110) s_real, s_img
              spn_o(n, m, ik, 2) = cmplx(s_real, s_img, dp)
              read (spn_in, *, err=110, end=110) s_real, s_img
              spn_o(n, m, ik, 3) = cmplx(s_real, s_img, dp)
              ! Read upper-triangular part, now build the rest
              spn_o(m, n, ik, 1) = conjg(spn_o(n, m, ik, 1))
              spn_o(m, n, ik, 2) = conjg(spn_o(n, m, ik, 2))
              spn_o(m, n, ik, 3) = conjg(spn_o(n, m, ik, 3))
            end do
          end do
        end do
      else
        allocate (spn_temp(3, (num_bands*(num_bands + 1))/2), stat=ierr)
        if (ierr /= 0) then
          call set_error_alloc(error, 'Error in allocating spm_temp in get_SS_R', comm)
          return
        end if
        do ik = 1, num_kpts
          read (spn_in) ((spn_temp(s, m), s=1, 3), m=1, (num_bands*(num_bands + 1))/2)
          counter = 0
          do m = 1, num_bands
            do n = 1, m
              counter = counter + 1
              spn_o(n, m, ik, 1) = spn_temp(1, counter)
              spn_o(m, n, ik, 1) = conjg(spn_temp(1, counter))
              spn_o(n, m, ik, 2) = spn_temp(2, counter)
              spn_o(m, n, ik, 2) = conjg(spn_temp(2, counter))
              spn_o(n, m, ik, 3) = spn_temp(3, counter)
              spn_o(m, n, ik, 3) = conjg(spn_temp(3, counter))
            end do
          end do
        end do
        deallocate (spn_temp, stat=ierr)
        if (ierr /= 0) then
          call set_error_dealloc(error, 'Error in deallocating spm_temp in get_SS_R', comm)
          return
        end if
      end if

      close (spn_in)

      ! Transform to projected subspace, Wannier gauge
      !
      SS_q(:, :, :, :) = cmplx_0
      do ik = 1, num_kpts
        do is = 1, 3

          call get_gauge_overlap_matrix(num_bands, num_wann, eigval, v_matrix, dis_manifold, &
                                        ik, num_states(ik), ik, num_states(ik), &
                                        spn_o(:, :, ik, is), have_disentangled, SS_q(:, :, ik, is))
        end do !is
      end do !ik

      call fourier_q_to_R(num_kpts, wigner_seitz%nrpts, wigner_seitz%irvec, kpt_latt, SS_q(:, :, :, 1), SS_R_temp(:, :, :, 1))
      call fourier_q_to_R(num_kpts, wigner_seitz%nrpts, wigner_seitz%irvec, kpt_latt, SS_q(:, :, :, 2), SS_R_temp(:, :, :, 2))
      call fourier_q_to_R(num_kpts, wigner_seitz%nrpts, wigner_seitz%irvec, kpt_latt, SS_q(:, :, :, 3), SS_R_temp(:, :, :, 3))

      call operator_wigner_setup(ws_distance, ws_region, wigner_seitz, num_wann, SS_R_temp(:, :, :, 1), SS_R(:, :, :, 1))
      call operator_wigner_setup(ws_distance, ws_region, wigner_seitz, num_wann, SS_R_temp(:, :, :, 2), SS_R(:, :, :, 2))
      call operator_wigner_setup(ws_distance, ws_region, wigner_seitz, num_wann, SS_R_temp(:, :, :, 3), SS_R(:, :, :, 3))
    end if !on_root

    call comms_bcast(SS_R(1, 1, 1, 1), num_wann*num_wann*wigner_seitz%nrpts_pw90*3, error, comm)
    if (allocated(error)) return

    if (print_output%timing_level > 1 .and. print_output%iprint > 0) call io_stopwatch_stop('get_oper: get_SS_R', timer)
    return

    deallocate (SS_R_temp)

109 call set_error_file(error, 'Error: Problem opening input file '//trim(seedname)//'.spn', comm)
    return
110 call set_error_file(error, 'Error: Problem reading input file '//trim(seedname)//'.spn', comm)
    return

  end subroutine get_SS_R