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

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

18 19 20 21 22 23 24 25 26
    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
27 28


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

    CALL priv_find_data(id,d)
42
    CALL eig66_data_storedefault(d,jspins,nkpts,nmat,neig,l_real.and..not.l_soc,l_soc)
43 44 45

    IF (PRESENT(n_size_opt)) d%n_size=n_size_opt
    IF (ALLOCATED(d%pe_ev)) THEN
46 47
       IF (create) CALL reset_eig(id,l_soc)
       IF (PRESENT(filename)) CALL judft_error("Storing of data not implemented for MPI case",calledby="eig66_mpi.F")
48 49
       RETURN !everything already done!
    ENDIF
50

51 52 53 54 55 56 57 58 59 60
    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
61
    CALL priv_create_memory(1,local_slots,d%neig_handle,d%neig_data)
62 63 64
    d%neig_data=0

    !The eigenvalues
65
    d%size_eig=neig
66
    CALL priv_create_memory(d%size_eig,local_slots,d%eig_handle,real_data_ptr=d%eig_data)
67
    d%eig_data=1E99
68 69 70 71
    !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

72 73 74 75
    !The eigenvectors
    local_slots=COUNT(d%pe_ev==d%irank)
    slot_size=nmat

76
    IF (l_real.AND..NOT.l_soc) THEN
77 78 79
       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)
80 81
    ENDIF
    IF (PRESENT(filename).AND..NOT.create) CALL judft_error("Storing of data not implemented for MPI case",calledby="eig66_mpi.F")
Daniel Wortmann's avatar
Daniel Wortmann committed
82
    CALL MPI_BARRIER(MPI_COMM,e)
83 84
    CALL timestop("create data spaces in ei66_mpi")
  CONTAINS
85
    SUBROUTINE priv_create_memory(slot_size,local_slots,handle,int_data_ptr,real_data_ptr,cmplx_data_ptr)
86 87
      IMPLICIT NONE
      INTEGER,INTENT(IN)           :: slot_size,local_slots
88 89 90
      INTEGER,POINTER,OPTIONAL,ASYNCHRONOUS  :: int_data_ptr(:)
      REAL   ,POINTER,OPTIONAL,ASYNCHRONOUS  :: real_data_ptr(:)
      COMPLEX,POINTER,OPTIONAL,ASYNCHRONOUS  :: cmplx_data_ptr(:)
91
      INTEGER,INTENT(OUT)          :: handle
92
#ifdef CPP_MPI
93 94 95
      TYPE(c_ptr)::ptr
      INTEGER:: e
      INTEGER(MPI_ADDRESS_KIND) :: length
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
      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") 
112
      length=MAX(1,slot_size*local_slots)
113
 
114
#ifdef CPP_MPI_ALLOC      
115 116 117
      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")
118 119 120 121 122 123 124
#endif	
      IF (PRESENT(real_data_ptr)) THEN
#ifdef CPP_MPI_ALLOC         
         CALL C_F_POINTER(ptr,real_data_ptr,(/length/type_size/))
#else
         ALLOCATE(real_data_ptr(length))
#endif         
125
      	CALL MPI_WIN_CREATE(real_data_ptr, length,slot_size*type_size,Mpi_INFO_NULL, MPI_COMM,handle, e)
126 127 128 129 130 131
    ELSEIF(PRESENT(int_data_ptr)) THEN
#ifdef CPP_MPI_ALLOC
       CALL C_F_POINTER(ptr,int_data_ptr,(/length/type_size/))
#else
       ALLOCATE(int_data_ptr(length))
#endif         
132
      	CALL MPI_WIN_CREATE(int_data_ptr, length,slot_size*type_size,Mpi_INFO_NULL, MPI_COMM,handle, e)
133 134 135 136 137 138 139 140
    ELSE
#ifdef CPP_MPI_ALLOC       
       CALL C_F_POINTER(ptr,cmplx_data_ptr,(/length/type_size/))
#else
       ALLOCATE(cmplx_data_ptr(length))
