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


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

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

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

#ifdef CPP_MPI
168 169 170
    INTEGER                   :: pe,tmp_size,e
    INTEGER(MPI_ADDRESS_KIND) :: slot
    INTEGER                   :: n1,n2,n3,n
171 172 173
    INTEGER,ALLOCATABLE,ASYNCHRONOUS       :: tmp_int(:)
    REAL,ALLOCATABLE,ASYNCHRONOUS          :: tmp_real(:)
    COMPLEX,ALLOCATABLE,ASYNCHRONOUS       :: tmp_cmplx(:)
174
    TYPE(t_data_MPI),POINTER,ASYNCHRONOUS :: d
175 176 177 178 179 180 181 182 183
    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
184
    IF (PRESENT(eig).or.PRESENT(w_iks)) THEN
185
       ALLOCATE(tmp_real(MIN(SIZE(eig),d%size_eig)))
Daniel Wortmann's avatar
Daniel Wortmann committed
186
       IF (PRESENT(eig)) THEN
187
          CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,d%eig_handle,e)
Daniel Wortmann's avatar
Daniel Wortmann committed
188
          CALL MPI_GET(tmp_real,SIZE(tmp_real),MPI_DOUBLE_PRECISION,pe,slot,size(tmp_real),MPI_DOUBLE_PRECISION,d%eig_handle,e)
189
          CALL MPI_WIN_UNLOCK(pe,d%eig_handle,e)
190
          eig(:size(tmp_real))=tmp_real
Daniel Wortmann's avatar
Daniel Wortmann committed
191
       END IF
192 193
       IF (PRESENT(w_iks)) THEN
          CALL MPI_WIN_LOCK(MPI_LOCK_SHARED,pe,0,d%w_iks_handle,e)
Daniel Wortmann's avatar
Daniel Wortmann committed
194
          CALL MPI_GET(tmp_real,size(tmp_real),MPI_DOUBLE_PRECISION,pe,slot,size(tmp_real),MPI_DOUBLE_PRECISION,d%w_iks_handle,e)
195
          CALL MPI_WIN_UNLOCK(pe,d%w_iks_handle,e)
196
          w_iks(:SIZE(tmp_real))=tmp_real
197
       END IF
198 199 200
       DEALLOCATE(tmp_real)
    ENDIF

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

#endif
240 241
  END SUBROUTINE read_eig

242
  SUBROUTINE write_eig(id,nk,jspin,neig,neig_total,eig,w_iks,n_size,n_rank,zmat)
243 244
    INTEGER, INTENT(IN)          :: id,nk,jspin
    INTEGER, INTENT(IN),OPTIONAL :: n_size,n_rank
245 246
    INTEGER, INTENT(IN),OPTIONAL :: neig,neig_total
    REAL,    INTENT(IN),OPTIONAL :: eig(:),w_iks(:)
247
    TYPE(t_mat),INTENT(IN),OPTIONAL :: zmat
248 249

#ifdef CPP_MPI
250 251
    INTEGER                   :: pe,tmp_size,e
    INTEGER(MPI_ADDRESS_KIND) :: slot
252
    INTEGER                   :: n1,n2,n3,n,nn
253 254 255
    INTEGER,ALLOCATABLE,ASYNCHRONOUS       :: tmp_int(:)
    REAL,ALLOCATABLE,ASYNCHRONOUS          :: tmp_real(:)
    COMPLEX,ALLOCATABLE,ASYNCHRONOUS       :: tmp_cmplx(:)
256
    LOGICAL                   :: acc
257
    TYPE(t_data_MPI),POINTER,ASYNCHRONOUS :: d
258

259 260
    INTEGER:: irank,ierr

261 262
    CALL priv_find_data(id,d)

263 264
    CALL MPI_COMM_RANK(MPI_COMM_WORLD,irank,ierr)

265 266
    pe=d%pe_basis(nk,jspin)
    slot=d%slot_basis(nk,jspin)
