### Deleted some old versions of subroutines in eigen

parent d86baa66
 !-------------------------------------------------------------------------------- ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany ! This file is part of FLEUR and available as free software under the conditions ! of the MIT license as expressed in the LICENSE file in more detail. !-------------------------------------------------------------------------------- MODULE m_hsint CONTAINS SUBROUTINE hsint(input,noco,jij,stars, vpw,lapw,jspin,& n_size,n_rank,bkpt,cell,atoms,l_real,hamOvlp) !********************************************************************* ! initializes and sets up the hamiltonian and overlap matrices ! for the interstitial. only the lower triangle of the hermitian ! matrices are stored in compact real mode such that if h(i,j), ! i.ge.j, is hermitian and a is real, then ! a(i,j)=real( h(i,j) ) and a(j,i)=aimag( h(i,j) ) ! m. weinert 1986 ! ! For the eigenvector parallelization each pe calculates an equal share ! of columns labeled nc. Then the starting element of a columns nc is ! ! ii = (nc-1)*( n_rank - n_size + 1 ) + n_size*(nc-1)*nc/2 ! ! and, if a non-collinear matrix has to be set up, the starting column ! for the second spin-direction is ! ! nc = int( 1. + (nv - n_rank - 1)/n_size ) + 1 . ! ! For this direction, the outer loop starts at ! ! istart = n_rank + (nc - 1)*n_size - nv . gb99 ! ! for a lo-calculation nv has to be replaced by nv+nlotot gb01 ! !********************************************************************* USE m_types IMPLICIT NONE TYPE(t_input),INTENT(IN) :: input TYPE(t_noco),INTENT(IN) :: noco TYPE(t_jij),INTENT(IN) :: jij TYPE(t_stars),INTENT(IN) :: stars TYPE(t_cell),INTENT(IN) :: cell TYPE(t_atoms),INTENT(IN) :: atoms TYPE(t_lapw),INTENT(INOUT) :: lapw TYPE(t_hamOvlp),INTENT(INOUT) :: hamOvlp ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: n_size,n_rank,jspin ! .. ! .. Array Arguments .. COMPLEX, INTENT (INOUT) :: vpw(stars%ng3) REAL, INTENT (IN) :: bkpt(3) LOGICAL,INTENT(IN) :: l_real ! .. ! .. Local Scalars .. COMPLEX th,ts,phase REAL b1(3),b2(3),r2 INTEGER i,i1,i2,i3,ii,in,j,ig3,ispin,l,iloc INTEGER istart,nc COMPLEX ust1,vp1 COMPLEX, ALLOCATABLE :: vpw1(:) ! for J constants ! .. ! .. !\$OMP PARALLEL if (l_real) THEN !\$OMP DO do i = 1, size(hamOvlp%a_r) hamOvlp%a_r(i)=0.0 end do !OMP END DO !\$OMP DO do i = 1, size(hamOvlp%b_r) hamOvlp%b_r(i)=0.0 end do !OMP END DO ELSE !\$OMP DO do i = 1, size(hamOvlp%a_c) hamOvlp%a_c(i)=0.0 end do !\$OMP END DO !\$OMP DO do i = 1, size(hamOvlp%b_c) hamOvlp%b_c(i)=0.0 end do !\$OMP END DO ENDIF !\$OMP END PARALLEL ust1 = stars%ustep(1) ispin = jspin lapw%nmat = lapw%nv(ispin) !---> pk non-collinear IF (noco%l_noco) THEN !---> determine spin-up spin-up part of Hamiltonian- and overlapp-matrix !---> reload V_11 READ (25) (vpw(ig3),ig3=1,stars%ng3) !--- J const IF( jij%l_J) THEN ALLOCATE ( vpw1(stars%ng3) ) READ (25) (vpw1(ig3),ig3=1,stars%ng3) ENDIF !--- J const lapw%nmat = lapw%nv(1) + lapw%nv(2) ispin = 1 !--- J const IF (jij%l_J) THEN DO i = 1,stars%ng3 vpw(i) = (vpw(i) + vpw1(i))/2. END DO ENDIF !--- J const vp1 = REAL(vpw(1)) ENDIF !---> pk non-collinear vp1 = vpw(1) !---> loop over (k+g') ii = 0 !\$OMP PARALLEL DO SCHEDULE(dynamic) DEFAULT(none) & !\$OMP SHARED(n_rank,n_size,lapw,ispin,stars,input,bkpt,cell,vpw,ust1,vp1) & !\$OMP SHARED(l_real,hamOvlp)& !\$OMP PRIVATE(i,j,iloc,i1,i2,i3,in,phase,b1,b2,r2,th,ts)& !\$OMP FIRSTPRIVATE(ii) DO i = n_rank+1, lapw%nv(ispin), n_size !---> loop over (k+g) DO j = 1,i - 1 ii = 0 DO iloc = n_rank+1,i-n_size,n_size ii = ii + iloc ENDDO ii = ii + j !--> determine index and phase factor i1 = lapw%k1(i,ispin) - lapw%k1(j,ispin) i2 = lapw%k2(i,ispin) - lapw%k2(j,ispin) i3 = lapw%k3(i,ispin) - lapw%k3(j,ispin) in = stars%ig(i1,i2,i3) IF (in.EQ.0) CYCLE phase = stars%rgphs(i1,i2,i3) !+APW_LO IF (input%l_useapw) THEN b1(1) = bkpt(1)+lapw%k1(i,ispin) ; b2(1) = bkpt(1)+lapw%k1(j,ispin) b1(2) = bkpt(2)+lapw%k2(i,ispin) ; b2(2) = bkpt(2)+lapw%k2(j,ispin) b1(3) = bkpt(3)+lapw%k3(i,ispin) ; b2(3) = bkpt(3)+lapw%k3(j,ispin) r2 = DOT_PRODUCT(MATMUL(b2,cell%bbmat),b1) th = phase*(0.5*r2*stars%ustep(in)+vpw(in)) ELSE th = phase* (0.25* (lapw%rk(i,ispin)**2+lapw%rk(j,ispin)**2)*stars%ustep(in) + vpw(in)) ENDIF !-APW_LO !---> determine matrix element and store ts = phase*stars%ustep(in) if (l_real) THEN hamOvlp%a_r(ii) = REAL(th) hamOvlp%b_r(ii) = REAL(ts) else hamOvlp%a_c(ii) = th hamOvlp%b_c(ii) = ts endif ENDDO !---> diagonal term (g-g'=0 always first star) ii = ii + 1 if (l_real) THEN hamOvlp%a_r(ii) = 0.5*lapw%rk(i,ispin)*lapw%rk(i,ispin)*REAL(ust1) + REAL(vp1) hamOvlp%b_r(ii) = REAL(ust1) else hamOvlp%a_c(ii) = 0.5*lapw%rk(i,ispin)*lapw%rk(i,ispin)*ust1 + vp1 hamOvlp%b_c(ii) = ust1 endif ENDDO !\$OMP END PARALLEL DO !---> pk non-collinear IF (noco%l_noco) THEN !+gb99 nc = INT( 1. + (lapw%nv(1)+atoms%nlotot - n_rank - 1)/n_size ) istart = n_rank + nc*n_size - (lapw%nv(1)+atoms%nlotot) ! ii = (nv(1)+nlotot+1)*(nv(1)+nlotot+2)/2 - 1 ii = nc*(n_rank-n_size+1) + n_size*(nc+1)*nc/2 + lapw%nv(1)+atoms%nlotot !-gb99 ispin = 2 !---> determine spin-down spin-down part of Hamiltonian- and ovlp-matrix !---> reload V_22 !--- J constants IF(.NOT.jij%l_J) THEN READ (25) (vpw(ig3),ig3=1,stars%ng3) vp1 = REAL(vpw(1)) ENDIF !--- J constants !---> loop over (k+g') DO i = istart+1, lapw%nv(ispin), n_size nc = nc + 1 !---> loop over (k+g) DO j = 1,i - 1 !-gb99 ii = (nv(1)+i-1)*(nv(1)+i)/2 + nv(1) + j ii = (nc-1)*( n_rank - n_size + 1 ) + n_size*(nc-1)*nc/2 + lapw%nv(1)+atoms%nlotot + j !---> determine index and phase factor i1 = lapw%k1(i,ispin) - lapw%k1(j,ispin) i2 = lapw%k2(i,ispin) - lapw%k2(j,ispin) i3 = lapw%k3(i,ispin) - lapw%k3(j,ispin) in = stars%ig(i1,i2,i3) IF (in.EQ.0) THEN WRITE (*,*) 'HSINT: G-G'' not in star i,j= ',i,j ELSE phase = stars%rgphs(i1,i2,i3) !+APW_LO IF (input%l_useapw) THEN b1(1) = bkpt(1)+lapw%k1(i,ispin) ; b2(1) = bkpt(1)+lapw%k1(j,ispin) b1(2) = bkpt(2)+lapw%k2(i,ispin) ; b2(2) = bkpt(2)+lapw%k2(j,ispin) b1(3) = bkpt(3)+lapw%k3(i,ispin) ; b2(3) = bkpt(3)+lapw%k3(j,ispin) r2 = DOT_PRODUCT(MATMUL(b2,cell%bbmat),b1) th = phase*( 0.5*r2*stars%ustep(in) + vpw(in) ) ELSE th = phase* (0.25* (lapw%rk(i,ispin)**2+lapw%rk(j,ispin)**2)*stars%ustep(in) + vpw(in)) ENDIF !-APW_LO ts = phase*stars%ustep(in) hamOvlp%a_c(ii) = th hamOvlp%b_c(ii) = ts ENDIF ENDDO !---> diagonal term (g-g'=0 always first star) !-gb99 ii = (nv(1)+i)*(nv(1)+i+1)/2 ii = ii + 1 hamOvlp%a_c(ii) = 0.5*lapw%rk(i,ispin)*lapw%rk(i,ispin)*ust1 + vp1 hamOvlp%b_c(ii) = ust1 ENDDO !---> determine spin-down spin-up part of Hamiltonian- and ovlp-matrix !---> reload real part of V_21 READ (25) (vpw(ig3),ig3=1,stars%ng3) nc = INT( 1. + (lapw%nv(1)+atoms%nlotot - n_rank - 1)/n_size ) ! !---> loop over (k+g') ! DO i = istart+1, lapw%nv(2), n_size nc = nc + 1 !---> loop over (k+g) DO j = 1,lapw%nv(1) !-gb99 ii = (nv(1)+i-1)*(nv(1)+i)/2 + j ii = (nc-1)*( n_rank - n_size + 1 ) + n_size*(nc-1)*nc/2 + j !---> determine index and phase factor i1 = lapw%k1(i,2) - lapw%k1(j,1) i2 = lapw%k2(i,2) - lapw%k2(j,1) i3 = lapw%k3(i,2) - lapw%k3(j,1) in = stars%ig(i1,i2,i3) IF (in.EQ.0) THEN WRITE (*,*) 'HSINT: G-G'' not in star i,j= ',i,j ELSE hamOvlp%a_c(ii) = stars%rgphs(i1,i2,i3)*vpw(in) !--- J constants IF(jij%l_J) THEN hamOvlp%a_c(ii) = 0 ENDIF !--- J constants ENDIF ENDDO ENDDO !---> pk non-collinear ENDIF IF (jij%l_J) DEALLOCATE (vpw1) RETURN END SUBROUTINE hsint END MODULE m_hsint
 !-------------------------------------------------------------------------------- ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany ! This file is part of FLEUR and available as free software under the conditions ! of the MIT license as expressed in the LICENSE file in more detail. !-------------------------------------------------------------------------------- MODULE m_hsmt_blas use m_juDFT implicit none CONTAINS SUBROUTINE hsmt_blas(sym,atoms,isp,noco,cell,lapw,td,ud,gk,vk,fj,gj,smat,hmat) !Calculate overlap matrix USE m_hsmt_ab USE m_constants, ONLY : fpi_const,tpi_const USE m_types USE m_ylm IMPLICIT NONE TYPE(t_sym),INTENT(IN) :: sym TYPE(t_noco),INTENT(IN) :: noco TYPE(t_cell),INTENT(IN) :: cell TYPE(t_atoms),INTENT(IN) :: atoms TYPE(t_lapw),INTENT(IN) :: lapw TYPE(t_tlmplm),INTENT(IN) :: td TYPE(t_usdus),INTENT(IN) :: ud ! .. ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: isp ! .. ! .. Array Arguments .. REAL,INTENT(IN) :: gk(:,:,:),vk(:,:,:) REAL,INTENT(IN) :: fj(:,0:,:,:),gj(:,0:,:,:) TYPE(t_lapwmat),INTENT(INOUT)::smat,hmat INTEGER:: n,nn,na,aboffset,l,ll,m COMPLEX,ALLOCATABLE:: ab(:,:),tmpdata(:,:),tmp_s(:,:),tmp_h(:,:),ab1(:,:) ALLOCATE(ab(lapw%nv(isp),2*atoms%lmaxd*(atoms%lmaxd+2)+2),ab1(lapw%nv(isp),2*atoms%lmaxd*(atoms%lmaxd+2)+2)) ALLOCATE(tmp_s(smat%matsize1,smat%matsize2),tmp_h(smat%matsize1,smat%matsize2)) tmp_s=0.0;tmp_h=0.0;ab=0.0;ab1=0.0 ntyploop: DO n=1,atoms%ntype DO nn = 1,atoms%neq(n) na = SUM(atoms%neq(:n-1))+nn IF ((atoms%invsat(na)==0) .OR. (atoms%invsat(na)==1)) THEN !---> Calculate Overlapp matrix CALL timestart("ab-coefficients") CALL hsmt_ab(sym,atoms,isp,n,na,cell,lapw,gk,vk,fj,gj,ab,aboffset) CALL timestop("ab-coefficients") CALL timestart("Overlapp") CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1)) DO l=0,atoms%lmax(n) ll=l*(l+1) DO m=-l,l ab1(:,1+ll+m)=SQRT(ud%ddn(l,n,isp))*ab(:,aboffset+1+ll+m) ENDDO ENDDO CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1)) CALL timestop("Overlapp") CALL timestart("Hamiltonian") !Calculate Hamiltonian CALL zgemm("N","N",SIZE(ab,1),2*aboffset,2*aboffset,CMPLX(1.0,0.0),ab,SIZE(ab,1),td%h_loc(:,:,n,isp),SIZE(td%h_loc,1),CMPLX(0.,0.),ab1,SIZE(ab,1)) ! CALL zgemm("N","C",lapw%nv(isp),lapw%nv(isp),2*aboffset,CMPLX(1.0,0.0),ab,SIZE(ab,1),ab1,SIZE(ab,1),CMPLX(1.0,0),tmp_h,SIZE(tmp_h,1)) CALL ZHERK("U","N",lapw%nv(isp),2*aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_h,SIZE(tmp_h,1)) CALL timestop("Hamiltonian") ENDIF END DO END DO ntyploop !Copy tmp array back IF (smat%l_real) THEN smat%data_r=smat%data_r+tmp_s hmat%data_r=hmat%data_r+tmp_h-td%e_shift*tmp_s ELSE smat%data_c=smat%data_c+tmp_s hmat%data_c=hmat%data_c+tmp_h-td%e_shift*tmp_s ENDIF END SUBROUTINE hsmt_blas #if 1==2 !this version uses zherk for Hamiltonian ntyploop: DO n=1,atoms%ntype DO nn = 1,atoms%neq(n) na = SUM(atoms%neq(:n-1))+nn IF ((atoms%invsat(na)==0) .OR. (atoms%invsat(na)==1)) THEN !---> Calculate Overlapp matrix CALL timestart("ab-coefficients") CALL hsmt_ab(sym,atoms,isp,n,na,cell,lapw,gk,vk,fj,gj,ab,aboffset) CALL timestop("ab-coefficients") CALL timestart("Overlapp") CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1)) DO l=0,atoms%lmax(n) ll=l*(l+1) DO m=-l,l ab1(:,1+ll+m)=SQRT(ud%ddn(l,n,isp))*ab(:,aboffset+1+ll+m) ENDDO ENDDO CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1)) CALL timestop("Overlapp") CALL timestart("Hamiltonian") !Calculate Hamiltonian CALL zgemm("N","N",SIZE(ab,1),2*aboffset,2*aboffset,CMPLX(1.0,0.0),ab,SIZE(ab,1),td%h_loc(:,:,n,isp),SIZE(td%h_loc,1),CMPLX(0.,0.),ab1,SIZE(ab,1)) CALL ZHERK("U","N",lapw%nv(isp),2*aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_h,SIZE(tmp_h,1)) CALL timestop("Hamiltonian") ENDIF END DO END DO ntyploop !Copy tmp array back IF (smat%l_real) THEN smat%data_r=smat%data_r+tmp_s hmat%data_r=hmat%data_r+tmp_h-td%e_shift*tmp_s ELSE smat%data_c=smat%data_c+tmp_s hmat%data_c=hmat%data_c+tmp_h-td%e_shift*tmp_s ENDIF #endif END MODULE m_hsmt_blas
