Line data Source code
1 : !!****m* ABINIT/m_results_out
2 : !! NAME
3 : !! m_results_out
4 : !!
5 : !! FUNCTION
6 : !! This module provides the definition of the results_out_type used
7 : !! to store results from GS calculations.
8 : !!
9 : !! COPYRIGHT
10 : !! Copyright (C) 2008-2026 ABINIT group (MT)
11 : !! This file is distributed under the terms of the
12 : !! GNU General Public License, see ~abinit/COPYING
13 : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : !!
15 : !! TODO
16 : !! One should replace the 'pointer' by 'allocatable'. This was tried, in October 2014,
17 : !! but Petrus_nag complained (test v67mbpt t31...t34), and also max2 (paral#08 np=10).
18 : !!
19 : !! SOURCE
20 :
21 : #if defined HAVE_CONFIG_H
22 : #include "config.h"
23 : #endif
24 :
25 : #include "abi_common.h"
26 :
27 : MODULE m_results_out
28 :
29 : use defs_basis
30 : use m_dtset
31 : use m_errors
32 : use m_abicore
33 : use m_xmpi
34 :
35 : use defs_abitypes, only : MPI_type
36 :
37 : implicit none
38 :
39 : private
40 :
41 : ! public procedures.
42 : public :: init_results_out
43 : public :: destroy_results_out
44 : public :: copy_results_out
45 : public :: gather_results_out
46 : !!***
47 :
48 : !!****t* m_results_out/results_out_type
49 : !! NAME
50 : !! results_out_type
51 : !!
52 : !! FUNCTION
53 : !! This structured datatype contains a subset of the results of a GS
54 : !! calculation, needed to perform the so-called "internal tests", and
55 : !! to perform the timing analysis
56 : !!
57 : !! SOURCE
58 :
59 : type, public :: results_out_type
60 :
61 : ! WARNING : if you modify this datatype, please check whether there might be creation/destruction/copy routines,
62 : ! declared in another part of ABINIT, that might need to take into account your modification.
63 :
64 : ! Integer scalar
65 :
66 : integer :: natom
67 : ! The number of atoms for this dataset
68 : integer :: nimage
69 : ! The number of images of the cell for this dataset (treated by current proc)
70 : integer :: nkpt
71 : ! The number of k-pints for this dataset
72 : integer :: nocc
73 : ! The number of occupations for this dataset
74 : integer :: npsp
75 : ! The number of pseudopotentials
76 : integer :: ntypat
77 : ! The number of types of atoms
78 :
79 : ! Integer arrays
80 :
81 : integer, pointer :: npwtot(:,:)
82 : ! npw(mxnkpt,nimage) Full number of plane waves for each
83 : ! k point, computed with the "true" rprimd
84 : ! Not taking into account the decrease due to istwfk
85 : ! Not taking into account the spread of pws on different procs
86 :
87 : ! Real (real(dp)) arrays
88 :
89 : real(dp), pointer :: acell(:,:)
90 : ! acell(3,nimage)
91 : ! Length of primitive vectors
92 :
93 : real(dp), pointer :: amu(:,:)
94 : ! amu(ntypat,nimage)
95 : ! Mass of the atomic type
96 :
97 : real(dp), pointer :: etotal(:)
98 : ! etotal(nimage)
99 : ! Total energy (Hartree)
100 :
101 : real(dp), pointer :: fcart(:,:,:)
102 : ! fcart(3,natom,nimage) Cartesian forces (Hartree/Bohr)
103 : ! Forces in cartesian coordinates (Hartree)
104 :
105 : real(dp), pointer :: gred(:,:,:)
106 : ! gred(3,natom,nimage)
107 : ! Forces in reduced coordinates (Hartree)
108 : ! Actually, gradient of the total energy with respect
109 : ! to change of reduced coordinates
110 :
111 : real(dp), pointer :: intgres(:,:,:)
112 : ! intgres(4,natom,nimage) ! 4 is for nspden
113 : ! Gradient of the total energy wrt constraints (Hartree)
114 :
115 : real(dp), pointer :: mixalch(:,:,:)
116 : ! mixalch(npsp,ntypat,nimage) [note that in psps datastructure, the dimensioning is npspalch,ntypalch]
117 : ! Mixing coefficients going from the input pseudopotentials (those for alchemical mixing) to the alchemical atoms
118 :
119 : real(dp), pointer :: occ(:,:)
120 : ! occ(mxmband_upper*mxnkpt*mxnsppol,nimage)
121 : ! Electronic occupations
122 :
123 : real(dp), pointer :: rprim(:,:,:)
124 : ! rprim(3,3,nimage)
125 : ! Dimensionless real space primitive translations
126 :
127 : real(dp), pointer :: strten(:,:)
128 : ! strten(6,nimage)
129 : ! Stress tensor
130 :
131 : real(dp), pointer :: vel(:,:,:)
132 : ! vel(3,natom,nimage)
133 : ! Atomic velocities
134 :
135 : real(dp), pointer :: vel_cell(:,:,:)
136 : ! vel_cell(3,3,nimage)
137 : ! Cell velocities
138 : ! Time derivatives of dimensional primitive translations
139 :
140 : real(dp), pointer :: xred(:,:,:)
141 : ! xred(3,natom,nimage)
142 : ! Atomic positions in reduced coordinates
143 :
144 : end type results_out_type
145 : !!***
146 :
147 : CONTAINS
148 :
149 : !===========================================================
150 : !!***
151 :
152 : !!****f* m_results_out/init_results_out
153 : !! NAME
154 : !! init_results_out
155 : !!
156 : !! FUNCTION
157 : !! Init all scalars and pointers in an array of results_out datastructures
158 : !!
159 : !! INPUTS
160 : !! dtsets(:)= <type datafiles_type> contains all input variables,
161 : !! option_alloc=0: only allocate datastructure
162 : !! 1: allocate and initialize the whole datastructure
163 : !! 2: allocate datastructure and initialize only first member
164 : !! option_size=0: allocate results_out with a global number images
165 : !! (use mxnimage=max(dtset%nimage))
166 : !! 1: allocate results_out with a number of images per processor
167 : !! (use mxnimage=max(mpi_enreg%my_nimage))
168 : !! mpi_enregs=information about MPI parallelization
169 : !! mxnimage=-optional- maximal value of nimage over datasets
170 : !! if this argument is present, it is used for allocations
171 : !! if it is not present, allocations are automatic
172 : !! natom= number of atoms
173 : !! nband= number of bands
174 : !! nkpt= number of k-points
175 : !! nsppol= number of independant spin components
176 : !!
177 : !! SIDE EFFECTS
178 : !! results_out(:)=<type(results_out_type)>=results_out datastructure array
179 : !!
180 : !! SOURCE
181 :
182 1426 : subroutine init_results_out(dtsets,option_alloc,option_size,mpi_enregs,&
183 1426 : & mxnatom,mxnband,mxnkpt,mxnpsp,mxnsppol,mxntypat,results_out)
184 :
185 : !Arguments ------------------------------------
186 : !scalars
187 : integer,intent(in) :: option_alloc,option_size
188 : integer,intent(in) :: mxnatom,mxnband,mxnkpt,mxnpsp,mxnsppol,mxntypat
189 : !arrays
190 : type(dataset_type),intent(in) :: dtsets(:)
191 : type(results_out_type),intent(inout) :: results_out(:)
192 : type(MPI_type), intent(in) :: mpi_enregs(:)
193 : !Local variables-------------------------------
194 : !scalars
195 : integer :: dtsets_size,idt1,idt2,idt3,ii,jj,kk
196 : integer :: mpi_enregs_size,mxnimage_,natom_,nkpt_,nocc_
197 : integer :: results_out_size
198 : ! type(MPI_type) :: mpi_img
199 : !arrays
200 1426 : integer,allocatable :: img(:,:),nimage(:)
201 1426 : real(dp),allocatable :: tmp(:,:)
202 :
203 : !************************************************************************
204 :
205 : !@results_out_type
206 :
207 1426 : dtsets_size=size(dtsets)
208 1426 : results_out_size=size(results_out)
209 1426 : mpi_enregs_size=size(mpi_enregs)
210 1426 : if (dtsets_size/=mpi_enregs_size .or. dtsets_size/=results_out_size) then
211 0 : ABI_ERROR("init_results_out: wrong sizes (2)!")
212 : endif
213 :
214 1426 : if (results_out_size>0) then
215 :
216 1426 : idt1=lbound(results_out,1);idt2=ubound(results_out,1)
217 1426 : idt3=idt2;if (option_alloc==2) idt3=idt1
218 4278 : ABI_MALLOC(nimage,(idt1:idt2))
219 9806 : nimage=0
220 1426 : mxnimage_=1
221 1426 : if (option_size==0) then
222 0 : do ii=idt1,idt2
223 0 : nimage(ii)=dtsets(ii)%nimage
224 0 : if (nimage(ii)>mxnimage_) mxnimage_=nimage(ii)
225 : end do
226 0 : if (option_alloc>0) then
227 0 : ABI_MALLOC(img,(mxnimage_,idt1:idt3))
228 0 : img=0
229 0 : do ii=idt1,idt3
230 0 : do jj=1,nimage(ii)
231 0 : img(jj,ii)=jj
232 : end do
233 : end do
234 : end if
235 : else
236 9806 : do ii=idt1,idt2
237 8380 : nimage(ii)=mpi_enregs(ii)%my_nimage
238 9806 : if (nimage(ii)>mxnimage_) mxnimage_=nimage(ii)
239 : end do
240 1426 : if (option_alloc>0) then
241 5704 : ABI_MALLOC(img,(mxnimage_,idt1:idt3))
242 18587 : img=0
243 9806 : do ii=idt1,idt3
244 18446 : do jj=1,nimage(ii)
245 17020 : img(jj,ii)=mpi_enregs(ii)%my_imgtab(jj)
246 : end do
247 : end do
248 : end if
249 : end if
250 :
251 9806 : do ii=idt1,idt2
252 :
253 25140 : ABI_MALLOC(results_out(ii)%acell,(3,mxnimage_))
254 33520 : ABI_MALLOC(results_out(ii)%amu,(mxntypat,mxnimage_))
255 25140 : ABI_MALLOC(results_out(ii)%etotal,(mxnimage_))
256 33520 : ABI_MALLOC(results_out(ii)%fcart,(3,mxnatom,mxnimage_))
257 25140 : ABI_MALLOC(results_out(ii)%gred,(3,mxnatom,mxnimage_))
258 33520 : ABI_MALLOC(results_out(ii)%intgres,(4,mxnatom,mxnimage_))
259 41900 : ABI_MALLOC(results_out(ii)%mixalch,(mxnpsp,mxntypat,mxnimage_))
260 33520 : ABI_MALLOC(results_out(ii)%npwtot,(mxnkpt,mxnimage_))
261 33520 : ABI_MALLOC(results_out(ii)%occ,(mxnband*mxnkpt*mxnsppol,mxnimage_))
262 25140 : ABI_MALLOC(results_out(ii)%rprim,(3,3,mxnimage_))
263 25140 : ABI_MALLOC(results_out(ii)%strten,(6,mxnimage_))
264 25140 : ABI_MALLOC(results_out(ii)%vel,(3,mxnatom,mxnimage_))
265 16760 : ABI_MALLOC(results_out(ii)%vel_cell,(3,3,mxnimage_))
266 25140 : ABI_MALLOC(results_out(ii)%xred,(3,mxnatom,mxnimage_))
267 :
268 9806 : if ((option_alloc==1).or.(option_alloc==2.and.ii==idt3)) then
269 8380 : results_out(ii)%nimage=nimage(ii)
270 : results_out(ii)%natom =mxnatom
271 : results_out(ii)%nkpt =mxnkpt
272 8380 : results_out(ii)%npsp =mxnpsp
273 8380 : results_out(ii)%ntypat =mxntypat
274 : results_out(ii)%nocc =mxnband*mxnkpt*mxnsppol
275 8380 : natom_=dtsets(ii)%natom
276 8380 : nkpt_=dtsets(ii)%nkpt;if(ii==0) nkpt_=mxnkpt
277 8380 : nocc_=mxnband*dtsets(ii)%nkpt*dtsets(ii)%nsppol
278 : results_out(ii)%nimage=nimage(ii)
279 8380 : results_out(ii)%natom=natom_
280 8380 : results_out(ii)%nkpt=nkpt_
281 8380 : results_out(ii)%nocc=nocc_
282 43504 : results_out(ii)%acell=zero
283 28403 : results_out(ii)%amu=zero
284 17161 : results_out(ii)%etotal(:)=zero
285 260693 : results_out(ii)%fcart(:,:,:)=zero
286 260693 : results_out(ii)%gred(:,:,:)=zero
287 321576 : results_out(ii)%intgres(:,:,:)=zero
288 45046 : results_out(ii)%mixalch(:,:,:)=zero
289 1815196 : results_out(ii)%occ=zero
290 122533 : results_out(ii)%rprim=zero
291 69847 : results_out(ii)%strten(:,:)=zero
292 260693 : results_out(ii)%vel=zero
293 122533 : results_out(ii)%vel_cell=zero
294 260693 : results_out(ii)%xred=zero
295 233101 : results_out(ii)%npwtot(:,:)=0
296 8380 : if (nimage(ii)>0) then
297 17020 : do jj=1,nimage(ii)
298 8640 : kk=img(jj,ii)
299 34560 : results_out(ii)%acell(:,jj) =dtsets(ii)%acell_orig(:,kk)
300 19621 : results_out(ii)%amu(:,jj) =dtsets(ii)%amu_orig(:,kk)
301 112320 : results_out(ii)%rprim(:,:,jj) =dtsets(ii)%rprim_orig(:,:,kk)
302 112320 : results_out(ii)%vel_cell(:,:,jj)=dtsets(ii)%vel_cell_orig(:,:,kk)
303 35735 : results_out(ii)%mixalch(:,:,jj) =dtsets(ii)%mixalch_orig(:,:,kk)
304 8640 : if (natom_>0) then
305 21642 : ABI_MALLOC(tmp,(3,natom_))
306 161686 : tmp(1:3,1:natom_)=dtsets(ii)%vel_orig(1:3,1:natom_,kk)
307 161686 : results_out(ii)%vel(1:3,1:natom_,jj)=tmp(1:3,1:natom_)
308 161686 : tmp(1:3,1:natom_)=dtsets(ii)%xred_orig(1:3,1:natom_,kk)
309 161686 : results_out(ii)%xred(1:3,1:natom_,jj)=tmp(1:3,1:natom_)
310 7214 : ABI_FREE(tmp)
311 : end if
312 17020 : if (nocc_>0) then
313 1030484 : results_out(ii)%occ(1:nocc_,jj)=dtsets(ii)%occ_orig(1:nocc_,kk)
314 : end if
315 : end do
316 : end if
317 : end if
318 :
319 : end do
320 1426 : ABI_FREE(nimage)
321 : !if (option_size/=0.and.option_alloc==1) then
322 1426 : if (allocated(img)) then
323 1426 : ABI_FREE(img)
324 : end if
325 : end if
326 :
327 1426 : end subroutine init_results_out
328 : !!***
329 :
330 : !----------------------------------------------------------------------
331 :
332 : !!****f* m_results_out/destroy_results_out
333 : !! NAME
334 : !! destroy_results_out
335 : !!
336 : !! FUNCTION
337 : !! Clean and destroy an array of results_out datastructures
338 : !!
339 : !! SIDE EFFECTS
340 : !! results_out(:)=<type(results_out_type)>=results_out datastructure array
341 : !!
342 : !! SOURCE
343 :
344 1426 : subroutine destroy_results_out(results_out)
345 :
346 : !Arguments ------------------------------------
347 : !arrays
348 : type(results_out_type),intent(inout) :: results_out(:)
349 : !Local variables-------------------------------
350 : !scalars
351 : integer :: idt1,idt2,ii,results_out_size
352 :
353 : !************************************************************************
354 :
355 : !@results_out_type
356 :
357 1426 : results_out_size=size(results_out)
358 1426 : if (results_out_size>0) then
359 :
360 1426 : idt1=lbound(results_out,1);idt2=ubound(results_out,1)
361 9806 : do ii=idt1,idt2
362 8380 : results_out(ii)%nimage=0
363 8380 : results_out(ii)%natom=0
364 8380 : results_out(ii)%nkpt=0
365 8380 : results_out(ii)%nocc=0
366 8380 : if (associated(results_out(ii)%acell)) then
367 8380 : ABI_FREE(results_out(ii)%acell)
368 : end if
369 8380 : if (associated(results_out(ii)%amu)) then
370 8380 : ABI_FREE(results_out(ii)%amu)
371 : end if
372 8380 : if (associated(results_out(ii)%etotal)) then
373 8380 : ABI_FREE(results_out(ii)%etotal)
374 : end if
375 8380 : if (associated(results_out(ii)%fcart)) then
376 8380 : ABI_FREE(results_out(ii)%fcart)
377 : end if
378 8380 : if (associated(results_out(ii)%gred)) then
379 8380 : ABI_FREE(results_out(ii)%gred)
380 : end if
381 8380 : if (associated(results_out(ii)%intgres)) then
382 8380 : ABI_FREE(results_out(ii)%intgres)
383 : end if
384 8380 : if (associated(results_out(ii)%mixalch)) then
385 8380 : ABI_FREE(results_out(ii)%mixalch)
386 : end if
387 8380 : if (associated(results_out(ii)%npwtot)) then
388 8380 : ABI_FREE(results_out(ii)%npwtot)
389 : end if
390 8380 : if (associated(results_out(ii)%occ)) then
391 8380 : ABI_FREE(results_out(ii)%occ)
392 : end if
393 8380 : if (associated(results_out(ii)%rprim)) then
394 8380 : ABI_FREE(results_out(ii)%rprim)
395 : end if
396 8380 : if (associated(results_out(ii)%strten)) then
397 8380 : ABI_FREE(results_out(ii)%strten)
398 : end if
399 8380 : if (associated(results_out(ii)%vel)) then
400 8380 : ABI_FREE(results_out(ii)%vel)
401 : end if
402 8380 : if (associated(results_out(ii)%vel_cell)) then
403 8380 : ABI_FREE(results_out(ii)%vel_cell)
404 : end if
405 9806 : if (associated(results_out(ii)%xred)) then
406 8380 : ABI_FREE(results_out(ii)%xred)
407 : end if
408 : end do
409 :
410 : end if
411 :
412 1426 : end subroutine destroy_results_out
413 : !!***
414 :
415 : !----------------------------------------------------------------------
416 :
417 : !!****f* m_results_out/copy_results_out
418 : !! NAME
419 : !! copy_results_out
420 : !!
421 : !! FUNCTION
422 : !! Copy a results_out datastructure into another
423 : !!
424 : !! INPUTS
425 : !! results_out_in=<type(results_out_type)>=input results_out datastructure
426 : !!
427 : !! OUTPUT
428 : !! results_out_out=<type(results_out_type)>=output results_out datastructure
429 : !!
430 : !! SOURCE
431 :
432 0 : subroutine copy_results_out(results_out_in,results_out_out)
433 :
434 : !Arguments ------------------------------------
435 : !arrays
436 : type(results_out_type),intent(in) :: results_out_in
437 : type(results_out_type),intent(out) :: results_out_out
438 : !Local variables-------------------------------
439 : !scalars
440 : integer :: natom_,natom_out,nimage_,nimage_out,nkpt_,nkpt_out,npsp_,npsp_out,nocc_,nocc_out,ntypat_,ntypat_out
441 :
442 : !************************************************************************
443 :
444 : !@results_out_type
445 :
446 0 : nimage_=size(results_out_in%etotal)
447 0 : natom_ =size(results_out_in%fcart,2)
448 0 : nkpt_ =size(results_out_in%npwtot,1)
449 0 : nocc_ =size(results_out_in%occ,1)
450 0 : npsp_ =size(results_out_in%mixalch,1)
451 0 : ntypat_=size(results_out_in%mixalch,2)
452 0 : nimage_out=0;if (associated(results_out_out%etotal))nimage_out=size(results_out_out%etotal)
453 0 : natom_out =0;if (associated(results_out_out%fcart)) natom_out =size(results_out_out%fcart,2)
454 0 : nkpt_out =0;if (associated(results_out_out%npwtot))nkpt_out =size(results_out_out%npwtot,1)
455 0 : nocc_out =0;if (associated(results_out_out%occ)) nocc_out =size(results_out_out%occ,1)
456 0 : npsp_out =0;if (associated(results_out_out%mixalch))npsp_out =size(results_out_out%mixalch,1)
457 0 : ntypat_out=0;if (associated(results_out_out%mixalch))ntypat_out=size(results_out_out%mixalch,2)
458 :
459 0 : if (nimage_>nimage_out) then
460 0 : if (associated(results_out_out%acell)) then
461 0 : ABI_FREE(results_out_out%acell)
462 : end if
463 0 : if (associated(results_out_out%etotal)) then
464 0 : ABI_FREE(results_out_out%etotal)
465 : end if
466 0 : if (associated(results_out_out%rprim)) then
467 0 : ABI_FREE(results_out_out%rprim)
468 : end if
469 0 : if (associated(results_out_out%strten)) then
470 0 : ABI_FREE(results_out_out%strten)
471 : end if
472 0 : if (associated(results_out_out%vel_cell)) then
473 0 : ABI_FREE(results_out_out%vel_cell)
474 : end if
475 0 : ABI_MALLOC(results_out_out%acell,(3,nimage_))
476 0 : ABI_MALLOC(results_out_out%etotal,(nimage_))
477 0 : ABI_MALLOC(results_out_out%rprim,(3,3,nimage_))
478 0 : ABI_MALLOC(results_out_out%strten,(6,nimage_))
479 0 : ABI_MALLOC(results_out_out%vel_cell,(3,3,nimage_))
480 : end if
481 0 : if (nimage_>nimage_out.or.natom_>natom_out) then
482 0 : if (associated(results_out_out%fcart)) then
483 0 : ABI_FREE(results_out_out%fcart)
484 : end if
485 0 : if (associated(results_out_out%gred)) then
486 0 : ABI_FREE(results_out_out%gred)
487 : end if
488 0 : if (associated(results_out_out%intgres)) then
489 0 : ABI_FREE(results_out_out%intgres)
490 : end if
491 0 : if (associated(results_out_out%vel)) then
492 0 : ABI_FREE(results_out_out%vel)
493 : end if
494 0 : if (associated(results_out_out%xred)) then
495 0 : ABI_FREE(results_out_out%xred)
496 : end if
497 0 : ABI_MALLOC(results_out_out%fcart,(3,natom_,nimage_))
498 0 : ABI_MALLOC(results_out_out%gred,(3,natom_,nimage_))
499 0 : ABI_MALLOC(results_out_out%intgres,(4,natom_,nimage_))
500 0 : ABI_MALLOC(results_out_out%vel,(3,natom_,nimage_))
501 0 : ABI_MALLOC(results_out_out%xred,(3,natom_,nimage_))
502 : end if
503 0 : if (nimage_>nimage_out.or.nkpt_>nkpt_out) then
504 0 : if (associated(results_out_out%npwtot)) then
505 0 : ABI_FREE(results_out_out%npwtot)
506 : end if
507 0 : ABI_MALLOC(results_out_out%npwtot,(nkpt_,nimage_))
508 : end if
509 0 : if (nimage_>nimage_out.or.nocc_>nocc_out) then
510 0 : if (associated(results_out_out%occ)) then
511 0 : ABI_FREE(results_out_out%occ)
512 : end if
513 0 : ABI_MALLOC(results_out_out%occ,(nocc_,nimage_))
514 : end if
515 0 : if (ntypat_>ntypat_out) then
516 0 : if (associated(results_out_out%amu)) then
517 0 : ABI_FREE(results_out_out%amu)
518 : end if
519 0 : ABI_MALLOC(results_out_out%amu,(ntypat_,nimage_))
520 : end if
521 :
522 0 : if (npsp_>npsp_out.or.ntypat_>ntypat_out) then
523 0 : if (associated(results_out_out%mixalch)) then
524 0 : ABI_FREE(results_out_out%mixalch)
525 : end if
526 0 : ABI_MALLOC(results_out_out%mixalch,(npsp_,ntypat_,nimage_))
527 : end if
528 :
529 0 : results_out_out%nimage=results_out_in%nimage
530 0 : results_out_out%natom =results_out_in%natom
531 0 : results_out_out%nkpt =results_out_in%nkpt
532 0 : results_out_out%nocc =results_out_in%nocc
533 0 : results_out_out%acell(1:3,1:nimage_) =results_out_in%acell(1:3,1:nimage_)
534 0 : results_out_out%amu(1:ntypat_,1:nimage_) =results_out_in%amu(1:ntypat_,1:nimage_)
535 0 : results_out_out%etotal(1:nimage_) =results_out_in%etotal(1:nimage_)
536 0 : results_out_out%fcart(1:3,1:natom_,1:nimage_)=results_out_in%fcart(1:3,1:natom_,1:nimage_)
537 0 : results_out_out%gred(1:3,1:natom_,1:nimage_) =results_out_in%gred(1:3,1:natom_,1:nimage_)
538 0 : results_out_out%intgres(1:4,1:natom_,1:nimage_) =results_out_in%intgres(1:4,1:natom_,1:nimage_)
539 0 : results_out_out%mixalch(1:npsp_,1:ntypat_,1:nimage_)=results_out_in%mixalch(1:npsp_,1:ntypat_,1:nimage_)
540 0 : results_out_out%npwtot(1:nkpt_,1:nimage_) =results_out_in%npwtot(1:nkpt_,1:nimage_)
541 0 : results_out_out%occ(1:nocc_,1:nimage_) =results_out_in%occ(1:nocc_,1:nimage_)
542 0 : results_out_out%rprim(1:3,1:3,1:nimage_) =results_out_in%rprim(1:3,1:3,1:nimage_)
543 0 : results_out_out%strten(1:6,1:nimage_) =results_out_in%strten(1:6,1:nimage_)
544 0 : results_out_out%xred(1:3,1:natom_,1:nimage_) =results_out_in%xred(1:3,1:natom_,1:nimage_)
545 0 : results_out_out%vel(1:3,1:natom_,1:nimage_) =results_out_in%vel(1:3,1:natom_,1:nimage_)
546 0 : results_out_out%vel_cell(1:3,1:3,1:nimage_) =results_out_in%vel_cell(1:3,1:3,1:nimage_)
547 :
548 0 : end subroutine copy_results_out
549 : !!***
550 :
551 : !----------------------------------------------------------------------
552 :
553 : !!****f* m_results_out/gather_results_out
554 : !! NAME
555 : !! gather_results_out
556 : !!
557 : !! FUNCTION
558 : !! Gather results_out datastructure array using communicator over images (replicas) of the cell.
559 : !! Each contribution of single processor is gathered into a big array on master processor
560 : !!
561 : !! INPUTS
562 : !! allgather= --optional, default=false-- if TRUE do ALL_GATHER instead of GATHER
563 : !! dtsets(:)= <type datafiles_type> contains all input variables,
564 : !! master= --optional, default=0-- index of master proc receiving gathered data (if allgather=false)
565 : !! mpi_enregs=information about MPI parallelization
566 : !! only_one_per_img= --optional, default=true-- if TRUE, the gather operation
567 : !! is only done by one proc per image (master of the comm_cell)
568 : !! results_out(:)=<type(results_out_type)>=results_out datastructure array on each proc
569 : !! use_results_all=true if results_out_all datastructure is allocated for current proc
570 : !!
571 : !! SIDE EFFECTS
572 : !! === f use_results_all=true ===
573 : !! results_out_all(:)=<type(results_out_type)>=global (gathered) results_out datastructure array
574 : !!
575 : !! SOURCE
576 :
577 0 : subroutine gather_results_out(dtsets,mpi_enregs,results_out,results_out_all,use_results_all,&
578 : & master,allgather,only_one_per_img) ! optional arguments
579 :
580 : !Arguments ------------------------------------
581 : !scalars
582 : integer,optional,intent(in) :: master
583 : logical,optional,intent(in) :: allgather,only_one_per_img
584 : logical,intent(in) :: use_results_all
585 : !arrays
586 : type(dataset_type),intent(in) :: dtsets(:)
587 : type(results_out_type),intent(in) :: results_out(:)
588 : type(results_out_type),intent(inout) :: results_out_all(:)
589 : type(MPI_type), intent(inout) :: mpi_enregs(:)
590 : !Local variables-------------------------------
591 : !scalars
592 : integer :: dtsets_size
593 : integer :: ibufi,ibufr
594 : integer :: idt1,idt2,ierr,ii,iproc,jj
595 : integer :: isize,isize_img
596 : integer :: master_all,master_img,master_one_img
597 : integer :: mpi_enregs_size,mxnatom,mxnband,mxnkpt,mxnpsp,mxnsppol,mxntypat
598 : integer :: natom_,nkpt_,nocc_,npsp_,ntypat_,nimage,nimagetot
599 : integer :: results_out_size,results_out_all_size
600 : integer :: rsize,rsize_img
601 : logical :: do_allgather,one_per_img
602 : character(len=500) :: msg
603 : ! type(MPI_type):: mpi_img
604 : !arrays
605 0 : integer,allocatable :: ibuffer(:),ibuffer_all(:),ibufshft(:)
606 0 : integer,allocatable :: iimg(:),isize_img_all(:),nimage_all(:)
607 0 : integer,allocatable :: rbufshft(:),rsize_img_all(:)
608 0 : real(dp),allocatable :: rbuffer(:),rbuffer_all(:)
609 :
610 : !************************************************************************
611 :
612 : !@results_out_type
613 :
614 0 : one_per_img=.true.;if (present(only_one_per_img)) one_per_img=only_one_per_img
615 0 : do_allgather=.false.;if (present(allgather)) do_allgather=allgather
616 0 : master_all=0;if (present(master)) master_all=master
617 :
618 : ! call init_mpi_enreg(mpi_img,init_mpi=.false.)
619 0 : master_img=0;master_one_img=0
620 : ! i_am_master=(mpi_img%me==master_all)
621 : ! use_results_all= &
622 : !& ((( do_allgather).and.( one_per_img).and.(mpi_img%me_cell==master_one_img)) .or. &
623 : !& (( do_allgather).and.(.not.one_per_img)) .or. &
624 : !& ((.not.do_allgather).and.( one_per_img).and.(mpi_img%me==master_all)) .or. &
625 : !& ((.not.do_allgather).and.(.not.one_per_img).and.(mpi_img%me_img==master_img)))
626 :
627 0 : dtsets_size=size(dtsets);results_out_size=size(results_out)
628 0 : mpi_enregs_size=size(mpi_enregs)
629 0 : if (dtsets_size/=results_out_size) then
630 0 : msg=' Wrong sizes for dtsets and results_out datastructures !'
631 0 : ABI_BUG(msg)
632 : end if
633 0 : if (mpi_enregs_size/=results_out_size) then
634 0 : msg=' Wrong sizes for dtsets and results_out datastructures !'
635 0 : ABI_BUG(msg)
636 : end if
637 :
638 0 : if (use_results_all) then
639 0 : results_out_all_size=size(results_out_all)
640 0 : if (results_out_size/=results_out_all_size) then
641 0 : msg=' Wrong size for results_out_all datastructure !'
642 0 : ABI_BUG(msg)
643 : end if
644 : end if
645 :
646 0 : if (results_out_size>0) then
647 :
648 0 : idt1=lbound(results_out,1);idt2=ubound(results_out,1)
649 :
650 : ! Create global results_out_all datastructure
651 0 : if (use_results_all) then
652 0 : mxnatom=1;mxnband=1;mxnkpt=1;mxnpsp=1;mxntypat=1
653 0 : do ii=idt1,idt2
654 0 : isize=size(results_out(ii)%fcart,2) ;if (isize>mxnatom) mxnatom=isize
655 0 : isize=size(results_out(ii)%occ,1) ;if (isize>mxnband) mxnband=isize
656 0 : isize=size(results_out(ii)%mixalch,1);if(isize>mxnpsp) mxnpsp=isize
657 0 : isize=size(results_out(ii)%npwtot,1);if (isize>mxnkpt) mxnkpt=isize
658 0 : isize=size(results_out(ii)%mixalch,2);if(isize>mxntypat) mxntypat=isize
659 : end do
660 0 : mxnband=mxnband/mxnkpt;mxnsppol=1
661 0 : call init_results_out(dtsets,2,0,mpi_enregs,mxnatom,mxnband,mxnkpt,mxnpsp,mxnsppol,mxntypat,results_out_all)
662 : end if
663 :
664 : ! Loop over results_out components (datasets)
665 0 : do ii=idt1,idt2
666 :
667 : ! Simple copy in case of 1 image
668 0 : if (dtsets(ii)%npimage<=1) then
669 0 : if (use_results_all) then
670 0 : call copy_results_out(results_out(ii),results_out_all(ii))
671 : end if
672 : else
673 :
674 : ! Retrieve MPI information for this dataset
675 :
676 0 : if ((.not.one_per_img).or.(mpi_enregs(ii)%me_cell==master_one_img)) then
677 :
678 : ! Gather number of images treated by each proc
679 0 : ABI_MALLOC(nimage_all,(mpi_enregs(ii)%nproc_img))
680 0 : nimage_all=0
681 0 : nimage=results_out(ii)%nimage
682 0 : call xmpi_allgather(nimage,nimage_all,mpi_enregs(ii)%comm_img,ierr)
683 0 : nimagetot=sum(nimage_all)
684 :
685 : ! Copy scalars from distributed results_out to gathered one
686 0 : if (use_results_all) then
687 0 : results_out_all(ii)%nimage=nimagetot
688 0 : results_out_all(ii)%natom =results_out(ii)%natom
689 0 : results_out_all(ii)%nkpt =results_out(ii)%nkpt
690 0 : results_out_all(ii)%nocc =results_out(ii)%nocc
691 0 : results_out_all(ii)%npsp =results_out(ii)%npsp
692 0 : results_out_all(ii)%ntypat=results_out(ii)%ntypat
693 : end if
694 :
695 : ! Compute number of integers/reals needed by current
696 : ! results_out structure for current proc
697 0 : isize=results_out(ii)%nkpt
698 0 : rsize=28+16*results_out(ii)%natom+results_out(ii)%nocc+results_out(ii)%npsp*results_out(ii)%ntypat+results_out(ii)%ntypat
699 0 : isize_img=results_out(ii)%nimage*isize
700 0 : rsize_img=results_out(ii)%nimage*rsize
701 0 : ABI_MALLOC(isize_img_all,(mpi_enregs(ii)%nproc_img))
702 0 : ABI_MALLOC(rsize_img_all,(mpi_enregs(ii)%nproc_img))
703 0 : isize_img_all(:)=isize*nimage_all(:)
704 0 : rsize_img_all(:)=rsize*nimage_all(:)
705 0 : ABI_FREE(nimage_all)
706 :
707 : ! Compute shifts in buffer arrays for each proc
708 0 : ABI_MALLOC(ibufshft,(mpi_enregs(ii)%nproc_img))
709 0 : ibufshft(1)=0
710 0 : ABI_MALLOC(rbufshft,(mpi_enregs(ii)%nproc_img))
711 0 : rbufshft(1)=0
712 0 : do jj=2,mpi_enregs(ii)%nproc_img
713 0 : ibufshft(jj)=ibufshft(jj-1)+isize_img_all(jj-1)
714 0 : rbufshft(jj)=rbufshft(jj-1)+rsize_img_all(jj-1)
715 : end do
716 :
717 : ! Load buffers
718 0 : ABI_MALLOC(ibuffer,(isize_img))
719 0 : ABI_MALLOC(rbuffer,(rsize_img))
720 0 : ibufi=0;ibufr=0
721 0 : natom_=results_out(ii)%natom
722 0 : nkpt_ =results_out(ii)%nkpt
723 0 : nocc_ =results_out(ii)%nocc
724 0 : npsp_ =results_out(ii)%npsp
725 0 : ntypat_ =results_out(ii)%ntypat
726 0 : do jj=1,results_out(ii)%nimage
727 0 : ibuffer(ibufi+1:ibufi+nkpt_)=results_out(ii)%npwtot(1:nkpt_,jj)
728 0 : ibufi=ibufi+nkpt_
729 0 : rbuffer(ibufr+1:ibufr+3)=results_out(ii)%acell(1:3,jj)
730 0 : ibufr=ibufr+3
731 0 : rbuffer(ibufr+1:ibufr+ntypat_)=results_out(ii)%amu(1:ntypat_,jj)
732 0 : ibufr=ibufr+ntypat_
733 0 : rbuffer(ibufr+1)=results_out(ii)%etotal(jj)
734 0 : ibufr=ibufr+1
735 0 : rbuffer(ibufr+1:ibufr+3*natom_)=reshape(results_out(ii)%fcart(1:3,1:natom_,jj),(/3*natom_/))
736 0 : ibufr=ibufr+3*natom_
737 0 : rbuffer(ibufr+1:ibufr+3*natom_)=reshape(results_out(ii)%gred(1:3,1:natom_,jj),(/3*natom_/))
738 0 : ibufr=ibufr+3*natom_
739 0 : rbuffer(ibufr+1:ibufr+4*natom_)=reshape(results_out(ii)%intgres(1:4,1:natom_,jj),(/4*natom_/))
740 0 : ibufr=ibufr+4*natom_
741 : rbuffer(ibufr+1:ibufr+npsp_*ntypat_)=&
742 0 : & reshape(results_out(ii)%mixalch(1:npsp_,1:ntypat_,jj),(/npsp_*ntypat_/) )
743 0 : ibufr=ibufr+npsp_*ntypat_
744 0 : rbuffer(ibufr+1:ibufr+nocc_)=results_out(ii)%occ(1:nocc_,jj)
745 0 : ibufr=ibufr+nocc_
746 0 : rbuffer(ibufr+1:ibufr+9)=reshape(results_out(ii)%rprim(1:3,1:3,jj),(/9/))
747 0 : ibufr=ibufr+9
748 0 : rbuffer(ibufr+1:ibufr+9)=reshape(results_out(ii)%vel_cell(1:3,1:3,jj),(/9/))
749 0 : ibufr=ibufr+9
750 0 : rbuffer(ibufr+1:ibufr+6)=results_out(ii)%strten(1:6,jj)
751 0 : ibufr=ibufr+6
752 0 : rbuffer(ibufr+1:ibufr+3*natom_)=reshape(results_out(ii)%vel(1:3,1:natom_,jj),(/3*natom_/))
753 0 : ibufr=ibufr+3*natom_
754 0 : rbuffer(ibufr+1:ibufr+3*natom_)=reshape(results_out(ii)%xred(1:3,1:natom_,jj),(/3*natom_/))
755 0 : ibufr=ibufr+3*natom_
756 : end do
757 0 : if (ibufi/=isize_img.or.ibufr/=rsize_img) then
758 0 : msg=' wrong buffer sizes !'
759 0 : ABI_BUG(msg)
760 : end if
761 :
762 : ! Gather all data
763 0 : if (use_results_all) then
764 0 : ABI_MALLOC(ibuffer_all,(isize*nimagetot))
765 0 : ABI_MALLOC(rbuffer_all,(rsize*nimagetot))
766 : end if
767 0 : if (.not.use_results_all) then
768 0 : ABI_MALLOC(ibuffer_all,(0))
769 0 : ABI_MALLOC(rbuffer_all,(0))
770 : end if
771 0 : if (do_allgather) then
772 : call xmpi_allgatherv(ibuffer,isize_img,ibuffer_all,isize_img_all,ibufshft,&
773 0 : & mpi_enregs(ii)%comm_img,ierr)
774 : call xmpi_allgatherv(rbuffer,rsize_img,rbuffer_all,rsize_img_all,rbufshft,&
775 0 : & mpi_enregs(ii)%comm_img,ierr)
776 : else
777 : call xmpi_gatherv(ibuffer,isize_img,ibuffer_all,isize_img_all,ibufshft,&
778 0 : & master_img,mpi_enregs(ii)%comm_img,ierr)
779 : call xmpi_gatherv(rbuffer,rsize_img,rbuffer_all,rsize_img_all,rbufshft,&
780 0 : & master_img,mpi_enregs(ii)%comm_img,ierr)
781 : end if
782 0 : ABI_FREE(isize_img_all)
783 0 : ABI_FREE(rsize_img_all)
784 0 : ABI_FREE(ibuffer)
785 0 : ABI_FREE(rbuffer)
786 :
787 : ! Transfer buffers into gathered results_out_all (master proc only)
788 0 : if (use_results_all) then
789 0 : ABI_MALLOC(iimg,(mpi_enregs(ii)%nproc_img))
790 0 : iimg=0
791 0 : natom_=results_out_all(ii)%natom
792 0 : nkpt_=results_out_all(ii)%nkpt
793 0 : nocc_=results_out_all(ii)%nocc
794 0 : npsp_ =results_out_all(ii)%npsp
795 0 : ntypat_ =results_out_all(ii)%ntypat
796 0 : do jj=1,nimagetot
797 : ! The following line supposes that images are sorted by increasing index
798 0 : iproc=mpi_enregs(ii)%distrb_img(jj)+1;iimg(iproc)=iimg(iproc)+1
799 0 : ibufi=ibufshft(iproc)+(iimg(iproc)-1)*isize
800 0 : ibufr=rbufshft(iproc)+(iimg(iproc)-1)*rsize
801 0 : results_out_all(ii)%npwtot(1:nkpt_,jj)=ibuffer_all(ibufi+1:ibufi+nkpt_)
802 0 : ibufi=ibufi+nkpt_
803 0 : results_out_all(ii)%acell(1:3,jj)=rbuffer_all(ibufr+1:ibufr+3)
804 0 : ibufr=ibufr+3
805 0 : results_out_all(ii)%amu(1:ntypat_,jj)=rbuffer_all(ibufr+1:ibufr+ntypat_)
806 0 : ibufr=ibufr+ntypat_
807 0 : results_out_all(ii)%etotal(jj)=rbuffer_all(ibufr+1)
808 0 : ibufr=ibufr+1
809 : results_out_all(ii)%fcart(1:3,1:natom_,jj)= &
810 0 : & reshape(rbuffer_all(ibufr+1:ibufr+3*natom_),(/3,natom_/))
811 0 : ibufr=ibufr+3*natom_
812 : results_out_all(ii)%gred(1:3,1:natom_,jj)= &
813 0 : & reshape(rbuffer_all(ibufr+1:ibufr+3*natom_),(/3,natom_/))
814 0 : ibufr=ibufr+3*natom_
815 : results_out_all(ii)%intgres(1:4,1:natom_,jj)= &
816 0 : & reshape(rbuffer_all(ibufr+1:ibufr+4*natom_),(/4,natom_/))
817 0 : ibufr=ibufr+4*natom_
818 : results_out_all(ii)%mixalch(1:npsp_,1:ntypat_,jj)= &
819 0 : & reshape(rbuffer_all(ibufr+1:ibufr+npsp_*ntypat_),(/npsp_,ntypat_/))
820 0 : ibufr=ibufr+npsp_*ntypat_
821 0 : results_out_all(ii)%occ(1:nocc_,jj)=rbuffer_all(ibufr+1:ibufr+nocc_)
822 0 : ibufr=ibufr+nocc_
823 0 : results_out_all(ii)%rprim(1:3,1:3,jj)=reshape(rbuffer_all(ibufr+1:ibufr+9),(/3,3/))
824 0 : ibufr=ibufr+9
825 0 : results_out_all(ii)%vel_cell(1:3,1:3,jj)=reshape(rbuffer_all(ibufr+1:ibufr+9),(/3,3/))
826 0 : ibufr=ibufr+9
827 0 : results_out_all(ii)%strten(1:6,jj)=rbuffer_all(ibufr+1:ibufr+6)
828 0 : ibufr=ibufr+6
829 : results_out_all(ii)%vel(1:3,1:natom_,jj)= &
830 0 : & reshape(rbuffer_all(ibufr+1:ibufr+3*natom_),(/3,natom_/))
831 0 : ibufr=ibufr+3*natom_
832 : results_out_all(ii)%xred(1:3,1:natom_,jj)= &
833 0 : & reshape(rbuffer_all(ibufr+1:ibufr+3*natom_),(/3,natom_/))
834 0 : ibufr=ibufr+3*natom_
835 : end do
836 0 : ABI_FREE(iimg)
837 : end if
838 :
839 : ! Free memory
840 0 : ABI_FREE(ibufshft)
841 0 : ABI_FREE(rbufshft)
842 0 : ABI_FREE(ibuffer_all)
843 0 : ABI_FREE(rbuffer_all)
844 :
845 : end if
846 : end if
847 : end do
848 : end if
849 :
850 0 : end subroutine gather_results_out
851 : !!***
852 :
853 0 : END MODULE m_results_out
854 : !!***
|
