TABLE OF CONTENTS


ABINIT/m_xmpi [ Modules ]

[ Top ] [ Modules ]

NAME

  m_xmpi

FUNCTION

  This module provides MPI named constants, tools for inquiring the MPI environment
  and a set of generic interfaces wrapping the most commonly used MPI primitives.

COPYRIGHT

 Copyright (C) 2009-2018 ABINIT group (MG, MB, XG, YP, MT)
 This file is distributed under the terms of the
 GNU General Public License, see ~abinit/COPYING
 or http://www.gnu.org/copyleft/gpl.txt .

PARENTS

TODO

  Get rid of xmpi_paral. Sequential code is the **exception**. Developers should code parallel
  code or code that is compatible both with MPI and seq (thanks to the wrappers provided by this module)

SOURCE

24 #if defined HAVE_CONFIG_H
25 #include "config.h"
26 #endif
27 
28 #include "abi_common.h"
29 
30 MODULE 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

m_wffile/xmpio_read_frm [ Functions ]

[ Top ] [ m_wffile ] [ Functions ]

NAME

  xmpio_read_frm

FUNCTION

  Read the content of a single record marker in a FORTRAN file at a given offset using MPI-IO.
  the file pointer is modified according to the value of advance.

INPUTS

  fh=MPI-IO file handler.
  sc_mode=
    xmpio_single     ==> for reading by current proc.
    xmpio_collective ==> for collective reading.
  offset=MPI/IO file pointer
  [advance]=By default the routine will move the file pointer to the next record.
    advance=.FALSE. can be used so that the next read will continue picking information
    off of the currect record.

OUTPUT

  fmarker=Content of the Fortran record marker.
  mpierr= MPI error code

SIDE EFFECTS

  offset=
     input: file pointer used to access the Fortran marker.
     output: new offset updated after the reading, depending on advance.

PARENTS

      m_bse_io,m_exc_diago,m_exc_itdiago,m_hdr,m_io_screening,m_xmpi

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

3034 #ifdef HAVE_MPI_IO
3035 
3036 subroutine xmpio_read_frm(fh,offset,sc_mode,fmarker,mpierr,advance)
3037 
3038 
3039 !This section has been created automatically by the script Abilint (TD).
3040 !Do not modify the following lines by hand.
3041 #undef ABI_FUNC
3042 #define ABI_FUNC 'xmpio_read_frm'
3043 !End of the abilint section
3044 
3045  implicit none
3046 
3047 !Arguments ------------------------------------
3048 !scalars
3049  integer,intent(in) :: fh,sc_mode
3050  integer(XMPI_OFFSET_KIND),intent(inout) :: offset
3051  integer(XMPI_OFFSET_KIND),intent(out) :: fmarker
3052  integer,intent(out) :: mpierr
3053  logical,optional,intent(in) :: advance
3054 
3055 !Local variables-------------------------------
3056 !scalars
3057  integer :: bsize_frm,mpi_type_frm,myfh
3058  integer(kind=int16) :: delim_record2
3059  integer(kind=int32) :: delim_record4
3060  integer(kind=int64) :: delim_record8
3061 #if defined HAVE_FC_INT_QUAD
3062  integer*16 :: delim_record16
3063 #endif
3064  character(len=500) :: msg
3065 !arrays
3066  integer :: statux(MPI_STATUS_SIZE)
3067 
3068 !************************************************************************
3069 
3070  !Workaround for XLF.
3071  myfh = fh
3072 
3073  bsize_frm    = xmpio_bsize_frm    ! Byte size of the Fortran record marker.
3074  mpi_type_frm = xmpio_mpi_type_frm ! MPI type of the record marker.
3075 
3076  SELECT CASE (sc_mode)
3077 
3078  CASE (xmpio_single)
3079 
3080    if (bsize_frm==4) then
3081      call MPI_FILE_READ_AT(myfh,offset,delim_record4,1,mpi_type_frm,statux,mpierr)
3082      fmarker = delim_record4
3083    else if (bsize_frm==8) then
3084      call MPI_FILE_READ_AT(myfh,offset,delim_record8,1,mpi_type_frm,statux,mpierr)
3085      fmarker = delim_record8
3086 #if defined HAVE_FC_INT_QUAD
3087    else if (bsize_frm==16) then
3088      call MPI_FILE_READ_AT(myfh,offset,delim_record16,1,mpi_type_frm,statux,mpierr)
3089      fmarker = delim_record16
3090 #endif
3091    else if (bsize_frm==2) then
3092      call MPI_FILE_READ_AT(myfh,offset,delim_record2 ,1,mpi_type_frm,statux,mpierr)
3093      fmarker = delim_record2
3094    else
3095      call xmpi_abort(msg='Wrong record marker length!')
3096    end if
3097 
3098  CASE (xmpio_collective)
3099 
3100    if (bsize_frm==4) then
3101      call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record4 ,1,mpi_type_frm,statux,mpierr)
3102      fmarker = delim_record4
3103    else if (bsize_frm==8) then
3104      call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record8 ,1,mpi_type_frm,statux,mpierr)
3105      fmarker = delim_record8
3106 #if defined HAVE_FC_INT_QUAD
3107    else if (bsize_frm==16) then
3108      call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record16,1,mpi_type_frm,statux,mpierr)
3109      fmarker = delim_record16
3110 #endif
3111    else if (bsize_frm==2) then
3112      call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record2 ,1,mpi_type_frm,statux,mpierr)
3113      fmarker = delim_record2
3114    else
3115      call xmpi_abort(msg='Wrong record marker length!')
3116    end if
3117 
3118  CASE DEFAULT
3119    write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode
3120    call xmpi_abort(msg=msg)
3121  END SELECT
3122 
3123  if (PRESENT(advance)) then
3124    if (advance) then
3125      offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record.
3126    else
3127      offset = offset + bsize_frm  ! Move the pointer after the marker.
3128    end if
3129  else
3130    offset = offset + fmarker + 2*bsize_frm
3131  end if
3132 
3133 end subroutine xmpio_read_frm

m_wffile/xmpio_write_frm [ Functions ]

[ Top ] [ m_wffile ] [ Functions ]

NAME

  xmpio_write_frm

FUNCTION

  Write a single record marker in a FORTRAN file at a given offset using MPI-IO.
  The file pointer is modified according to the value of advance.

INPUTS

  fh=MPI-IO file handler.
  sc_mode=
         xmpio_single     ==> for reading by current proc.
         xmpio_collective ==> for collective reading.
  fmarker=The content of the Fortran marker i.e. the size of the record in bytes.
  [advance]=By default the routine will move the file pointer to the next record.
    advance=.FALSE. can be used so that the next write will continue writing data
    on the currect record.

OUTPUT

  mpierr= error code

SIDE EFFECTS

  offset=
     input: offset of  the Fortran marker.
     output: new offset updated after the writing, depending on advance.

PARENTS

      m_ioarr

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

3174 #ifdef HAVE_MPI_IO
3175 
3176 subroutine xmpio_write_frm(fh,offset,sc_mode,fmarker,mpierr,advance)
3177 
3178 
3179 !This section has been created automatically by the script Abilint (TD).
3180 !Do not modify the following lines by hand.
3181 #undef ABI_FUNC
3182 #define ABI_FUNC 'xmpio_write_frm'
3183 !End of the abilint section
3184 
3185  implicit none
3186 
3187 !Arguments ------------------------------------
3188 !scalars
3189  integer,intent(in) :: fh,sc_mode
3190  integer(XMPI_OFFSET_KIND),intent(in) :: fmarker
3191  integer(XMPI_OFFSET_KIND),intent(inout) :: offset
3192  integer,intent(out) :: mpierr
3193  logical,optional,intent(in) :: advance
3194 
3195 !Local variables-------------------------------
3196 !scalars
3197  integer :: myfh,bsize_frm,mpi_type_frm
3198  integer(XMPI_OFFSET_KIND) :: last
3199  integer(kind=int16)  :: delim_record2
3200  integer(kind=int32)  :: delim_record4
3201  integer(kind=int64)  :: delim_record8
3202 #if defined HAVE_FC_INT_QUAD
3203  integer*16 :: delim_record16
3204 #endif
3205  character(len=500) :: msg
3206 !arrays
3207  integer :: statux(MPI_STATUS_SIZE)
3208 
3209 !************************************************************************
3210 
3211  ! Workaround for XLF
3212  myfh = fh
3213 
3214  bsize_frm    = xmpio_bsize_frm      ! Byte size of the Fortran record marker.
3215  mpi_type_frm = xmpio_mpi_type_frm   ! MPI type of the record marker.
3216  last = offset + bsize_frm + fmarker ! position of the end marker
3217 
3218  SELECT CASE (sc_mode)
3219 
3220  CASE (xmpio_single)
3221    if (bsize_frm==4) then
3222      delim_record4 = fmarker
3223      call MPI_FILE_WRITE_AT(myfh,offset,delim_record4 ,1,mpi_type_frm,statux,mpierr)
3224      call MPI_FILE_WRITE_AT(myfh,last,delim_record4 ,1,mpi_type_frm,statux,mpierr)
3225 
3226    else if (bsize_frm==8) then
3227      delim_record8 = fmarker
3228      call MPI_FILE_WRITE_AT(myfh,offset,delim_record8 ,1,mpi_type_frm,statux,mpierr)
3229      call MPI_FILE_WRITE_AT(myfh,last,delim_record8 ,1,mpi_type_frm,statux,mpierr)
3230 #if defined HAVE_FC_INT_QUAD
3231    else if (bsize_frm==16) then
3232      delim_record16 = fmarker
3233      call MPI_FILE_WRITE_AT(myfh,offset,delim_record16,1,mpi_type_frm,statux,mpierr)
3234      call MPI_FILE_WRITE_AT(myfh,last,delim_record16 ,1,mpi_type_frm,statux,mpierr)
3235 #endif
3236    else if (bsize_frm==2) then
3237      delim_record2 = fmarker
3238      call MPI_FILE_WRITE_AT(myfh,offset,delim_record2, 1,mpi_type_frm,statux,mpierr)
3239      call MPI_FILE_WRITE_AT(myfh,last,delim_record2 ,1,mpi_type_frm,statux,mpierr)
3240    else
3241      call xmpi_abort(msg='Wrong record marker length!')
3242    end if
3243 
3244  CASE (xmpio_collective)
3245    if (bsize_frm==4) then
3246      delim_record4 = fmarker
3247      call MPI_FILE_WRITE_AT_ALL(myfh,offset,delim_record4 ,1,mpi_type_frm,statux,mpierr)
3248      call MPI_FILE_WRITE_AT_ALL(myfh,last,delim_record4 ,1,mpi_type_frm,statux,mpierr)
3249    else if (bsize_frm==8) then
3250      delim_record8 = fmarker
3251      call MPI_FILE_WRITE_AT_ALL(myfh,offset,delim_record8 ,1,mpi_type_frm,statux,mpierr)
3252      call MPI_FILE_WRITE_AT_ALL(myfh,last,delim_record8 ,1,mpi_type_frm,statux,mpierr)
3253 #if defined HAVE_FC_INT_QUAD
3254    else if (bsize_frm==16) then
3255      delim_record16 = fmarker
3256      call MPI_FILE_WRITE_AT_ALL(myfh,offset,delim_record16,1,mpi_type_frm,statux,mpierr)
3257      call MPI_FILE_WRITE_AT_ALL(myfh,last,delim_record16 ,1,mpi_type_frm,statux,mpierr)
3258 #endif
3259    else if (bsize_frm==2) then
3260      delim_record2 = fmarker
3261      call MPI_FILE_WRITE_AT_ALL(myfh,offset,delim_record2 ,1,mpi_type_frm,statux,mpierr)
3262      call MPI_FILE_WRITE_AT_ALL(myfh,last,delim_record2 ,1,mpi_type_frm,statux,mpierr)
3263    else
3264      call xmpi_abort(msg='Wrong record marker length!')
3265    end if
3266 
3267  CASE DEFAULT
3268    write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode
3269    call xmpi_abort(msg=msg)
3270  END SELECT
3271 
3272  if (PRESENT(advance)) then
3273    if (advance) then
3274      offset = offset + fmarker + 2*bsize_frm  ! Move the file pointer to the next record.
3275    else
3276      offset = offset + bsize_frm              ! Move the pointer after the marker.
3277    end if
3278  else
3279    offset = offset + fmarker + 2*bsize_frm
3280  end if
3281 
3282 end subroutine xmpio_write_frm

