cdninf.f90 7.52 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
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
MODULE m_cdninf
CONTAINS
  SUBROUTINE cdninf(&
       &                  input,sym,noco,jspin,atoms,vacuum,&
       &                  sliceplot,banddos,ikpt,bkpt,wk,&
       &                  cell,kpts,&
       &                  nbands,eig,qal,qis,qvac,qvlay,&
       &                  qstars,jsym,ksym)
    !***********************************************************************
    !     this subroutine calculates the charge distribution of each state
    !     and writes this information to the out file. If dos or vacdos
    !     are .true. it also write the necessary information for dos or
    !     bandstructure plots to the file dosinp and vacdos respectivly
    !***********************************************************************
    !       changed this subroutine slightly for parallisation of dosinp&
    !       vacdos output (argument z replaced by ksym,jsym, removed sympsi
    !       call)                                        d.wortmann 5.99
    !
    !******** ABBREVIATIONS ************************************************
    !     qal      : l-like charge of each state
    !     qvac     : vacuum charge of each state
    !     qvlay    : charge in layers (z-ranges) in the vacuum of each state
    !     starcoeff: T if star coefficients have been calculated
    !     qstars   : star coefficients for layers (z-ranges) in vacuum
    !
    !***********************************************************************
    USE m_types
    IMPLICIT NONE
    TYPE(t_banddos),INTENT(IN)     :: banddos
    TYPE(t_sliceplot),INTENT(IN)   :: sliceplot
    TYPE(t_input),INTENT(IN)       :: input
    TYPE(t_vacuum),INTENT(IN)      :: vacuum
    TYPE(t_noco),INTENT(IN)        :: noco
    TYPE(t_sym),INTENT(IN)         :: sym
    TYPE(t_cell),INTENT(IN)        :: cell
    TYPE(t_kpts),INTENT(IN)        :: kpts
    TYPE(t_atoms),INTENT(IN)       :: atoms

    !     .. Scalar Arguments ..
    REAL,INTENT(IN):: wk
    INTEGER,INTENT(IN):: ikpt,jspin ,nbands 
    !
    !     STM Arguments
    COMPLEX, INTENT (IN) ::qstars(:,:,:,:) !(vacuum%nstars,DIMENSION%neigd,vacuum%layerd,2)
    !     ..
    !     .. Array Arguments ..
    REAL,    INTENT (IN) :: qvlay(:,:,:) !DIMENSION%neigd,vacuum%layerd,2)
Daniel Wortmann's avatar
Daniel Wortmann committed
54
55
    REAL,    INTENT (IN) :: qis(:,:,:)!(DIMENSION%neigd,kpts%nkpt,DIMENSION%jspd) 
    REAL,    INTENT (IN) :: qvac(:,:,:,:) !(DIMENSION%neigd,2,kpts%nkpt,DIMENSION%jspd)
56
57
    REAL,    INTENT (IN) :: bkpt(3)
    REAL,    INTENT (IN) :: eig(:)!(DIMENSION%neigd)
Daniel Wortmann's avatar
Daniel Wortmann committed
58
    REAL,    INTENT (IN) :: qal(0:,:,:)!(0:3,atoms%ntype,neigd)
59
60
61
62
63
64
65
66
67
68
    INTEGER, INTENT (IN) :: jsym(:)!(DIMENSION%neigd)
    INTEGER, INTENT (IN) :: ksym(:)!(neigd)
    !     ..
    !     .. Local Scalars ..
    REAL qalmax,qishlp,qvacmt,qvact
    INTEGER i,iband,ilay,iqispc,iqvacpc,ityp,itypqmax,ivac,l,lqmax
    INTEGER istar
    !     ..
    !     .. Local Arrays ..
    REAL cartk(3)
Daniel Wortmann's avatar
Daniel Wortmann committed
69
    INTEGER iqalpc(0:3,atoms%ntype)
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
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
115
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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
    CHARACTER chstat(0:3)
    !     ..
    !     .. Data statements ..
    DATA chstat/'s','p','d','f'/
    !     ..


    IF (input%film) THEN
       WRITE (6,FMT=8000) (bkpt(i),i=1,3)
8000   FORMAT (/,3x,'q(atom,l): k=',3f10.5,/,/,t8,'e',t13,'max',t18,&
            &          'int',t22,'vac',t28,'spheres(s,p,d,f)')
       IF (banddos%dos) THEN
          cartk=MATMUL(bkpt,cell%bmat)
          WRITE (85,FMT=8020) cartk(1),cartk(2),cartk(3),nbands,wk
          !     *************** for vacdos shz Jan.96
          IF (banddos%vacdos) THEN
             WRITE (86,FMT=8020) cartk(1),cartk(2),cartk(3),nbands,wk
          END IF
       END IF
    ELSE
       WRITE (6,FMT=8010) (bkpt(i),i=1,3)
