LCOV - code coverage report
Current view: top level - eigen_secvar - h_nonmuff.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             : !--------------------------------------------------------------------------------
       2             : ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
       3             : ! This file is part of FLEUR and available as free software under the conditions
       4             : ! of the MIT license as expressed in the LICENSE file in more detail.
       5             : !--------------------------------------------------------------------------------
       6             : 
       7             : MODULE m_hnonmuff
       8             :   !*********************************************************************
       9             :   !     updates hamiltonian by adding non-spherical matrix elements in
      10             :   !     the second-variation scheme. usage of tlmplm-nonmuff required
      11             :   !                r. p  1995
      12             :   !*********************************************************************
      13             : CONTAINS
      14           0 :   SUBROUTINE h_nonmuff(atoms,DIMENSION,sym,cell, jsp,ne,usdus,td, bkpt,lapw, h,l_real,z_r,z_c)
      15             : 
      16             :     USE m_constants, ONLY : fpi_const,tpi_const
      17             :     USE m_types
      18             :     USE m_sphbes
      19             :     USE m_dsphbs
      20             :     USE m_ylm
      21             :     IMPLICIT NONE
      22             : 
      23             :     TYPE(t_dimension),INTENT(IN)   :: DIMENSION
      24             :     TYPE(t_sym),INTENT(IN)         :: sym
      25             :     TYPE(t_cell),INTENT(IN)        :: cell
      26             :     TYPE(t_atoms),INTENT(IN)       :: atoms
      27             :     TYPE(t_usdus),INTENT(IN)       :: usdus
      28             :     TYPE(t_lapw),INTENT(IN)        :: lapw
      29             :     !     ..
      30             :     !     .. Scalar Arguments ..
      31             :     LOGICAL,INTENT(IN)   :: l_real
      32             :     INTEGER, INTENT (IN) :: jsp,ne     
      33             :     !     ..
      34             :     TYPE(t_tlmplm),INTENT(IN)::td
      35             :     !     .. Array Arguments ..
      36             :     REAL,    INTENT (IN) :: bkpt(3)   
      37             :     REAL,    INTENT (INOUT) :: h(ne*(ne+1)/2)
      38             : 
      39             :     REAL,    OPTIONAL,INTENT (IN) :: z_r(DIMENSION%nbasfcn,ne)
      40             :     COMPLEX, OPTIONAL,INTENT (IN) :: z_c(DIMENSION%nbasfcn,ne)
      41             :     !     ..
      42             :     !     .. Local Scalars ..
      43             :     COMPLEX dtd,dtu,hij,phase,sij,utd,utu
      44             :     REAL con1,ff,gg,gs,th,ws
      45             :     INTEGER l,l1,ll1,lm,lmp,lwn,invsfct
      46             :     INTEGER i,im,in,j,k,ke ,m1,n,na,nn,np,ii,ij,m
      47             :     !     ..
      48             :     !     .. Local Arrays ..
      49           0 :     COMPLEX a(DIMENSION%neigd,0:DIMENSION%lmd),ax(DIMENSION%neigd)
      50           0 :     COMPLEX b(DIMENSION%neigd,0:DIMENSION%lmd),bx(DIMENSION%neigd), ylm( (atoms%lmaxd+1)**2 )
      51           0 :     REAL vmult(3),vsmult(3),f(0:atoms%lmaxd,SIZE(lapw%k1,1)),g(0:atoms%lmaxd,SIZE(lapw%k1,1))
      52             :     !     ..
      53             :     !     ..
      54             : 
      55           0 :     con1 = fpi_const/SQRT(cell%omtil)
      56             :     !--->    loop over each atom type
      57           0 :     na = 0
      58           0 :     DO  n = 1,atoms%ntype
      59           0 :        lwn = atoms%lmax(n)
      60             :        !--->    set up wronskians for the matching conditions for each ntype
      61           0 :        DO k = 1,lapw%nv(jsp)
      62           0 :           gs = lapw%rk(k,jsp)*atoms%rmt(n)
      63           0 :           CALL sphbes(lwn,gs, f(0,k))
      64           0 :           CALL dsphbs(lwn,gs,f(0,k), g(0,k))
      65             :        ENDDO
      66           0 :        DO  l = 0,lwn
      67           0 :           ws = usdus%uds(l,n,jsp)*usdus%dus(l,n,jsp) - usdus%us(l,n,jsp)*usdus%duds(l,n,jsp)
      68           0 :           DO  k = 1,lapw%nv(jsp)
      69           0 :              ff = f(l,k)
      70           0 :              gg = lapw%rk(k,jsp)*g(l,k)
      71           0 :              f(l,k) = con1* (usdus%uds(l,n,jsp)*gg-ff*usdus%duds(l,n,jsp))/ws
      72           0 :              g(l,k) = con1* (usdus%dus(l,n,jsp)*ff-gg*usdus%us(l,n,jsp))/ws
      73             :           ENDDO
      74             :        ENDDO
      75             :        !--->    loop over equivalent atoms
      76           0 :        DO  nn = 1,atoms%neq(n)
      77           0 :           na = na + 1
      78             :           !+inv
      79           0 :           IF ((atoms%invsat(na).EQ.0) .OR. (atoms%invsat(na).EQ.1)) THEN
      80           0 :              IF (atoms%invsat(na).EQ.0) invsfct = 1
      81           0 :              IF (atoms%invsat(na).EQ.1) invsfct = 2
      82           0 :              np = atoms%ngopr(na)
      83             :              !---> a and b
      84           0 :              a(:ne,:) = CMPLX(0.0,0.0)
      85           0 :              b(:ne,:) = CMPLX(0.0,0.0)
      86           0 :              DO  k = 1,lapw%nv(jsp)
      87           0 :                 vmult=bkpt+(/lapw%k1(k,jsp),lapw%k2(k,jsp),lapw%k3(k,jsp)/)
      88           0 :                 th = tpi_const* DOT_PRODUCT( vmult,atoms%taual(:,na))
      89           0 :                 phase = CMPLX(COS(th),-SIN(th))
      90             :                 !-->     apply the rotation that brings this atom into the
      91             :                 !-->     representative for hamiltonian (this is the definition
      92             :                 !-->     of ngopr(na)) and transform to cartesian coordinates
      93           0 :                 vsmult=MATMUL(vmult,sym%mrot(:,:,np))
      94           0 :                 vmult=MATMUL(vsmult,cell%bmat)
      95           0 :                 CALL ylm4(lwn,vmult, ylm)
      96             :                 !-->     synthesize the complex conjugates of a and b
      97           0 :                 if (l_real) THEN
      98           0 :                    DO l = 0,lwn
      99           0 :                       ll1 = l* (l+1)
     100           0 :                       DO m = -l,l
     101           0 :                          lm = ll1 + m
     102           0 :                          hij = f(l,k) * ( phase * ylm(lm+1) )
     103           0 :                          sij = g(l,k) * ( phase * ylm(lm+1) )
     104           0 :                          a(:ne,lm) = a(:ne,lm) + hij*z_r(k,:ne)
     105           0 :                          b(:ne,lm) = b(:ne,lm) + sij*z_r(k,:ne)
     106             :                       END DO
     107             :                    END DO
     108             : 
     109             :                 else
     110           0 :                    DO l = 0,lwn
     111           0 :                       ll1 = l* (l+1)
     112           0 :                       DO m = -l,l
     113           0 :                          lm = ll1 + m
     114           0 :                          hij = f(l,k) * ( phase * ylm(lm+1) )
     115           0 :                          sij = g(l,k) * ( phase * ylm(lm+1) )
     116           0 :                          a(:ne,lm) = a(:ne,lm) + hij*z_c(k,:ne)
     117           0 :                          b(:ne,lm) = b(:ne,lm) + sij*z_c(k,:ne)
     118             :                       END DO
     119             :                    END DO
     120             :                 endif
     121             :              ENDDO
     122           0 :              DO  l = 0,lwn
     123           0 :                 DO  m = -l,l
     124           0 :                    lmp = l* (l+1) + m
     125             :                    !--->    initialize ax and bx
     126           0 :                    ax = CMPLX(0.0,0.0)
     127           0 :                    bx = CMPLX(0.0,0.0)
     128             :                    !--->    loop over l,m
     129           0 :                    DO  l1 = 0,lwn
     130           0 :                       DO  m1 = -l1,l1
     131           0 :                          lm = l1* (l1+1) + m1
     132           0 :                          in = td%ind(lmp,lm,nn,jsp)
     133           0 :                          IF (in.NE.-9999) THEN
     134           0 :                             IF (in.GE.0) THEN
     135           0 :                                utu = CONJG(td%tuu(in,nn,jsp))*invsfct
     136           0 :                                dtu = CONJG(td%tdu(in,nn,jsp))*invsfct
     137           0 :                                utd = CONJG(td%tud(in,nn,jsp))*invsfct
     138           0 :                                dtd = CONJG(td%tdd(in,nn,jsp))*invsfct
     139             :                             ELSE
     140           0 :                                im = -in
     141           0 :                                utu = td%tuu(im,nn,jsp)*invsfct
     142           0 :                                dtd = td%tdd(im,nn,jsp)*invsfct
     143           0 :                                utd = td%tdu(im,nn,jsp)*invsfct
     144           0 :                                dtu = td%tud(im,nn,jsp)*invsfct
     145             :                             END IF
     146             :                             !--->    update ax, bx
     147           0 :                             ax(:ne) = ax(:ne) + CONJG(utu*a(:ne,lm)+utd*b(:ne,lm))
     148           0 :                             bx(:ne) = bx(:ne) + CONJG(dtu*a(:ne,lm)+dtd*b(:ne,lm))
     149             :                          END IF
     150             :                       ENDDO
     151             :                    ENDDO
     152             : 
     153             :                    !--->    update hamiltonian in upper packed storage mode
     154           0 :                    DO i = 1,ne
     155           0 :                       ii = (i-1)*i/2
     156           0 :                       DO j = 1,i - 1
     157           0 :                          ij = ii + j
     158           0 :                          hij = a(i,lmp)*ax(j) + b(i,lmp)*bx(j)
     159           0 :                          h(ij) = h(ij) + REAL(hij)
     160             :                       END DO
     161             :                       h(ii+i) = h(ii+i) + REAL(a(i,lmp)*ax(i)+&
     162           0 :                            &                        b(i,lmp)*bx(i))
     163             :                    END DO
     164             :                 ENDDO
     165             :              ENDDO
     166             : 
     167             :           ENDIF
     168             :           !-inv
     169             :        ENDDO
     170             :     ENDDO
     171           0 :   END SUBROUTINE h_nonmuff
     172             : END MODULE m_hnonmuff

Generated by: LCOV version 1.13