LCOV - code coverage report
Current view: top level - wannier - wann_anglmom.f90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 0 112 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_wann_anglmom
       8             :   !***********************************************************************
       9             :   !     Compute matrix elements of angular momentum operator 
      10             :   !     in the muffin-tin spheres.
      11             :   !
      12             :   !     Frank Freimuth
      13             :   !***********************************************************************
      14             : CONTAINS
      15           0 :   SUBROUTINE wann_anglmom(atoms,usdus,jspin,acof,bcof,ccof, mmn)
      16             :     USE m_types
      17             :     IMPLICIT NONE
      18             :     !     .. scalar arguments ..
      19             :     TYPE(t_atoms),INTENT(in)::atoms
      20             :     TYPE(t_usdus),INTENT(in)::usdus
      21             :     INTEGER,INTENT(IN)      ::jspin
      22             :     !     .. array arguments ..
      23             :     COMPLEX, INTENT (in)  :: ccof(-atoms%llod:,:,:,:) !ccof(-llod:llod,noccbd,atoms%nlod,natd)
      24             :     COMPLEX, INTENT (in)  :: acof(:,0:,:)!acof(noccbd,0:lmd,natd)
      25             :     COMPLEX, INTENT (in)  :: bcof(:,0:,:)!bcof(noccbd,0:lmd,natd)
      26             :     COMPLEX, INTENT (inout) :: mmn(:,:,:)!mmn(3,noccbd,noccbd)
      27             :     !     .. local scalars ..
      28             :     LOGICAL :: l_select
      29             :     INTEGER :: i,j,l,lo,lop,m,natom,nn,ntyp
      30             :     INTEGER :: nt1,nt2,lm,n,ll1,indat
      31             :     COMPLEX :: suma_z,sumb_z
      32             :     COMPLEX :: suma_p,sumb_p
      33             :     COMPLEX :: suma_m,sumb_m
      34             :     COMPLEX :: suma_x,sumb_x
      35             :     COMPLEX :: suma_y,sumb_y
      36             :     REAL    :: lplus,lminus
      37             :     !     ..
      38             :     !     .. local arrays ..
      39           0 :     COMPLEX, ALLOCATABLE :: qlo_z(:,:,:,:,:)
      40           0 :     COMPLEX, ALLOCATABLE :: qlo_p(:,:,:,:,:)
      41           0 :     COMPLEX, ALLOCATABLE :: qlo_m(:,:,:,:,:)
      42             : 
      43           0 :     COMPLEX, ALLOCATABLE :: qaclo_z(:,:,:,:),qbclo_z(:,:,:,:)
      44           0 :     COMPLEX, ALLOCATABLE :: qaclo_p(:,:,:,:),qbclo_p(:,:,:,:)
      45           0 :     COMPLEX, ALLOCATABLE :: qaclo_m(:,:,:,:),qbclo_m(:,:,:,:)
      46             :     !     ..
      47             :     !     .. intrinsic functions ..
      48             :     INTRINSIC conjg
      49             : 
      50             :     ALLOCATE (qlo_z(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%nlod,atoms%ntype) &
      51             :            ,qaclo_z(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype),&
      52           0 :            qbclo_z(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype) )
      53             : 
      54             :     ALLOCATE (qlo_p(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%nlod,atoms%ntype) &
      55             :             ,qaclo_p(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype),&
      56           0 :             qbclo_p(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype) )
      57             : 
      58             :     ALLOCATE (qlo_m(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%nlod,atoms%ntype)&
      59             :                ,qaclo_m(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype),&
      60           0 :                 qbclo_m(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype) )
      61             : 
      62           0 :     INQUIRE(file='select_anglmom',exist=l_select)
      63           0 :     WRITE(*,*)'select_anglmom: ',l_select
      64           0 :     IF(l_select) THEN
      65           0 :        OPEN(866,file='select_anglmom')
      66           0 :        READ(866,*)indat
      67           0 :        CLOSE(866)
      68           0 :        WRITE(*,*)'anglmom for atom=',indat
      69           0 :        WRITE(*,*)atoms%ntype
      70           0 :        WRITE(*,*)atoms%neq(indat)
      71             :     ENDIF
      72             : 
      73             :     !-----> lapw-lapw-Terms
      74           0 :     DO i = 1,SIZE(acof,1)            
      75           0 :        DO j = 1,SIZE(acof,1)
      76             :           nt1 = 1
      77           0 :           DO n = 1,atoms%ntype
      78           0 :              nt2 = nt1 + atoms%neq(n) - 1
      79           0 :              DO l = 0,atoms%lmax(n)
      80           0 :                 suma_z = CMPLX(0.,0.); sumb_z = CMPLX(0.,0.)
      81           0 :                 suma_m = CMPLX(0.,0.); sumb_m = CMPLX(0.,0.)
      82           0 :                 suma_p = CMPLX(0.,0.); sumb_p = CMPLX(0.,0.)
      83           0 :                 IF(l_select .AND. (n.NE.indat)) CYCLE
      84           0 :                 ll1 = l* (l+1)
      85           0 :                 DO m = -l,l
      86           0 :                    lm = ll1 + m
      87           0 :                    lplus=SQRT(REAL( (l-m)*(l+m+1) ) )
      88           0 :                    lminus=SQRT(REAL( (l+m)*(l-m+1) ) )
      89           0 :                    DO natom = nt1,nt2
      90             :                       suma_z = suma_z + acof(i,lm,natom)*&
      91           0 :                                                      CONJG(acof(j,lm,natom))*REAL(m)
      92             :                       sumb_z = sumb_z + bcof(i,lm,natom)*&
      93           0 :                                                      CONJG(bcof(j,lm,natom))*REAL(m)
      94           0 :                       IF(m+1.LE.l)THEN
      95             :                          suma_p = suma_p + acof(i,lm,natom)*&
      96           0 :                                                         CONJG(acof(j,lm+1,natom))*lplus
      97             :                          sumb_p = sumb_p + bcof(i,lm,natom)*&
      98           0 :                                                         CONJG(bcof(j,lm+1,natom))*lplus
      99             :                       ENDIF
     100           0 :                       IF(m-1.GE.-l)THEN
     101             :                          suma_m = suma_m + acof(i,lm,natom)*&
     102           0 :                                                         CONJG(acof(j,lm-1,natom))*lminus
     103             :                          sumb_m = sumb_m + bcof(i,lm,natom)*&
     104           0 :                                                         CONJG(bcof(j,lm-1,natom))*lminus
     105             :                       ENDIF
     106             :                    ENDDO
     107             :                 ENDDO
     108           0 :                 mmn(3,j,i) = mmn(3,j,i) + (suma_z+sumb_z*usdus%ddn(l,n,jspin))
     109             : 
     110           0 :                 suma_x=0.5*(suma_p+suma_m)
     111           0 :                 sumb_x=0.5*(sumb_p+sumb_m)
     112           0 :                 mmn(1,j,i) = mmn(1,j,i) + (suma_x+sumb_x*usdus%ddn(l,n,jspin))
     113             : 
     114           0 :                 suma_y=CMPLX(0.0,-0.5)*(suma_p-suma_m)
     115           0 :                 sumb_y=CMPLX(0.0,-0.5)*(sumb_p-sumb_m)
     116           0 :                 mmn(2,j,i) = mmn(2,j,i) + (suma_y+sumb_y*usdus%ddn(l,n,jspin))
     117             :              ENDDO ! l
     118           0 :              nt1 = nt1 + atoms%neq(n)
     119             :           ENDDO ! n
     120             :        ENDDO ! j
     121             :     ENDDO ! i
     122             : 
     123             : 
     124             :     !---> Terms involving local orbitals.
     125           0 :     qlo_z = 0.0; qlo_p = 0.0; qlo_m = 0.0
     126           0 :     qaclo_z = 0.0; qaclo_p = 0.0; qaclo_m = 0.0
     127           0 :     qbclo_z = 0.0; qbclo_p = 0.0; qbclo_m = 0.0
     128             : 
     129             :     natom = 0
     130           0 :     DO ntyp = 1,atoms%ntype
     131           0 :        DO nn = 1,atoms%neq(ntyp)
     132           0 :           natom = natom + 1
     133           0 :           IF(l_select .AND. (ntyp.NE.indat)) CYCLE
     134           0 :           DO lo = 1,atoms%nlo(ntyp)
     135           0 :              l = atoms%llo(lo,ntyp)
     136           0 :              ll1 = l* (l+1)
     137           0 :              DO m = -l,l
     138           0 :                 lm = ll1 + m
     139           0 :                 lplus=SQRT(REAL( (l-m)*(l+m+1) ) )
     140           0 :                 lminus=SQRT(REAL( (l+m)*(l-m+1) ) )
     141           0 :                 DO i = 1,SIZE(acof,1)
     142           0 :                    DO j = 1,SIZE(acof,1)
     143             :                       qbclo_z(j,i,lo,ntyp) = qbclo_z(j,i,lo,ntyp) + (&
     144             :                                     bcof(i,lm,natom) * CONJG(ccof(m,j,lo,natom)) +&
     145           0 :                                     ccof(m,i,lo,natom)*CONJG(bcof(j,lm,natom)) )*REAL(m)
     146             : 
     147             :                       qaclo_z(j,i,lo,ntyp) = qaclo_z(j,i,lo,ntyp) + (&
     148             :                                     acof(i,lm,natom) * CONJG(ccof(m,j,lo,natom)) +&
     149           0 :                                     ccof(m,i,lo,natom)*CONJG(acof(j,lm,natom)) )*REAL(m)
     150           0 :                       IF(m+1.LE.l)THEN
     151             :                          qbclo_p(j,i,lo,ntyp) = qbclo_p(j,i,lo,ntyp) + (&
     152             :                                          bcof(i,lm,natom) * CONJG(ccof(m+1,j,lo,natom)) +&
     153           0 :                                          ccof(m,i,lo,natom)*CONJG(bcof(j,lm+1,natom)) )*lplus
     154             : 
     155             :                          qaclo_p(j,i,lo,ntyp) = qaclo_p(j,i,lo,ntyp) + (&
     156             :                                          acof(i,lm,natom) * CONJG(ccof(m+1,j,lo,natom)) +&
     157           0 :                                          ccof(m,i,lo,natom)*CONJG(acof(j,lm+1,natom)) )*lplus
     158             :                       ENDIF
     159           0 :                       IF(m-1.GE.-l)THEN
     160             :                          qbclo_m(j,i,lo,ntyp) = qbclo_m(j,i,lo,ntyp) + (&
     161             :                                          bcof(i,lm,natom) * CONJG(ccof(m-1,j,lo,natom)) +&
     162           0 :                                          ccof(m,i,lo,natom)*CONJG(bcof(j,lm-1,natom)) )*lminus
     163             : 
     164             :                          qaclo_m(j,i,lo,ntyp) = qaclo_m(j,i,lo,ntyp) + (&
     165             :                                          acof(i,lm,natom) * CONJG(ccof(m-1,j,lo,natom)) +&
     166           0 :                                          ccof(m,i,lo,natom)*CONJG(acof(j,lm-1,natom)) )*lminus
     167             :                       ENDIF
     168             : 
     169             :                    ENDDO !j
     170             :                 ENDDO !i
     171             :              ENDDO !m
     172           0 :              DO lop = 1,atoms%nlo(ntyp)
     173           0 :                 IF (atoms%llo(lop,ntyp).EQ.l) THEN
     174           0 :                    DO m = -l,l
     175           0 :                       lplus=SQRT(REAL( (l-m)*(l+m+1) ) )
     176           0 :                       lminus=SQRT(REAL( (l+m)*(l-m+1) ) )
     177           0 :                       DO i = 1,SIZE(acof,1)
     178           0 :                          DO j = 1,SIZE(acof,1)
     179             :                             qlo_z(j,i,lop,lo,ntyp) = qlo_z(j,i,lop,lo,ntyp) + &
     180             :                                                      CONJG(ccof(m,j,lop,natom))&
     181           0 :                                                                 *ccof(m,i,lo,natom)*REAL(m)
     182           0 :                             IF(m+1.LE.l)THEN
     183             :                                qlo_p(j,i,lop,lo,ntyp) = &
     184             :                                                        qlo_p(j,i,lop,lo,ntyp) + &
     185             :                                                         CONJG(ccof(m+1,j,lop,natom))&
     186           0 :                                                              *ccof(m,i,lo,natom)*lplus
     187             : 
     188             :                             ENDIF
     189           0 :                             IF(m-1.GE.-l)THEN
     190             :                                qlo_m(j,i,lop,lo,ntyp) = &
     191             :                                                        qlo_m(j,i,lop,lo,ntyp) + &
     192             :                                                         CONJG(ccof(m-1,j,lop,natom))&
     193           0 :                                                              *ccof(m,i,lo,natom)*lminus
     194             :                             ENDIF
     195             :                          ENDDO ! j
     196             :                       ENDDO ! i
     197             :                    ENDDO ! m
     198             :                 ENDIF
     199             :              ENDDO ! lop
     200             :           ENDDO ! lo
     201             :        ENDDO ! nn
     202             :     ENDDO ! ntyp
     203             :     !---> perform summation of the coefficients with the integrals
     204             :     !---> of the radial basis functions
     205           0 :     DO ntyp = 1,atoms%ntype
     206           0 :        IF(l_select .AND. (ntyp.NE.indat) ) CYCLE
     207           0 :        DO lo = 1,atoms%nlo(ntyp)
     208           0 :           l = atoms%llo(lo,ntyp)
     209           0 :           DO j = 1,SIZE(acof,1)
     210           0 :              DO i = 1,SIZE(acof,1)
     211             :                 mmn(3,i,j)= mmn(3,i,j)  + &
     212             :                                     qaclo_z(i,j,lo,ntyp)*usdus%uulon(lo,ntyp,jspin) +&
     213           0 :                                     qbclo_z(i,j,lo,ntyp)*usdus%dulon(lo,ntyp,jspin)  
     214             : 
     215             :                 suma_p=qaclo_p(i,j,lo,ntyp)*usdus%uulon(lo,ntyp,jspin) +&
     216           0 :                                      qbclo_p(i,j,lo,ntyp)*usdus%dulon(lo,ntyp,jspin)
     217             : 
     218             :                 suma_m=qaclo_m(i,j,lo,ntyp)*usdus%uulon(lo,ntyp,jspin) +&
     219           0 :                                      qbclo_m(i,j,lo,ntyp)*usdus%dulon(lo,ntyp,jspin)
     220             : 
     221           0 :                 suma_x=            0.5*(suma_p+suma_m)
     222           0 :                 suma_y=CMPLX(0.0,-0.5)*(suma_p-suma_m)
     223             : 
     224           0 :                 mmn(1,i,j)= mmn(1,i,j)  + suma_x
     225           0 :                 mmn(2,i,j)= mmn(2,i,j)  + suma_y 
     226             : 
     227             :              ENDDO !i
     228             :           ENDDO !j 
     229           0 :           DO lop = 1,atoms%nlo(ntyp)
     230           0 :              IF (atoms%llo(lop,ntyp).EQ.l) THEN
     231           0 :                 DO j = 1,SIZE(acof,1)
     232           0 :                    DO i = 1,SIZE(acof,1)
     233             :                       mmn(3,i,j) = mmn(3,i,j)  + &
     234           0 :                                           qlo_z(i,j,lop,lo,ntyp)*usdus%uloulopn(lop,lo,ntyp,jspin)
     235           0 :                       suma_p=qlo_p(i,j,lop,lo,ntyp)*usdus%uloulopn(lop,lo,ntyp,jspin)
     236           0 :                       suma_m=qlo_m(i,j,lop,lo,ntyp)*usdus%uloulopn(lop,lo,ntyp,jspin)
     237           0 :                       mmn(1,i,j) = mmn(1,i,j) + 0.5*(suma_p+suma_m)
     238             :                       mmn(2,i,j) = mmn(2,i,j) + &
     239           0 :                                             CMPLX(0.0,-0.5)*(suma_p-suma_m)
     240             :                    ENDDO ! i
     241             :                 ENDDO ! j
     242             :              ENDIF
     243             :           ENDDO !lop
     244             :        ENDDO !lo 
     245             :     ENDDO !ntyp 
     246           0 :     DEALLOCATE ( qlo_z,qaclo_z,qbclo_z )
     247           0 :     DEALLOCATE ( qlo_m,qaclo_m,qbclo_m )
     248           0 :     DEALLOCATE ( qlo_p,qaclo_p,qbclo_p )
     249             : 
     250           0 :   END SUBROUTINE wann_anglmom
     251             : END MODULE m_wann_anglmom

Generated by: LCOV version 1.13