8010   FORMAT (/,3x,'q(atom,l): k=',3f10.5,/,/,t8,'e',t13,'max',t18,&
            &          'int',t24,'spheres(s,p,d,f)')
       IF (banddos%dos) THEN
          cartk=MATMUL(bkpt,cell%bmat)
          WRITE (85,FMT=8020) cartk(1),cartk(2),cartk(3),nbands,wk
       END IF
    END IF
8020 FORMAT (1x,3e20.12,i6,e20.12)

    DO iband = 1,nbands
       IF (sliceplot%slice) THEN
          WRITE (6,FMT=8030) iband,eig(iband)
8030      FORMAT (' cdnval: slice for i=',i4,'  and energy',1e12.4)
       END IF

       qvacmt = 0.0
       qvact = 0.0
       IF (input%film) THEN
          DO ivac = 1,vacuum%nvac
             qvact = qvact + qvac(iband,ivac,ikpt,jspin)
          END DO
          IF (sym%invs .OR. sym%zrfs) qvact = 2.0*qvact
          iqvacpc = NINT(qvact*100.0)
          qvacmt = qvact
       END IF
       qalmax = 0.0
       lqmax = 0
       itypqmax = 0
       DO ityp = 1,atoms%ntype
          DO l = 0,3
             iqalpc(l,ityp) = NINT(qal(l,ityp,iband)*100.0)
             qvacmt = qvacmt + qal(l,ityp,iband)*atoms%neq(ityp)
             IF (qalmax.LT.qal(l,ityp,iband)) THEN
                qalmax = qal(l,ityp,iband)
                lqmax = l
                itypqmax = ityp
             END IF
          END DO
       END DO
       qishlp = 1.0 - qvacmt
       IF (noco%l_noco) qishlp = qis(iband,ikpt,jspin)
       iqispc = NINT(qishlp*100.0)
       IF (input%film) THEN
          WRITE (6,FMT=8040) eig(iband),chstat(lqmax),itypqmax,&
               &        iqispc,iqvacpc, ((iqalpc(l,ityp),l=0,3),ityp=1,atoms%ntype)
8040      FORMAT (f10.4,2x,a1,i2,2x,2i3, (t26,6 (4i3,1x)))
          IF (banddos%dos) THEN
             IF (banddos%ndir.NE.0) THEN
                WRITE (85,FMT=8050) eig(iband),ksym(iband),&
                     &              jsym(iband),qvact, ((qal(l,ityp,iband),l=0,3),&
                     &              ityp=1,atoms%ntype)
8050            FORMAT (f12.5,2i2,f12.5,/, (4f12.5))
             ELSE
                WRITE (85,FMT=8060) eig(iband),&
                     &              ((qal(l,ityp,iband),l=0,3),ityp=1,atoms%ntype),qvact
8060            FORMAT (10f12.7)
             END IF
          END IF
          !     ***************** for vacdos shz Jan.96
          IF (banddos%vacdos) THEN
             IF (.NOT.vacuum%starcoeff) THEN
                WRITE (86,FMT=8070) eig(iband),&
                     &               ((qvlay(iband,ilay,ivac),ilay=1,vacuum%layers),&
                     &                               ivac=1,vacuum%nvac)
             ELSE
                WRITE (86,FMT=8070) eig(iband),&
                     &                 ((qvlay(iband,ilay,ivac),&
                     &                 (REAL(qstars(istar,iband,ilay,ivac)),&
                     &                 istar=1,vacuum%nstars-1),ilay=1,vacuum%layers),ivac=1,vacuum%nvac)
             END IF
8070         FORMAT (f10.4,2x,20(e16.8,1x))

          END IF
          !     **************************************
       ELSE
          WRITE (6,FMT=8080) eig(iband),chstat(lqmax),itypqmax,&
               &        iqispc, ((iqalpc(l,ityp),l=0,3),ityp=1,atoms%ntype)
8080      FORMAT (f10.4,2x,a1,i2,2x,i3, (t26,6 (4i3,1x)))
          IF (banddos%dos) THEN
             IF (banddos%ndir.NE.0) THEN
                WRITE (85,FMT=8050) eig(iband),ksym(iband),&
                     &              jsym(iband),0.0, ((qal(l,ityp,iband),l=0,3),ityp=1,&
                     &              atoms%ntype)
             ELSE
                WRITE (85,FMT=8060) eig(iband),&
                     &              ((qal(l,ityp,iband),l=0,3),ityp=1,atoms%ntype),0.0
             END IF
          END IF
       END IF
    END DO
  END SUBROUTINE cdninf
END MODULE m_cdninf