f2u.f90 5.6 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 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 54 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 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
      MODULE m_f2u
      use m_juDFT
!     ****************************************************
!     write unformatted density or potential onto unit '99'
!     e. wimmer   march 1985
!     ****************************************************
      CONTAINS
      SUBROUTINE f2u(&
     &               stars,input,atoms,sphhar,vacuum,&
     &               cell,sym,l_noco)
!
      USE m_wrtdop
      USE m_types
      IMPLICIT NONE
!     ..
!     .. Scalar Arguments .. 
      TYPE(t_stars),INTENT(IN)  :: stars
      TYPE(t_input),INTENT(IN)  :: input
      TYPE(t_vacuum),INTENT(IN) :: vacuum
      TYPE(t_atoms),INTENT(IN)  :: atoms
      TYPE(t_sphhar),INTENT(IN) :: sphhar
      TYPE(t_sym),INTENT(IN)    :: sym
      TYPE(t_cell),INTENT(IN)   :: cell
      LOGICAL,INTENT(IN)        :: l_noco

!     ..
!
!     .. Local Scalars ..
      INTEGER it,nu,i,jsp,jspdum,nn,n,ndum,jrin,j,ntypsyn,na
      INTEGER nlhn,lh,lhdum,nq3n,k,ivac,ivdum,nmzn,nq2n,nmzxyn
      REAL    z1n,delzn,rmtn,dxn
      LOGICAL n_exist
      CHARACTER(len=2) namaux
      CHARACTER(len=8) dop,iop
!     ..
!     .. Local Arrays ..
      COMPLEX, ALLOCATABLE :: n_mmp(:,:,:)
      COMPLEX, ALLOCATABLE :: fpw(:,:),fzxy(:,:,:,:)
      COMPLEX, ALLOCATABLE :: cdom(:),cdomvz(:,:),cdomvxy(:,:,:)
      REAL,    ALLOCATABLE :: fz(:,:,:),fr(:,:,:,:)
      REAL,    ALLOCATABLE :: fpwr(:,:),fzxyr(:,:,:,:)
      CHARACTER(len=8) name(10),space(10)
!     ..
!     .. Data statements ..
      DATA space/10*'        '/
!     ..
!
      !atoms%jmtd = maxval(atoms%jri(:))
      !sphhar%nlhd = maxval(sphhar%nlh(:))

      IF (l_noco) THEN
         OPEN (98,file='rhomat_inp',form='unformatted')
         OPEN (99,file='rhomat_form',form='formatted')
      ELSE
         OPEN (98,file='cdn_unf',form='unformatted')
         OPEN (99,file='cdn_form',form='formatted')
      ENDIF
      nu=99