m_xmpi/sys_exit [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

 sys_exit

FUNCTION

 Routine for clean exit of f90 code by one processor

INPUTS

   exit_status:
     return code.

NOTES

  By default, it uses "call exit(1)", that is not completely portable.

PARENTS

      m_xmpi

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

871 subroutine sys_exit(exit_status)
872 
873 
874 !This section has been created automatically by the script Abilint (TD).
875 !Do not modify the following lines by hand.
876 #undef ABI_FUNC
877 #define ABI_FUNC 'sys_exit'
878 !End of the abilint section
879 
880  implicit none
881 
882 !Arguments ------------------------------------
883 !scalars
884  integer,intent(in) :: exit_status
885 
886 ! **********************************************************************
887 
888 #if defined FC_NAG
889  call exit(exit_status)
890 #elif defined HAVE_FC_EXIT
891  call exit(exit_status)
892 #else
893  ! stop with exit_status
894  ! MT 06-2013:stop function only accept parameters !
895  if (exit_status== 0) stop  "0"
896  if (exit_status== 1) stop  "1"
897  if (exit_status==-1) stop "-1"
898 #endif
899  stop 1
900 
901 end subroutine sys_exit

m_xmpi/xmpi_abort [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_abort

FUNCTION

  Hides MPI_ABORT from MPI library.

INPUTS

  [comm]=communicator of tasks to abort.
  [mpierr]=Error code to return to invoking environment.
  [msg]=User message
  [exit_status]=optional, shell return code, default 1

PARENTS

      initmpi_grid,leave_new,m_initcuda,m_libpaw_tools,m_xmpi,testkgrid

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

787 subroutine xmpi_abort(comm,mpierr,msg,exit_status)
788 
789 
790 !This section has been created automatically by the script Abilint (TD).
791 !Do not modify the following lines by hand.
792 #undef ABI_FUNC
793 #define ABI_FUNC 'xmpi_abort'
794 !End of the abilint section
795 
796  implicit none
797 
798 !Arguments-------------------------
799  integer,optional,intent(in) :: comm,mpierr,exit_status
800  character(len=*),optional,intent(in) :: msg
801 
802 !Local variables-------------------
803  integer :: ierr,my_comm,my_errorcode,ilen,ierr2
804  logical :: testopen
805  character(len=xmpi_msg_len) :: mpi_msg_error
806 
807 ! *************************************************************************
808 
809  ierr=0
810  my_comm = xmpi_world; if (PRESENT(comm)) my_comm = comm
811 
812  if (PRESENT(msg)) then
813    write(std_out,'(2a)')"User message: ",TRIM(msg)
814  end if
815 
816  ! Close std_out and ab_out
817  inquire(std_out,opened=testopen)
818  if (testopen) close(std_out)
819 
820  inquire(ab_out,opened=testopen)
821  if (testopen) close(ab_out)
822 
823 #ifdef HAVE_MPI
824  my_errorcode=MPI_ERR_UNKNOWN; if (PRESENT(mpierr)) my_errorcode=mpierr
825 
826  call MPI_ERROR_STRING(my_errorcode, mpi_msg_error, ilen, ierr2)
827 
828  !if (ilen>xmpi_msg_len) write(std_out,*)" WARNING: MPI message has been truncated!"
829  !if (ierr2/=MPI_SUCCESS) then
830  !  write(std_out,'(a,i0)')" WARNING: MPI_ERROR_STRING returned ierr2= ",ierr2
831  !else
832  !  write(std_out,'(2a)')" MPI_ERROR_STRING: ",TRIM(mpi_msg_error)
833  !end if
834 
835  call MPI_ABORT(my_comm,my_errorcode,ierr)
836 #endif
837 
838  if (present(exit_status)) then
839    call sys_exit(exit_status)
840  else
841    call sys_exit(1)
842  end if
843 
844 end subroutine xmpi_abort

m_xmpi/xmpi_barrier [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_barrier

FUNCTION

  Hides MPI_BARRIER from MPI library.

INPUTS

  comm=MPI communicator

PARENTS

      alloc_hamilt_gpu,atomden,calc_optical_mels,calc_ucrpa,chebfi
      m_datafordmft,denfgr,dfpt_nselt,dfpt_nstpaw,dfpt_scfcv,exc_build_block
      fermisolverec,getcgqphase,gstateimg,iofn1,ks_ddiago,m_abihist,m_bse_io
      m_dvdb,m_exc_diago,m_exc_itdiago,m_exc_spectra,m_fit_polynomial_coeff
      m_green,m_haydock,m_hdr,m_io_redirect,m_ioarr,m_iowf,m_plowannier
      m_sigmaph,m_slk,m_wfd,m_wffile,m_wfk,m_xgScalapack,mlwfovlp,mlwfovlp_pw
      mover,mover_effpot,outkss,pawmkaewf,qmc_prep_ctqmc,rf2_init,sigma,tddft
      vtorho,vtorhorec,wfk_analyze

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1840 subroutine xmpi_barrier(comm)
1841 
1842 
1843 !This section has been created automatically by the script Abilint (TD).
1844 !Do not modify the following lines by hand.
1845 #undef ABI_FUNC
1846 #define ABI_FUNC 'xmpi_barrier'
1847 !End of the abilint section
1848 
1849  implicit none
1850 
1851 !Arguments-------------------------
1852  integer,intent(in) :: comm
1853 
1854 !Local variables-------------------
1855  integer   :: ier
1856 #ifdef HAVE_MPI
1857  integer :: nprocs
1858 #endif
1859 
1860 ! *************************************************************************
1861 
1862  ier = 0
1863 #ifdef HAVE_MPI
1864  if (comm/=xmpi_comm_null) then
1865    call MPI_COMM_SIZE(comm,nprocs,ier)
1866    if(nprocs>1)then
1867      call MPI_BARRIER(comm,ier)
1868    end if
1869  end if
1870 #endif
1871 
1872 end subroutine xmpi_barrier

m_xmpi/xmpi_comm_create [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_comm_create

FUNCTION

  Hides MPI_COMM_CREATE from MPI library.

INPUTS

  comm=communicator
  group=group, which is a subset of the group of comm

OUTPUT

  newcomm=new communicator

PARENTS

      m_wfd

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1472 subroutine xmpi_comm_create(comm,group,newcomm,mpierr)
1473 
1474 
1475 !This section has been created automatically by the script Abilint (TD).
1476 !Do not modify the following lines by hand.
1477 #undef ABI_FUNC
1478 #define ABI_FUNC 'xmpi_comm_create'
1479 !End of the abilint section
1480 
1481  implicit none
1482 
1483 !Arguments-------------------------
1484 !scalars
1485  integer,intent(in) :: comm,group
1486  integer,intent(out) :: mpierr
1487  integer,intent(inout) :: newcomm
1488 
1489 ! *************************************************************************
1490 
1491  mpierr=0
1492 #ifdef HAVE_MPI
1493  if (group/=xmpi_group_null) then
1494    call MPI_comm_create(comm,group,newcomm,mpierr)
1495  else
1496    newcomm=xmpi_comm_null
1497  end if
1498 #else
1499   newcomm=xmpi_comm_self
1500 #endif
1501 
1502 end subroutine xmpi_comm_create

m_xmpi/xmpi_comm_free_0D [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_comm_free_0D

FUNCTION

  Hides MPI_COMM_FREE from MPI library.
  Does not abort MPI in case of an invalid communicator

INPUTS

  comm=MPI communicator.

PARENTS

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1098 subroutine xmpi_comm_free_0D(comm)
1099 
1100 
1101 !This section has been created automatically by the script Abilint (TD).
1102 !Do not modify the following lines by hand.
1103 #undef ABI_FUNC
1104 #define ABI_FUNC 'xmpi_comm_free_0D'
1105 !End of the abilint section
1106 
1107  implicit none
1108 
1109 !Arguments-------------------------
1110  integer,intent(inout) :: comm
1111 
1112 !Local variables-------------------------------
1113 !scalars
1114 #ifdef HAVE_MPI
1115  integer :: comm_world,err_handler_dum,err_handler_sav,ierr,mpierr,mpierr_class
1116 
1117 ! *************************************************************************
1118 
1119  if (comm/=xmpi_comm_null.and.comm/=xmpi_world.and.comm/=xmpi_comm_self) then
1120 
1121    comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
1122    call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,ierr)
1123    call MPI_COMM_FREE(comm,mpierr)
1124    call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,ierr)
1125 
1126    if (mpierr/=MPI_SUCCESS) then
1127      call MPI_ERROR_CLASS(mpierr,mpierr_class,ierr)
1128      if (mpierr_class/=MPI_ERR_COMM) then
1129        write(std_out,*)" WARNING: MPI_COMM_FREE returned ierr= ",mpierr
1130      end if
1131    end if
1132 
1133  end if
1134 
1135 #else
1136  if (.false.) write(std_out,*) comm
1137 #endif
1138 
1139 end subroutine xmpi_comm_free_0D

m_xmpi/xmpi_comm_free_1D [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_comm_free_1D

FUNCTION

  Hides MPI_COMM_FREE from MPI library. Target 1D arrays
  Does not abort MPI in case of an invalid communicator

INPUTS

  comms(:)=MPI communicators

PARENTS

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1162 subroutine xmpi_comm_free_1D(comms)
1163 
1164 
1165 !This section has been created automatically by the script Abilint (TD).
1166 !Do not modify the following lines by hand.
1167 #undef ABI_FUNC
1168 #define ABI_FUNC 'xmpi_comm_free_1D'
1169 !End of the abilint section
1170 
1171  implicit none
1172 
1173 !Arguments-------------------------
1174  integer,intent(inout) :: comms(:)
1175 
1176 !Local variables-------------------------------
1177 !scalars
1178 #ifdef HAVE_MPI
1179  integer :: comm_world,err_handler_dum,err_handler_sav,ii,mpierr
1180 
1181 ! *************************************************************************
1182 
1183  comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
1184  call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,mpierr)
1185 
1186  do ii=LBOUND(comms,DIM=1),UBOUND(comms,DIM=1)
1187    if (comms(ii)/=xmpi_comm_null.and.comms(ii)/=xmpi_world.and.comms(ii)/=xmpi_comm_self) then
1188      call MPI_COMM_FREE(comms(ii),mpierr)
1189    end if
1190  end do
1191 
1192  call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,mpierr)
1193 
1194 #else
1195  if (.false.) write(std_out,*) comms(1)
1196 #endif
1197 
1198 end subroutine xmpi_comm_free_1D

m_xmpi/xmpi_comm_free_2D [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_comm_free_2D

FUNCTION

  Hides MPI_COMM_FREE from MPI library. Target 2D arrays
  Does not abort MPI in case of an invalid communicator

INPUTS

  comms=MPI communicator.

PARENTS

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1221 subroutine xmpi_comm_free_2D(comms)
1222 
1223 
1224 !This section has been created automatically by the script Abilint (TD).
1225 !Do not modify the following lines by hand.
1226 #undef ABI_FUNC
1227 #define ABI_FUNC 'xmpi_comm_free_2D'
1228 !End of the abilint section
1229 
1230  implicit none
1231 
1232 !Arguments-------------------------
1233  integer,intent(inout) :: comms(:,:)
1234 
1235 !Local variables-------------------------------
1236 !scalars
1237 #ifdef HAVE_MPI
1238  integer :: comm_world,err_handler_dum,err_handler_sav,ii,jj,mpierr
1239 
1240 ! *************************************************************************
1241 
1242  comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
1243  call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,mpierr)
1244 
1245  do jj=LBOUND(comms,DIM=2),UBOUND(comms,DIM=2)
1246    do ii=LBOUND(comms,DIM=1),UBOUND(comms,DIM=1)
1247      if (comms(ii,jj)/=xmpi_comm_null.and.comms(ii,jj)/=xmpi_world.and. &
1248 &        comms(ii,jj)/=xmpi_comm_self) then
1249        call MPI_COMM_FREE(comms(ii,jj),mpierr)
1250      end if
1251    end do
1252  end do
1253 
1254  call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,mpierr)
1255 
1256 #else
1257  if (.false.) write(std_out,*) comms(1,1)
1258 #endif
1259 
1260 end subroutine xmpi_comm_free_2D

m_xmpi/xmpi_comm_free_3D [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_comm_free_3D

FUNCTION

  Hides MPI_COMM_FREE from MPI library. Target 3D arrays
  Does not abort MPI in case of an invalid communicator

INPUTS

  comms=MPI communicator.

PARENTS

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1283 subroutine xmpi_comm_free_3D(comms)
1284 
1285 
1286 !This section has been created automatically by the script Abilint (TD).
1287 !Do not modify the following lines by hand.
1288 #undef ABI_FUNC
1289 #define ABI_FUNC 'xmpi_comm_free_3D'
1290 !End of the abilint section
1291 
1292  implicit none
1293 
1294 !Arguments-------------------------
1295  integer,intent(inout) :: comms(:,:,:)
1296 
1297 !Local variables-------------------------------
1298 !scalars
1299 #ifdef HAVE_MPI
1300  integer :: comm_world,err_handler_dum,err_handler_sav,ii,jj,kk,mpierr
1301 
1302 ! *************************************************************************
1303 
1304  comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
1305  call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,mpierr)
1306 
1307  do kk=LBOUND(comms,DIM=3),UBOUND(comms,DIM=3)
1308    do jj=LBOUND(comms,DIM=2),UBOUND(comms,DIM=2)
1309      do ii=LBOUND(comms,DIM=1),UBOUND(comms,DIM=1)
1310        if (comms(ii,jj,kk)/=xmpi_comm_null.and.comms(ii,jj,kk)/=xmpi_world.and. &
1311 &          comms(ii,jj,kk)/=xmpi_comm_self) then
1312          call MPI_COMM_FREE(comms(ii,jj,kk),mpierr)
1313        end if
1314      end do
1315    end do
1316  end do
1317 
1318  call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,mpierr)
1319 
1320 #else
1321  if (.false.) write(std_out,*) comms(1,1,1)
1322 #endif
1323 
1324 end subroutine xmpi_comm_free_3D