#endif   
       CALL MPI_WIN_CREATE(cmplx_data_ptr, length,slot_size*type_size,Mpi_INFO_NULL, MPI_COMM,handle, e)
    ENDIF
141
#endif
142
    END SUBROUTINE priv_create_memory
143 144


145
#endif
146 147
  END SUBROUTINE open_eig
  SUBROUTINE close_eig(id,delete,filename)
148 149 150
    INTEGER,INTENT(IN)         :: id
    LOGICAL,INTENT(IN),OPTIONAL:: delete
    CHARACTER(LEN=*),INTENT(IN),OPTIONAL::filename
151
    TYPE(t_data_MPI),POINTER,ASYNCHRONOUS :: d
152
    CALL priv_find_data(id,d)
153

154 155
    IF (PRESENT(delete)) THEN
       IF (delete) WRITE(*,*) "No deallocation of memory implemented in eig66_mpi"
156
    ENDIF
157
    IF (PRESENT(filename)) CALL judft_error("Storing of data not implemented for MPI case",calledby="eig66_mpi.F")
158 159
  END SUBROUTINE close_eig

160
  SUBROUTINE read_eig(id,nk,jspin,neig,eig,w_iks,n_start,n_end,zmat)
161 162 163
    IMPLICIT NONE
    INTEGER, INTENT(IN)            :: id,nk,jspin
    INTEGER, INTENT(OUT),OPTIONAL  :: neig
Daniel Wortmann's avatar
Daniel Wortmann committed
164
    REAL,    INTENT(OUT),OPTIONAL  :: eig(:),w_iks(:)
165
    INTEGER, INTENT(IN),OPTIONAL   :: n_start,n_end
166
    TYPE(t_mat),OPTIONAL  :: zmat
167 168

#ifdef CPP_MPI
169 170 171 172 173 174
    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(:)
175
    TYPE(t_data_MPI),POINTER,ASYNCHRONOUS :: d
176 177 178 179 180 181 182 183 184 185
    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
Daniel Wortmann's avatar
Daniel Wortmann committed
186
    IF (PRESENT(eig).or.PRESENT(w_iks)) THEN
187
       ALLOCATE(tmp_real(d%size_eig))
Daniel Wortmann's avatar
Daniel Wortmann committed
188
       IF (PRESENT(eig)) THEN
189 190 191
          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
192 193 194 195 196
          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
197 198 199 200 201 202
       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
203 204 205
       DEALLOCATE(tmp_real)
    ENDIF

206
    IF (PRESENT(zmat)) THEN
207
       tmp_size=zmat%matsize1
208 209
       ALLOCATE(tmp_real(tmp_size))
       ALLOCATE(tmp_cmplx(tmp_size))
210
       DO n=1,zmat%matsize2
211 212 213 214 215 216 217
          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)
218 219
          
          if (zmat%l_real) THEN
220 221 222 223 224
             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)
225
                zmat%data_r(:,n)=REAL(tmp_cmplx)
226 227 228 229 230
             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)
231
                zmat%data_r(:,n)=tmp_real
232
             endif
233
          ELSE
234
             if (d%l_real) call judft_error("Could not read complex data, only real data is stored",calledby="eig66_mpi%read_eig")
235 236 237 238
             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)
239
             zmat%data_c(:,n)=tmp_cmplx
Daniel Wortmann's avatar
Bugfix  
Daniel Wortmann committed
240
          ENDIF
241 242
       ENDDO
    ENDIF
243 244

#endif
245 246
  END SUBROUTINE read_eig

247
  SUBROUTINE write_eig(id,nk,jspin,neig,neig_total,eig,w_iks,n_size,n_rank,zmat)
248 249
    INTEGER, INTENT(IN)          :: id,nk,jspin
    INTEGER, INTENT(IN),OPTIONAL :: n_size,n_rank
250 251
    INTEGER, INTENT(IN),OPTIONAL :: neig,neig_total
    REAL,    INTENT(IN),OPTIONAL :: eig(:),w_iks(:)
