LCOV - code coverage report
Current view: top level - eigen_secvar - hssr_wu.F90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 0 81 0.0 %
Date: 2019-09-08 04:53:50 Functions: 0 1 0.0 %

          Line data    Source code
       1             : MODULE m_hssrwu
       2             :   USE m_juDFT
       3             :   !
       4             :   !*********************************************************************
       5             :   !     updates the hamiltonian and overlap matrices with the
       6             :   !     contributions from the spheres, both spherical and non-
       7             :   !     spherical, for step forward approach
       8             :   !                r. wu  1992
       9             :   !*********************************************************************
      10             : CONTAINS
      11           0 :   SUBROUTINE hssr_wu(atoms,DIMENSION,sym, jsp,el,ne,usdus,lapw,input,&
      12           0 :        tlmplm,acof,bcof,ccof, h_r,s_r,h_c,s_c)
      13             :     !
      14             :     USE m_types
      15             :     IMPLICIT NONE
      16             : 
      17             :     TYPE(t_dimension),INTENT(IN)   :: DIMENSION
      18             :     TYPE(t_sym),INTENT(IN)         :: sym
      19             :     TYPE(t_atoms),INTENT(IN)       :: atoms
      20             :     TYPE(t_usdus),INTENT(IN)       :: usdus
      21             :     TYPE(t_tlmplm),INTENT(IN)      :: tlmplm
      22             :     TYPE(t_lapw),INTENT(IN)        :: lapw
      23             :     TYPE(t_input),INTENT(IN)       :: input
      24             :     !     ..
      25             :     !     .. Scalar Arguments ..
      26             :     INTEGER, INTENT (IN) :: jsp,ne     
      27             :     !     ..
      28             :     !     .. Array Arguments ..
      29             :     REAL,    INTENT (IN) :: el(0:atoms%lmaxd,atoms%ntype,input%jspins)
      30             :     COMPLEX, INTENT (IN) :: acof(DIMENSION%neigd,0:DIMENSION%lmd,atoms%nat)
      31             :     COMPLEX, INTENT (IN) :: bcof(DIMENSION%neigd,0:DIMENSION%lmd,atoms%nat)
      32             :     COMPLEX, INTENT (IN) :: ccof(-atoms%llod:atoms%llod,DIMENSION%neigd,atoms%nlod,atoms%nat)
      33             : 
      34             :     REAL,    OPTIONAL,INTENT (INOUT) :: h_r(DIMENSION%neigd,DIMENSION%neigd),s_r(DIMENSION%neigd,DIMENSION%neigd)
      35             :     COMPLEX, OPTIONAL,INTENT (INOUT) :: h_c(DIMENSION%neigd,DIMENSION%neigd),s_c(DIMENSION%neigd,DIMENSION%neigd)
      36             : 
      37             :     !     ..
      38             :     !     .. Local Scalars ..
      39             :     COMPLEX dtd,dtu,hij,sij,utd,utu
      40             :     REAL invsfct
      41             :     INTEGER i,im,in,j,k,ke,l,l1,ll1,lm,lmp,lwn ,m1,n,na,nn,lmplm,m
      42             :     LOGICAL :: l_real
      43             :     !     ..
      44             :     !     .. Local Arrays ..
      45           0 :     COMPLEX, ALLOCATABLE :: a(:,:),b(:,:),ax(:),bx(:)
      46             :     !     ..
      47             :     !     .. Intrinsic Functions ..
      48             :     INTRINSIC cmplx,conjg,exp,REAL,sqrt
      49             :     !     ..
      50             : 
      51           0 :     l_real=PRESENT(h_r)
      52             : 
      53           0 :     ALLOCATE ( a(DIMENSION%neigd,0:DIMENSION%lmd),ax(DIMENSION%neigd) )
      54           0 :     ALLOCATE ( b(DIMENSION%neigd,0:DIMENSION%lmd),bx(DIMENSION%neigd) )
      55             :     na = 0
      56           0 :     DO n = 1,atoms%ntype        ! loop over atom-types
      57           0 :        lwn = atoms%lmax(n)
      58           0 :        DO nn = 1,atoms%neq(n)    ! loop over atoms
      59           0 :           na = na + 1
      60             :           !+inv
      61           0 :           IF ((atoms%invsat(na).EQ.0) .OR. (atoms%invsat(na).EQ.1)) THEN
      62           0 :              CALL timestart("hssr_wu: spherical")
      63           0 :              IF (atoms%invsat(na).EQ.0) invsfct = 1.0
      64           0 :              IF (atoms%invsat(na).EQ.1) invsfct = SQRT(2.0)
      65           0 :              DO lm = 0, DIMENSION%lmd
      66           0 :                 DO ke = 1, ne
      67           0 :                    a(ke,lm) = invsfct*acof(ke,lm,na)
      68           0 :                    b(ke,lm) = invsfct*bcof(ke,lm,na)
      69             :                 ENDDO
      70             :              ENDDO
      71             : 
      72           0 :              DO l = 0,lwn                    ! l loop
      73           0 :                 DO m = -l,l                  ! m loop
      74           0 :                    lmp = l* (l+1) + m
      75           0 :                    DO i = 1,ne               ! matrix update
      76           0 :                       DO j = 1,i - 1
      77             :                          sij = a(i,lmp)*CONJG(a(j,lmp)) +&
      78           0 :                               b(i,lmp)*CONJG(b(j,lmp))*usdus%ddn(l,n,jsp)
      79             :                          hij = sij * el(l,n,jsp) +&
      80             :                               0.5 * ( a(i,lmp)*CONJG(b(j,lmp)) +&
      81           0 :                               b(i,lmp)*CONJG(a(j,lmp)) )
      82           0 :                          IF (l_real) THEN
      83           0 :                             s_r(i,j) = s_r(i,j) + REAL(sij)
      84           0 :                             h_r(i,j) = h_r(i,j) + REAL(hij)
      85             :                          ELSE
      86           0 :                             s_c(i,j) = s_c(i,j) + sij
      87           0 :                             h_c(i,j) = h_c(i,j) + hij
      88             :                          ENDIF
      89             :                       ENDDO
      90             :                    ENDDO
      91           0 :                    DO i = 1,ne
      92             :                       sij = a(i,lmp)*CONJG(a(i,lmp)) +&
      93           0 :                            b(i,lmp)*CONJG(b(i,lmp))*usdus%ddn(l,n,jsp)
      94             :                       hij = sij * el(l,n,jsp) +&
      95             :                            0.5 * ( a(i,lmp)*CONJG(b(i,lmp)) +&
      96           0 :                            b(i,lmp)*CONJG(a(i,lmp)) )
      97           0 :                       IF (l_real) THEN
      98           0 :                          s_r(i,i) = s_r(i,i) + REAL(sij)
      99           0 :                          h_r(i,i) = h_r(i,i) + REAL(hij)
     100             :                       ELSE
     101           0 :                          s_c(i,i) = s_c(i,i) + sij
     102           0 :                          h_c(i,i) = h_c(i,i) + hij
     103             :                       ENDIF
     104             :                    ENDDO
     105             :                 ENDDO        ! m
     106             :              ENDDO           ! l
     107             : 
     108           0 :              CALL timestop("hssr_wu: spherical")
     109           0 :              CALL timestart("hssr_wu: non-spherical")
     110           0 :              IF (atoms%lnonsph(n) >= 0 ) THEN
     111           0 :                 DO l = 0,atoms%lnonsph(n)
     112           0 :                    DO m = -l,l
     113             : 
     114           0 :                       lmp = l* (l+1) + m
     115           0 :                       ax(:) = CMPLX(0.0,0.0)
     116           0 :                       bx(:) = CMPLX(0.0,0.0)
     117             : 
     118           0 :                       DO l1 = 0,atoms%lnonsph(n)         ! l', m' loop
     119           0 :                          DO m1 = -l1,l1
     120           0 :                             lm = l1* (l1+1) + m1
     121           0 :                             in = tlmplm%ind(lmp,lm,n,jsp)
     122           0 :                             IF (in.NE.-9999) THEN
     123             : 
     124           0 :                                IF (in.GE.0) THEN
     125           0 :                                   utu = CONJG(tlmplm%tuu(in,n,jsp))
     126           0 :                                   dtu = CONJG(tlmplm%tdu(in,n,jsp))
     127           0 :                                   utd = CONJG(tlmplm%tud(in,n,jsp))
     128           0 :                                   dtd = CONJG(tlmplm%tdd(in,n,jsp))
     129             :                                ELSE
     130           0 :                                   im = -in
     131           0 :                                   utu = tlmplm%tuu(im,n,jsp)
     132           0 :                                   dtd = tlmplm%tdd(im,n,jsp)
     133           0 :                                   utd = tlmplm%tdu(im,n,jsp)
     134           0 :                                   dtu = tlmplm%tud(im,n,jsp)
     135             :                                END IF
     136             :                                !--->    update ax, bx
     137           0 :                                DO k = 1,ne
     138             :                                   ax(k) = ax(k) + utu*CONJG(a(k,lm))+&
     139           0 :                                        utd*CONJG(b(k,lm))
     140             :                                   bx(k) = bx(k) + dtu*CONJG(a(k,lm))+&
     141           0 :                                        dtd*CONJG(b(k,lm))
     142             :                                ENDDO
     143             : 
     144             :                             ENDIF ! in =/= -9999
     145             :                          ENDDO    ! m1
     146             :                       ENDDO       ! l1
     147             :                       !
     148             :                       !
     149             :                       !--->    update hamiltonian
     150           0 :                       IF (l_real) THEN
     151           0 :                          DO i = 1,ne
     152           0 :                             DO j = 1,i - 1
     153           0 :                                hij = a(i,lmp)*ax(j) + b(i,lmp)*bx(j)
     154           0 :                                h_r(i,j) = h_r(i,j) + REAL(hij)
     155             :                             ENDDO
     156             :                          ENDDO
     157             :                       ELSE
     158           0 :                          DO i = 1,ne
     159           0 :                             DO j = 1,i - 1
     160           0 :                                hij = a(i,lmp)*ax(j) + b(i,lmp)*bx(j)
     161           0 :                                h_c(i,j) = h_c(i,j) + hij
     162             :                             ENDDO
     163             :                          ENDDO
     164             :                       ENDIF
     165             : 
     166           0 :                       IF (l_real) THEN
     167           0 :                          DO i = 1,ne
     168           0 :                             h_r(i,i) = h_r(i,i) + REAL(a(i,lmp)*ax(i)+ b(i,lmp)*bx(i))
     169             :                          ENDDO
     170             :                       ELSE
     171           0 :                          DO i = 1,ne
     172           0 :                             h_c(i,i) = h_c(i,i) + a(i,lmp)*ax(i)+ b(i,lmp)*bx(i)
     173             :                          ENDDO
     174             :                       ENDIF
     175             : 
     176             :                    ENDDO ! m
     177             :                 ENDDO   ! l
     178             :              ENDIF     ! atoms%lnonsph >=0
     179           0 :              CALL timestop("hssr_wu: non-spherical")
     180             :              !-inv
     181             :           ENDIF ! invsatom = 0 or 1
     182             :        ENDDO   ! loop over atoms
     183             :     ENDDO     ! loop over atom-types
     184             : 
     185           0 :     DEALLOCATE ( a, b, ax, bx )
     186           0 :   END SUBROUTINE hssr_wu
     187             : END MODULE m_hssrwu

Generated by: LCOV version 1.13