hsmt_hlptomat.F90 2.84 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
module m_hsmt_hlptomat
#include "juDFT_env.h"
    implicit none
    contains
    subroutine hsmt_hlptomat(nlotot,nv,sub_comm,chi11,chi21,chi22,aahlp,aa,bbhlp,bb)
    !hsmt_hlptomat: aa/bbhlp - to -aa/bb matrix
    !Rotate the aahlp&bbhlp arrays from the local spin-frame into the global frame
    !and add the data to the aa&bb arrays, call mingeselle in distributed case

#ifdef CPP_MPI
      USE m_mingeselle
#endif
        implicit none
        integer, intent(in)                :: nlotot,nv(:),sub_comm
        complex, intent(in)                :: chi11,chi21,chi22
        complex, allocatable,intent(inout) :: aahlp(:)
        complex,             intent(inout) :: aa(:)
        complex, optional,intent(inout)    :: bb(:),bbhlp(:)

        integer :: ii,ij,ki,kj,n_rank,n_size

22
        REAL :: aa_r(1),bb_r(1) !dummy arguments for mingeselle
23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
#ifdef CPP_MPI
#include "mpif.h"
        CALL MPI_COMM_RANK(sub_comm,n_rank,ki)
        CALL MPI_COMM_SIZE(sub_comm,n_size,ki)
#else
        n_size=1
#endif
        IF (n_size==1) THEN
            DO ki =  1, nv(1)+nlotot
                !--->        spin-up spin-up part
                ii = (ki-1)*(ki)/2
                ij = (ki-1)*(ki)/2
                aa(ij+1:ij+ki)=aa(ij+1:ij+ki)+chi11*aahlp(ii+1:ii+ki)
                if (present(bb)) bb(ij+1:ij+ki)=bb(ij+1:ij+ki)+chi11*bbhlp(ii+1:ii+ki)
                !--->        spin-down spin-down part
                ij = (nv(1)+nlotot+ki-1)*(nv(1)+nlotot+ki)/2+nv(1)+nlotot
                aa(ij+1:ij+ki)=aa(ij+1:ij+ki)+chi22*aahlp(ii+1:ii+ki)
                if (present(bb)) bb(ij+1:ij+ki)=bb(ij+1:ij+ki)+chi22*bbhlp(ii+1:ii+ki)
                !--->        spin-down spin-up part, lower triangle
                ij = (nv(1)+nlotot+ki-1)*(nv(1)+nlotot+ki)/2
                aa(ij+1:ij+ki)=aa(ij+1:ij+ki)+chi21*aahlp(ii+1:ii+ki)
                if (present(bb)) bb(ij+1:ij+ki)=bb(ij+1:ij+ki)+chi21*bbhlp(ii+1:ii+ki)
                !--->        spin-down spin-up part, upper triangle.
                DO kj = 1,ki-1
                    ij = (nv(1)+nlotot+kj-1)*(nv(1)+nlotot+kj)/2 + ki
                    aa(ij) = aa(ij) + conjg(aahlp(ii+kj))*chi21
                    if (present(bb)) bb(ij) = bb(ij) + conjg(bbhlp(ii+kj))*chi21
                ENDDO
            ENDDO
        ELSE
            aa(:size(aahlp)) = aa(:size(aahlp))+aahlp*chi11
            aahlp = conjg(aahlp)*chi21
            IF (present(bb).and.nlotot>1) THEN
              !CALL juDFT_error("noco+LO and EVP is broken")
              bb(:size(aahlp)) = bb(:size(aahlp))+bbhlp*chi11
              bbhlp = conjg(bbhlp)*chi21
            ENDIF
            CALL mingeselle(SUB_COMM,n_size,n_rank,nv,&
61
                aahlp,.false.,aa_r,aa)
62
            IF (present(bb).and.nlotot>1) CALL mingeselle(SUB_COMM,n_size,n_rank,nv,&
63
                bbhlp,.false.,bb_r,bb)
64 65 66 67 68 69
        ENDIF

    end subroutine

    
end module m_hsmt_hlptomat