This diff is collapsed.
 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, intent(inout) :: aahlp(:) complex, intent(inout) :: aa(:) complex, optional,intent(inout) :: bb(:),bbhlp(:) integer :: ii,ij,ki,kj,n_rank,n_size REAL :: aa_r(1),bb_r(1) !dummy arguments for mingeselle #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 #ifdef CPP_MPI CALL mingeselle(SUB_COMM,n_size,n_rank,nv,& aahlp,.false.,aa_r,aa) IF (present(bb).and.nlotot>1) CALL mingeselle(SUB_COMM,n_size,n_rank,nv,& bbhlp,.false.,bb_r,bb) #endif ENDIF end subroutine end module m_hsmt_hlptomat
This diff is collapsed.
 !-------------------------------------------------------------------------------- ! Copyright (c) 2016 Peter Grnberg Institut, Forschungszentrum Jlich, Germany ! This file is part of FLEUR and available as free software under the conditions ! of the MIT license as expressed in the LICENSE file in more detail. !-------------------------------------------------------------------------------- MODULE m_hsmt_simple use m_juDFT implicit none CONTAINS SUBROUTINE hsmt_simple(jspin,bkpt,DIMENSION,input,sym,cell,atoms,lapw,td,noco,usdus,enpara,hmat,smat) use m_types use m_hsmt_fjgj USE m_hsmt_blas TYPE(t_dimension),INTENT(IN) :: DIMENSION TYPE(t_input),INTENT(IN) :: input TYPE(t_sym),INTENT(IN) :: sym TYPE(t_cell),INTENT(IN) :: cell TYPE(t_atoms),INTENT(IN) :: atoms TYPE(t_enpara),INTENT(IN) :: enpara TYPE(t_lapw),INTENT(IN) :: lapw TYPE(t_usdus),INTENT(IN) :: usdus TYPE(t_noco),INTENT(IN) :: noco TYPE(t_tlmplm),INTENT(IN) :: td TYPE(t_lapwmat),INTENT(INOUT) :: smat,hmat INTEGER,INTENT(IN) :: jspin REAL, INTENT (IN) :: bkpt(3) integer::k,jsp,n,nn,i REAL, ALLOCATABLE :: fj(:,:,:,:),gj(:,:,:,:) REAL, ALLOCATABLE :: gk(:,:,:),vk(:,:,:) REAL :: v(3),diff_h,diff_s REAL, PARAMETER :: eps = 1.0e-30 ALLOCATE(fj(dimension%nbasfcn,0:atoms%lmaxd,atoms%ntype,input%jspins)) ALLOCATE(gj(dimension%nbasfcn,0:atoms%lmaxd,atoms%ntype,input%jspins)) DO jsp=jspin,jspin !Set up the k+G+qss vectors ALLOCATE(vk(dimension%nbasfcn,3,1),gk(dimension%nbasfcn,3,1)) DO k = 1,lapw%nv(jsp) v=bkpt+(/lapw%k1(k,jsp),lapw%k2(k,jsp),lapw%k3(k,jsp)/)!-noco%qss/2 vk(k,:,1) = v gk(k,:,1) = MATMUL(TRANSPOSE(cell%bmat),v)/MAX (lapw%rk(k,jsp),eps) ENDDO CALL hsmt_fjgj(input,atoms,jsp,cell,lapw,usdus,fj,gj) CALL timestart("hsmt_blas") CALL hsmt_blas(sym,atoms,jsp,noco,cell,lapw,td,usdus,gk,vk,fj,gj,smat,hmat) CALL timestop("hsmt_blas") ENDDO !CALL hsmt_lo() end SUBROUTINE hsmt_simple end MODULE m_hsmt_simple
 !-------------------------------------------------------------------------------- ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany ! This file is part of FLEUR and available as free software under the conditions ! of the MIT license as expressed in the LICENSE file in more detail. !-------------------------------------------------------------------------------- MODULE m_socinit USE m_juDFT IMPLICIT NONE CONTAINS !>Initialization of SOC matrix elements used in first variation SOC !! SUBROUTINE socinit(mpi,atoms,sphhar,enpara,input,vr,noco,& !in usdus,rsoc) !out !Initialized the radial-spin-orbit elements in rsoc !needed for first variation SOC USE m_soinit USE m_types IMPLICIT NONE TYPE(t_mpi),INTENT(IN) :: mpi TYPE(t_input),INTENT(IN) :: input TYPE(t_noco),INTENT(IN) :: noco TYPE(t_sphhar),INTENT(IN) :: sphhar TYPE(t_atoms),INTENT(IN) :: atoms TYPE(t_enpara),INTENT(IN) :: enpara ! .. ! .. Scalar Arguments .. ! .. ! .. Array Arguments .. REAL, INTENT (IN) :: vr(:,0:,:,:)!(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,DIMENSION%jspd) TYPE(t_usdus),INTENT(INOUT):: usdus TYPE(t_rsoc),INTENT(OUT) :: rsoc ! .. ! .. Local Scalars .. INTEGER l,n ! for Spin-orbit... LOGICAL :: l_test LOGICAL, SAVE :: first_k = .TRUE. CHARACTER*3 :: chntype ALLOCATE(rsoc%rsopp(atoms%ntype,atoms%lmaxd,2,2),rsoc%rsoppd (atoms%ntype,atoms%lmaxd,2,2)) ALLOCATE(rsoc%rsopdp (atoms%ntype,atoms%lmaxd,2,2),rsoc%rsopdpd(atoms%ntype,atoms%lmaxd,2,2)) ALLOCATE(rsoc%rsoplop (atoms%ntype,atoms%nlod,2,2),rsoc%rsoplopd(atoms%ntype,atoms%nlod,2,2)) ALLOCATE(rsoc%rsopdplo(atoms%ntype,atoms%nlod,2,2),rsoc%rsopplo (atoms%ntype,atoms%nlod,2,2)) ALLOCATE(rsoc%rsoploplop(atoms%ntype,atoms%nlod,atoms%nlod,2,2)) CALL soinit(atoms,input,enpara,vr,noco%soc_opt(atoms%ntype+2),& rsoc%rsopp,rsoc%rsoppd,rsoc%rsopdp,rsoc%rsopdpd,usdus,& rsoc%rsoplop,rsoc%rsoplopd,rsoc%rsopdplo,rsoc%rsopplo,rsoc%rsoploplop) INQUIRE(file="socscale",exist=l_test) IF (l_test) THEN OPEN(99,file="socscale") READ(99,*) n CLOSE(99) WRITE(*,*) "SOC scaled by ",n,"%" rsoc%rsopp(:,:,:,:) = n/100.* rsoc%rsopp rsoc%rsopdp(:,:,:,:) = n/100.*rsoc%rsopdp rsoc%rsoppd(:,:,:,:) = n/100.*rsoc%rsoppd rsoc%rsopdpd(:,:,:,:) = n/100.*rsoc%rsopdpd rsoc%rsoplop(:,:,:,:) = n/100.*rsoc%rsoplop rsoc%rsoplopd(:,:,:,:) = n/100.*rsoc%rsoplopd rsoc%rsopdplo(:,:,:,:) = n/100.*rsoc%rsopdplo rsoc%rsopplo(:,:,:,:) = n/100.* rsoc%rsopplo rsoc%rsoploplop(:,:,:,:,:) = n/100.*rsoc%rsoploplop ENDIF IF (noco%soc_opt(atoms%ntype+1)) THEN DO n= 1,atoms%ntype IF (.NOT. noco%soc_opt(n)) THEN rsoc%rsopp(n,:,:,:) = 0.0 rsoc%rsopdp(n,:,:,:) = 0.0 rsoc%rsoppd(n,:,:,:) = 0.0 rsoc%rsopdpd(n,:,:,:) = 0.0 rsoc%rsoplop(n,:,:,:) = 0.0 rsoc%rsoplopd(n,:,:,:) = 0.0 rsoc%rsopdplo(n,:,:,:) = 0.0 rsoc%rsopplo(n,:,:,:) = 0.0 rsoc%rsoploplop(n,:,:,:,:) = 0.0 ENDIF ENDDO ENDIF IF ((first_k).AND.(mpi%irank.EQ.0)) THEN DO n = 1,atoms%ntype WRITE (6,FMT=8000) WRITE (6,FMT=9000) WRITE (6,FMT=8001) (2*rsoc%rsopp(n,l,1,1),l=1,3) WRITE (6,FMT=8001) (2*rsoc%rsopp(n,l,2,2),l=1,3) WRITE (6,FMT=8001) (2*rsoc%rsopp(n,l,2,1),l=1,3) ENDDO