aline_muff.F90 4.01 KB
Newer Older
1 2 3 4 5 6
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
MODULE m_alinemuff
  !************************************************************************
  !*                                                                      *
  !*     eigensystem-solver for moderatly-well converged potentials       *
  !*     a*z=e*b*z is transformed to h*z'=e*s*z' , whereby                *
  !*     h=C^T*a*C, s=C^T*b*C and z'=C^(-1)*z, when C is z of the last    *
  !*     iteration (lapw%nv*ne-array)                                          *
  !*     For ne<<lapw%nv the matrixsize is significantly reduced               *
  !*     aline uses ESSL-calls (use LAPACK's reduc3, tred3, bisect,       *
  !*     tinvit, trback and rebk3  if no ESSL available):                 *
  !*     SSPEV:  eigensystem-solver for symmetric, real packes h          *
  !*             here we have no s-matrix                                 *
  !*     For all eigenvalues are needed, SSPEV should perform better      *
  !*     then seclr4 (hope so)                                            *
  !*                                                     Gustav           *
  !*                                                                      *
  !************************************************************************
CONTAINS
25
  SUBROUTINE aline_muff(atoms,DIMENSION,sym, cell, jsp,ne, usdus,td, bkpt,lapw, eig,z_r,z_c,realdata)
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45

#include"cpp_double.h"

    USE m_hnonmuff
    USE m_types
    IMPLICIT NONE
    TYPE(t_dimension),INTENT(IN)   :: DIMENSION
    TYPE(t_sym),INTENT(IN)         :: sym
    TYPE(t_cell),INTENT(IN)        :: cell
    TYPE(t_atoms),INTENT(IN)       :: atoms
    TYPE(t_usdus),INTENT(IN)       :: usdus
    TYPE(t_lapw),INTENT(IN)        :: lapw
    TYPE(t_tlmplm),INTENT(IN)      :: td
    !     ..
    !     .. Scalar Arguments ..
    INTEGER, INTENT (IN) :: jsp,ne   
    !     ..
    !     .. Array Arguments ..
    REAL,    INTENT (IN) :: bkpt(3)   
    REAL,    INTENT (INOUT) :: eig(DIMENSION%neigd)
46 47 48 49

    REAL,    OPTIONAL,INTENT (INOUT) :: z_r(DIMENSION%nbasfcn,ne)
    COMPLEX, OPTIONAL,INTENT (INOUT) :: z_c(DIMENSION%nbasfcn,ne)
    LOGICAL,OPTIONAL,INTENT(IN):: realdata
50 51 52 53 54 55 56 57 58 59 60 61 62
    !     ..
    !     .. Local Scalars ..
    INTEGER i,info,j,ii
    !     ..
    !     .. Local Arrays ..
    REAL h(ne*(ne+1)/2),help(3*ne),z1(ne,ne)
    !     ..
    !     .. External Functions ..
    REAL CPP_BLAS_sdot
    EXTERNAL CPP_BLAS_sdot
    !     ..
    !     .. External Subroutines ..
    EXTERNAL CPP_LAPACK_ssygv
63
    LOGICAL l_real
64

65 66
    l_real=present(z_r)
    if (present(realdata)) l_real=realdata
67

68 69 70 71 72 73 74 75 76
    !     ..
    !---> initialize the hamiltonian and overlap matrix
       h = 0.0
       !---> add the diagonal (muffin-tin) terms
       DO i = 1,ne
          ii = (i-1)*i/2 + i
          h(ii) = eig(i)
       END DO
   
77
    !---> add the off-diagonal (non-muffin-tin) terms
78
    CALL h_nonmuff(atoms,DIMENSION,sym, cell, jsp,ne, usdus,td, bkpt,lapw, h,l_real,z_r,z_c)
79 80 81 82

    !---> DIAGONALIZE THE HAMILTONIAN USING LIBRARY-ROUTINES
#ifdef CPP_ESSL
    !---> ESSL call, IBM AIX
83
    CALL CPP_LAPACK_sspev (21, h, eig,z1, ne,ne,help,3*ne)
84 85
#else
    !---> LAPACK call
86
    CALL CPP_LAPACK_sspev ('V','U',ne, h, eig,z1, ne,help, info)
87 88 89 90 91 92
    WRITE (6,FMT=8000) info
8000 FORMAT (' AFTER CPP_LAPACK_sspev: info=',i4)
#endif

    !---> store eigenvectors on array z
    DO i = 1,lapw%nv(jsp)
93 94 95 96 97 98 99 100 101 102 103
       if (l_real) THEN
          help(:ne)=z_r(i,:ne)
          DO j = 1,ne
             z_r(i,j) = CPP_BLAS_sdot(ne,help,1,z1(1,j),1)
          END DO
       else
          help(:ne)=z_c(i,:ne)
          DO j = 1,ne
             z_c(i,j) = CPP_BLAS_sdot(ne,help,1,z1(1,j),1)
          END DO
       endif
104 105 106 107
    END DO

  END SUBROUTINE aline_muff
END MODULE m_alinemuff