LCOV - code coverage report
Current view: top level - eigen - orthoglo.F90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 23 23 100.0 %
Date: 2019-09-08 04:53:50 Functions: 1 1 100.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_orthoglo
       8             :   USE m_juDFT
       9             :   !*********************************************************************
      10             :   ! Each G-vector corresponds to a vector of C-coeff. These vectors must
      11             :   ! be linearly independent. This is checked by this soubroutine for an
      12             :   ! atom that doesn't have an inversion partner.
      13             :   ! Philipp Kurz 99/04
      14             :   !*********************************************************************
      15             : CONTAINS
      16       18382 :   SUBROUTINE orthoglo(l_real,atoms, nkvec,lo,l,linindq,l_lo2, cwork, linind)
      17             :     !
      18             :     !*************** ABBREVIATIONS ***************************************
      19             :     ! cwork   : contains the vectors of C-coeff.
      20             :     ! l_lo2   : changes this routine to old 'orthoglo2': same as orthoglo, 
      21             :     !           but for a pair of atoms that can be mapped onto eachother 
      22             :     !           by inversion.
      23             :     ! CF Replaced (unstable) Gram-Schmidt by diagonalization.
      24             :     !*********************************************************************
      25             :     !
      26             : #include"cpp_double.h"
      27             :     !
      28             :     USE m_types_setup
      29             :     IMPLICIT NONE
      30             :     TYPE(t_atoms),INTENT(IN)   :: atoms
      31             :     !     ..
      32             :     !     .. Scalar Arguments ..
      33             :     INTEGER, INTENT (IN) :: l,lo,nkvec
      34             :     REAL,    INTENT (IN) :: linindq
      35             :     LOGICAL, INTENT (IN) :: l_lo2,l_real
      36             :     LOGICAL, INTENT (OUT) :: linind
      37             :     !     ..
      38             :     !     .. Array Arguments ..
      39             :     COMPLEX,INTENT (INOUT):: cwork(-2*atoms%llod:2*atoms%llod+1,2*(2*atoms%llod+1) ,atoms%nlod)
      40             :     !     ..
      41             :     !     .. Local Scalars ..
      42             :     INTEGER dim,low,i,j
      43             :     !     ..
      44             :     !     .. Local Arrays ..
      45       73528 :     REAL eig(nkvec),rwork(3*nkvec)
      46       36764 :     REAL olap_r(nkvec,nkvec)
      47             :     EXTERNAL CPP_LAPACK_ssyev
      48       73528 :     COMPLEX olap_c(nkvec,nkvec),work(2*nkvec)
      49             :     EXTERNAL CPP_LAPACK_cheev
      50             : 
      51       18382 :     IF (l_lo2) THEN
      52       15096 :        dim = 2* (2*l+1)
      53       15096 :        low = -2*l
      54             :     ELSE
      55        3286 :        dim = 2*l+1
      56        3286 :        low = -l
      57             :     ENDIF
      58             : 
      59       78850 :     DO i = 1,nkvec
      60      588314 :        DO j = 1,nkvec
      61      315200 :           IF (l_real) THEN
      62      251196 :              olap_r(i,j) = DOT_PRODUCT(cwork(low:low+dim-1,i,lo), cwork(low:low+dim-1,j,lo))
      63             :           ELSE
      64        3536 :              olap_c(i,j) = DOT_PRODUCT(cwork(low:low+dim-1,i,lo), cwork(low:low+dim-1,j,lo))
      65             :           ENDIF
      66             :        ENDDO
      67             :     ENDDO
      68       18382 :     IF (l_real) THEN
      69       17760 :        CALL CPP_LAPACK_ssyev('N','U',nkvec,olap_r,nkvec,eig, rwork,3*nkvec,i)
      70       17760 :        IF(i/=0)  CALL juDFT_error("(S,D)SYEV failed.","orthoglo")
      71             :     ELSE
      72         622 :        CALL CPP_LAPACK_cheev('N','U',nkvec,olap_c,nkvec,eig, work,2*nkvec,rwork,i)
      73         622 :        IF(i/=0)  CALL juDFT_error("(C,Z)HEEV failed.","orthoglo")
      74             :     ENDIF
      75       18382 :     IF(eig(1).LT.linindq) THEN
      76        4608 :        linind = .FALSE.
      77             :     ELSE
      78       13774 :        linind = .TRUE.
      79             :     ENDIF
      80       18382 :     RETURN
      81             : 
      82             :   END SUBROUTINE orthoglo
      83             : END MODULE m_orthoglo

Generated by: LCOV version 1.13