eig66_mpi.F90 28.4 KB
Newer Older
1 2
MODULE m_eig66_mpi
#include "juDFT_env.h"
3
  USE m_eig66_data
4
  USE m_types
5
#ifdef CPP_MPI
6
  use mpi
7
#endif
8 9
  IMPLICIT NONE
  PRIVATE
10
  PUBLIC open_eig,read_eig,write_eig,close_eig,write_dos,read_dos
11 12
CONTAINS

13 14 15
  SUBROUTINE priv_find_data(id,d)
    INTEGER,INTENT(IN)::id
    TYPE(t_data_mpi),POINTER:: d
16

17 18 19 20 21 22 23 24 25
    CLASS(t_data),POINTER   ::dp
    CALL eig66_find_data(dp,id)
    SELECT TYPE(dp)
    TYPE is (t_data_mpi)
       d=>dp
       CLASS default
       CALL judft_error("BUG: wrong datatype in eig66_mpi")
    END SELECT
  END SUBROUTINE priv_find_data
26 27


28
  SUBROUTINE open_eig(id,mpi_comm,nmat,neig,nkpts,jspins,lmax,nlo,ntype,create,l_real,l_soc,nlotot,l_noco,n_size_opt,l_dos,l_mcd,l_orb,filename,layers,nstars,ncored,nsld,nat)
29 30 31
    USE,INTRINSIC::iso_c_binding
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: id,mpi_comm,nmat,neig,nkpts,jspins,nlo,ntype,lmax,nlotot
32
    LOGICAL, INTENT(IN) :: l_noco,create,l_real,l_soc
33
    INTEGER,INTENT(IN),OPTIONAL:: n_size_opt
34
    LOGICAL,INTENT(IN),OPTIONAL ::l_dos,l_mcd,l_orb
35 36 37 38
    CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: filename
    INTEGER,INTENT(IN),OPTIONAL :: layers,nstars,ncored,nsld,nat
#ifdef CPP_MPI
    INTEGER:: isize,e,slot_size,local_slots
39
    INTEGER,PARAMETER::mcored=27 !there should not be more that 27 core states
40 41 42
    TYPE(t_data_MPI),POINTER :: d

    CALL priv_find_data(id,d)
43
    CALL eig66_data_storedefault(d,jspins,nkpts,nmat,neig,lmax,nlotot,nlo,ntype,l_real.and..not.l_soc,l_soc,l_dos,l_mcd,l_orb)
44 45 46 47 48 49

    IF (PRESENT(n_size_opt)) d%n_size=n_size_opt
    IF (ALLOCATED(d%pe_ev)) THEN
       IF (create) THEN
          d%neig_data=0
          d%eig_data=1E99
50
          d%w_iks_data=1E99
51 52
          d%int_data=9999999
          d%real_data=1E99
53
          if (d%l_real.and..not.l_soc) THEN
54 55 56 57
             d%zr_data=0.0
          else
             d%zc_data=0.0
          endif
58 59 60 61 62 63 64 65 66 67 68 69 70 71 72
          d%qal_data=0.0
          d%qvac_data=0.0
          d%qvlay_data=0.0
          d%qstars_data=0.0
          d%ksym_data=0.0
          d%jsym_data=0.0
          d%mcd_data=0.0
          d%qintsl_data=0.0
          d%qmtsl_data=0.0
          d%qmtp_data=0.0
          d%orbcomp_data=0.0
       ENDIF
       IF (PRESENT(filename)) CALL priv_readfromfile()
       RETURN !everything already done!
    ENDIF
73

74 75 76 77 78 79 80 81 82 83
    CALL timestart("create data spaces in ei66_mpi")
    CALL MPI_COMM_RANK(MPI_COMM,d%irank,e)
    CALL MPI_COMM_SIZE(MPI_COMM,isize,e)

    CALL create_maps(d,isize,nkpts,jspins,neig,d%n_size)
    local_slots=COUNT(d%pe_basis==d%irank)
    !Now create the windows

    !Window for neig
    slot_size=1
84
    CALL priv_create_memory(1,local_slots,d%neig_handle,d%neig_data)
85 86 87 88 89
    d%neig_data=0

    !The integer values
    d%size_k=nmat
    slot_size=(5+3*d%size_k+1+nlotot)
90
    CALL priv_create_memory(slot_size,local_slots,d%int_handle,d%int_data)
91 92 93 94 95 96
    d%int_data=9999999

    !The real values
    d%size_el=(1+lmax)*ntype
    d%size_ello=nlo*ntype
    slot_size=(6+d%size_el+d%size_ello)
97
    CALL priv_create_memory(slot_size,local_slots,d%real_handle,real_data_ptr=d%real_data)
98 99 100
    d%real_data=1E99

    !The eigenvalues
101
    d%size_eig=neig
102
    CALL priv_create_memory(d%size_eig,local_slots,d%eig_handle,real_data_ptr=d%eig_data)
103
    d%eig_data=1E99
104 105 106 107
    !The w_iks
    CALL priv_create_memory(d%size_eig,local_slots,d%w_iks_handle,real_data_ptr=d%w_iks_data)
    d%w_iks_data=1E99

108 109 110 111
    !The eigenvectors
    local_slots=COUNT(d%pe_ev==d%irank)
    slot_size=nmat

112 113 114 115 116
    if (l_real.and..not.l_soc) THEN
       CALL priv_create_memory(slot_size,local_slots,d%zr_handle,real_data_ptr=d%zr_data)
    else
       CALL priv_create_memory(slot_size,local_slots,d%zc_handle,cmplx_data_ptr=d%zc_data)
    endif
117
    !Data for DOS etc
118
    IF (d%l_dos) THEN
119
       local_slots=COUNT(d%pe_basis==d%irank)