m_xmpi/xmpi_comm_group [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_comm_group

FUNCTION

  Hides MPI_COMM_GROUP from MPI library.

INPUTS

  comm=MPI communicator.

OUTPUT

  spaceGroup=The group associated to comm.
  mpierr=error code returned

PARENTS

      m_wfd,m_xmpi,pawprt

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1605 subroutine xmpi_comm_group(comm,spaceGroup,mpierr)
1606 
1607 
1608 !This section has been created automatically by the script Abilint (TD).
1609 !Do not modify the following lines by hand.
1610 #undef ABI_FUNC
1611 #define ABI_FUNC 'xmpi_comm_group'
1612 !End of the abilint section
1613 
1614  implicit none
1615 
1616 !Arguments-------------------------
1617  integer,intent(in) :: comm
1618  integer,intent(out) :: mpierr,spaceGroup
1619 
1620 ! *************************************************************************
1621 
1622  mpierr=0; spaceGroup=xmpi_group_null
1623 #ifdef HAVE_MPI
1624  if (comm/=xmpi_comm_null) then
1625    call MPI_COMM_GROUP(comm,spaceGroup,mpierr)
1626  end if
1627 #endif
1628 
1629 end subroutine xmpi_comm_group

m_xmpi/xmpi_comm_rank [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_comm_rank

FUNCTION

  Hides MPI_COMM_RANK from MPI library.

INPUTS

  comm=MPI communicator.

OUTPUT

  xmpi_comm_rank=The rank of the node inside comm

PARENTS

SOURCE

 995 function xmpi_comm_rank(comm)
 996 
 997 
 998 !This section has been created automatically by the script Abilint (TD).
 999 !Do not modify the following lines by hand.
1000 #undef ABI_FUNC
1001 #define ABI_FUNC 'xmpi_comm_rank'
1002 !End of the abilint section
1003 
1004  implicit none
1005 
1006 !Arguments-------------------------
1007  integer,intent(in) :: comm
1008  integer :: xmpi_comm_rank
1009 
1010 !Local variables-------------------
1011  integer :: mpierr
1012 
1013 ! *************************************************************************
1014 
1015  mpierr=0
1016 #ifdef HAVE_MPI
1017  xmpi_comm_rank=-1  ! Return non-sense value if the proc does not belong to the comm
1018  if (comm/=xmpi_comm_null) then
1019    call MPI_COMM_RANK(comm,xmpi_comm_rank,mpierr)
1020  end if
1021 #else
1022  xmpi_comm_rank=0
1023 #endif
1024 
1025 end function xmpi_comm_rank

m_xmpi/xmpi_comm_set_errhandler [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_set_errhandler

FUNCTION

  Hides MPI_COMM_SET_ERRHANDLER from MPI library.

INPUTS

  new_err_handler= new error handler

OUTPUT

  ierror=error code
  old_err_handler= old error handler

 SIZE EFFECTS
  comm= communicator (should be intent(in) but is intent(inout) in some
             OMPI implementation ; known as a bug)

PARENTS

SOURCE

2231 subroutine xmpi_comm_set_errhandler(comm,new_err_handler,old_err_handler,ierror)
2232 
2233 
2234 !This section has been created automatically by the script Abilint (TD).
2235 !Do not modify the following lines by hand.
2236 #undef ABI_FUNC
2237 #define ABI_FUNC 'xmpi_comm_set_errhandler'
2238 !End of the abilint section
2239 
2240  implicit none
2241 
2242 !Arguments-------------------------
2243  integer,intent(in) :: new_err_handler
2244  integer,intent(in) :: comm
2245  integer,intent(out) :: ierror,old_err_handler
2246 
2247 !Local variables-------------------------
2248  integer :: mpierr1,mpierr2,my_comm
2249 
2250 ! *************************************************************************
2251 
2252  ierror=0
2253  my_comm = comm  !should be intent(in) but is intent(inout) in some OMPI implementation ; known as a bug)
2254 
2255 #if defined HAVE_MPI
2256 
2257  mpierr1=MPI_SUCCESS; mpierr2=MPI_SUCCESS
2258 
2259 #if defined HAVE_MPI1
2260    call MPI_Errhandler_get(my_comm,old_err_handler,mpierr1)
2261    call MPI_Errhandler_set(my_comm,new_err_handler,mpierr2)
2262 #endif
2263 #if defined HAVE_MPI2
2264    call MPI_comm_get_Errhandler(my_comm,old_err_handler,mpierr1)
2265    call MPI_comm_set_Errhandler(my_comm,new_err_handler,mpierr2)
2266 #endif
2267 
2268  ierror=MPI_SUCCESS
2269  if (mpierr1/=MPI_SUCCESS) then
2270    ierror=mpierr1
2271  else if (mpierr2/=MPI_SUCCESS) then
2272    ierror=mpierr2
2273  end if
2274 #endif
2275 
2276 end subroutine xmpi_comm_set_errhandler

m_xmpi/xmpi_comm_size [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_comm_size

FUNCTION

  Hides MPI_COMM_SIZE from MPI library.

INPUTS

  comm=MPI communicator.

OUTPUT

  xmpi_comm_size=The number of processors inside comm.

PARENTS

SOURCE

1047 function xmpi_comm_size(comm)
1048 
1049 
1050 !This section has been created automatically by the script Abilint (TD).
1051 !Do not modify the following lines by hand.
1052 #undef ABI_FUNC
1053 #define ABI_FUNC 'xmpi_comm_size'
1054 !End of the abilint section
1055 
1056  implicit none
1057 
1058 !Arguments-------------------------
1059  integer,intent(in) :: comm
1060  integer :: xmpi_comm_size
1061 
1062 !Local variables-------------------------------
1063 !scalars
1064  integer :: mpierr
1065 
1066 ! *************************************************************************
1067 
1068  mpierr=0; xmpi_comm_size=1
1069 #ifdef HAVE_MPI
1070  if (comm/=xmpi_comm_null) then
1071    call MPI_COMM_SIZE(comm,xmpi_comm_size,mpierr)
1072  end if
1073 #endif
1074 
1075 end function xmpi_comm_size

m_xmpi/xmpi_comm_split [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_comm_split

FUNCTION

  Hides MPI_COMM_SPLIT from MPI library.

INPUTS

  input_comm=Input MPI communicator (to be splitted)
  color=Control of subset assignment (nonnegative integer).
        Processes with the same color are in the same new communicator
  key=Ccontrol of rank assigment (integer)

OUTPUT

  mpierr=error code returned
  output_comm=new splitted communicator

PARENTS

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1658 subroutine xmpi_comm_split(input_comm,color,key,output_comm,mpierr)
1659 
1660 
1661 !This section has been created automatically by the script Abilint (TD).
1662 !Do not modify the following lines by hand.
1663 #undef ABI_FUNC
1664 #define ABI_FUNC 'xmpi_comm_split'
1665 !End of the abilint section
1666 
1667  implicit none
1668 
1669 !Arguments-------------------------
1670 !scalars
1671  integer,intent(in) :: color,input_comm,key
1672  integer,intent(out) :: mpierr,output_comm
1673 
1674 ! *************************************************************************
1675 
1676  mpierr=0; output_comm=input_comm
1677 #ifdef HAVE_MPI
1678  if (input_comm/=xmpi_comm_null.and.input_comm/=xmpi_comm_self) then
1679    call MPI_COMM_SPLIT(input_comm,color,key,output_comm,mpierr)
1680  end if
1681 #endif
1682 
1683 end subroutine xmpi_comm_split

m_xmpi/xmpi_comm_translate_ranks [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_comm_translate_ranks

FUNCTION

  Helper function that translate the ranks from a communicator to another one.
  Wraps xmpi_group_translate_ranks but provides a more user-friendly interface

INPUTS

  from_comm=MPI communicator where from_ranks are defined.
  nrank=number of ranks in from_ranks and to_ranks arrays
  from_ranks(nrank)=array of zero or more valid ranks in from_comm

OUTPUT

  to_ranks(nrank)=array of corresponding ranks in to_comm
                xmpi_undefined when no correspondence exists

PARENTS

      m_paral_pert

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1776 subroutine xmpi_comm_translate_ranks(from_comm,nrank,from_ranks,to_comm,to_ranks)
1777 
1778 
1779 !This section has been created automatically by the script Abilint (TD).
1780 !Do not modify the following lines by hand.
1781 #undef ABI_FUNC
1782 #define ABI_FUNC 'xmpi_comm_translate_ranks'
1783 !End of the abilint section
1784 
1785  implicit none
1786 
1787 !Arguments-------------------------
1788 !scalars
1789  integer,intent(in) :: nrank,from_comm,to_comm
1790 !arrays
1791  integer,intent(in) :: from_ranks(nrank)
1792  integer,intent(out) :: to_ranks(nrank)
1793 
1794 !Local variables-------------------------------
1795 !scalars
1796  integer :: ierr,from_group,to_group
1797 
1798 ! *************************************************************************
1799 
1800  ! Get the groups
1801  call xmpi_comm_group(from_comm,from_group,ierr)
1802  call xmpi_comm_group(to_comm,to_group,ierr)
1803 
1804  call xmpi_group_translate_ranks(from_group,nrank,from_ranks,to_group,to_ranks,ierr)
1805 
1806  ! Release the groups
1807  call xmpi_group_free(from_group)
1808  call xmpi_group_free(to_group)
1809 
1810 end subroutine xmpi_comm_translate_ranks

m_xmpi/xmpi_distab_4D [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_distab_4D

FUNCTION

  Fill table defining the distribution of the tasks according to the number of processors involved in the
  calculation. For each set of indeces, the table contains the rank of the node in the MPI communicator.

INPUTS

  nprocs=The number of processors performing the calculation in parallel.

OUTPUT

  task_distrib(:,:,:,:) = Contains the rank of the node that is taking care of this particular set of loop indeces.
  Tasks are distributed across the nodes in column-major order.

PARENTS

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

2576 subroutine xmpi_distab_4D(nprocs,task_distrib)
2577 
2578 
2579 !This section has been created automatically by the script Abilint (TD).
2580 !Do not modify the following lines by hand.
2581 #undef ABI_FUNC
2582 #define ABI_FUNC 'xmpi_distab_4D'
2583 !End of the abilint section
2584 
2585  implicit none
2586 
2587 !Arguments ------------------------------------
2588  integer,intent(in) :: nprocs
2589 !arrays
2590  integer,intent(inout) :: task_distrib(:,:,:,:)
2591 
2592 !Local variables ------------------------------
2593 !scalars
2594  integer :: ii,jj,n1,n2,n3,n4,ntasks,irank,remainder,ntpblock
2595  integer,allocatable :: list(:)
2596 
2597 !************************************************************************
2598 
2599  n1= SIZE(task_distrib,DIM=1)
2600  n2= SIZE(task_distrib,DIM=2)
2601  n3= SIZE(task_distrib,DIM=3)
2602  n4= SIZE(task_distrib,DIM=4)
2603  ntasks = n1*n2*n3*n4
2604 
2605  ABI_ALLOCATE(list,(ntasks))
2606  list=-999
2607 
2608  ntpblock  = ntasks/nprocs
2609  remainder = MOD(ntasks,nprocs)
2610 
2611  if (ntpblock==0) then ! nprocs > ntasks
2612    do ii=1,ntasks
2613      list(ii) = ii-1
2614    end do
2615  else
2616    ii=1
2617    do irank=nprocs-1,0,-1 ! If remainder/=0, master will get less tasks.
2618      jj = ii+ntpblock-1
2619      if (remainder>0) then
2620        jj=jj+1
2621        remainder = remainder-1
2622      end if
2623      list(ii:jj)=irank
2624      ii=jj+1
2625    end do
2626  end if
2627 
2628  task_distrib = RESHAPE(list,(/n1,n2,n3,n4/))
2629 
2630  if (ANY(task_distrib==-999)) then
2631    call xmpi_abort(msg="task_distrib == -999")
2632  end if
2633 
2634  ABI_DEALLOCATE(list)
2635 
2636 end subroutine xmpi_distab_4D

m_xmpi/xmpi_distrib_with_replicas [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_distrib_with_replicas

FUNCTION

  This function distributes the i-th task among `nprocs` inside a MPI communicator.
  If nprocs > ntasks, multiple MPI ranks will be assigned to a given task.

INPUTS

  itask=Index of the task (must be <= ntasks)
  ntasks= number of tasks
  rank=MPI Rank of this processor
  nprocs=Number of processors in the MPI communicator.

OUTPUT

  True if this node will treat itask (replicas are possible if nprocs > ntasks)

PARENTS

SOURCE

2662 pure function xmpi_distrib_with_replicas(itask,ntasks,rank,nprocs) result(bool)
2663 
2664 
2665 !This section has been created automatically by the script Abilint (TD).
2666 !Do not modify the following lines by hand.
2667 #undef ABI_FUNC
2668 #define ABI_FUNC 'xmpi_distrib_with_replicas'
2669 !End of the abilint section
2670 
2671  implicit none
2672 
2673 !Arguments ------------------------------------
2674 !scalars
2675  integer,intent(in) :: itask,rank,nprocs,ntasks
2676  logical :: bool
2677 
2678 !Local variables-------------------------------
2679 !scalars
2680  integer :: ii,mnp_pool,rk_base
2681 
2682 ! *************************************************************************
2683 
2684  ! If the number of processors is less than ntasks, we have max one task per processor,
2685  ! else we replicate the tasks inside a pool of max size mnp_pool
2686  if (nprocs <= ntasks) then
2687    bool = (MODULO(itask-1, nprocs)==rank)
2688  else
2689    mnp_pool = (nprocs / ntasks)
2690    !write(std_out,*)"Will duplicate itasks"
2691    !write(std_out,*)"mnp_pool",mnp_pool,"nprocs, ntasks",nprocs,ntasks
2692 
2693    rk_base = MODULO(itask-1, nprocs)
2694    bool = .False.
2695    do ii=1,mnp_pool+1
2696      if (rank == rk_base + (ii-1) * ntasks) then
2697         bool = .True.; exit
2698      end if
2699    end do
2700  end if
2701 
2702 end function xmpi_distrib_with_replicas

m_xmpi/xmpi_end [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_end

FUNCTION

  Hides MPI_FINALIZE from MPI library.

INPUTS

  None

PARENTS

      aim,anaddb,band2eps,bsepostproc,conducti,cut3d,eph,fold2Bloch
      lapackprof,macroave,mrggkk,optic,tdep,ujdet,vdw_kernelgen

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

734 subroutine xmpi_end()
735 
736 
737 !This section has been created automatically by the script Abilint (TD).
738 !Do not modify the following lines by hand.
739 #undef ABI_FUNC
740 #define ABI_FUNC 'xmpi_end'
741 !End of the abilint section
742 
743  implicit none
744 
745 !Local variables-------------------
746  integer :: mpierr
747 
748 ! *************************************************************************
749 
750  mpierr=0
751 #ifdef HAVE_MPI
752  call MPI_BARRIER(MPI_COMM_WORLD,mpierr)  !  Needed by some HPC architectures (MT, 20110315)
753  call MPI_FINALIZE(mpierr)
754 #endif
755 
756 #ifndef FC_IBM
757  ! IBM8 returns 260. 320 ...
758  call sys_exit(0)
759 #endif
760 
761 end subroutine xmpi_end

m_xmpi/xmpi_error_string [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_error_string

FUNCTION

  Hides MPI_ERROR_STRING from MPI library.

INPUTS

OUTPUT

PARENTS

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

2178 subroutine xmpi_error_string(mpierr,err_string,ilen,ierror)
2179 
2180 
2181 !This section has been created automatically by the script Abilint (TD).
2182 !Do not modify the following lines by hand.
2183 #undef ABI_FUNC
2184 #define ABI_FUNC 'xmpi_error_string'
2185 !End of the abilint section
2186 
2187  implicit none
2188 
2189 !Arguments-------------------------
2190  integer,intent(in) :: mpierr
2191  integer,intent(out) :: ilen,ierror
2192  character(len=*),intent(out) :: err_string
2193 
2194 ! *************************************************************************
2195 
2196  ilen=0
2197 #ifdef HAVE_MPI
2198  call MPI_Error_string(mpierr,err_string,ilen,ierror)
2199 #else
2200  ierror=1
2201  err_string="Sorry, no MPI_Error_string routine is available to interpret the error message"
2202 #endif
2203 
2204 end subroutine xmpi_error_string

m_xmpi/xmpi_get_unit [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_get_unit

FUNCTION

 Get free unit (emulate F2008 newunit for portability reasons)
 Return -1 if no unit is found.

PARENTS

CHILDREN

SOURCE

689 integer function xmpi_get_unit() result(unt)
690 
691 
692 !This section has been created automatically by the script Abilint (TD).
693 !Do not modify the following lines by hand.
694 #undef ABI_FUNC
695 #define ABI_FUNC 'xmpi_get_unit'
696 !End of the abilint section
697 
698  implicit none
699 
700 !Local variables-------------------
701  logical :: isopen
702 
703 ! *************************************************************************
704 
705  do unt=1024,-1,-1
706    inquire(unit=unt, opened=isopen)
707    if (.not.isopen) exit
708  end do
709 
710 end function xmpi_get_unit

m_xmpi/xmpi_group_free [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_group_free

FUNCTION

  Hides MPI_GROUP_FREE from MPI library.
  Does not abort MPI in case of an invalid group

INPUTS

  spaceGroup=MPI group

PARENTS

      m_wfd,m_xmpi,pawprt

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1348 subroutine xmpi_group_free(spaceGroup)
1349 
1350 
1351 !This section has been created automatically by the script Abilint (TD).
1352 !Do not modify the following lines by hand.
1353 #undef ABI_FUNC
1354 #define ABI_FUNC 'xmpi_group_free'
1355 !End of the abilint section
1356 
1357  implicit none
1358 
1359 !Arguments-------------------------
1360  integer,intent(inout) :: spaceGroup
1361 
1362 !Local variables-------------------------------
1363 !scalars
1364 #ifdef HAVE_MPI
1365  integer :: comm_world,err_handler_dum,err_handler_sav,ierr,mpierr,mpierr_class
1366 
1367 ! *************************************************************************
1368 
1369  if (spaceGroup/=xmpi_group_null) then
1370 
1371    comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
1372    call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,ierr)
1373    call MPI_GROUP_FREE(spaceGroup,mpierr)
1374    call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,ierr)
1375 
1376    if (mpierr/=MPI_SUCCESS) then
1377      call MPI_ERROR_CLASS(mpierr,mpierr_class,ierr)
1378      if (mpierr_class/=MPI_ERR_GROUP) then
1379        write(std_out,*)" WARNING: MPI_GROUP_FREE returned ierr= ",mpierr
1380      end if
1381    end if
1382 
1383  end if
1384 
1385 #else
1386  if (.false.) write(std_out,*) spaceGroup
1387 #endif
1388 
1389 end subroutine xmpi_group_free

m_xmpi/xmpi_group_incl [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_group_incl

FUNCTION

  Hides MPI_GROUP_INCL from MPI library.

INPUTS

  group=input group
  nrank=number of elements in array ranks (size of newgroup)
  ranks=ranks of processes in group to appear in newgroup

OUTPUT

  newgroup= new group derived from above, in the order defined by ranks

PARENTS

      m_wfd

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1417 subroutine xmpi_group_incl(group,nranks,ranks,newgroup,mpierr)
1418 
1419 
1420 !This section has been created automatically by the script Abilint (TD).
1421 !Do not modify the following lines by hand.
1422 #undef ABI_FUNC
1423 #define ABI_FUNC 'xmpi_group_incl'
1424 !End of the abilint section
1425 
1426  implicit none
1427 
1428 !Arguments-------------------------
1429 !scalars
1430  integer,intent(in) :: group,nranks
1431  integer,intent(out) :: mpierr
1432  integer,intent(inout) :: newgroup
1433 !arrays
1434  integer,intent(in) :: ranks(nranks)
1435 
1436 ! *************************************************************************
1437 
1438  mpierr=0 ; newgroup=xmpi_group_null
1439 #ifdef HAVE_MPI
1440  if (group/=xmpi_group_null) then
1441    call MPI_GROUP_INCL(group,nranks,ranks,newgroup,mpierr)
1442  end if
1443 #endif
1444 
1445 end subroutine xmpi_group_incl

m_xmpi/xmpi_group_translate_ranks [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_group_translate_ranks

FUNCTION

  Hides MPI_GROUP_TRANSLATE_RANKS from MPI library.

INPUTS

  nrank=number of ranks in ranks1 and ranks2 arrays
  ranks1(nrank)=array of zero or more valid ranks in group1
  spaceGroup1=group1
  spaceGroup2=group2

OUTPUT

  mpierr=error code returned
  ranks2(nrank)=array of corresponding ranks in group2,
                xmpi_undefined when no correspondence exists

PARENTS

      m_xmpi,pawprt

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1714 subroutine xmpi_group_translate_ranks(spaceGroup1,nrank,ranks1,&
1715 &                                     spaceGroup2,ranks2,mpierr)
1716 
1717 
1718 !This section has been created automatically by the script Abilint (TD).
1719 !Do not modify the following lines by hand.
1720 #undef ABI_FUNC
1721 #define ABI_FUNC 'xmpi_group_translate_ranks'
1722 !End of the abilint section
1723 
1724  implicit none
1725 
1726 !Arguments-------------------------
1727 !scalars
1728  integer,intent(in) :: nrank,spaceGroup1,spaceGroup2
1729  integer,intent(out) :: mpierr
1730 !arrays
1731  integer,intent(in) :: ranks1(nrank)
1732  integer,intent(out) :: ranks2(nrank)
1733 
1734 ! *************************************************************************
1735 
1736  mpierr=0; ranks2(:)=xmpi_undefined
1737 #ifdef HAVE_MPI
1738  if (spaceGroup1/=xmpi_group_null.and.spaceGroup2/=xmpi_group_null) then
1739    call MPI_GROUP_TRANSLATE_RANKS(spaceGroup1,nrank,ranks1,&
1740 &                                 spaceGroup2,ranks2,mpierr)
1741  end if
1742 #else
1743  ranks2(1)=0
1744 #endif
1745 
1746 end subroutine xmpi_group_translate_ranks

m_xmpi/xmpi_init [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_init

FUNCTION

  Hides MPI_INIT from MPI library. Perform the initialization of some basic variables
  used by the MPI routines employed in abinit.

INPUTS

  None

PARENTS

      abinit,aim,anaddb,band2eps,bsepostproc,conducti,cut3d,dummy_tests
      fftprof,fold2Bloch,ioprof,lapackprof,macroave,mrgddb,mrgdv,mrggkk
      mrgscr,multibinit,optic,tdep,ujdet,vdw_kernelgen

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

594 subroutine xmpi_init()
595 
596 
597 !This section has been created automatically by the script Abilint (TD).
598 !Do not modify the following lines by hand.
599 #undef ABI_FUNC
600 #define ABI_FUNC 'xmpi_init'
601 !End of the abilint section
602 
603  implicit none
604 
605 !Local variables-------------------
606  integer :: mpierr,ierr,unt
607  logical :: exists
608 #ifdef HAVE_MPI
609  integer :: attribute_val
610  logical :: lflag
611 #ifdef HAVE_OPENMP
612  integer :: required,provided
613 #endif
614 #endif
615 
616 ! *************************************************************************
617 
618  mpierr=0
619 #ifdef HAVE_MPI
620 
621 #ifndef HAVE_OPENMP
622  call MPI_INIT(mpierr)
623 #else
624  required = MPI_THREAD_SINGLE
625  !required = MPI_THREAD_FUNNELED
626  !required = MPI_THREAD_SERIALIZED
627  !required = MPI_THREAD_MULTIPLE
628  call MPI_INIT_THREAD(required,provided,mpierr)
629  if (provided /= required) then
630    call xmpi_abort(msg="MPI_INIT_THREADS: provided /= required")
631  end if
632 #endif
633 
634  !%comm_world = xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
635  !%call xmpi_comm_set_errhandler(comm_world, MPI_ERRORS_RETURN, err_handler_sav, mpierr)
636 
637  ! Deprecated in MPI2 but not all MPI2 implementations provide MPI_Comm_get_attr !
638  call MPI_ATTR_GET(xmpi_world, MPI_TAG_UB, attribute_val, lflag, mpierr)
639  !call MPI_Comm_get_attr(xmpi_world, MPI_TAG_UB, attribute_val, lflag, mpierr)
640 
641  if (lflag) xmpi_tag_ub = attribute_val
642 
643 !  Define type values.
644  call MPI_TYPE_SIZE(MPI_CHARACTER,xmpi_bsize_ch,mpierr)
645  call MPI_TYPE_SIZE(MPI_INTEGER,xmpi_bsize_int,mpierr)
646  call MPI_TYPE_SIZE(MPI_REAL,xmpi_bsize_sp,mpierr)
647  call MPI_TYPE_SIZE(MPI_DOUBLE_PRECISION,xmpi_bsize_dp,mpierr)
648  call MPI_TYPE_SIZE(MPI_COMPLEX,xmpi_bsize_spc,mpierr)
649  call MPI_TYPE_SIZE(MPI_DOUBLE_COMPLEX,xmpi_bsize_dpc,mpierr)
650 
651  ! Find the byte size of Fortran record marker used in MPI-IO routines.
652  if (xmpio_bsize_frm == 0) then
653    call xmpio_get_info_frm(xmpio_bsize_frm, xmpio_mpi_type_frm, xmpi_world)
654  end if
655 #endif
656 
657  ! Master Removes the ABI_MPIABORTFILE if present so that we start with a clean environment
658  if (xmpi_comm_rank(xmpi_world) == 0) then
659     inquire(file=ABI_MPIABORTFILE, exist=exists)
660     if (exists) then
661        ! Get free unit (emulate F2008 newunit for portability reasons)
662        unt = xmpi_get_unit()
663        if (unt == -1) call xmpi_abort(msg="Cannot find free unit!!")
664        open(unit=unt, file=trim(ABI_MPIABORTFILE), status="old", iostat=ierr)
665        if (ierr == 0) close(unit=unt, status="delete", iostat=ierr)
666        if (ierr /= 0) call xmpi_abort(msg="Cannot remove ABI_MPIABORTFILE")
667     end if
668  end if
669 
670 end subroutine xmpi_init

m_xmpi/xmpi_iprobe [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_iprobe

FUNCTION

  Hides MPI_IPROBE from MPI library.
  Nonblocking test for a message.

INPUTS

  source= source processes
  tag= tag value
  mpicomm= communicator

OUTPUT

  flag= True if a message with the specified source, tag, and communicator is available
  mpierr= status error

PARENTS

      m_paw_an,m_paw_ij,m_pawfgrtab,m_pawrhoij

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1959 subroutine xmpi_iprobe(source,tag,mpicomm,flag,mpierr)
1960 
1961 
1962 !This section has been created automatically by the script Abilint (TD).
1963 !Do not modify the following lines by hand.
1964 #undef ABI_FUNC
1965 #define ABI_FUNC 'xmpi_iprobe'
1966 !End of the abilint section
1967 
1968  implicit none
1969 
1970 !Arguments-------------------------
1971  integer,intent(in) :: mpicomm,source,tag
1972  integer,intent(out) :: mpierr
1973  logical,intent(out) :: flag
1974 
1975 !Local variables-------------------
1976 #ifdef HAVE_MPI
1977  integer :: ier,status(MPI_STATUS_SIZE)
1978 #endif
1979 
1980 ! *************************************************************************
1981 
1982  mpierr = 0
1983 #ifdef HAVE_MPI
1984   call MPI_IPROBE(source,tag,mpicomm,flag,status,ier)
1985   mpierr=ier
1986 #endif
1987 
1988 end subroutine xmpi_iprobe

m_xmpi/xmpi_name [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_name

FUNCTION

  Hides MPI_GET_PROCESSOR_NAME from MPI library.

OUTPUT

  name= the host name transformed to integer variable.
  mpierr=Status error.

PARENTS

      m_gpu_detect

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

1896 subroutine xmpi_name(name_ch, mpierr)
1897 
1898 
1899 !This section has been created automatically by the script Abilint (TD).
1900 !Do not modify the following lines by hand.
1901 #undef ABI_FUNC
1902 #define ABI_FUNC 'xmpi_name'
1903 !End of the abilint section
1904 
1905  implicit none
1906 
1907 !Arguments-------------------------
1908  integer,intent(out) ::  mpierr
1909  character(20),intent(out) :: name_ch
1910 
1911 !Local variables-------------------
1912  integer :: name,len
1913 ! character(len=MPI_MAX_PROCESSOR_NAME) :: name_ch
1914 
1915 ! *************************************************************************
1916 !Get the name of this processor (usually the hostname)
1917 
1918  name   = 0
1919  mpierr = 0
1920 
1921 #ifdef HAVE_MPI
1922  call MPI_GET_PROCESSOR_NAME(name_ch, len, mpierr)
1923  name_ch = trim(name_ch)
1924 
1925 #else
1926  name_ch ='0'
1927 #endif
1928 
1929 end subroutine xmpi_name

m_xmpi/xmpi_request_free [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_request_free

FUNCTION

  Hides MPI_REQUEST_FREE from MPI library.
  Frees an array of communication request objects.

INPUTS

  requests(:)= communication request  array (array of handles)

OUTPUT

  mpierr= status error

PARENTS

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

2125 subroutine xmpi_request_free(requests,mpierr)
2126 
2127 
2128 !This section has been created automatically by the script Abilint (TD).
2129 !Do not modify the following lines by hand.
2130 #undef ABI_FUNC
2131 #define ABI_FUNC 'xmpi_request_free'
2132 !End of the abilint section
2133 
2134  implicit none
2135 
2136 !Arguments-------------------------
2137  integer,intent(inout) :: requests(:)
2138  integer,intent(out)  :: mpierr
2139 
2140 !Local variables-------------------
2141 #ifdef HAVE_MPI
2142  integer :: ier,ii
2143 #endif
2144 
2145 ! *************************************************************************
2146 
2147  mpierr = 0
2148 #ifdef HAVE_MPI
2149  do ii=1,size(requests)
2150    call MPI_REQUEST_FREE(requests(ii),ier)
2151  end do
2152  mpierr=ier
2153 #endif
2154 
2155 end subroutine xmpi_request_free

m_xmpi/xmpi_show_info [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_show_info

FUNCTION

  Printout of the most important variables stored in this module (useful for debugging).

INPUTS

  unt=Unit number for formatted output.

PARENTS

      abinit,leave_new,m_argparse

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

924 subroutine xmpi_show_info(unit)
925 
926 
927 !This section has been created automatically by the script Abilint (TD).
928 !Do not modify the following lines by hand.
929 #undef ABI_FUNC
930 #define ABI_FUNC 'xmpi_show_info'
931 !End of the abilint section
932 
933  implicit none
934 
935 !Arguments-------------------------
936  integer,optional,intent(in) :: unit
937 
938 !Local variables-------------------
939  integer :: my_unt
940 
941 ! *************************************************************************
942 
943  !@m_xmpi
944  my_unt = std_out; if (PRESENT(unit)) my_unt=unit
945 
946 #ifdef HAVE_MPI1
947   write(my_unt,*)" ==== Using MPI-1 specifications ==== "
948 #endif
949 #ifdef HAVE_MPI2
950   write(my_unt,*)" ==== Using MPI-2 specifications ==== "
951 #endif
952 
953 #ifdef HAVE_MPI_IO
954   write(my_unt,*)" MPI-IO support is ON"
955 #else
956   write(my_unt,*)" MPI-IO support is OFF"
957 #endif
958 
959 #ifdef HAVE_MPI
960  write(my_unt,*)" xmpi_tag_ub ................ ",xmpi_tag_ub
961  write(my_unt,*)" xmpi_bsize_ch .............. ",xmpi_bsize_ch
962  write(my_unt,*)" xmpi_bsize_int ............. ",xmpi_bsize_int
963  write(my_unt,*)" xmpi_bsize_sp .............. ",xmpi_bsize_sp
964  write(my_unt,*)" xmpi_bsize_dp .............. ",xmpi_bsize_dp
965  write(my_unt,*)" xmpi_bsize_spc ............. ",xmpi_bsize_spc
966  write(my_unt,*)" xmpi_bsize_dpc ............. ",xmpi_bsize_dpc
967  write(my_unt,*)" xmpio_bsize_frm ............ ",xmpio_bsize_frm
968  write(my_unt,*)" xmpi_address_kind .......... ",xmpi_address_kind
969  write(my_unt,*)" xmpi_offset_kind ........... ",xmpi_offset_kind
970  write(my_unt,*)" MPI_WTICK .................. ",MPI_WTICK()
971 #endif
972 
973 end subroutine xmpi_show_info

m_xmpi/xmpi_split_work2_i4b [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_split_work2_i4b

FUNCTION

  Splits a number of tasks, ntasks, among nprocs processors.
  The output arrays istart(1:nprocs) and istop(1:nprocs)
  report the starting and final task index for each CPU.
  Namely CPU with rank ii has to perform all the tasks between
  istart(ii+1) and istop(ii+1). Note the Fortran convention of using
  1 as first index of the array.
  Note, moreover, that if a proc has rank>ntasks then :
   istart(rank+1)=ntasks+1
   istop(rank+1)=ntask

  In this particular case, loops of the form

  do ii=istart(rank),istop(rank)
   ...
  end do

  are not executed. Moreover allocation such as foo(istart(rank):istop(rank))
  will generate a zero-sized array

INPUTS

  ntasks= number of tasks
  nprocs=Number of processors.

OUTPUT

  istart(nprocs),istop(nprocs)= indices defining the initial and final task for each processor
  ierr=Error status.
  warn_msg=String containing the warning message.
    +1 if ntasks is not divisible by nprocs.
    +2 if ntasks>nprocs.

PARENTS

      exc_build_block,m_screening,m_skw,setup_screening

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

2415 subroutine xmpi_split_work2_i4b(ntasks,nprocs,istart,istop,warn_msg,ierr)
2416 
2417 
2418 !This section has been created automatically by the script Abilint (TD).
2419 !Do not modify the following lines by hand.
2420 #undef ABI_FUNC
2421 #define ABI_FUNC 'xmpi_split_work2_i4b'
2422 !End of the abilint section
2423 
2424  implicit none
2425 
2426 !Arguments ------------------------------------
2427  integer,intent(in)  :: ntasks,nprocs
2428  integer,intent(out) :: ierr
2429  integer,intent(inout) :: istart(nprocs),istop(nprocs)
2430  character(len=500),intent(out) :: warn_msg
2431 
2432 !Local variables-------------------------------
2433  integer :: res,irank,block,block_tmp
2434 
2435 ! *************************************************************************
2436 
2437  block_tmp = ntasks/nprocs
2438  res       = MOD(ntasks,nprocs)
2439  block     = block_tmp+1
2440 
2441  warn_msg = ""; ierr=0
2442  if (res/=0) then
2443    write(warn_msg,'(a,i0,a,i0,2a)')&
2444 &   'The number of tasks = ',ntasks,' is not divisible by nprocs = ',nprocs,ch10,&
2445 &   'parallelism is not efficient '
2446    ierr=+1
2447  end if
2448 
2449  if (block_tmp==0) then
2450    write(warn_msg,'(a,i0,a,i0,2a)')&
2451 &   'The number of processors = ',nprocs,' is larger than number of tasks =',ntasks,ch10,&
2452 &   'This is a waste '
2453    ierr=+2
2454  end if
2455 
2456  do irank=0,nprocs-1
2457    if (irank<res) then
2458      istart(irank+1) = irank    *block+1
2459      istop (irank+1) = (irank+1)*block
2460    else
2461      istart(irank+1) = res*block + (irank-res  )*block_tmp+1
2462      istop (irank+1) = res*block + (irank-res+1)*block_tmp
2463    end if
2464  end do
2465 
2466 end subroutine xmpi_split_work2_i4b

m_xmpi/xmpi_split_work2_i8b [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_split_work2_i8b

FUNCTION

  Same as xmpi_split_work2_i8b but accepts 8 bytes integer.

INPUTS

  ntasks= number of tasks
  nprocs=Number of processors.

OUTPUT

  istart(nprocs),istop(nprocs)= indices defining the initial and final task for each processor
  ierr=Error status.
  warn_msg=String containing the warning message.
    +1 if ntasks is not divisible by nprocs.
    +2 if ntasks>nprocs.

PARENTS

      exc_build_block,m_shirley

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

2497 subroutine xmpi_split_work2_i8b(ntasks,nprocs,istart,istop,warn_msg,ierr)
2498 
2499 
2500 !This section has been created automatically by the script Abilint (TD).
2501 !Do not modify the following lines by hand.
2502 #undef ABI_FUNC
2503 #define ABI_FUNC 'xmpi_split_work2_i8b'
2504 !End of the abilint section
2505 
2506  implicit none
2507 
2508 !Arguments ------------------------------------
2509  integer,intent(in)  :: nprocs
2510  integer(i8b),intent(in)  :: ntasks
2511  integer,intent(out) :: ierr
2512  integer(i8b),intent(inout) :: istart(nprocs),istop(nprocs)
2513  character(len=500),intent(out) :: warn_msg
2514 
2515 !Local variables-------------------------------
2516  integer(i8b) :: res,irank,block,block_tmp
2517 
2518 ! *************************************************************************
2519 
2520  block_tmp = ntasks/nprocs
2521  res       = MOD(ntasks,INT(nprocs,KIND=i8b))
2522  block     = block_tmp+1
2523 
2524  warn_msg = ""; ierr=0
2525  if (res/=0) then
2526    write(warn_msg,'(a,i0,a,i0,2a)')&
2527 &   'The number of tasks = ',ntasks,' is not divisible by nprocs = ',nprocs,ch10,&
2528 &   'parallelism is not efficient '
2529    ierr=+1
2530  end if
2531  !
2532  if (block_tmp==0) then
2533    write(warn_msg,'(a,i0,a,i0,2a)')&
2534 &   ' The number of processors = ',nprocs,' is larger than number of tasks =',ntasks,ch10,&
2535 &   ' This is a waste '
2536    ierr=+2
2537  end if
2538 
2539  do irank=0,nprocs-1
2540    if (irank<res) then
2541      istart(irank+1)= irank   *block+1
2542      istop (irank+1)=(irank+1)*block
2543    else
2544      istart(irank+1)=res*block+(irank-res  )*block_tmp+1
2545      istop (irank+1)=res*block+(irank-res+1)*block_tmp
2546    end if
2547  end do
2548 
2549 end subroutine xmpi_split_work2_i8b

m_xmpi/xmpi_split_work_i4b [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  split_work_i4b

FUNCTION

  Splits the number of tasks, ntasks, among nprocs processors. Used for the MPI parallelization of simple loops.

INPUTS

  ntasks=number of tasks
  comm=MPI communicator.

OUTPUT

  my_start,my_stop= indices defining the initial and final task for this processor
  warn_msg=String containing a possible warning message if the distribution is not optima.
  ierr=Error status
    +1 if ntasks is not divisible by nprocs.
    +2 if ntasks>nprocs.

NOTES

  If nprocs>ntasks then :
    my_start=ntasks+1
    my_stop=ntask

  In this particular case, loops of the form

  do ii=my_start,my_stop
   ...
  end do

  are not executed. Moreover allocation such as foo(my_start:my_stop) will generate a zero-sized array.

PARENTS

SOURCE

2316 subroutine xmpi_split_work_i4b(ntasks,comm,my_start,my_stop,warn_msg,ierr)
2317 
2318 
2319 !This section has been created automatically by the script Abilint (TD).
2320 !Do not modify the following lines by hand.
2321 #undef ABI_FUNC
2322 #define ABI_FUNC 'xmpi_split_work_i4b'
2323 !End of the abilint section
2324 
2325  implicit none
2326 
2327 !Arguments ------------------------------------
2328  integer,intent(in)  :: ntasks,comm
2329  integer,intent(out) :: my_start,my_stop,ierr
2330  character(len=500) :: warn_msg
2331 
2332 !Local variables-------------------------------
2333  integer :: res,nprocs,my_rank,block_p1,block
2334 
2335 ! *************************************************************************
2336 
2337  nprocs  = xmpi_comm_size(comm)
2338  my_rank = xmpi_comm_rank(comm)
2339 
2340  block   = ntasks/nprocs
2341  res     = MOD(ntasks,nprocs)
2342  block_p1= block+1
2343 
2344  warn_msg = ""; ierr=0
2345  if (res/=0) then
2346    write(warn_msg,'(4a,i0,a,i0)')ch10,&
2347 &   'xmpi_split_work: ',ch10,&
2348 &   'The number of tasks= ',ntasks,' is not divisible by nprocs= ',nprocs
2349    ierr=1
2350  end if
2351  if (block==0) then
2352    write(warn_msg,'(4a,i0,a,i0,2a)')ch10,&
2353 &   'xmpi_split_work: ',ch10,&
2354 &   'The number of processors= ',nprocs,' is larger than number of tasks= ',ntasks,ch10,&
2355 &   'This is a waste '
2356     ierr=2
2357  end if
2358 
2359  if (my_rank<res) then
2360    my_start =  my_rank   *block_p1+1
2361    my_stop  = (my_rank+1)*block_p1
2362  else
2363    my_start = res*block_p1 + (my_rank-res  )*block + 1
2364    my_stop  = res*block_p1 + (my_rank-res+1)*block
2365  end if
2366 
2367 end subroutine xmpi_split_work_i4b

m_xmpi/xmpi_subcomm [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_subcomm

FUNCTION

  Return a sub-communicator from an input communicator and a given proc. ranks set.
  (hides subgroup creation/destruction)

INPUTS

  comm=input communicator
  nrank=number of elements in array ranks (size of subcomm)
  ranks=ranks of processes in group to appear in subcomm

OUTPUT

  [my_rank_in_group]=optional: my rank in the group of new sub-communicator
  xmpi_subcomm=new (sub-)communicator

PARENTS

SOURCE

1528 function xmpi_subcomm(comm,nranks,ranks,my_rank_in_group)
1529 
1530 
1531 !This section has been created automatically by the script Abilint (TD).
1532 !Do not modify the following lines by hand.
1533 #undef ABI_FUNC
1534 #define ABI_FUNC 'xmpi_subcomm'
1535 !End of the abilint section
1536 
1537  implicit none
1538 
1539 !Arguments-------------------------
1540 !scalars
1541  integer,intent(in) :: comm,nranks
1542  integer,intent(out),optional :: my_rank_in_group
1543  integer :: xmpi_subcomm
1544 !arrays
1545  integer,intent(in) :: ranks(nranks)
1546 
1547 !Local variables-------------------------------
1548 #ifdef HAVE_MPI
1549  integer :: group,ierr,subgroup
1550 #endif
1551 
1552 ! *************************************************************************
1553 
1554  xmpi_subcomm=xmpi_comm_null
1555  if (present(my_rank_in_group)) my_rank_in_group=xmpi_undefined
1556 
1557 #ifdef HAVE_MPI
1558  if (comm/=xmpi_comm_null.and.nranks>=0) then
1559    call MPI_COMM_GROUP(comm,group,ierr)
1560    call MPI_GROUP_INCL(group,nranks,ranks,subgroup,ierr)
1561    call MPI_COMM_CREATE(comm,subgroup,xmpi_subcomm,ierr)
1562    if ( nranks == 0 )xmpi_subcomm=xmpi_comm_self
1563    if (present(my_rank_in_group)) then
1564      call MPI_Group_rank(subgroup,my_rank_in_group,ierr)
1565    end if
1566    call MPI_GROUP_FREE(subgroup,ierr)
1567    call MPI_GROUP_FREE(group,ierr)
1568  end if
1569 #else
1570  if (nranks>0) then
1571    if (ranks(1)==0) then
1572      xmpi_subcomm=xmpi_comm_self
1573      if (present(my_rank_in_group)) my_rank_in_group=0
1574    end if
1575  end if
1576 #endif
1577 
1578 end function xmpi_subcomm

m_xmpi/xmpi_wait [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_wait

FUNCTION

  Hides MPI_WAIT from MPI library.
  Waits for an MPI request to complete.

INPUTS

  request= MPI request handle to wait for

OUTPUT

  mpierr= status error

PARENTS

      dfpt_scfcv,m_fftw3,m_paw_an,m_paw_ij,m_pawfgrtab,m_pawrhoij,m_sg2002
      mover,scfcv

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

2016 subroutine xmpi_wait(request,mpierr)
2017 
2018 
2019 !This section has been created automatically by the script Abilint (TD).
2020 !Do not modify the following lines by hand.
2021 #undef ABI_FUNC
2022 #define ABI_FUNC 'xmpi_wait'
2023 !End of the abilint section
2024 
2025  implicit none
2026 
2027 !Arguments-------------------------
2028  integer,intent(out) :: mpierr
2029  integer,intent(inout) :: request
2030 
2031 !Local variables-------------------
2032 #ifdef HAVE_MPI
2033  integer :: ier,status(MPI_STATUS_SIZE)
2034 #endif
2035 
2036 ! *************************************************************************
2037 
2038  mpierr = 0
2039 #ifdef HAVE_MPI
2040   call MPI_WAIT(request,status,ier)
2041   mpierr=ier
2042 #endif
2043 
2044 end subroutine xmpi_wait

m_xmpi/xmpi_waitall [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpi_waitall

FUNCTION

  Hides MPI_WAITALL from MPI library.
  Waits for all given MPI Requests to complete.

INPUTS

  array_of_requests= array of request handles

OUTPUT

  mpierr= status error

PARENTS

      m_paw_an,m_paw_ij,m_pawfgrtab,m_pawrhoij

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

2071 subroutine xmpi_waitall(array_of_requests,mpierr)
2072 
2073 
2074 !This section has been created automatically by the script Abilint (TD).
2075 !Do not modify the following lines by hand.
2076 #undef ABI_FUNC
2077 #define ABI_FUNC 'xmpi_waitall'
2078 !End of the abilint section
2079 
2080  implicit none
2081 
2082 !Arguments-------------------------
2083  integer,intent(inout) :: array_of_requests(:)
2084  integer,intent(out) :: mpierr
2085 
2086 !Local variables-------------------
2087 #ifdef HAVE_MPI
2088  integer :: ier,status(MPI_STATUS_SIZE,size(array_of_requests))
2089 #endif
2090 
2091 ! *************************************************************************
2092 
2093  mpierr = 0
2094 #ifdef HAVE_MPI
2095   call MPI_WAITALL(size(array_of_requests),array_of_requests,status,ier)
2096   mpierr=ier
2097 #endif
2098 
2099 end subroutine xmpi_waitall

m_xmpi/xmpio_check_frmarkers [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_check_frmarkers

FUNCTION

  Check a set of Fortran record markers starting at a given offset using MPI-IO.

INPUTS

  fh=MPI-IO file handler.
  offset=MPI-IO file pointer
  sc_mode=Option for individual or collective reading.
  nfrec=Number of Fortran records to be checked.
  bsize_frecord(nfrec)=Byte size of the Fortran records (markers are NOT included)
    These values will be compared with the markers reported in the file.

OUTPUT

  ierr=A non-zero error code signals failure.

PARENTS

      m_bse_io,m_exc_itdiago,m_slk,m_wfk

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

3752 #ifdef HAVE_MPI_IO
3753 
3754 subroutine xmpio_check_frmarkers(fh,offset,sc_mode,nfrec,bsize_frecord,ierr)
3755 
3756 
3757 !This section has been created automatically by the script Abilint (TD).
3758 !Do not modify the following lines by hand.
3759 #undef ABI_FUNC
3760 #define ABI_FUNC 'xmpio_check_frmarkers'
3761 !End of the abilint section
3762 
3763  implicit none
3764 
3765 !Arguments ------------------------------------
3766 !scalars
3767  integer,intent(in) :: fh,nfrec,sc_mode
3768  integer(XMPI_OFFSET_KIND),intent(in) :: offset
3769  integer,intent(out) :: ierr
3770 !arrays
3771  integer(XMPI_OFFSET_KIND),intent(in) :: bsize_frecord(nfrec)
3772 
3773 !Local variables-------------------------------
3774 !scalars
3775  integer :: nb,irec,frmarkers_type,jj,bsize_frm,mpi_type_frm,mpierr,myfh
3776  integer(XMPI_OFFSET_KIND) :: displ
3777 !arrays
3778  integer(kind=int16),allocatable :: bufdelim2(:)
3779  integer(kind=int32),allocatable :: bufdelim4(:)
3780  integer(kind=int64),allocatable :: bufdelim8(:)
3781 #ifdef HAVE_FC_INT_QUAD
3782  integer*16,allocatable :: bufdelim16(:)
3783 #endif
3784 !integer :: statux(MPI_STATUS_SIZE)
3785  integer,allocatable :: block_length(:),block_type(:)
3786  integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
3787  integer(XMPI_OFFSET_KIND),allocatable :: delim_record(:)
3788 
3789 !************************************************************************
3790 
3791  ! Workaround for XLF
3792  myfh = fh
3793 
3794  ierr=0
3795 
3796  bsize_frm    = xmpio_bsize_frm     ! Byte size of the Fortran record marker.
3797  mpi_type_frm = xmpio_mpi_type_frm  ! MPI type of the record marker.
3798  !
3799  ! Define the view for the file.
3800  nb=2*nfrec
3801  ABI_MALLOC(block_length,(nb+2))
3802  ABI_MALLOC(block_displ,(nb+2))
3803  ABI_MALLOC(block_type,(nb+2))
3804  block_length(1)=1
3805  block_displ (1)=0
3806  block_type  (1)=MPI_LB
3807 
3808  jj=2; displ=0
3809  do irec=1,nfrec
3810    block_type (jj:jj+1) =mpi_type_frm
3811    block_length(jj:jj+1)=1
3812    block_displ(jj  )     = displ
3813    block_displ(jj+1)     = bsize_frm + displ + bsize_frecord(irec)
3814    jj=jj+2
3815    displ = displ + bsize_frecord(irec) + 2*bsize_frm ! Move to the beginning of the next column.
3816    if (xmpio_max_address(displ)) ierr=-1  ! Check for wraparound.
3817  end do
3818 
3819  block_length(nb+2)=1
3820  block_displ (nb+2)=displ
3821  block_type  (nb+2)=MPI_UB
3822 
3823  call xmpio_type_struct(nb+2,block_length,block_displ,block_type,frmarkers_type,mpierr)
3824  ABI_FREE(block_length)
3825  ABI_FREE(block_displ)
3826  ABI_FREE(block_type)
3827 
3828  call MPI_TYPE_COMMIT(frmarkers_type,mpierr)
3829  call MPI_FILE_SET_VIEW(myfh,offset,MPI_BYTE,frmarkers_type,"native",MPI_INFO_NULL,mpierr)
3830 
3831  jj=1
3832  ABI_MALLOC(delim_record,(nb))
3833  do irec=1,nfrec
3834    delim_record(jj:jj+1)=bsize_frecord(irec)
3835    jj=jj+2
3836  end do
3837 
3838  ! Read markers according to the MPI type of the Fortran marker.
3839  SELECT CASE (bsize_frm)
3840 
3841  CASE (4)
3842    ABI_MALLOC(bufdelim4,(nb))
3843    if (sc_mode==xmpio_single) then
3844      call MPI_FILE_READ    (myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
3845    else if (sc_mode==xmpio_collective) then
3846      call MPI_FILE_READ_ALL(myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
3847    else
3848      ierr=2
3849    end if
3850    if (ANY(bufdelim4/=delim_record)) ierr=1
3851    !if (ierr==1) then
3852    !  do irec=1,2*nfrec
3853    !    write(std_out,*)"irec, bufdelim4, delim_record: ",irec,bufdelim4(irec),delim_record(irec)
3854    !  end do
3855    !end if
3856    ABI_FREE(bufdelim4)
3857 
3858  CASE (8)
3859    ABI_MALLOC(bufdelim8,(nb))
3860    if (sc_mode==xmpio_single) then
3861      call MPI_FILE_READ    (myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
3862    else if (sc_mode==xmpio_collective) then
3863      call MPI_FILE_READ_ALL(myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
3864    else
3865      ierr=2
3866    end if
3867    if (ANY(bufdelim8/=delim_record)) ierr=1
3868    ABI_FREE(bufdelim8)
3869 
3870 #ifdef HAVE_FC_INT_QUAD
3871  CASE (16)
3872    ABI_MALLOC(bufdelim16,(nb))
3873    if (sc_mode==xmpio_single) then
3874      call MPI_FILE_READ    (myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
3875    else if (sc_mode==xmpio_collective) then
3876      call MPI_FILE_READ_ALL(myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
3877    else
3878      ierr=2
3879    end if
3880    if (ANY(bufdelim16/=delim_record)) ierr=1
3881    ABI_FREE(bufdelim16)
3882 #endif
3883 
3884  CASE (2)
3885    ABI_MALLOC(bufdelim2,(nb))
3886    if (sc_mode==xmpio_single) then
3887      call MPI_FILE_READ    (myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
3888    else if (sc_mode==xmpio_collective) then
3889      call MPI_FILE_READ_ALL(myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
3890    else
3891      ierr=2
3892    end if
3893    if (ANY(bufdelim2/=delim_record)) ierr=1
3894    ABI_FREE(bufdelim2)
3895 
3896  CASE DEFAULT
3897    ierr=-2
3898  END SELECT
3899 
3900  ! Free memory
3901  call MPI_TYPE_FREE(frmarkers_type,mpierr)
3902  ABI_FREE(delim_record)
3903 
3904 end subroutine xmpio_check_frmarkers

m_xmpi/xmpio_create_coldistr_from_fp3blocks [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_create_coldistr_from_fp3blocks

FUNCTION

  Returns an MPI datatype that can be used to MPI-IO (read|write) the columns of a
  matrix of the form  M = (S1    F3)
                          (F3^H  S2)
  where S1 and S2 are square (symmetric|Hermitian) matrices whose upper triangle is stored on file
  while F3 is a generic matrix (not necessarily square) stored in full mode.
  The Fortran file contains the blocks in the following order.
      upper(S1)
      upper(S2)
      F3

INPUTS

  sizes(2)=Number of elements of type old_type in each dimension of the full array M (array of positive integers)
  my_cols(2)=initial and final column to (read|write). Array of positive integers, Fortran convention.
  block_sizes(2,3)=The sizes of S1, S2, F.
  old_type=MPI datatype of the elements of the matrix.

OUTPUT

  new_type=New MPI type that can be used to instanciate the MPI-IO view for the Fortran file.
  my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
    marker (lets call it "base"). Each node should (read|write) using my_offset = base + my_offpad.
    my_offpad is used so that one can safely change the way the fileview is generated (for example
    to make it more efficient) without having to change the client code.
  offset_err=Error code. A non-zero returned value signals that the global matrix is tool large
    for a single MPI-IO access (see notes below).

NOTES

  1) block_displ is given in bytes due to the presence of the marker.
     If the displacement of an element is too large, the routine returns
     offset_err=1 so that the caller knows that several MPI-IO reads are required to (read| write) the file.

PARENTS

      m_bse_io

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

4705 #ifdef HAVE_MPI_IO
4706 
4707 subroutine xmpio_create_coldistr_from_fp3blocks(sizes,block_sizes,my_cols,old_type,new_type,my_offpad,offset_err)
4708 
4709 
4710 !This section has been created automatically by the script Abilint (TD).
4711 !Do not modify the following lines by hand.
4712 #undef ABI_FUNC
4713 #define ABI_FUNC 'xmpio_create_coldistr_from_fp3blocks'
4714 !End of the abilint section
4715 
4716  implicit none
4717 
4718 !Arguments ------------------------------------
4719 !scalars
4720  integer,intent(in) :: old_type
4721  integer,intent(out) :: new_type,offset_err
4722  integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
4723 !arrays
4724  integer,intent(in) :: sizes(2),my_cols(2),block_sizes(2,3)
4725 
4726 !Local variables-------------------------------
4727 !scalars
4728  integer :: my_ncol,bsize_old,my_col,which_block,uplo,swap
4729  integer :: my_nels,my_el,row_glob,ii_hpk,jj_hpk,ii,jj
4730  integer :: col_glob,bsize_frm,mpierr,row_shift,col_shift,n1,n2
4731  integer(XMPI_OFFSET_KIND) :: my_offset,ijp,bsize_tot,max_displ,min_displ
4732  integer(XMPI_ADDRESS_KIND) :: address
4733 !arrays
4734  integer,allocatable :: block_length(:),block_type(:)
4735  integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
4736  integer(XMPI_OFFSET_KIND) :: bsize_mat(2)
4737 
4738 !************************************************************************
4739 
4740  if ( sizes(1) /= SUM(block_sizes(1,1:2)) .or. &
4741 &     sizes(2) /= SUM(block_sizes(2,1:2)) ) then
4742    write(std_out,*)" xmpio_create_coldistr_from_fp3blocks: Inconsistency between block_sizes ans sizes "
4743    call xmpi_abort()
4744  end if
4745 
4746  if ( block_sizes(1,1)/=block_sizes(2,1) .or.&
4747 &     block_sizes(1,2)/=block_sizes(2,2) ) then
4748    write(std_out,*)" xmpio_create_coldistr_from_fp3blocks: first two blocks must be square"
4749    call xmpi_abort()
4750  end if
4751 
4752  if ( block_sizes(2,3)/=block_sizes(2,2) .or.&
4753 &     block_sizes(1,3)/=block_sizes(1,1) ) then
4754    write(std_out,*)" xmpio_create_coldistr_from_fp3blocks: Full matrix must be square"
4755    call xmpi_abort()
4756  end if
4757 
4758  write(std_out,*)" xmpio_create_coldistr_from_fp3blocks is still under testing"
4759  !call xmpi_abort()
4760 
4761  ! Byte size of the Fortran record marker.
4762  bsize_frm = xmpio_bsize_frm
4763 
4764  ! Byte size of old_type.
4765  call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
4766 
4767  ! my number of columns and total numer of elements to be read.
4768  my_ncol = my_cols(2) - my_cols(1) + 1
4769  my_nels = sizes(1)*my_ncol
4770  !
4771  ! block_displ(el+1) stores the displacement of the local element el taking into account the Fortran marker.
4772  ABI_MALLOC(block_displ,(my_nels+2))
4773  ABI_MALLOC(block_length,(my_nels+2))
4774  ABI_MALLOC(block_type,(my_nels+2))
4775  !
4776  ! * the view assumes that the file pointer used to instanciate the MPI-IO view
4777  !   points to the first element of the first column. In other words,the first Fortran record marker
4778  !   is not taken into account in the calculation of the displacements.
4779  my_offpad=xmpio_bsize_frm
4780  !
4781  ! Byte size of the first two blocks including the markers.
4782  n1=block_sizes(1,1)
4783  bsize_mat(1) = (n1*(n1+1)/2)*bsize_old + 2*n1*bsize_frm
4784 
4785  n2=block_sizes(1,2)
4786  bsize_mat(2) = (n2*(n2+1)/2)*bsize_old + 2*n2*bsize_frm
4787 
4788  bsize_tot=SUM(bsize_mat) +  PRODUCT(block_sizes(:,3))*bsize_old + block_sizes(2,3)*2*bsize_frm - bsize_frm
4789  write(std_out,*)"bsize_mat",bsize_mat,"bsize_tot",bsize_tot
4790  !
4791  ! * Some matrix elements are read twice. This part has to be tested.
4792  offset_err=0; my_el=0; max_displ=0; min_displ=HUGE(address)
4793  do my_col=1,my_ncol
4794    col_glob = (my_col-1) + my_cols(1)
4795    do row_glob=1,sizes(1)
4796      !
4797      which_block=3
4798      if (row_glob<=block_sizes(1,1).and.col_glob<=block_sizes(2,1)) which_block=1
4799      if (row_glob >block_sizes(1,1).and.col_glob >block_sizes(2,1)) which_block=2
4800 
4801      if ( ANY(which_block == (/1,2/)) ) then ! S1 or S2
4802        !
4803        row_shift=(which_block-1)*block_sizes(1,1)
4804        col_shift=(which_block-1)*block_sizes(2,1)
4805 
4806        ii_hpk = row_glob - row_shift
4807        jj_hpk = col_glob - col_shift
4808        if (jj_hpk<ii_hpk) then ! Exchange the indeces so that the symmetric is read.
4809          swap   = jj_hpk
4810          jj_hpk = ii_hpk
4811          ii_hpk = swap
4812        end if
4813        ijp = ii_hpk + jj_hpk*(jj_hpk-1)/2  ! Index for packed form
4814        my_offset = (ijp-1)*bsize_old + (jj_hpk-1)*2*bsize_frm
4815        if (which_block==2) my_offset=my_offset+bsize_mat(1)    ! Shift the offset to account for S1.
4816        !my_offset=4
4817        !
4818      else
4819        ! The element belongs either to F3 of F3^H.
4820        ! Now find whether it is the upper or the lower block since only F3 is stored on file.
4821        uplo=1; if (row_glob>block_sizes(1,1)) uplo=2
4822 
4823        if (uplo==1) then
4824          row_shift=0
4825          col_shift=block_sizes(2,1)
4826        else
4827          row_shift=block_sizes(1,1)
4828          col_shift=0
4829        end if
4830        ii = row_glob - row_shift
4831        jj = col_glob - col_shift
4832 
4833        if (uplo==2) then ! Exchange the indeces since the symmetric element will be read.
4834          swap=jj
4835          jj  =ii
4836          ii  =swap
4837        end if
4838 
4839        my_offset = (ii-1)*bsize_old + (jj-1)*block_sizes(1,3)*bsize_old + (jj-1)*2*bsize_frm
4840        my_offset = my_offset + SUM(bsize_mat)
4841        !if (uplo==1) my_offset=my_offset + bsize_mat(1)
4842        !my_offset=0
4843        !if (ii==1.and.jj==1) write(std_out,*)" (1,1) offset = ",my_offset
4844        !if (ii==block_sizes(1,3).and.jj==block_sizes(2,3)) write(std_out,*)" (n,n) offset =", my_offset
4845        if (my_offset>=bsize_tot-1*bsize_old) then
4846          write(std_out,*)"WARNING (my_offset>bsize_tot-bsize_old),",ii,jj,my_offset,bsize_tot
4847        end if
4848      end if
4849 
4850      if (xmpio_max_address(my_offset)) offset_err=1   ! Check for wraparounds.
4851      my_el = my_el+1
4852      block_displ (my_el+1)=my_offset
4853      block_length(my_el+1)=1
4854      block_type  (my_el+1)=old_type
4855      max_displ = MAX(max_displ,my_offset)
4856      min_displ = MIN(min_displ,my_offset)
4857      !if (which_block==3) write(std_out,*)" my_el, which, displ: ",my_el,which_block,block_displ(my_el+1)
4858    end do
4859  end do
4860 
4861  write(std_out,*)" MAX displ = ",max_displ," my_nels = ",my_nels
4862  write(std_out,*)" MIN displ = ",MINVAL(block_displ(2:my_nels+1))
4863 
4864  !block_displ (1)=max_displ ! Do not change this value.
4865  !if (min_displ>0) block_displ (1)=min_displ ! Do not change this value.
4866 
4867  block_displ (1)=min_displ
4868  block_displ (1)=0
4869  block_length(1)=0
4870  block_type  (1)=MPI_LB
4871 
4872  block_length(my_nels+2)=0
4873  !block_displ (my_nels+2)=bsize_tot
4874  block_displ (my_nels+2)=max_displ
4875  block_type  (my_nels+2)=MPI_UB
4876 
4877  call xmpio_type_struct(my_nels+2,block_length,block_displ,block_type,new_type,mpierr)
4878  !call xmpio_type_struct(my_nels,block_length(2:),block_displ(2:),block_type(2:),new_type,mpierr)
4879 
4880  !call MPI_TYPE_CREATE_INDEXED_BLOCK(my_nels, block_length(2:), block_displ(2:), old_type, new_type, mpierr)
4881 
4882  call MPI_TYPE_COMMIT(new_type,mpierr)
4883 
4884  ABI_FREE(block_length)
4885  ABI_FREE(block_displ)
4886  ABI_FREE(block_type)
4887 
4888 end subroutine xmpio_create_coldistr_from_fp3blocks

m_xmpi/xmpio_create_coldistr_from_fpacked [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_create_coldistr_from_fpacked

FUNCTION

  Returns an MPI datatype that can be used to MPI-IO (read|write) the columns of an
  (Hermitian|Symmetric) matrix whose upper triangle is written on a Fortran binary file.
  Note that the view assumes that the file pointer used to instanciate the MPI-IO view
  points to the first element of the first column. In other words,the first Fortran record marker
  (if any) is not taken into account in the calculation of the displacements.

INPUTS

  sizes(2)=Number of elements of type old_type in each dimension of the full array (array of positive integers)
  my_cols(2)=initial and final column to (read|write). Array of positive integers, Fortran convention.
  old_type=MPI datatype of the elements of the matrix.

OUTPUT

  new_type=New MPI type that can be used to instanciate the MPI-IO view for the Fortran file.
  my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
    marker (lets call it "base"). Each node should (read|write) using my_offset = base + my_offpad.
    my_offpad is used so that one can safely change the way the fileview is generated (for example
    to make it more efficient) without having to change the client code.
  offset_err=Error code. A non-zero returned value signals that the global matrix is tool large
    for a single MPI-IO access (see notes below).

NOTES

  1) The matrix on file is written in the following FORTRAN format (let us assume a 3x3 matrix for simplicity)

      m (1,1)             m
      m (1,2) (2,2)       m
      m (1,3) (2,3) (3,3) m

     each Fortran record stores a column of the packed matrix, "m" denotes the Fortran
     record marker that introduces holes in the file view.

  2) With (signed) Fortran integers, the maximum size of the file that
     that can be read in one-shot is around 2Gb when etype is set to byte.
     Using a larger etype might create portability problems (real data on machines using
     integer*16 for the marker) since etype must be a multiple of the Fortran record marker
     Due to the above reason, block_displ is given in bytes but it has to be defined as Fortran
     integer. If the displacement cannot be stored in a Fortran integer, the routine returns
     offset_err=1 so that the caller will know that several MPI-IO reads are nedded to
     read the file.

PARENTS

      m_bse_io

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

4564 #ifdef HAVE_MPI_IO
4565 
4566 subroutine xmpio_create_coldistr_from_fpacked(sizes,my_cols,old_type,new_type,my_offpad,offset_err)
4567 
4568 
4569 !This section has been created automatically by the script Abilint (TD).
4570 !Do not modify the following lines by hand.
4571 #undef ABI_FUNC
4572 #define ABI_FUNC 'xmpio_create_coldistr_from_fpacked'
4573 !End of the abilint section
4574 
4575  implicit none
4576 
4577 !Arguments ------------------------------------
4578 !scalars
4579  integer,intent(in) :: old_type
4580  integer,intent(out) :: new_type,offset_err
4581  integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
4582 !arrays
4583  integer,intent(in) :: sizes(2),my_cols(2)
4584 
4585 !Local variables-------------------------------
4586 !scalars
4587  integer :: my_ncol,bsize_old,my_col
4588  integer :: my_nels,my_el,row_glob,ii_hpk,jj_hpk,col_glob,bsize_frm,mpierr
4589  integer(XMPI_OFFSET_KIND) :: my_offset,ijp_glob
4590  !character(len=500) :: msg
4591 !arrays
4592  integer,allocatable :: block_length(:),block_type(:)
4593  integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
4594 
4595 !************************************************************************
4596 
4597  ! Byte size of the Fortran record marker.
4598  bsize_frm = xmpio_bsize_frm
4599 
4600  ! Byte size of old_type.
4601  call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
4602 
4603  ! my number of columns and total numer of elements to be read.
4604  my_ncol = my_cols(2) - my_cols(1) + 1
4605  my_nels = my_ncol*sizes(1)
4606  !
4607  ! block_displ(el+1) stores the displacement of the local element el taking into account the Fortran marker.
4608  ABI_MALLOC(block_displ,(my_nels+2))
4609  ABI_MALLOC(block_length,(my_nels+2))
4610  ABI_MALLOC(block_type,(my_nels+2))
4611 
4612  block_length(1)=1
4613  block_displ (1)=0
4614  block_type  (1)=MPI_LB
4615  !
4616  ! * the view assumes that the file pointer used to instanciate the MPI-IO view
4617  !   points to the first element of the first column. In other words,the first Fortran record marker
4618  !   is not taken into account in the calculation of the displacements.
4619  my_offpad=xmpio_bsize_frm
4620 
4621  ! * Some matrix elements are read twice. This part has to be tested.
4622  offset_err=0; my_el=0
4623  do my_col=1,my_ncol
4624    col_glob = (my_col-1) + my_cols(1)
4625    do row_glob=1,sizes(1)
4626      if (col_glob>=row_glob) then
4627        ii_hpk = row_glob
4628        jj_hpk = col_glob
4629        ijp_glob = row_glob + col_glob*(col_glob-1)/2  ! Index for packed form
4630      else ! Exchange the indeces as (jj,ii) will be read.
4631        ii_hpk = col_glob
4632        jj_hpk = row_glob
4633        ijp_glob = col_glob + row_glob*(row_glob-1)/2  ! Index for packed form
4634      end if
4635      my_el = my_el+1
4636      my_offset = (ijp_glob-1)* bsize_old + (jj_hpk-1)*2*bsize_frm
4637      if (xmpio_max_address(my_offset)) offset_err=1   ! Check for wraparounds.
4638      block_displ (my_el+1)=my_offset
4639      block_length(my_el+1)=1
4640      block_type  (my_el+1)=old_type
4641      !write(std_out,*)" my_el, displ: ",my_el,block_displ(my_el+1)
4642    end do
4643  end do
4644 
4645  block_length(my_nels+2)=1
4646  block_displ (my_nels+2)=my_offset
4647  block_type  (my_nels+2)=MPI_UB
4648 
4649  call xmpio_type_struct(my_nels+2,block_length,block_displ,block_type,new_type,mpierr)
4650 
4651  call MPI_TYPE_COMMIT(new_type,mpierr)
4652 
4653  ABI_FREE(block_length)
4654  ABI_FREE(block_displ)
4655  ABI_FREE(block_type)
4656 
4657 end subroutine xmpio_create_coldistr_from_fpacked

m_xmpi/xmpio_create_fherm_packed [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_create_fherm_packed

FUNCTION

  Returns an MPI datatype that can be used to (read|write) with MPI-IO the columns of an
  Hermitian matrix whose upper triangle is written on a Fortran binary file.
  Note that the view assumes that the file pointer used to create the MPI-IO view
  points to the first element of the first column. In other words,the first Fortran record marker
  (if any) is not taken into account in the calculation of the displacements.

INPUTS

  array_of_starts(2)=starting coordinates in the global Hermitian matrix
     (array of positive integers with jj>=ii, Fortran convention)
  array_of_ends(2)=final coordinates in the global Hermitian matrix
     (array of positive integers, jj>=ii, Fortran convention)
  is_fortran_file=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files.
  old_type=MPI datatype of the elements of the matrix.

OUTPUT

  my_offset=Offset relative to the beginning of the matrix in the file.
  hmat_type=New MPI type.
  offset_err= error code

NOTES

  The matrix on file is written in the following FORTRAN format (let us assume a 3x3 matrix for simplicity)

    m (1,1)             m
    m (1,2) (2,2)       m
    m (1,3) (2,3) (3,3) m

  each Fortran record stores a column of the packed Hermitian matrix, "m" denotes the Fortran
  record marker that introduces holes in the MPI-IO file view.
  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).
  The MPI-IO file view should be created by moving the file pointer so that it points to the elements (1,2).

  File views for C-streams is not optimal since one can use a single slice of contigous data.

PARENTS

      exc_build_block

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

4401 #ifdef HAVE_MPI_IO
4402 
4403 subroutine xmpio_create_fherm_packed(array_of_starts,array_of_ends,is_fortran_file,my_offset,old_type,hmat_type,offset_err)
4404 
4405 
4406 !This section has been created automatically by the script Abilint (TD).
4407 !Do not modify the following lines by hand.
4408 #undef ABI_FUNC
4409 #define ABI_FUNC 'xmpio_create_fherm_packed'
4410 !End of the abilint section
4411 
4412  implicit none
4413 
4414 !Arguments ------------------------------------
4415 !scalars
4416  integer,intent(in) :: old_type
4417  integer,intent(out) :: offset_err,hmat_type
4418  integer(XMPI_OFFSET_KIND),intent(out) :: my_offset
4419  logical,intent(in) :: is_fortran_file
4420 !arrays
4421  integer,intent(in) :: array_of_starts(2),array_of_ends(2)
4422 
4423 !Local variables-------------------------------
4424 !scalars
4425  integer :: nrow,my_ncol,ii,bsize_old,col,jj_glob,bsize_frm,prev_col,mpierr
4426  integer(XMPI_OFFSET_KIND) :: col_displ
4427 !arrays
4428  integer,allocatable :: col_type(:),block_length(:),block_type(:)
4429  integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
4430 
4431 !************************************************************************
4432 
4433  offset_err=0
4434 
4435  ! Byte size of old_type.
4436  call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
4437 
4438  bsize_frm=0; if (is_fortran_file) bsize_frm = xmpio_bsize_frm
4439 
4440  my_ncol = array_of_ends(2) - array_of_starts(2) + 1
4441  !
4442  ! Calculate my offset relative to the beginning of the matrix in the file.
4443  prev_col = array_of_starts(2)-1
4444  my_offset = (prev_col*(prev_col+1)/2)*bsize_old + (array_of_starts(1)-1)*bsize_old + 2*prev_col*bsize_frm + bsize_frm
4445  !
4446  ! col_type(col) describes the col-th column of the packed matrix.
4447  ! block_displ(col+1) stores its displacement taking into account the Fortran marker.
4448  ABI_MALLOC(col_type,(my_ncol))
4449  ABI_MALLOC(block_displ,(my_ncol+2))
4450 
4451  if (my_ncol>1) then
4452    col_displ=0
4453    do col=1,my_ncol
4454     jj_glob = (col-1) + array_of_starts(2)
4455     nrow = jj_glob
4456     if (jj_glob==array_of_starts(2)) nrow = jj_glob - array_of_starts(1) + 1 ! First column treated by me.
4457     if (jj_glob==array_of_ends(2))   nrow = array_of_ends(1)                 ! Last column treated by me.
4458     call MPI_Type_contiguous(nrow,old_type,col_type(col),mpierr)
4459     !
4460     if (xmpio_max_address(col_displ)) offset_err=1  ! Test for wraparounds
4461     block_displ(col+1) = col_displ
4462     col_displ = col_displ + nrow * bsize_old + 2 * bsize_frm  ! Move to the next column.
4463    end do
4464 
4465  else if (my_ncol==1) then  ! The case of a single column is treated separately.
4466     block_displ(2) = 0
4467     nrow = array_of_ends(1) - array_of_starts(1) + 1
4468     call MPI_Type_contiguous(nrow,old_type,col_type(2),mpierr)
4469     col_displ= nrow*bsize_old
4470     if (xmpio_max_address(col_displ)) offset_err=1  ! Test for wraparounds
4471  else
4472    call xmpi_abort(msg="my_ncol cannot be negative!")
4473  end if
4474 
4475  ABI_MALLOC(block_length,(my_ncol+2))
4476  ABI_MALLOC(block_type,(my_ncol+2))
4477 
4478  block_length(1)=1
4479  block_displ (1)=0
4480  block_type  (1)=MPI_LB
4481 
4482  do ii=2,my_ncol+1
4483    block_length(ii)=1
4484    block_type(ii)  =col_type(ii-1)
4485    !write(std_out,*)" ii-1, depl, length, type: ",ii-1,block_displ(ii),block_length(ii),block_type(ii)
4486  end do
4487 
4488  block_length(my_ncol+2)= 1
4489  block_displ (my_ncol+2)= col_displ
4490  block_type  (my_ncol+2)= MPI_UB
4491 
4492  call xmpio_type_struct(my_ncol+2,block_length,block_displ,block_type,hmat_type,mpierr)
4493 
4494  call MPI_TYPE_COMMIT(hmat_type,mpierr)
4495 
4496  ABI_FREE(block_length)
4497  ABI_FREE(block_displ)
4498  ABI_FREE(block_type)
4499 
4500  do col=1,my_ncol
4501    call MPI_TYPE_FREE(col_type(col),mpierr)
4502  end do
4503 
4504  ABI_FREE(col_type)
4505 
4506 end subroutine xmpio_create_fherm_packed

m_xmpi/xmpio_create_fstripes [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_create_fstripes

FUNCTION

  Return a MPI type that can be used to (read|write) a set of interleaved Fortran records.

  <FRM> type(1), type(1), ... <FRM>  ! size(1) elements
  <FRM> type(2), type(2), ... <FRM>  ! size(2) elements
  <FRM> type(1), type(1), ... <FRM>  ! size(1) elements
  ....

INPUTS

  ncount = Number of records with elements of type types(1) to (read|write)
  sizes(1:2) = Number of elements of each type in the two sets of record
  type(1:2) = MPI Type of the elements in the first and in the second record.

OUTPUT

  my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
    marker individuating the beginning of the matrix. (lets call it "base").
    Each node should (read|write) using my_offset = base + my_offpad.
    my_offpad is used so that one can safely change the way the fileview is generated (for example
    to make it more efficient) without having to change the client code.
  new_type=New MPI type.
  mpierr= MPI error code

PARENTS

      m_wfk

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

3322 #ifdef HAVE_MPI_IO
3323 
3324 subroutine xmpio_create_fstripes(ncount,sizes,types,new_type,my_offpad,mpierr)
3325 
3326 
3327 !This section has been created automatically by the script Abilint (TD).
3328 !Do not modify the following lines by hand.
3329 #undef ABI_FUNC
3330 #define ABI_FUNC 'xmpio_create_fstripes'
3331 !End of the abilint section
3332 
3333  implicit none
3334 
3335 !Arguments ------------------------------------
3336 !scalars
3337  integer,intent(in) :: ncount
3338  integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
3339  integer,intent(out) :: new_type,mpierr
3340 !arrays
3341  integer,intent(in) :: types(2),sizes(2)
3342 
3343 !Local variables-------------------------------
3344 !scalars
3345  integer :: type_x,type_y,bsize_frm,bsize_x,bsize_y,nx,ny,column_type
3346  integer(MPI_ADDRESS_KIND) :: stride
3347 
3348 !************************************************************************
3349 
3350  ! Byte size of the Fortran record marker.
3351  bsize_frm = xmpio_bsize_frm
3352 
3353  ! Number of elements in the two stripes.
3354  nx = sizes(1)
3355  ny = sizes(2)
3356 
3357  type_x = types(1)
3358  type_y = types(2)
3359 
3360  ! Byte size of type_x and type_y
3361  call MPI_TYPE_SIZE(type_x,bsize_x,mpierr)
3362  ABI_HANDLE_MPIERR(mpierr)
3363 
3364  call MPI_TYPE_SIZE(type_y,bsize_y,mpierr)
3365  ABI_HANDLE_MPIERR(mpierr)
3366 
3367  ! The view starts at the first element of the first stripe.
3368  my_offpad = xmpio_bsize_frm
3369 
3370  call MPI_Type_contiguous(nx,type_x,column_type,mpierr)
3371  ABI_HANDLE_MPIERR(mpierr)
3372 
3373  ! Byte size of the Fortran record + the two markers.
3374  stride = nx*bsize_x + 2*bsize_frm  + ny*bsize_y + 2*bsize_frm
3375 
3376  ! ncount colum_type separated by stride bytes
3377  call MPI_Type_create_hvector(ncount,1,stride,column_type,new_type,mpierr)
3378  ABI_HANDLE_MPIERR(mpierr)
3379 
3380  call MPI_TYPE_COMMIT(new_type,mpierr)
3381  ABI_HANDLE_MPIERR(mpierr)
3382 
3383  call MPI_TYPE_FREE(column_type,mpierr)
3384  ABI_HANDLE_MPIERR(mpierr)
3385 
3386 end subroutine xmpio_create_fstripes

m_xmpi/xmpio_create_fsubarray_2D [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_create_fsubarray_2D

FUNCTION

  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.

INPUTS

  sizes(2)=number of elements of type old_type in each dimension of the full array (array of positive integers)
  subsizes(2)=number of elements of type old_type in each dimension of the subarray (array of positive integers)
  array_of_starts(2)=starting coordinates of the subarray in each dimension (array of nonnegative integers >=1, <=sizes)
  old_type=Old MPI type.

OUTPUT

  my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
    marker individuating the beginning of the matrix. (lets call it "base").
    Each node should (read|write) using my_offset = base + my_offpad.
    my_offpad is used so that one can safely change the way the fileview is generated (for example
    to make it more efficient) without having to change the client code.
  new_type=New MPI type.
  mpierr= MPI error code

PARENTS

      exc_build_block,m_exc_itdiago,m_mpiotk,m_wfk

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

3422 #ifdef HAVE_MPI_IO
3423 
3424 subroutine xmpio_create_fsubarray_2D(sizes,subsizes,array_of_starts,old_type,new_type,my_offpad,mpierr)
3425 
3426 
3427 !This section has been created automatically by the script Abilint (TD).
3428 !Do not modify the following lines by hand.
3429 #undef ABI_FUNC
3430 #define ABI_FUNC 'xmpio_create_fsubarray_2D'
3431 !End of the abilint section
3432 
3433  implicit none
3434 
3435 !Arguments ------------------------------------
3436 !scalars
3437  integer,intent(in) :: old_type
3438  integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
3439  integer,intent(out) :: mpierr,new_type
3440 !arrays
3441  integer,intent(in) :: sizes(2),subsizes(2),array_of_starts(2)
3442 !Local variables-------------------------------
3443 !scalars
3444  integer :: bsize_frm,bsize_old,nx,ny
3445  integer :: column_type,ldx
3446  integer(XMPI_OFFSET_KIND) :: st_x,st_y
3447  integer(MPI_ADDRESS_KIND) :: stride_x
3448  !character(len=500) :: msg
3449 
3450 !************************************************************************
3451 
3452  ! Byte size of the Fortran record marker.
3453  bsize_frm = xmpio_bsize_frm
3454 
3455  ! Byte size of old_type.
3456  call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
3457  ABI_HANDLE_MPIERR(mpierr)
3458  !
3459  ! Number of columns and rows of the submatrix.
3460  nx = subsizes(1)
3461  ny = subsizes(2)
3462 
3463  ldx = sizes(1)
3464  st_x = array_of_starts(1)
3465  st_y = array_of_starts(2)
3466 
3467  ! The view starts at the first element of the submatrix.
3468  my_offpad = (st_x-1)*bsize_old + (st_y-1)*(ldx*bsize_old+2*xmpio_bsize_frm) + xmpio_bsize_frm
3469 
3470  ! Byte size of the Fortran record + the two markers.
3471  stride_x = ldx*bsize_old + 2*bsize_frm
3472 
3473  call MPI_Type_contiguous(nx,old_type,column_type,mpierr)
3474  ABI_HANDLE_MPIERR(mpierr)
3475 
3476  call MPI_Type_create_hvector(ny,1,stride_x,column_type,new_type,mpierr)
3477  ABI_HANDLE_MPIERR(mpierr)
3478 
3479  call MPI_TYPE_COMMIT(new_type,mpierr)
3480  ABI_HANDLE_MPIERR(mpierr)
3481 
3482  call MPI_TYPE_FREE(column_type, mpierr)
3483  ABI_HANDLE_MPIERR(mpierr)
3484 
3485 end subroutine xmpio_create_fsubarray_2D

m_xmpi/xmpio_create_fsubarray_3D [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_create_fsubarray_3D

FUNCTION

  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.

INPUTS

  sizes(3)=number of elements of type old_type in each dimension of the full array (array of positive integers)
  subsizes(3)=number of elements of type old_type in each dimension of the subarray (array of positive integers)
  array_of_starts(3)=starting coordinates of the subarray in each dimension (array of nonnegative integers >=1, <=sizes)
  old_type=Old MPI type.

OUTPUT

  my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
    marker individuating the beginning of the matrix. (lets call it "base").
    Each node should (read|write) using my_offset = base + my_offpad.
    my_offpad is used so that one can safely change the way the fileview is generated (for example
    to make it more efficient) without having to change the client code.
  new_type=New MPI type.
  mpierr= MPI error code

PARENTS

      m_mpiotk

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

3521 #ifdef HAVE_MPI_IO
3522 
3523 subroutine xmpio_create_fsubarray_3D(sizes,subsizes,array_of_starts,old_type,new_type,my_offpad,mpierr)
3524 
3525 
3526 !This section has been created automatically by the script Abilint (TD).
3527 !Do not modify the following lines by hand.
3528 #undef ABI_FUNC
3529 #define ABI_FUNC 'xmpio_create_fsubarray_3D'
3530 !End of the abilint section
3531 
3532  implicit none
3533 
3534 !Arguments ------------------------------------
3535 !scalars
3536  integer,intent(in) :: old_type
3537  integer,intent(out) :: mpierr,new_type
3538  integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
3539 !arrays
3540  integer,intent(in) :: sizes(3),subsizes(3),array_of_starts(3)
3541 !Local variables-------------------------------
3542 !scalars
3543  integer :: bsize_frm,bsize_old,nx,ny,nz
3544  integer :: column_type,plane_type,ldx,ldy,ldz
3545  integer(XMPI_OFFSET_KIND) :: st_x,st_y,st_z
3546  integer(MPI_ADDRESS_KIND) :: stride_x
3547  !character(len=500) :: msg
3548 
3549 !************************************************************************
3550 
3551  bsize_frm = xmpio_bsize_frm    ! Byte size of the Fortran record marker.
3552 
3553  ! Byte size of old_type.
3554  call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
3555  ABI_HANDLE_MPIERR(mpierr)
3556  !
3557  ! Number of columns and rows of the submatrix.
3558  nx = subsizes(1)
3559  ny = subsizes(2)
3560  nz = subsizes(3)
3561 
3562  ldx = sizes(1)
3563  ldy = sizes(2)
3564  ldz = sizes(3)
3565 
3566  st_x = array_of_starts(1)
3567  st_y = array_of_starts(2)
3568  st_z = array_of_starts(3)
3569 
3570  ! The view starts at the first element of the submatrix.
3571  my_offpad = (st_x-1)*bsize_old + &
3572 &            (st_y-1)*    (ldx*bsize_old+2*xmpio_bsize_frm) + &
3573 &            (st_z-1)*ldy*(ldx*bsize_old+2*xmpio_bsize_frm) + &
3574 &             xmpio_bsize_frm
3575 
3576  ! Byte size of the Fortran record + the two markers.
3577  stride_x = ldx*bsize_old + 2*bsize_frm
3578 
3579  call MPI_Type_contiguous(nx,old_type,column_type,mpierr)
3580  ABI_HANDLE_MPIERR(mpierr)
3581 
3582  call MPI_Type_create_hvector(ny,1,stride_x,column_type,plane_type,mpierr)
3583  ABI_HANDLE_MPIERR(mpierr)
3584 
3585  call MPI_Type_create_hvector(nz,1,ldy*stride_x,plane_type,new_type,mpierr)
3586  ABI_HANDLE_MPIERR(mpierr)
3587 
3588  ! Commit the datatype
3589  call MPI_TYPE_COMMIT(new_type,mpierr)
3590  ABI_HANDLE_MPIERR(mpierr)
3591 
3592  ! Free memory
3593  call MPI_TYPE_FREE(plane_type, mpierr)
3594  ABI_HANDLE_MPIERR(mpierr)
3595 
3596 end subroutine xmpio_create_fsubarray_3D

m_xmpi/xmpio_create_fsubarray_4D [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_create_fsubarray_4D

FUNCTION

  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.

INPUTS

  sizes(4)=number of elements of type old_type in each dimension of the full array (array of positive integers)
  subsizes(4)=number of elements of type old_type in each dimension of the subarray (array of positive integers)
  array_of_starts(4)=starting coordinates of the subarray in each dimension (array of nonnegative integers >=1, <=sizes)
  old_type=Old MPI type.

OUTPUT

  my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
    marker individuating the beginning of the matrix. (lets call it "base").
    Each node should (read|write) using my_offset = base + my_offpad.
    my_offpad is used so that one can safely change the way the fileview is generated (for example
    to make it more efficient) without having to change the client code.
  new_type=New MPI type.
  mpierr= MPI error code

PARENTS

      m_mpiotk

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

3632 #ifdef HAVE_MPI_IO
3633 
3634 subroutine xmpio_create_fsubarray_4D(sizes,subsizes,array_of_starts,old_type,new_type,my_offpad,mpierr)
3635 
3636 
3637 !This section has been created automatically by the script Abilint (TD).
3638 !Do not modify the following lines by hand.
3639 #undef ABI_FUNC
3640 #define ABI_FUNC 'xmpio_create_fsubarray_4D'
3641 !End of the abilint section
3642 
3643  implicit none
3644 
3645 !Arguments ------------------------------------
3646 !scalars
3647  integer,intent(in) :: old_type
3648  integer,intent(out) :: mpierr,new_type
3649  integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
3650 !arrays
3651  integer,intent(in) :: sizes(4),subsizes(4),array_of_starts(4)
3652 
3653 !Local variables-------------------------------
3654 !scalars
3655  integer :: bsize_frm,bsize_old,nx,ny,nz,na
3656  integer :: column_type,plane_type,ldx,ldy,ldz,lda,vol_type
3657  integer(XMPI_OFFSET_KIND) :: st_x,st_y,st_z,st_a
3658  integer(MPI_ADDRESS_KIND) :: stride_x
3659 
3660 !************************************************************************
3661 
3662  bsize_frm = xmpio_bsize_frm    ! Byte size of the Fortran record marker.
3663 
3664  ! Byte size of old_type.
3665  call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
3666  ABI_HANDLE_MPIERR(mpierr)
3667  !
3668  ! Number of columns and rows of the submatrix.
3669  nx = subsizes(1)
3670  ny = subsizes(2)
3671  nz = subsizes(3)
3672  na = subsizes(4)
3673 
3674  ldx = sizes(1)
3675  ldy = sizes(2)
3676  ldz = sizes(3)
3677  lda = sizes(4)
3678 
3679  st_x = array_of_starts(1)
3680  st_y = array_of_starts(2)
3681  st_z = array_of_starts(3)
3682  st_a = array_of_starts(4)
3683 
3684  ! The view starts at the first element of the submatrix.
3685  my_offpad = (st_x-1)*bsize_old + &
3686 &            (st_y-1)*        (ldx*bsize_old+2*xmpio_bsize_frm) + &
3687 &            (st_z-1)*ldy*    (ldx*bsize_old+2*xmpio_bsize_frm) + &
3688 &            (st_a-1)*lda*ldy*(ldx*bsize_old+2*xmpio_bsize_frm) + &
3689 &             xmpio_bsize_frm
3690 
3691  ! Byte size of the Fortran record + the two markers.
3692  stride_x = ldx*bsize_old + 2*bsize_frm
3693 
3694  call MPI_Type_contiguous(nx,old_type,column_type,mpierr)
3695  ABI_HANDLE_MPIERR(mpierr)
3696 
3697  call MPI_Type_create_hvector(ny,1,stride_x,column_type,plane_type,mpierr)
3698  ABI_HANDLE_MPIERR(mpierr)
3699 
3700  call MPI_Type_create_hvector(nz,1,ldy*stride_x,plane_type,vol_type,mpierr)
3701  ABI_HANDLE_MPIERR(mpierr)
3702 
3703  call MPI_Type_create_hvector(na,1,ldz*ldy*stride_x,vol_type,new_type,mpierr)
3704  ABI_HANDLE_MPIERR(mpierr)
3705 
3706  ! Commit the datatype
3707  call MPI_TYPE_COMMIT(new_type,mpierr)
3708  ABI_HANDLE_MPIERR(mpierr)
3709 
3710  ! Free memory
3711  call MPI_TYPE_FREE(column_type, mpierr)
3712  ABI_HANDLE_MPIERR(mpierr)
3713 
3714  call MPI_TYPE_FREE(plane_type, mpierr)
3715  ABI_HANDLE_MPIERR(mpierr)
3716 
3717  call MPI_TYPE_FREE(vol_type, mpierr)
3718  ABI_HANDLE_MPIERR(mpierr)
3719 
3720 end subroutine xmpio_create_fsubarray_4D

m_xmpi/xmpio_get_info_frm [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_marker_info

FUNCTION

  Return the byte size of the Fortran record and its corresponding MPI_type (compiler-dependent).
  These two values are needed to access sequential binary Fortran files with MPI/IO routines where
  C-streams are used.

INPUTS

 comm=MPI communicator. Only master will find the values for the record marker. The results
 are then broadcast to all the other nodes in comm.

OUTPUT

  bsize_frm=Byte size of the Fortran record marker.
  mpi_type_frm=MPI type of the marker.

PARENTS

SOURCE

2853 subroutine xmpio_get_info_frm(bsize_frm,mpi_type_frm,comm)
2854 
2855 
2856 !This section has been created automatically by the script Abilint (TD).
2857 !Do not modify the following lines by hand.
2858 #undef ABI_FUNC
2859 #define ABI_FUNC 'xmpio_get_info_frm'
2860 !End of the abilint section
2861 
2862  implicit none
2863 
2864 !Arguments ------------------------------------
2865 !scalars
2866  integer,intent(in) :: comm
2867  integer,intent(out) :: mpi_type_frm,bsize_frm
2868 
2869 !Local variables-------------------------------
2870  integer :: my_rank
2871 #ifdef HAVE_MPI_IO
2872 !scalars
2873  integer,parameter :: master=0
2874  integer :: spt,ept,ii
2875  integer :: f90_unt,iimax,mpio_fh,bsize_int,mpierr
2876  integer(XMPI_OFFSET_KIND) :: offset,rml
2877  character(len=fnlen) :: fname
2878  character(len=500) :: errmsg
2879  logical :: file_exists
2880 !arrays
2881  integer :: xvals(2),ivals(100),read_5ivals(5),ref_5ivals(5)
2882  integer :: rm_lengths(4)=(/4,8,2,16/)
2883  integer :: statux(MPI_STATUS_SIZE)
2884  real(dp) :: xrand(fnlen)
2885 #endif
2886 
2887 !************************************************************************
2888 
2889  bsize_frm=0; mpi_type_frm=0
2890 
2891  my_rank = xmpi_comm_rank(comm) !; RETURN
2892 
2893 #ifdef HAVE_MPI_IO
2894  if ( my_rank == master ) then
2895    ! Fortran scratch files cannot have a name so have to generate a random one.
2896    ! cannot use pick_aname since it is higher level.
2897    fname = "__MPI_IO_FRM__"
2898    spt=LEN(trim(fname))+1; ept=spt
2899 
2900    inquire(file=trim(fname),exist=file_exists)
2901 
2902    do while (file_exists)
2903      call RANDOM_NUMBER(xrand(spt:ept))
2904      xrand(spt:ept) = 64+xrand(spt:ept)*26
2905      do ii=spt,ept
2906        fname(ii:ii) = ACHAR(NINT(xrand(ii)))
2907      end do
2908      ept = MIN(ept+1,fnlen)
2909      inquire(file=trim(fname),exist=file_exists)
2910    end do
2911    !
2912    ! Write five integers on the binary file open in Fortran mode, then try
2913    ! to reread the values with MPI-IO using different offsets for the record marker.
2914    !
2915    f90_unt = xmpi_get_unit()
2916    if (f90_unt == -1) call xmpi_abort(msg="Cannot find free unit!!")
2917    ! MT dec 2013: suppress the new attribute: often cause unwanted errors
2918    !              and theoretically useless because of the previous inquire
2919    open(unit=f90_unt,file=trim(fname),form="unformatted",err=10, iomsg=errmsg)
2920 
2921    ref_5ivals = (/(ii, ii=5,9)/)
2922    ivals = HUGE(1); ivals(5:9)=ref_5ivals
2923    write(f90_unt, err=10, iomsg=errmsg) ivals
2924    close(f90_unt, err=10, iomsg=errmsg)
2925 
2926    call MPI_FILE_OPEN(xmpi_comm_self, trim(fname), MPI_MODE_RDONLY, MPI_INFO_NULL, mpio_fh,mpierr)
2927 
2928    iimax=3 ! Define number of INTEGER types to be tested
2929 #ifdef HAVE_FC_INT_QUAD
2930    iimax=4
2931 #endif
2932    !
2933    ! Try to read ivals(5:9) from file.
2934    ii=0; bsize_frm=-1
2935    call MPI_TYPE_SIZE(MPI_INTEGER,bsize_int,mpierr)
2936 
2937    do while (bsize_frm<=0 .and. ii<iimax)
2938      ii=ii+1
2939      rml = rm_lengths(ii)
2940      offset = rml + 4 * bsize_int
2941      call MPI_FILE_READ_AT(mpio_fh,offset,read_5ivals,5,MPI_INTEGER,statux,mpierr)
2942      !write(std_out,*)read_5ivals
2943      if (mpierr==MPI_SUCCESS .and. ALL(read_5ivals==ref_5ivals) ) bsize_frm=rml
2944    end do
2945 
2946    if (ii==iimax.and.bsize_frm<=0) then
2947      write(std_out,'(7a)') &
2948 &      'Error during FORTRAN file record marker detection:',ch10,&
2949 &      'It was not possible to read/write a small file!',ch10,&
2950 &      'ACTION: check your access permissions to the file system.',ch10,&
2951 &      'Common sources of this problem: quota limit exceeded, R/W incorrect permissions, ...'
2952      call xmpi_abort()
2953    else
2954      !write(std_out,'(a,i0)')' Detected FORTRAN record mark length: ',bsize_frm
2955    end if
2956 
2957    call MPI_FILE_CLOSE(mpio_fh, mpierr)
2958    !
2959    ! Select MPI datatype corresponding to the Fortran marker.
2960    SELECT CASE (bsize_frm)
2961    CASE (4)
2962      mpi_type_frm=MPI_INTEGER4
2963    CASE (8)
2964      mpi_type_frm=MPI_INTEGER8
2965 #if defined HAVE_FC_INT_QUAD && defined HAVE_MPI_INTEGER16
2966    CASE (16)
2967      mpi_type_frm=MPI_INTEGER16
2968 #endif
2969    CASE (2)
2970      mpi_type_frm=MPI_INTEGER2
2971    CASE DEFAULT
2972      write(std_out,'(a,i0)')" Wrong bsize_frm: ",bsize_frm
2973      call xmpi_abort()
2974    END SELECT
2975 
2976    open(unit=f90_unt,file=trim(fname), err=10, iomsg=errmsg)
2977    close(f90_unt,status="delete", err=10, iomsg=errmsg)
2978  end if
2979  !
2980  ! Broadcast data.
2981  xvals = (/bsize_frm,mpi_type_frm/)
2982  call xmpi_bcast(xvals,master,comm,mpierr)
2983 
2984  bsize_frm    = xvals(1)
2985  mpi_type_frm = xvals(2)
2986 
2987  return
2988 
2989 !HANDLE IO ERROR
2990 10 continue
2991  call xmpi_abort(msg=errmsg)
2992 #endif
2993 
2994 end subroutine xmpio_get_info_frm

m_xmpi/xmpio_max_address [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_max_address

FUNCTION

  Returns .TRUE. if offset cannot be stored in a Fortran integer of kind XMPI_ADDRESS_KIND.

PARENTS

SOURCE

4133 #ifdef HAVE_MPI_IO
4134 
4135 function xmpio_max_address(offset)
4136 
4137 
4138 !This section has been created automatically by the script Abilint (TD).
4139 !Do not modify the following lines by hand.
4140 #undef ABI_FUNC
4141 #define ABI_FUNC 'xmpio_max_address'
4142 !End of the abilint section
4143 
4144  implicit none
4145 
4146 !Arguments ------------------------------------
4147 !scalars
4148  logical :: xmpio_max_address
4149  integer(XMPI_OFFSET_KIND),intent(in) :: offset
4150 !arrays
4151 
4152 !Local variables-------------------------------
4153 !scalars
4154  integer(XMPI_ADDRESS_KIND) :: address
4155  integer(XMPI_OFFSET_KIND),parameter :: max_address=HUGE(address)-100
4156 
4157 !************************************************************************
4158 
4159  xmpio_max_address = (offset >= max_address)
4160 
4161 end function xmpio_max_address

m_xmpi/xmpio_read_dp [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_read_dp

FUNCTION

  Read the content of a single record marker in a FORTRAN file at a given offset using MPI-IO.
  the file pointer is modified according to the value of advance.
  targer: double precision real array

INPUTS

  fh=MPI-IO file handler.
  offset=MPI-IO file pointer
  sc_mode=
         xmpio_single     ==> for reading by current proc.
         xmpio_collective ==> for collective reading.
  ncount=Number of elements in the buffer
  [advance]=By default the routine will move the file pointer to the next record.
    advance=.FALSE. can be used so that the next read will continue picking information
    off of the currect record.

OUTPUT

  buf(ncount)=array with the values read from file
  fmarker=Content of the Fortran record marker.
  mpierr= MPI error code

SIDE EFFECTS

  offset=
     input: file pointer used to access the Fortran marker.
     output: new offset updated after the reading, depending on advance.

PARENTS

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

4053 #ifdef HAVE_MPI_IO
4054 
4055 subroutine xmpio_read_dp(fh,offset,sc_mode,ncount,buf,fmarker,mpierr,advance)
4056 
4057 
4058 !This section has been created automatically by the script Abilint (TD).
4059 !Do not modify the following lines by hand.
4060 #undef ABI_FUNC
4061 #define ABI_FUNC 'xmpio_read_dp'
4062 !End of the abilint section
4063 
4064  implicit none
4065 
4066 !Arguments ------------------------------------
4067 !scalars
4068  integer,intent(in) :: fh,sc_mode,ncount
4069  integer(XMPI_OFFSET_KIND),intent(inout) :: offset
4070  integer(XMPI_OFFSET_KIND),intent(out) :: fmarker
4071  integer,intent(out) :: mpierr
4072  logical,optional,intent(in) :: advance
4073 !arrays
4074  real(dp),intent(out) :: buf(ncount)
4075 
4076 !Local variables-------------------------------
4077 !scalars
4078  integer :: bsize_frm,myfh
4079  integer(XMPI_OFFSET_KIND) :: my_offset
4080  character(len=500) :: msg
4081 !arrays
4082  integer :: statux(MPI_STATUS_SIZE)
4083 
4084 !************************************************************************
4085 
4086  ! Workaround for XLF
4087  myfh = fh
4088 
4089  my_offset = offset
4090  bsize_frm = xmpio_bsize_frm  ! Byte size of the Fortran record marker.
4091 
4092  call xmpio_read_frm(myfh,my_offset,sc_mode,fmarker,mpierr,advance=.FALSE.)
4093 
4094  SELECT CASE (sc_mode)
4095  CASE (xmpio_single)
4096    call MPI_FILE_READ_AT(myfh, my_offset, buf, ncount, MPI_DOUBLE_PRECISION, statux, mpierr)
4097 
4098  CASE (xmpio_collective)
4099    call MPI_FILE_READ_AT_ALL(myfh, my_offset, buf, ncount, MPI_DOUBLE_PRECISION, statux, mpierr)
4100 
4101  CASE DEFAULT
4102    write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode
4103    call xmpi_abort(msg=msg)
4104  END SELECT
4105 
4106  if (PRESENT(advance)) then
4107    if (advance) then
4108      offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record.
4109    else
4110      offset = offset + bsize_frm  ! Move the pointer after the marker.
4111    end if
4112  else
4113    offset = offset + fmarker + 2*bsize_frm
4114  end if
4115 
4116 end subroutine xmpio_read_dp

m_xmpi/xmpio_read_int [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_read_int

FUNCTION

  Read the content of a single record marker in a FORTRAN file at a given offset using MPI-IO.
  the file pointer is modified according to the value of advance.
  target: integer array

INPUTS

  fh=MPI-IO file handler.
  offset=MPI-IO file pointer
  sc_mode=
         xmpio_single     ==> for reading by current proc.
         xmpio_collective ==> for collective reading.
  ncount=Number of elements in the buffer
  [advance]=By default the routine will move the file pointer to the next record.
    advance=.FALSE. can be used so that the next read will continue picking information
    off of the currect record.

OUTPUT

  buf(ncount)=array with the values read from file
  fmarker=Content of the Fortran record marker.
  mpierr= MPI error code

SIDE EFFECTS

  offset=
     input: file pointer used to access the Fortran marker.
     output: new offset updated after the reading, depending on advance.

PARENTS

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

3947 #ifdef HAVE_MPI_IO
3948 
3949 subroutine xmpio_read_int(fh,offset,sc_mode,ncount,buf,fmarker,mpierr,advance)
3950 
3951 
3952 !This section has been created automatically by the script Abilint (TD).
3953 !Do not modify the following lines by hand.
3954 #undef ABI_FUNC
3955 #define ABI_FUNC 'xmpio_read_int'
3956 !End of the abilint section
3957 
3958  implicit none
3959 
3960 !Arguments ------------------------------------
3961 !scalars
3962  integer,intent(in) :: fh,sc_mode,ncount
3963  integer(XMPI_OFFSET_KIND),intent(inout) :: offset
3964  integer(XMPI_OFFSET_KIND),intent(out) :: fmarker
3965  integer,intent(out) :: mpierr
3966  logical,optional,intent(in) :: advance
3967 !arrays
3968  integer,intent(out) :: buf(ncount)
3969 
3970 !Local variables-------------------------------
3971 !scalars
3972  integer :: myfh,bsize_frm
3973  integer(XMPI_OFFSET_KIND) :: my_offset
3974  character(len=500) :: msg
3975 !arrays
3976  integer :: statux(MPI_STATUS_SIZE)
3977 
3978 !************************************************************************
3979 
3980  ! Workaround for XLF
3981  myfh = fh
3982 
3983  my_offset = offset
3984  bsize_frm = xmpio_bsize_frm  ! Byte size of the Fortran record marker.
3985 
3986  call xmpio_read_frm(myfh,my_offset,sc_mode,fmarker,mpierr,advance=.FALSE.)
3987 
3988  SELECT CASE (sc_mode)
3989  CASE (xmpio_single)
3990    call MPI_FILE_READ_AT(myfh, my_offset, buf, ncount, MPI_INTEGER, statux, mpierr)
3991 
3992  CASE (xmpio_collective)
3993    call MPI_FILE_READ_AT_ALL(myfh, my_offset, buf, ncount, MPI_INTEGER, statux, mpierr)
3994 
3995  CASE DEFAULT
3996    write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode
3997    call xmpi_abort(msg=msg)
3998  END SELECT
3999 
4000  if (PRESENT(advance)) then
4001    if (advance) then
4002      offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record.
4003    else
4004      offset = offset + bsize_frm  ! Move the pointer after the marker.
4005    end if
4006  else
4007    offset = offset + fmarker + 2*bsize_frm
4008  end if
4009 
4010 end subroutine xmpio_read_int

m_xmpi/xmpio_type_struct [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_type_struct

FUNCTION

  Some highly non-standard MPI implementations support MPI-IO without
  implementing the full set of MPI-2 extensions.
  This wrapper will call the obsolete MPI_TYPE_STRUCT if MPI_TYPE_CREATE_STRUCT
  is not supported. Note that MPI_TYPE_STRUCT requires the displacement arrays
  to be an array of default integers whereas the argument block_displ is an array of kind XMPI_ADDRESS_KIND.
  The routine will abort if the displacement cannot be represented with a default integer.

INPUTS

 ncount= number of blocks (integer) --- also number of entries in arrays array_of_types, array_of_displacements and array_of_blocklengths
 array_of_blocklength(ncount)=number of elements in each block (array of integer)
 array_of_displacements(ncount)=byte displacement of each block (array of integer)
 array_of_types(ncount)=type of elements in each block (array of handles to datatype objects)

OUTPUT

 new_type=new datatype (handle)
 mpierr=MPI status error

PARENTS

      m_slk,m_wffile,m_wfk,m_xmpi

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

2783 #ifdef HAVE_MPI_IO
2784 
2785 subroutine xmpio_type_struct(ncount,block_length,block_displ,block_type,new_type,mpierr)
2786 
2787 
2788 !This section has been created automatically by the script Abilint (TD).
2789 !Do not modify the following lines by hand.
2790 #undef ABI_FUNC
2791 #define ABI_FUNC 'xmpio_type_struct'
2792 !End of the abilint section
2793 
2794  implicit none
2795 
2796 !Arguments ------------------------------------
2797 !scalars
2798  integer,intent(in) :: ncount
2799  integer,intent(out) :: new_type,mpierr
2800 !arrays
2801  integer,intent(in) :: block_length(ncount),block_type(ncount)
2802  integer(XMPI_ADDRESS_KIND),intent(in) :: block_displ(ncount)
2803 
2804 !Local variables-------------------
2805 #ifndef HAVE_MPI_TYPE_CREATE_STRUCT
2806  integer,allocatable :: tmp_displ(:)
2807 #endif
2808 
2809 !************************************************************************
2810 
2811 #ifdef HAVE_MPI_TYPE_CREATE_STRUCT
2812  call MPI_TYPE_CREATE_STRUCT(ncount,block_length,block_displ,block_type,new_type,mpierr)
2813 #else
2814 
2815  ABI_MALLOC(tmp_displ,(ncount))
2816  tmp_displ = block_displ
2817  if (ANY(block_displ > HUGE(tmp_displ(1)) ))then
2818    call xmpi_abort(msg=" byte displacement cannot be represented with a default integer")
2819  end if
2820 
2821  call MPI_TYPE_STRUCT(ncount,block_length,block_displ,block_type,new_type,mpierr)
2822  ABI_FREE(tmp_displ)
2823 #endif
2824 
2825 end subroutine xmpio_type_struct

m_xmpi/xmpio_write_frmarkers [ Functions ]

[ Top ] [ m_xmpi ] [ Functions ]

NAME

  xmpio_write_frmarkers

FUNCTION

  Write a set of Fortran record markers starting at a given offset using MPI-IO.

INPUTS

  fh=MPI-IO file handler.
  offset=MPI-IO file pointer
  sc_mode=Option for individual or collective reading.
  nfrec=Number of Fortran records to be written.
  bsize_frecord(nfrec)=Byte size of the Fortran records to be written (markers are NOT included in the size)

OUTPUT

  ierr=A non-zero error code signals failure.

PARENTS

      exc_build_block,m_exc_itdiago,m_ioarr,m_slk,m_wfk

CHILDREN

      mpi_type_commit,mpi_type_size,xmpi_abort,xmpio_type_struct

SOURCE

4192 #ifdef HAVE_MPI_IO
4193 
4194 subroutine xmpio_write_frmarkers(fh,offset,sc_mode,nfrec,bsize_frecord,ierr)
4195 
4196 
4197 !This section has been created automatically by the script Abilint (TD).
4198 !Do not modify the following lines by hand.
4199 #undef ABI_FUNC
4200 #define ABI_FUNC 'xmpio_write_frmarkers'
4201 !End of the abilint section
4202 
4203  implicit none
4204 
4205 !Arguments ------------------------------------
4206 !scalars
4207  integer,intent(in) :: fh,nfrec,sc_mode
4208  integer(XMPI_OFFSET_KIND),intent(in) :: offset
4209  integer,intent(out) :: ierr
4210 !arrays
4211  integer(XMPI_OFFSET_KIND),intent(in) :: bsize_frecord(nfrec)
4212 
4213 !Local variables-------------------------------
4214 !scalars
4215  integer :: nb,irec,frmarkers_type,jj,bsize_frm,mpi_type_frm,mpierr,myfh
4216  integer(XMPI_OFFSET_KIND) :: displ
4217 !integer(XMPI_OFFSET_KIND) :: my_offset
4218 !character(len=500) :: msg
4219 !arrays
4220  integer(kind=int16),allocatable :: bufdelim2(:)
4221  integer(kind=int32),allocatable :: bufdelim4(:)
4222  integer(kind=int64),allocatable :: bufdelim8(:)
4223 #ifdef HAVE_FC_INT_QUAD
4224  integer*16,allocatable :: bufdelim16(:)
4225 #endif
4226 !integer :: statux(MPI_STATUS_SIZE)
4227  integer,allocatable :: block_length(:),block_type(:)
4228  integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
4229  integer(XMPI_OFFSET_KIND),allocatable :: delim_record(:)
4230 
4231 !************************************************************************
4232 
4233  ! Workaround for XLF
4234  myfh = fh; ierr=0
4235 
4236  !my_offset = offset
4237  !do irec=1,nfrec
4238  !  call xmpio_write_frm(myfh,my_offset,sc_mode,bsize_frecord(irec),mpierr)
4239  !end do
4240  !return
4241 
4242  ! FIXME: This is buggy
4243  bsize_frm    = xmpio_bsize_frm     ! Byte size of the Fortran record marker.
4244  mpi_type_frm = xmpio_mpi_type_frm  ! MPI type of the record marker.
4245 
4246  ! Define the view for the file
4247  nb=2*nfrec
4248  ABI_MALLOC(block_length,(nb+2))
4249  ABI_MALLOC(block_displ,(nb+2))
4250  ABI_MALLOC(block_type,(nb+2))
4251  block_length(1)=1
4252  block_displ (1)=0
4253  block_type  (1)=MPI_LB
4254 
4255  jj=2; displ=0
4256  do irec=1,nfrec
4257    block_type (jj:jj+1)  = mpi_type_frm
4258    block_length(jj:jj+1) = 1
4259    block_displ(jj  )     = displ
4260    block_displ(jj+1)     = displ + bsize_frm + bsize_frecord(irec)
4261    jj=jj+2
4262    displ = displ + bsize_frecord(irec) + 2*bsize_frm ! Move to the beginning of the next column.
4263    if (xmpio_max_address(displ)) then ! Check for wraparound.
4264       ierr = -1; return
4265    end if
4266  end do
4267 
4268  block_length(nb+2) = 1
4269  block_displ (nb+2) = displ
4270  block_type  (nb+2) = MPI_UB
4271 
4272  call xmpio_type_struct(nb+2,block_length,block_displ,block_type,frmarkers_type,mpierr)
4273 
4274  ABI_FREE(block_length)
4275  ABI_FREE(block_displ)
4276  ABI_FREE(block_type)
4277 
4278  call MPI_TYPE_COMMIT(frmarkers_type,mpierr)
4279  call MPI_FILE_SET_VIEW(myfh,offset,MPI_BYTE,frmarkers_type,"native",MPI_INFO_NULL,mpierr)
4280 
4281  jj=1
4282  ABI_MALLOC(delim_record,(nb))
4283  do irec=1,nfrec
4284    delim_record(jj:jj+1)=bsize_frecord(irec)
4285    jj=jj+2
4286  end do
4287 
4288  ! Write all markers according to the MPI type of the Fortran marker.
4289  SELECT CASE (bsize_frm)
4290 
4291  CASE (4)
4292    ABI_MALLOC(bufdelim4,(nb))
4293    bufdelim4=delim_record
4294    if (sc_mode==xmpio_single) then
4295      call MPI_FILE_WRITE    (myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4296    else if (sc_mode==xmpio_collective) then
4297      call MPI_FILE_WRITE_ALL(myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4298    else
4299      ierr=2
4300    end if
4301    ABI_FREE(bufdelim4)
4302 
4303  CASE (8)
4304    ABI_MALLOC(bufdelim8,(nb))
4305    bufdelim8=delim_record
4306    if (sc_mode==xmpio_single) then
4307      call MPI_FILE_WRITE    (myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4308    else if (sc_mode==xmpio_collective) then
4309      call MPI_FILE_WRITE_ALL(myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4310    else
4311      ierr=2
4312    end if
4313    ABI_FREE(bufdelim8)
4314 
4315 #ifdef HAVE_FC_INT_QUAD
4316  CASE (16)
4317    ABI_MALLOC(bufdelim16,(nb))
4318    bufdelim16=delim_record
4319    if (sc_mode==xmpio_single) then
4320      call MPI_FILE_WRITE    (myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4321    else if (sc_mode==xmpio_collective) then
4322      call MPI_FILE_WRITE_ALL(myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4323    else
4324      ierr=2
4325    end if
4326    ABI_FREE(bufdelim16)
4327 #endif
4328 
4329  CASE (2)
4330    ABI_MALLOC(bufdelim2,(nb))
4331    bufdelim2=delim_record
4332    if (sc_mode==xmpio_single) then
4333      call MPI_FILE_WRITE    (myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4334    else if (sc_mode==xmpio_collective) then
4335      call MPI_FILE_WRITE_ALL(myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4336    else
4337      ierr=2
4338    end if
4339    ABI_FREE(bufdelim2)
4340 
4341  CASE DEFAULT
4342    ierr=-2
4343  END SELECT
4344 
4345  ! Free memory
4346  call MPI_TYPE_FREE(frmarkers_type,mpierr)
4347  ABI_FREE(delim_record)
4348 
4349 end subroutine xmpio_write_frmarkers
4350 #endif