bmt.f90 3.18 KB
Newer Older
1 2 3 4
MODULE m_bmt
contains
  SUBROUTINE bmt(&
       & stars,input,noco,atoms,sphhar,vacuum,&
5
       & cell,sym,oneD)
6 7 8
    !
    use m_types
    use m_juDFT
9
    USE m_cdn_io
10 11 12
    USE m_wrtdop
    IMPLICIT NONE
    !     ..
13
    TYPE(t_stars),INTENT(IN)    :: stars
14 15 16 17 18 19 20
    TYPE(t_input),INTENT(INOUT) :: input
    TYPE(t_noco),INTENT(IN)     :: noco
    TYPE(t_atoms),INTENT(IN)    :: atoms
    TYPE(t_sphhar),INTENT(IN)   :: sphhar
    TYPE(t_vacuum),INTENT(IN)   :: vacuum
    TYPE(t_cell),INTENT(IN)     :: cell
    TYPE(t_sym),INTENT(IN)      :: sym
21
    TYPE(t_oneD),INTENT(IN)     :: oneD
22
    INTEGER k,i,ivac  ,it 
23
    INTEGER type,typmag, archiveType
24 25
    REAL fermiEnergyTemp
    LOGICAL l_qfix
26 27 28
    CHARACTER(len=8) filename 
    COMPLEX, ALLOCATABLE :: fpw(:,:),fzxy(:,:,:,:)
    REAL,    ALLOCATABLE :: fz(:,:,:),fr(:,:,:,:)
29 30
    COMPLEX, ALLOCATABLE :: cdom(:),cdomvz(:,:),cdomvxy(:,:,:)

31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
    !     ..
    !     ..


    typmag= atoms%ntype 
    ! only muffin-tins with type <= typmag remain magnetic  


    IF (input%jspins/=2) THEN
       CALL juDFT_error("Stop in bmt:  jspins/=2",calledby="bmt")
    ENDIF

    !atoms%jmtd = maxval(atoms%jri(:))
    !sphhar%nlhd = maxval(sphhar%nlh(:))

46 47
    ALLOCATE(fpw(stars%ng3,input%jspins),fzxy(vacuum%nmzxy,stars%ng2-1,2,input%jspins))
    ALLOCATE(fr(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,input%jspins),fz(vacuum%nmz,2,input%jspins))
48
    ALLOCATE(cdom(stars%ng3),cdomvz(vacuum%nmzd,2),cdomvxy(vacuum%nmzxyd,oneD%odi%n2d-1,2))
49

50 51 52
    archiveType = CDN_ARCHIVE_TYPE_CDN1_const
    IF (noco%l_noco) archiveType = CDN_ARCHIVE_TYPE_NOCO_const

53
    CALL readDensity(stars,vacuum,atoms,cell,sphhar,input,sym,oneD,archiveType,&
54
                     CDN_INPUT_DEN_const,0,fermiEnergyTemp,l_qfix,it,fr,fpw,fz,fzxy,cdom,cdomvz,cdomvxy)
55 56 57 58 59 60 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 98 99 100

    IF ( typmag < atoms%ntype ) THEN 
       DO type= typmag+1,atoms%ntype 
          DO k= 0,sphhar%nlhd
             DO i= 1,atoms%jmtd
                fr(i,k,type,1)= ( fr(i,k,type,1) + fr(i,k,type,2) )/2. 
                fr(i,k,type,2)= fr(i,k,type,1) 
             ENDDO
          ENDDO
       ENDDO
    ENDIF

    DO k= 1,stars%ng3
       fpw(k,1)= ( fpw(k,1) + fpw(k,2) )/2.
       fpw(k,2)= fpw(k,1)
    ENDDO
    IF (input%film) THEN
       DO ivac= 1,vacuum%nvac
          DO i= 1,vacuum%nmz
             fz(i,ivac,1)= ( fz(i,ivac,1) + fz(i,ivac,2) )/2.  
             fz(i,ivac,2)= fz(i,ivac,1)
          ENDDO
          DO k= 2,stars%ng2
             DO i= 1,vacuum%nmzxy
                fzxy(i,k-1,ivac,1)= &
                     &         ( fzxy(i,k-1,ivac,1) + fzxy(i,k-1,ivac,2) )/2. 
                fzxy(i,k-1,ivac,2)= fzxy(i,k-1,ivac,1)
             ENDDO
          ENDDO
       ENDDO
    ENDIF

    filename= 'cdnbmtXX'
    IF ( typmag < atoms%ntype ) THEN
       filename(7:7)= ACHAR(IACHAR('0')+ MOD(typmag,100)/10 )
       filename(8:8)= ACHAR(IACHAR('0')+ MOD(typmag,10) )
       OPEN(98,file=filename(1:8),form='unformatted',status='replace')
    ELSE
       OPEN(98,file=filename(1:6),form='unformatted',status='replace')
    ENDIF
    CALL wrtdop(&
         & stars,vacuum,atoms,sphhar,input,sym,&
         & 98,&
         & it,fr,fpw,fz,fzxy)
    CLOSE(98) 

101 102
    DEALLOCATE(cdom,cdomvz,cdomvxy)
    DEALLOCATE(fpw,fzxy,fr,fz)
103 104 105

  END SUBROUTINE bmt
END MODULE m_bmt