120 121 122
       CALL priv_create_memory(4*ntype*neig,local_slots,d%qal_handle,real_data_ptr=d%qal_data)
       CALL priv_create_memory(neig*2,local_slots,d%qvac_handle,real_data_ptr=d%qvac_data)
       CALL priv_create_memory(neig,local_slots,d%qis_handle,real_data_ptr=d%qis_data)
123 124
       CALL priv_create_memory(neig*max(1,layers)*2,local_slots,d%qvlay_handle,real_data_ptr=d%qvlay_data)
       CALL priv_create_memory(max(1,nstars)*neig*max(1,layers)*2,local_slots,d%qstars_handle,cmplx_data_ptr=d%qstars_data)
125 126 127
       CALL priv_create_memory(neig,local_slots,d%jsym_handle,d%jsym_data)
       CALL priv_create_memory(neig,local_slots,d%ksym_handle,d%ksym_data)
       IF (l_mcd) CALL priv_create_memory(3*ntype*mcored*neig,local_slots,d%mcd_handle,real_data_ptr=d%mcd_data)
128
       IF (l_orb) THEN
129 130 131 132
          CALL priv_create_memory(nsld*neig,local_slots,d%qintsl_handle,real_data_ptr=d%qintsl_data)
          CALL priv_create_memory(nsld*neig,local_slots,d%qmtsl_handle,real_data_ptr=d%qmtsl_data)
          CALL priv_create_memory(nat*neig,local_slots,d%qmtp_handle,real_data_ptr=d%qmtp_data)
          CALL priv_create_memory(23*nat*neig,local_slots,d%orbcomp_handle,real_data_ptr=d%orbcomp_data)
133 134 135 136 137 138 139
       ENDIF
    ELSE
       ALLOCATE(d%qal_data(1),d%qvac_data(1),d%qis_data(1),d%qvlay_data(1),d%qstars_data(1),&
            d%jsym_data(1),d%ksym_data(1),d%mcd_data(1),d%qintsl_data(1),d%qmtsl_data(1),&
            d%qmtp_data(1),d%orbcomp_data(1))
    ENDIF
    IF (PRESENT(filename).AND..NOT.create) CALL priv_readfromfile()
140
    CALL MPI_BARRIER(MPI_COMM,e)
141 142
    CALL timestop("create data spaces in ei66_mpi")
  CONTAINS
143
    SUBROUTINE priv_create_memory(slot_size,local_slots,handle,int_data_ptr,real_data_ptr,cmplx_data_ptr)
144 145
      IMPLICIT NONE
      INTEGER,INTENT(IN)           :: slot_size,local_slots
146 147 148
      INTEGER,POINTER,INTENT(OUT),OPTIONAL  :: int_data_ptr(:)
      REAL   ,POINTER,INTENT(OUT),OPTIONAL  :: real_data_ptr(:)
      COMPLEX,POINTER,INTENT(OUT),OPTIONAL  :: cmplx_data_ptr(:)
149
      INTEGER,INTENT(OUT)          :: handle
150
#ifdef CPP_MPI
151 152 153
      TYPE(c_ptr)::ptr
      INTEGER:: e
      INTEGER(MPI_ADDRESS_KIND) :: length
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
      INTEGER                   :: type_size

      length=0   
      IF (present(real_data_ptr)) THEN
          length=length+1
          CALL MPI_TYPE_SIZE(MPI_DOUBLE_PRECISION,type_size,e)
      ENDIF
      IF (present(cmplx_data_ptr)) THEN
          length=length+1
          CALL MPI_TYPE_SIZE(MPI_DOUBLE_COMPLEX,type_size,e)
      ENDIF
      IF (present(int_data_ptr)) THEN 
          length=length+1
          CALL MPI_TYPE_SIZE(MPI_INTEGER,type_size,e)
      ENDIF
      if (length.ne.1) call judft_error("Bug in eig66_mpi:create_memory") 
170
      length=MAX(1,slot_size*local_slots)
171
 
172 173 174 175
      length=length*type_size

      CALL MPI_ALLOC_MEM(length,MPI_INFO_NULL,ptr,e)
      IF (e.NE.0) CPP_error("Could not allocated MPI-Data in eig66_mpi")
176 177 178
	
      IF (present(real_data_ptr)) THEN	
      	CALL C_F_POINTER(ptr,real_data_ptr,(/length/type_size/))
179
      	CALL MPI_WIN_CREATE(real_data_ptr, length,slot_size*type_size,Mpi_INFO_NULL, MPI_COMM,handle, e)
180 181
      ELSEIF(present(int_data_ptr)) THEN
      	CALL C_F_POINTER(ptr,int_data_ptr,(/length/type_size/))
182
      	CALL MPI_WIN_CREATE(int_data_ptr, length,slot_size*type_size,Mpi_INFO_NULL, MPI_COMM,handle, e)
183 184
      ELSE
      	CALL C_F_POINTER(ptr,cmplx_data_ptr,(/length/type_size/))
185
      	CALL MPI_WIN_CREATE(cmplx_data_ptr, length,slot_size*type_size,Mpi_INFO_NULL, MPI_COMM,handle, e)
186
      ENDIF
187
#endif
188
    END SUBROUTINE priv_create_memory
189 190


191 192 193 194 195
    SUBROUTINE priv_readfromfile()
      USE m_eig66_DA,ONLY:open_eig_DA=>open_eig,read_eig_DA=>read_eig,close_eig_da=>close_eig
      INTEGER:: jspin,nk,i,ii,iii,nv,tmp_id
      REAL   :: wk,bk3(3),evac(2)
      INTEGER :: k1(nmat),k2(nmat),k3(nmat),kveclo(nlotot)
Daniel Wortmann's avatar
Daniel Wortmann committed
196
      REAL    :: eig(neig),w_iks(neig),ello(nlo,ntype),el(lmax,ntype)
