flipcdn.f90 7.74 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
      MODULE m_flipcdn
!     *******************************************************
!     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 22
!     *******************************************************
      CONTAINS
        SUBROUTINE flipcdn(&
             &                   atoms,input,vacuum,sphhar,&
23
             &                   stars,sym,oneD,cell,&
24
             &                   l_noco)
25
          USE m_cdn_io
26 27 28 29 30 31 32 33
          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(IN)  :: input
          TYPE(t_sym),INTENT(IN)    :: sym
34
          TYPE(t_oneD),INTENT(IN)     :: oneD
35 36 37 38
          TYPE(t_cell),INTENT(IN)   :: cell
          LOGICAL,INTENT(IN)        :: l_noco

          !     .. Local Scalars ..
39
          REAL    rhodummy,rhodumms,fermiEnergyTemp
Daniel Wortmann's avatar
Daniel Wortmann committed
40
          INTEGER i,iter,nt,j,lh,na,mp,ispin,urec,itype,m,i_u
41
          INTEGER archiveType
42 43
            
          CHARACTER(len=8) iop,dop
44
          LOGICAL n_exist,l_qfix
45 46 47 48 49 50 51 52 53 54 55 56
          !     ..
          !     .. Local Arrays ..
          COMPLEX, ALLOCATABLE :: n_mmp(:,:,:,:),qpw(:,:),rhtxy(:,:,:,:)
          REAL   , ALLOCATABLE :: rho(:,:,:,:),rht(:,:,:)
          COMPLEX, ALLOCATABLE :: cdom(:),cdomvz(:,:),cdomvxy(:,:,:)
          CHARACTER(len=80), ALLOCATABLE :: clines(:)
          CHARACTER(len=8) name(10)
          !     ..
          !atoms%jmtd = MAXVAL(atoms%jri(:))
          !sphhar%nlhd = MAXVAL(sphhar%nlh(:))
          ALLOCATE ( rho(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,input%jspins),qpw(stars%ng3,input%jspins) )
          ALLOCATE ( rhtxy(vacuum%nmzxy,stars%ng2-1,2,input%jspins),rht(vacuum%nmz,2,input%jspins) )
57
          archiveType = CDN_ARCHIVE_TYPE_CDN1_const
58 59 60
          IF (l_noco) THEN
             ALLOCATE( cdom(stars%ng3) )
             ALLOCATE( cdomvz(vacuum%nmz,2),cdomvxy(vacuum%nmzxy,stars%ng2-1,2) )
61
             archiveType = CDN_ARCHIVE_TYPE_NOCO_const
62 63 64
          ENDIF

          !     ---> read the charge density 
65
          CALL readDensity(stars,vacuum,atoms,cell,sphhar,input,sym,oneD,archiveType,&
66
                     CDN_INPUT_DEN_const,0,fermiEnergyTemp,l_qfix,iter,rho,qpw,rht,rhtxy,cdom,cdomvz,cdomvxy)
67

68 69 70
          !     ---> flip cdn for each atom with nflip=-1
          !
          na = 1
Daniel Wortmann's avatar
Daniel Wortmann committed
71 72
          DO itype = 1, atoms%ntype
             IF (atoms%nflip(itype).EQ.-1) THEN
73 74
                !     ---> spherical and non-spherical m.t. charge density
                DO lh = 0,sphhar%nlh(atoms%ntypsy(na))
Daniel Wortmann's avatar
Daniel Wortmann committed
75 76 77 78 79 80 81
                   DO j = 1,atoms%jri(itype)
                      rhodummy = rho(j,lh,itype,1)
                      rho(j,lh,itype,1) = rho(j,lh,itype,input%jspins)
                      rho(j,lh,itype,input%jspins) = rhodummy
                   END DO
                END DO
             ELSE IF (atoms%nflip(itype).EQ.-2) THEN
82
                DO lh = 0,sphhar%nlh(atoms%ntypsy(na))
