LCOV - code coverage report
Current view: top level - eigen_soc - abcof_soc.F90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 98 124 79.0 %
Date: 2019-09-08 04:53:50 Functions: 2 2 100.0 %

          Line data    Source code
       1             : MODULE m_abcof_soc
       2             : CONTAINS
       3          76 :   SUBROUTINE abcof_soc(input,atoms,sym, cell,lapw,ne,usdus,&
       4             :                    noco,jspin,oneD,nat_start,nat_stop,nat_l,&
       5          76 :                    acof,bcof,ccof,zMat)
       6             :     !     ************************************************************
       7             :     !     subroutine constructs the a,b coefficients of the linearized
       8             :     !     m.t. wavefunctions for each band and atom.       c.l. fu
       9             :     !     ************************************************************
      10             : #include "cpp_double.h"
      11             : 
      12             :     USE m_constants, ONLY : tpi_const
      13             :     USE m_setabc1lo
      14             :     USE m_sphbes
      15             :     USE m_dsphbs
      16             :     USE m_ylm
      17             :     USE m_types
      18             :     USE m_juDFT
      19             :     IMPLICIT NONE
      20             :     TYPE(t_input),INTENT(IN)  :: input
      21             :     TYPE(t_usdus),INTENT(IN)  :: usdus
      22             :     TYPE(t_lapw),INTENT(IN)   :: lapw
      23             :     TYPE(t_oneD),INTENT(IN)   :: oneD
      24             :     TYPE(t_noco),INTENT(IN)   :: noco
      25             :     TYPE(t_sym),INTENT(IN)    :: sym
      26             :     TYPE(t_cell),INTENT(IN)   :: cell
      27             :     TYPE(t_atoms),INTENT(IN)  :: atoms
      28             :     TYPE(t_mat),INTENT(IN)    :: zMat
      29             :     !     ..
      30             :     !     .. Scalar Arguments ..
      31             :     INTEGER, INTENT (IN) :: ne,nat_start,nat_stop,nat_l
      32             :     INTEGER, INTENT (IN) :: jspin
      33             :     !     ..
      34             :     !     .. Array Arguments ..
      35             :     COMPLEX, INTENT (OUT) :: acof(:,0:,:)!(nobd,0:dimension%lmd,nat_l)
      36             :     COMPLEX, INTENT (OUT) :: bcof(:,0:,:)!(nobd,0:dimension%lmd,nat_l)
      37             :     COMPLEX, INTENT (OUT) :: ccof(-atoms%llod:,:,:,:)!(-llod:llod,nobd,atoms%nlod,nat_l)
      38             :     !     ..
      39             :     !     .. Local Scalars ..
      40             :     COMPLEX cexp,phase,c_0,c_1,c_2,ctmp,term1
      41             :     REAL const,df,r1,s,tmk,wronk
      42             :     INTEGER i,j,k,l,ll1,lm,n,natom,nn,iatom,jatom,lmp,m,nkvec,nbasf
      43             :     INTEGER inv_f,ie,ilo,iintsp,nintsp,nvmax,lo,natom_l,na2
      44             :     !     ..
      45             :     !     .. Local Arrays ..
      46          76 :     INTEGER nbasf0(atoms%nlod,atoms%nat)
      47          76 :     REAL dfj(0:atoms%lmaxd),fj(0:atoms%lmaxd),fg(3),fgp(3),fk(3),fkp(3)
      48         456 :     REAL alo1(atoms%nlod),blo1(atoms%nlod),clo1(atoms%nlod)
      49          76 :     COMPLEX ylm( (atoms%lmaxd+1)**2 )
      50         152 :     LOGICAL apw(0:atoms%lmaxd,atoms%ntype)
      51          76 :     REAL,    ALLOCATABLE :: work_r(:)
      52          76 :     COMPLEX, ALLOCATABLE :: work_c(:)
      53         228 :  !$ COMPLEX, ALLOCATABLE :: acof_l(:,:),bcof_l(:,:),ccof_l(:,:,:)
      54             : 
      55          76 :     CALL timestart("abcof")
      56             : 
      57          76 :     IF (zmat%l_real) THEN
      58           0 :        IF (noco%l_soc.AND.sym%invs) CALL judft_error("BUG in abcof, SOC&INVS but real?")
      59           0 :        IF (noco%l_noco) CALL judft_error("BUG in abcof, l_noco but real?")
      60             :     ENDIF
      61             : 
      62          76 :     const = 2 * tpi_const/SQRT(cell%omtil)
      63             : 
      64         221 :     acof(:,:,:)   = CMPLX(0.0,0.0)
      65         221 :     bcof(:,:,:)   = CMPLX(0.0,0.0)
      66         221 :     ccof(:,:,:,:) = CMPLX(0.0,0.0)
      67             : 
      68             :     !+APW_LO
      69         224 :     DO n = 1, atoms%ntype
      70        1496 :        DO l = 0,atoms%lmax(n)
      71        1348 :           apw(l,n) = .FALSE.
      72        1472 :           DO lo = 1,atoms%nlo(n)
      73        1472 :              IF (atoms%l_dulo(lo,n)) apw(l,n) = .TRUE.
      74             :           ENDDO
      75        1496 :           IF ((input%l_useapw).AND.(atoms%lapw_l(n).GE.l)) apw(l,n) = .FALSE.
      76             :        ENDDO
      77         236 :        DO lo = 1,atoms%nlo(n)
      78         160 :           IF (atoms%l_dulo(lo,n)) apw(atoms%llo(lo,n),n) = .TRUE.
      79             :        ENDDO
      80             :     ENDDO
      81             :     !+APW_LO
      82             :     !
      83             :     nintsp = 1
      84             :     !---> loop over the interstitial spin
      85         152 :     DO iintsp = 1,nintsp
      86             :        !
      87          76 :        nvmax=lapw%nv(jspin)
      88          76 :        IF (noco%l_ss) nvmax=lapw%nv(iintsp)
      89          76 :        natom_l = 0
      90             : 
      91             :        !---> loop over atom types
      92         224 :        DO n = 1,atoms%ntype
      93         148 :           CALL setabc1lo(atoms,n,usdus,jspin,alo1,blo1,clo1)
      94             :           !  ----> loop over equivalent atoms
      95         376 :           DO nn = 1,atoms%neq(n)
      96         152 :              natom = SUM(atoms%neq(:n-1)) + nn
      97         300 :              IF ((natom.GE.nat_start).AND.(natom.LE.nat_stop)) THEN
      98         145 :                 natom_l = natom_l + 1
      99         145 :                 IF (atoms%invsat(natom).EQ.2) THEN
     100           0 :                    jatom = sym%invsatnr(natom)
     101             :                 ELSE
     102             :                    jatom = natom
     103             :                 ENDIF
     104         145 :                 IF (zmat%l_real) THEN
     105           0 :                    ALLOCATE ( work_r(ne) )
     106             :                 ELSE
     107         145 :                    ALLOCATE ( work_c(ne) )
     108             :                 ENDIF
     109             :                 !--->        loop over lapws
     110             : #ifndef CPP_OLDINTEL
     111             :                 !$OMP PARALLEL &
     112             :                 !$OMP& DEFAULT(none)&
     113             :                 !$OMP& PRIVATE(k,i,work_r,work_c,fg,fk,s,r1,fj,dfj,l,df,wronk,tmk,phase,lo,nkvec,na2,nbasf,&
     114             :                 !$OMP& j,fkp,fgp,ylm,ll1,m,c_0,c_1,c_2,lmp,inv_f,lm,term1,ctmp,acof_l,bcof_l,ccof_l)&
     115             :                 !$OMP& SHARED(n,nn,natom,natom_l,noco,atoms,sym,cell,oneD,lapw,nvmax,ne,zMat,usdus,iintsp,&
     116         435 :                 !$OMP& alo1,blo1,clo1,jatom,jspin,apw,const,nbasf0,acof,bcof,ccof,nat_start,nat_stop)
     117         145 :                 !$   ALLOCATE(acof_l(size(acof,1),0:size(acof,2)-1),bcof_l(size(bcof,1),0:size(bcof,2)-1))
     118         145 :                 !$   ALLOCATE(ccof_l(-atoms%llod:atoms%llod,size(ccof,2),size(ccof,3)))
     119       13820 :                 !$   acof_l=0 ; bcof_l=0 ; ccof_l=0 
     120             :                 !$OMP DO
     121             : #endif
     122             :                 DO k = 1,nvmax
     123       27064 :                    IF (zmat%l_real) THEN
     124           0 :                       work_r(:ne)=zMat%data_r(k,:ne)
     125             :                    ELSE
     126       27064 :                       work_c(:ne)=zMat%data_c(k,:ne)
     127             :                    END IF
     128             : 
     129      108256 :                    fg = lapw%gvec(:,k,jspin) 
     130      189448 :                    fk = lapw%bkpt + fg
     131      108256 :                    s =  DOT_PRODUCT(fk,MATMUL(cell%bbmat,fk))
     132       27064 :                    s = SQRT(s)
     133       27064 :                    r1 = atoms%rmt(n)*s
     134       27064 :                    CALL sphbes(atoms%lmax(n),r1,fj)
     135       27064 :                    CALL dsphbs(atoms%lmax(n),r1,fj,dfj)
     136             :                    !  ----> construct a and b coefficients
     137      270644 :                    DO l = 0,atoms%lmax(n)
     138      243580 :                       df = s*dfj(l)
     139      243580 :                       wronk = usdus%uds(l,n,jspin)*usdus%dus(l,n,jspin) - usdus%us(l,n,jspin)*usdus%duds(l,n,jspin)
     140      270644 :                       IF (apw(l,n)) THEN
     141           0 :                          fj(l) = 1.0*const * fj(l)/usdus%us(l,n,jspin)
     142           0 :                          dfj(l) = 0.0
     143             :                       ELSE
     144      243580 :                          dfj(l) = const* (usdus%dus(l,n,jspin)*fj(l)-df*usdus%us(l,n,jspin))/wronk
     145      243580 :                          fj(l) = const* (df*usdus%uds(l,n,jspin)-fj(l)*usdus%duds(l,n,jspin))/wronk
     146             :                       ENDIF
     147             :                    ENDDO ! loop over l
     148      108256 :                    tmk = tpi_const* DOT_PRODUCT(fk(:),atoms%taual(:,jatom))
     149       27064 :                    phase = CMPLX(COS(tmk),SIN(tmk))
     150      351832 :                    fkp = MATMUL(fk(:),cell%bmat) ! fkr
     151       27064 :                    fgp = MATMUL(fg(:),cell%bmat) ! fgr
     152             :                    !     ----> generate spherical harmonics
     153       27064 :                    CALL ylm4(atoms%lmax(n),fkp,ylm)
     154             :                    !     ----> loop over l
     155       27064 :                    DO l = 0,atoms%lmax(n)
     156      243580 :                       ll1 = l* (l+1)
     157             :                       !     ----> loop over m
     158     2529148 :                       DO m = -l,l
     159     2258504 :                          lm = ll1 + m
     160     2258504 :                          c_0 = CONJG(ylm(lm+1))*phase
     161     2258504 :                          c_1 = c_0 *  fj(l)
     162     2258504 :                          c_2 = c_0 * dfj(l)
     163     2502084 :                          IF (atoms%invsat(natom).EQ.2) THEN
     164           0 :                            lmp = ll1 - m
     165           0 :                            inv_f = (-1)**(l-m)
     166           0 :                            c_1 =  conjg(c_1) * inv_f
     167           0 :                            c_2 =  conjg(c_2) * inv_f
     168           0 :                            IF (zmat%l_real) THEN
     169             :                               !$ IF (.false.) THEN
     170             :                               acof(:ne,lmp,natom_l) = acof(:ne,lmp,natom_l) +  c_1 * work_r(:ne)
     171             :                               bcof(:ne,lmp,natom_l) = bcof(:ne,lmp,natom_l) +  c_2 * work_r(:ne)
     172             :                               !$ ENDIF
     173           0 :                               !$ acof_l(:ne,lmp) = acof_l(:ne,lmp) +  c_1 * work_r(:ne)
     174           0 :                               !$ bcof_l(:ne,lmp) = bcof_l(:ne,lmp) +  c_2 * work_r(:ne)
     175             :                            ELSE
     176             :                               !$ IF (.false.) THEN
     177             :                               acof(:ne,lmp,natom_l) = acof(:ne,lmp,natom_l) +  c_1 * work_c(:ne)
     178             :                               bcof(:ne,lmp,natom_l) = bcof(:ne,lmp,natom_l) +  c_2 * work_c(:ne)
     179             :                               !$ ENDIF
     180           0 :                               !$ acof_l(:ne,lmp) = acof_l(:ne,lmp) +  c_1 * work_c(:ne)
     181           0 :                               !$ bcof_l(:ne,lmp) = bcof_l(:ne,lmp) +  c_2 * work_c(:ne)
     182             :                            END IF
     183             :                          ELSE
     184             :                            !     ----> loop over bands
     185     2258504 :                            IF (zmat%l_real) THEN
     186             :                               !$ IF (.false.) THEN
     187             :                               acof(:ne,lm,natom_l) = acof(:ne,lm,natom_l) +  c_1 * work_r(:ne)
     188             :                               bcof(:ne,lm,natom_l) = bcof(:ne,lm,natom_l) +  c_2 * work_r(:ne)
     189             :                               !$ ENDIF
     190           0 :                               !$ acof_l(:ne,lm) = acof_l(:ne,lm) +  c_1 * work_r(:ne)
     191           0 :                               !$ bcof_l(:ne,lm) = bcof_l(:ne,lm) +  c_2 * work_r(:ne)
     192             :                            ELSE
     193             :                               !$ IF (.false.) THEN
     194             :                               acof(:ne,lm,natom_l) = acof(:ne,lm,natom_l) +  c_1 * work_c(:ne)
     195             :                               bcof(:ne,lm,natom_l) = bcof(:ne,lm,natom_l) +  c_2 * work_c(:ne)
     196             :                               !$ ENDIF
     197   102158236 :                               !$ acof_l(:ne,lm) = acof_l(:ne,lm) +  c_1 * work_c(:ne)
     198     2258504 :                               !$ bcof_l(:ne,lm) = bcof_l(:ne,lm) +  c_2 * work_c(:ne)
     199             :                            END IF
     200             :                          ENDIF
     201             :                       ENDDO ! loop over m
     202             :                    ENDDO ! loop over l
     203       32994 :                    DO lo=1,atoms%nlo(n)
     204       48994 :                       DO nkvec=1,lapw%nkvec(lo,jatom) 
     205       27860 :                          IF (k==lapw%kvec(nkvec,lo,jatom)) THEN !check if this k-vector has LO attached
     206          30 :                             term1 = 2 * tpi_const/SQRT(cell%omtil) * ((atoms%rmt(n)**2)/2) * phase
     207          30 :                             IF ((atoms%invsat(natom)==0).OR.(atoms%invsat(natom)==1)) THEN
     208             :                                na2=natom
     209             :                             ELSE
     210           0 :                                na2 = sym%invsatnr(natom)
     211             :                             ENDIF
     212          30 :                             nbasf=lapw%nv(iintsp)+lapw%index_lo(lo,na2)+nkvec
     213          30 :                             l = atoms%llo(lo,n)
     214          30 :                             ll1 = l* (l+1)
     215        1758 :                             DO i = 1,ne
     216        7194 :                                DO m = -l,l
     217        7164 :                                   lm = ll1 + m
     218             :                                   !+gu_con
     219        8892 :                                   IF ((atoms%invsat(natom)==0).OR.(atoms%invsat(natom)==1)) THEN
     220        7164 :                                      IF (zMat%l_real) THEN
     221           0 :                                         ctmp = zMat%data_r(nbasf,i)*term1*CONJG(ylm(ll1+m+1))
     222             :                                      ELSE
     223        7164 :                                         ctmp = zMat%data_c(nbasf,i)*term1*CONJG(ylm(ll1+m+1))
     224             :                                      ENDIF
     225             :                                      !$ IF (.false.) THEN
     226             :                                      acof(i,lm,natom_l) = acof(i,lm,natom_l) + ctmp*alo1(lo)
     227             :                                      bcof(i,lm,natom_l) = bcof(i,lm,natom_l) + ctmp*blo1(lo)
     228             :                                      ccof(m,i,lo,natom_l) = ccof(m,i,lo,natom_l) + ctmp*clo1(lo)
     229             :                                      !$ ENDIF
     230        7164 :                                      !$ acof_l(i,lm)   = acof_l(i,lm)   +  ctmp*alo1(lo)
     231        7164 :                                      !$ bcof_l(i,lm)   = bcof_l(i,lm)   +  ctmp*blo1(lo)
     232        7164 :                                      !$ ccof_l(m,i,lo) = ccof_l(m,i,lo) +  ctmp*clo1(lo)
     233             :                                   ELSE
     234           0 :                                      ctmp = zMat%data_c(nbasf,i)*CONJG(term1)*ylm(ll1+m+1)*(-1)**(l-m)
     235           0 :                                      lmp = ll1 - m
     236             :                                      !$ IF (.false.) THEN
     237             :                                      acof(i,lmp,natom_l) = acof(i,lmp,natom_l) +ctmp*alo1(lo)
     238             :                                      bcof(i,lmp,natom_l) = bcof(i,lmp,natom_l) +ctmp*blo1(lo)
     239             :                                      ccof(-m,i,lo,natom_l) = ccof(-m,i,lo,natom_l) +ctmp*clo1(lo)
     240             :                                      !$ ENDIF
     241           0 :                                      !$ acof_l(i,lmp)   = acof_l(i,lmp)   +  ctmp*alo1(lo)
     242           0 :                                      !$ bcof_l(i,lmp)   = bcof_l(i,lmp)   +  ctmp*blo1(lo)
     243           0 :                                      !$ ccof_l(-m,i,lo) = ccof_l(-m,i,lo) +  ctmp*clo1(lo)
     244             :                                   ENDIF
     245             :                                END DO
     246             :                             END DO
     247             :                          ENDIF
     248             :                       ENDDO
     249             :                    END DO
     250             :                 ENDDO ! loop over LAPWs (k)
     251             : #ifndef CPP_OLDINTEL
     252             :                 !$OMP END DO
     253         290 :                 !$OMP CRITICAL
     254       13530 :                 !$ acof(:,:,natom_l)   = acof(:,:,natom_l)   + acof_l(:,:)
     255       13530 :                 !$ bcof(:,:,natom_l)   = bcof(:,:,natom_l)   + bcof_l(:,:)
     256         435 :                 !$ ccof(:,:,:,natom_l) = ccof(:,:,:,natom_l) + ccof_l(:,:,:)
     257             :                 !$OMP END CRITICAL
     258         145 :                 !$ DEALLOCATE (acof_l,bcof_l,ccof_l)
     259             :                 !$OMP END PARALLEL
     260             : #endif
     261         145 :                 IF (zmat%l_real) THEN
     262           0 :                    DEALLOCATE(work_r)
     263             :                 ELSE               
     264         145 :                    DEALLOCATE(work_c)
     265             :                 ENDIF
     266             :              ENDIF ! nat_start <= natom <= nat_stop
     267             :           ENDDO    ! loop over equivalent atoms
     268             :        ENDDO       ! loop over atom types
     269             :     ENDDO       ! loop over interstitial spin
     270             : 
     271          76 :     CALL timestop("abcof")
     272             : 
     273         304 :   END SUBROUTINE abcof_soc
     274             : END MODULE m_abcof_soc

Generated by: LCOV version 1.13