197 198 199 200 201
      TYPE(t_zmat)::zmat
      zmat%l_real=d%l_real
      zmat%nbasfcn=nmat
      zmat%nbands=neig
      allocate(zmat%z_r(nmat,neig),zmat%z_c(nmat,neig))
202 203 204
      !only do this with PE=0
      IF (d%irank==0) THEN
         tmp_id=eig66_data_newid(DA_mode)
205
         IF (d%l_dos) CPP_error("Could not read DOS data")
206
         CALL open_eig_DA(tmp_id,nmat,neig,nkpts,jspins,lmax,nlo,ntype,nlotot,.FALSE.,.FALSE.,d%l_real,l_soc,.FALSE.,.FALSE.,filename)
207 208
         DO jspin=1,jspins
            DO nk=1,nkpts
Daniel Wortmann's avatar
Daniel Wortmann committed
209 210
                  CALL read_eig_DA(tmp_id,nk,jspin,nv,i,k1,k2,k3,bk3,wk,ii,eig,w_iks,el,ello,evac,kveclo,zmat=zmat)
                  CALL write_eig(id,nk,jspin,ii,ii,nv,nmat,k1,k2,k3,bk3,wk,eig,w_iks,el,ello,evac,nlotot,kveclo,zmat=zmat)
211
              ENDDO
212 213 214 215
         ENDDO
         CALL close_eig_DA(tmp_id)
      ENDIF
    END SUBROUTINE priv_readfromfile
216
#endif
217 218
  END SUBROUTINE open_eig
  SUBROUTINE close_eig(id,delete,filename)
219 220 221
    INTEGER,INTENT(IN)         :: id
    LOGICAL,INTENT(IN),OPTIONAL:: delete
    CHARACTER(LEN=*),INTENT(IN),OPTIONAL::filename
222 223
    TYPE(t_data_MPI),POINTER :: d
    CALL priv_find_data(id,d)
224

225 226
    IF (PRESENT(delete)) THEN
       IF (delete) WRITE(*,*) "No deallocation of memory implemented in eig66_mpi"
227
    ENDIF
228 229 230 231 232 233 234 235 236
    IF (PRESENT(filename)) CALL priv_writetofile()
  CONTAINS
    SUBROUTINE priv_writetofile()
      USE m_eig66_DA,ONLY:open_eig_DA=>open_eig,write_eig_DA=>write_eig,close_eig_DA=>close_eig
      IMPLICIT NONE

      INTEGER:: nlotot,nk,jspin,nv,i,ii,tmp_id
      REAL   :: wk,bk3(3),evac(2)
      INTEGER :: k1(d%nmat),k2(d%nmat),k3(d%nmat),kveclo(d%nlotot)
Daniel Wortmann's avatar
Daniel Wortmann committed
237
      REAL    :: eig(d%neig),w_iks(d%neig),ello(d%nlo,d%ntype),el(d%lmax,d%ntype)
238 239 240 241 242
      TYPE(t_zmat)::zmat
      zmat%l_real=d%l_real
      zmat%nbasfcn=d%nmat
      zmat%nbands=d%neig
      allocate(zmat%z_r(d%nmat,d%neig),zmat%z_c(d%nmat,d%neig))
243
      nlotot=d%nlotot
244

245 246 247
      IF (d%irank==0) THEN
         tmp_id=eig66_data_newid(DA_mode)
         IF (d%l_dos) CPP_error("Could not write DOS data")
248
         CALL open_eig_DA(tmp_id,d%nmat,d%neig,d%nkpts,d%jspins,d%lmax,d%nlo,d%ntype,d%nlotot,.FALSE.,.FALSE.,d%l_real,d%l_soc,.FALSE.,.FALSE.,filename)
249 250
         DO jspin=1,d%jspins
            DO nk=1,d%nkpts
Daniel Wortmann's avatar
Daniel Wortmann committed
251 252
               CALL read_eig(id,nk,jspin,nv,i,k1,k2,k3,bk3,wk,ii,eig,w_iks,el,ello,evac,kveclo,zmat=zmat)
               CALL write_eig_DA(tmp_id,nk,jspin,ii,ii,nv,i,k1,k2,k3,bk3,wk,eig,w_iks,el,ello,evac,nlotot,kveclo,zmat=zmat)
253
            ENDDO
254
         ENDDO
255 256 257 258 259 260 261
         CALL close_eig_DA(tmp_id)
      ENDIF
      CALL eig66_remove_data(id)
    END SUBROUTINE priv_writetofile

  END SUBROUTINE close_eig

Daniel Wortmann's avatar
Daniel Wortmann committed
262
  SUBROUTINE read_eig(id,nk,jspin,nv,nmat,k1,k2,k3,bk3,wk,neig,eig,w_iks,el,&
263
       ello,evac,kveclo,n_start,n_end,zmat)
264 265 266 267
    IMPLICIT NONE
    INTEGER, INTENT(IN)            :: id,nk,jspin
    INTEGER, INTENT(OUT),OPTIONAL  :: nv,nmat
    INTEGER, INTENT(OUT),OPTIONAL  :: neig
Daniel Wortmann's avatar
Daniel Wortmann committed
268
    REAL,    INTENT(OUT),OPTIONAL  :: eig(:),w_iks(:)
269 270 271 272
    INTEGER, INTENT(OUT),OPTIONAL  :: k1(:),k2(:),k3(:),kveclo(:)
    REAL,    INTENT(OUT),OPTIONAL  :: evac(:),ello(:,:),el(:,:)
    REAL,    INTENT(OUT),OPTIONAL  :: bk3(:),wk
    INTEGER, INTENT(IN),OPTIONAL   :: n_start,n_end
273
    TYPE(t_zmat),OPTIONAL  :: zmat
274 275