Daniel Wortmann's avatar
Daniel Wortmann committed
83 84 85 86 87 88 89
                   DO j = 1,atoms%jri(itype)
                      rhodummy = rho(j,lh,itype,1) + rho(j,lh,itype,input%jspins)
                      rhodumms = rho(j,lh,itype,1) - rho(j,lh,itype,input%jspins)
                      rho(j,lh,itype,1) = 0.5 * (rhodummy + atoms%bmu(itype)*rhodumms)
                      rho(j,lh,itype,input%jspins) = 0.5 * (rhodummy - atoms%bmu(itype)*rhodumms )
                   END DO
                END DO
90
             END IF
Daniel Wortmann's avatar
Daniel Wortmann committed
91
             na = na + atoms%neq(itype)
92
          ENDDO
93
          !     ----> write the spin-polarized density
94
          CALL writeDensity(stars,vacuum,atoms,cell,sphhar,input,sym,oneD,archiveType,CDN_INPUT_DEN_const,&
95
                            0,-1.0,0.0,.FALSE.,iter,rho,qpw,rht,rhtxy,cdom,cdomvz,cdomvxy)
96 97 98 99 100 101 102
          !
          ! for lda+U: flip n-matrix 
          !
          IF (atoms%n_u.GT.0) THEN
             INQUIRE (file='n_mmp_mat',exist=n_exist)
             IF (n_exist) THEN
                OPEN (69,file='n_mmp_mat',status='old',form='formatted')
Daniel Wortmann's avatar
Daniel Wortmann committed
103
                ALLOCATE (n_mmp(-3:3,-3:3,atoms%n_u,2))
104 105 106

                READ (69,9000) n_mmp
                !   flip    ...
Daniel Wortmann's avatar
Daniel Wortmann committed
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
                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 = n_mmp(m,mp,i_u,1)
                            n_mmp(m,mp,i_u,1) = n_mmp(m,mp,i_u,input%jspins)
                            n_mmp(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 = n_mmp(m,mp,i_u,1) + n_mmp(m,mp,i_u,input%jspins)
                            rhodumms = n_mmp(m,mp,i_u,1) - n_mmp(m,mp,i_u,input%jspins)
                            n_mmp(m,mp,i_u,1) = 0.5 * (rhodummy + atoms%bmu(itype) * rhodumms)
                            n_mmp(m,mp,i_u,input%jspins) = 0.5 * (rhodummy - atoms%bmu(itype) * rhodumms)
                         END DO
                      END DO
                   END IF
                END DO
128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
                !   flip    ...
                REWIND (69)
                WRITE (69,9000) n_mmp
9000            FORMAT(7f20.13)
                !
                DEALLOCATE ( n_mmp )
             ENDIF
          ENDIF
          !-lda+U
          !
          !--->   read enpara and  flip lines
          !
          INQUIRE(file='enpara',exist=n_exist)
          IF (n_exist) THEN
             OPEN(40,file ='enpara',status='old',form='formatted')

Daniel Wortmann's avatar
Daniel Wortmann committed
144 145 146 147
             j = 2
             DO itype = 1, atoms%ntype
                j = j + 1
                IF (atoms%nlo(itype)>0) j = j + 2
148
             ENDDO
Daniel Wortmann's avatar
Daniel Wortmann committed
149 150 151
             IF (input%film) j = j + 1
             ALLOCATE (clines(2*j))
             DO i = 1, 2*j
152 153 154 155 156 157
                READ (40,'(a)') clines(i)
             ENDDO

             REWIND 40
             i = 0 
             DO ispin = 1,input%jspins
Daniel Wortmann's avatar
Daniel Wortmann committed
158
                i = i + 2
159 160
                WRITE (40,'(a)') TRIM(clines(i-1))
                WRITE (40,'(a)') TRIM(clines(i))
Daniel Wortmann's avatar
Daniel Wortmann committed
161 162 163 164 165
                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
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186
                   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
                   ENDIF
                ENDDO
                IF (input%film) THEN
                   i = i + 1
                   WRITE (40,'(a)') TRIM(clines(i))
                ENDIF
             ENDDO

             DEALLOCATE (clines,rho,qpw,rhtxy,rht)
             IF (l_noco) THEN
                DEALLOCATE (cdom,cdomvz,cdomvxy)
             ENDIF
             CLOSE(40)
          ENDIF
        END SUBROUTINE flipcdn
      END MODULE m_flipcdn