loddop.f90 7.48 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26
      MODULE m_loddop
      USE m_juDFT
      CONTAINS
        SUBROUTINE loddop(&
             &                  stars,vacuum,atoms,sphhar,&
             &                  input,sym,&
             &                  nu,&
             &                  it,fr,fpw,fz,fzxy)
          !     ***********************************************************
          !     reload formatted density or potential   c.l.fu
          !     ***********************************************************
          USE m_types
          IMPLICIT NONE
          !
          !     .. Scalar Arguments ..
          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

          INTEGER, INTENT (IN) :: nu  
          INTEGER, INTENT (OUT):: it
          !     ..
          !     .. Array Arguments ..
27 28 29
          COMPLEX, INTENT (OUT):: fpw(:,:),fzxy(:,:,:,:)!(stars%ng3,input%jspins),fzxy(vacuum%nmzxyd,stars%ng2-1,2,input%jspins)
          REAL,    INTENT (OUT):: fr(:,0:,:,:)!(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,input%jspins)
          REAL,    INTENT (OUT):: fz(:,:,:)!(vacuum%nmzd,2,input%jspins)
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
          CHARACTER(len=8) :: dop,iop,name(10)
          !     ..
          !     .. Local Scalars ..
          REAL delzn,dxn,rmtn,z1n,dummy
          INTEGER i,ivac,ivdummy,j,jrin,jsp,jspdum,k,lh,lhdummy,n,ndum,nlhn,&
               &        nmzn,nmzxyn,nn,nq2n,nq3n,ntydum,n_diff,na
          CHARACTER(len=2) namaux
          !     ..
          !     .. Local Arrays ..
          REAL, ALLOCATABLE :: fpwr(:,:),fzxyr(:,:,:,:)

          CHARACTER(len=8) space(10)
          !     ..
          !     .. Intrinsic Functions ..
          INTRINSIC cmplx
          !     ..
          !     .. Data statements ..
          DATA space/10*'        '/
          !     ..

          fr = 0 ; fzxy = 0 ; fr = 0 ; fz = 0

52 53
          IF (sym%invs) ALLOCATE ( fpwr(stars%ng3,SIZE(fpw,2)) )
          IF (sym%invs2) ALLOCATE ( fzxyr(vacuum%nmzxyd,stars%ng2-1,2,SIZE(fzxy,4)) )
54 55 56 57 58 59

          name = space
          READ (nu,END=200,ERR=200) name
          !      WRITE (*,FMT=8000) name
          ! 8000 FORMAT (' loddop title:',10a8)
          READ (nu,END=200,ERR=200) iop,dop,it
60
          DO  jsp = 1,SIZE(fr,4)
61 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 89 90 91 92 93 94 95 96 97
             READ (nu,END=200,ERR=200) jspdum
             READ (nu,END=200,ERR=200) nn
             IF (nn/=atoms%ntype) CALL juDFT_error("nn.NE.ntype",calledby =&
                  &       "loddop" )

             na = 1
             DO  n = 1,nn
                READ (nu,END=200,ERR=200) namaux,ndum,jrin,rmtn,dxn
                READ (nu,END=200,ERR=200) ntydum,nlhn
                !+gu
                IF ( nlhn.GT.sphhar%nlh(atoms%ntypsy(na)) ) THEN
                   WRITE (*,*) 'nlh (',nlhn,') set to (',sphhar%nlh(atoms%ntypsy(na)),')'
                   n_diff = nlhn - sphhar%nlh(atoms%ntypsy(na))
                   nlhn = sphhar%nlh(atoms%ntypsy(na))
                ELSE
                   n_diff = 0 
                ENDIF
                !-gu
                DO  lh = 0,nlhn
                   READ (nu,END=200,ERR=200) lhdummy
                   READ (nu,END=200,ERR=200) (fr(i,lh,n,jsp),i=1,jrin)
                ENDDO
                IF (nlhn.LT.sphhar%nlh(atoms%ntypsy(na))) THEN
                   DO lh = nlhn + 1,sphhar%nlh(atoms%ntypsy(na))
                      DO i = 1,atoms%jri(n)
                         fr(i,lh,n,jsp) = 0.
                      ENDDO
                   ENDDO
                ELSE
                   DO lh = 1, n_diff
                      READ (nu,END=200,ERR=200) lhdummy
                      READ (nu,END=200,ERR=200) dummy
                   ENDDO
                ENDIF

                na = na + atoms%neq(n)
             ENDDO
