1!{\src2tex{textfont=tt}} 2!!****m* ABINIT/m_xmpi 3!! NAME 4!! m_xmpi 5!! 6!! FUNCTION 7!! This module provides MPI named constants, tools for inquiring the MPI environment 8!! and a set of generic interfaces wrapping the most commonly used MPI primitives. 9!! 10!! COPYRIGHT 11!! Copyright (C) 2009-2016 ABINIT group (MG, MB, XG, YP, MT) 12!! This file is distributed under the terms of the 13!! GNU General Public License, see ~abinit/COPYING 14!! or http://www.gnu.org/copyleft/gpl.txt . 15!! 16!! PARENTS 17!! 18!! TODO 19!! Get rid of xmpi_paral. Sequential code is the **exception**. Developers should code parallel 20!! code or code that is compatible both with MPI and seq (thanks to the wrappers provided by this module) 21!! 22!! SOURCE 23 24#if defined HAVE_CONFIG_H 25#include "config.h" 26#endif 27 28#include "abi_common.h" 29 30MODULE m_xmpi 31 32 use defs_basis 33 use m_profiling_abi 34#ifdef HAVE_FC_ISO_FORTRAN_2008 35 use ISO_FORTRAN_ENV, only : int16,int32,int64 36#endif 37#ifdef HAVE_MPI2 38 use mpi 39#endif 40#ifdef FC_NAG 41 use f90_unix_proc 42#endif 43 44 implicit none 45 46 private 47!!*** 48 49#ifdef HAVE_MPI1 50 include 'mpif.h' 51#endif 52#ifndef HAVE_FC_ISO_FORTRAN_2008 53 integer,parameter :: int16=2,int32=4,int64=8 54#endif 55 56#ifdef HAVE_MPI 57 ! MPI constants used in abinit. Make sure that a corresponding fake value is provided for the sequential version. 58 integer,public,parameter :: xmpi_world = MPI_COMM_WORLD 59 integer,public,parameter :: xmpi_comm_self = MPI_COMM_SELF 60 integer,public,parameter :: xmpi_undefined = MPI_UNDEFINED 61 integer,public,parameter :: xmpi_undefined_rank = MPI_UNDEFINED ! MPI_UNDEFINED_RANK is not portable. 62 integer,public,parameter :: xmpi_comm_null = MPI_COMM_NULL 63 integer,public,parameter :: xmpi_group_null = MPI_GROUP_NULL 64 integer,public,parameter :: xmpi_any_source = MPI_ANY_SOURCE 65 integer,public,parameter :: xmpi_request_null = MPI_REQUEST_NULL 66 integer,public,parameter :: xmpi_msg_len = MPI_MAX_ERROR_STRING ! Length of fortran string used to store MPI error strings. 67 integer,public,parameter :: xmpi_paral = 1 68 integer,public,parameter :: xmpi_info_null = MPI_INFO_NULL 69#else 70 ! Fake replacements for the sequential version. 71 integer,public,parameter :: xmpi_world = 0 72 integer,public,parameter :: xmpi_comm_self = 0 73 integer,public,parameter :: xmpi_undefined =-32765 74 integer,public,parameter :: xmpi_undefined_rank =-32766 75 integer,public,parameter :: xmpi_comm_null = 0 76 integer,public,parameter :: xmpi_group_null = 0 77 integer,public,parameter :: xmpi_any_source = 0 78 integer,public,parameter :: xmpi_request_null = 738197504 79 integer,public,parameter :: xmpi_msg_len = 1000 80 integer,public,parameter :: xmpi_paral = 0 81 integer,public,parameter :: xmpi_info_null = 0 82#endif 83 84 integer,save,private :: xmpi_tag_ub=32767 85 ! The tag upper bound value must be at least 32767. An MPI implementation is free to make 86 ! the value of MPI_TAG_UB larger than this hence xmpi_tag_ub is redefined when MPI is init in xmpi_init. 87 88 ! Size in bytes of the entries used in MPI datatypes. 89 integer,save, public ABI_PROTECTED:: xmpi_bsize_ch =0 90 integer,save, public ABI_PROTECTED:: xmpi_bsize_int=0 91 integer,save, public ABI_PROTECTED:: xmpi_bsize_sp =0 92 integer,save, public ABI_PROTECTED:: xmpi_bsize_dp =0 93 integer,save, public ABI_PROTECTED:: xmpi_bsize_spc=0 94 integer,save, public ABI_PROTECTED:: xmpi_bsize_dpc=0 95 96 ! kind of the offset used for MPI-IO. 97#ifdef HAVE_MPI_IO 98 integer,public,parameter :: xmpi_offset_kind =MPI_OFFSET_KIND 99 integer,public,parameter :: xmpi_address_kind=MPI_ADDRESS_KIND 100 integer,public,parameter :: xmpi_mpiio=1 101#else 102 integer,public,parameter :: xmpi_offset_kind=i8b 103 integer,public,parameter :: xmpi_address_kind=i8b 104 integer,public,parameter :: xmpi_mpiio=0 105#endif 106 107 ! The byte size and the MPI type of the Fortran record marker. 108 ! These quantities are compiler-dependent and are initalized here 109 ! for selected compilers or in xmpio_get_info_frm that is called by xmpi_init (only if MPI-IO is on). 110#if defined HAVE_MPI && (defined FC_INTEL || defined FC_GNU || defined FC_IBM) 111 integer,save,public ABI_PROTECTED :: xmpio_bsize_frm =4 112 integer,save,public ABI_PROTECTED :: xmpio_mpi_type_frm=MPI_INTEGER4 113#else 114 integer,save,public ABI_PROTECTED :: xmpio_bsize_frm =0 115 integer,save,public ABI_PROTECTED :: xmpio_mpi_type_frm=0 116#endif 117 118 integer,save, public ABI_PROTECTED :: xmpio_info = xmpi_info_null 119 ! Global variable used to pass hints to the MPI-IO routines. 120 121 integer(XMPI_OFFSET_KIND),public,parameter :: xmpio_chunk_bsize = 2000 * (1024.0_dp**2) 122 ! Defines the chunk size (in bytes) used to (read|write) data in a single MPI-IO call. 123 ! MPI-IO, indeed, crashes if we try to do the IO of a large array with a single call. 124 ! We use a value <= 2 Gb to avoid wraparound errors with standard integers. 125 126 ! Options used for the MPI-IO wrappers used in abinit. 127 integer,public,parameter :: xmpio_single =1 ! Individual IO. 128 integer,public,parameter :: xmpio_collective=2 ! Collective IO. 129 130!---------------------------------------------------------------------- 131!!*** 132 133! Public procedures. 134 public :: xmpi_init ! Initialize the MPI environment. 135 public :: xmpi_end ! Terminate the MPI environment. 136 public :: xmpi_abort ! Hides MPI_ABORT from MPI library. 137 public :: xmpi_show_info ! Printout of the basic variables stored in this module (useful for debugging). 138 public :: xmpi_group_free ! Hides MPI_GROUP_FREE from MPI library. 139 public :: xmpi_group_incl ! Hides MPI_GROUP_INCL from MPI library. 140 public :: xmpi_group_translate_ranks ! Hides MPI_GROUP_TRANSLATE_RANKS from MPI library. 141 public :: xmpi_comm_create ! Hides MPI_COMM_CREATE from MPI library. 142 public :: xmpi_comm_rank ! Hides MPI_COMM_RANK from MPI library. 143 public :: xmpi_comm_size ! Hides MPI_COMM_SIZE from MPI library. 144 public :: xmpi_comm_free ! Hides MPI_COMM_FREE from MPI library. 145 public :: xmpi_comm_group ! Hides MPI_COMM_GROUP from MPI library. 146 public :: xmpi_comm_translate_ranks ! Hides MPI_GROUP_TRANSLATE_RANKS from MPI library. 147 public :: xmpi_comm_split ! Hides MPI_COMM_SPLIT from MPI library. 148 public :: xmpi_subcomm ! Creates a sub-communicator from an input communicator. 149 public :: xmpi_barrier ! Hides MPI_BARRIER from MPI library. 150 public :: xmpi_name ! Hides MPI_NAME from MPI library. 151 public :: xmpi_iprobe ! Hides MPI_IPROBE from MPI library. 152 public :: xmpi_wait ! Hides MPI_WAIT from MPI library. 153 public :: xmpi_waitall ! Hides MPI_WAITALL from MPI library. 154 public :: xmpi_request_free ! Hides MPI_REQUEST_FREE from MPI library. 155 public :: xmpi_comm_set_errhandler ! Hides MPI_COMM_SET_ERRHANDLER from MPI library. 156 public :: xmpi_error_string ! Return a string describing the error from ierr. 157 public :: xmpi_split_work 158 public :: xmpi_distab 159 public :: xmpi_distrib_with_replicas ! Distribute tasks among MPI ranks (replicas are allowed) 160 161 interface xmpi_comm_free 162 module procedure xmpi_comm_free_0D 163 module procedure xmpi_comm_free_1D 164 module procedure xmpi_comm_free_2D 165 module procedure xmpi_comm_free_3D 166 end interface xmpi_comm_free 167 168 interface xmpi_split_work 169 module procedure xmpi_split_work_i4b 170 end interface xmpi_split_work 171 172 public :: xmpi_split_work2_i4b 173 public :: xmpi_split_work2_i8b 174 !public :: xmpi_split_work2 175 ! 176 ! g95@green v0.93 is not able to resolve the interface. 177 ! For the time being, this generic interface has been disabled. 178 !interface xmpi_split_work2 179 ! module procedure xmpi_split_work2_i4b 180 ! module procedure xmpi_split_work2_i8b 181 !end interface xmpi_split_work2 182 183 interface xmpi_distab 184 module procedure xmpi_distab_4D 185 end interface xmpi_distab 186 187!MPI generic interfaces. 188 public :: xmpi_allgather 189 public :: xmpi_allgatherv 190 public :: xmpi_alltoall 191 public :: xmpi_ialltoall 192 public :: xmpi_alltoallv 193 public :: xmpi_ialltoallv 194 public :: xmpi_bcast 195 public :: xmpi_exch 196 public :: xmpi_gather 197 public :: xmpi_gatherv 198 public :: xmpi_max 199 public :: xmpi_min 200 public :: xmpi_recv 201 public :: xmpi_irecv 202 public :: xmpi_scatterv 203 public :: xmpi_send 204 public :: xmpi_isend 205 public :: xmpi_sum_master 206 public :: xmpi_sum 207 public :: xmpi_isum 208 public :: xmpi_land ! allreduce with MPI_LAND 209 public :: xmpi_lor ! allreduce with MPI_LOR 210 211#ifdef HAVE_MPI_IO 212 public :: xmpio_max_address ! Returns .TRUE. if offset cannot be stored in integer(kind=XMPI_ADDRESS_KIND). 213 public :: xmpio_type_struct 214 public :: xmpio_get_info_frm 215 public :: xmpio_check_frmarkers 216 public :: xmpio_read_frm 217 public :: xmpio_read_int 218 public :: xmpio_read_dp 219 public :: xmpio_write_frm 220 public :: xmpio_write_frmarkers 221 222 public :: xmpio_create_fstripes 223 public :: xmpio_create_fsubarray_2D 224 public :: xmpio_create_fsubarray_3D 225 public :: xmpio_create_fsubarray_4D 226 public :: xmpio_create_fherm_packed 227 public :: xmpio_create_coldistr_from_fpacked 228 public :: xmpio_create_coldistr_from_fp3blocks 229 230!interface xmpio_read 231! module procedure xmpio_read_int 232! module procedure xmpio_read_dp 233!end interface xmpio_read 234! 235!interface xmpio_write 236! module procedure xmpio_write_int 237! module procedure xmpio_write_dp 238!end interface xmpio_write 239#endif 240 241!---------------------------------------------------------------------- 242 243interface xmpi_allgather 244 module procedure xmpi_allgather_int 245 module procedure xmpi_allgather_char 246 module procedure xmpi_allgather_int1d 247 module procedure xmpi_allgather_dp1d 248 module procedure xmpi_allgather_dp2d 249 module procedure xmpi_allgather_dp3d 250 module procedure xmpi_allgather_dp4d 251end interface xmpi_allgather 252 253!---------------------------------------------------------------------- 254 255interface xmpi_allgatherv 256 module procedure xmpi_allgatherv_int2d 257 module procedure xmpi_allgatherv_int 258 module procedure xmpi_allgatherv_int1_dp1 259 module procedure xmpi_allgatherv_dp 260 module procedure xmpi_allgatherv_dp2d 261 module procedure xmpi_allgatherv_dp3d 262 module procedure xmpi_allgatherv_dp4d 263 module procedure xmpi_allgatherv_coeff2d 264 module procedure xmpi_allgatherv_coeff2d_indx 265end interface xmpi_allgatherv 266 267!---------------------------------------------------------------------- 268 269! blocking 270interface xmpi_alltoall 271 module procedure xmpi_alltoall_int 272 module procedure xmpi_alltoall_dp2d 273 module procedure xmpi_alltoall_dp4d 274end interface xmpi_alltoall 275 276! non-blocking version (requires MPI3) 277! Prototype: 278! 279! call xmpi_ialltoall(xval, sendsize, recvbuf, recvsize, comm, request) 280! 281! If the MPI library does not provide ialltoall, we call the blocking version and 282! we return xmpi_request_null (see xmpi_ialltoall.finc) 283! Client code should always test/wait the request so that code semantics is preserved. 284 285interface xmpi_ialltoall 286 module procedure xmpi_ialltoall_dp4d 287end interface xmpi_ialltoall 288 289!---------------------------------------------------------------------- 290 291interface xmpi_alltoallv 292 module procedure xmpi_alltoallv_dp2d 293 module procedure xmpi_alltoallv_int2d 294 module procedure xmpi_alltoallv_dp1d 295 module procedure xmpi_alltoallv_dp1d2 296end interface xmpi_alltoallv 297 298!---------------------------------------------------------------------- 299 300! non-blocking version (requires MPI3) 301! Prototype: 302! 303! call xmpi_ialltoallv(xval,sendcnts,sdispls,recvbuf,recvcnts,rdispls,comm,request) 304! 305! If the MPI library does not provide ialltoallv, we call the blocking version and 306! we return xmpi_request_null (see xmpi_ialltoallv.finc) 307! Client code should always test/wait the request so that code semantics is preserved. 308 309interface xmpi_ialltoallv 310 module procedure xmpi_ialltoallv_dp2d 311 module procedure xmpi_ialltoallv_int2d 312 module procedure xmpi_ialltoallv_dp1d2 313end interface xmpi_ialltoallv 314 315!---------------------------------------------------------------------- 316 317interface xmpi_bcast 318 module procedure xmpi_bcast_intv 319 module procedure xmpi_bcast_int1d 320 module procedure xmpi_bcast_int2d 321 module procedure xmpi_bcast_int3d 322 module procedure xmpi_bcast_dpv 323 module procedure xmpi_bcast_dp1d 324 module procedure xmpi_bcast_dp2d 325 module procedure xmpi_bcast_dp3d 326 module procedure xmpi_bcast_dp4d 327 module procedure xmpi_bcast_spv 328 module procedure xmpi_bcast_sp1d 329 module procedure xmpi_bcast_sp2d 330 module procedure xmpi_bcast_sp3d 331 module procedure xmpi_bcast_sp4d 332 module procedure xmpi_bcast_cplxv 333 module procedure xmpi_bcast_cplx1d 334 module procedure xmpi_bcast_cplx2d 335 module procedure xmpi_bcast_cplx3d 336 module procedure xmpi_bcast_cplx4d 337 module procedure xmpi_bcast_dcv 338 module procedure xmpi_bcast_dc1d 339 module procedure xmpi_bcast_dc2d 340 module procedure xmpi_bcast_dc3d 341 module procedure xmpi_bcast_dc4d 342 module procedure xmpi_bcast_ch0d 343 module procedure xmpi_bcast_ch1d 344 module procedure xmpi_bcast_log0d 345 module procedure xmpi_bcast_coeffi2_1d 346 module procedure xmpi_bcast_coeff2_1d 347end interface xmpi_bcast 348 349!---------------------------------------------------------------------- 350 351interface xmpi_exch 352 module procedure xmpi_exch_intn 353 module procedure xmpi_exch_int2d 354 module procedure xmpi_exch_dpn 355 module procedure xmpi_exch_dp2d 356 module procedure xmpi_exch_dp3d 357 module procedure xmpi_exch_dp4d_tag 358 module procedure xmpi_exch_dp5d_tag 359 module procedure xmpi_exch_spc_1d 360 module procedure xmpi_exch_dpc_1d 361 module procedure xmpi_exch_dpc_2d 362end interface xmpi_exch 363 364!---------------------------------------------------------------------- 365 366interface xmpi_gather 367 module procedure xmpi_gather_int 368 module procedure xmpi_gather_int2d 369 module procedure xmpi_gather_dp 370 module procedure xmpi_gather_dp2d 371 module procedure xmpi_gather_dp3d 372 module procedure xmpi_gather_dp4d 373end interface xmpi_gather 374 375!---------------------------------------------------------------------- 376 377interface xmpi_gatherv 378 module procedure xmpi_gatherv_int 379 module procedure xmpi_gatherv_int1_dp1 380 module procedure xmpi_gatherv_int2d 381 module procedure xmpi_gatherv_dp 382 module procedure xmpi_gatherv_dp2d 383 module procedure xmpi_gatherv_dp3d 384 module procedure xmpi_gatherv_dp4d 385end interface xmpi_gatherv 386 387!---------------------------------------------------------------------- 388 389interface xmpi_max 390 module procedure xmpi_max_int0d_i4b 391 module procedure xmpi_max_int0d_i8b 392 module procedure xmpi_max_int 393 module procedure xmpi_max_dpv 394 module procedure xmpi_max_dp0d_ip 395end interface xmpi_max 396 397!---------------------------------------------------------------------- 398 399interface xmpi_min 400 module procedure xmpi_min_intv 401 module procedure xmpi_min_dpv 402end interface xmpi_min 403 404!---------------------------------------------------------------------- 405 406!interface xmpi_min_max 407! module procedure xmpi_min_max_int0d_i4b 408!end interface xmpi_min_max 409 410!---------------------------------------------------------------------- 411 412interface xmpi_recv 413 module procedure xmpi_recv_intv 414 module procedure xmpi_recv_int1d 415 module procedure xmpi_recv_int2d 416 module procedure xmpi_recv_dp1d 417 module procedure xmpi_recv_dp2d 418 module procedure xmpi_recv_dp3d 419end interface xmpi_recv 420 421!---------------------------------------------------------------------- 422 423interface xmpi_irecv 424 module procedure xmpi_irecv_intv 425 module procedure xmpi_irecv_int1d 426 module procedure xmpi_irecv_dp1d 427end interface xmpi_irecv 428 429!---------------------------------------------------------------------- 430 431interface xmpi_scatterv 432 module procedure xmpi_scatterv_int 433 module procedure xmpi_scatterv_int2d 434 module procedure xmpi_scatterv_dp 435 module procedure xmpi_scatterv_dp2d 436 module procedure xmpi_scatterv_dp3d 437 module procedure xmpi_scatterv_dp4d 438end interface xmpi_scatterv 439 440!---------------------------------------------------------------------- 441 442interface xmpi_isend 443 module procedure xmpi_isend_int1d 444 module procedure xmpi_isend_dp1d 445end interface xmpi_isend 446 447!---------------------------------------------------------------------- 448 449interface xmpi_send 450 module procedure xmpi_send_intv 451 module procedure xmpi_send_int1d 452 module procedure xmpi_send_int2d 453 module procedure xmpi_send_dp1d 454 module procedure xmpi_send_dp2d 455 module procedure xmpi_send_dp3d 456end interface xmpi_send 457 458!---------------------------------------------------------------------- 459 460interface xmpi_sum_master 461 module procedure xmpi_sum_master_int 462 module procedure xmpi_sum_master_int2d 463 module procedure xmpi_sum_master_int4d 464 module procedure xmpi_sum_master_dp1d 465 module procedure xmpi_sum_master_dp2d 466 module procedure xmpi_sum_master_dp3d 467 module procedure xmpi_sum_master_dp4d 468 module procedure xmpi_sum_master_dp5d 469 module procedure xmpi_sum_master_dp6d 470 module procedure xmpi_sum_master_dp7d 471 module procedure xmpi_sum_master_c1cplx 472 module procedure xmpi_sum_master_c2cplx 473 module procedure xmpi_sum_master_c3cplx 474 module procedure xmpi_sum_master_c4cplx 475 module procedure xmpi_sum_master_c5cplx 476 module procedure xmpi_sum_master_c1dpc 477 module procedure xmpi_sum_master_c2dpc 478 module procedure xmpi_sum_master_c3dpc 479 module procedure xmpi_sum_master_c4dpc 480 module procedure xmpi_sum_master_c5dpc 481end interface xmpi_sum_master 482 483!---------------------------------------------------------------------- 484 485!MG:TODO procedure marked with !? are considered obsolete. 486! and will be removed in future versions. 487! Please use interfaces where array dimensions are not passed explicitly. 488! Rationale: The array descriptor is already passed to the routine 489! so it does not make sense to pass the dimension explicitly. 490 491interface xmpi_sum 492 module procedure xmpi_sum_int 493 module procedure xmpi_sum_intv 494 module procedure xmpi_sum_intv2 495 module procedure xmpi_sum_intn !? 496 module procedure xmpi_sum_int2t !? 497 module procedure xmpi_sum_int2d 498 module procedure xmpi_sum_int3d 499 module procedure xmpi_sum_int4d 500 module procedure xmpi_sum_dp 501 module procedure xmpi_sum_dpvt 502 module procedure xmpi_sum_dpv 503 module procedure xmpi_sum_dpn !? 504 module procedure xmpi_sum_dp2d 505 module procedure xmpi_sum_dp3d 506 module procedure xmpi_sum_dp4d 507 module procedure xmpi_sum_dp5d 508 module procedure xmpi_sum_dp6d 509 module procedure xmpi_sum_dp7d 510 module procedure xmpi_sum_dp2t !? 511 module procedure xmpi_sum_dp2d2t 512 module procedure xmpi_sum_dp3d2t !? 513 module procedure xmpi_sum_dp4d2t !? 514 module procedure xmpi_sum_c0dc 515 module procedure xmpi_sum_c1dc 516 module procedure xmpi_sum_c2dc 517 module procedure xmpi_sum_c3dc 518 module procedure xmpi_sum_c4dc 519 module procedure xmpi_sum_c5dc 520 module procedure xmpi_sum_c6dc 521 module procedure xmpi_sum_c7dc 522 module procedure xmpi_sum_c1cplx 523 module procedure xmpi_sum_c2cplx 524 module procedure xmpi_sum_c3cplx 525 module procedure xmpi_sum_c4cplx 526 module procedure xmpi_sum_c5cplx 527 module procedure xmpi_sum_c6cplx 528end interface xmpi_sum 529!!*** 530 531interface xmpi_isum 532 module procedure xmpi_isum_int0d 533end interface xmpi_isum 534!!*** 535 536 537interface xmpi_land 538 module procedure xmpi_land_log0d 539end interface xmpi_land 540!!*** 541 542interface xmpi_lor 543 module procedure xmpi_lor_log1d 544 module procedure xmpi_lor_log2d 545 module procedure xmpi_lor_log3d 546end interface xmpi_lor 547!!!*** 548 549 550!---------------------------------------------------------------------- 551 552CONTAINS !=========================================================== 553!!*** 554 555!!****f* m_xmpi/xmpi_init 556!! NAME 557!! xmpi_init 558!! 559!! FUNCTION 560!! Hides MPI_INIT from MPI library. Perform the initialization of some basic variables 561!! used by the MPI routines employed in abinit. 562!! 563!! INPUTS 564!! None 565!! 566!! PARENTS 567!! abinit,aim,anaddb,band2eps,bsepostproc,conducti,cut3d,fftprof 568!! fold2Bloch,ioprof,lapackprof,macroave,mrgddb,mrgdv,mrggkk,mrgscr,optic 569!! ujdet,vdw_kernelgen 570!! 571!! CHILDREN 572!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 573!! 574!! SOURCE 575 576subroutine xmpi_init() 577 578 579!This section has been created automatically by the script Abilint (TD). 580!Do not modify the following lines by hand. 581#undef ABI_FUNC 582#define ABI_FUNC 'xmpi_init' 583!End of the abilint section 584 585 implicit none 586 587!Local variables------------------- 588 integer :: mpierr,ierr,unt 589 logical :: exists,isopen 590#ifdef HAVE_MPI 591 integer :: attribute_val,required,provided 592 logical :: lflag 593#endif 594 595! ************************************************************************* 596 597 mpierr=0 598#ifdef HAVE_MPI 599 600#ifndef HAVE_OPENMP 601 call MPI_INIT(mpierr) 602#else 603 required = MPI_THREAD_SINGLE 604 !required = MPI_THREAD_FUNNELED 605 !required = MPI_THREAD_SERIALIZED 606 !required = MPI_THREAD_MULTIPLE 607 call MPI_INIT_THREAD(required,provided,mpierr) 608 if (provided /= required) then 609 call xmpi_abort(msg="MPI_INIT_THREADS: provided /= required") 610 end if 611#endif 612 613 !%comm_world = xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout)) 614 !%call xmpi_comm_set_errhandler(comm_world, MPI_ERRORS_RETURN, err_handler_sav, mpierr) 615 616 ! Deprecated in MPI2 but not all MPI2 implementations provide MPI_Comm_get_attr ! 617 call MPI_ATTR_GET(xmpi_world, MPI_TAG_UB, attribute_val, lflag, mpierr) 618 !call MPI_Comm_get_attr(xmpi_world, MPI_TAG_UB, attribute_val, lflag, mpierr) 619 620 if (lflag) xmpi_tag_ub = attribute_val 621 622! Define type values. 623 call MPI_TYPE_SIZE(MPI_CHARACTER,xmpi_bsize_ch,mpierr) 624 call MPI_TYPE_SIZE(MPI_INTEGER,xmpi_bsize_int,mpierr) 625 call MPI_TYPE_SIZE(MPI_REAL,xmpi_bsize_sp,mpierr) 626 call MPI_TYPE_SIZE(MPI_DOUBLE_PRECISION,xmpi_bsize_dp,mpierr) 627 call MPI_TYPE_SIZE(MPI_COMPLEX,xmpi_bsize_spc,mpierr) 628 call MPI_TYPE_SIZE(MPI_DOUBLE_COMPLEX,xmpi_bsize_dpc,mpierr) 629 630 ! Find the byte size of Fortran record marker used in MPI-IO routines. 631 if (xmpio_bsize_frm == 0) then 632 call xmpio_get_info_frm(xmpio_bsize_frm, xmpio_mpi_type_frm, xmpi_world) 633 end if 634#endif 635 636 ! Master Removes the ABI_MPIABORTFILE if present so that we start with a clean environment 637 if (xmpi_comm_rank(xmpi_world) == 0) then 638 inquire(file=ABI_MPIABORTFILE, exist=exists) 639 if (exists) then 640 ! Get free unit (emulate F2008 newunit for portability reasons) 641 unt = xmpi_get_unit() 642 if (unt == -1) call xmpi_abort(msg="Cannot find free unit!!") 643 open(unit=unt, file=trim(ABI_MPIABORTFILE), status="old", iostat=ierr) 644 if (ierr == 0) close(unit=unt, status="delete", iostat=ierr) 645 if (ierr /= 0) call xmpi_abort(msg="Cannot remove ABI_MPIABORTFILE") 646 end if 647 end if 648 649end subroutine xmpi_init 650!!*** 651 652!---------------------------------------------------------------------- 653 654!!****f* m_xmpi/xmpi_get_unit 655!! NAME 656!! xmpi_get_unit 657!! 658!! FUNCTION 659!! Get free unit (emulate F2008 newunit for portability reasons) 660!! Return -1 if no unit is found. 661!! 662!! PARENTS 663!! 664!! CHILDREN 665!! 666!! SOURCE 667 668integer function xmpi_get_unit() result(unt) 669 670 671!This section has been created automatically by the script Abilint (TD). 672!Do not modify the following lines by hand. 673#undef ABI_FUNC 674#define ABI_FUNC 'xmpi_get_unit' 675!End of the abilint section 676 677 implicit none 678 679!Local variables------------------- 680 logical :: isopen 681 682! ************************************************************************* 683 684 do unt=1024,-1,-1 685 inquire(unit=unt, opened=isopen) 686 if (.not.isopen) exit 687 end do 688 689end function xmpi_get_unit 690!!*** 691 692!---------------------------------------------------------------------- 693 694!!****f* m_xmpi/xmpi_end 695!! NAME 696!! xmpi_end 697!! 698!! FUNCTION 699!! Hides MPI_FINALIZE from MPI library. 700!! 701!! INPUTS 702!! None 703!! 704!! PARENTS 705!! aim,anaddb,band2eps,bsepostproc,conducti,cut3d,fold2Bloch,lapackprof 706!! macroave,mrgddb,mrggkk,optic,ujdet,vdw_kernelgen 707!! 708!! CHILDREN 709!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 710!! 711!! SOURCE 712 713subroutine xmpi_end() 714 715 716!This section has been created automatically by the script Abilint (TD). 717!Do not modify the following lines by hand. 718#undef ABI_FUNC 719#define ABI_FUNC 'xmpi_end' 720!End of the abilint section 721 722 implicit none 723 724!Local variables------------------- 725 integer :: mpierr 726 727! ************************************************************************* 728 729 mpierr=0 730#ifdef HAVE_MPI 731 call MPI_BARRIER(MPI_COMM_WORLD,mpierr) ! Needed by some HPC architectures (MT, 20110315) 732 call MPI_FINALIZE(mpierr) 733#endif 734 735end subroutine xmpi_end 736!!*** 737 738!---------------------------------------------------------------------- 739 740!!****f* m_xmpi/xmpi_abort 741!! NAME 742!! xmpi_abort 743!! 744!! FUNCTION 745!! Hides MPI_ABORT from MPI library. 746!! 747!! INPUTS 748!! [comm]=communicator of tasks to abort. 749!! [mpierr]=Error code to return to invoking environment. 750!! [msg]=User message 751!! [exit_status]=optional, shell return code, default 1 752!! 753!! PARENTS 754!! initmpi_grid,leave_new,m_initcuda,m_libpaw_tools,m_xmpi,testkgrid 755!! 756!! CHILDREN 757!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 758!! 759!! SOURCE 760 761subroutine xmpi_abort(comm,mpierr,msg,exit_status) 762 763 764!This section has been created automatically by the script Abilint (TD). 765!Do not modify the following lines by hand. 766#undef ABI_FUNC 767#define ABI_FUNC 'xmpi_abort' 768!End of the abilint section 769 770 implicit none 771 772!Arguments------------------------- 773 integer,optional,intent(in) :: comm,mpierr,exit_status 774 character(len=*),optional,intent(in) :: msg 775 776!Local variables------------------- 777 integer :: ierr,my_comm,my_errorcode,ilen,ierr2 778 logical :: testopen 779 character(len=xmpi_msg_len) :: mpi_msg_error 780 781! ************************************************************************* 782 783 ierr=0 784 my_comm = xmpi_world; if (PRESENT(comm)) my_comm = comm 785 786 if (PRESENT(msg)) then 787 write(std_out,'(2a)')"User message: ",TRIM(msg) 788 end if 789 790 ! Close std_out and ab_out 791 inquire(std_out,opened=testopen) 792 if (testopen) close(std_out) 793 794 inquire(ab_out,opened=testopen) 795 if (testopen) close(ab_out) 796 797#ifdef HAVE_MPI 798 my_errorcode=MPI_ERR_UNKNOWN; if (PRESENT(mpierr)) my_errorcode=mpierr 799 800 call MPI_ERROR_STRING(my_errorcode, mpi_msg_error, ilen, ierr2) 801 802 !if (ilen>xmpi_msg_len) write(std_out,*)" WARNING: MPI message has been truncated!" 803 !if (ierr2/=MPI_SUCCESS) then 804 ! write(std_out,'(a,i0)')" WARNING: MPI_ERROR_STRING returned ierr2= ",ierr2 805 !else 806 ! write(std_out,'(2a)')" MPI_ERROR_STRING: ",TRIM(mpi_msg_error) 807 !end if 808 809 call MPI_ABORT(my_comm,my_errorcode,ierr) 810#endif 811 812 if (present(exit_status)) then 813 call sys_exit(exit_status) 814 else 815 call sys_exit(1) 816 end if 817 818end subroutine xmpi_abort 819!!*** 820 821!---------------------------------------------------------------------- 822 823!!****f* m_xmpi/sys_exit 824!! NAME 825!! sys_exit 826!! 827!! FUNCTION 828!! Routine for clean exit of f90 code by one processor 829!! 830!! INPUTS 831!! exit_status: 832!! return code. 833!! 834!! NOTES 835!! By default, it uses "call exit(1)", that is not completely portable. 836!! 837!! PARENTS 838!! m_xmpi 839!! 840!! CHILDREN 841!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 842!! 843!! SOURCE 844 845subroutine sys_exit(exit_status) 846 847 848!This section has been created automatically by the script Abilint (TD). 849!Do not modify the following lines by hand. 850#undef ABI_FUNC 851#define ABI_FUNC 'sys_exit' 852!End of the abilint section 853 854 implicit none 855 856!Arguments ------------------------------------ 857!scalars 858 integer,intent(in) :: exit_status 859 860! ********************************************************************** 861 862#if defined FC_NAG 863 call exit(exit_status) 864#elif defined HAVE_FC_EXIT 865 call exit(exit_status) 866#else 867 ! stop with exit_status 868 ! MT 06-2013:stop function only accept parameters ! 869 if (exit_status== 0) stop "0" 870 if (exit_status== 1) stop "1" 871 if (exit_status==-1) stop "-1" 872#endif 873 stop 1 874 875end subroutine sys_exit 876!!*** 877 878!---------------------------------------------------------------------- 879 880!!****f* m_xmpi/xmpi_show_info 881!! NAME 882!! xmpi_show_info 883!! 884!! FUNCTION 885!! Printout of the most important variables stored in this module (useful for debugging). 886!! 887!! INPUTS 888!! unt=Unit number for formatted output. 889!! 890!! PARENTS 891!! abinit,leave_new,m_errors 892!! 893!! CHILDREN 894!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 895!! 896!! SOURCE 897 898subroutine xmpi_show_info(unit) 899 900 901!This section has been created automatically by the script Abilint (TD). 902!Do not modify the following lines by hand. 903#undef ABI_FUNC 904#define ABI_FUNC 'xmpi_show_info' 905!End of the abilint section 906 907 implicit none 908 909!Arguments------------------------- 910 integer,optional,intent(in) :: unit 911 912!Local variables------------------- 913 integer :: my_unt 914 915! ************************************************************************* 916 917 !@m_xmpi 918 my_unt = std_out; if (PRESENT(unit)) my_unt=unit 919 920#ifdef HAVE_MPI1 921 write(my_unt,*)" ==== Using MPI-1 specifications ==== " 922#endif 923#ifdef HAVE_MPI2 924 write(my_unt,*)" ==== Using MPI-2 specifications ==== " 925#endif 926 927#ifdef HAVE_MPI_IO 928 write(my_unt,*)" MPI-IO support is ON" 929#else 930 write(my_unt,*)" MPI-IO support is OFF" 931#endif 932 933#ifdef HAVE_MPI 934 write(my_unt,*)" xmpi_tag_ub ................ ",xmpi_tag_ub 935 write(my_unt,*)" xmpi_bsize_ch .............. ",xmpi_bsize_ch 936 write(my_unt,*)" xmpi_bsize_int ............. ",xmpi_bsize_int 937 write(my_unt,*)" xmpi_bsize_sp .............. ",xmpi_bsize_sp 938 write(my_unt,*)" xmpi_bsize_dp .............. ",xmpi_bsize_dp 939 write(my_unt,*)" xmpi_bsize_spc ............. ",xmpi_bsize_spc 940 write(my_unt,*)" xmpi_bsize_dpc ............. ",xmpi_bsize_dpc 941 write(my_unt,*)" xmpio_bsize_frm ............ ",xmpio_bsize_frm 942 write(my_unt,*)" xmpi_address_kind .......... ",xmpi_address_kind 943 write(my_unt,*)" xmpi_offset_kind ........... ",xmpi_offset_kind 944 write(my_unt,*)" MPI_WTICK .................. ",MPI_WTICK() 945#endif 946 947end subroutine xmpi_show_info 948!!*** 949 950!---------------------------------------------------------------------- 951 952!!****f* m_xmpi/xmpi_comm_rank 953!! NAME 954!! xmpi_comm_rank 955!! 956!! FUNCTION 957!! Hides MPI_COMM_RANK from MPI library. 958!! 959!! INPUTS 960!! comm=MPI communicator. 961!! 962!! OUTPUT 963!! xmpi_comm_rank=The rank of the node inside comm 964!! 965!! PARENTS 966!! 967!! SOURCE 968 969function xmpi_comm_rank(comm) 970 971 972!This section has been created automatically by the script Abilint (TD). 973!Do not modify the following lines by hand. 974#undef ABI_FUNC 975#define ABI_FUNC 'xmpi_comm_rank' 976!End of the abilint section 977 978 implicit none 979 980!Arguments------------------------- 981 integer,intent(in) :: comm 982 integer :: xmpi_comm_rank 983 984!Local variables------------------- 985 integer :: mpierr 986 987! ************************************************************************* 988 989 mpierr=0 990#ifdef HAVE_MPI 991 xmpi_comm_rank=-1 ! Return non-sense value if the proc does not belong to the comm 992 if (comm/=xmpi_comm_null) then 993 call MPI_COMM_RANK(comm,xmpi_comm_rank,mpierr) 994 end if 995#else 996 xmpi_comm_rank=0 997#endif 998 999end function xmpi_comm_rank 1000!!*** 1001 1002!---------------------------------------------------------------------- 1003 1004!!****f* m_xmpi/xmpi_comm_size 1005!! NAME 1006!! xmpi_comm_size 1007!! 1008!! FUNCTION 1009!! Hides MPI_COMM_SIZE from MPI library. 1010!! 1011!! INPUTS 1012!! comm=MPI communicator. 1013!! 1014!! OUTPUT 1015!! xmpi_comm_size=The number of processors inside comm. 1016!! 1017!! PARENTS 1018!! 1019!! SOURCE 1020 1021function xmpi_comm_size(comm) 1022 1023 1024!This section has been created automatically by the script Abilint (TD). 1025!Do not modify the following lines by hand. 1026#undef ABI_FUNC 1027#define ABI_FUNC 'xmpi_comm_size' 1028!End of the abilint section 1029 1030 implicit none 1031 1032!Arguments------------------------- 1033 integer,intent(in) :: comm 1034 integer :: xmpi_comm_size 1035 1036!Local variables------------------------------- 1037!scalars 1038 integer :: mpierr 1039 1040! ************************************************************************* 1041 1042 mpierr=0; xmpi_comm_size=1 1043#ifdef HAVE_MPI 1044 if (comm/=xmpi_comm_null) then 1045 call MPI_COMM_SIZE(comm,xmpi_comm_size,mpierr) 1046 end if 1047#endif 1048 1049end function xmpi_comm_size 1050!!*** 1051 1052!---------------------------------------------------------------------- 1053 1054!!****f* m_xmpi/xmpi_comm_free_0D 1055!! NAME 1056!! xmpi_comm_free_0D 1057!! 1058!! FUNCTION 1059!! Hides MPI_COMM_FREE from MPI library. 1060!! Does not abort MPI in case of an invalid communicator 1061!! 1062!! INPUTS 1063!! comm=MPI communicator. 1064!! 1065!! PARENTS 1066!! 1067!! CHILDREN 1068!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1069!! 1070!! SOURCE 1071 1072subroutine xmpi_comm_free_0D(comm) 1073 1074 1075!This section has been created automatically by the script Abilint (TD). 1076!Do not modify the following lines by hand. 1077#undef ABI_FUNC 1078#define ABI_FUNC 'xmpi_comm_free_0D' 1079!End of the abilint section 1080 1081 implicit none 1082 1083!Arguments------------------------- 1084 integer,intent(inout) :: comm 1085 1086!Local variables------------------------------- 1087!scalars 1088#ifdef HAVE_MPI 1089 integer :: comm_world,err_handler_dum,err_handler_sav,ierr,mpierr,mpierr_class 1090 1091! ************************************************************************* 1092 1093 if (comm/=xmpi_comm_null.and.comm/=xmpi_world.and.comm/=xmpi_comm_self) then 1094 1095 comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout)) 1096 call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,ierr) 1097 call MPI_COMM_FREE(comm,mpierr) 1098 call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,ierr) 1099 1100 if (mpierr/=MPI_SUCCESS) then 1101 call MPI_ERROR_CLASS(mpierr,mpierr_class,ierr) 1102 if (mpierr_class/=MPI_ERR_COMM) then 1103 write(std_out,*)" WARNING: MPI_COMM_FREE returned ierr= ",mpierr 1104 end if 1105 end if 1106 1107 end if 1108 1109#else 1110 if (.false.) write(std_out,*) comm 1111#endif 1112 1113end subroutine xmpi_comm_free_0D 1114!!*** 1115 1116!---------------------------------------------------------------------- 1117 1118!!****f* m_xmpi/xmpi_comm_free_1D 1119!! NAME 1120!! xmpi_comm_free_1D 1121!! 1122!! FUNCTION 1123!! Hides MPI_COMM_FREE from MPI library. Target 1D arrays 1124!! Does not abort MPI in case of an invalid communicator 1125!! 1126!! INPUTS 1127!! comms(:)=MPI communicators 1128!! 1129!! PARENTS 1130!! 1131!! CHILDREN 1132!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1133!! 1134!! SOURCE 1135 1136subroutine xmpi_comm_free_1D(comms) 1137 1138 1139!This section has been created automatically by the script Abilint (TD). 1140!Do not modify the following lines by hand. 1141#undef ABI_FUNC 1142#define ABI_FUNC 'xmpi_comm_free_1D' 1143!End of the abilint section 1144 1145 implicit none 1146 1147!Arguments------------------------- 1148 integer,intent(inout) :: comms(:) 1149 1150!Local variables------------------------------- 1151!scalars 1152#ifdef HAVE_MPI 1153 integer :: comm_world,err_handler_dum,err_handler_sav,ii,mpierr 1154 1155! ************************************************************************* 1156 1157 comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout)) 1158 call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,mpierr) 1159 1160 do ii=LBOUND(comms,DIM=1),UBOUND(comms,DIM=1) 1161 if (comms(ii)/=xmpi_comm_null.and.comms(ii)/=xmpi_world.and.comms(ii)/=xmpi_comm_self) then 1162 call MPI_COMM_FREE(comms(ii),mpierr) 1163 end if 1164 end do 1165 1166 call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,mpierr) 1167 1168#else 1169 if (.false.) write(std_out,*) comms(1) 1170#endif 1171 1172end subroutine xmpi_comm_free_1D 1173!!*** 1174 1175!---------------------------------------------------------------------- 1176 1177!!****f* m_xmpi/xmpi_comm_free_2D 1178!! NAME 1179!! xmpi_comm_free_2D 1180!! 1181!! FUNCTION 1182!! Hides MPI_COMM_FREE from MPI library. Target 2D arrays 1183!! Does not abort MPI in case of an invalid communicator 1184!! 1185!! INPUTS 1186!! comms=MPI communicator. 1187!! 1188!! PARENTS 1189!! 1190!! CHILDREN 1191!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1192!! 1193!! SOURCE 1194 1195subroutine xmpi_comm_free_2D(comms) 1196 1197 1198!This section has been created automatically by the script Abilint (TD). 1199!Do not modify the following lines by hand. 1200#undef ABI_FUNC 1201#define ABI_FUNC 'xmpi_comm_free_2D' 1202!End of the abilint section 1203 1204 implicit none 1205 1206!Arguments------------------------- 1207 integer,intent(inout) :: comms(:,:) 1208 1209!Local variables------------------------------- 1210!scalars 1211#ifdef HAVE_MPI 1212 integer :: comm_world,err_handler_dum,err_handler_sav,ii,jj,mpierr 1213 1214! ************************************************************************* 1215 1216 comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout)) 1217 call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,mpierr) 1218 1219 do jj=LBOUND(comms,DIM=2),UBOUND(comms,DIM=2) 1220 do ii=LBOUND(comms,DIM=1),UBOUND(comms,DIM=1) 1221 if (comms(ii,jj)/=xmpi_comm_null.and.comms(ii,jj)/=xmpi_world.and. & 1222& comms(ii,jj)/=xmpi_comm_self) then 1223 call MPI_COMM_FREE(comms(ii,jj),mpierr) 1224 end if 1225 end do 1226 end do 1227 1228 call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,mpierr) 1229 1230#else 1231 if (.false.) write(std_out,*) comms(1,1) 1232#endif 1233 1234end subroutine xmpi_comm_free_2D 1235!!*** 1236 1237!---------------------------------------------------------------------- 1238 1239!!****f* m_xmpi/xmpi_comm_free_3D 1240!! NAME 1241!! xmpi_comm_free_3D 1242!! 1243!! FUNCTION 1244!! Hides MPI_COMM_FREE from MPI library. Target 3D arrays 1245!! Does not abort MPI in case of an invalid communicator 1246!! 1247!! INPUTS 1248!! comms=MPI communicator. 1249!! 1250!! PARENTS 1251!! 1252!! CHILDREN 1253!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1254!! 1255!! SOURCE 1256 1257subroutine xmpi_comm_free_3D(comms) 1258 1259 1260!This section has been created automatically by the script Abilint (TD). 1261!Do not modify the following lines by hand. 1262#undef ABI_FUNC 1263#define ABI_FUNC 'xmpi_comm_free_3D' 1264!End of the abilint section 1265 1266 implicit none 1267 1268!Arguments------------------------- 1269 integer,intent(inout) :: comms(:,:,:) 1270 1271!Local variables------------------------------- 1272!scalars 1273#ifdef HAVE_MPI 1274 integer :: comm_world,err_handler_dum,err_handler_sav,ii,jj,kk,mpierr 1275 1276! ************************************************************************* 1277 1278 comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout)) 1279 call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,mpierr) 1280 1281 do kk=LBOUND(comms,DIM=3),UBOUND(comms,DIM=3) 1282 do jj=LBOUND(comms,DIM=2),UBOUND(comms,DIM=2) 1283 do ii=LBOUND(comms,DIM=1),UBOUND(comms,DIM=1) 1284 if (comms(ii,jj,kk)/=xmpi_comm_null.and.comms(ii,jj,kk)/=xmpi_world.and. & 1285& comms(ii,jj,kk)/=xmpi_comm_self) then 1286 call MPI_COMM_FREE(comms(ii,jj,kk),mpierr) 1287 end if 1288 end do 1289 end do 1290 end do 1291 1292 call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,mpierr) 1293 1294#else 1295 if (.false.) write(std_out,*) comms(1,1,1) 1296#endif 1297 1298end subroutine xmpi_comm_free_3D 1299!!*** 1300 1301!---------------------------------------------------------------------- 1302 1303!!****f* m_xmpi/xmpi_group_free 1304!! NAME 1305!! xmpi_group_free 1306!! 1307!! FUNCTION 1308!! Hides MPI_GROUP_FREE from MPI library. 1309!! Does not abort MPI in case of an invalid group 1310!! 1311!! INPUTS 1312!! spaceGroup=MPI group 1313!! 1314!! PARENTS 1315!! m_wfd,m_xmpi,pawprt 1316!! 1317!! CHILDREN 1318!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1319!! 1320!! SOURCE 1321 1322subroutine xmpi_group_free(spaceGroup) 1323 1324 1325!This section has been created automatically by the script Abilint (TD). 1326!Do not modify the following lines by hand. 1327#undef ABI_FUNC 1328#define ABI_FUNC 'xmpi_group_free' 1329!End of the abilint section 1330 1331 implicit none 1332 1333!Arguments------------------------- 1334 integer,intent(inout) :: spaceGroup 1335 1336!Local variables------------------------------- 1337!scalars 1338#ifdef HAVE_MPI 1339 integer :: comm_world,err_handler_dum,err_handler_sav,ierr,mpierr,mpierr_class 1340 1341! ************************************************************************* 1342 1343 if (spaceGroup/=xmpi_group_null) then 1344 1345 comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout)) 1346 call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,ierr) 1347 call MPI_GROUP_FREE(spaceGroup,mpierr) 1348 call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,ierr) 1349 1350 if (mpierr/=MPI_SUCCESS) then 1351 call MPI_ERROR_CLASS(mpierr,mpierr_class,ierr) 1352 if (mpierr_class/=MPI_ERR_GROUP) then 1353 write(std_out,*)" WARNING: MPI_GROUP_FREE returned ierr= ",mpierr 1354 end if 1355 end if 1356 1357 end if 1358 1359#else 1360 if (.false.) write(std_out,*) spaceGroup 1361#endif 1362 1363end subroutine xmpi_group_free 1364!!*** 1365 1366!---------------------------------------------------------------------- 1367 1368!!****f* m_xmpi/xmpi_group_incl 1369!! NAME 1370!! xmpi_group_incl 1371!! 1372!! FUNCTION 1373!! Hides MPI_GROUP_INCL from MPI library. 1374!! 1375!! INPUTS 1376!! group=input group 1377!! nrank=number of elements in array ranks (size of newgroup) 1378!! ranks=ranks of processes in group to appear in newgroup 1379!! 1380!! OUTPUT 1381!! newgroup= new group derived from above, in the order defined by ranks 1382!! 1383!! PARENTS 1384!! m_wfd 1385!! 1386!! CHILDREN 1387!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1388!! 1389!! SOURCE 1390 1391subroutine xmpi_group_incl(group,nranks,ranks,newgroup,mpierr) 1392 1393 1394!This section has been created automatically by the script Abilint (TD). 1395!Do not modify the following lines by hand. 1396#undef ABI_FUNC 1397#define ABI_FUNC 'xmpi_group_incl' 1398!End of the abilint section 1399 1400 implicit none 1401 1402!Arguments------------------------- 1403!scalars 1404 integer,intent(in) :: group,nranks 1405 integer,intent(out) :: mpierr 1406 integer,intent(inout) :: newgroup 1407!arrays 1408 integer,intent(in) :: ranks(nranks) 1409 1410! ************************************************************************* 1411 1412 mpierr=0 ; newgroup=xmpi_group_null 1413#ifdef HAVE_MPI 1414 if (group/=xmpi_group_null) then 1415 call MPI_GROUP_INCL(group,nranks,ranks,newgroup,mpierr) 1416 end if 1417#endif 1418 1419end subroutine xmpi_group_incl 1420!!*** 1421 1422!---------------------------------------------------------------------- 1423 1424!!****f* m_xmpi/xmpi_comm_create 1425!! NAME 1426!! xmpi_comm_create 1427!! 1428!! FUNCTION 1429!! Hides MPI_COMM_CREATE from MPI library. 1430!! 1431!! INPUTS 1432!! comm=communicator 1433!! group=group, which is a subset of the group of comm 1434!! 1435!! OUTPUT 1436!! newcomm=new communicator 1437!! 1438!! PARENTS 1439!! m_wfd 1440!! 1441!! CHILDREN 1442!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1443!! 1444!! SOURCE 1445 1446subroutine xmpi_comm_create(comm,group,newcomm,mpierr) 1447 1448 1449!This section has been created automatically by the script Abilint (TD). 1450!Do not modify the following lines by hand. 1451#undef ABI_FUNC 1452#define ABI_FUNC 'xmpi_comm_create' 1453!End of the abilint section 1454 1455 implicit none 1456 1457!Arguments------------------------- 1458!scalars 1459 integer,intent(in) :: comm,group 1460 integer,intent(out) :: mpierr 1461 integer,intent(inout) :: newcomm 1462 1463! ************************************************************************* 1464 1465 mpierr=0 1466#ifdef HAVE_MPI 1467 if (group/=xmpi_group_null) then 1468 call MPI_comm_create(comm,group,newcomm,mpierr) 1469 else 1470 newcomm=xmpi_comm_null 1471 end if 1472#else 1473 newcomm=xmpi_comm_self 1474#endif 1475 1476end subroutine xmpi_comm_create 1477!!*** 1478 1479!---------------------------------------------------------------------- 1480 1481!!****f* m_xmpi/xmpi_subcomm 1482!! NAME 1483!! xmpi_subcomm 1484!! 1485!! FUNCTION 1486!! Return a sub-communicator from an input communicator and a given proc. ranks set. 1487!! (hides subgroup creation/destruction) 1488!! 1489!! INPUTS 1490!! comm=input communicator 1491!! nrank=number of elements in array ranks (size of subcomm) 1492!! ranks=ranks of processes in group to appear in subcomm 1493!! 1494!! OUTPUT 1495!! [my_rank_in_group]=optional: my rank in the group of new sub-communicator 1496!! xmpi_subcomm=new (sub-)communicator 1497!! 1498!! PARENTS 1499!! 1500!! SOURCE 1501 1502function xmpi_subcomm(comm,nranks,ranks,my_rank_in_group) 1503 1504 1505!This section has been created automatically by the script Abilint (TD). 1506!Do not modify the following lines by hand. 1507#undef ABI_FUNC 1508#define ABI_FUNC 'xmpi_subcomm' 1509!End of the abilint section 1510 1511 implicit none 1512 1513!Arguments------------------------- 1514!scalars 1515 integer,intent(in) :: comm,nranks 1516 integer,intent(out),optional :: my_rank_in_group 1517 integer :: xmpi_subcomm 1518!arrays 1519 integer,intent(in) :: ranks(nranks) 1520 1521!Local variables------------------------------- 1522#ifdef HAVE_MPI 1523 integer :: group,ierr,subgroup 1524#endif 1525 1526! ************************************************************************* 1527 1528 xmpi_subcomm=xmpi_comm_null 1529 if (present(my_rank_in_group)) my_rank_in_group=xmpi_undefined 1530 1531#ifdef HAVE_MPI 1532 if (comm/=xmpi_comm_null.and.nranks>=0) then 1533 call MPI_COMM_GROUP(comm,group,ierr) 1534 call MPI_GROUP_INCL(group,nranks,ranks,subgroup,ierr) 1535 call MPI_COMM_CREATE(comm,subgroup,xmpi_subcomm,ierr) 1536 if ( nranks == 0 )xmpi_subcomm=xmpi_comm_self 1537 if (present(my_rank_in_group)) then 1538 call MPI_Group_rank(subgroup,my_rank_in_group,ierr) 1539 end if 1540 call MPI_GROUP_FREE(subgroup,ierr) 1541 call MPI_GROUP_FREE(group,ierr) 1542 end if 1543#else 1544 if (nranks>0) then 1545 if (ranks(1)==0) then 1546 xmpi_subcomm=xmpi_comm_self 1547 if (present(my_rank_in_group)) my_rank_in_group=0 1548 end if 1549 end if 1550#endif 1551 1552end function xmpi_subcomm 1553!!*** 1554 1555!---------------------------------------------------------------------- 1556 1557!!****f* m_xmpi/xmpi_comm_group 1558!! NAME 1559!! xmpi_comm_group 1560!! 1561!! FUNCTION 1562!! Hides MPI_COMM_GROUP from MPI library. 1563!! 1564!! INPUTS 1565!! comm=MPI communicator. 1566!! 1567!! OUTPUT 1568!! spaceGroup=The group associated to comm. 1569!! mpierr=error code returned 1570!! 1571!! PARENTS 1572!! m_wfd,m_xmpi,pawprt 1573!! 1574!! CHILDREN 1575!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1576!! 1577!! SOURCE 1578 1579subroutine xmpi_comm_group(comm,spaceGroup,mpierr) 1580 1581 1582!This section has been created automatically by the script Abilint (TD). 1583!Do not modify the following lines by hand. 1584#undef ABI_FUNC 1585#define ABI_FUNC 'xmpi_comm_group' 1586!End of the abilint section 1587 1588 implicit none 1589 1590!Arguments------------------------- 1591 integer,intent(in) :: comm 1592 integer,intent(out) :: mpierr,spaceGroup 1593 1594! ************************************************************************* 1595 1596 mpierr=0; spaceGroup=xmpi_group_null 1597#ifdef HAVE_MPI 1598 if (comm/=xmpi_comm_null) then 1599 call MPI_COMM_GROUP(comm,spaceGroup,mpierr) 1600 end if 1601#endif 1602 1603end subroutine xmpi_comm_group 1604!!*** 1605 1606!---------------------------------------------------------------------- 1607 1608!!****f* m_xmpi/xmpi_comm_split 1609!! NAME 1610!! xmpi_comm_split 1611!! 1612!! FUNCTION 1613!! Hides MPI_COMM_SPLIT from MPI library. 1614!! 1615!! INPUTS 1616!! input_comm=Input MPI communicator (to be splitted) 1617!! color=Control of subset assignment (nonnegative integer). 1618!! Processes with the same color are in the same new communicator 1619!! key=Ccontrol of rank assigment (integer) 1620!! 1621!! OUTPUT 1622!! mpierr=error code returned 1623!! output_comm=new splitted communicator 1624!! 1625!! PARENTS 1626!! 1627!! CHILDREN 1628!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1629!! 1630!! SOURCE 1631 1632subroutine xmpi_comm_split(input_comm,color,key,output_comm,mpierr) 1633 1634 1635!This section has been created automatically by the script Abilint (TD). 1636!Do not modify the following lines by hand. 1637#undef ABI_FUNC 1638#define ABI_FUNC 'xmpi_comm_split' 1639!End of the abilint section 1640 1641 implicit none 1642 1643!Arguments------------------------- 1644!scalars 1645 integer,intent(in) :: color,input_comm,key 1646 integer,intent(out) :: mpierr,output_comm 1647 1648! ************************************************************************* 1649 1650 mpierr=0; output_comm=input_comm 1651#ifdef HAVE_MPI 1652 if (input_comm/=xmpi_comm_null.and.input_comm/=xmpi_comm_self) then 1653 call MPI_COMM_SPLIT(input_comm,color,key,output_comm,mpierr) 1654 end if 1655#endif 1656 1657end subroutine xmpi_comm_split 1658!!*** 1659 1660!---------------------------------------------------------------------- 1661 1662!!****f* m_xmpi/xmpi_group_translate_ranks 1663!! NAME 1664!! xmpi_group_translate_ranks 1665!! 1666!! FUNCTION 1667!! Hides MPI_GROUP_TRANSLATE_RANKS from MPI library. 1668!! 1669!! INPUTS 1670!! nrank=number of ranks in ranks1 and ranks2 arrays 1671!! ranks1(nrank)=array of zero or more valid ranks in group1 1672!! spaceGroup1=group1 1673!! spaceGroup2=group2 1674!! 1675!! OUTPUT 1676!! mpierr=error code returned 1677!! ranks2(nrank)=array of corresponding ranks in group2, 1678!! xmpi_undefined when no correspondence exists 1679!! 1680!! PARENTS 1681!! m_xmpi,pawprt 1682!! 1683!! CHILDREN 1684!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1685!! 1686!! SOURCE 1687 1688subroutine xmpi_group_translate_ranks(spaceGroup1,nrank,ranks1,& 1689& spaceGroup2,ranks2,mpierr) 1690 1691 1692!This section has been created automatically by the script Abilint (TD). 1693!Do not modify the following lines by hand. 1694#undef ABI_FUNC 1695#define ABI_FUNC 'xmpi_group_translate_ranks' 1696!End of the abilint section 1697 1698 implicit none 1699 1700!Arguments------------------------- 1701!scalars 1702 integer,intent(in) :: nrank,spaceGroup1,spaceGroup2 1703 integer,intent(out) :: mpierr 1704!arrays 1705 integer,intent(in) :: ranks1(nrank) 1706 integer,intent(out) :: ranks2(nrank) 1707 1708! ************************************************************************* 1709 1710 mpierr=0; ranks2(:)=xmpi_undefined 1711#ifdef HAVE_MPI 1712 if (spaceGroup1/=xmpi_group_null.and.spaceGroup2/=xmpi_group_null) then 1713 call MPI_GROUP_TRANSLATE_RANKS(spaceGroup1,nrank,ranks1,& 1714& spaceGroup2,ranks2,mpierr) 1715 end if 1716#else 1717 ranks2(1)=0 1718#endif 1719 1720end subroutine xmpi_group_translate_ranks 1721!!*** 1722 1723!---------------------------------------------------------------------- 1724 1725!!****f* m_xmpi/xmpi_comm_translate_ranks 1726!! NAME 1727!! xmpi_comm_translate_ranks 1728!! 1729!! FUNCTION 1730!! Helper function that translate the ranks from a communicator to another one. 1731!! Wraps xmpi_group_translate_ranks but provides a more user-friendly interface 1732!! 1733!! INPUTS 1734!! from_comm=MPI communicator where from_ranks are defined. 1735!! nrank=number of ranks in from_ranks and to_ranks arrays 1736!! from_ranks(nrank)=array of zero or more valid ranks in from_comm 1737!! 1738!! OUTPUT 1739!! to_ranks(nrank)=array of corresponding ranks in to_comm 1740!! xmpi_undefined when no correspondence exists 1741!! 1742!! PARENTS 1743!! m_paral_pert 1744!! 1745!! CHILDREN 1746!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1747!! 1748!! SOURCE 1749 1750subroutine xmpi_comm_translate_ranks(from_comm,nrank,from_ranks,to_comm,to_ranks) 1751 1752 1753!This section has been created automatically by the script Abilint (TD). 1754!Do not modify the following lines by hand. 1755#undef ABI_FUNC 1756#define ABI_FUNC 'xmpi_comm_translate_ranks' 1757!End of the abilint section 1758 1759 implicit none 1760 1761!Arguments------------------------- 1762!scalars 1763 integer,intent(in) :: nrank,from_comm,to_comm 1764!arrays 1765 integer,intent(in) :: from_ranks(nrank) 1766 integer,intent(out) :: to_ranks(nrank) 1767 1768!Local variables------------------------------- 1769!scalars 1770 integer :: ierr,from_group,to_group 1771 1772! ************************************************************************* 1773 1774 ! Get the groups 1775 call xmpi_comm_group(from_comm,from_group,ierr) 1776 call xmpi_comm_group(to_comm,to_group,ierr) 1777 1778 call xmpi_group_translate_ranks(from_group,nrank,from_ranks,to_group,to_ranks,ierr) 1779 1780 ! Release the groups 1781 call xmpi_group_free(from_group) 1782 call xmpi_group_free(to_group) 1783 1784end subroutine xmpi_comm_translate_ranks 1785!!*** 1786 1787!---------------------------------------------------------------------- 1788 1789!!****f* m_xmpi/xmpi_barrier 1790!! NAME 1791!! xmpi_barrier 1792!! 1793!! FUNCTION 1794!! Hides MPI_BARRIER from MPI library. 1795!! 1796!! INPUTS 1797!! comm=MPI communicator 1798!! 1799!! PARENTS 1800!! alloc_hamilt_gpu,atomden,calc_optical_mels,calc_ucrpa,chebfi,cohsex_me 1801!! datafordmft,denfgr,dfpt_nselt,dfpt_nstpaw,dfpt_scfcv,exc_build_block 1802!! fermisolverec,getcgqphase,gstateimg,iofn1,ks_ddiago,m_bse_io 1803!! m_exc_diago,m_exc_itdiago,m_exc_spectra,m_green,m_haydock,m_hdr 1804!! m_io_kss,m_io_redirect,m_ioarr,m_iowf,m_plowannier,m_slk,m_wfd,m_wffile 1805!! m_wfk,mlwfovlp,mlwfovlp_pw,mover,outkss,pawmkaewf,qmc_prep_ctqmc,sigma 1806!! tddft,vtorho,vtorhorec,wfk_analyze 1807!! 1808!! CHILDREN 1809!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1810!! 1811!! SOURCE 1812 1813subroutine xmpi_barrier(comm) 1814 1815 1816!This section has been created automatically by the script Abilint (TD). 1817!Do not modify the following lines by hand. 1818#undef ABI_FUNC 1819#define ABI_FUNC 'xmpi_barrier' 1820!End of the abilint section 1821 1822 implicit none 1823 1824!Arguments------------------------- 1825 integer,intent(in) :: comm 1826 1827!Local variables------------------- 1828 integer :: ier 1829#ifdef HAVE_MPI 1830 integer :: nprocs 1831#endif 1832 1833! ************************************************************************* 1834 1835 ier = 0 1836#ifdef HAVE_MPI 1837 if (comm/=xmpi_comm_null) then 1838 call MPI_COMM_SIZE(comm,nprocs,ier) 1839 if(nprocs>1)then 1840 call MPI_BARRIER(comm,ier) 1841 end if 1842 end if 1843#endif 1844 1845end subroutine xmpi_barrier 1846!!*** 1847 1848!---------------------------------------------------------------------- 1849 1850!!****f* m_xmpi/xmpi_name 1851!! NAME 1852!! xmpi_name 1853!! 1854!! FUNCTION 1855!! Hides MPI_GET_PROCESSOR_NAME from MPI library. 1856!! 1857!! OUTPUT 1858!! name= the host name transformed to integer variable. 1859!! mpierr=Status error. 1860!! 1861!! PARENTS 1862!! m_gpu_detect 1863!! 1864!! CHILDREN 1865!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1866!! 1867!! SOURCE 1868 1869subroutine xmpi_name(name_ch, mpierr) 1870 1871 1872!This section has been created automatically by the script Abilint (TD). 1873!Do not modify the following lines by hand. 1874#undef ABI_FUNC 1875#define ABI_FUNC 'xmpi_name' 1876!End of the abilint section 1877 1878 implicit none 1879 1880!Arguments------------------------- 1881 integer,intent(out) :: mpierr 1882 character(20),intent(out) :: name_ch 1883 1884!Local variables------------------- 1885 integer :: name,len 1886! character(len=MPI_MAX_PROCESSOR_NAME) :: name_ch 1887 1888! ************************************************************************* 1889!Get the name of this processor (usually the hostname) 1890 1891 name = 0 1892 mpierr = 0 1893 1894#ifdef HAVE_MPI 1895 call MPI_GET_PROCESSOR_NAME(name_ch, len, mpierr) 1896 name_ch = trim(name_ch) 1897 1898#else 1899 name_ch ='0' 1900#endif 1901 1902end subroutine xmpi_name 1903!!*** 1904 1905!---------------------------------------------------------------------- 1906 1907!!****f* m_xmpi/xmpi_iprobe 1908!! NAME 1909!! xmpi_iprobe 1910!! 1911!! FUNCTION 1912!! Hides MPI_IPROBE from MPI library. 1913!! Nonblocking test for a message. 1914!! 1915!! INPUTS 1916!! source= source processes 1917!! tag= tag value 1918!! mpicomm= communicator 1919!! 1920!! OUTPUT 1921!! flag= True if a message with the specified source, tag, and communicator is available 1922!! mpierr= status error 1923!! 1924!! PARENTS 1925!! m_paw_an,m_paw_ij,m_pawfgrtab,m_pawrhoij 1926!! 1927!! CHILDREN 1928!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1929!! 1930!! SOURCE 1931 1932subroutine xmpi_iprobe(source,tag,mpicomm,flag,mpierr) 1933 1934 1935!This section has been created automatically by the script Abilint (TD). 1936!Do not modify the following lines by hand. 1937#undef ABI_FUNC 1938#define ABI_FUNC 'xmpi_iprobe' 1939!End of the abilint section 1940 1941 implicit none 1942 1943!Arguments------------------------- 1944 integer,intent(in) :: mpicomm,source,tag 1945 integer,intent(out) :: mpierr 1946 logical,intent(out) :: flag 1947 1948!Local variables------------------- 1949#ifdef HAVE_MPI 1950 integer :: ier,status(MPI_STATUS_SIZE) 1951#endif 1952 1953! ************************************************************************* 1954 1955 mpierr = 0 1956#ifdef HAVE_MPI 1957 call MPI_IPROBE(source,tag,mpicomm,flag,status,ier) 1958 mpierr=ier 1959#endif 1960 1961end subroutine xmpi_iprobe 1962!!*** 1963 1964!---------------------------------------------------------------------- 1965 1966!!****f* m_xmpi/xmpi_wait 1967!! NAME 1968!! xmpi_wait 1969!! 1970!! FUNCTION 1971!! Hides MPI_WAIT from MPI library. 1972!! Waits for an MPI request to complete. 1973!! 1974!! INPUTS 1975!! request= MPI request handle to wait for 1976!! 1977!! OUTPUT 1978!! mpierr= status error 1979!! 1980!! PARENTS 1981!! dfpt_scfcv,m_fftw3,m_paw_an,m_paw_ij,m_pawfgrtab,m_pawrhoij,m_sg2002 1982!! mover,scfcv 1983!! 1984!! CHILDREN 1985!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 1986!! 1987!! SOURCE 1988 1989subroutine xmpi_wait(request,mpierr) 1990 1991 1992!This section has been created automatically by the script Abilint (TD). 1993!Do not modify the following lines by hand. 1994#undef ABI_FUNC 1995#define ABI_FUNC 'xmpi_wait' 1996!End of the abilint section 1997 1998 implicit none 1999 2000!Arguments------------------------- 2001 integer,intent(out) :: mpierr 2002 integer,intent(inout) :: request 2003 2004!Local variables------------------- 2005#ifdef HAVE_MPI 2006 integer :: ier,status(MPI_STATUS_SIZE) 2007#endif 2008 2009! ************************************************************************* 2010 2011 mpierr = 0 2012#ifdef HAVE_MPI 2013 call MPI_WAIT(request,status,ier) 2014 mpierr=ier 2015#endif 2016 2017end subroutine xmpi_wait 2018!!*** 2019 2020!---------------------------------------------------------------------- 2021 2022!!****f* m_xmpi/xmpi_waitall 2023!! NAME 2024!! xmpi_waitall 2025!! 2026!! FUNCTION 2027!! Hides MPI_WAITALL from MPI library. 2028!! Waits for all given MPI Requests to complete. 2029!! 2030!! INPUTS 2031!! array_of_requests= array of request handles 2032!! 2033!! OUTPUT 2034!! mpierr= status error 2035!! 2036!! PARENTS 2037!! m_paw_an,m_paw_ij,m_pawfgrtab,m_pawrhoij 2038!! 2039!! CHILDREN 2040!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 2041!! 2042!! SOURCE 2043 2044subroutine xmpi_waitall(array_of_requests,mpierr) 2045 2046 2047!This section has been created automatically by the script Abilint (TD). 2048!Do not modify the following lines by hand. 2049#undef ABI_FUNC 2050#define ABI_FUNC 'xmpi_waitall' 2051!End of the abilint section 2052 2053 implicit none 2054 2055!Arguments------------------------- 2056 integer,intent(inout) :: array_of_requests(:) 2057 integer,intent(out) :: mpierr 2058 2059!Local variables------------------- 2060#ifdef HAVE_MPI 2061 integer :: ier,status(MPI_STATUS_SIZE,size(array_of_requests)) 2062#endif 2063 2064! ************************************************************************* 2065 2066 mpierr = 0 2067#ifdef HAVE_MPI 2068 call MPI_WAITALL(size(array_of_requests),array_of_requests,status,ier) 2069 mpierr=ier 2070#endif 2071 2072end subroutine xmpi_waitall 2073!!*** 2074 2075!---------------------------------------------------------------------- 2076 2077!!****f* m_xmpi/xmpi_request_free 2078!! NAME 2079!! xmpi_request_free 2080!! 2081!! FUNCTION 2082!! Hides MPI_REQUEST_FREE from MPI library. 2083!! Frees an array of communication request objects. 2084!! 2085!! INPUTS 2086!! requests(:)= communication request array (array of handles) 2087!! 2088!! OUTPUT 2089!! mpierr= status error 2090!! 2091!! PARENTS 2092!! 2093!! CHILDREN 2094!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 2095!! 2096!! SOURCE 2097 2098subroutine xmpi_request_free(requests,mpierr) 2099 2100 2101!This section has been created automatically by the script Abilint (TD). 2102!Do not modify the following lines by hand. 2103#undef ABI_FUNC 2104#define ABI_FUNC 'xmpi_request_free' 2105!End of the abilint section 2106 2107 implicit none 2108 2109!Arguments------------------------- 2110 integer,intent(inout) :: requests(:) 2111 integer,intent(out) :: mpierr 2112 2113!Local variables------------------- 2114#ifdef HAVE_MPI 2115 integer :: ier,ii 2116#endif 2117 2118! ************************************************************************* 2119 2120 mpierr = 0 2121#ifdef HAVE_MPI 2122 do ii=1,size(requests) 2123 call MPI_REQUEST_FREE(requests(ii),ier) 2124 end do 2125 mpierr=ier 2126#endif 2127 2128end subroutine xmpi_request_free 2129!!*** 2130 2131!---------------------------------------------------------------------- 2132 2133!!****f* m_xmpi/xmpi_error_string 2134!! NAME 2135!! xmpi_error_string 2136!! 2137!! FUNCTION 2138!! Hides MPI_ERROR_STRING from MPI library. 2139!! 2140!! INPUTS 2141!! 2142!! OUTPUT 2143!! 2144!! PARENTS 2145!! 2146!! CHILDREN 2147!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 2148!! 2149!! SOURCE 2150 2151subroutine xmpi_error_string(mpierr,err_string,ilen,ierror) 2152 2153 2154!This section has been created automatically by the script Abilint (TD). 2155!Do not modify the following lines by hand. 2156#undef ABI_FUNC 2157#define ABI_FUNC 'xmpi_error_string' 2158!End of the abilint section 2159 2160 implicit none 2161 2162!Arguments------------------------- 2163 integer,intent(in) :: mpierr 2164 integer,intent(out) :: ilen,ierror 2165 character(len=*),intent(out) :: err_string 2166 2167! ************************************************************************* 2168 2169 ilen=0 2170#ifdef HAVE_MPI 2171 call MPI_Error_string(mpierr,err_string,ilen,ierror) 2172#else 2173 ierror=1 2174 err_string="Sorry, no MPI_Error_string routine is available to interpret the error message" 2175#endif 2176 2177end subroutine xmpi_error_string 2178!!*** 2179 2180!---------------------------------------------------------------------- 2181 2182!!****f* m_xmpi/xmpi_comm_set_errhandler 2183!! NAME 2184!! xmpi_set_errhandler 2185!! 2186!! FUNCTION 2187!! Hides MPI_COMM_SET_ERRHANDLER from MPI library. 2188!! 2189!! INPUTS 2190!! new_err_handler= new error handler 2191!! 2192!! OUTPUT 2193!! ierror=error code 2194!! old_err_handler= old error handler 2195!! 2196!! SIZE EFFECTS 2197!! comm= communicator (should be intent(in) but is intent(inout) in some 2198!! OMPI implementation ; known as a bug) 2199!! 2200!! PARENTS 2201!! 2202!! SOURCE 2203 2204subroutine xmpi_comm_set_errhandler(comm,new_err_handler,old_err_handler,ierror) 2205 2206 2207!This section has been created automatically by the script Abilint (TD). 2208!Do not modify the following lines by hand. 2209#undef ABI_FUNC 2210#define ABI_FUNC 'xmpi_comm_set_errhandler' 2211!End of the abilint section 2212 2213 implicit none 2214 2215!Arguments------------------------- 2216 integer,intent(in) :: new_err_handler 2217 integer,intent(in) :: comm 2218 integer,intent(out) :: ierror,old_err_handler 2219 2220!Local variables------------------------- 2221 integer :: mpierr1,mpierr2,my_comm 2222 2223! ************************************************************************* 2224 2225 ierror=0 2226 my_comm = comm !should be intent(in) but is intent(inout) in some OMPI implementation ; known as a bug) 2227 2228#if defined HAVE_MPI 2229 2230 mpierr1=MPI_SUCCESS; mpierr2=MPI_SUCCESS 2231 2232#if defined HAVE_MPI1 2233 call MPI_Errhandler_get(my_comm,old_err_handler,mpierr1) 2234 call MPI_Errhandler_set(my_comm,new_err_handler,mpierr2) 2235#endif 2236#if defined HAVE_MPI2 2237 call MPI_comm_get_Errhandler(my_comm,old_err_handler,mpierr1) 2238 call MPI_comm_set_Errhandler(my_comm,new_err_handler,mpierr2) 2239#endif 2240 2241 ierror=MPI_SUCCESS 2242 if (mpierr1/=MPI_SUCCESS) then 2243 ierror=mpierr1 2244 else if (mpierr2/=MPI_SUCCESS) then 2245 ierror=mpierr2 2246 end if 2247#endif 2248 2249end subroutine xmpi_comm_set_errhandler 2250!!*** 2251 2252!---------------------------------------------------------------------- 2253 2254!!****f* m_xmpi/xmpi_split_work_i4b 2255!! NAME 2256!! split_work_i4b 2257!! 2258!! FUNCTION 2259!! Splits the number of tasks, ntasks, among nprocs processors. Used for the MPI parallelization of simple loops. 2260!! 2261!! INPUTS 2262!! ntasks=number of tasks 2263!! comm=MPI communicator. 2264!! 2265!! OUTPUT 2266!! my_start,my_stop= indices defining the initial and final task for this processor 2267!! warn_msg=String containing a possible warning message if the distribution is not optima. 2268!! ierr=Error status 2269!! +1 if ntasks is not divisible by nprocs. 2270!! +2 if ntasks>nprocs. 2271!! 2272!! NOTES 2273!! If nprocs>ntasks then : 2274!! my_start=ntasks+1 2275!! my_stop=ntask 2276!! 2277!! In this particular case, loops of the form 2278!! 2279!! do ii=my_start,my_stop 2280!! ... 2281!! end do 2282!! 2283!! are not executed. Moreover allocation such as foo(my_start:my_stop) will generate a zero-sized array. 2284!! 2285!! PARENTS 2286!! 2287!! SOURCE 2288 2289subroutine xmpi_split_work_i4b(ntasks,comm,my_start,my_stop,warn_msg,ierr) 2290 2291 2292!This section has been created automatically by the script Abilint (TD). 2293!Do not modify the following lines by hand. 2294#undef ABI_FUNC 2295#define ABI_FUNC 'xmpi_split_work_i4b' 2296!End of the abilint section 2297 2298 implicit none 2299 2300!Arguments ------------------------------------ 2301 integer,intent(in) :: ntasks,comm 2302 integer,intent(out) :: my_start,my_stop,ierr 2303 character(len=500) :: warn_msg 2304 2305!Local variables------------------------------- 2306 integer :: res,nprocs,my_rank,block_p1,block 2307 2308! ************************************************************************* 2309 2310 nprocs = xmpi_comm_size(comm) 2311 my_rank = xmpi_comm_rank(comm) 2312 2313 block = ntasks/nprocs 2314 res = MOD(ntasks,nprocs) 2315 block_p1= block+1 2316 2317 warn_msg = ""; ierr=0 2318 if (res/=0) then 2319 write(warn_msg,'(4a,i0,a,i0)')ch10,& 2320& 'xmpi_split_work: ',ch10,& 2321& 'The number of tasks= ',ntasks,' is not divisible by nprocs= ',nprocs 2322 ierr=1 2323 end if 2324 if (block==0) then 2325 write(warn_msg,'(4a,i0,a,i0,2a)')ch10,& 2326& 'xmpi_split_work: ',ch10,& 2327& 'The number of processors= ',nprocs,' is larger than number of tasks= ',ntasks,ch10,& 2328& 'This is a waste ' 2329 ierr=2 2330 end if 2331 2332 if (my_rank<res) then 2333 my_start = my_rank *block_p1+1 2334 my_stop = (my_rank+1)*block_p1 2335 else 2336 my_start = res*block_p1 + (my_rank-res )*block + 1 2337 my_stop = res*block_p1 + (my_rank-res+1)*block 2338 end if 2339 2340end subroutine xmpi_split_work_i4b 2341!!*** 2342 2343!---------------------------------------------------------------------- 2344 2345!!****f* m_xmpi/xmpi_split_work2_i4b 2346!! NAME 2347!! xmpi_split_work2_i4b 2348!! 2349!! FUNCTION 2350!! Splits a number of tasks, ntasks, among nprocs processors. 2351!! The output arrays istart(1:nprocs) and istop(1:nprocs) 2352!! report the starting and final task index for each CPU. 2353!! Namely CPU with rank ii has to perform all the tasks between 2354!! istart(ii+1) and istop(ii+1). Note the Fortran convention of using 2355!! 1 as first index of the array. 2356!! Note, moreover, that if a proc has rank>ntasks then : 2357!! istart(rank+1)=ntasks+1 2358!! istop(rank+1)=ntask 2359!! 2360!! In this particular case, loops of the form 2361!! 2362!! do ii=istart(rank),istop(rank) 2363!! ... 2364!! end do 2365!! 2366!! are not executed. Moreover allocation such as foo(istart(rank):istop(rank)) 2367!! will generate a zero-sized array 2368!! 2369!! INPUTS 2370!! ntasks= number of tasks 2371!! nprocs=Number of processors. 2372!! 2373!! OUTPUT 2374!! istart(nprocs),istop(nprocs)= indices defining the initial and final task for each processor 2375!! ierr=Error status. 2376!! warn_msg=String containing the warning message. 2377!! +1 if ntasks is not divisible by nprocs. 2378!! +2 if ntasks>nprocs. 2379!! 2380!! PARENTS 2381!! exc_build_block,m_screening,setup_screening 2382!! 2383!! CHILDREN 2384!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 2385!! 2386!! SOURCE 2387 2388subroutine xmpi_split_work2_i4b(ntasks,nprocs,istart,istop,warn_msg,ierr) 2389 2390 2391!This section has been created automatically by the script Abilint (TD). 2392!Do not modify the following lines by hand. 2393#undef ABI_FUNC 2394#define ABI_FUNC 'xmpi_split_work2_i4b' 2395!End of the abilint section 2396 2397 implicit none 2398 2399!Arguments ------------------------------------ 2400 integer,intent(in) :: ntasks,nprocs 2401 integer,intent(out) :: ierr 2402 integer,intent(inout) :: istart(nprocs),istop(nprocs) 2403 character(len=500),intent(out) :: warn_msg 2404 2405!Local variables------------------------------- 2406 integer :: res,irank,block,block_tmp 2407 2408! ************************************************************************* 2409 2410 block_tmp = ntasks/nprocs 2411 res = MOD(ntasks,nprocs) 2412 block = block_tmp+1 2413 2414 warn_msg = ""; ierr=0 2415 if (res/=0) then 2416 write(warn_msg,'(a,i0,a,i0,2a)')& 2417& 'The number of tasks = ',ntasks,' is not divisible by nprocs = ',nprocs,ch10,& 2418& 'parallelism is not efficient ' 2419 ierr=+1 2420 end if 2421 2422 if (block_tmp==0) then 2423 write(warn_msg,'(a,i0,a,i0,2a)')& 2424& 'The number of processors = ',nprocs,' is larger than number of tasks =',ntasks,ch10,& 2425& 'This is a waste ' 2426 ierr=+2 2427 end if 2428 2429 do irank=0,nprocs-1 2430 if (irank<res) then 2431 istart(irank+1)= irank *block+1 2432 istop (irank+1)=(irank+1)*block 2433 else 2434 istart(irank+1)=res*block+(irank-res )*block_tmp+1 2435 istop (irank+1)=res*block+(irank-res+1)*block_tmp 2436 end if 2437 end do 2438 2439end subroutine xmpi_split_work2_i4b 2440!!*** 2441 2442!---------------------------------------------------------------------- 2443 2444!!****f* m_xmpi/xmpi_split_work2_i8b 2445!! NAME 2446!! xmpi_split_work2_i8b 2447!! 2448!! FUNCTION 2449!! Same as xmpi_split_work2_i8b but accepts 8 bytes integer. 2450!! 2451!! INPUTS 2452!! ntasks= number of tasks 2453!! nprocs=Number of processors. 2454!! 2455!! OUTPUT 2456!! istart(nprocs),istop(nprocs)= indices defining the initial and final task for each processor 2457!! ierr=Error status. 2458!! warn_msg=String containing the warning message. 2459!! +1 if ntasks is not divisible by nprocs. 2460!! +2 if ntasks>nprocs. 2461!! 2462!! PARENTS 2463!! exc_build_block,m_shirley 2464!! 2465!! CHILDREN 2466!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 2467!! 2468!! SOURCE 2469 2470subroutine xmpi_split_work2_i8b(ntasks,nprocs,istart,istop,warn_msg,ierr) 2471 2472 2473!This section has been created automatically by the script Abilint (TD). 2474!Do not modify the following lines by hand. 2475#undef ABI_FUNC 2476#define ABI_FUNC 'xmpi_split_work2_i8b' 2477!End of the abilint section 2478 2479 implicit none 2480 2481!Arguments ------------------------------------ 2482 integer,intent(in) :: nprocs 2483 integer(i8b),intent(in) :: ntasks 2484 integer,intent(out) :: ierr 2485 integer(i8b),intent(inout) :: istart(nprocs),istop(nprocs) 2486 character(len=500),intent(out) :: warn_msg 2487 2488!Local variables------------------------------- 2489 integer(i8b) :: res,irank,block,block_tmp 2490 2491! ************************************************************************* 2492 2493 block_tmp = ntasks/nprocs 2494 res = MOD(ntasks,INT(nprocs,KIND=i8b)) 2495 block = block_tmp+1 2496 2497 warn_msg = ""; ierr=0 2498 if (res/=0) then 2499 write(warn_msg,'(a,i0,a,i0,2a)')& 2500& 'The number of tasks = ',ntasks,' is not divisible by nprocs = ',nprocs,ch10,& 2501& 'parallelism is not efficient ' 2502 ierr=+1 2503 end if 2504 ! 2505 if (block_tmp==0) then 2506 write(warn_msg,'(a,i0,a,i0,2a)')& 2507& ' The number of processors = ',nprocs,' is larger than number of tasks =',ntasks,ch10,& 2508& ' This is a waste ' 2509 ierr=+2 2510 end if 2511 2512 do irank=0,nprocs-1 2513 if (irank<res) then 2514 istart(irank+1)= irank *block+1 2515 istop (irank+1)=(irank+1)*block 2516 else 2517 istart(irank+1)=res*block+(irank-res )*block_tmp+1 2518 istop (irank+1)=res*block+(irank-res+1)*block_tmp 2519 end if 2520 end do 2521 2522end subroutine xmpi_split_work2_i8b 2523!!*** 2524 2525!---------------------------------------------------------------------- 2526 2527!!****f* m_xmpi/xmpi_distab_4D 2528!! NAME 2529!! xmpi_distab_4D 2530!! 2531!! FUNCTION 2532!! Fill table defining the distribution of the tasks according to the number of processors involved in the 2533!! calculation. For each set of indeces, the table contains the rank of the node in the MPI communicator. 2534!! 2535!! INPUTS 2536!! nprocs=The number of processors performing the calculation in parallel. 2537!! 2538!! OUTPUT 2539!! task_distrib(:,:,:,:) = Contains the rank of the node that is taking care of this particular set of loop indeces. 2540!! Tasks are distributed across the nodes in column-major order. 2541!! 2542!! PARENTS 2543!! 2544!! CHILDREN 2545!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 2546!! 2547!! SOURCE 2548 2549subroutine xmpi_distab_4D(nprocs,task_distrib) 2550 2551 2552!This section has been created automatically by the script Abilint (TD). 2553!Do not modify the following lines by hand. 2554#undef ABI_FUNC 2555#define ABI_FUNC 'xmpi_distab_4D' 2556!End of the abilint section 2557 2558 implicit none 2559 2560!Arguments ------------------------------------ 2561 integer,intent(in) :: nprocs 2562!arrays 2563 integer,intent(inout) :: task_distrib(:,:,:,:) 2564 2565!Local variables ------------------------------ 2566!scalars 2567 integer :: ii,jj,n1,n2,n3,n4,ntasks,irank,remainder,ntpblock 2568 integer,allocatable :: list(:) 2569 2570!************************************************************************ 2571 2572 n1= SIZE(task_distrib,DIM=1) 2573 n2= SIZE(task_distrib,DIM=2) 2574 n3= SIZE(task_distrib,DIM=3) 2575 n4= SIZE(task_distrib,DIM=4) 2576 ntasks = n1*n2*n3*n4 2577 2578 ABI_ALLOCATE(list,(ntasks)) 2579 list=-999 2580 2581 ntpblock = ntasks/nprocs 2582 remainder = MOD(ntasks,nprocs) 2583 2584 if (ntpblock==0) then ! nprocs > ntasks 2585 do ii=1,ntasks 2586 list(ii) = ii-1 2587 end do 2588 else 2589 ii=1 2590 do irank=nprocs-1,0,-1 ! If remainder/=0, master will get less tasks. 2591 jj = ii+ntpblock-1 2592 if (remainder>0) then 2593 jj=jj+1 2594 remainder = remainder-1 2595 end if 2596 list(ii:jj)=irank 2597 ii=jj+1 2598 end do 2599 end if 2600 2601 task_distrib = RESHAPE(list,(/n1,n2,n3,n4/)) 2602 2603 if (ANY(task_distrib==-999)) then 2604 call xmpi_abort(msg="task_distrib == -999") 2605 end if 2606 2607 ABI_DEALLOCATE(list) 2608 2609end subroutine xmpi_distab_4D 2610!!*** 2611 2612!---------------------------------------------------------------------- 2613 2614!!****f* m_xmpi/xmpi_distrib_with_replicas 2615!! NAME 2616!! xmpi_distrib_with_replicas 2617!! 2618!! FUNCTION 2619!! This function distributes the i-th task among `nprocs` inside a MPI communicator. 2620!! If nprocs > ntasks, multiple MPI ranks will be assigned to a given task. 2621!! 2622!! INPUTS 2623!! itask=Index of the task (must be <= ntasks) 2624!! ntasks= number of tasks 2625!! rank=MPI Rank of this processor 2626!! nprocs=Number of processors in the MPI communicator. 2627!! 2628!! OUTPUT 2629!! True if this node will treat itask (replicas are possible if nprocs > ntasks) 2630!! 2631!! PARENTS 2632!! 2633!! SOURCE 2634 2635pure function xmpi_distrib_with_replicas(itask,ntasks,rank,nprocs) result(bool) 2636 2637 2638!This section has been created automatically by the script Abilint (TD). 2639!Do not modify the following lines by hand. 2640#undef ABI_FUNC 2641#define ABI_FUNC 'xmpi_distrib_with_replicas' 2642!End of the abilint section 2643 2644 implicit none 2645 2646!Arguments ------------------------------------ 2647!scalars 2648 integer,intent(in) :: itask,rank,nprocs,ntasks 2649 logical :: bool 2650 2651!Local variables------------------------------- 2652!scalars 2653 integer :: ii,mnp_pool,rk_base 2654 2655! ************************************************************************* 2656 2657 ! If the number of processors is less than ntasks, we have max one task per processor, 2658 ! else we replicate the tasks inside a pool of max size mnp_pool 2659 if (nprocs <= ntasks) then 2660 bool = (MODULO(itask-1, nprocs)==rank) 2661 else 2662 mnp_pool = (nprocs / ntasks) 2663 !write(std_out,*)"Will duplicate itasks" 2664 !write(std_out,*)"mnp_pool",mnp_pool,"nprocs, ntasks",nprocs,ntasks 2665 2666 rk_base = MODULO(itask-1, nprocs) 2667 bool = .False. 2668 do ii=1,mnp_pool+1 2669 if (rank == rk_base + (ii-1) * ntasks) then 2670 bool = .True.; exit 2671 end if 2672 end do 2673 end if 2674 2675end function xmpi_distrib_with_replicas 2676!!*** 2677 2678!---------------------------------------------------------------------- 2679 2680! Include files providing wrappers for some of the most commonly used MPI primitives. 2681 2682#include "xmpi_allgather.finc" 2683 2684#include "xmpi_allgatherv.finc" 2685 2686#include "xmpi_alltoall.finc" 2687 2688#include "xmpi_ialltoall.finc" 2689 2690#include "xmpi_alltoallv.finc" 2691 2692#include "xmpi_ialltoallv.finc" 2693 2694#include "xmpi_bcast.finc" 2695 2696#include "xmpi_exch.finc" 2697 2698#include "xmpi_gather.finc" 2699 2700#include "xmpi_gatherv.finc" 2701 2702#include "xmpi_max.finc" 2703 2704#include "xmpi_min.finc" 2705 2706#include "xmpi_recv.finc" 2707 2708#include "xmpi_irecv.finc" 2709 2710#include "xmpi_scatterv.finc" 2711 2712#include "xmpi_send.finc" 2713 2714#include "xmpi_isend.finc" 2715 2716#include "xmpi_sum_master.finc" 2717 2718#include "xmpi_sum.finc" 2719 2720#include "xmpi_isum.finc" 2721 2722#include "xmpi_land_lor.finc" 2723 2724!------------------------------------------------------------------------------------ 2725 2726!!****f* m_xmpi/xmpio_type_struct 2727!! NAME 2728!! xmpio_type_struct 2729!! 2730!! FUNCTION 2731!! Some highly non-standard MPI implementations support MPI-IO without 2732!! implementing the full set of MPI-2 extensions. 2733!! This wrapper will call the obsolete MPI_TYPE_STRUCT if MPI_TYPE_CREATE_STRUCT 2734!! is not supported. Note that MPI_TYPE_STRUCT requires the displacement arrays 2735!! to be an array of default integers whereas the argument block_displ is an array of kind XMPI_ADDRESS_KIND. 2736!! The routine will abort if the displacement cannot be represented with a default integer. 2737!! 2738!! INPUTS 2739!! ncount= number of blocks (integer) --- also number of entries in arrays array_of_types, array_of_displacements and array_of_blocklengths 2740!! array_of_blocklength(ncount)=number of elements in each block (array of integer) 2741!! array_of_displacements(ncount)=byte displacement of each block (array of integer) 2742!! array_of_types(ncount)=type of elements in each block (array of handles to datatype objects) 2743!! 2744!! OUTPUT 2745!! new_type=new datatype (handle) 2746!! mpierr=MPI status error 2747!! 2748!! PARENTS 2749!! m_slk,m_wffile,m_wfk,m_xmpi 2750!! 2751!! CHILDREN 2752!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 2753!! 2754!! SOURCE 2755 2756#ifdef HAVE_MPI_IO 2757 2758subroutine xmpio_type_struct(ncount,block_length,block_displ,block_type,new_type,mpierr) 2759 2760 2761!This section has been created automatically by the script Abilint (TD). 2762!Do not modify the following lines by hand. 2763#undef ABI_FUNC 2764#define ABI_FUNC 'xmpio_type_struct' 2765!End of the abilint section 2766 2767 implicit none 2768 2769!Arguments ------------------------------------ 2770!scalars 2771 integer,intent(in) :: ncount 2772 integer,intent(out) :: new_type,mpierr 2773!arrays 2774 integer,intent(in) :: block_length(ncount),block_type(ncount) 2775 integer(XMPI_ADDRESS_KIND),intent(in) :: block_displ(ncount) 2776 2777!Local variables------------------- 2778#ifndef HAVE_MPI_TYPE_CREATE_STRUCT 2779 integer,allocatable :: tmp_displ(:) 2780#endif 2781 2782!************************************************************************ 2783 2784#ifdef HAVE_MPI_TYPE_CREATE_STRUCT 2785 call MPI_TYPE_CREATE_STRUCT(ncount,block_length,block_displ,block_type,new_type,mpierr) 2786#else 2787 2788 ABI_MALLOC(tmp_displ,(ncount)) 2789 tmp_displ = block_displ 2790 if (ANY(block_displ > HUGE(tmp_displ(1)) ))then 2791 call xmpi_abort(msg=" byte displacement cannot be represented with a default integer") 2792 end if 2793 2794 call MPI_TYPE_STRUCT(ncount,block_length,block_displ,block_type,new_type,mpierr) 2795 ABI_FREE(tmp_displ) 2796#endif 2797 2798end subroutine xmpio_type_struct 2799!!*** 2800 2801#endif 2802 2803!---------------------------------------------------------------------- 2804 2805!!****f* m_xmpi/xmpio_get_info_frm 2806!! NAME 2807!! xmpio_marker_info 2808!! 2809!! FUNCTION 2810!! Return the byte size of the Fortran record and its corresponding MPI_type (compiler-dependent). 2811!! These two values are needed to access sequential binary Fortran files with MPI/IO routines where 2812!! C-streams are used. 2813!! 2814!! INPUTS 2815!! comm=MPI communicator. Only master will find the values for the record marker. The results 2816!! are then broadcast to all the other nodes in comm. 2817!! 2818!! OUTPUT 2819!! bsize_frm=Byte size of the Fortran record marker. 2820!! mpi_type_frm=MPI type of the marker. 2821!! 2822!! PARENTS 2823!! 2824!! SOURCE 2825 2826subroutine xmpio_get_info_frm(bsize_frm,mpi_type_frm,comm) 2827 2828 2829!This section has been created automatically by the script Abilint (TD). 2830!Do not modify the following lines by hand. 2831#undef ABI_FUNC 2832#define ABI_FUNC 'xmpio_get_info_frm' 2833!End of the abilint section 2834 2835 implicit none 2836 2837!Arguments ------------------------------------ 2838!scalars 2839 integer,intent(in) :: comm 2840 integer,intent(out) :: mpi_type_frm,bsize_frm 2841 2842!Local variables------------------------------- 2843 integer :: my_rank 2844#ifdef HAVE_MPI_IO 2845!scalars 2846 integer,parameter :: master=0 2847 integer :: spt,ept,ii 2848 integer :: f90_unt,ierr,iimax,mpio_fh,bsize_int,mpierr 2849 integer(XMPI_OFFSET_KIND) :: offset,rml 2850 character(len=fnlen) :: fname 2851 character(len=500) :: errmsg 2852 logical :: file_exists 2853!arrays 2854 integer :: xvals(2),ivals(100),read_5ivals(5),ref_5ivals(5) 2855 integer :: rm_lengths(4)=(/4,8,2,16/) 2856 integer :: statux(MPI_STATUS_SIZE) 2857 real(dp) :: xrand(fnlen) 2858#endif 2859 2860!************************************************************************ 2861 2862 bsize_frm=0; mpi_type_frm=0 2863 2864 my_rank = xmpi_comm_rank(comm) !; RETURN 2865 2866#ifdef HAVE_MPI_IO 2867 if ( my_rank == master ) then 2868 ! Fortran scratch files cannot have a name so have to generate a random one. 2869 ! cannot use pick_aname since it is higher level. 2870 fname = "__MPI_IO_FRM__" 2871 spt=LEN(trim(fname))+1; ept=spt 2872 2873 inquire(file=trim(fname),exist=file_exists) 2874 2875 do while (file_exists) 2876 call RANDOM_NUMBER(xrand(spt:ept)) 2877 xrand(spt:ept) = 64+xrand(spt:ept)*26 2878 do ii=spt,ept 2879 fname(ii:ii) = ACHAR(NINT(xrand(ii))) 2880 end do 2881 ept = MIN(ept+1,fnlen) 2882 inquire(file=trim(fname),exist=file_exists) 2883 end do 2884 ! 2885 ! Write five integers on the binary file open in Fortran mode, then try 2886 ! to reread the values with MPI-IO using different offsets for the record marker. 2887 ! 2888 f90_unt = xmpi_get_unit() 2889 if (f90_unt == -1) call xmpi_abort(msg="Cannot find free unit!!") 2890 ! MT dec 2013: suppress the new attribute: often cause unwanted errors 2891 ! and theoretically useless because of the previous inquire 2892 open(unit=f90_unt,file=trim(fname),form="unformatted",err=10, iomsg=errmsg) 2893 2894 ref_5ivals = (/(ii, ii=5,9)/) 2895 ivals = HUGE(1); ivals(5:9)=ref_5ivals 2896 write(f90_unt, err=10, iomsg=errmsg) ivals 2897 close(f90_unt, err=10, iomsg=errmsg) 2898 2899 call MPI_FILE_OPEN(xmpi_comm_self, trim(fname), MPI_MODE_RDONLY, MPI_INFO_NULL, mpio_fh,mpierr) 2900 2901 iimax=3 ! Define number of INTEGER types to be tested 2902#ifdef HAVE_FC_INT_QUAD 2903 iimax=4 2904#endif 2905 ! 2906 ! Try to read ivals(5:9) from file. 2907 ii=0; bsize_frm=-1 2908 call MPI_TYPE_SIZE(MPI_INTEGER,bsize_int,mpierr) 2909 2910 do while (bsize_frm<=0 .and. ii<iimax) 2911 ii=ii+1 2912 rml = rm_lengths(ii) 2913 offset = rml + 4 * bsize_int 2914 call MPI_FILE_READ_AT(mpio_fh,offset,read_5ivals,5,MPI_INTEGER,statux,mpierr) 2915 !write(std_out,*)read_5ivals 2916 if (mpierr==MPI_SUCCESS .and. ALL(read_5ivals==ref_5ivals) ) bsize_frm=rml 2917 end do 2918 2919 if (ii==iimax.and.bsize_frm<=0) then 2920 write(std_out,'(7a)') & 2921& 'Error during FORTRAN file record marker detection:',ch10,& 2922& 'It was not possible to read/write a small file!',ch10,& 2923& 'ACTION: check your access permissions to the file system.',ch10,& 2924& 'Common sources of this problem: quota limit exceeded, R/W incorrect permissions, ...' 2925 call xmpi_abort() 2926 else 2927 !write(std_out,'(a,i0)')' Detected FORTRAN record mark length: ',bsize_frm 2928 end if 2929 2930 call MPI_FILE_CLOSE(mpio_fh, mpierr) 2931 ! 2932 ! Select MPI datatype corresponding to the Fortran marker. 2933 SELECT CASE (bsize_frm) 2934 CASE (4) 2935 mpi_type_frm=MPI_INTEGER4 2936 CASE (8) 2937 mpi_type_frm=MPI_INTEGER8 2938#if defined HAVE_FC_INT_QUAD && defined HAVE_MPI_INTEGER16 2939 CASE (16) 2940 mpi_type_frm=MPI_INTEGER16 2941#endif 2942 CASE (2) 2943 mpi_type_frm=MPI_INTEGER2 2944 CASE DEFAULT 2945 write(std_out,'(a,i0)')" Wrong bsize_frm: ",bsize_frm 2946 call xmpi_abort() 2947 END SELECT 2948 2949 open(unit=f90_unt,file=trim(fname), err=10, iomsg=errmsg) 2950 close(f90_unt,status="delete", err=10, iomsg=errmsg) 2951 end if 2952 ! 2953 ! Broadcast data. 2954 xvals = (/bsize_frm,mpi_type_frm/) 2955 call xmpi_bcast(xvals,master,comm,mpierr) 2956 2957 bsize_frm = xvals(1) 2958 mpi_type_frm = xvals(2) 2959 2960 return 2961 2962!HANDLE IO ERROR 296310 continue 2964 call xmpi_abort(msg=errmsg) 2965#endif 2966 2967end subroutine xmpio_get_info_frm 2968!!*** 2969 2970!---------------------------------------------------------------------- 2971 2972!!****f* m_wffile/xmpio_read_frm 2973!! NAME 2974!! xmpio_read_frm 2975!! 2976!! FUNCTION 2977!! Read the content of a single record marker in a FORTRAN file at a given offset using MPI-IO. 2978!! the file pointer is modified according to the value of advance. 2979!! 2980!! INPUTS 2981!! fh=MPI-IO file handler. 2982!! sc_mode= 2983!! xmpio_single ==> for reading by current proc. 2984!! xmpio_collective ==> for collective reading. 2985!! offset=MPI/IO file pointer 2986!! [advance]=By default the routine will move the file pointer to the next record. 2987!! advance=.FALSE. can be used so that the next read will continue picking information 2988!! off of the currect record. 2989!! 2990!! OUTPUT 2991!! fmarker=Content of the Fortran record marker. 2992!! mpierr= MPI error code 2993!! 2994!! SIDE EFFECTS 2995!! offset= 2996!! input: file pointer used to access the Fortran marker. 2997!! output: new offset updated after the reading, depending on advance. 2998!! 2999!! PARENTS 3000!! m_bse_io,m_exc_diago,m_exc_itdiago,m_hdr,m_io_screening,m_xmpi 3001!! 3002!! CHILDREN 3003!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 3004!! 3005!! SOURCE 3006 3007#ifdef HAVE_MPI_IO 3008 3009subroutine xmpio_read_frm(fh,offset,sc_mode,fmarker,mpierr,advance) 3010 3011 3012!This section has been created automatically by the script Abilint (TD). 3013!Do not modify the following lines by hand. 3014#undef ABI_FUNC 3015#define ABI_FUNC 'xmpio_read_frm' 3016!End of the abilint section 3017 3018 implicit none 3019 3020!Arguments ------------------------------------ 3021!scalars 3022 integer,intent(in) :: fh,sc_mode 3023 integer(XMPI_OFFSET_KIND),intent(inout) :: offset 3024 integer(XMPI_OFFSET_KIND),intent(out) :: fmarker 3025 integer,intent(out) :: mpierr 3026 logical,optional,intent(in) :: advance 3027 3028!Local variables------------------------------- 3029!scalars 3030 integer :: bsize_frm,mpi_type_frm,myfh 3031 integer(kind=int16) :: delim_record2 3032 integer(kind=int32) :: delim_record4 3033 integer(kind=int64) :: delim_record8 3034#if defined HAVE_FC_INT_QUAD 3035 integer*16 :: delim_record16 3036#endif 3037 character(len=500) :: msg 3038!arrays 3039 integer :: statux(MPI_STATUS_SIZE) 3040 3041!************************************************************************ 3042 3043 !Workaround for XLF. 3044 myfh = fh 3045 3046 bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker. 3047 mpi_type_frm = xmpio_mpi_type_frm ! MPI type of the record marker. 3048 3049 SELECT CASE (sc_mode) 3050 3051 CASE (xmpio_single) 3052 3053 if (bsize_frm==4) then 3054 call MPI_FILE_READ_AT(myfh,offset,delim_record4,1,mpi_type_frm,statux,mpierr) 3055 fmarker = delim_record4 3056 else if (bsize_frm==8) then 3057 call MPI_FILE_READ_AT(myfh,offset,delim_record8,1,mpi_type_frm,statux,mpierr) 3058 fmarker = delim_record8 3059#if defined HAVE_FC_INT_QUAD 3060 else if (bsize_frm==16) then 3061 call MPI_FILE_READ_AT(myfh,offset,delim_record16,1,mpi_type_frm,statux,mpierr) 3062 fmarker = delim_record16 3063#endif 3064 else if (bsize_frm==2) then 3065 call MPI_FILE_READ_AT(myfh,offset,delim_record2 ,1,mpi_type_frm,statux,mpierr) 3066 fmarker = delim_record2 3067 else 3068 call xmpi_abort(msg='Wrong record marker length!') 3069 end if 3070 3071 CASE (xmpio_collective) 3072 3073 if (bsize_frm==4) then 3074 call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record4 ,1,mpi_type_frm,statux,mpierr) 3075 fmarker = delim_record4 3076 else if (bsize_frm==8) then 3077 call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record8 ,1,mpi_type_frm,statux,mpierr) 3078 fmarker = delim_record8 3079#if defined HAVE_FC_INT_QUAD 3080 else if (bsize_frm==16) then 3081 call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record16,1,mpi_type_frm,statux,mpierr) 3082 fmarker = delim_record16 3083#endif 3084 else if (bsize_frm==2) then 3085 call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record2 ,1,mpi_type_frm,statux,mpierr) 3086 fmarker = delim_record2 3087 else 3088 call xmpi_abort(msg='Wrong record marker length!') 3089 end if 3090 3091 CASE DEFAULT 3092 write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode 3093 call xmpi_abort(msg=msg) 3094 END SELECT 3095 3096 if (PRESENT(advance)) then 3097 if (advance) then 3098 offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record. 3099 else 3100 offset = offset + bsize_frm ! Move the pointer after the marker. 3101 end if 3102 else 3103 offset = offset + fmarker + 2*bsize_frm 3104 end if 3105 3106end subroutine xmpio_read_frm 3107!!*** 3108 3109#endif 3110 3111!------------------------------------------------------------------------------------ 3112 3113!!****f* m_wffile/xmpio_write_frm 3114!! NAME 3115!! xmpio_write_frm 3116!! 3117!! FUNCTION 3118!! Write a single record marker in a FORTRAN file at a given offset using MPI-IO. 3119!! The file pointer is modified according to the value of advance. 3120!! 3121!! INPUTS 3122!! fh=MPI-IO file handler. 3123!! sc_mode= 3124!! xmpio_single ==> for reading by current proc. 3125!! xmpio_collective ==> for collective reading. 3126!! fmarker=The content of the Fortran marker i.e. the size of the record in bytes. 3127!! [advance]=By default the routine will move the file pointer to the next record. 3128!! advance=.FALSE. can be used so that the next write will continue writing data 3129!! on the currect record. 3130!! 3131!! OUTPUT 3132!! mpierr= error code 3133!! 3134!! SIDE EFFECTS 3135!! offset= 3136!! input: offset of the Fortran marker. 3137!! output: new offset updated after the writing, depending on advance. 3138!! 3139!! PARENTS 3140!! m_ioarr 3141!! 3142!! CHILDREN 3143!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 3144!! 3145!! SOURCE 3146 3147#ifdef HAVE_MPI_IO 3148 3149subroutine xmpio_write_frm(fh,offset,sc_mode,fmarker,mpierr,advance) 3150 3151 3152!This section has been created automatically by the script Abilint (TD). 3153!Do not modify the following lines by hand. 3154#undef ABI_FUNC 3155#define ABI_FUNC 'xmpio_write_frm' 3156!End of the abilint section 3157 3158 implicit none 3159 3160!Arguments ------------------------------------ 3161!scalars 3162 integer,intent(in) :: fh,sc_mode 3163 integer(XMPI_OFFSET_KIND),intent(in) :: fmarker 3164 integer(XMPI_OFFSET_KIND),intent(inout) :: offset 3165 integer,intent(out) :: mpierr 3166 logical,optional,intent(in) :: advance 3167 3168!Local variables------------------------------- 3169!scalars 3170 integer :: myfh,bsize_frm,mpi_type_frm 3171 integer(XMPI_OFFSET_KIND) :: last 3172 integer(kind=int16) :: delim_record2 3173 integer(kind=int32) :: delim_record4 3174 integer(kind=int64) :: delim_record8 3175#if defined HAVE_FC_INT_QUAD 3176 integer*16 :: delim_record16 3177#endif 3178 character(len=500) :: msg 3179!arrays 3180 integer :: statux(MPI_STATUS_SIZE) 3181 3182!************************************************************************ 3183 3184 ! Workaround for XLF 3185 myfh = fh 3186 3187 bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker. 3188 mpi_type_frm = xmpio_mpi_type_frm ! MPI type of the record marker. 3189 last = offset + bsize_frm + fmarker ! position of the end marker 3190 3191 SELECT CASE (sc_mode) 3192 3193 CASE (xmpio_single) 3194 if (bsize_frm==4) then 3195 delim_record4 = fmarker 3196 call MPI_FILE_WRITE_AT(myfh,offset,delim_record4 ,1,mpi_type_frm,statux,mpierr) 3197 call MPI_FILE_WRITE_AT(myfh,last,delim_record4 ,1,mpi_type_frm,statux,mpierr) 3198 3199 else if (bsize_frm==8) then 3200 delim_record8 = fmarker 3201 call MPI_FILE_WRITE_AT(myfh,offset,delim_record8 ,1,mpi_type_frm,statux,mpierr) 3202 call MPI_FILE_WRITE_AT(myfh,last,delim_record8 ,1,mpi_type_frm,statux,mpierr) 3203#if defined HAVE_FC_INT_QUAD 3204 else if (bsize_frm==16) then 3205 delim_record16 = fmarker 3206 call MPI_FILE_WRITE_AT(myfh,offset,delim_record16,1,mpi_type_frm,statux,mpierr) 3207 call MPI_FILE_WRITE_AT(myfh,last,delim_record16 ,1,mpi_type_frm,statux,mpierr) 3208#endif 3209 else if (bsize_frm==2) then 3210 delim_record2 = fmarker 3211 call MPI_FILE_WRITE_AT(myfh,offset,delim_record2, 1,mpi_type_frm,statux,mpierr) 3212 call MPI_FILE_WRITE_AT(myfh,last,delim_record2 ,1,mpi_type_frm,statux,mpierr) 3213 else 3214 call xmpi_abort(msg='Wrong record marker length!') 3215 end if 3216 3217 CASE (xmpio_collective) 3218 if (bsize_frm==4) then 3219 delim_record4 = fmarker 3220 call MPI_FILE_WRITE_AT_ALL(myfh,offset,delim_record4 ,1,mpi_type_frm,statux,mpierr) 3221 call MPI_FILE_WRITE_AT_ALL(myfh,last,delim_record4 ,1,mpi_type_frm,statux,mpierr) 3222 else if (bsize_frm==8) then 3223 delim_record8 = fmarker 3224 call MPI_FILE_WRITE_AT_ALL(myfh,offset,delim_record8 ,1,mpi_type_frm,statux,mpierr) 3225 call MPI_FILE_WRITE_AT_ALL(myfh,last,delim_record8 ,1,mpi_type_frm,statux,mpierr) 3226#if defined HAVE_FC_INT_QUAD 3227 else if (bsize_frm==16) then 3228 delim_record16 = fmarker 3229 call MPI_FILE_WRITE_AT_ALL(myfh,offset,delim_record16,1,mpi_type_frm,statux,mpierr) 3230 call MPI_FILE_WRITE_AT_ALL(myfh,last,delim_record16 ,1,mpi_type_frm,statux,mpierr) 3231#endif 3232 else if (bsize_frm==2) then 3233 delim_record2 = fmarker 3234 call MPI_FILE_WRITE_AT_ALL(myfh,offset,delim_record2 ,1,mpi_type_frm,statux,mpierr) 3235 call MPI_FILE_WRITE_AT_ALL(myfh,last,delim_record2 ,1,mpi_type_frm,statux,mpierr) 3236 else 3237 call xmpi_abort(msg='Wrong record marker length!') 3238 end if 3239 3240 CASE DEFAULT 3241 write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode 3242 call xmpi_abort(msg=msg) 3243 END SELECT 3244 3245 if (PRESENT(advance)) then 3246 if (advance) then 3247 offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record. 3248 else 3249 offset = offset + bsize_frm ! Move the pointer after the marker. 3250 end if 3251 else 3252 offset = offset + fmarker + 2*bsize_frm 3253 end if 3254 3255end subroutine xmpio_write_frm 3256!!*** 3257#endif 3258 3259!------------------------------------------------------------------------------------ 3260 3261!!****f* m_xmpi/xmpio_create_fstripes 3262!! NAME 3263!! xmpio_create_fstripes 3264!! 3265!! FUNCTION 3266!! Return a MPI type that can be used to (read|write) a set of interleaved Fortran records. 3267!! 3268!! <FRM> type(1), type(1), ... <FRM> ! size(1) elements 3269!! <FRM> type(2), type(2), ... <FRM> ! size(2) elements 3270!! <FRM> type(1), type(1), ... <FRM> ! size(1) elements 3271!! .... 3272!! 3273!! INPUTS 3274!! ncount = Number of records with elements of type types(1) to (read|write) 3275!! sizes(1:2) = Number of elements of each type in the two sets of record 3276!! type(1:2) = MPI Type of the elements in the first and in the second record. 3277!! 3278!! OUTPUT 3279!! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record 3280!! marker individuating the beginning of the matrix. (lets call it "base"). 3281!! Each node should (read|write) using my_offset = base + my_offpad. 3282!! my_offpad is used so that one can safely change the way the fileview is generated (for example 3283!! to make it more efficient) without having to change the client code. 3284!! new_type=New MPI type. 3285!! mpierr= MPI error code 3286!! 3287!! PARENTS 3288!! m_wfk 3289!! 3290!! CHILDREN 3291!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 3292!! 3293!! SOURCE 3294 3295#ifdef HAVE_MPI_IO 3296 3297subroutine xmpio_create_fstripes(ncount,sizes,types,new_type,my_offpad,mpierr) 3298 3299 3300!This section has been created automatically by the script Abilint (TD). 3301!Do not modify the following lines by hand. 3302#undef ABI_FUNC 3303#define ABI_FUNC 'xmpio_create_fstripes' 3304!End of the abilint section 3305 3306 implicit none 3307 3308!Arguments ------------------------------------ 3309!scalars 3310 integer,intent(in) :: ncount 3311 integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad 3312 integer,intent(out) :: new_type,mpierr 3313!arrays 3314 integer,intent(in) :: types(2),sizes(2) 3315 3316!Local variables------------------------------- 3317!scalars 3318 integer :: type_x,type_y,bsize_frm,bsize_x,bsize_y,nx,ny,column_type 3319 integer(MPI_ADDRESS_KIND) :: stride 3320 3321!************************************************************************ 3322 3323 ! Byte size of the Fortran record marker. 3324 bsize_frm = xmpio_bsize_frm 3325 3326 ! Number of elements in the two stripes. 3327 nx = sizes(1) 3328 ny = sizes(2) 3329 3330 type_x = types(1) 3331 type_y = types(2) 3332 3333 ! Byte size of type_x and type_y 3334 call MPI_TYPE_SIZE(type_x,bsize_x,mpierr) 3335 ABI_HANDLE_MPIERR(mpierr) 3336 3337 call MPI_TYPE_SIZE(type_y,bsize_y,mpierr) 3338 ABI_HANDLE_MPIERR(mpierr) 3339 3340 ! The view starts at the first element of the first stripe. 3341 my_offpad = xmpio_bsize_frm 3342 3343 call MPI_Type_contiguous(nx,type_x,column_type,mpierr) 3344 ABI_HANDLE_MPIERR(mpierr) 3345 3346 ! Byte size of the Fortran record + the two markers. 3347 stride = nx*bsize_x + 2*bsize_frm + ny*bsize_y + 2*bsize_frm 3348 3349 ! ncount colum_type separated by stride bytes 3350 call MPI_Type_create_hvector(ncount,1,stride,column_type,new_type,mpierr) 3351 ABI_HANDLE_MPIERR(mpierr) 3352 3353 call MPI_TYPE_COMMIT(new_type,mpierr) 3354 ABI_HANDLE_MPIERR(mpierr) 3355 3356 call MPI_TYPE_FREE(column_type,mpierr) 3357 ABI_HANDLE_MPIERR(mpierr) 3358 3359end subroutine xmpio_create_fstripes 3360!!*** 3361#endif 3362 3363!------------------------------------------------------------------------------------ 3364 3365!!****f* m_xmpi/xmpio_create_fsubarray_2D 3366!! NAME 3367!! xmpio_create_fsubarray_2D 3368!! 3369!! FUNCTION 3370!! Return a MPI type that can be used to (read|write) a 2D matrix of elements of type old_type stored in a Fortran file. 3371!! 3372!! INPUTS 3373!! sizes(2)=number of elements of type old_type in each dimension of the full array (array of positive integers) 3374!! subsizes(2)=number of elements of type old_type in each dimension of the subarray (array of positive integers) 3375!! array_of_starts(2)=starting coordinates of the subarray in each dimension (array of nonnegative integers >=1, <=sizes) 3376!! old_type=Old MPI type. 3377!! 3378!! OUTPUT 3379!! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record 3380!! marker individuating the beginning of the matrix. (lets call it "base"). 3381!! Each node should (read|write) using my_offset = base + my_offpad. 3382!! my_offpad is used so that one can safely change the way the fileview is generated (for example 3383!! to make it more efficient) without having to change the client code. 3384!! new_type=New MPI type. 3385!! mpierr= MPI error code 3386!! 3387!! PARENTS 3388!! exc_build_block,m_exc_itdiago,m_mpiotk,m_wfk 3389!! 3390!! CHILDREN 3391!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 3392!! 3393!! SOURCE 3394 3395#ifdef HAVE_MPI_IO 3396 3397subroutine xmpio_create_fsubarray_2D(sizes,subsizes,array_of_starts,old_type,new_type,my_offpad,mpierr) 3398 3399 3400!This section has been created automatically by the script Abilint (TD). 3401!Do not modify the following lines by hand. 3402#undef ABI_FUNC 3403#define ABI_FUNC 'xmpio_create_fsubarray_2D' 3404!End of the abilint section 3405 3406 implicit none 3407 3408!Arguments ------------------------------------ 3409!scalars 3410 integer,intent(in) :: old_type 3411 integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad 3412 integer,intent(out) :: mpierr,new_type 3413!arrays 3414 integer,intent(in) :: sizes(2),subsizes(2),array_of_starts(2) 3415!Local variables------------------------------- 3416!scalars 3417 integer :: bsize_frm,bsize_old,nx,ny 3418 integer :: column_type,ldx 3419 integer(XMPI_OFFSET_KIND) :: st_x,st_y 3420 integer(MPI_ADDRESS_KIND) :: stride_x 3421 !character(len=500) :: msg 3422 3423!************************************************************************ 3424 3425 ! Byte size of the Fortran record marker. 3426 bsize_frm = xmpio_bsize_frm 3427 3428 ! Byte size of old_type. 3429 call MPI_TYPE_SIZE(old_type,bsize_old,mpierr) 3430 ABI_HANDLE_MPIERR(mpierr) 3431 ! 3432 ! Number of columns and rows of the submatrix. 3433 nx = subsizes(1) 3434 ny = subsizes(2) 3435 3436 ldx = sizes(1) 3437 st_x = array_of_starts(1) 3438 st_y = array_of_starts(2) 3439 3440 ! The view starts at the first element of the submatrix. 3441 my_offpad = (st_x-1)*bsize_old + (st_y-1)*(ldx*bsize_old+2*xmpio_bsize_frm) + xmpio_bsize_frm 3442 3443 ! Byte size of the Fortran record + the two markers. 3444 stride_x = ldx*bsize_old + 2*bsize_frm 3445 3446 call MPI_Type_contiguous(nx,old_type,column_type,mpierr) 3447 ABI_HANDLE_MPIERR(mpierr) 3448 3449 call MPI_Type_create_hvector(ny,1,stride_x,column_type,new_type,mpierr) 3450 ABI_HANDLE_MPIERR(mpierr) 3451 3452 call MPI_TYPE_COMMIT(new_type,mpierr) 3453 ABI_HANDLE_MPIERR(mpierr) 3454 3455 call MPI_TYPE_FREE(column_type, mpierr) 3456 ABI_HANDLE_MPIERR(mpierr) 3457 3458end subroutine xmpio_create_fsubarray_2D 3459!!*** 3460#endif 3461 3462!------------------------------------------------------------------------------------ 3463 3464!!****f* m_xmpi/xmpio_create_fsubarray_3D 3465!! NAME 3466!! xmpio_create_fsubarray_3D 3467!! 3468!! FUNCTION 3469!! Return a MPI type that can be used to (read|write) a 3D matrix of elements of type old_type stored in a Fortran file. 3470!! 3471!! INPUTS 3472!! sizes(3)=number of elements of type old_type in each dimension of the full array (array of positive integers) 3473!! subsizes(3)=number of elements of type old_type in each dimension of the subarray (array of positive integers) 3474!! array_of_starts(3)=starting coordinates of the subarray in each dimension (array of nonnegative integers >=1, <=sizes) 3475!! old_type=Old MPI type. 3476!! 3477!! OUTPUT 3478!! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record 3479!! marker individuating the beginning of the matrix. (lets call it "base"). 3480!! Each node should (read|write) using my_offset = base + my_offpad. 3481!! my_offpad is used so that one can safely change the way the fileview is generated (for example 3482!! to make it more efficient) without having to change the client code. 3483!! new_type=New MPI type. 3484!! mpierr= MPI error code 3485!! 3486!! PARENTS 3487!! m_mpiotk 3488!! 3489!! CHILDREN 3490!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 3491!! 3492!! SOURCE 3493 3494#ifdef HAVE_MPI_IO 3495 3496subroutine xmpio_create_fsubarray_3D(sizes,subsizes,array_of_starts,old_type,new_type,my_offpad,mpierr) 3497 3498 3499!This section has been created automatically by the script Abilint (TD). 3500!Do not modify the following lines by hand. 3501#undef ABI_FUNC 3502#define ABI_FUNC 'xmpio_create_fsubarray_3D' 3503!End of the abilint section 3504 3505 implicit none 3506 3507!Arguments ------------------------------------ 3508!scalars 3509 integer,intent(in) :: old_type 3510 integer,intent(out) :: mpierr,new_type 3511 integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad 3512!arrays 3513 integer,intent(in) :: sizes(3),subsizes(3),array_of_starts(3) 3514!Local variables------------------------------- 3515!scalars 3516 integer :: bsize_frm,bsize_old,nx,ny,nz 3517 integer :: column_type,plane_type,ldx,ldy,ldz 3518 integer(XMPI_OFFSET_KIND) :: st_x,st_y,st_z 3519 integer(MPI_ADDRESS_KIND) :: stride_x 3520 !character(len=500) :: msg 3521 3522!************************************************************************ 3523 3524 bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker. 3525 3526 ! Byte size of old_type. 3527 call MPI_TYPE_SIZE(old_type,bsize_old,mpierr) 3528 ABI_HANDLE_MPIERR(mpierr) 3529 ! 3530 ! Number of columns and rows of the submatrix. 3531 nx = subsizes(1) 3532 ny = subsizes(2) 3533 nz = subsizes(3) 3534 3535 ldx = sizes(1) 3536 ldy = sizes(2) 3537 ldz = sizes(3) 3538 3539 st_x = array_of_starts(1) 3540 st_y = array_of_starts(2) 3541 st_z = array_of_starts(3) 3542 3543 ! The view starts at the first element of the submatrix. 3544 my_offpad = (st_x-1)*bsize_old + & 3545& (st_y-1)* (ldx*bsize_old+2*xmpio_bsize_frm) + & 3546& (st_z-1)*ldy*(ldx*bsize_old+2*xmpio_bsize_frm) + & 3547& xmpio_bsize_frm 3548 3549 ! Byte size of the Fortran record + the two markers. 3550 stride_x = ldx*bsize_old + 2*bsize_frm 3551 3552 call MPI_Type_contiguous(nx,old_type,column_type,mpierr) 3553 ABI_HANDLE_MPIERR(mpierr) 3554 3555 call MPI_Type_create_hvector(ny,1,stride_x,column_type,plane_type,mpierr) 3556 ABI_HANDLE_MPIERR(mpierr) 3557 3558 call MPI_Type_create_hvector(nz,1,ldy*stride_x,plane_type,new_type,mpierr) 3559 ABI_HANDLE_MPIERR(mpierr) 3560 3561 ! Commit the datatype 3562 call MPI_TYPE_COMMIT(new_type,mpierr) 3563 ABI_HANDLE_MPIERR(mpierr) 3564 3565 ! Free memory 3566 call MPI_TYPE_FREE(plane_type, mpierr) 3567 ABI_HANDLE_MPIERR(mpierr) 3568 3569end subroutine xmpio_create_fsubarray_3D 3570!!*** 3571#endif 3572 3573!------------------------------------------------------------------------------------ 3574 3575!!****f* m_xmpi/xmpio_create_fsubarray_4D 3576!! NAME 3577!! xmpio_create_fsubarray_4D 3578!! 3579!! FUNCTION 3580!! Return a MPI type that can be used to (read|write) a 2D matrix of elements of type old_type stored in a Fortran file. 3581!! 3582!! INPUTS 3583!! sizes(4)=number of elements of type old_type in each dimension of the full array (array of positive integers) 3584!! subsizes(4)=number of elements of type old_type in each dimension of the subarray (array of positive integers) 3585!! array_of_starts(4)=starting coordinates of the subarray in each dimension (array of nonnegative integers >=1, <=sizes) 3586!! old_type=Old MPI type. 3587!! 3588!! OUTPUT 3589!! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record 3590!! marker individuating the beginning of the matrix. (lets call it "base"). 3591!! Each node should (read|write) using my_offset = base + my_offpad. 3592!! my_offpad is used so that one can safely change the way the fileview is generated (for example 3593!! to make it more efficient) without having to change the client code. 3594!! new_type=New MPI type. 3595!! mpierr= MPI error code 3596!! 3597!! PARENTS 3598!! m_mpiotk 3599!! 3600!! CHILDREN 3601!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 3602!! 3603!! SOURCE 3604 3605#ifdef HAVE_MPI_IO 3606 3607subroutine xmpio_create_fsubarray_4D(sizes,subsizes,array_of_starts,old_type,new_type,my_offpad,mpierr) 3608 3609 3610!This section has been created automatically by the script Abilint (TD). 3611!Do not modify the following lines by hand. 3612#undef ABI_FUNC 3613#define ABI_FUNC 'xmpio_create_fsubarray_4D' 3614!End of the abilint section 3615 3616 implicit none 3617 3618!Arguments ------------------------------------ 3619!scalars 3620 integer,intent(in) :: old_type 3621 integer,intent(out) :: mpierr,new_type 3622 integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad 3623!arrays 3624 integer,intent(in) :: sizes(4),subsizes(4),array_of_starts(4) 3625 3626!Local variables------------------------------- 3627!scalars 3628 integer :: bsize_frm,bsize_old,nx,ny,nz,na 3629 integer :: column_type,plane_type,ldx,ldy,ldz,lda,vol_type 3630 integer(XMPI_OFFSET_KIND) :: st_x,st_y,st_z,st_a 3631 integer(MPI_ADDRESS_KIND) :: stride_x 3632 3633!************************************************************************ 3634 3635 bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker. 3636 3637 ! Byte size of old_type. 3638 call MPI_TYPE_SIZE(old_type,bsize_old,mpierr) 3639 ABI_HANDLE_MPIERR(mpierr) 3640 ! 3641 ! Number of columns and rows of the submatrix. 3642 nx = subsizes(1) 3643 ny = subsizes(2) 3644 nz = subsizes(3) 3645 na = subsizes(4) 3646 3647 ldx = sizes(1) 3648 ldy = sizes(2) 3649 ldz = sizes(3) 3650 lda = sizes(4) 3651 3652 st_x = array_of_starts(1) 3653 st_y = array_of_starts(2) 3654 st_z = array_of_starts(3) 3655 st_a = array_of_starts(4) 3656 3657 ! The view starts at the first element of the submatrix. 3658 my_offpad = (st_x-1)*bsize_old + & 3659& (st_y-1)* (ldx*bsize_old+2*xmpio_bsize_frm) + & 3660& (st_z-1)*ldy* (ldx*bsize_old+2*xmpio_bsize_frm) + & 3661& (st_a-1)*lda*ldy*(ldx*bsize_old+2*xmpio_bsize_frm) + & 3662& xmpio_bsize_frm 3663 3664 ! Byte size of the Fortran record + the two markers. 3665 stride_x = ldx*bsize_old + 2*bsize_frm 3666 3667 call MPI_Type_contiguous(nx,old_type,column_type,mpierr) 3668 ABI_HANDLE_MPIERR(mpierr) 3669 3670 call MPI_Type_create_hvector(ny,1,stride_x,column_type,plane_type,mpierr) 3671 ABI_HANDLE_MPIERR(mpierr) 3672 3673 call MPI_Type_create_hvector(nz,1,ldy*stride_x,plane_type,vol_type,mpierr) 3674 ABI_HANDLE_MPIERR(mpierr) 3675 3676 call MPI_Type_create_hvector(na,1,ldz*ldy*stride_x,vol_type,new_type,mpierr) 3677 ABI_HANDLE_MPIERR(mpierr) 3678 3679 ! Commit the datatype 3680 call MPI_TYPE_COMMIT(new_type,mpierr) 3681 ABI_HANDLE_MPIERR(mpierr) 3682 3683 ! Free memory 3684 call MPI_TYPE_FREE(column_type, mpierr) 3685 ABI_HANDLE_MPIERR(mpierr) 3686 3687 call MPI_TYPE_FREE(plane_type, mpierr) 3688 ABI_HANDLE_MPIERR(mpierr) 3689 3690 call MPI_TYPE_FREE(vol_type, mpierr) 3691 ABI_HANDLE_MPIERR(mpierr) 3692 3693end subroutine xmpio_create_fsubarray_4D 3694!!*** 3695#endif 3696 3697!------------------------------------------------------------------------------------ 3698 3699!!****f* m_xmpi/xmpio_check_frmarkers 3700!! NAME 3701!! xmpio_check_frmarkers 3702!! 3703!! FUNCTION 3704!! Check a set of Fortran record markers starting at a given offset using MPI-IO. 3705!! 3706!! INPUTS 3707!! fh=MPI-IO file handler. 3708!! offset=MPI-IO file pointer 3709!! sc_mode=Option for individual or collective reading. 3710!! nfrec=Number of Fortran records to be checked. 3711!! bsize_frecord(nfrec)=Byte size of the Fortran records (markers are NOT included) 3712!! These values will be compared with the markers reported in the file. 3713!! 3714!! OUTPUT 3715!! ierr=A non-zero error code signals failure. 3716!! 3717!! PARENTS 3718!! m_bse_io,m_exc_itdiago,m_slk,m_wfk 3719!! 3720!! CHILDREN 3721!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 3722!! 3723!! SOURCE 3724 3725#ifdef HAVE_MPI_IO 3726 3727subroutine xmpio_check_frmarkers(fh,offset,sc_mode,nfrec,bsize_frecord,ierr) 3728 3729 3730!This section has been created automatically by the script Abilint (TD). 3731!Do not modify the following lines by hand. 3732#undef ABI_FUNC 3733#define ABI_FUNC 'xmpio_check_frmarkers' 3734!End of the abilint section 3735 3736 implicit none 3737 3738!Arguments ------------------------------------ 3739!scalars 3740 integer,intent(in) :: fh,nfrec,sc_mode 3741 integer(XMPI_OFFSET_KIND),intent(in) :: offset 3742 integer,intent(out) :: ierr 3743!arrays 3744 integer(XMPI_OFFSET_KIND),intent(in) :: bsize_frecord(nfrec) 3745 3746!Local variables------------------------------- 3747!scalars 3748 integer :: nb,irec,frmarkers_type,jj,bsize_frm,mpi_type_frm,mpierr,myfh 3749 integer(XMPI_OFFSET_KIND) :: displ 3750!arrays 3751 integer(kind=int16),allocatable :: bufdelim2(:) 3752 integer(kind=int32),allocatable :: bufdelim4(:) 3753 integer(kind=int64),allocatable :: bufdelim8(:) 3754#ifdef HAVE_FC_INT_QUAD 3755 integer*16,allocatable :: bufdelim16(:) 3756#endif 3757!integer :: statux(MPI_STATUS_SIZE) 3758 integer,allocatable :: block_length(:),block_type(:) 3759 integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:) 3760 integer(XMPI_OFFSET_KIND),allocatable :: delim_record(:) 3761 3762!************************************************************************ 3763 3764 ! Workaround for XLF 3765 myfh = fh 3766 3767 ierr=0 3768 3769 bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker. 3770 mpi_type_frm = xmpio_mpi_type_frm ! MPI type of the record marker. 3771 ! 3772 ! Define the view for the file. 3773 nb=2*nfrec 3774 ABI_MALLOC(block_length,(nb+2)) 3775 ABI_MALLOC(block_displ,(nb+2)) 3776 ABI_MALLOC(block_type,(nb+2)) 3777 block_length(1)=1 3778 block_displ (1)=0 3779 block_type (1)=MPI_LB 3780 3781 jj=2; displ=0 3782 do irec=1,nfrec 3783 block_type (jj:jj+1) =mpi_type_frm 3784 block_length(jj:jj+1)=1 3785 block_displ(jj ) = displ 3786 block_displ(jj+1) = bsize_frm + displ + bsize_frecord(irec) 3787 jj=jj+2 3788 displ = displ + bsize_frecord(irec) + 2*bsize_frm ! Move to the beginning of the next column. 3789 if (xmpio_max_address(displ)) ierr=-1 ! Check for wraparound. 3790 end do 3791 3792 block_length(nb+2)=1 3793 block_displ (nb+2)=displ 3794 block_type (nb+2)=MPI_UB 3795 3796 call xmpio_type_struct(nb+2,block_length,block_displ,block_type,frmarkers_type,mpierr) 3797 ABI_FREE(block_length) 3798 ABI_FREE(block_displ) 3799 ABI_FREE(block_type) 3800 3801 call MPI_TYPE_COMMIT(frmarkers_type,mpierr) 3802 call MPI_FILE_SET_VIEW(myfh,offset,MPI_BYTE,frmarkers_type,"native",MPI_INFO_NULL,mpierr) 3803 3804 jj=1 3805 ABI_MALLOC(delim_record,(nb)) 3806 do irec=1,nfrec 3807 delim_record(jj:jj+1)=bsize_frecord(irec) 3808 jj=jj+2 3809 end do 3810 3811 ! Read markers according to the MPI type of the Fortran marker. 3812 SELECT CASE (bsize_frm) 3813 3814 CASE (4) 3815 ABI_MALLOC(bufdelim4,(nb)) 3816 if (sc_mode==xmpio_single) then 3817 call MPI_FILE_READ (myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 3818 else if (sc_mode==xmpio_collective) then 3819 call MPI_FILE_READ_ALL(myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 3820 else 3821 ierr=2 3822 end if 3823 if (ANY(bufdelim4/=delim_record)) ierr=1 3824 !if (ierr==1) then 3825 ! do irec=1,2*nfrec 3826 ! write(std_out,*)"irec, bufdelim4, delim_record: ",irec,bufdelim4(irec),delim_record(irec) 3827 ! end do 3828 !end if 3829 ABI_FREE(bufdelim4) 3830 3831 CASE (8) 3832 ABI_MALLOC(bufdelim8,(nb)) 3833 if (sc_mode==xmpio_single) then 3834 call MPI_FILE_READ (myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 3835 else if (sc_mode==xmpio_collective) then 3836 call MPI_FILE_READ_ALL(myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 3837 else 3838 ierr=2 3839 end if 3840 if (ANY(bufdelim8/=delim_record)) ierr=1 3841 ABI_FREE(bufdelim8) 3842 3843#ifdef HAVE_FC_INT_QUAD 3844 CASE (16) 3845 ABI_MALLOC(bufdelim16,(nb)) 3846 if (sc_mode==xmpio_single) then 3847 call MPI_FILE_READ (myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 3848 else if (sc_mode==xmpio_collective) then 3849 call MPI_FILE_READ_ALL(myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 3850 else 3851 ierr=2 3852 end if 3853 if (ANY(bufdelim16/=delim_record)) ierr=1 3854 ABI_FREE(bufdelim16) 3855#endif 3856 3857 CASE (2) 3858 ABI_MALLOC(bufdelim2,(nb)) 3859 if (sc_mode==xmpio_single) then 3860 call MPI_FILE_READ (myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 3861 else if (sc_mode==xmpio_collective) then 3862 call MPI_FILE_READ_ALL(myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 3863 else 3864 ierr=2 3865 end if 3866 if (ANY(bufdelim2/=delim_record)) ierr=1 3867 ABI_FREE(bufdelim2) 3868 3869 CASE DEFAULT 3870 ierr=-2 3871 END SELECT 3872 3873 ! Free memory 3874 call MPI_TYPE_FREE(frmarkers_type,mpierr) 3875 ABI_FREE(delim_record) 3876 3877end subroutine xmpio_check_frmarkers 3878!!*** 3879#endif 3880 3881!---------------------------------------------------------------------- 3882 3883!!****f* m_xmpi/xmpio_read_int 3884!! NAME 3885!! xmpio_read_int 3886!! 3887!! FUNCTION 3888!! Read the content of a single record marker in a FORTRAN file at a given offset using MPI-IO. 3889!! the file pointer is modified according to the value of advance. 3890!! target: integer array 3891!! 3892!! INPUTS 3893!! fh=MPI-IO file handler. 3894!! offset=MPI-IO file pointer 3895!! sc_mode= 3896!! xmpio_single ==> for reading by current proc. 3897!! xmpio_collective ==> for collective reading. 3898!! ncount=Number of elements in the buffer 3899!! [advance]=By default the routine will move the file pointer to the next record. 3900!! advance=.FALSE. can be used so that the next read will continue picking information 3901!! off of the currect record. 3902!! 3903!! OUTPUT 3904!! buf(ncount)=array with the values read from file 3905!! fmarker=Content of the Fortran record marker. 3906!! mpierr= MPI error code 3907!! 3908!! SIDE EFFECTS 3909!! offset= 3910!! input: file pointer used to access the Fortran marker. 3911!! output: new offset updated after the reading, depending on advance. 3912!! 3913!! PARENTS 3914!! 3915!! CHILDREN 3916!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 3917!! 3918!! SOURCE 3919 3920#ifdef HAVE_MPI_IO 3921 3922subroutine xmpio_read_int(fh,offset,sc_mode,ncount,buf,fmarker,mpierr,advance) 3923 3924 3925!This section has been created automatically by the script Abilint (TD). 3926!Do not modify the following lines by hand. 3927#undef ABI_FUNC 3928#define ABI_FUNC 'xmpio_read_int' 3929!End of the abilint section 3930 3931 implicit none 3932 3933!Arguments ------------------------------------ 3934!scalars 3935 integer,intent(in) :: fh,sc_mode,ncount 3936 integer(XMPI_OFFSET_KIND),intent(inout) :: offset 3937 integer(XMPI_OFFSET_KIND),intent(out) :: fmarker 3938 integer,intent(out) :: mpierr 3939 logical,optional,intent(in) :: advance 3940!arrays 3941 integer,intent(out) :: buf(ncount) 3942 3943!Local variables------------------------------- 3944!scalars 3945 integer :: myfh,bsize_frm 3946 integer(XMPI_OFFSET_KIND) :: my_offset 3947 character(len=500) :: msg 3948!arrays 3949 integer :: statux(MPI_STATUS_SIZE) 3950 3951!************************************************************************ 3952 3953 ! Workaround for XLF 3954 myfh = fh 3955 3956 my_offset = offset 3957 bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker. 3958 3959 call xmpio_read_frm(myfh,my_offset,sc_mode,fmarker,mpierr,advance=.FALSE.) 3960 3961 SELECT CASE (sc_mode) 3962 CASE (xmpio_single) 3963 call MPI_FILE_READ_AT(myfh, my_offset, buf, ncount, MPI_INTEGER, statux, mpierr) 3964 3965 CASE (xmpio_collective) 3966 call MPI_FILE_READ_AT_ALL(myfh, my_offset, buf, ncount, MPI_INTEGER, statux, mpierr) 3967 3968 CASE DEFAULT 3969 write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode 3970 call xmpi_abort(msg=msg) 3971 END SELECT 3972 3973 if (PRESENT(advance)) then 3974 if (advance) then 3975 offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record. 3976 else 3977 offset = offset + bsize_frm ! Move the pointer after the marker. 3978 end if 3979 else 3980 offset = offset + fmarker + 2*bsize_frm 3981 end if 3982 3983end subroutine xmpio_read_int 3984!!*** 3985#endif 3986 3987!---------------------------------------------------------------------- 3988 3989!!****f* m_xmpi/xmpio_read_dp 3990!! NAME 3991!! xmpio_read_dp 3992!! 3993!! FUNCTION 3994!! Read the content of a single record marker in a FORTRAN file at a given offset using MPI-IO. 3995!! the file pointer is modified according to the value of advance. 3996!! targer: double precision real array 3997!! 3998!! INPUTS 3999!! fh=MPI-IO file handler. 4000!! offset=MPI-IO file pointer 4001!! sc_mode= 4002!! xmpio_single ==> for reading by current proc. 4003!! xmpio_collective ==> for collective reading. 4004!! ncount=Number of elements in the buffer 4005!! [advance]=By default the routine will move the file pointer to the next record. 4006!! advance=.FALSE. can be used so that the next read will continue picking information 4007!! off of the currect record. 4008!! 4009!! OUTPUT 4010!! buf(ncount)=array with the values read from file 4011!! fmarker=Content of the Fortran record marker. 4012!! mpierr= MPI error code 4013!! 4014!! SIDE EFFECTS 4015!! offset= 4016!! input: file pointer used to access the Fortran marker. 4017!! output: new offset updated after the reading, depending on advance. 4018!! 4019!! PARENTS 4020!! 4021!! CHILDREN 4022!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 4023!! 4024!! SOURCE 4025 4026#ifdef HAVE_MPI_IO 4027 4028subroutine xmpio_read_dp(fh,offset,sc_mode,ncount,buf,fmarker,mpierr,advance) 4029 4030 4031!This section has been created automatically by the script Abilint (TD). 4032!Do not modify the following lines by hand. 4033#undef ABI_FUNC 4034#define ABI_FUNC 'xmpio_read_dp' 4035!End of the abilint section 4036 4037 implicit none 4038 4039!Arguments ------------------------------------ 4040!scalars 4041 integer,intent(in) :: fh,sc_mode,ncount 4042 integer(XMPI_OFFSET_KIND),intent(inout) :: offset 4043 integer(XMPI_OFFSET_KIND),intent(out) :: fmarker 4044 integer,intent(out) :: mpierr 4045 logical,optional,intent(in) :: advance 4046!arrays 4047 real(dp),intent(out) :: buf(ncount) 4048 4049!Local variables------------------------------- 4050!scalars 4051 integer :: bsize_frm,myfh 4052 integer(XMPI_OFFSET_KIND) :: my_offset 4053 character(len=500) :: msg 4054!arrays 4055 integer :: statux(MPI_STATUS_SIZE) 4056 4057!************************************************************************ 4058 4059 ! Workaround for XLF 4060 myfh = fh 4061 4062 my_offset = offset 4063 bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker. 4064 4065 call xmpio_read_frm(myfh,my_offset,sc_mode,fmarker,mpierr,advance=.FALSE.) 4066 4067 SELECT CASE (sc_mode) 4068 CASE (xmpio_single) 4069 call MPI_FILE_READ_AT(myfh, my_offset, buf, ncount, MPI_DOUBLE_PRECISION, statux, mpierr) 4070 4071 CASE (xmpio_collective) 4072 call MPI_FILE_READ_AT_ALL(myfh, my_offset, buf, ncount, MPI_DOUBLE_PRECISION, statux, mpierr) 4073 4074 CASE DEFAULT 4075 write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode 4076 call xmpi_abort(msg=msg) 4077 END SELECT 4078 4079 if (PRESENT(advance)) then 4080 if (advance) then 4081 offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record. 4082 else 4083 offset = offset + bsize_frm ! Move the pointer after the marker. 4084 end if 4085 else 4086 offset = offset + fmarker + 2*bsize_frm 4087 end if 4088 4089end subroutine xmpio_read_dp 4090!!*** 4091#endif 4092 4093!------------------------------------------------------------------------------------ 4094 4095!!****f* m_xmpi/xmpio_max_address 4096!! NAME 4097!! xmpio_max_address 4098!! 4099!! FUNCTION 4100!! Returns .TRUE. if offset cannot be stored in a Fortran integer of kind XMPI_ADDRESS_KIND. 4101!! 4102!! PARENTS 4103!! 4104!! SOURCE 4105 4106#ifdef HAVE_MPI_IO 4107 4108function xmpio_max_address(offset) 4109 4110 4111!This section has been created automatically by the script Abilint (TD). 4112!Do not modify the following lines by hand. 4113#undef ABI_FUNC 4114#define ABI_FUNC 'xmpio_max_address' 4115!End of the abilint section 4116 4117 implicit none 4118 4119!Arguments ------------------------------------ 4120!scalars 4121 logical :: xmpio_max_address 4122 integer(XMPI_OFFSET_KIND),intent(in) :: offset 4123!arrays 4124 4125!Local variables------------------------------- 4126!scalars 4127 integer(XMPI_ADDRESS_KIND) :: address 4128 integer(XMPI_OFFSET_KIND),parameter :: max_address=HUGE(address)-100 4129 4130!************************************************************************ 4131 4132 xmpio_max_address = (offset >= max_address) 4133 4134end function xmpio_max_address 4135!!*** 4136#endif 4137 4138!------------------------------------------------------------------------------------ 4139 4140!!****f* m_xmpi/xmpio_write_frmarkers 4141!! NAME 4142!! xmpio_write_frmarkers 4143!! 4144!! FUNCTION 4145!! Write a set of Fortran record markers starting at a given offset using MPI-IO. 4146!! 4147!! INPUTS 4148!! fh=MPI-IO file handler. 4149!! offset=MPI-IO file pointer 4150!! sc_mode=Option for individual or collective reading. 4151!! nfrec=Number of Fortran records to be written. 4152!! bsize_frecord(nfrec)=Byte size of the Fortran records to be written (markers are NOT included in the size) 4153!! 4154!! OUTPUT 4155!! ierr=A non-zero error code signals failure. 4156!! 4157!! PARENTS 4158!! exc_build_block,m_exc_itdiago,m_ioarr,m_slk,m_wfk 4159!! 4160!! CHILDREN 4161!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 4162!! 4163!! SOURCE 4164 4165#ifdef HAVE_MPI_IO 4166 4167subroutine xmpio_write_frmarkers(fh,offset,sc_mode,nfrec,bsize_frecord,ierr) 4168 4169 4170!This section has been created automatically by the script Abilint (TD). 4171!Do not modify the following lines by hand. 4172#undef ABI_FUNC 4173#define ABI_FUNC 'xmpio_write_frmarkers' 4174!End of the abilint section 4175 4176 implicit none 4177 4178!Arguments ------------------------------------ 4179!scalars 4180 integer,intent(in) :: fh,nfrec,sc_mode 4181 integer(XMPI_OFFSET_KIND),intent(in) :: offset 4182 integer,intent(out) :: ierr 4183!arrays 4184 integer(XMPI_OFFSET_KIND),intent(in) :: bsize_frecord(nfrec) 4185 4186!Local variables------------------------------- 4187!scalars 4188 integer :: nb,irec,frmarkers_type,jj,bsize_frm,mpi_type_frm,mpierr,myfh 4189 integer(XMPI_OFFSET_KIND) :: displ,my_offset 4190!character(len=500) :: msg 4191!arrays 4192 integer(kind=int16),allocatable :: bufdelim2(:) 4193 integer(kind=int32),allocatable :: bufdelim4(:) 4194 integer(kind=int64),allocatable :: bufdelim8(:) 4195#ifdef HAVE_FC_INT_QUAD 4196 integer*16,allocatable :: bufdelim16(:) 4197#endif 4198!integer :: statux(MPI_STATUS_SIZE) 4199 integer,allocatable :: block_length(:),block_type(:) 4200 integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:) 4201 integer(XMPI_OFFSET_KIND),allocatable :: delim_record(:) 4202 4203!************************************************************************ 4204 4205 ! Workaround for XLF 4206 myfh = fh; ierr=0 4207 4208 !my_offset = offset 4209 !do irec=1,nfrec 4210 ! call xmpio_write_frm(myfh,my_offset,sc_mode,bsize_frecord(irec),mpierr) 4211 !end do 4212 !return 4213 4214 ! FIXME: This is buggy 4215 bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker. 4216 mpi_type_frm = xmpio_mpi_type_frm ! MPI type of the record marker. 4217 4218 ! Define the view for the file 4219 nb=2*nfrec 4220 ABI_MALLOC(block_length,(nb+2)) 4221 ABI_MALLOC(block_displ,(nb+2)) 4222 ABI_MALLOC(block_type,(nb+2)) 4223 block_length(1)=1 4224 block_displ (1)=0 4225 block_type (1)=MPI_LB 4226 4227 jj=2; displ=0 4228 do irec=1,nfrec 4229 block_type (jj:jj+1) = mpi_type_frm 4230 block_length(jj:jj+1) = 1 4231 block_displ(jj ) = displ 4232 block_displ(jj+1) = displ + bsize_frm + bsize_frecord(irec) 4233 jj=jj+2 4234 displ = displ + bsize_frecord(irec) + 2*bsize_frm ! Move to the beginning of the next column. 4235 if (xmpio_max_address(displ)) then ! Check for wraparound. 4236 ierr = -1; return 4237 end if 4238 end do 4239 4240 block_length(nb+2) = 1 4241 block_displ (nb+2) = displ 4242 block_type (nb+2) = MPI_UB 4243 4244 call xmpio_type_struct(nb+2,block_length,block_displ,block_type,frmarkers_type,mpierr) 4245 4246 ABI_FREE(block_length) 4247 ABI_FREE(block_displ) 4248 ABI_FREE(block_type) 4249 4250 call MPI_TYPE_COMMIT(frmarkers_type,mpierr) 4251 call MPI_FILE_SET_VIEW(myfh,offset,MPI_BYTE,frmarkers_type,"native",MPI_INFO_NULL,mpierr) 4252 4253 jj=1 4254 ABI_MALLOC(delim_record,(nb)) 4255 do irec=1,nfrec 4256 delim_record(jj:jj+1)=bsize_frecord(irec) 4257 jj=jj+2 4258 end do 4259 4260 ! Write all markers according to the MPI type of the Fortran marker. 4261 SELECT CASE (bsize_frm) 4262 4263 CASE (4) 4264 ABI_MALLOC(bufdelim4,(nb)) 4265 bufdelim4=delim_record 4266 if (sc_mode==xmpio_single) then 4267 call MPI_FILE_WRITE (myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 4268 else if (sc_mode==xmpio_collective) then 4269 call MPI_FILE_WRITE_ALL(myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 4270 else 4271 ierr=2 4272 end if 4273 ABI_FREE(bufdelim4) 4274 4275 CASE (8) 4276 ABI_MALLOC(bufdelim8,(nb)) 4277 bufdelim8=delim_record 4278 if (sc_mode==xmpio_single) then 4279 call MPI_FILE_WRITE (myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 4280 else if (sc_mode==xmpio_collective) then 4281 call MPI_FILE_WRITE_ALL(myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 4282 else 4283 ierr=2 4284 end if 4285 ABI_FREE(bufdelim8) 4286 4287#ifdef HAVE_FC_INT_QUAD 4288 CASE (16) 4289 ABI_MALLOC(bufdelim16,(nb)) 4290 bufdelim16=delim_record 4291 if (sc_mode==xmpio_single) then 4292 call MPI_FILE_WRITE (myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 4293 else if (sc_mode==xmpio_collective) then 4294 call MPI_FILE_WRITE_ALL(myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 4295 else 4296 ierr=2 4297 end if 4298 ABI_FREE(bufdelim16) 4299#endif 4300 4301 CASE (2) 4302 ABI_MALLOC(bufdelim2,(nb)) 4303 bufdelim2=delim_record 4304 if (sc_mode==xmpio_single) then 4305 call MPI_FILE_WRITE (myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 4306 else if (sc_mode==xmpio_collective) then 4307 call MPI_FILE_WRITE_ALL(myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr) 4308 else 4309 ierr=2 4310 end if 4311 ABI_FREE(bufdelim2) 4312 4313 CASE DEFAULT 4314 ierr=-2 4315 END SELECT 4316 4317 ! Free memory 4318 call MPI_TYPE_FREE(frmarkers_type,mpierr) 4319 ABI_FREE(delim_record) 4320 4321end subroutine xmpio_write_frmarkers 4322#endif 4323!!*** 4324 4325!------------------------------------------------------------------------------------ 4326 4327!!****f* m_xmpi/xmpio_create_fherm_packed 4328!! NAME 4329!! xmpio_create_fherm_packed 4330!! 4331!! FUNCTION 4332!! Returns an MPI datatype that can be used to (read|write) with MPI-IO the columns of an 4333!! Hermitian matrix whose upper triangle is written on a Fortran binary file. 4334!! Note that the view assumes that the file pointer used to create the MPI-IO view 4335!! points to the first element of the first column. In other words,the first Fortran record marker 4336!! (if any) is not taken into account in the calculation of the displacements. 4337!! 4338!! INPUTS 4339!! array_of_starts(2)=starting coordinates in the global Hermitian matrix 4340!! (array of positive integers with jj>=ii, Fortran convention) 4341!! array_of_ends(2)=final coordinates in the global Hermitian matrix 4342!! (array of positive integers, jj>=ii, Fortran convention) 4343!! is_fortran_file=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files. 4344!! old_type=MPI datatype of the elements of the matrix. 4345!! 4346!! OUTPUT 4347!! my_offset=Offset relative to the beginning of the matrix in the file. 4348!! hmat_type=New MPI type. 4349!! offset_err= error code 4350!! 4351!! NOTES 4352!! The matrix on file is written in the following FORTRAN format (let us assume a 3x3 matrix for simplicity) 4353!! 4354!! m (1,1) m 4355!! m (1,2) (2,2) m 4356!! m (1,3) (2,3) (3,3) m 4357!! 4358!! each Fortran record stores a column of the packed Hermitian matrix, "m" denotes the Fortran 4359!! record marker that introduces holes in the MPI-IO file view. 4360!! To read the columns from (1,2) up to (2,2) one should use array_of_starts=(1,2) and array_of_ends=(2,2). 4361!! The MPI-IO file view should be created by moving the file pointer so that it points to the elements (1,2). 4362!! 4363!! NOTES 4364!! File views for C-streams is not optimal since one can use a single slice of contigous data. 4365!! 4366!! PARENTS 4367!! exc_build_block 4368!! 4369!! CHILDREN 4370!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 4371!! 4372!! SOURCE 4373 4374#ifdef HAVE_MPI_IO 4375 4376subroutine xmpio_create_fherm_packed(array_of_starts,array_of_ends,is_fortran_file,my_offset,old_type,hmat_type,offset_err) 4377 4378 4379!This section has been created automatically by the script Abilint (TD). 4380!Do not modify the following lines by hand. 4381#undef ABI_FUNC 4382#define ABI_FUNC 'xmpio_create_fherm_packed' 4383!End of the abilint section 4384 4385 implicit none 4386 4387!Arguments ------------------------------------ 4388!scalars 4389 integer,intent(in) :: old_type 4390 integer,intent(out) :: offset_err,hmat_type 4391 integer(XMPI_OFFSET_KIND),intent(out) :: my_offset 4392 logical,intent(in) :: is_fortran_file 4393!arrays 4394 integer,intent(in) :: array_of_starts(2),array_of_ends(2) 4395 4396!Local variables------------------------------- 4397!scalars 4398 integer :: nrow,my_ncol,ii,bsize_old,col,jj_glob,bsize_frm,prev_col,mpierr 4399 integer(XMPI_OFFSET_KIND) :: col_displ 4400!arrays 4401 integer,allocatable :: col_type(:),block_length(:),block_type(:) 4402 integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:) 4403 4404!************************************************************************ 4405 4406 offset_err=0 4407 4408 ! Byte size of old_type. 4409 call MPI_TYPE_SIZE(old_type,bsize_old,mpierr) 4410 4411 bsize_frm=0; if (is_fortran_file) bsize_frm = xmpio_bsize_frm 4412 4413 my_ncol = array_of_ends(2) - array_of_starts(2) + 1 4414 ! 4415 ! Calculate my offset relative to the beginning of the matrix in the file. 4416 prev_col = array_of_starts(2)-1 4417 my_offset = (prev_col*(prev_col+1)/2)*bsize_old + (array_of_starts(1)-1)*bsize_old + 2*prev_col*bsize_frm + bsize_frm 4418 ! 4419 ! col_type(col) describes the col-th column of the packed matrix. 4420 ! block_displ(col+1) stores its displacement taking into account the Fortran marker. 4421 ABI_MALLOC(col_type,(my_ncol)) 4422 ABI_MALLOC(block_displ,(my_ncol+2)) 4423 4424 if (my_ncol>1) then 4425 col_displ=0 4426 do col=1,my_ncol 4427 jj_glob = (col-1) + array_of_starts(2) 4428 nrow = jj_glob 4429 if (jj_glob==array_of_starts(2)) nrow = jj_glob - array_of_starts(1) + 1 ! First column treated by me. 4430 if (jj_glob==array_of_ends(2)) nrow = array_of_ends(1) ! Last column treated by me. 4431 call MPI_Type_contiguous(nrow,old_type,col_type(col),mpierr) 4432 ! 4433 if (xmpio_max_address(col_displ)) offset_err=1 ! Test for wraparounds 4434 block_displ(col+1) = col_displ 4435 col_displ = col_displ + nrow * bsize_old + 2 * bsize_frm ! Move to the next column. 4436 end do 4437 4438 else if (my_ncol==1) then ! The case of a single column is treated separately. 4439 block_displ(2) = 0 4440 nrow = array_of_ends(1) - array_of_starts(1) + 1 4441 call MPI_Type_contiguous(nrow,old_type,col_type(2),mpierr) 4442 col_displ= nrow*bsize_old 4443 if (xmpio_max_address(col_displ)) offset_err=1 ! Test for wraparounds 4444 else 4445 call xmpi_abort(msg="my_ncol cannot be negative!") 4446 end if 4447 4448 ABI_MALLOC(block_length,(my_ncol+2)) 4449 ABI_MALLOC(block_type,(my_ncol+2)) 4450 4451 block_length(1)=1 4452 block_displ (1)=0 4453 block_type (1)=MPI_LB 4454 4455 do ii=2,my_ncol+1 4456 block_length(ii)=1 4457 block_type(ii) =col_type(ii-1) 4458 !write(std_out,*)" ii-1, depl, length, type: ",ii-1,block_displ(ii),block_length(ii),block_type(ii) 4459 end do 4460 4461 block_length(my_ncol+2)= 1 4462 block_displ (my_ncol+2)= col_displ 4463 block_type (my_ncol+2)= MPI_UB 4464 4465 call xmpio_type_struct(my_ncol+2,block_length,block_displ,block_type,hmat_type,mpierr) 4466 4467 call MPI_TYPE_COMMIT(hmat_type,mpierr) 4468 4469 ABI_FREE(block_length) 4470 ABI_FREE(block_displ) 4471 ABI_FREE(block_type) 4472 4473 do col=1,my_ncol 4474 call MPI_TYPE_FREE(col_type(col),mpierr) 4475 end do 4476 4477 ABI_FREE(col_type) 4478 4479end subroutine xmpio_create_fherm_packed 4480!!*** 4481#endif 4482 4483!------------------------------------------------------------------------------------ 4484 4485!!****f* m_xmpi/xmpio_create_coldistr_from_fpacked 4486!! NAME 4487!! xmpio_create_coldistr_from_fpacked 4488!! 4489!! FUNCTION 4490!! Returns an MPI datatype that can be used to MPI-IO (read|write) the columns of an 4491!! (Hermitian|Symmetric) matrix whose upper triangle is written on a Fortran binary file. 4492!! Note that the view assumes that the file pointer used to instanciate the MPI-IO view 4493!! points to the first element of the first column. In other words,the first Fortran record marker 4494!! (if any) is not taken into account in the calculation of the displacements. 4495!! 4496!! INPUTS 4497!! sizes(2)=Number of elements of type old_type in each dimension of the full array (array of positive integers) 4498!! my_cols(2)=initial and final column to (read|write). Array of positive integers, Fortran convention. 4499!! old_type=MPI datatype of the elements of the matrix. 4500!! 4501!! OUTPUT 4502!! new_type=New MPI type that can be used to instanciate the MPI-IO view for the Fortran file. 4503!! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record 4504!! marker (lets call it "base"). Each node should (read|write) using my_offset = base + my_offpad. 4505!! my_offpad is used so that one can safely change the way the fileview is generated (for example 4506!! to make it more efficient) without having to change the client code. 4507!! offset_err=Error code. A non-zero returned value signals that the global matrix is tool large 4508!! for a single MPI-IO access (see notes below). 4509!! 4510!! NOTES 4511!! 1) The matrix on file is written in the following FORTRAN format (let us assume a 3x3 matrix for simplicity) 4512!! 4513!! m (1,1) m 4514!! m (1,2) (2,2) m 4515!! m (1,3) (2,3) (3,3) m 4516!! 4517!! each Fortran record stores a column of the packed matrix, "m" denotes the Fortran 4518!! record marker that introduces holes in the file view. 4519!! 4520!! 2) With (signed) Fortran integers, the maximum size of the file that 4521!! that can be read in one-shot is around 2Gb when etype is set to byte. 4522!! Using a larger etype might create portability problems (real data on machines using 4523!! integer*16 for the marker) since etype must be a multiple of the Fortran record marker 4524!! Due to the above reason, block_displ is given in bytes but it has to be defined as Fortran 4525!! integer. If the displacement cannot be stored in a Fortran integer, the routine returns 4526!! offset_err=1 so that the caller will know that several MPI-IO reads are nedded to 4527!! read the file. 4528!! 4529!! PARENTS 4530!! m_bse_io 4531!! 4532!! CHILDREN 4533!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 4534!! 4535!! SOURCE 4536 4537#ifdef HAVE_MPI_IO 4538 4539subroutine xmpio_create_coldistr_from_fpacked(sizes,my_cols,old_type,new_type,my_offpad,offset_err) 4540 4541 4542!This section has been created automatically by the script Abilint (TD). 4543!Do not modify the following lines by hand. 4544#undef ABI_FUNC 4545#define ABI_FUNC 'xmpio_create_coldistr_from_fpacked' 4546!End of the abilint section 4547 4548 implicit none 4549 4550!Arguments ------------------------------------ 4551!scalars 4552 integer,intent(in) :: old_type 4553 integer,intent(out) :: new_type,offset_err 4554 integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad 4555!arrays 4556 integer,intent(in) :: sizes(2),my_cols(2) 4557 4558!Local variables------------------------------- 4559!scalars 4560 integer :: my_ncol,bsize_old,my_col 4561 integer :: my_nels,my_el,row_glob,ii_hpk,jj_hpk,col_glob,bsize_frm,mpierr 4562 integer(XMPI_OFFSET_KIND) :: my_offset,ijp_glob 4563 !character(len=500) :: msg 4564!arrays 4565 integer,allocatable :: block_length(:),block_type(:) 4566 integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:) 4567 4568!************************************************************************ 4569 4570 ! Byte size of the Fortran record marker. 4571 bsize_frm = xmpio_bsize_frm 4572 4573 ! Byte size of old_type. 4574 call MPI_TYPE_SIZE(old_type,bsize_old,mpierr) 4575 4576 ! my number of columns and total numer of elements to be read. 4577 my_ncol = my_cols(2) - my_cols(1) + 1 4578 my_nels = my_ncol*sizes(1) 4579 ! 4580 ! block_displ(el+1) stores the displacement of the local element el taking into account the Fortran marker. 4581 ABI_MALLOC(block_displ,(my_nels+2)) 4582 ABI_MALLOC(block_length,(my_nels+2)) 4583 ABI_MALLOC(block_type,(my_nels+2)) 4584 4585 block_length(1)=1 4586 block_displ (1)=0 4587 block_type (1)=MPI_LB 4588 ! 4589 ! * the view assumes that the file pointer used to instanciate the MPI-IO view 4590 ! points to the first element of the first column. In other words,the first Fortran record marker 4591 ! is not taken into account in the calculation of the displacements. 4592 my_offpad=xmpio_bsize_frm 4593 4594 ! * Some matrix elements are read twice. This part has to be tested. 4595 offset_err=0; my_el=0 4596 do my_col=1,my_ncol 4597 col_glob = (my_col-1) + my_cols(1) 4598 do row_glob=1,sizes(1) 4599 if (col_glob>=row_glob) then 4600 ii_hpk = row_glob 4601 jj_hpk = col_glob 4602 ijp_glob = row_glob + col_glob*(col_glob-1)/2 ! Index for packed form 4603 else ! Exchange the indeces as (jj,ii) will be read. 4604 ii_hpk = col_glob 4605 jj_hpk = row_glob 4606 ijp_glob = col_glob + row_glob*(row_glob-1)/2 ! Index for packed form 4607 end if 4608 my_el = my_el+1 4609 my_offset = (ijp_glob-1)* bsize_old + (jj_hpk-1)*2*bsize_frm 4610 if (xmpio_max_address(my_offset)) offset_err=1 ! Check for wraparounds. 4611 block_displ (my_el+1)=my_offset 4612 block_length(my_el+1)=1 4613 block_type (my_el+1)=old_type 4614 !write(std_out,*)" my_el, displ: ",my_el,block_displ(my_el+1) 4615 end do 4616 end do 4617 4618 block_length(my_nels+2)=1 4619 block_displ (my_nels+2)=my_offset 4620 block_type (my_nels+2)=MPI_UB 4621 4622 call xmpio_type_struct(my_nels+2,block_length,block_displ,block_type,new_type,mpierr) 4623 4624 call MPI_TYPE_COMMIT(new_type,mpierr) 4625 4626 ABI_FREE(block_length) 4627 ABI_FREE(block_displ) 4628 ABI_FREE(block_type) 4629 4630end subroutine xmpio_create_coldistr_from_fpacked 4631!!*** 4632#endif 4633 4634!------------------------------------------------------------------------------------ 4635 4636!!****f* m_xmpi/xmpio_create_coldistr_from_fp3blocks 4637!! NAME 4638!! xmpio_create_coldistr_from_fp3blocks 4639!! 4640!! FUNCTION 4641!! Returns an MPI datatype that can be used to MPI-IO (read|write) the columns of a 4642!! matrix of the form M = (S1 F3) 4643!! (F3^H S2) 4644!! where S1 and S2 are square (symmetric|Hermitian) matrices whose upper triangle is stored on file 4645!! while F3 is a generic matrix (not necessarily square) stored in full mode. 4646!! The Fortran file contains the blocks in the following order. 4647!! upper(S1) 4648!! upper(S2) 4649!! F3 4650!! INPUTS 4651!! sizes(2)=Number of elements of type old_type in each dimension of the full array M (array of positive integers) 4652!! my_cols(2)=initial and final column to (read|write). Array of positive integers, Fortran convention. 4653!! block_sizes(2,3)=The sizes of S1, S2, F. 4654!! old_type=MPI datatype of the elements of the matrix. 4655!! 4656!! OUTPUT 4657!! new_type=New MPI type that can be used to instanciate the MPI-IO view for the Fortran file. 4658!! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record 4659!! marker (lets call it "base"). Each node should (read|write) using my_offset = base + my_offpad. 4660!! my_offpad is used so that one can safely change the way the fileview is generated (for example 4661!! to make it more efficient) without having to change the client code. 4662!! offset_err=Error code. A non-zero returned value signals that the global matrix is tool large 4663!! for a single MPI-IO access (see notes below). 4664!! 4665!! NOTES 4666!! 1) block_displ is given in bytes due to the presence of the marker. 4667!! If the displacement of an element is too large, the routine returns 4668!! offset_err=1 so that the caller knows that several MPI-IO reads are required to (read| write) the file. 4669!! 4670!! PARENTS 4671!! m_bse_io 4672!! 4673!! CHILDREN 4674!! mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct 4675!! 4676!! SOURCE 4677 4678#ifdef HAVE_MPI_IO 4679 4680subroutine xmpio_create_coldistr_from_fp3blocks(sizes,block_sizes,my_cols,old_type,new_type,my_offpad,offset_err) 4681 4682 4683!This section has been created automatically by the script Abilint (TD). 4684!Do not modify the following lines by hand. 4685#undef ABI_FUNC 4686#define ABI_FUNC 'xmpio_create_coldistr_from_fp3blocks' 4687!End of the abilint section 4688 4689 implicit none 4690 4691!Arguments ------------------------------------ 4692!scalars 4693 integer,intent(in) :: old_type 4694 integer,intent(out) :: new_type,offset_err 4695 integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad 4696!arrays 4697 integer,intent(in) :: sizes(2),my_cols(2),block_sizes(2,3) 4698 4699!Local variables------------------------------- 4700!scalars 4701 integer :: my_ncol,bsize_old,my_col,which_block,uplo,swap 4702 integer :: my_nels,my_el,row_glob,ii_hpk,jj_hpk,ii,jj 4703 integer :: col_glob,bsize_frm,mpierr,row_shift,col_shift,n1,n2 4704 integer(XMPI_OFFSET_KIND) :: my_offset,ijp,bsize_tot,max_displ,min_displ 4705 integer(XMPI_ADDRESS_KIND) :: address 4706!arrays 4707 integer,allocatable :: block_length(:),block_type(:) 4708 integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:) 4709 integer(XMPI_OFFSET_KIND) :: bsize_mat(2) 4710 4711!************************************************************************ 4712 4713 if ( sizes(1) /= SUM(block_sizes(1,1:2)) .or. & 4714& sizes(2) /= SUM(block_sizes(2,1:2)) ) then 4715 write(std_out,*)" xmpio_create_coldistr_from_fp3blocks: Inconsistency between block_sizes ans sizes " 4716 call xmpi_abort() 4717 end if 4718 4719 if ( block_sizes(1,1)/=block_sizes(2,1) .or.& 4720& block_sizes(1,2)/=block_sizes(2,2) ) then 4721 write(std_out,*)" xmpio_create_coldistr_from_fp3blocks: first two blocks must be square" 4722 call xmpi_abort() 4723 end if 4724 4725 if ( block_sizes(2,3)/=block_sizes(2,2) .or.& 4726& block_sizes(1,3)/=block_sizes(1,1) ) then 4727 write(std_out,*)" xmpio_create_coldistr_from_fp3blocks: Full matrix must be square" 4728 call xmpi_abort() 4729 end if 4730 4731 write(std_out,*)" xmpio_create_coldistr_from_fp3blocks is still under testing" 4732 !call xmpi_abort() 4733 4734 ! Byte size of the Fortran record marker. 4735 bsize_frm = xmpio_bsize_frm 4736 4737 ! Byte size of old_type. 4738 call MPI_TYPE_SIZE(old_type,bsize_old,mpierr) 4739 4740 ! my number of columns and total numer of elements to be read. 4741 my_ncol = my_cols(2) - my_cols(1) + 1 4742 my_nels = sizes(1)*my_ncol 4743 ! 4744 ! block_displ(el+1) stores the displacement of the local element el taking into account the Fortran marker. 4745 ABI_MALLOC(block_displ,(my_nels+2)) 4746 ABI_MALLOC(block_length,(my_nels+2)) 4747 ABI_MALLOC(block_type,(my_nels+2)) 4748 ! 4749 ! * the view assumes that the file pointer used to instanciate the MPI-IO view 4750 ! points to the first element of the first column. In other words,the first Fortran record marker 4751 ! is not taken into account in the calculation of the displacements. 4752 my_offpad=xmpio_bsize_frm 4753 ! 4754 ! Byte size of the first two blocks including the markers. 4755 n1=block_sizes(1,1) 4756 bsize_mat(1) = (n1*(n1+1)/2)*bsize_old + 2*n1*bsize_frm 4757 4758 n2=block_sizes(1,2) 4759 bsize_mat(2) = (n2*(n2+1)/2)*bsize_old + 2*n2*bsize_frm 4760 4761 bsize_tot=SUM(bsize_mat) + PRODUCT(block_sizes(:,3))*bsize_old + block_sizes(2,3)*2*bsize_frm - bsize_frm 4762 write(std_out,*)"bsize_mat",bsize_mat,"bsize_tot",bsize_tot 4763 ! 4764 ! * Some matrix elements are read twice. This part has to be tested. 4765 offset_err=0; my_el=0; max_displ=0; min_displ=HUGE(address) 4766 do my_col=1,my_ncol 4767 col_glob = (my_col-1) + my_cols(1) 4768 do row_glob=1,sizes(1) 4769 ! 4770 which_block=3 4771 if (row_glob<=block_sizes(1,1).and.col_glob<=block_sizes(2,1)) which_block=1 4772 if (row_glob >block_sizes(1,1).and.col_glob >block_sizes(2,1)) which_block=2 4773 4774 if ( ANY(which_block == (/1,2/)) ) then ! S1 or S2 4775 ! 4776 row_shift=(which_block-1)*block_sizes(1,1) 4777 col_shift=(which_block-1)*block_sizes(2,1) 4778 4779 ii_hpk = row_glob - row_shift 4780 jj_hpk = col_glob - col_shift 4781 if (jj_hpk<ii_hpk) then ! Exchange the indeces so that the symmetric is read. 4782 swap = jj_hpk 4783 jj_hpk = ii_hpk 4784 ii_hpk = swap 4785 end if 4786 ijp = ii_hpk + jj_hpk*(jj_hpk-1)/2 ! Index for packed form 4787 my_offset = (ijp-1)*bsize_old + (jj_hpk-1)*2*bsize_frm 4788 if (which_block==2) my_offset=my_offset+bsize_mat(1) ! Shift the offset to account for S1. 4789 !my_offset=4 4790 ! 4791 else 4792 ! The element belongs either to F3 of F3^H. 4793 ! Now find whether it is the upper or the lower block since only F3 is stored on file. 4794 uplo=1; if (row_glob>block_sizes(1,1)) uplo=2 4795 4796 if (uplo==1) then 4797 row_shift=0 4798 col_shift=block_sizes(2,1) 4799 else 4800 row_shift=block_sizes(1,1) 4801 col_shift=0 4802 end if 4803 ii = row_glob - row_shift 4804 jj = col_glob - col_shift 4805 4806 if (uplo==2) then ! Exchange the indeces since the symmetric element will be read. 4807 swap=jj 4808 jj =ii 4809 ii =swap 4810 end if 4811 4812 my_offset = (ii-1)*bsize_old + (jj-1)*block_sizes(1,3)*bsize_old + (jj-1)*2*bsize_frm 4813 my_offset = my_offset + SUM(bsize_mat) 4814 !if (uplo==1) my_offset=my_offset + bsize_mat(1) 4815 !my_offset=0 4816 !if (ii==1.and.jj==1) write(std_out,*)" (1,1) offset = ",my_offset 4817 !if (ii==block_sizes(1,3).and.jj==block_sizes(2,3)) write(std_out,*)" (n,n) offset =", my_offset 4818 if (my_offset>=bsize_tot-1*bsize_old) then 4819 write(std_out,*)"WARNING (my_offset>bsize_tot-bsize_old),",ii,jj,my_offset,bsize_tot 4820 end if 4821 end if 4822 4823 if (xmpio_max_address(my_offset)) offset_err=1 ! Check for wraparounds. 4824 my_el = my_el+1 4825 block_displ (my_el+1)=my_offset 4826 block_length(my_el+1)=1 4827 block_type (my_el+1)=old_type 4828 max_displ = MAX(max_displ,my_offset) 4829 min_displ = MIN(min_displ,my_offset) 4830 !if (which_block==3) write(std_out,*)" my_el, which, displ: ",my_el,which_block,block_displ(my_el+1) 4831 end do 4832 end do 4833 4834 write(std_out,*)" MAX displ = ",max_displ," my_nels = ",my_nels 4835 write(std_out,*)" MIN displ = ",MINVAL(block_displ(2:my_nels+1)) 4836 4837 !block_displ (1)=max_displ ! Do not change this value. 4838 !if (min_displ>0) block_displ (1)=min_displ ! Do not change this value. 4839 4840 block_displ (1)=min_displ 4841 block_displ (1)=0 4842 block_length(1)=0 4843 block_type (1)=MPI_LB 4844 4845 block_length(my_nels+2)=0 4846 !block_displ (my_nels+2)=bsize_tot 4847 block_displ (my_nels+2)=max_displ 4848 block_type (my_nels+2)=MPI_UB 4849 4850 call xmpio_type_struct(my_nels+2,block_length,block_displ,block_type,new_type,mpierr) 4851 !call xmpio_type_struct(my_nels,block_length(2:),block_displ(2:),block_type(2:),new_type,mpierr) 4852 4853 !call MPI_TYPE_CREATE_INDEXED_BLOCK(my_nels, block_length(2:), block_displ(2:), old_type, new_type, mpierr) 4854 4855 call MPI_TYPE_COMMIT(new_type,mpierr) 4856 4857 ABI_FREE(block_length) 4858 ABI_FREE(block_displ) 4859 ABI_FREE(block_type) 4860 4861end subroutine xmpio_create_coldistr_from_fp3blocks 4862!!*** 4863#endif 4864 4865END MODULE m_xmpi 4866!!*** 4867