!
      ALLOCATE( fpw(stars%ng3,input%jspins),fzxy(vacuum%nmzxy,stars%ng2-1,2,input%jspins) )
      ALLOCATE( cdom(stars%ng3),cdomvz(vacuum%nmz,2),cdomvxy(vacuum%nmzxy,stars%ng2-1,2) )
      ALLOCATE( fr(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,input%jspins),fz(vacuum%nmz,2,input%jspins) )
      ALLOCATE( fpwr(stars%ng3,input%jspins),fzxyr(vacuum%nmzxy,stars%ng2-1,2,input%jspins) )

      DO 10 i = 1,10
         name(i) = space(i)
   10 CONTINUE
      READ (nu,FMT=8030) name
      WRITE (6,FMT=8000) name
 8000 FORMAT (' loddop title:',10a8)
      READ (nu,FMT=8050) iop,dop,it
      DO 60 jsp = 1,input%jspins
         READ (nu,FMT=8060) jspdum
         READ (nu,FMT=8070) nn
         IF (nn/=atoms%ntype)  CALL juDFT_error("loddop",calledby ="f2u")
         na = 1
         DO 30 n = 1,nn
            READ (nu,FMT=8010) namaux,ndum,jrin,rmtn,dxn
 8010       FORMAT (a2,4x,i3,6x,i3,6x,f10.6,5x,f10.6)
            READ (nu,FMT=8020) ntypsyn,nlhn
            IF (ntypsyn.NE.atoms%ntypsy(na)) THEN
              WRITE (6,*) 'ntypsyn = ',ntypsyn, ' =/='
              WRITE (6,*) 'ntypsy(na) = ',atoms%ntypsy(na)
              CALL juDFT_error("ntypsyn /= ntypsy(na)",calledby ="f2u")
            ENDIF
 8020       FORMAT (7x,i2,2x,4x,i3)
            DO 20 lh = 0,nlhn
               READ (nu,FMT=8060) lhdum
               READ (nu,FMT=8100) (fr(i,lh,n,jsp),i=1,jrin)
   20       CONTINUE
            na = na + atoms%neq(n)
   30    CONTINUE
         READ (nu,FMT=8110) nq3n
         IF (sym%invs) THEN
            READ (nu,FMT=8100) (fpwr(k,jsp),k=1,nq3n)
            DO k=1,nq3n
              fpw(k,jsp) = cmplx(fpwr(k,jsp),0.0)
            ENDDO
         ELSE
            READ (nu,FMT=8100) (fpw(k,jsp),k=1,nq3n)
         END IF
         IF (input%film) THEN
            DO 50 ivac = 1,vacuum%nvac
               READ (nu,FMT=8060) ivdum
               READ (nu,FMT=8120) nmzn,z1n,delzn
               READ (nu,FMT=8040) (fz(i,ivac,jsp),i=1,nmzn)
               READ (nu,FMT=8130) nq2n,nmzxyn
               DO 40 k = 2,nq2n
                  IF (sym%invs2) THEN
                     READ (nu,FMT=8100) (fzxyr(j,k-1,ivac,jsp),j=1,&
     &                 nmzxyn)
                     DO j=1,nmzxyn
                       fzxy(j,k-1,ivac,jsp) = &
     &                            cmplx(fzxyr(j,k-1,ivac,jsp),0.0)
                     ENDDO
                  ELSE
                     READ (nu,FMT=8100) (fzxy(j,k-1,ivac,jsp),j=1,&
     &                 nmzxyn)
                  END IF
   40          CONTINUE
   50       CONTINUE
         END IF
   60 CONTINUE

      IF (l_noco) THEN
         READ (99,8100) (cdom(k),k=1,stars%ng3)
         IF (input%film) THEN
            READ (99,8100) ((cdomvz(j,ivac),j=1,vacuum%nmz),ivac=1,vacuum%nvac)
            READ (99,8100) (((cdomvxy(j,k-1,ivac),j=1,vacuum%nmzxy),k=2,stars%ng2),&
     &                                              ivac=1,vacuum%nvac)
         ENDIF
      ENDIF

      CLOSE (99)

 8030 FORMAT (10a8)
 8040 FORMAT (4e20.13)
 8050 FORMAT (a8,1x,a8,11x,i3)
 8060 FORMAT (a9)
 8070 FORMAT (6x,i3)
 8080 FORMAT (15x,i3,6x,f10.6,5x,f10.6)
 8090 FORMAT (15x,i2)
 8100 FORMAT (4e20.13)
 8110 FORMAT (4x,i6)
 8120 FORMAT (4x,i3,5x,f20.13,7x,f8.4)
 8130 FORMAT (4x,i5,8x,i5)
!
      CALL wrtdop(&
     &            stars,vacuum,atoms,sphhar,&
     &            input,sym,98,&
     &            it,fr,fpw,fz,fzxy)

      IF (l_noco) THEN
         WRITE (98) (cdom(k),k=1,stars%ng3)
         IF (input%film) THEN
            WRITE (98) ((cdomvz(j,ivac),j=1,vacuum%nmz),ivac=1,vacuum%nvac)
            WRITE (98) (((cdomvxy(j,k-1,ivac),j=1,vacuum%nmzxy),k=2,stars%ng2),&
     &                                              ivac=1,vacuum%nvac)
         ENDIF
      ENDIF
      CLOSE (98)
      DEALLOCATE( fpw,fzxy,cdom,cdomvz,cdomvxy,fr,fz,fpwr,fzxyr )
         
      END SUBROUTINE f2u
      END MODULE m_f2u