#ifdef CPP_MPI
276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325
    INTEGER                   :: pe,tmp_size,e
    INTEGER(MPI_ADDRESS_KIND) :: slot
    INTEGER                   :: n1,n2,n3,n
    INTEGER,ALLOCATABLE       :: tmp_int(:)
    REAL,ALLOCATABLE          :: tmp_real(:)
    COMPLEX,ALLOCATABLE       :: tmp_cmplx(:)
    TYPE(t_data_MPI),POINTER :: d
    CALL priv_find_data(id,d)
    pe=d%pe_basis(nk,jspin)
    slot=d%slot_basis(nk,jspin)
    IF (PRESENT(neig))THEN
       CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,d%neig_handle,e)
       ! Get current values
       CALL  MPI_GET(neig,1,MPI_INTEGER,pe,slot,1,MPI_INTEGER,d%neig_handle,e)
       CALL MPI_WIN_UNLOCK(pe,d%neig_handle,e)

    ENDIF
    !read the integer values
    IF (ANY((/PRESENT(nv),PRESENT(nmat),PRESENT(k1),PRESENT(k2),PRESENT(k3),PRESENT(kveclo)/))) THEN
       tmp_size=4+3*d%size_k
       IF (PRESENT(kveclo)) tmp_size=tmp_size+SIZE(kveclo)
       ALLOCATE(tmp_int(tmp_size))
       CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,d%int_handle,e)
       ! Get current values
       CALL  MPI_GET(tmp_int,tmp_size,MPI_INTEGER,pe,slot,tmp_size,MPI_INTEGER,d%int_handle,e)
       CALL MPI_WIN_UNLOCK(pe,d%int_handle,e)
       !IF (present(neig)) neig=tmp_int(1)
       IF (PRESENT(nv))   nv=tmp_int(2)
       IF (PRESENT(nmat)) nmat=tmp_int(3)
       IF (PRESENT(k1))   k1=tmp_int(4+1:4+SIZE(k1))
       IF (PRESENT(k2))   k2=tmp_int(4+d%size_k+1:4+d%size_k+SIZE(k2))
       IF (PRESENT(k3))   k3=tmp_int(4+2*d%size_k+1:4+2*d%size_k+SIZE(k3))
       IF (PRESENT(kveclo)) kveclo=tmp_int(4+3*d%size_k+1:4+3*d%size_k+SIZE(kveclo))

    ENDIF
    !read the real-values
    IF (ANY((/PRESENT(wk),PRESENT(bk3),PRESENT(el),PRESENT(ello),PRESENT(evac)/))) THEN
       tmp_size=6+d%size_el+d%size_ello
       ALLOCATE(tmp_real(tmp_size))
       CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,d%real_handle,e)
       ! Get current values
       CALL  MPI_GET(tmp_real,tmp_size,MPI_DOUBLE_PRECISION,pe,slot,tmp_size,MPI_DOUBLE_PRECISION,d%real_handle,e)
       CALL MPI_WIN_UNLOCK(pe,d%real_handle,e)
       IF (PRESENT(wk))   wk=tmp_real(1)
       IF (PRESENT(bk3))  bk3=tmp_real(2:4)
       IF (PRESENT(evac)) evac=tmp_real(5:6)
       IF (PRESENT(el))   el=RESHAPE(tmp_real(6+1:6+SIZE(el)),SHAPE(el))
       IF (PRESENT(ello)) ello=RESHAPE(tmp_real(6+d%size_el+1:6+d%size_el+SIZE(ello)),SHAPE(ello))
       DEALLOCATE(tmp_real)
    ENDIF
Daniel Wortmann's avatar
Daniel Wortmann committed
326
    IF (PRESENT(eig).or.PRESENT(w_iks)) THEN
327
       ALLOCATE(tmp_real(d%size_eig))
Daniel Wortmann's avatar
Daniel Wortmann committed
328
       IF (PRESENT(eig)) THEN
329 330 331
          CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,d%eig_handle,e)
          CALL MPI_GET(tmp_real,d%size_eig,MPI_DOUBLE_PRECISION,pe,slot,d%size_eig,MPI_DOUBLE_PRECISION,d%eig_handle,e)
          CALL MPI_WIN_UNLOCK(pe,d%eig_handle,e)
Daniel Wortmann's avatar
Daniel Wortmann committed
332 333 334 335 336
          n1=1;n3=1;n2=SIZE(eig)
          IF (PRESENT(n_start)) n1=n_start
          IF (PRESENT(n_end)) n2=n_end
          eig(:n2-n1+1)=tmp_real(n1:n2)
       END IF
337 338 339 340 341 342
       IF (PRESENT(w_iks)) THEN
          CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,d%w_iks_handle,e)
          CALL MPI_GET(tmp_real,d%size_eig,MPI_DOUBLE_PRECISION,pe,slot,d%size_eig,MPI_DOUBLE_PRECISION,d%w_iks_handle,e)
          CALL MPI_WIN_UNLOCK(pe,d%w_iks_handle,e)
          w_iks=tmp_real(:size(w_iks))
       END IF
343 344 345
       DEALLOCATE(tmp_real)
    ENDIF

346 347
    IF (PRESENT(zmat)) THEN
       tmp_size=zmat%nbasfcn
348 349
       ALLOCATE(tmp_real(tmp_size))
       ALLOCATE(tmp_cmplx(tmp_size))
350
       DO n=1,zmat%nbands
351 352 353 354 355 356 357
          n1=n
          IF (PRESENT(n_start)) n1=n_start+n-1
          IF (PRESENT(n_end)) THEN
             IF (n1>n_end) CYCLE
          ENDIF
          slot=d%slot_ev(nk,jspin,n1)
          pe=d%pe_ev(nk,jspin,n1)
358 359
          
          if (zmat%l_real) THEN
