[cig-commits] [commit] devel: Fixed call of write_seismograms in iterate_time and an allocate issue with ASDF that was causing the output to hang when more than 6 processors were used to run the solver. (9221b3e)
cig_noreply at geodynamics.org
cig_noreply at geodynamics.org
Wed Apr 9 08:56:39 PDT 2014
Repository : ssh://geoshell/specfem3d_globe
On branch : devel
Link : https://github.com/geodynamics/specfem3d_globe/compare/64e1b38f0c5ebb4056cce0b15d41c0b9f94ab6e5...099a4d330d5b173b21e51ad441f9f429e5d37842
>---------------------------------------------------------------
commit 9221b3ed18903af26dc980838b4719ac53110ac8
Author: James Smith <jas11 at princeton.edu>
Date: Wed Mar 19 21:48:50 2014 -0400
Fixed call of write_seismograms in iterate_time and an allocate issue with ASDF that was causing the output to hang when more than 6 processors were used to run the solver.
>---------------------------------------------------------------
9221b3ed18903af26dc980838b4719ac53110ac8
flags.guess | 3 +-
src/specfem3D/iterate_time.F90 | 6 ++-
src/specfem3D/write_output_ASDF.F90 | 97 ++++++++++++++++++++++++-------------
3 files changed, 69 insertions(+), 37 deletions(-)
diff --git a/flags.guess b/flags.guess
index e07592c..c8755b3 100644
--- a/flags.guess
+++ b/flags.guess
@@ -89,7 +89,8 @@ case $my_FC in
# parallel file systems like SFS 3.2 / Lustre 1.8. If omitted
# I/O throughput lingers at 2.5 MB/s, with it it can increase to ~44 MB/s
# However it does not make much of a difference on NFS mounted volumes or with SFS 3.1.1 / Lustre 1.6.7.1
- DEF_FFLAGS="-O3 -check nobounds -xHost -fpe0 -ftz -assume buffered_io -assume byterecl -align sequence -vec-report0 -std03 -diag-disable 6477 -implicitnone -gen-interfaces -warn all" # -mcmodel=medium -shared-intel
+ #DEF_FFLAGS="-O3 -check nobounds -xHost -fpe0 -ftz -assume buffered_io -assume byterecl -align sequence -vec-report0 -std03 -diag-disable 6477 -implicitnone -gen-interfaces -warn all" # -mcmodel=medium -shared-intel
+ DEF_FFLAGS="-O3 -check nobounds -xHost -fpe0 -ftz -assume buffered_io -assume byterecl -align sequence -vec-report0 -std03 -diag-disable 6477 -implicitnone -gen-interfaces -warn all -mcmodel=medium -shared-intel"
##############################################################################################################################
##############################################################################################################################
##############################################################################################################################
diff --git a/src/specfem3D/iterate_time.F90 b/src/specfem3D/iterate_time.F90
index 3cc596c..c33d69c 100644
--- a/src/specfem3D/iterate_time.F90
+++ b/src/specfem3D/iterate_time.F90
@@ -135,7 +135,11 @@
endif ! kernel simulations
! write the seismograms with time shift
- if( nrec_local > 0 .or. ( WRITE_SEISMOGRAMS_BY_MASTER .and. myrank == 0 ) ) then
+ if( nrec_local > 0 .or. ( WRITE_SEISMOGRAMS_BY_MASTER .and. myrank == 0 )) then
+ call write_seismograms()
+ ! asdf uses adios that defines the MPI communicator group that the solver is
+ ! run with. this means every processor in the group is needed for write_seismograms
+ elseif (OUTPUT_SEISMOS_ASDF) then
call write_seismograms()
endif
diff --git a/src/specfem3D/write_output_ASDF.F90 b/src/specfem3D/write_output_ASDF.F90
index c88d19d..5062924 100644
--- a/src/specfem3D/write_output_ASDF.F90
+++ b/src/specfem3D/write_output_ASDF.F90
@@ -125,10 +125,10 @@ subroutine store_asdf_data(asdf_container, seismogram_tmp, irec_local, &
intent(in) :: seismogram_tmp
integer,intent(in) :: iorientation
type(asdf_event),intent(inout) :: asdf_container
+ double precision,intent(in) :: phi
! Variables
integer :: length_station_name, length_network_name
integer :: ier, i
- double precision,intent(in) :: phi
i = (irec_local-1)*(3) + (iorientation)
asdf_container%npoints(i) = seismo_current
@@ -284,13 +284,18 @@ subroutine write_asdf(asdf_container)
character(len=200) :: ASDF_FN
call world_duplicate(comm)
+print *, comm
call world_size(sizeprocs)
-
+print *, sizeprocs
+print *, "declaring group"
! declare new group that uses MPI
call adios_declare_group (adios_group, "EVENTS", "iter", 1, adios_err)
+print *, "declared group"
call adios_select_method (adios_group, "MPI", "", "", adios_err)
+print *, "selected method"
ASDF_FN="OUTPUT_FILES/"//trim(event_name_SAC)//"_sem.bp"
+ print *, "write_data"
call write_asdf_data (ASDF_FN, asdf_container, adios_group, myrank, &
sizeprocs, comm, ierr)
@@ -330,6 +335,7 @@ subroutine write_asdf_data(asdf_fn, asdf_container, adios_group, rank, &
adios_err)
!call the write sub
+print *, "write_asdf_data_sub"
call write_asdf_data_sub (asdf_container, adios_handle, rank, nproc, &
comm, ierr)
@@ -398,6 +404,7 @@ subroutine define_asdf_data (adios_group, my_group_size, asdf_container, &
dum_real)
!string info
+print *, "string info"
call define_adios_scalar (adios_group, my_group_size, "", &
"receiver_name_len", dum_int)
call define_adios_scalar (adios_group, my_group_size, "", &
@@ -432,6 +439,7 @@ subroutine define_asdf_data (adios_group, my_group_size, asdf_container, &
call define_adios_local_string_1d_array (adios_group, my_group_size,&
string_total_length, "", "receiver_id", dum_string)
+print *, "global arrays"
call define_adios_global_real_1d_array (adios_group, my_group_size, &
nrecords, "", "event_lat", real_array)
call define_adios_global_real_1d_array (adios_group, my_group_size, &
@@ -472,6 +480,7 @@ subroutine define_asdf_data (adios_group, my_group_size, asdf_container, &
nrecords, "", "S_pick", real_array)
!DISPLACEMENT
+print *, "records"
do i = 1, nrecords
write(i_string, '(I10)' ) i+offset
record=trim(asdf_container%receiver_name_array(i))//"."// &
@@ -622,6 +631,7 @@ subroutine write_asdf_data_sub (asdf_container, adios_handle, rank, &
rank, nproc, comm, ierr)
!ensemble the string for receiver_name, network, componen and receiver_id
+print *, "first allocate"
allocate(character(len=6*asdf_container%nrecords) :: receiver_name, STAT=ierr)
if (ierr /= 0) call exit_MPI (rank, 'Allocate failed.')
allocate(character(len=6*asdf_container%nrecords) :: network, STAT=ierr)
@@ -647,6 +657,7 @@ subroutine write_asdf_data_sub (asdf_container, adios_handle, rank, &
component_len = len_trim(component)
receiver_id_len = len_trim(receiver_id)
+ call synchronize_all()
!get global dimensions for strings
call gather_string_total_length(receiver_name_len, rn_len_total,&
rank, nproc, comm, ierr)
@@ -656,29 +667,44 @@ subroutine write_asdf_data_sub (asdf_container, adios_handle, rank, &
rank, nproc, comm, ierr)
call gather_string_total_length(component_len, comp_len_total,&
rank, nproc, comm, ierr)
- allocate(character(len=rn_len_total) :: receiver_name_total, STAT=ierr)
- if (ierr /= 0) call exit_MPI (rank, 'Allocate failed.')
- allocate(character(len=nw_len_total) :: network_total, STAT=ierr)
- if (ierr /= 0) call exit_MPI (rank, 'Allocate failed.')
- allocate(character(len=rid_len_total) :: receiver_id_total, STAT=ierr)
- if (ierr /= 0) call exit_MPI (rank, 'Allocate failed.')
- allocate(character(len=comp_len_total) :: component_total, STAT=ierr)
- if (ierr /= 0) call exit_MPI (rank, 'Allocate failed.')
+ if (rank .eq. 0) then
+ allocate(character(len=rn_len_total) :: receiver_name_total, STAT=ierr)
+ if (ierr /= 0) then
+ print *, ierr
+ call exit_MPI (rank, 'Allocate failed.')
+ endif
+ allocate(character(len=nw_len_total) :: network_total, STAT=ierr)
+ if (ierr /= 0) then
+ print *, ierr
+ call exit_MPI (rank, 'Allocate failed.')
+ endif
+ allocate(character(len=rid_len_total) :: receiver_id_total, STAT=ierr)
+ if (ierr /= 0) then
+ print *, ierr
+ call exit_MPI (rank, 'Allocate failed.')
+ endif
+ allocate(character(len=comp_len_total) :: component_total, STAT=ierr)
+ if (ierr /= 0) then
+ print *, ierr
+ call exit_MPI (rank, 'Allocate failed.')
+ endif
+ endif
+ call synchronize_all()
!write all local strings into global string
call gather_string_offset_info(receiver_name_len, rn_len_total,rn_offset, &
- receiver_name, receiver_name_total, &
- rank, nproc, comm, ierr)
+ receiver_name, receiver_name_total, &
+ rank, nproc, comm, ierr)
call gather_string_offset_info(network_len, nw_len_total, nw_offset, &
- network, network_total, &
- rank, nproc, comm, ierr)
+ network, network_total, &
+ rank, nproc, comm, ierr)
call gather_string_offset_info(component_len, comp_len_total, comp_offset, &
- component, component_total, &
- rank, nproc, comm, ierr)
+ component, component_total, &
+ rank, nproc, comm, ierr)
call gather_string_offset_info(receiver_id_len, rid_len_total,rid_offset, &
- receiver_id, receiver_id_total, &
- rank, nproc, comm, ierr)
- !===========================
+ receiver_id, receiver_id_total, &
+ rank, nproc, comm, ierr)
+ !==========================
!write out the string info
if(rank.eq.0)then
call adios_write(adios_handle, "receiver_name", trim(receiver_name_total), &
@@ -687,13 +713,12 @@ subroutine write_asdf_data_sub (asdf_container, adios_handle, rank, &
call adios_write(adios_handle, "component",trim(component_total), adios_err)
call adios_write(adios_handle, "receiver_id", trim(receiver_id_total), &
adios_err)
+ deallocate(receiver_name_total)
+ deallocate(network_total)
+ deallocate(receiver_id_total)
+ deallocate(component_total)
endif
- deallocate(receiver_name_total)
- deallocate(network_total)
- deallocate(receiver_id_total)
- deallocate(component_total)
-
!===========================
! write seismic records
do i = 1, asdf_container%nrecords
@@ -833,34 +858,35 @@ subroutine gather_offset_info(local_dim, global_dim, offset,&
integer,intent(in) :: rank, nproc, comm
integer,intent(inout) :: ierr
- integer, allocatable :: local_dim_all_proc(:)
- integer, allocatable :: offset_all_proc(:)
+ integer, allocatable :: dim_all_proc(:)
+ integer, allocatable :: offset_proc(:)
integer :: i
- allocate(local_dim_all_proc(nproc), STAT=ierr)
+print *, "local_dim"
+ allocate(dim_all_proc(nproc), STAT=ierr)
if (ierr /= 0) call exit_MPI (rank, 'Allocate failed.')
- allocate(offset_all_proc(nproc), STAT=ierr)
+ allocate(offset_proc(nproc), STAT=ierr)
if (ierr /= 0) call exit_MPI (rank, 'Allocate failed.')
call synchronize_all()
- call MPI_Gather(local_dim, 1, MPI_INTEGER, local_dim_all_proc, 1, &
+ call MPI_Gather(local_dim, 1, MPI_INTEGER, dim_all_proc, 1, &
MPI_INTEGER, 0, comm, ierr)
if(rank.eq.0)then
- offset_all_proc(1)=0
+ offset_proc(1)=0
do i=2, nproc
- offset_all_proc(i)=sum(local_dim_all_proc(1:(i-1)))
+ offset_proc(i)=sum(dim_all_proc(1:(i-1)))
enddo
- global_dim=sum(local_dim_all_proc(1:nproc))
+ global_dim=sum(dim_all_proc(1:nproc))
endif
- call MPI_Scatter(offset_all_proc, 1, MPI_INTEGER, offset, &
+ call MPI_Scatter(offset_proc, 1, MPI_INTEGER, offset, &
1, MPI_INTEGER, 0, comm, ierr)
call MPI_Bcast(global_dim, 1, MPI_INTEGER, 0, comm, ierr)
- deallocate(local_dim_all_proc, STAT=ierr)
+ deallocate(dim_all_proc, STAT=ierr)
if (ierr /= 0) call exit_MPI (rank, 'Deallocate failed.')
- deallocate(offset_all_proc, STAT=ierr)
+ deallocate(offset_proc, STAT=ierr)
if (ierr /= 0) call exit_MPI (rank, 'Deallocate failed.')
end subroutine gather_offset_info
@@ -885,6 +911,7 @@ subroutine gather_string_total_length(local_dim, global_dim,&
integer, allocatable :: local_dim_all_proc(:)
+print *, "master"
if(rank.eq.0)then
allocate(local_dim_all_proc(nproc),STAT=ierr)
if (ierr /= 0) call exit_MPI (rank, 'Allocate failed.')
More information about the CIG-COMMITS
mailing list