98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
             IF (jsp<=SIZE(fpw,2)) THEN
                READ (nu,END=200,ERR=200) nq3n
                !+gu
                IF (nq3n.GT.stars%ng3) THEN
                   WRITE (*,*) 'nq3n (',nq3n,') reduced to nq3 (',stars%ng3,')'
                   nq3n = stars%ng3
                ENDIF
                !-gu
                IF (sym%invs) THEN
                   READ (nu,END=200,ERR=200) (fpwr(k,jsp),k=1,nq3n)
                   fpw(:nq3n,jsp) = CMPLX(fpwr(:nq3n,jsp),0.)
                   
                ELSE
                   READ (nu,END=200,ERR=200) (fpw(k,jsp),k=1,nq3n)
                END IF
                IF (nq3n.LT.stars%ng3) THEN
                   fpw(nq3n+1:,jsp) = (0.,0.)
                END IF
116 117
             ENDIF
             IF (input%film) THEN
118 119 120 121 122
                IF (jsp<=SIZE(fz,3)) THEN
                   DO  ivac = 1,vacuum%nvac
                      READ (nu,END=200,ERR=200) ivdummy
                      READ (nu,END=200,ERR=200) nmzn,z1n,delzn
                      READ (nu,END=200,ERR=200) (fz(i,ivac,jsp),i=1,nmzn)
123
                      IF (vacuum%nvac.EQ.1) THEN
124 125 126 127 128 129 130 131 132 133 134
                         DO i=1,nmzn
                            fz(i,2,jsp)=fz(i,1,jsp)
                         ENDDO
                      ENDIF
                      IF (jsp<=SIZE(fzxy,4)) THEN
                         READ (nu,END=200,ERR=200) nq2n,nmzxyn
                         !+gu
                         IF (nq2n.GT.stars%ng2) THEN
                            WRITE (*,*) 'nq2n (',nq2n,') reduced to nq2 (',stars%ng2,')'
                            n_diff = nq2n - stars%ng2
                            nq2n = stars%ng2
135
                         ELSE
136
                            n_diff = 0
137
                         ENDIF
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
                         !-gu
                         DO  k = 2,nq2n
                            IF (sym%invs2) THEN
                               READ (nu,END=200,ERR=200) &
                                    &                              (fzxyr(j,k-1,ivac,jsp),j=1,nmzxyn)
                               fzxy(:nmzxyn,k-1,ivac,jsp) = CMPLX(fzxyr(:nmzxyn,k-1,ivac,&
                                    &                                         jsp),0.)
                            ELSE
                               READ (nu,END=200,ERR=200)  &
                                    &                               (fzxy(j,k-1,ivac,jsp),j=1,nmzxyn)
                            END IF
                            IF (vacuum%nvac.EQ.1) THEN
                               IF (sym%invs) THEN
                                  DO j = 1,nmzxyn
                                     fzxy(j,k-1,2,jsp) = CONJG(fzxy(j,k-1,1,jsp))
                                  ENDDO
                               ELSE
                                  DO j = 1,nmzxyn
                                     fzxy(j,k-1,2,jsp) = fzxy(j,k-1,1,jsp)
                                  ENDDO
                               ENDIF
                            ENDIF
                         ENDDO
                         !+gu
                         DO k = 1,n_diff
                            READ (nu,END=200,ERR=200) dummy
                         ENDDO
                         !-gu
                         IF (nq2n.LT.stars%ng2) THEN
                            fzxy(:nmzxyn,nq2n:,ivac,jsp) = (0.,0.)
                         END IF
169 170
                      ENDIF
                   ENDDO
171 172
                END IF
             ENDIF
173 174 175 176 177 178 179 180 181 182 183 184
          ENDDO
          !
          IF (sym%invs) DEALLOCATE (fpwr)
          IF (sym%invs2) DEALLOCATE ( fzxyr )
          RETURN

200       WRITE (6,*) 'error reading dop nr.',nu
          IF (nu /= 98)  CALL juDFT_error("error reading d/p-file!",calledby&
          &     ="loddop")

        END SUBROUTINE loddop
      END MODULE m_loddop