360 361 362 363 364
             if (.not.d%l_real) THEN
                CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,d%zc_handle,e)
                CALL MPI_GET(tmp_cmplx,tmp_size,MPI_DOUBLE_COMPLEX,pe,slot,tmp_size,MPI_DOUBLE_COMPLEX,d%zc_handle,e)
                CALL MPI_WIN_UNLOCK(pe,d%zc_handle,e)
                !print *, nk,jspin,n1,"r PE:",pe," Slot: ",slot," Size:",tmp_size,tmp_cmplx(1)
365
                zmat%z_r(:,n)=REAL(tmp_cmplx)
366 367 368 369 370
             else
                CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,d%zr_handle,e)
                CALL MPI_GET(tmp_real,tmp_size,MPI_DOUBLE_PRECISION,pe,slot,tmp_size,MPI_DOUBLE_PRECISION,d%zr_handle,e)
                CALL MPI_WIN_UNLOCK(pe,d%zr_handle,e)
                !print *, nk,jspin,n1,"r PE:",pe," Slot: ",slot," Size:",tmp_size,tmp_real(1)
371
                zmat%z_r(:,n)=tmp_real
372
             endif
373
          ELSE
374
             if (d%l_real) call judft_error("Could not read complex data, only real data is stored",calledby="eig66_mpi%read_eig")
375 376 377 378
             CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,d%zc_handle,e)
             CALL MPI_GET(tmp_cmplx,tmp_size,MPI_DOUBLE_COMPLEX,pe,slot,tmp_size,MPI_DOUBLE_COMPLEX,d%zc_handle,e)
             CALL MPI_WIN_UNLOCK(pe,d%zc_handle,e)
             !print *, nk,jspin,n1,"r PE:",pe," Slot: ",slot," Size:",tmp_size,tmp_cmplx(1)
379
             zmat%z_c(:,n)=tmp_cmplx
Daniel Wortmann's avatar
Daniel Wortmann committed
380
          ENDIF
381 382
       ENDDO
    ENDIF
383 384

#endif
385 386 387
  END SUBROUTINE read_eig

  SUBROUTINE write_eig(id,nk,jspin,neig,neig_total,nv,nmat,k1,k2,k3,bk3,wk, &
Daniel Wortmann's avatar
Daniel Wortmann committed
388
       eig,w_iks,el,ello,evac,                     &
389
       nlotot,kveclo,n_size,n_rank,zmat)
390 391 392 393 394
    INTEGER, INTENT(IN)          :: id,nk,jspin
    INTEGER, INTENT(IN),OPTIONAL :: n_size,n_rank
    REAL,    INTENT(IN),OPTIONAL :: wk
    INTEGER, INTENT(IN),OPTIONAL :: neig,nv,nmat,nlotot,neig_total
    INTEGER, INTENT(IN),OPTIONAL :: k1(:),k2(:),k3(:),kveclo(:)
Daniel Wortmann's avatar
Daniel Wortmann committed
395
    REAL,    INTENT(IN),OPTIONAL :: bk3(3),eig(:),el(:,:),w_iks(:)
396
    REAL,    INTENT(IN),OPTIONAL :: evac(:),ello(:,:)
397
    TYPE(t_zmat),INTENT(IN),OPTIONAL :: zmat
398 399

#ifdef CPP_MPI
400 401
    INTEGER                   :: pe,tmp_size,e
    INTEGER(MPI_ADDRESS_KIND) :: slot
402
    INTEGER                   :: n1,n2,n3,n,nn
403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455
    INTEGER,ALLOCATABLE       :: tmp_int(:)
    REAL,ALLOCATABLE          :: tmp_real(:)
    COMPLEX,ALLOCATABLE       :: tmp_cmplx(:)
    LOGICAL                   :: acc
    TYPE(t_data_MPI),POINTER :: d

    CALL priv_find_data(id,d)

    pe=d%pe_basis(nk,jspin)
    slot=d%slot_basis(nk,jspin)
    !write the number of eigenvalues values
    IF (PRESENT(neig_total)) THEN
       CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,d%neig_handle,e)
       ALLOCATE(tmp_int(1))
       tmp_int(1)=neig_total
       CALL MPI_PUT(tmp_int,1,MPI_INTEGER,pe,slot,1,MPI_INTEGER,d%neig_handle,e)
       CALL MPI_WIN_UNLOCK(pe,d%neig_handle,e)
       DEALLOCATE(tmp_int)
    ENDIF

    IF (ANY((/PRESENT(nv),PRESENT(nmat),PRESENT(nlotot),PRESENT(k1),PRESENT(k2),PRESENT(k3),PRESENT(kveclo)/))) THEN
       tmp_size=5+3*d%size_k
       IF (PRESENT(kveclo)) tmp_size=tmp_size+SIZE(kveclo)
       ALLOCATE(tmp_int(tmp_size))
       tmp_int=9999999
       tmp_int(1)=0
       IF (PRESENT(nv))   tmp_int(2)=nv
       IF (PRESENT(nmat)) tmp_int(3)=nmat
       IF (PRESENT(nlotot)) tmp_int(4)=nlotot
       IF (PRESENT(k1))   tmp_int(4+1:4+SIZE(k1))=k1
       IF (PRESENT(k2))   tmp_int(4+d%size_k+1:4+d%size_k+SIZE(k2))=k2
       IF (PRESENT(k3))   tmp_int(4+2*d%size_k+1:4+2*d%size_k+SIZE(k3))=k3
       IF (PRESENT(kveclo)) tmp_int(4+3*d%size_k+1:4+3*d%size_k+SIZE(kveclo))=kveclo
       CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,d%int_handle,e)
       CALL MPI_ACCUMULATE(tmp_int,tmp_size,MPI_INTEGER,pe,slot,tmp_size,MPI_INTEGER,MPI_MIN,d%int_handle,e)
       CALL MPI_WIN_UNLOCK(pe,d%int_handle,e)
    ENDIF
    !write the real-values
    IF (ANY((/PRESENT(wk),PRESENT(bk3),PRESENT(el),PRESENT(ello),PRESENT(evac)/))) THEN
       tmp_size=6+d%size_el+d%size_ello
       ALLOCATE(tmp_real(tmp_size))
       tmp_real=1E99
       IF (PRESENT(wk))   tmp_real(1)=wk
       IF (PRESENT(bk3))  tmp_real(2:4)=bk3
       IF (PRESENT(evac)) tmp_real(5:6)=evac
       IF (PRESENT(el))   tmp_real(6+1:6+SIZE(el))=RESHAPE(el,(/SIZE(el)/))
       IF (PRESENT(ello)) tmp_real(6+d%size_el+1:6+d%size_el+SIZE(ello))=RESHAPE(ello,(/SIZE(ello)/))

       CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,d%real_handle,e)
       CALL MPI_ACCUMULATE(tmp_real,tmp_size,MPI_DOUBLE_PRECISION,pe,slot,tmp_size,MPI_DOUBLE_PRECISION,MPI_MIN,d%real_handle,e)
       CALL MPI_WIN_UNLOCK(pe,d%real_handle,e)
       DEALLOCATE(tmp_real)
    ENDIF
