flipcdn.f90 5.63 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
MODULE m_flipcdn
8 9 10 11 12 13 14 15 16
!     *******************************************************
!     this subroutine reads the charge density and flips the 
!     magnetic moment within the m.t.sphere for each atom 
!     according to the variable nflip. This variable is read in
!     the main program
!             nflip = -1 : flip spin in sphere
!             nflip = -2 : scale spin by bmu(n)
!             nflip = any: no spin flip
!                            r.pentcheva,kfa,Feb'96
Daniel Wortmann's avatar
Daniel Wortmann committed
17 18
!
!     Extension to multiple U per atom type by G.M. 2017
19
!     *******************************************************
20 21
CONTAINS

22
SUBROUTINE flipcdn(atoms,input,vacuum,sphhar,stars,sym,noco,oneD,cell)
23 24 25 26 27 28 29 30 31 32 33 34 35

   USE m_constants
   USE m_cdn_io
   USE m_types

   IMPLICIT NONE

   TYPE(t_stars),INTENT(IN)    :: stars
   TYPE(t_vacuum),INTENT(IN)   :: vacuum
   TYPE(t_atoms),INTENT(IN)    :: atoms
   TYPE(t_sphhar),INTENT(IN)   :: sphhar
   TYPE(t_input),INTENT(INOUT) :: input
   TYPE(t_sym),INTENT(IN)      :: sym
36
   TYPE(t_noco),INTENT(IN)     :: noco
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
   TYPE(t_oneD),INTENT(IN)     :: oneD
   TYPE(t_cell),INTENT(IN)     :: cell

   ! Local type instance
   TYPE(t_potden)            :: den

   ! Local Scalars
   REAL                      :: rhodummy,rhodumms,fermiEnergyTemp
   INTEGER                   :: i,nt,j,lh,na,mp,ispin,urec,itype,m,i_u
   INTEGER                   :: archiveType
   LOGICAL                   :: n_exist,l_qfix,l_error

   ! Local Arrays
   CHARACTER(len=80), ALLOCATABLE :: clines(:)

52
   CALL den%init(stars,atoms,sphhar,vacuum,noco,input%jspins,POTDEN_TYPE_DEN)
53
   IF(noco%l_noco) THEN
54 55 56 57 58 59 60
      archiveType = CDN_ARCHIVE_TYPE_NOCO_const
   ELSE
      archiveType = CDN_ARCHIVE_TYPE_CDN1_const
   END IF

   ! read the charge density 
   CALL readDensity(stars,vacuum,atoms,cell,sphhar,input,sym,oneD,archiveType,&
61
                    CDN_INPUT_DEN_const,0,fermiEnergyTemp,l_qfix,den)
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88

   ! flip cdn for each atom with nflip=-1
   na = 1
   DO itype = 1, atoms%ntype
      IF (atoms%nflip(itype).EQ.-1) THEN
         ! spherical and non-spherical m.t. charge density
         DO lh = 0,sphhar%nlh(atoms%ntypsy(na))
            DO j = 1,atoms%jri(itype)
               rhodummy = den%mt(j,lh,itype,1)
               den%mt(j,lh,itype,1) = den%mt(j,lh,itype,input%jspins)
               den%mt(j,lh,itype,input%jspins) = rhodummy
            END DO
         END DO
      ELSE IF (atoms%nflip(itype).EQ.-2) THEN
         DO lh = 0,sphhar%nlh(atoms%ntypsy(na))
            DO j = 1,atoms%jri(itype)
               rhodummy = den%mt(j,lh,itype,1) + den%mt(j,lh,itype,input%jspins)
               rhodumms = den%mt(j,lh,itype,1) - den%mt(j,lh,itype,input%jspins)
               den%mt(j,lh,itype,1) = 0.5 * (rhodummy + atoms%bmu(itype)*rhodumms)
               den%mt(j,lh,itype,input%jspins) = 0.5 * (rhodummy - atoms%bmu(itype)*rhodumms )
            END DO
         END DO
      END IF
         na = na + atoms%neq(itype)
   END DO

   ! for LDA+U: flip density matrix
89
   IF (ANY(den%mmpMat(:,:,:,:).NE.0.0).AND.atoms%n_u>0) THEN
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
      DO i_u = 1, atoms%n_u
         itype = atoms%lda_u(i_u)%atomType
         IF (atoms%nflip(itype).EQ.-1) THEN
            DO m = -3,3
               DO mp = -3,3
                  rhodummy = den%mmpMat(m,mp,i_u,1)
                  den%mmpMat(m,mp,i_u,1) = den%mmpMat(m,mp,i_u,input%jspins)
                  den%mmpMat(m,mp,i_u,input%jspins) = rhodummy
               END DO
            END DO
         ELSE IF (atoms%nflip(itype).EQ.-2) THEN
            DO m = -3,3
               DO mp = -3,3
                  rhodummy = den%mmpMat(m,mp,i_u,1) + den%mmpMat(m,mp,i_u,input%jspins)
                  rhodumms = den%mmpMat(m,mp,i_u,1) - den%mmpMat(m,mp,i_u,input%jspins)
                  den%mmpMat(m,mp,i_u,1) = 0.5 * (rhodummy + atoms%bmu(itype) * rhodumms)
                  den%mmpMat(m,mp,i_u,input%jspins) = 0.5 * (rhodummy - atoms%bmu(itype) * rhodumms)
               END DO
            END DO
         END IF
      END DO
   END IF

   ! write the spin-polarized density
   CALL writeDensity(stars,vacuum,atoms,cell,sphhar,input,sym,oneD,archiveType,CDN_INPUT_DEN_const,&
115
                     0,-1.0,0.0,.FALSE.,den)
116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162

   ! read enpara and  flip lines
   INQUIRE(file='enpara',exist=n_exist)
   IF (n_exist) THEN
      OPEN(40,file ='enpara',status='old',form='formatted')

      j = 2
      DO itype = 1, atoms%ntype
         j = j + 1
         IF (atoms%nlo(itype)>0) j = j + 2
      END DO
      IF (input%film) j = j + 1
      ALLOCATE (clines(2*j))
      DO i = 1, 2*j
         READ (40,'(a)') clines(i)
      END DO

      REWIND 40
      i = 0 
      DO ispin = 1,input%jspins
         i = i + 2
         WRITE (40,'(a)') TRIM(clines(i-1))
         WRITE (40,'(a)') TRIM(clines(i))
         DO itype = 1, atoms%ntype
            i = i + 1
            m = i
            IF (atoms%nflip(itype)==-1) m = MOD(i+j,2*j)
            IF (m==0) m = 2*j
            WRITE (40,'(a)') TRIM(clines(m))
            IF (atoms%nlo(itype)>0) THEN
               WRITE (40,'(a)') TRIM(clines(m+1))
               WRITE (40,'(a)') TRIM(clines(m+2))
               i = i + 2
            END IF
         END DO
         IF (input%film) THEN
            i = i + 1
            WRITE (40,'(a)') TRIM(clines(i))
         END IF
      END DO
      DEALLOCATE (clines)
      CLOSE(40)
   END IF

END SUBROUTINE flipcdn

END MODULE m_flipcdn