Daniel Wortmann's avatar
Daniel Wortmann committed
252
    TYPE(t_mat),INTENT(IN),OPTIONAL :: zmat
253 254

#ifdef CPP_MPI
255 256
    INTEGER                   :: pe,tmp_size,e
    INTEGER(MPI_ADDRESS_KIND) :: slot
257
    INTEGER                   :: n1,n2,n3,n,nn
258 259 260 261
    INTEGER,ALLOCATABLE       :: tmp_int(:)
    REAL,ALLOCATABLE          :: tmp_real(:)
    COMPLEX,ALLOCATABLE       :: tmp_cmplx(:)
    LOGICAL                   :: acc
262
    TYPE(t_data_MPI),POINTER,ASYNCHRONOUS :: d
263 264 265 266 267 268 269 270 271 272 273 274 275 276 277

    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

Daniel Wortmann's avatar
Daniel Wortmann committed
278
    IF (PRESENT(eig).OR.PRESENT(w_iks)) THEN
279 280
       ALLOCATE(tmp_real(d%size_eig))
       tmp_real=1E99
Daniel Wortmann's avatar
Daniel Wortmann committed
281 282 283 284 285 286 287 288 289 290
       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
291 292 293 294 295 296 297
          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
298
       END if
299 300 301 302 303 304
       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
305 306
       DEALLOCATE(tmp_real)
    ENDIF
307
    IF (PRESENT(zmat)) THEN
Daniel Wortmann's avatar
Daniel Wortmann committed
308
       tmp_size=zmat%matsize1
309 310
       ALLOCATE(tmp_real(tmp_size))
       ALLOCATE(tmp_cmplx(tmp_size))
Daniel Wortmann's avatar
Daniel Wortmann committed
311
       DO n=1,zmat%matsize2
312 313 314
          n1=n-1
          IF (PRESENT(n_size)) n1=n_size*n1
          IF (PRESENT(n_rank)) n1=n1+n_rank
315
          IF (n1+1>size(d%slot_ev,3)) EXIT
316 317 318
          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)
319
          IF (zmat%l_real) THEN
320
             if (.not.d%l_real) THEN
Daniel Wortmann's avatar
Daniel Wortmann committed
321
                tmp_cmplx=zmat%data_r(:,n)
322 323 324 325
                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
Daniel Wortmann's avatar
Daniel Wortmann committed
326
                tmp_real=zmat%data_r(:,n)
327 328 329 330
                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
331
          ELSE
332
             if (d%l_real) CALL juDFT_error("Could not write complex data to file prepared for real data",calledby="eig66_mpi%write_eig")
Daniel Wortmann's avatar
Daniel Wortmann committed
333
             tmp_cmplx=zmat%data_c(:,n)
334 335 336
             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)
337
          ENDIF
338 339
       ENDDO
    ENDIF
340 341

#endif
342 343
  END SUBROUTINE write_eig

344 345 346 347
  SUBROUTINE reset_eig(id,l_soc)
    INTEGER, INTENT(IN)        :: id
    LOGICAL, INTENT(IN)        :: l_soc
#ifdef CPP_MPI
348
    TYPE(t_data_MPI),POINTER,ASYNCHRONOUS :: d
349 350 351 352 353 354 355 356 357 358 359 360 361
    CALL priv_find_data(id,d)

    d%neig_data=0
    d%eig_data=1E99
    d%w_iks_data=1E99
    if (d%l_real.and..not.l_soc) THEN
       d%zr_data=0.0
    else
       d%zc_data=0.0
    endif
#endif
  END SUBROUTINE reset_eig

362

363
#ifdef CPP_MPI
364 365
  SUBROUTINE create_maps(d,isize,nkpts,jspins,neig,n_size)
    IMPLICIT NONE
366
    TYPE(t_data_MPI),INTENT(INOUT),ASYNCHRONOUS:: d
367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401
    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
402

403
  END SUBROUTINE create_maps
404
#endif
405

406
END MODULE m_eig66_mpi