Daniel Wortmann's avatar
Daniel Wortmann committed
456
    IF (PRESENT(eig).OR.PRESENT(w_iks)) THEN
457 458
       ALLOCATE(tmp_real(d%size_eig))
       tmp_real=1E99
Daniel Wortmann's avatar
Daniel Wortmann committed
459 460 461 462 463 464 465 466 467 468
       if (PRESENT(EIG)) THEN
          n1=1;n3=1
          IF (PRESENT(n_rank)) n1=n_rank+1
          IF (PRESENT(n_size)) n3=n_size
          n2=SIZE(eig)*n3+n1-1
          nn=1
          DO n=n1,min(n2,d%size_eig),n3
             tmp_real(n)=eig(nn)
             nn=nn+1
          ENDDO
469 470 471 472 473 474 475
          CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,d%eig_handle,e)
          IF (n3.ne.1) THEN
             CALL MPI_ACCUMULATE(tmp_real,d%size_eig,MPI_DOUBLE_PRECISION,pe,slot,d%size_eig,MPI_DOUBLE_PRECISION,MPI_MIN,d%eig_handle,e)
          ELSE
             CALL MPI_PUT(tmp_real,d%size_eig,MPI_DOUBLE_PRECISION,pe,slot,d%size_eig,MPI_DOUBLE_PRECISION,d%eig_handle,e)
          ENDIF
          CALL MPI_WIN_UNLOCK(pe,d%eig_handle,e)
Daniel Wortmann's avatar
Daniel Wortmann committed
476
       END if
477 478 479 480 481 482
       IF (PRESENT(w_iks)) THEN
          tmp_real(:size(w_iks))=w_iks
          CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,d%w_iks_handle,e)
          CALL MPI_PUT(tmp_real,d%size_eig,MPI_DOUBLE_PRECISION,pe,slot,d%size_eig,MPI_DOUBLE_PRECISION,d%w_iks_handle,e)
          CALL MPI_WIN_UNLOCK(pe,d%w_iks_handle,e)
       END IF
483 484
       DEALLOCATE(tmp_real)
    ENDIF
485 486
    IF (PRESENT(zmat)) THEN
       tmp_size=zmat%nbasfcn
487 488
       ALLOCATE(tmp_real(tmp_size))
       ALLOCATE(tmp_cmplx(tmp_size))
489
       DO n=1,zmat%nbands
490 491 492
          n1=n-1
          IF (PRESENT(n_size)) n1=n_size*n1
          IF (PRESENT(n_rank)) n1=n1+n_rank
493
          IF (n1+1>size(d%slot_ev,3)) EXIT
494 495 496
          slot=d%slot_ev(nk,jspin,n1+1)
          pe=d%pe_ev(nk,jspin,n1+1)
          !print *, "PE:",pe," Slot: ",slot," Size:",tmp_size,tmp_real(1)
497
          IF (zmat%l_real) THEN
498
             if (.not.d%l_real) THEN
499
                tmp_cmplx=zmat%z_r(:,n)
500 501 502 503
                CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,d%zc_handle,e)
                CALL MPI_PUT(tmp_cmplx,tmp_size,MPI_DOUBLE_COMPLEX,pe,slot,tmp_size,MPI_DOUBLE_COMPLEX,d%zc_handle,e)
                CALL MPI_WIN_UNLOCK(pe,d%zc_handle,e)
             else
504
                tmp_real=zmat%z_r(:,n)
505 506 507 508
                CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,d%zr_handle,e)
                CALL MPI_PUT(tmp_real,tmp_size,MPI_DOUBLE_PRECISION,pe,slot,tmp_size,MPI_DOUBLE_PRECISION,d%zr_handle,e)
                CALL MPI_WIN_UNLOCK(pe,d%zr_handle,e)
             endif
509
          ELSE
510
             if (d%l_real) CALL juDFT_error("Could not write complex data to file prepared for real data",calledby="eig66_mpi%write_eig")
511
             tmp_cmplx=zmat%z_c(:,n)
512 513 514
             CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,d%zc_handle,e)
             CALL MPI_PUT(tmp_cmplx,tmp_size,MPI_DOUBLE_COMPLEX,pe,slot,tmp_size,MPI_DOUBLE_COMPLEX,d%zc_handle,e)
             CALL MPI_WIN_UNLOCK(pe,d%zc_handle,e)
515
          ENDIF
516 517
       ENDDO
    ENDIF
518 519

#endif
520 521
  END SUBROUTINE write_eig