267 268
    !write the number of eigenvalues 
    !only one process needs to do it
269 270 271 272 273 274 275 276 277
    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

278 279
    !write the eigenvalues 
    !only one process needs to do it
Daniel Wortmann's avatar
Daniel Wortmann committed
280
    IF (PRESENT(eig).OR.PRESENT(w_iks)) THEN
281 282
       ALLOCATE(tmp_real(d%size_eig))
       tmp_real=1E99
Daniel Wortmann's avatar
Daniel Wortmann committed
283
       if (PRESENT(EIG)) THEN
284
          tmp_real(:SIZE(eig)) = eig(:SIZE(eig))
285
          CALL MPI_WIN_LOCK(MPI_LOCK_EXCLUSIVE,pe,0,d%eig_handle,e)
286
          CALL MPI_PUT(tmp_real,d%size_eig,MPI_DOUBLE_PRECISION,pe,slot,d%size_eig,MPI_DOUBLE_PRECISION,d%eig_handle,e)
287
          CALL MPI_WIN_UNLOCK(pe,d%eig_handle,e)
Daniel Wortmann's avatar
Daniel Wortmann committed
288
       END if
289 290 291 292 293 294
       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
295 296
       DEALLOCATE(tmp_real)
    ENDIF
297 298 299

    !write the eigenvectors
    !all procceses participate 
300
    IF (PRESENT(zmat)) THEN
301
       tmp_size=zmat%matsize1
302 303
       ALLOCATE(tmp_real(tmp_size))
       ALLOCATE(tmp_cmplx(tmp_size))
304
       DO n=1,zmat%matsize2
305 306 307
          n1=n-1
          IF (PRESENT(n_size)) n1=n_size*n1
          IF (PRESENT(n_rank)) n1=n1+n_rank
308
          IF (n1+1>size(d%slot_ev,3)) EXIT
309 310
          slot=d%slot_ev(nk,jspin,n1+1)
          pe=d%pe_ev(nk,jspin,n1+1)
311
          IF (zmat%l_real) THEN
312
             if (.not.d%l_real) THEN
313
                tmp_cmplx=zmat%data_r(:,n)
314 315 316
                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)
317
               else
318
                tmp_real=zmat%data_r(:,n)
319 320 321 322
                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
323
          ELSE
324
             if (d%l_real) CALL juDFT_error("Could not write complex data to file prepared for real data",calledby="eig66_mpi%write_eig")
325
             tmp_cmplx=zmat%data_c(:,n)
326 327 328
             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)
329
          ENDIF
330 331
       ENDDO
    ENDIF
332 333

#endif
334 335
  END SUBROUTINE write_eig

336 337 338 339
  SUBROUTINE reset_eig(id,l_soc)
    INTEGER, INTENT(IN)        :: id
    LOGICAL, INTENT(IN)        :: l_soc
#ifdef CPP_MPI
340
    TYPE(t_data_MPI),POINTER,ASYNCHRONOUS :: d
341 342 343 344 345 346 347 348 349 350 351 352 353
    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

354

355
#ifdef CPP_MPI
356 357
  SUBROUTINE create_maps(d,isize,nkpts,jspins,neig,n_size)
    IMPLICIT NONE
358
    TYPE(t_data_MPI),INTENT(INOUT),ASYNCHRONOUS:: d
359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386
    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
387 388
             !pe=MOD(n1,n_members)*n_size+MOD(n,n_size)
             pe=MOD(n1,n_members)*n_size+MOD(n-1,n_size)
389 390 391 392 393 394
             d%pe_ev(nk,j,n)=pe
             d%slot_ev(nk,j,n)=used(pe)
             used(pe)=used(pe)+1
          ENDDO
       ENDDO
    ENDDO
395

396
  END SUBROUTINE create_maps
397
#endif
398

399
END MODULE m_eig66_mpi