522
#ifdef CPP_MPI
523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539
  SUBROUTINE priv_put_data(pe,slot,DATA,handle)
    IMPLICIT NONE
    INTEGER,INTENT(IN)  :: pe,slot
    CLASS(*),INTENT(IN) :: DATA(:)
    INTEGER,INTENT(IN)  :: handle

    INTEGER             :: len,e
    INTEGER,ALLOCATABLE :: int_tmp(:)
    REAL,ALLOCATABLE    :: real_tmp(:)
    COMPLEX,ALLOCATABLE:: cmplx_tmp(:)
    INCLUDE 'mpif.h'
    len=SIZE(DATA)
    SELECT TYPE(DATA)
    TYPE IS (INTEGER)
       ALLOCATE(int_tmp(len))
       int_tmp=DATA
       CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,handle,e)
540
       CALL MPI_PUT(int_tmp,len,MPI_INTEGER,pe,int(slot,MPI_ADDRESS_KIND),len,MPI_INTEGER,handle,e)
541 542 543 544 545
       CALL MPI_WIN_UNLOCK(pe,handle,e)
    TYPE is (REAL)
       ALLOCATE(real_tmp(len))
       real_tmp=DATA
       CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,handle,e)
546
       CALL MPI_PUT(real_tmp,len,MPI_DOUBLE_PRECISION,pe,int(slot,MPI_ADDRESS_KIND),len,MPI_DOUBLE_PRECISION,handle,e)
547 548 549 550 551
       CALL MPI_WIN_UNLOCK(pe,handle,e)
    TYPE is (COMPLEX)
       ALLOCATE(cmplx_tmp(len))
       cmplx_tmp=DATA
       CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,handle,e)
552
       CALL MPI_PUT(cmplx_tmp,len,MPI_DOUBLE_COMPLEX,pe,int(slot,MPI_ADDRESS_KIND),len,MPI_DOUBLE_COMPLEX,handle,e)
553 554 555 556
       CALL MPI_WIN_UNLOCK(pe,handle,e)
    END SELECT
  END SUBROUTINE priv_put_data

557
  SUBROUTINE priv_get_data(pe,slot,len,handle,idata,rdata,cdata)
558 559
    IMPLICIT NONE
    INTEGER,INTENT(IN)  :: pe,slot,len
560 561 562
    INTEGER,INTENT(OUT),optional :: iDATA(len)
    REAL,INTENT(OUT),optional    :: rDATA(len)
    COMPLEX,INTENT(OUT),optional :: cDATA(len)
563 564 565 566 567 568 569 570
    INTEGER,INTENT(IN)  :: handle

    INTEGER             :: e
    INTEGER,ALLOCATABLE :: int_tmp(:)
    REAL,ALLOCATABLE    :: real_tmp(:)
    COMPLEX,ALLOCATABLE:: cmplx_tmp(:)
    INCLUDE 'mpif.h'

571
    IF (present(idata)) THEN
572 573
       ALLOCATE(int_tmp(len))
       CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,handle,e)
574
       CALL MPI_GET(int_tmp,len,MPI_INTEGER,pe,int(slot,MPI_ADDRESS_KIND),len,MPI_INTEGER,handle,e)
575
       CALL MPI_WIN_UNLOCK(pe,handle,e)
576 577
       iDATA=int_tmp
    ELSE IF (PRESENT(rdata)) THEN
578 579
       ALLOCATE(real_tmp(len))
       CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,handle,e)
580
       CALL MPI_GET(real_tmp,len,MPI_DOUBLE_PRECISION,pe,int(slot,MPI_ADDRESS_KIND),len,MPI_DOUBLE_PRECISION,handle,e)
581
       CALL MPI_WIN_UNLOCK(pe,handle,e)
582 583
       rDATA=real_tmp
    ELSE IF (PRESENT(cdata)) THEN
584 585
       ALLOCATE(cmplx_tmp(len))
       CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,handle,e)
586
       CALL MPI_GET(cmplx_tmp,len,MPI_DOUBLE_COMPLEX,pe,int(slot,MPI_ADDRESS_KIND),len,MPI_DOUBLE_COMPLEX,handle,e)
587
       CALL MPI_WIN_UNLOCK(pe,handle,e)
588 589 590 591 592
       cDATA=cmplx_tmp
    ELSE
       call judft_error("BUG in priv_get_data")
    ENDIF

593
  END SUBROUTINE priv_get_data
594
#endif
595 596 597 598 599 600 601 602 603

  SUBROUTINE write_dos(id,nk,jspin,qal,qvac,qis,qvlay,qstars,ksym,jsym,mcd,qintsl,qmtsl,qmtp,orbcomp)
    IMPLICIT NONE
    INTEGER, INTENT(IN)          :: id,nk,jspin
    REAL,INTENT(IN)              :: qal(:,:,:),qvac(:,:),qis(:),qvlay(:,:,:)
    COMPLEX,INTENT(IN)           :: qstars(:,:,:,:)
    INTEGER,INTENT(IN)           :: ksym(:),jsym(:)
    REAL,INTENT(IN),OPTIONAL     :: mcd(:,:,:)
    REAL,INTENT(IN),OPTIONAL     :: qintsl(:,:),qmtsl(:,:),qmtp(:,:),orbcomp(:,:,:)
604
#ifdef CPP_MPI
605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625
    TYPE(t_data_MPI),POINTER :: d
    INTEGER:: pe,slot

    CALL priv_find_data(id,d)
    pe=d%pe_basis(nk,jspin)
    slot=d%slot_basis(nk,jspin)

    CALL priv_put_data(pe,slot,RESHAPE(qal,(/SIZE(qal)/)),d%qal_handle)
    CALL priv_put_data(pe,slot,RESHAPE(qvac,(/SIZE(qvac)/)),d%qvac_handle)
    CALL priv_put_data(pe,slot,RESHAPE(qis,(/SIZE(qis)/)),d%qis_handle)
    CALL priv_put_data(pe,slot,RESHAPE(qvlay,(/SIZE(qvlay)/)),d%qvlay_handle)
    CALL priv_put_data(pe,slot,RESHAPE(qstars,(/SIZE(qstars)/)),d%qstars_handle)
    CALL priv_put_data(pe,slot,RESHAPE(ksym,(/SIZE(ksym)/)),d%ksym_handle)
    CALL priv_put_data(pe,slot,RESHAPE(jsym,(/SIZE(jsym)/)),d%jsym_handle)
    IF (d%l_mcd.AND.PRESENT(mcd))  CALL priv_put_data(pe,slot,RESHAPE(mcd,(/SIZE(mcd)/)),d%mcd_handle)
    IF (d%l_orb.AND.PRESENT(qintsl)) THEN
       CALL priv_put_data(pe,slot,RESHAPE(qintsl,(/SIZE(qintsl)/)),d%qintsl_handle)
       CALL priv_put_data(pe,slot,RESHAPE(qmtsl,(/SIZE(qmtsl)/)),d%qmtsl_handle)
       CALL priv_put_data(pe,slot,RESHAPE(qmtp,(/SIZE(qmtp)/)),d%qmtp_handle)
       CALL priv_put_data(pe,slot,RESHAPE(orbcomp,(/SIZE(orbcomp)/)),d%orbcomp_handle)
    ENDIF
626
#endif
627 628 629 630 631 632 633 634 635 636
  END SUBROUTINE write_dos

  SUBROUTINE read_dos(id,nk,jspin,qal,qvac,qis,qvlay,qstars,ksym,jsym,mcd,qintsl,qmtsl,qmtp,orbcomp)
    IMPLICIT NONE
    INTEGER, INTENT(IN)          :: id,nk,jspin
    REAL,INTENT(out)              :: qal(:,:,:),qvac(:,:),qis(:),qvlay(:,:,:)
    COMPLEX,INTENT(out)           :: qstars(:,:,:,:)
    INTEGER,INTENT(out)           :: ksym(:),jsym(:)
    REAL,INTENT(out),OPTIONAL     :: mcd(:,:,:)
    REAL,INTENT(out),OPTIONAL     :: qintsl(:,:),qmtsl(:,:),qmtp(:,:),orbcomp(:,:,:)
637
#ifdef CPP_MPI
638 639 640 641 642 643 644
    TYPE(t_data_MPI),POINTER :: d
    INTEGER:: pe,slot

    CALL priv_find_data(id,d)
    pe=d%pe_basis(nk,jspin)
    slot=d%slot_basis(nk,jspin)

645 646 647 648 649 650 651 652
    CALL priv_get_data(pe,slot,SIZE(qal),d%qal_handle,rdata=qal)
    CALL priv_get_data(pe,slot,SIZE(qvac),d%qvac_handle,rdata=qvac)
    CALL priv_get_data(pe,slot,SIZE(qis),d%qis_handle,rdata=qis)
    CALL priv_get_data(pe,slot,SIZE(qvlay),d%qvlay_handle,rdata=qvlay)
    CALL priv_get_data(pe,slot,SIZE(qstars),d%qstars_handle,cdata=qstars)
    CALL priv_get_data(pe,slot,SIZE(ksym),d%ksym_handle,idata=ksym)
    CALL priv_get_data(pe,slot,SIZE(jsym),d%jsym_handle,idata=jsym)
    IF (d%l_mcd.AND.PRESENT(mcd))  CALL priv_get_data(pe,slot,SIZE(mcd),d%mcd_handle,rdata=mcd)
653
    IF (d%l_orb.AND.PRESENT(qintsl)) THEN
654 655 656 657
       CALL priv_get_data(pe,slot,SIZE(qintsl),d%qintsl_handle,rdata=qintsl)
       CALL priv_get_data(pe,slot,SIZE(qmtsl),d%qmtsl_handle,rdata=qmtsl)
       CALL priv_get_data(pe,slot,SIZE(qmtp),d%qmtp_handle,rdata=qmtp)
       CALL priv_get_data(pe,slot,SIZE(orbcomp),d%orbcomp_handle,rdata=orbcomp)
658
    ENDIF
659
#endif
660 661
  END SUBROUTINE read_dos

662 663

#ifdef CPP_MPI
664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701
  SUBROUTINE create_maps(d,isize,nkpts,jspins,neig,n_size)
    IMPLICIT NONE
    TYPE(t_data_MPI),INTENT(INOUT):: d
    INTEGER,INTENT(IN):: isize,nkpts,jspins,neig,n_size

    INTEGER:: nk,j,n1,n2,n,pe,n_members
    INTEGER::used(0:isize)

    ALLOCATE(d%pe_basis(nkpts,jspins),d%slot_basis(nkpts,jspins))
    ALLOCATE(d%pe_ev(nkpts,jspins,neig),d%slot_ev(nkpts,jspins,neig))

    !basis contains a total of nkpts*jspins entries
    d%pe_basis=-1
    d%pe_ev=-1
    used=0
    n_members=isize/n_size !no of k-points in parallel
    DO j=1,jspins
       DO nk=1,nkpts
          n1=nk+(j-1)*nkpts-1
          pe=MOD(n1,n_members)*n_size
          d%pe_basis(nk,j)=pe
          d%slot_basis(nk,j)=used(pe)
          used(pe)=used(pe)+1
       ENDDO
    ENDDO
    used=0
    DO n=1,neig
       DO j=1,jspins
          DO nk=1,nkpts
             n1=nk+(j-1)*nkpts-1
             !eigenvectors have more entries
             pe=MOD(n1,n_members)*n_size+MOD(n,n_size)
             d%pe_ev(nk,j,n)=pe
             d%slot_ev(nk,j,n)=used(pe)
             used(pe)=used(pe)+1
          ENDDO
       ENDDO
    ENDDO
702

703
  END SUBROUTINE create_maps
704 705 706 707


#endif
END MODULE m_eig66_mpi