[cig-commits] r22486 - in seismo/3D/SPECFEM3D_GLOBE: branches/SPECFEM3D_GLOBE_SUNFLOWER/setup branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D trunk/setup trunk/src/meshfem3D trunk/src/shared trunk/src/specfem3D
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Tue Jul 2 08:37:50 PDT 2013
Author: dkomati1
Date: 2013-07-02 08:37:49 -0700 (Tue, 02 Jul 2013)
New Revision: 22486
Removed:
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh_adios.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_absorb_adios.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/save_arrays_solver_adios.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_chunks_data_adios.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_data_adios.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_faces_data_adios.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_surface_data_adios.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/adios_helpers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/adios_manager.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_acoustic.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_elastic.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/iterate_time.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_arrays_solver_adios.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_attenuation_adios.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays_adios.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases_adios.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays_adios.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D_par.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_specfem_adios_header.F90
Modified:
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/setup/constants.h.in
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/assemble_MPI_scalar.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_add_sources.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_arrays_source.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_boundary_kernel.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_coupling.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_acoustic.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_crust_mantle_Dev.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_elastic.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_inner_core_Dev.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_outer_core_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_seismograms.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/get_attenuation.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/initialize_simulation.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_sources.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/noise_tomography.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/prepare_timerun.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_mesh_databases.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/save_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/setup_sources_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D_par.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_movie_surface.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_movie_volume.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/setup/constants.h.in
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/check_simulation_stability.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_add_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_arrays_source.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_boundary_kernel.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_coupling.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_element.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_seismograms.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/get_attenuation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/get_event_info.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/initialize_simulation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/locate_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/locate_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/noise_tomography.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/prepare_timerun.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/setup_sources_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_volume.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_output_SAC.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_seismograms.f90
Log:
done making all the easy merges in src/specfem3D;
also got rid of all the ADIOS files that I had put in the trunk
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/setup/constants.h.in
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/setup/constants.h.in 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/setup/constants.h.in 2013-07-02 15:37:49 UTC (rev 22486)
@@ -362,6 +362,11 @@
! Deville routines optimized for NGLLX = NGLLY = NGLLZ = 5
integer, parameter :: m1 = NGLLX, m2 = NGLLX * NGLLY
+! mid-points inside a GLL element
+ integer, parameter :: MIDX = (NGLLX+1)/2
+ integer, parameter :: MIDY = (NGLLY+1)/2
+ integer, parameter :: MIDZ = (NGLLZ+1)/2
+
! gravitational constant
double precision, parameter :: GRAV = 6.6723d-11
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/assemble_MPI_scalar.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/assemble_MPI_scalar.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/assemble_MPI_scalar.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -29,7 +29,6 @@
!---- assemble the contributions between slices and chunks using MPI
!----
-
subroutine assemble_MPI_scalar(NPROC,nglob,array_val, &
num_interfaces,max_nibool_interfaces, &
nibool_interfaces,ibool_interfaces, &
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_add_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_add_sources.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_add_sources.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -204,7 +204,6 @@
do i=1,NGLLX
iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec))
-
! adds adjoint source acting at this time step (it):
!
! note: we use index iadj_vec(it) which is the corresponding time step
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_arrays_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_arrays_source.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_arrays_source.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -127,7 +127,6 @@
!================================================================
-
subroutine compute_arrays_source_adjoint(myrank, adj_source_file, &
xi_receiver,eta_receiver,gamma_receiver, nu,adj_sourcearray, &
xigll,yigll,zigll,NSTEP_BLOCK,iadjsrc,it_sub_adj,NSTEP_SUB_ADJ, &
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_boundary_kernel.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_boundary_kernel.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_boundary_kernel.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -25,7 +25,6 @@
!
!=====================================================================
-
subroutine compute_boundary_kernels()
! kernel calculations
@@ -550,8 +549,7 @@
! ==========================================================================================
-
-subroutine compute_stress_from_strain(dsdx,sigma,i,j,k,ispec,iregion_code, &
+ subroutine compute_stress_from_strain(dsdx,sigma,i,j,k,ispec,iregion_code, &
kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
@@ -594,7 +592,6 @@
integer :: iglob
-
! --- precompute sum ---
duxdxl_plus_duydyl = dsdx(1,1) + dsdx(2,2)
@@ -953,6 +950,4 @@
sigma(3,1) = sigma(1,3)
sigma(3,2) = sigma(2,3)
-
-
end subroutine compute_stress_from_strain
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_coupling.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_coupling.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_coupling.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -62,7 +62,6 @@
real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n,nx,ny,nz,weight
integer :: i,j,k,k_corresp,ispec,ispec2D,iglob_cm,iglob_oc,ispec_selected
-
! for surface elements exactly on the CMB
do ispec2D = 1,nspec2D_top !NSPEC2D_TOP(IREGION_OUTER_CORE)
@@ -71,6 +70,7 @@
! only for DOFs exactly on the CMB (top of these elements)
k = NGLLZ
+
! get displacement on the solid side using pointwise matching
k_corresp = 1
@@ -225,7 +225,6 @@
!-------------------------------------------------------------------------------------------------
!
-
subroutine compute_coupling_CMB_fluid(displ_crust_mantle,b_displ_crust_mantle, &
accel_crust_mantle,b_accel_crust_mantle, &
ibool_crust_mantle,ibelm_bottom_crust_mantle, &
@@ -277,7 +276,7 @@
! only for DOFs exactly on the CMB (bottom of these elements)
k = 1
- ! get velocity potential on the fluid side using pointwise matching
+ ! get potential on the fluid side using pointwise matching
k_corresp = NGLLZ
do j = 1,NGLLY
@@ -450,15 +449,13 @@
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: b_accel_crust_mantle
! mass matrices
!
- ! in the case of stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
- ! on Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
+ ! in the case of Stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
+ ! on the Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
!
! if absorbing_conditions are not set or if NCHUNKS=6, only one mass matrix is needed
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -210,9 +210,7 @@
templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
ispec_strain = 1
- !$OMP CRITICAL
epsilon_trace_over_3(i,j,k,ispec_strain) = templ
- !$OMP END CRITICAL
else
ispec_strain = ispec
epsilon_trace_over_3(i,j,k,ispec_strain) = templ
@@ -616,9 +614,7 @@
templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
ispec_strain = 1
- !$OMP CRITICAL
epsilon_trace_over_3(i,j,k,ispec_strain) = templ
- !$OMP END CRITICAL
else
ispec_strain = ispec
epsilon_trace_over_3(i,j,k,ispec_strain) = templ
@@ -1095,7 +1091,7 @@
logical :: is_backward_field
! local parameters
- !real(kind=CUSTOM_REAL) one_minus_sum_beta_use
+ ! real(kind=CUSTOM_REAL) one_minus_sum_beta_use
real(kind=CUSTOM_REAL) minus_sum_beta,mul
! the 21 coefficients for an anisotropic medium in reduced notation
real(kind=CUSTOM_REAL) c11,c22,c33,c44,c55,c66,c12,c13,c23,c14,c24,c34,c15,c25,c35,c45,c16,c26,c36,c46,c56
@@ -1206,9 +1202,7 @@
templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
ispec_strain = 1
- !$OMP CRITICAL
epsilon_trace_over_3(i,j,k,ispec_strain) = templ
- !$OMP END CRITICAL
else
ispec_strain = ispec
epsilon_trace_over_3(i,j,k,ispec_strain) = templ
@@ -1472,81 +1466,18 @@
! local parameters
real(kind=CUSTOM_REAL) R_xx_val1,R_yy_val1
integer :: i_SLS
-#ifdef _HANDOPT_ATT
- real(kind=CUSTOM_REAL) R_xx_val2,R_yy_val2,R_xx_val3,R_yy_val3
- integer :: imodulo_N_SLS
- integer :: i_SLS1,i_SLS2
-#endif
-#ifdef _HANDOPT_ATT
-! way 2:
-! note: this should help compilers to pipeline the code and make better use of the cache;
-! depending on compilers, it can further decrease the computation time by ~ 30%.
-! by default, N_SLS = 3, therefore we take steps of 3
- imodulo_N_SLS = mod(N_SLS,3)
-
- if(imodulo_N_SLS >= 1) then
- do i_SLS = 1,imodulo_N_SLS
- R_xx_val1 = R_xx_loc(i_SLS)
- R_yy_val1 = R_yy_loc(i_SLS)
- sigma_xx = sigma_xx - R_xx_val1
- sigma_yy = sigma_yy - R_yy_val1
- sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
- sigma_xy = sigma_xy - R_xy_loc(i_SLS)
- sigma_xz = sigma_xz - R_xz_loc(i_SLS)
- sigma_yz = sigma_yz - R_yz_loc(i_SLS)
- enddo
- endif
- if(N_SLS >= imodulo_N_SLS+1) then
- ! note: another possibility would be using a reduction example for this loop; was tested but it does not improve,
- ! probably since N_SLS == 3 is too small for a loop benefit
- do i_SLS = imodulo_N_SLS+1,N_SLS,3
- R_xx_val1 = R_xx_loc(i_SLS)
- R_yy_val1 = R_yy_loc(i_SLS)
-
- i_SLS1=i_SLS+1
- R_xx_val2 = R_xx_loc(i_SLS1)
- R_yy_val2 = R_yy_loc(i_SLS1)
-
- i_SLS2 =i_SLS+2
- R_xx_val3 = R_xx_loc(i_SLS2)
- R_yy_val3 = R_yy_loc(i_SLS2)
-
- sigma_xx = sigma_xx - R_xx_val1 - R_xx_val2 - R_xx_val3
- sigma_yy = sigma_yy - R_yy_val1 - R_yy_val2 - R_yy_val3
- sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1 &
- + R_xx_val2 + R_yy_val2 &
- + R_xx_val3 + R_yy_val3
-
- sigma_xy = sigma_xy - R_xy_loc(i_SLS)
- sigma_xz = sigma_xz - R_xz_loc(i_SLS)
- sigma_yz = sigma_yz - R_yz_loc(i_SLS)
-
- sigma_xy = sigma_xy - R_xy_loc(i_SLS1)
- sigma_xz = sigma_xz - R_xz_loc(i_SLS1)
- sigma_yz = sigma_yz - R_yz_loc(i_SLS1)
-
- sigma_xy = sigma_xy - R_xy_loc(i_SLS2)
- sigma_xz = sigma_xz - R_xz_loc(i_SLS2)
- sigma_yz = sigma_yz - R_yz_loc(i_SLS2)
- enddo
- endif
-#else
-! way 1:
-
do i_SLS = 1,N_SLS
- R_xx_val1 = R_xx_loc(i_SLS) ! R_memory(1,i_SLS,i,j,k,ispec)
- R_yy_val1 = R_yy_loc(i_SLS) ! R_memory(2,i_SLS,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val1
- sigma_yy = sigma_yy - R_yy_val1
- sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
- sigma_xy = sigma_xy - R_xy_loc(i_SLS) ! R_memory(3,i_SLS,i,j,k,ispec)
- sigma_xz = sigma_xz - R_xz_loc(i_SLS) ! R_memory(4,i_SLS,i,j,k,ispec)
- sigma_yz = sigma_yz - R_yz_loc(i_SLS) ! R_memory(5,i_SLS,i,j,k,ispec)
+ R_xx_val1 = R_xx_loc(i_SLS) ! R_memory(1,i_SLS,i,j,k,ispec)
+ R_yy_val1 = R_yy_loc(i_SLS) ! R_memory(2,i_SLS,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val1
+ sigma_yy = sigma_yy - R_yy_val1
+ sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
+ sigma_xy = sigma_xy - R_xy_loc(i_SLS) ! R_memory(3,i_SLS,i,j,k,ispec)
+ sigma_xz = sigma_xz - R_xz_loc(i_SLS) ! R_memory(4,i_SLS,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_yz_loc(i_SLS) ! R_memory(5,i_SLS,i,j,k,ispec)
enddo
-#endif
-
end subroutine compute_element_att_stress
!
@@ -1557,8 +1488,7 @@
vx,vy,vz,vnspec,factor_common, &
alphaval,betaval,gammaval, &
c44store,muvstore, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy, &
- epsilondev_xz,epsilondev_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz, &
epsilondev_loc,is_backward_field)
! crust mantle
! update memory variables based upon the Runge-Kutta scheme
@@ -1617,72 +1547,12 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_c44_muv
integer :: i_SLS
-! double precision :: kappa
-
-#ifdef _HANDOPT_ATT
- real(kind=CUSTOM_REAL) :: alphal,betal,gammal
- integer :: i,j,k
-#endif
-
! use Runge-Kutta scheme to march in time
! get coefficients for that standard linear solid
! IMPROVE we use mu_v here even if there is some anisotropy
! IMPROVE we should probably use an average value instead
-#ifdef _HANDOPT_ATT
-! way 2:
- do i_SLS = 1,N_SLS
-
- alphal = alphaval(i_SLS)
- betal = betaval(i_SLS)
- gammal = gammaval(i_SLS)
-
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- if( USE_3D_ATTENUATION_ARRAYS ) then
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- factor_common_c44_muv(:,:,:) = factor_common(i_SLS,:,:,:,ispec) * c44store(:,:,:,ispec)
- else
- factor_common_c44_muv(:,:,:) = factor_common(i_SLS,:,:,:,ispec) * muvstore(:,:,:,ispec)
- endif
- else
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- factor_common_c44_muv(:,:,:) = factor_common(i_SLS,1,1,1,ispec) * c44store(:,:,:,ispec)
- else
- factor_common_c44_muv(:,:,:) = factor_common(i_SLS,1,1,1,ispec) * muvstore(:,:,:,ispec)
- endif
- endif
-
- ! this helps to vectorize the inner most loop
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- ! R_memory(:,i_SLS,i,j,k,ispec) = alphal * R_memory(:,i_SLS,i,j,k,ispec) &
- ! + factor_common_c44_muv(i,j,k) &
- ! *( betal * epsilondev(:,i,j,k,ispec) + gammal * epsilondev_loc(:,i,j,k))
-
- R_xx(i_SLS,i,j,k,ispec) = alphal * R_xx(i_SLS,i,j,k,ispec) + factor_common_c44_muv(i,j,k) * &
- (betal * epsilondev_xx(i,j,k,ispec) + gammal * epsilondev_loc(1,i,j,k))
-
- R_yy(i_SLS,i,j,k,ispec) = alphal * R_yy(i_SLS,i,j,k,ispec) + factor_common_c44_muv(i,j,k) * &
- (betal * epsilondev_yy(i,j,k,ispec) + gammal * epsilondev_loc(2,i,j,k))
-
- R_xy(i_SLS,i,j,k,ispec) = alphal * R_xy(i_SLS,i,j,k,ispec) + factor_common_c44_muv(i,j,k) * &
- (betal * epsilondev_xy(i,j,k,ispec) + gammal * epsilondev_loc(3,i,j,k))
-
- R_xz(i_SLS,i,j,k,ispec) = alphal * R_xz(i_SLS,i,j,k,ispec) + factor_common_c44_muv(i,j,k) * &
- (betal * epsilondev_xz(i,j,k,ispec) + gammal * epsilondev_loc(4,i,j,k))
-
- R_yz(i_SLS,i,j,k,ispec) = alphal * R_yz(i_SLS,i,j,k,ispec) + factor_common_c44_muv(i,j,k) * &
- (betal * epsilondev_yz(i,j,k,ispec) + gammal * epsilondev_loc(5,i,j,k))
-
- enddo
- enddo
- enddo
- enddo ! i_SLS
-#else
-! way 1:
-
!daniel: att - debug original
do i_SLS = 1,N_SLS
! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
@@ -1721,8 +1591,6 @@
if( is_backward_field ) then
endif
-#endif
-
end subroutine compute_element_att_memory_cm
!
@@ -1733,8 +1601,7 @@
vx,vy,vz,vnspec,factor_common, &
alphaval,betaval,gammaval, &
muvstore, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy, &
- epsilondev_xz,epsilondev_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz, &
epsilondev_loc,is_backward_field)
! inner core
! update memory variables based upon the Runge-Kutta scheme
@@ -1788,25 +1655,13 @@
integer :: i_SLS
-#ifdef _HANDOPT_ATT
- real(kind=CUSTOM_REAL) :: alphal,betal,gammal
- integer :: i,j,k
-#endif
-
! use Runge-Kutta scheme to march in time
! get coefficients for that standard linear solid
! IMPROVE we use mu_v here even if there is some anisotropy
! IMPROVE we should probably use an average value instead
-#ifdef _HANDOPT_ATT
-! way 2:
do i_SLS = 1,N_SLS
-
- alphal = alphaval(i_SLS)
- betal = betaval(i_SLS)
- gammal = gammaval(i_SLS)
-
! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
if( USE_3D_ATTENUATION_ARRAYS ) then
factor_common_use(:,:,:) = factor_common(i_SLS,:,:,:,ispec) * muvstore(:,:,:,ispec)
@@ -1814,42 +1669,6 @@
factor_common_use(:,:,:) = factor_common(i_SLS,1,1,1,ispec) * muvstore(:,:,:,ispec)
endif
- ! this helps to vectorize the inner most loop
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- ! R_memory(:,i_SLS,i,j,k,ispec) = alphal * R_memory(:,i_SLS,i,j,k,ispec) &
- ! + factor_common_use(i,j,k) &
- ! *( betal * epsilondev(:,i,j,k,ispec) + gammal * epsilondev_loc(:,i,j,k))
-
- R_xx(i_SLS,i,j,k,ispec) = alphal * R_xx(i_SLS,i,j,k,ispec) + factor_common_use(i,j,k) * &
- (betal * epsilondev_xx(i,j,k,ispec) + gammal * epsilondev_loc(1,i,j,k))
- R_yy(i_SLS,i,j,k,ispec) = alphal * R_yy(i_SLS,i,j,k,ispec) + factor_common_use(i,j,k) * &
- (betal * epsilondev_yy(i,j,k,ispec) + gammal * epsilondev_loc(2,i,j,k))
- R_xy(i_SLS,i,j,k,ispec) = alphal * R_xy(i_SLS,i,j,k,ispec) + factor_common_use(i,j,k) * &
- (betal * epsilondev_xy(i,j,k,ispec) + gammal * epsilondev_loc(3,i,j,k))
- R_xz(i_SLS,i,j,k,ispec) = alphal * R_xz(i_SLS,i,j,k,ispec) + factor_common_use(i,j,k) * &
- (betal * epsilondev_xz(i,j,k,ispec) + gammal * epsilondev_loc(4,i,j,k))
- R_yz(i_SLS,i,j,k,ispec) = alphal * R_yz(i_SLS,i,j,k,ispec) + factor_common_use(i,j,k) * &
- (betal * epsilondev_yz(i,j,k,ispec) + gammal * epsilondev_loc(5,i,j,k))
-
- enddo
- enddo
- enddo
-
- enddo ! i_SLS
-#else
-! way 1:
-
- do i_SLS = 1,N_SLS
-
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- if( USE_3D_ATTENUATION_ARRAYS ) then
- factor_common_use(:,:,:) = factor_common(i_SLS,:,:,:,ispec) * muvstore(:,:,:,ispec)
- else
- factor_common_use(:,:,:) = factor_common(i_SLS,1,1,1,ispec) * muvstore(:,:,:,ispec)
- endif
-
! do i_memory = 1,5
! R_memory(i_memory,i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_memory(i_memory,i_SLS,:,:,:,ispec) &
! + muvstore(:,:,:,ispec) * factor_common_use(:,:,:) * &
@@ -1877,11 +1696,8 @@
if( is_backward_field ) then
endif
-#endif
-
end subroutine compute_element_att_memory_ic
-
!
!--------------------------------------------------------------------------------------------
!
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_acoustic.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_acoustic.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_acoustic.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -294,10 +294,6 @@
use constants_solver,only: CUSTOM_REAL
-#ifdef _HANDOPT
- use specfem_par,only: imodulo_NGLOB_OUTER_CORE
-#endif
-
implicit none
integer :: NGLOB
@@ -316,32 +312,10 @@
! Newmark time scheme
! multiply by the inverse of the mass matrix and update velocity
-#ifdef _HANDOPT_NEWMARK
-! way 2:
- ! outer core
- if(imodulo_NGLOB_OUTER_CORE >= 1) then
- do i=1,imodulo_NGLOB_OUTER_CORE
- accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
- enddo
- endif
- do i=imodulo_NGLOB_OUTER_CORE+1,NGLOB,3
- accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
-
- accel_outer_core(i+1) = accel_outer_core(i+1)*rmass_outer_core(i+1)
- veloc_outer_core(i+1) = veloc_outer_core(i+1) + deltatover2*accel_outer_core(i+1)
-
- accel_outer_core(i+2) = accel_outer_core(i+2)*rmass_outer_core(i+2)
- veloc_outer_core(i+2) = veloc_outer_core(i+2) + deltatover2*accel_outer_core(i+2)
- enddo
-#else
-! way 1:
do i=1,NGLOB
accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
enddo
-#endif
end subroutine compute_forces_ac_update_veloc
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_crust_mantle_Dev.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_crust_mantle_Dev.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_crust_mantle_Dev.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -25,15 +25,6 @@
!
!=====================================================================
-! preprocessing definition: #define _HANDOPT : turns hand-optimized code on
-! #undef _HANDOPT : turns hand-optimized code off
-! or compile with: -D_HANDOPT
-!#define _HANDOPT
-
-! note: these hand optimizations should help compilers to pipeline the code and make better use of the cache;
-! depending on compilers, it can further decrease the computation time by ~ 30%.
-! the original routines are commented with "! way 1", the hand-optimized routines with "! way 2"
-
subroutine compute_forces_crust_mantle_Dev( NSPEC,NGLOB,NSPEC_ATT, &
deltat, &
displ_crust_mantle, &
@@ -187,14 +178,10 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
integer :: ispec,i,j,k,iglob1
-! integer :: computed_elements
+
integer :: num_elements,ispec_p
integer :: iphase
-#ifdef _HANDOPT
- integer, dimension(5) :: iglobv5
-#endif
-
! ****************************************************
! big loop over all spectral elements in the solid
! ****************************************************
@@ -219,42 +206,12 @@
! pages 386 and 389 and Figure 8.3.1
do k=1,NGLLZ
do j=1,NGLLY
-
-#ifdef _HANDOPT
-! way 2:
- ! since we know that NGLLX = 5, this should help pipelining
- iglobv5(:) = ibool(:,j,k,ispec)
-
- dummyx_loc(1,j,k) = displ_crust_mantle(1,iglobv5(1))
- dummyy_loc(1,j,k) = displ_crust_mantle(2,iglobv5(1))
- dummyz_loc(1,j,k) = displ_crust_mantle(3,iglobv5(1))
-
- dummyx_loc(2,j,k) = displ_crust_mantle(1,iglobv5(2))
- dummyy_loc(2,j,k) = displ_crust_mantle(2,iglobv5(2))
- dummyz_loc(2,j,k) = displ_crust_mantle(3,iglobv5(2))
-
- dummyx_loc(3,j,k) = displ_crust_mantle(1,iglobv5(3))
- dummyy_loc(3,j,k) = displ_crust_mantle(2,iglobv5(3))
- dummyz_loc(3,j,k) = displ_crust_mantle(3,iglobv5(3))
-
- dummyx_loc(4,j,k) = displ_crust_mantle(1,iglobv5(4))
- dummyy_loc(4,j,k) = displ_crust_mantle(2,iglobv5(4))
- dummyz_loc(4,j,k) = displ_crust_mantle(3,iglobv5(4))
-
- dummyx_loc(5,j,k) = displ_crust_mantle(1,iglobv5(5))
- dummyy_loc(5,j,k) = displ_crust_mantle(2,iglobv5(5))
- dummyz_loc(5,j,k) = displ_crust_mantle(3,iglobv5(5))
-
-#else
-! way 1:
do i=1,NGLLX
iglob1 = ibool(i,j,k,ispec)
dummyx_loc(i,j,k) = displ_crust_mantle(1,iglob1)
dummyy_loc(i,j,k) = displ_crust_mantle(2,iglob1)
dummyz_loc(i,j,k) = displ_crust_mantle(3,iglob1)
enddo
-
-#endif
enddo
enddo
@@ -267,78 +224,26 @@
do k=1,NGLLZ
do j=1,NGLLY
-
-#ifdef _HANDOPT
- ! way 2:
- ! since we know that NGLLX = 5, this should help pipelining
- iglobv5(:) = ibool(:,j,k,ispec)
-
- dummyx_loc_att(1,j,k) = dummyx_loc(1,j,k) + deltat*veloc_crust_mantle(1,iglobv5(1))
- dummyy_loc_att(1,j,k) = dummyy_loc(1,j,k) + deltat*veloc_crust_mantle(2,iglobv5(1))
- dummyz_loc_att(1,j,k) = dummyz_loc(1,j,k) + deltat*veloc_crust_mantle(3,iglobv5(1))
-
- dummyx_loc_att(2,j,k) = dummyx_loc(2,j,k) + deltat*veloc_crust_mantle(1,iglobv5(2))
- dummyy_loc_att(2,j,k) = dummyy_loc(2,j,k) + deltat*veloc_crust_mantle(2,iglobv5(2))
- dummyz_loc_att(2,j,k) = dummyz_loc(2,j,k) + deltat*veloc_crust_mantle(3,iglobv5(2))
-
- dummyx_loc_att(3,j,k) = dummyx_loc(3,j,k) + deltat*veloc_crust_mantle(1,iglobv5(3))
- dummyy_loc_att(3,j,k) = dummyy_loc(3,j,k) + deltat*veloc_crust_mantle(2,iglobv5(3))
- dummyz_loc_att(3,j,k) = dummyz_loc(3,j,k) + deltat*veloc_crust_mantle(3,iglobv5(3))
-
- dummyx_loc_att(4,j,k) = dummyx_loc(4,j,k) + deltat*veloc_crust_mantle(1,iglobv5(4))
- dummyy_loc_att(4,j,k) = dummyy_loc(4,j,k) + deltat*veloc_crust_mantle(2,iglobv5(4))
- dummyz_loc_att(4,j,k) = dummyz_loc(4,j,k) + deltat*veloc_crust_mantle(3,iglobv5(4))
-
- dummyx_loc_att(5,j,k) = dummyx_loc(5,j,k) + deltat*veloc_crust_mantle(1,iglobv5(5))
- dummyy_loc_att(5,j,k) = dummyy_loc(5,j,k) + deltat*veloc_crust_mantle(2,iglobv5(5))
- dummyz_loc_att(5,j,k) = dummyz_loc(5,j,k) + deltat*veloc_crust_mantle(3,iglobv5(5))
-
-#else
- ! way 1:
do i=1,NGLLX
iglob1 = ibool(i,j,k,ispec)
dummyx_loc_att(i,j,k) = dummyx_loc(i,j,k) + deltat*veloc_crust_mantle(1,iglob1)
dummyy_loc_att(i,j,k) = dummyy_loc(i,j,k) + deltat*veloc_crust_mantle(2,iglob1)
dummyz_loc_att(i,j,k) = dummyz_loc(i,j,k) + deltat*veloc_crust_mantle(3,iglob1)
enddo
-
-#endif
enddo
enddo
else
! takes old routines
do k=1,NGLLZ
do j=1,NGLLY
-#ifdef _HANDOPT
- dummyx_loc_att(1,j,k) = dummyx_loc(1,j,k)
- dummyx_loc_att(2,j,k) = dummyx_loc(2,j,k)
- dummyx_loc_att(3,j,k) = dummyx_loc(3,j,k)
- dummyx_loc_att(4,j,k) = dummyx_loc(4,j,k)
- dummyx_loc_att(5,j,k) = dummyx_loc(5,j,k)
-
- dummyy_loc_att(1,j,k) = dummyy_loc(1,j,k)
- dummyy_loc_att(2,j,k) = dummyy_loc(2,j,k)
- dummyy_loc_att(3,j,k) = dummyy_loc(3,j,k)
- dummyy_loc_att(4,j,k) = dummyy_loc(4,j,k)
- dummyy_loc_att(5,j,k) = dummyy_loc(5,j,k)
-
- dummyz_loc_att(1,j,k) = dummyz_loc(1,j,k)
- dummyz_loc_att(2,j,k) = dummyz_loc(2,j,k)
- dummyz_loc_att(3,j,k) = dummyz_loc(3,j,k)
- dummyz_loc_att(4,j,k) = dummyz_loc(4,j,k)
- dummyz_loc_att(5,j,k) = dummyz_loc(5,j,k)
-#else
!do i=1,NGLLX
! dummyx_loc_att(i,j,k) = dummyx_loc(i,j,k)
! dummyy_loc_att(i,j,k) = dummyy_loc(i,j,k)
! dummyz_loc_att(i,j,k) = dummyz_loc(i,j,k)
!enddo
-
dummyx_loc_att(:,j,k) = dummyx_loc(:,j,k)
dummyy_loc_att(:,j,k) = dummyy_loc(:,j,k)
dummyz_loc_att(:,j,k) = dummyz_loc(:,j,k)
-
-#endif
enddo
enddo
endif
@@ -576,6 +481,7 @@
hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
enddo
enddo
+
do i=1,m1
do j=1,m1
! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
@@ -600,6 +506,7 @@
enddo
enddo
enddo
+
do j=1,m1
do i=1,m2
E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
@@ -637,31 +544,16 @@
if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
enddo ! NGLLX
-
enddo ! NGLLY
enddo ! NGLLZ
! sum contributions from each element to the global mesh and add gravity terms
do k=1,NGLLZ
do j=1,NGLLY
-
-#ifdef _HANDOPT
-! way 2:
- iglobv5(:) = ibool(:,j,k,ispec)
-
- accel_crust_mantle(:,iglobv5(1)) = accel_crust_mantle(:,iglobv5(1)) + sum_terms(:,1,j,k)
- accel_crust_mantle(:,iglobv5(2)) = accel_crust_mantle(:,iglobv5(2)) + sum_terms(:,2,j,k)
- accel_crust_mantle(:,iglobv5(3)) = accel_crust_mantle(:,iglobv5(3)) + sum_terms(:,3,j,k)
- accel_crust_mantle(:,iglobv5(4)) = accel_crust_mantle(:,iglobv5(4)) + sum_terms(:,4,j,k)
- accel_crust_mantle(:,iglobv5(5)) = accel_crust_mantle(:,iglobv5(5)) + sum_terms(:,5,j,k)
-
-#else
-! way 1:
do i=1,NGLLX
iglob1 = ibool(i,j,k,ispec)
accel_crust_mantle(:,iglob1) = accel_crust_mantle(:,iglob1) + sum_terms(:,i,j,k)
enddo
-#endif
enddo
enddo
@@ -694,8 +586,6 @@
epsilondev_xz,epsilondev_yz, &
epsilondev_loc,is_backward_field)
-! endif
-
endif
! save deviatoric strain for Runge-Kutta scheme
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_elastic.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_elastic.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_elastic.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -608,10 +608,6 @@
use constants_solver,only: CUSTOM_REAL,NDIM
-#ifdef _HANDOPT
- use specfem_par,only: imodulo_NGLOB_CRUST_MANTLE4
-#endif
-
implicit none
integer :: NGLOB,NGLOB_XY,NCHUNKS_VAL
@@ -643,44 +639,6 @@
if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-#ifdef _HANDOPT_NEWMARK
- ! way 2:
- if(imodulo_NGLOB_CRUST_MANTLE4 >= 1) then
- do i=1,imodulo_NGLOB_CRUST_MANTLE4
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
- endif
- do i=imodulo_NGLOB_CRUST_MANTLE4+1,NGLOB,4
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
-
- accel_crust_mantle(1,i+1) = accel_crust_mantle(1,i+1)*rmassx_crust_mantle(i+1) &
- + two_omega_earth*veloc_crust_mantle(2,i+1)
- accel_crust_mantle(2,i+1) = accel_crust_mantle(2,i+1)*rmassy_crust_mantle(i+1) &
- - two_omega_earth*veloc_crust_mantle(1,i+1)
- accel_crust_mantle(3,i+1) = accel_crust_mantle(3,i+1)*rmassz_crust_mantle(i+1)
-
- accel_crust_mantle(1,i+2) = accel_crust_mantle(1,i+2)*rmassx_crust_mantle(i+2) &
- + two_omega_earth*veloc_crust_mantle(2,i+2)
- accel_crust_mantle(2,i+2) = accel_crust_mantle(2,i+2)*rmassy_crust_mantle(i+2) &
- - two_omega_earth*veloc_crust_mantle(1,i+2)
- accel_crust_mantle(3,i+2) = accel_crust_mantle(3,i+2)*rmassz_crust_mantle(i+2)
-
- accel_crust_mantle(1,i+3) = accel_crust_mantle(1,i+3)*rmassx_crust_mantle(i+3) &
- + two_omega_earth*veloc_crust_mantle(2,i+3)
- accel_crust_mantle(2,i+3) = accel_crust_mantle(2,i+3)*rmassy_crust_mantle(i+3) &
- - two_omega_earth*veloc_crust_mantle(1,i+3)
- accel_crust_mantle(3,i+3) = accel_crust_mantle(3,i+3)*rmassz_crust_mantle(i+3)
- enddo
-#else
- ! way 1:
do i=1,NGLOB
accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
+ two_omega_earth*veloc_crust_mantle(2,i)
@@ -688,48 +646,9 @@
- two_omega_earth*veloc_crust_mantle(1,i)
accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
enddo
-#endif
else
-#ifdef _HANDOPT_NEWMARK
- ! way 2:
- if(imodulo_NGLOB_CRUST_MANTLE4 >= 1) then
- do i=1,imodulo_NGLOB_CRUST_MANTLE4
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
- endif
- do i=imodulo_NGLOB_CRUST_MANTLE4+1,NGLOB,4
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
-
- accel_crust_mantle(1,i+1) = accel_crust_mantle(1,i+1)*rmassz_crust_mantle(i+1) &
- + two_omega_earth*veloc_crust_mantle(2,i+1)
- accel_crust_mantle(2,i+1) = accel_crust_mantle(2,i+1)*rmassz_crust_mantle(i+1) &
- - two_omega_earth*veloc_crust_mantle(1,i+1)
- accel_crust_mantle(3,i+1) = accel_crust_mantle(3,i+1)*rmassz_crust_mantle(i+1)
-
- accel_crust_mantle(1,i+2) = accel_crust_mantle(1,i+2)*rmassz_crust_mantle(i+2) &
- + two_omega_earth*veloc_crust_mantle(2,i+2)
- accel_crust_mantle(2,i+2) = accel_crust_mantle(2,i+2)*rmassz_crust_mantle(i+2) &
- - two_omega_earth*veloc_crust_mantle(1,i+2)
- accel_crust_mantle(3,i+2) = accel_crust_mantle(3,i+2)*rmassz_crust_mantle(i+2)
-
- accel_crust_mantle(1,i+3) = accel_crust_mantle(1,i+3)*rmassz_crust_mantle(i+3) &
- + two_omega_earth*veloc_crust_mantle(2,i+3)
- accel_crust_mantle(2,i+3) = accel_crust_mantle(2,i+3)*rmassz_crust_mantle(i+3) &
- - two_omega_earth*veloc_crust_mantle(1,i+3)
- accel_crust_mantle(3,i+3) = accel_crust_mantle(3,i+3)*rmassz_crust_mantle(i+3)
- enddo
-#else
- ! way 1:
do i=1,NGLOB
accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
+ two_omega_earth*veloc_crust_mantle(2,i)
@@ -737,7 +656,6 @@
- two_omega_earth*veloc_crust_mantle(1,i)
accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
enddo
-#endif
endif
@@ -752,10 +670,6 @@
use constants_solver,only: CUSTOM_REAL,NDIM
-#ifdef _HANDOPT
- use specfem_par,only: imodulo_NGLOB_CRUST_MANTLE4,imodulo_NGLOB_INNER_CORE
-#endif
-
implicit none
integer :: NGLOB_CM,NGLOB_IC
@@ -783,60 +697,6 @@
! - inner core region
! needs both, acceleration update & velocity corrector terms
-#ifdef _HANDOPT_NEWMARK
-! way 2:
- ! crust/mantle region
- if( imodulo_NGLOB_CRUST_MANTLE4 >= 1 ) then
- do i=1,imodulo_NGLOB_CRUST_MANTLE4
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- enddo
- endif
- do i=imodulo_NGLOB_CRUST_MANTLE4+1,NGLOB_CM,4
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i+1) = veloc_crust_mantle(:,i+1) + deltatover2*accel_crust_mantle(:,i+1)
- veloc_crust_mantle(:,i+2) = veloc_crust_mantle(:,i+2) + deltatover2*accel_crust_mantle(:,i+2)
- veloc_crust_mantle(:,i+3) = veloc_crust_mantle(:,i+3) + deltatover2*accel_crust_mantle(:,i+3)
- enddo
-
- ! inner core region
- if(imodulo_NGLOB_INNER_CORE >= 1) then
- do i=1,imodulo_NGLOB_INNER_CORE
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
- enddo
- endif
- do i=imodulo_NGLOB_INNER_CORE+1,NGLOB_IC,3
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
-
- accel_inner_core(1,i+1) = accel_inner_core(1,i+1)*rmass_inner_core(i+1) &
- + two_omega_earth*veloc_inner_core(2,i+1)
- accel_inner_core(2,i+1) = accel_inner_core(2,i+1)*rmass_inner_core(i+1) &
- - two_omega_earth*veloc_inner_core(1,i+1)
- accel_inner_core(3,i+1) = accel_inner_core(3,i+1)*rmass_inner_core(i+1)
-
- veloc_inner_core(:,i+1) = veloc_inner_core(:,i+1) + deltatover2*accel_inner_core(:,i+1)
-
- accel_inner_core(1,i+2) = accel_inner_core(1,i+2)*rmass_inner_core(i+2) &
- + two_omega_earth*veloc_inner_core(2,i+2)
- accel_inner_core(2,i+2) = accel_inner_core(2,i+2)*rmass_inner_core(i+2) &
- - two_omega_earth*veloc_inner_core(1,i+2)
- accel_inner_core(3,i+2) = accel_inner_core(3,i+2)*rmass_inner_core(i+2)
-
- veloc_inner_core(:,i+2) = veloc_inner_core(:,i+2) + deltatover2*accel_inner_core(:,i+2)
- enddo
-#else
-! way 1:
! mantle
do i=1,NGLOB_CM
veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
@@ -851,6 +711,5 @@
veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
enddo
-#endif
end subroutine compute_forces_el_update_veloc
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_inner_core_Dev.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_inner_core_Dev.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_inner_core_Dev.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -25,15 +25,6 @@
!
!=====================================================================
-! preprocessing definition: #define _HANDOPT : turns hand-optimized code on
-! #undef _HANDOPT : turns hand-optimized code off
-! or compile with: -D_HANDOPT
-!#define _HANDOPT
-
-! note: these hand optimizations should help compilers to pipeline the code and make better use of the cache;
-! depending on compilers, it can further decrease the computation time by ~ 30%.
-! the original routines are commented with "! way 1", the hand-optimized routines with "! way 2"
-
subroutine compute_forces_inner_core_Dev( NSPEC,NGLOB,NSPEC_ATT, &
deltat, &
displ_inner_core, &
@@ -205,15 +196,12 @@
integer :: num_elements,ispec_p
integer :: iphase
-#ifdef _HANDOPT
- integer, dimension(5) :: iglobv5
-#endif
-
! ****************************************************
! big loop over all spectral elements in the solid
! ****************************************************
! computed_elements = 0
+
if( .not. phase_is_inner ) then
iphase = 1
num_elements = nspec_outer
@@ -237,41 +225,12 @@
do k=1,NGLLZ
do j=1,NGLLY
-
-#ifdef _HANDOPT
-! way 2:
- ! since we know that NGLLX = 5, this should help pipelining
- iglobv5(:) = ibool(:,j,k,ispec)
-
- dummyx_loc(1,j,k) = displ_inner_core(1,iglobv5(1))
- dummyy_loc(1,j,k) = displ_inner_core(2,iglobv5(1))
- dummyz_loc(1,j,k) = displ_inner_core(3,iglobv5(1))
-
- dummyx_loc(2,j,k) = displ_inner_core(1,iglobv5(2))
- dummyy_loc(2,j,k) = displ_inner_core(2,iglobv5(2))
- dummyz_loc(2,j,k) = displ_inner_core(3,iglobv5(2))
-
- dummyx_loc(3,j,k) = displ_inner_core(1,iglobv5(3))
- dummyy_loc(3,j,k) = displ_inner_core(2,iglobv5(3))
- dummyz_loc(3,j,k) = displ_inner_core(3,iglobv5(3))
-
- dummyx_loc(4,j,k) = displ_inner_core(1,iglobv5(4))
- dummyy_loc(4,j,k) = displ_inner_core(2,iglobv5(4))
- dummyz_loc(4,j,k) = displ_inner_core(3,iglobv5(4))
-
- dummyx_loc(5,j,k) = displ_inner_core(1,iglobv5(5))
- dummyy_loc(5,j,k) = displ_inner_core(2,iglobv5(5))
- dummyz_loc(5,j,k) = displ_inner_core(3,iglobv5(5))
-
-#else
-! way 1:
do i=1,NGLLX
iglob1 = ibool(i,j,k,ispec)
dummyx_loc(i,j,k) = displ_inner_core(1,iglob1)
dummyy_loc(i,j,k) = displ_inner_core(2,iglob1)
dummyz_loc(i,j,k) = displ_inner_core(3,iglob1)
enddo
-#endif
enddo
enddo
@@ -283,75 +242,23 @@
do k=1,NGLLZ
do j=1,NGLLY
-
-#ifdef _HANDOPT
- ! way 2:
- ! since we know that NGLLX = 5, this should help pipelining
- iglobv5(:) = ibool(:,j,k,ispec)
-
- dummyx_loc_att(1,j,k) = deltat*veloc_inner_core(1,iglobv5(1))
- dummyy_loc_att(1,j,k) = deltat*veloc_inner_core(2,iglobv5(1))
- dummyz_loc_att(1,j,k) = deltat*veloc_inner_core(3,iglobv5(1))
-
- dummyx_loc_att(2,j,k) = deltat*veloc_inner_core(1,iglobv5(2))
- dummyy_loc_att(2,j,k) = deltat*veloc_inner_core(2,iglobv5(2))
- dummyz_loc_att(2,j,k) = deltat*veloc_inner_core(3,iglobv5(2))
-
- dummyx_loc_att(3,j,k) = deltat*veloc_inner_core(1,iglobv5(3))
- dummyy_loc_att(3,j,k) = deltat*veloc_inner_core(2,iglobv5(3))
- dummyz_loc_att(3,j,k) = deltat*veloc_inner_core(3,iglobv5(3))
-
- dummyx_loc_att(4,j,k) = deltat*veloc_inner_core(1,iglobv5(4))
- dummyy_loc_att(4,j,k) = deltat*veloc_inner_core(2,iglobv5(4))
- dummyz_loc_att(4,j,k) = deltat*veloc_inner_core(3,iglobv5(4))
-
- dummyx_loc_att(5,j,k) = deltat*veloc_inner_core(1,iglobv5(5))
- dummyy_loc_att(5,j,k) = deltat*veloc_inner_core(2,iglobv5(5))
- dummyz_loc_att(5,j,k) = deltat*veloc_inner_core(3,iglobv5(5))
-
-#else
- ! way 1:
do i=1,NGLLX
iglob1 = ibool(i,j,k,ispec)
dummyx_loc_att(i,j,k) = deltat*veloc_inner_core(1,iglob1)
dummyy_loc_att(i,j,k) = deltat*veloc_inner_core(2,iglob1)
dummyz_loc_att(i,j,k) = deltat*veloc_inner_core(3,iglob1)
enddo
-
-#endif
enddo
enddo
else
! takes old routines
do k=1,NGLLZ
do j=1,NGLLY
-#ifdef _HANDOPT
- dummyx_loc_att(1,j,k) = 0._CUSTOM_REAL
- dummyy_loc_att(1,j,k) = 0._CUSTOM_REAL
- dummyz_loc_att(1,j,k) = 0._CUSTOM_REAL
-
- dummyx_loc_att(2,j,k) = 0._CUSTOM_REAL
- dummyy_loc_att(2,j,k) = 0._CUSTOM_REAL
- dummyz_loc_att(2,j,k) = 0._CUSTOM_REAL
-
- dummyx_loc_att(3,j,k) = 0._CUSTOM_REAL
- dummyy_loc_att(3,j,k) = 0._CUSTOM_REAL
- dummyz_loc_att(3,j,k) = 0._CUSTOM_REAL
-
- dummyx_loc_att(4,j,k) = 0._CUSTOM_REAL
- dummyy_loc_att(4,j,k) = 0._CUSTOM_REAL
- dummyz_loc_att(4,j,k) = 0._CUSTOM_REAL
-
- dummyx_loc_att(5,j,k) = 0._CUSTOM_REAL
- dummyy_loc_att(5,j,k) = 0._CUSTOM_REAL
- dummyz_loc_att(5,j,k) = 0._CUSTOM_REAL
-#else
do i=1,NGLLX
dummyx_loc_att(i,j,k) = 0._CUSTOM_REAL
dummyy_loc_att(i,j,k) = 0._CUSTOM_REAL
dummyz_loc_att(i,j,k) = 0._CUSTOM_REAL
enddo
-#endif
enddo
enddo
endif
@@ -822,17 +729,17 @@
endif ! end of section with gravity terms
! form dot product with test vector, non-symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl) ! this goes to accel_x
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl) ! this goes to accel_y
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl) ! this goes to accel_z
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl) ! this goes to accel_x
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl) ! this goes to accel_y
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl) ! this goes to accel_z
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl) ! this goes to accel_x
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl) ! this goes to accel_y
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl) ! this goes to accel_z
enddo
enddo
@@ -862,6 +769,7 @@
hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
enddo
enddo
+
do i=1,m1
do j=1,m1
! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
@@ -886,6 +794,7 @@
enddo
enddo
enddo
+
do j=1,m1
do i=1,m2
E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
@@ -929,23 +838,10 @@
! sum contributions from each element to the global mesh and add gravity terms
do k=1,NGLLZ
do j=1,NGLLY
-#ifdef _HANDOPT
-! way 2:
- iglobv5(:) = ibool(:,j,k,ispec)
-
- accel_inner_core(:,iglobv5(1)) = accel_inner_core(:,iglobv5(1)) + sum_terms(:,1,j,k)
- accel_inner_core(:,iglobv5(2)) = accel_inner_core(:,iglobv5(2)) + sum_terms(:,2,j,k)
- accel_inner_core(:,iglobv5(3)) = accel_inner_core(:,iglobv5(3)) + sum_terms(:,3,j,k)
- accel_inner_core(:,iglobv5(4)) = accel_inner_core(:,iglobv5(4)) + sum_terms(:,4,j,k)
- accel_inner_core(:,iglobv5(5)) = accel_inner_core(:,iglobv5(5)) + sum_terms(:,5,j,k)
-
-#else
-! way 1:
do i=1,NGLLX
iglob1 = ibool(i,j,k,ispec)
accel_inner_core(:,iglob1) = accel_inner_core(:,iglob1) + sum_terms(:,i,j,k)
enddo
-#endif
enddo
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_outer_core_Dev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_outer_core_Dev.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_outer_core_Dev.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -80,7 +80,6 @@
! for the Euler scheme for rotation
real(kind=CUSTOM_REAL) :: two_omega_deltat,cos_two_omega_t,sin_two_omega_t,A_rotation,B_rotation, &
ux_rotation,uy_rotation,dpotentialdx_with_rot,dpotentialdy_with_rot
-
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: source_euler_A,source_euler_B
integer :: ispec,iglob
@@ -112,7 +111,7 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
displ_times_grad_x_ln_rho,displ_times_grad_y_ln_rho,displ_times_grad_z_ln_rho
-! integer :: computed_elements
+! integer :: computed_elements
integer :: num_elements,ispec_p
integer :: iphase
@@ -122,7 +121,7 @@
if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. (.not. phase_is_inner) ) div_displfluid(:,:,:,:) = 0._CUSTOM_REAL
-! computed_elements = 0
+! computed_elements = 0
if( .not. phase_is_inner ) then
iphase = 1
num_elements = nspec_outer
@@ -191,6 +190,7 @@
hprime_xx(i,5)*B1_m1_m2_5points(5,j)
enddo
enddo
+
do k = 1,NGLLX
do j=1,m1
do i=1,m1
@@ -202,6 +202,7 @@
enddo
enddo
enddo
+
do j=1,m1
do i=1,m2
C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
@@ -213,7 +214,6 @@
enddo
-
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
@@ -369,6 +369,7 @@
hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
enddo
enddo
+
do k = 1,NGLLX
do j=1,m1
do i=1,m1
@@ -380,6 +381,7 @@
enddo
enddo
enddo
+
do j=1,m1
do i=1,m2
E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_kernels.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_kernels.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -25,7 +25,6 @@
!
!=====================================================================
-
subroutine compute_kernels()
! kernel calculations
@@ -436,12 +435,10 @@
end subroutine compute_kernels_outer_core
-
!
!-------------------------------------------------------------------------------------------------
!
-
subroutine compute_kernels_inner_core()
use constants_solver
@@ -514,12 +511,11 @@
!
! Subroutines to compute the kernels for the 21 elastic coefficients
-! Last modified 19/04/2007
subroutine compute_strain_product(prod,eps_trace_over_3,epsdev,&
b_eps_trace_over_3,b_epsdev)
- ! Purpose : compute the 21 strain products at a grid point
+ ! Purpose: compute the 21 strain products at a grid point
! (ispec,i,j,k fixed) and at a time t to compute then the kernels cij_kl (Voigt notation)
! (eq. 15 of Tromp et al., 2005)
! prod(1)=eps11*eps11 -> c11, prod(2)=eps11eps22 -> c12, prod(3)=eps11eps33 -> c13, ...
@@ -528,8 +524,6 @@
! This then gives how the 21 kernels are organized
! For crust_mantle
- ! Modif 09/11/2005
-
implicit none
include "constants.h"
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_seismograms.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_seismograms.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -377,7 +377,6 @@
shdur_der(irec_local) = shdur_der(irec_local) + eps_m_s * Hp_deltat
-
enddo
end subroutine compute_seismograms_adjoint
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/get_attenuation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/get_attenuation.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/get_attenuation.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -28,8 +28,7 @@
subroutine get_attenuation_model_3D_or_1D(myrank, prname, &
one_minus_sum_beta, &
factor_common, &
- scale_factor, tau_s, &
- vx, vy, vz, vnspec)
+ scale_factor, tau_s, vx, vy, vz, vnspec)
use specfem_par,only: ATTENUATION_VAL, ADIOS_FOR_ARRAYS_SOLVER
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/initialize_simulation.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/initialize_simulation.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -25,7 +25,6 @@
!
!=====================================================================
-
subroutine initialize_simulation()
use specfem_par
@@ -39,16 +38,20 @@
integer, dimension(MAX_NUM_REGIONS) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+
integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
integer :: ratio_divide_central_cube
integer :: sizeprocs
integer :: ios
integer :: NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,NPROC_XI,NPROC_ETA
+
double precision :: RMOHO_FICTITIOUS_IN_MESHER,R120,R_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,&
CENTER_LATITUDE_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
GAMMA_ROTATION_AZIMUTH
+
integer :: REFERENCE_1D_MODEL,THREE_D_MODEL
+
logical :: TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS, &
ATTENUATION,ATTENUATION_NEW,ATTENUATION_3D,ROTATION,ELLIPTICITY, &
GRAVITY,CASE_3D,ISOTROPIC_3D_MANTLE, &
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -61,13 +61,6 @@
seismo_offset = it_begin-1
seismo_current = 0
-#ifdef _HANDOPT
- imodulo_NGLOB_CRUST_MANTLE = mod(NGLOB_CRUST_MANTLE,3)
- imodulo_NGLOB_CRUST_MANTLE4 = mod(NGLOB_CRUST_MANTLE,4)
- imodulo_NGLOB_INNER_CORE = mod(NGLOB_INNER_CORE,3)
- imodulo_NGLOB_OUTER_CORE = mod(NGLOB_OUTER_CORE,3)
-#endif
-
! get MPI starting time
time_start = wtime()
@@ -186,99 +179,7 @@
! on CPU
! Newmark time scheme update
-#ifdef _HANDOPT_NEWMARK
-! way 2:
-! One common technique in computational science to help enhance pipelining is loop unrolling
-!
-! we're accessing NDIM=3 components at each line,
-! that is, for an iteration, the register must contain
-! NDIM * displ_ + NDIM * veloc_ + NDIM * accel + deltat + deltatsq..
-! in most cases a real (CUSTOM_REAL) value will have 4 bytes,
-! assuming a default cache size of about 128 bytes, we unroll here in steps of 3, thus 29 reals or 118 bytes,
-! rather than with steps of 4
! mantle
- if(imodulo_NGLOB_CRUST_MANTLE >= 1) then
- do i = 1,imodulo_NGLOB_CRUST_MANTLE
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
-
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
-
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- endif
- do i = imodulo_NGLOB_CRUST_MANTLE+1,NGLOB_CRUST_MANTLE, 3 ! in steps of 3
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
- displ_crust_mantle(:,i+1) = displ_crust_mantle(:,i+1) &
- + deltat*veloc_crust_mantle(:,i+1) + deltatsqover2*accel_crust_mantle(:,i+1)
- displ_crust_mantle(:,i+2) = displ_crust_mantle(:,i+2) &
- + deltat*veloc_crust_mantle(:,i+2) + deltatsqover2*accel_crust_mantle(:,i+2)
-
-
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i+1) = veloc_crust_mantle(:,i+1) &
- + deltatover2*accel_crust_mantle(:,i+1)
- veloc_crust_mantle(:,i+2) = veloc_crust_mantle(:,i+2) &
- + deltatover2*accel_crust_mantle(:,i+2)
-
- ! set acceleration to zero
- ! note: we do initialize acceleration in this loop since it is read already into the cache,
- ! otherwise it would have to be read in again for this explicitly,
- ! which would make this step more expensive
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- accel_crust_mantle(:,i+1) = 0._CUSTOM_REAL
- accel_crust_mantle(:,i+2) = 0._CUSTOM_REAL
- enddo
-
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- displ_outer_core(i) = displ_outer_core(i) &
- + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
-
- veloc_outer_core(i) = veloc_outer_core(i) &
- + deltatover2*accel_outer_core(i)
-
- accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
-
- ! inner core
- if(imodulo_NGLOB_INNER_CORE >= 1) then
- do i = 1,imodulo_NGLOB_INNER_CORE
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
-
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
- endif
- do i = imodulo_NGLOB_INNER_CORE+1,NGLOB_INNER_CORE, 3 ! in steps of 3
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
- displ_inner_core(:,i+1) = displ_inner_core(:,i+1) &
- + deltat*veloc_inner_core(:,i+1) + deltatsqover2*accel_inner_core(:,i+1)
- displ_inner_core(:,i+2) = displ_inner_core(:,i+2) &
- + deltat*veloc_inner_core(:,i+2) + deltatsqover2*accel_inner_core(:,i+2)
-
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
- veloc_inner_core(:,i+1) = veloc_inner_core(:,i+1) &
- + deltatover2*accel_inner_core(:,i+1)
- veloc_inner_core(:,i+2) = veloc_inner_core(:,i+2) &
- + deltatover2*accel_inner_core(:,i+2)
-
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- accel_inner_core(:,i+1) = 0._CUSTOM_REAL
- accel_inner_core(:,i+2) = 0._CUSTOM_REAL
- enddo
-#else
-! way 1:
- ! mantle
do i=1,NGLOB_CRUST_MANTLE
displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
+ deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
@@ -302,85 +203,10 @@
+ deltatover2*accel_inner_core(:,i)
accel_inner_core(:,i) = 0._CUSTOM_REAL
enddo
-#endif
! backward field
if (SIMULATION_TYPE == 3) then
-
-#ifdef _HANDOPT_NEWMARK
-! way 2:
! mantle
- if(imodulo_NGLOB_CRUST_MANTLE >= 1) then
- do i=1,imodulo_NGLOB_CRUST_MANTLE
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- endif
- do i=imodulo_NGLOB_CRUST_MANTLE+1,NGLOB_CRUST_MANTLE,3
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_displ_crust_mantle(:,i+1) = b_displ_crust_mantle(:,i+1) &
- + b_deltat*b_veloc_crust_mantle(:,i+1) + b_deltatsqover2*b_accel_crust_mantle(:,i+1)
- b_displ_crust_mantle(:,i+2) = b_displ_crust_mantle(:,i+2) &
- + b_deltat*b_veloc_crust_mantle(:,i+2) + b_deltatsqover2*b_accel_crust_mantle(:,i+2)
-
-
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i+1) = b_veloc_crust_mantle(:,i+1) &
- + b_deltatover2*b_accel_crust_mantle(:,i+1)
- b_veloc_crust_mantle(:,i+2) = b_veloc_crust_mantle(:,i+2) &
- + b_deltatover2*b_accel_crust_mantle(:,i+2)
-
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- b_accel_crust_mantle(:,i+1) = 0._CUSTOM_REAL
- b_accel_crust_mantle(:,i+2) = 0._CUSTOM_REAL
- enddo
-
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- b_displ_outer_core(i) = b_displ_outer_core(i) &
- + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) &
- + b_deltatover2*b_accel_outer_core(i)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
-
- ! inner core
- if(imodulo_NGLOB_INNER_CORE >= 1) then
- do i=1,imodulo_NGLOB_INNER_CORE
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
- endif
- do i=imodulo_NGLOB_INNER_CORE+1,NGLOB_INNER_CORE,3
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_displ_inner_core(:,i+1) = b_displ_inner_core(:,i+1) &
- + b_deltat*b_veloc_inner_core(:,i+1) + b_deltatsqover2*b_accel_inner_core(:,i+1)
- b_displ_inner_core(:,i+2) = b_displ_inner_core(:,i+2) &
- + b_deltat*b_veloc_inner_core(:,i+2) + b_deltatsqover2*b_accel_inner_core(:,i+2)
-
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i+1) = b_veloc_inner_core(:,i+1) &
- + b_deltatover2*b_accel_inner_core(:,i+1)
- b_veloc_inner_core(:,i+2) = b_veloc_inner_core(:,i+2) &
- + b_deltatover2*b_accel_inner_core(:,i+2)
-
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- b_accel_inner_core(:,i+1) = 0._CUSTOM_REAL
- b_accel_inner_core(:,i+2) = 0._CUSTOM_REAL
- enddo
-#else
-! way 1:
- ! mantle
do i=1,NGLOB_CRUST_MANTLE
b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+ b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
@@ -404,7 +230,6 @@
+ b_deltatover2*b_accel_inner_core(:,i)
b_accel_inner_core(:,i) = 0._CUSTOM_REAL
enddo
-#endif
endif ! SIMULATION_TYPE == 3
else
! on GPU
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_receivers.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_receivers.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -30,7 +30,7 @@
!----
subroutine locate_receivers(nspec,nglob,ibool, &
- xstore,ystore,zstore, &
+ xstore,ystore,zstore, &
yr,jda,ho,mi,sec, &
theta_source,phi_source,NCHUNKS,ELLIPTICITY)
@@ -139,10 +139,6 @@
character(len=150) OUTPUT_FILES
character(len=2) bic
- integer,parameter :: MIDX = (NGLLX+1)/2
- integer,parameter :: MIDY = (NGLLY+1)/2
- integer,parameter :: MIDZ = (NGLLZ+1)/2
-
! timing
double precision, external :: wtime
@@ -220,6 +216,30 @@
! close receiver file
close(1)
+! BS BS begin
+! In case that the same station and network name appear twice (or more times) in the STATIONS
+! file, problems occur, as two (or more) seismograms are written (with mode
+! "append") to a file with same name. The philosophy here is to accept multiple
+! appearences and to just add a count to the station name in this case.
+ allocate(station_duplet(nrec))
+ station_duplet=0
+ do irec = 1,nrec
+ do i=1,irec-1
+ if ((station_name(irec)==station_name(i)) .and. &
+ (network_name(irec)==network_name(i))) then
+
+ station_duplet(i)=station_duplet(i)+1
+ if (len_trim(station_name(irec)) <= MAX_LENGTH_STATION_NAME-3) then
+ write(station_name(irec),"(a,'_',i2.2)") trim(station_name(irec)),station_duplet(i)+1
+ else
+ call exit_MPI(myrank,'Please increase MAX_LENGTH_STATION_NAME by at lease 3')
+ endif
+
+ endif
+ enddo
+ enddo
+! BS BS end
+
! if receivers can not be buried, sets depth to zero
if( .not. RECEIVERS_CAN_BE_BURIED ) stbur(:) = 0.d0
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_sources.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_sources.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -134,10 +134,6 @@
integer :: yr,jda,ho,mi
double precision :: sec
- integer,parameter :: MIDX = (NGLLX+1)/2
- integer,parameter :: MIDY = (NGLLY+1)/2
- integer,parameter :: MIDZ = (NGLLZ+1)/2
-
! timer MPI
double precision time_start,tCPU
double precision, external :: wtime
@@ -176,7 +172,7 @@
! initializes source mask
if( SAVE_SOURCE_MASK .and. SIMULATION_TYPE == 3 ) then
- allocate( mask_source(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier )
+ allocate(mask_source(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier)
if( ier /= 0 ) call exit_mpi(myrank,'error allocating mask source array')
mask_source(:,:,:,:) = 1.0_CUSTOM_REAL
endif
@@ -314,7 +310,6 @@
call get_topo_bathy(lat(isource),long(isource),elevation,ibathy_topo)
r0 = r0 + elevation/R_EARTH
endif
-
if(ELLIPTICITY) then
dcost = dcos(theta)
p20 = 0.5d0*(3.0d0*dcost*dcost-1.0d0)
@@ -333,7 +328,7 @@
! debug
! would only output desired target locations
- !if(myrank == 0) print*,sngl(x_target_source),sngl(y_target_source),sngl(z_target_source)
+ !if(myrank == 0) print *,sngl(x_target_source),sngl(y_target_source),sngl(z_target_source)
! set distance to huge initial value
distmin = HUGEVAL
@@ -352,7 +347,7 @@
dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
+ (y_target_source - dble(ystore(iglob)))**2 &
+ (z_target_source - dble(zstore(iglob)))**2)
- if( dist > typical_size ) cycle
+ if(dist > typical_size) cycle
endif
! define the interval in which we look for points
@@ -773,7 +768,6 @@
!-------------------------------------------------------------------------------------------------
!
-
subroutine calc_mask_source(mask_source,ispec,NSPEC,typical_size, &
x_target_source,y_target_source,z_target_source, &
ibool,xstore,ystore,zstore,NGLOB)
@@ -848,11 +842,9 @@
! stores into file
call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_TMP_PATH)
-
open(unit=27,file=trim(prname)//'mask_source.bin', &
status='unknown',form='unformatted',action='write',iostat=ier)
if( ier /= 0 ) call exit_mpi(myrank,'error opening mask_source.bin file')
-
write(27) mask_source
close(27)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/noise_tomography.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/noise_tomography.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/noise_tomography.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -210,6 +210,7 @@
use specfem_par
use specfem_par_crustmantle
+
implicit none
! local parameters
@@ -397,6 +398,7 @@
use specfem_par
use specfem_par_crustmantle
+
implicit none
! local parameters
@@ -445,6 +447,7 @@
use specfem_par
use specfem_par_crustmantle
+
implicit none
! local parameters
@@ -453,7 +456,7 @@
! get coordinates of surface mesh and surface displacement
if( .not. GPU_MODE ) then
! on CPU
- do ispec2D = 1, NSPEC_TOP ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
ispec = ibelm_top_crust_mantle(ispec2D)
k = NGLLZ
do j = 1,NGLLY
@@ -469,11 +472,10 @@
endif
! save surface motion to disk
- call write_abs(9,noise_surface_movie,CUSTOM_REAL*NDIM*NGLLX*NGLLY*NSPEC_TOP,it)
+ call write_abs(9,noise_surface_movie,CUSTOM_REAL*NDIM*NGLLX*NGLLY*nspec_top,it)
end subroutine noise_save_surface_movie
-
!
!-------------------------------------------------------------------------------------------------
!
@@ -496,6 +498,7 @@
use specfem_par
use specfem_par_crustmantle
+
implicit none
integer :: NGLOB
@@ -507,7 +510,6 @@
integer :: ipoin,ispec2D,ispec,i,j,k,iglob
real(kind=CUSTOM_REAL) :: eta
-
! read surface movie
call read_abs(9,noise_surface_movie,CUSTOM_REAL*NDIM*NGLLX*NGLLY*NSPEC_TOP,it_index)
@@ -515,7 +517,7 @@
if( .not. GPU_MODE ) then
! on CPU
ipoin = 0
- do ispec2D = 1, NSPEC_TOP ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
ispec = ibelm_top_crust_mantle(ispec2D)
k = NGLLZ
@@ -552,7 +554,6 @@
end subroutine noise_read_add_surface_movie
-
!
!-------------------------------------------------------------------------------------------------
!
@@ -580,7 +581,7 @@
real(kind=CUSTOM_REAL) :: eta
! read surface movie, needed for Sigma_kl_crust_mantle
- call read_abs(9,noise_surface_movie,CUSTOM_REAL*NDIM*NGLLX*NGLLY*NSPEC_TOP,it)
+ call read_abs(9,noise_surface_movie,CUSTOM_REAL*NDIM*NGLLX*NGLLY*nspec_top,it)
! noise source strength kernel
! to keep similar structure to other kernels, the source strength kernel is saved as a volumetric kernel
@@ -629,6 +630,7 @@
use specfem_par
use specfem_par_crustmantle
+
implicit none
! local parameters
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/prepare_timerun.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/prepare_timerun.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/prepare_timerun.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -685,7 +685,6 @@
end subroutine prepare_timerun_gravity
-
!
!-------------------------------------------------------------------------------------------------
!
@@ -806,9 +805,14 @@
! anelasticity: implications for seismology and mantle composition,
! Geophys. J. R. Astron. Soc., vol. 47, pp. 41-58 (1976)
! and in Aki, K. and Richards, P. G., Quantitative seismology, theory and methods,
- ! W. H. Freeman, (1980), second edition, sections 5.5 and 5.5.2, eq. (5.81) p. 170
+ ! W. H. Freeman, (1980), second edition, sections 5.5 and 5.5.2, eq. (5.81) p. 170.
+ ! Beware that in the book of Aki and Richards eq. (5.81) is given for velocities
+ ! while we need an equation for "mu" and thus we have an additional factor of 2
+ ! in the scaling factor below and in equation (49) of Komatitsch and Tromp, Geophys. J. Int. (2002) 149, 390-412,
+ ! because "mu" is related to the square of velocity.
! rescale in crust and mantle
+
do ispec = 1,NSPEC_CRUST_MANTLE
do k=1,NGLLZ
do j=1,NGLLY
@@ -854,12 +858,14 @@
muhstore_crust_mantle(i,j,k,ispec) = muhstore_crust_mantle(i,j,k,ispec) * scale_factor
endif
endif
+
enddo
enddo
enddo
enddo ! enddo CRUST MANTLE
! rescale in inner core
+
do ispec = 1,NSPEC_INNER_CORE
do k=1,NGLLZ
do j=1,NGLLY
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -198,7 +198,7 @@
! mass matrices
!
! in the case of stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
- ! on Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
+ ! on the Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
!
! if absorbing_conditions are not set or if NCHUNKS=6, only one mass matrix is needed
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_forward_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_forward_arrays.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_forward_arrays.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -283,4 +283,4 @@
endif
endif
-end subroutine read_forward_arrays
+ end subroutine read_forward_arrays
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_mesh_databases.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_mesh_databases.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -222,6 +222,7 @@
use specfem_par
use specfem_par_outercore
+
implicit none
! local parameters
@@ -1122,4 +1123,3 @@
close(27)
end subroutine read_mesh_databases_stacey
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/save_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/save_kernels.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/save_kernels.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -29,6 +29,7 @@
use specfem_par
use specfem_par_crustmantle
+
implicit none
! local parameters
@@ -482,7 +483,7 @@
write(27) alpha_kl_outer_core
close(27)
- !deviatoric kernel check
+ ! deviatoric kernel check
if( deviatoric_outercore ) then
open(unit=27,file=trim(prname)//'mu_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) beta_kl_outer_core
@@ -595,10 +596,8 @@
write(27) icb_kl
close(27)
-
end subroutine save_kernels_boundary_kl
-
!
!-------------------------------------------------------------------------------------------------
!
@@ -656,7 +655,6 @@
close(27)
enddo
-
end subroutine save_kernels_source_derivatives
!
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/setup_sources_receivers.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/setup_sources_receivers.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -145,7 +145,6 @@
enddo
endif
-
! filter source time function by Gaussian with hdur = HDUR_MOVIE when outputing movies or shakemaps
if (MOVIE_SURFACE .or. MOVIE_VOLUME ) then
! smaller hdur_movie will do
@@ -619,12 +618,10 @@
end subroutine setup_sources_receivers_srcarr
-
!
!-------------------------------------------------------------------------------------------------
!
-
subroutine setup_sources_receivers_adjindx(NSTEP,NSTEP_SUB_ADJ, &
NTSTEP_BETWEEN_READ_ADJSRC, &
iadjsrc,iadjsrc_len,iadj_vec)
@@ -639,7 +636,6 @@
integer, dimension(NSTEP_SUB_ADJ) :: iadjsrc_len
integer, dimension(NSTEP) :: iadj_vec
-
! local parameters
integer :: iadj_block,it,it_sub_adj
@@ -696,7 +692,6 @@
end subroutine setup_sources_receivers_adjindx
-
!
!-------------------------------------------------------------------------------------------------
!
@@ -778,7 +773,6 @@
!-------------------------------------------------------------------------------------------------
!
-
subroutine setup_sources_receivers_intp(NSOURCES,myrank, &
islice_selected_source, &
xi_source,eta_source,gamma_source, &
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -27,17 +27,6 @@
!
! United States and French Government Sponsorship Acknowledged.
-! preprocessing definition: #define _HANDOPT : turns hand-optimized code on
-! #undef _HANDOPT : turns hand-optimized code off
-! or compile with: -D_HANDOPT
-! (with the IBM xlf compiler, change this to -WF,-D_HANDOPT )
-!
-!#define _HANDOPT
-
-! note: these hand optimizations should help compilers to pipeline the code and make better use of the cache;
-! depending on compilers, it can further decrease the computation time by ~ 30%.
-! the original routines are commented with "! way 1", the hand-optimized routines with "! way 2"
-
program xspecfem3D
use specfem_par
@@ -73,6 +62,20 @@
! pages = {1-32},
! number = {1}}
!
+! @ARTICLE{PeKoLuMaLeCaLeMaLiBlNiBaTr11,
+! author = {Daniel Peter and Dimitri Komatitsch and Yang Luo and Roland Martin
+! and Nicolas {Le Goff} and Emanuele Casarotti and Pieyre {Le Loher}
+! and Federica Magnoni and Qinya Liu and C\'eline Blitz and Tarje Nissen-Meyer
+! and Piero Basini and Jeroen Tromp},
+! title = {Forward and adjoint simulations of seismic wave propagation on fully
+! unstructured hexahedral meshes},
+! journal={Geophys. J. Int.},
+! year = {2011},
+! volume = {186},
+! pages = {721-739},
+! number = {2},
+! doi = {10.1111/j.1365-246X.2011.05044.x}}
+!
! or
!
! @ARTICLE{VaCaSaKoVi99,
@@ -233,7 +236,19 @@
! pages = {1-32},
! number = {1}}
!
-! or
+! @ARTICLE{PeKoLuMaLeCaLeMaLiBlNiBaTr11,
+! author = {Daniel Peter and Dimitri Komatitsch and Yang Luo and Roland Martin
+! and Nicolas {Le Goff} and Emanuele Casarotti and Pieyre {Le Loher}
+! and Federica Magnoni and Qinya Liu and C\'eline Blitz and Tarje Nissen-Meyer
+! and Piero Basini and Jeroen Tromp},
+! title = {Forward and adjoint simulations of seismic wave propagation on fully
+! unstructured hexahedral meshes},
+! journal={Geophys. J. Int.},
+! year = {2011},
+! volume = {186},
+! pages = {721-739},
+! number = {2},
+! doi = {10.1111/j.1365-246X.2011.05044.x}}
!
! @ARTICLE{LiTr06,
! author={Qinya Liu and Jeroen Tromp},
@@ -291,7 +306,7 @@
! new convention for the name of seismograms, to conform to the IRIS standard;
! new directory structure
!
-! v. 5.0 aka Tiger, many developers some with Princeton Tiger logo on their shirts, February 2010:
+! v. 5.0, many developers, February 2010:
! new moho mesh stretching honoring crust2.0 moho depths,
! new attenuation assignment, new SAC headers, new general crustal models,
! faster performance due to Deville routines and enhanced loop unrolling,
@@ -310,7 +325,7 @@
! added AK135 and 1066a, fixed topography/bathymetry routine,
! new attenuation routines, faster and better I/Os on very large
! systems, many small improvements and bug fixes, new "configure"
-! script, new Pyre version, new user's manual etc.
+! script, new user's manual etc.
!
! v. 3.5 Dimitri Komatitsch, Brian Savage and Jeroen Tromp, Caltech, July 2004:
! any size of chunk, 3D attenuation, case of two chunks,
@@ -371,8 +386,9 @@
! Its first time derivative is called veloc_outer_core.
! Its second time derivative is called accel_outer_core.
-
+! *************************************************
! ************** PROGRAM STARTS HERE **************
+! *************************************************
!
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
@@ -422,11 +438,7 @@
! required to perform matrix-matrix products at the spectral element level.
! For most compilers and hardware, will result in a significant speedup (> 30% or more, sometimes twice faster).
!
-! note 5: a common technique to help compilers enhance pipelining is loop unrolling. We do this here in a simple
-! and straigthforward way, so don't be confused about the do-loop writing. For this to take effect,
-! you have to turn the hand-optimization flag on: compile with additional flag -D_HANDOPT
-!
-! note 6: whenever adding some new code, please make sure to use
+! note 5: whenever adding some new code, please make sure to use
! spaces rather than tabs. Tabulators are in principle not allowed in Fortran95.
!
!-------------------------------------------------------------------------------------------------
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D_par.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D_par.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D_par.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -322,11 +322,6 @@
! ADJOINT
real(kind=CUSTOM_REAL) :: b_deltat,b_deltatover2,b_deltatsqover2
-#ifdef _HANDOPT
- integer :: imodulo_NGLOB_CRUST_MANTLE,imodulo_NGLOB_CRUST_MANTLE4, &
- imodulo_NGLOB_INNER_CORE,imodulo_NGLOB_OUTER_CORE
-#endif
-
end module specfem_par
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_movie_surface.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_movie_surface.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_movie_surface.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -30,6 +30,7 @@
use specfem_par
use specfem_par_crustmantle
use specfem_par_movie
+
implicit none
include 'mpif.h'
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_movie_volume.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_movie_volume.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_movie_volume.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -67,7 +67,7 @@
thetaval = ystore_crust_mantle(iglob)
phival = zstore_crust_mantle(iglob)
- ! we alread changed xyz back to rthetaphi
+ ! we already changed xyz back to rthetaphi
if( (rval < MOVIE_TOP .and. rval > MOVIE_BOTTOM) .and. &
(thetaval > MOVIE_NORTH .and. thetaval < MOVIE_SOUTH) .and. &
( (phival < MOVIE_EAST .and. phival > MOVIE_WEST) .or. &
@@ -111,6 +111,7 @@
Iepsilondev_yz)
use constants_solver
+
implicit none
real(kind=CUSTOM_REAL) :: deltat
@@ -161,8 +162,6 @@
real(kind=CUSTOM_REAL), dimension(npoints_3dmovie) :: store_val3D_x,store_val3D_y, store_val3D_z
real(kind=CUSTOM_REAL), dimension(npoints_3dmovie) :: store_val3D_mu
-! character(len=150) :: prname
-
if(NDIM /= 3) stop 'movie volume output requires NDIM = 3'
if(MOVIE_COARSE) then
@@ -299,8 +298,7 @@
! input
integer :: myrank,npoints_3dmovie,MOVIE_VOLUME_TYPE,it
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_3DMOVIE) :: &
- eps_trace_over_3_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_3DMOVIE) :: eps_trace_over_3_crust_mantle
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_3DMOVIE) :: &
epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle,epsilondev_xy_crust_mantle, &
@@ -316,7 +314,7 @@
character(len=150) LOCAL_TMP_PATH,outputname
! variables
- !character(len=150) prname
+ ! character(len=150) prname
real(kind=CUSTOM_REAL) :: muv_3dmovie
real(kind=CUSTOM_REAL),dimension(3,3) :: eps_loc,eps_loc_new
real(kind=CUSTOM_REAL),dimension(:),allocatable :: store_val3d_NN,store_val3d_EE,store_val3d_ZZ,&
@@ -351,7 +349,7 @@
iNIT = 1
endif
- !write(prname,"('proc',i6.6)") myrank
+ ! write(prname,"('proc',i6.6)") myrank
ipoints_3dmovie=0
do ispec=1,NSPEC_CRUST_MANTLE
@@ -456,11 +454,11 @@
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
real(kind=CUSTOM_REAL), dimension(3,NGLOB_CRUST_MANTLE) :: vector_crust_mantle
+ logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: mask_3dmovie
+
double precision :: scalingval
real(kind=CUSTOM_REAL), dimension(3,3,npoints_3dmovie) :: nu_3dmovie
- logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: mask_3dmovie
-
character(len=150) LOCAL_TMP_PATH
! local parameters
@@ -476,6 +474,14 @@
if(NDIM /= 3) call exit_MPI(myrank,'write_movie_volume requires NDIM = 3')
! allocates arrays
+!! DK DK to Daniel: "vector_scaled" is a big array, we could consider suppress it
+!! DK DK (it does not appear in the trunk version of the same routine)
+!! DK DK to Daniel: "vector_scaled" is a big array, we could consider suppress it
+!! DK DK (it does not appear in the trunk version of the same routine)
+!! DK DK to Daniel: "vector_scaled" is a big array, we could consider suppress it
+!! DK DK (it does not appear in the trunk version of the same routine)
+!! DK DK to Daniel: "vector_scaled" is a big array, we could consider suppress it
+!! DK DK (it does not appear in the trunk version of the same routine)
allocate(store_val3d_N(npoints_3dmovie), &
store_val3d_E(npoints_3dmovie), &
store_val3d_Z(npoints_3dmovie), &
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/setup/constants.h.in
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/setup/constants.h.in 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/setup/constants.h.in 2013-07-02 15:37:49 UTC (rev 22486)
@@ -380,6 +380,11 @@
! Deville routines optimized for NGLLX = NGLLY = NGLLZ = 5
integer, parameter :: m1 = NGLLX, m2 = NGLLX * NGLLY
+! mid-points inside a GLL element
+ integer, parameter :: MIDX = (NGLLX+1)/2
+ integer, parameter :: MIDY = (NGLLY+1)/2
+ integer, parameter :: MIDZ = (NGLLZ+1)/2
+
! gravitational constant
double precision, parameter :: GRAV = 6.6723d-11
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh_adios.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh_adios.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh_adios.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,175 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
-subroutine crm_save_mesh_files_adios(nspec,npointot,iregion_code, &
- num_ibool_AVS_DX, mask_ibool)
- use mpi
- use adios_write_mod
-
- use meshfem3d_par,only: &
- ibool,idoubling, &
- xstore,ystore,zstore, &
- myrank,NGLLX,NGLLY,NGLLZ, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN, &
- ADIOS_FOR_AVS_DX, LOCAL_PATH
-
-
- use meshfem3D_models_par,only: &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- nspl,rspl,espl,espl2
-
- use create_regions_mesh_par2
-
- ! Modules for temporary AVS/DX data
- use AVS_DX_global_mod
- use AVS_DX_global_faces_mod
- use AVS_DX_global_chunks_mod
- use AVS_DX_surface_mod
-
- implicit none
-
- ! number of spectral elements in each block
- integer,intent(in) :: nspec,npointot,iregion_code
-
- ! local parameters
- ! arrays used for AVS or DX files
- integer, dimension(npointot), intent(inout) :: num_ibool_AVS_DX
- logical, dimension(npointot), intent(inout) :: mask_ibool
- ! structures used for ADIOS AVS/DX files
- type(avs_dx_global_t) :: avs_dx_global_vars
- type(avs_dx_global_faces_t) :: avs_dx_global_faces_vars
- type(avs_dx_global_chunks_t) :: avs_dx_global_chunks_vars
- type(avs_dx_surface_t) :: avs_dx_surface_vars
-
- character(len=150) :: reg_name, outputname, group_name
- integer :: comm, sizeprocs, ier
- integer(kind=8) :: adios_group, group_size_inc, adios_totalsize, adios_handle
-
- ! create a prefix for the file name such as LOCAL_PATH/regX_
- call create_name_database_adios(reg_name,iregion_code,LOCAL_PATH)
- outputname = trim(reg_name) // "AVS_DX.bp"
- write(group_name,"('SPECFEM3D_GLOBE_AVS_DX_reg',i1)") iregion_code
- call world_size(sizeprocs) ! TODO keep it in parameters
- ! Alias COMM_WORLD to use ADIOS
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ier)
- group_size_inc = 0
- call adios_declare_group(adios_group, group_name, &
- "", 0, ier)
- ! We set the transport method to 'MPI'. This seems to be the correct choice
- ! for now. We might want to move this to the constant.h file later on.
- call adios_select_method(adios_group, "MPI", "", "", ier)
-
- !--- Define ADIOS variables -----------------------------
- call define_AVS_DX_global_data_adios(adios_group, myrank, nspec, ibool, &
- npointot, mask_ibool, group_size_inc, avs_dx_global_vars)
-
- call define_AVS_DX_global_faces_data_adios (adios_group, &
- myrank, prname, nspec, iMPIcut_xi,iMPIcut_eta, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- group_size_inc, avs_dx_global_faces_vars)
-
- call define_AVS_DX_global_chunks_data(adios_group, &
- myrank,prname,nspec,iboun,ibool, &
- idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- group_size_inc, avs_dx_global_chunks_vars)
-
- call define_AVS_DX_surfaces_data_adios(adios_group, &
- myrank,prname,nspec,iboun, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,npointot,&
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- group_size_inc, avs_dx_surface_vars)
-
- !--- Open an ADIOS handler to the AVS_DX file. ---------
- call adios_open (adios_handle, group_name, &
- outputname, "w", comm, ier);
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, ier)
-
- !--- Schedule writes for the previously defined ADIOS variables
- call prepare_AVS_DX_global_data_adios(adios_handle, myrank, &
- nspec, ibool, idoubling, xstore, ystore, zstore, num_ibool_AVS_DX, &
- mask_ibool, npointot, avs_dx_global_vars)
- call write_AVS_DX_global_data_adios(adios_handle, myrank, &
- sizeprocs, avs_dx_global_vars)
-
- call prepare_AVS_DX_global_faces_data_adios (myrank, prname, nspec, &
- iMPIcut_xi,iMPIcut_eta, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- avs_dx_global_faces_vars)
- call write_AVS_DX_global_faces_data_adios(adios_handle, myrank, &
- sizeprocs, avs_dx_global_faces_vars, ISOTROPIC_3D_MANTLE)
-
- call prepare_AVS_DX_global_chunks_data_adios(myrank,prname,nspec, &
- iboun,ibool, idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,&
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- avs_dx_global_chunks_vars)
- call write_AVS_DX_global_chunks_data_adios(adios_handle, myrank, &
- sizeprocs, avs_dx_global_chunks_vars, ISOTROPIC_3D_MANTLE)
-
- call prepare_AVS_DX_surfaces_data_adios(myrank,prname,nspec,iboun, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,npointot,&
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- avs_dx_surface_vars)
- call write_AVS_DX_surfaces_data_adios(adios_handle, myrank, &
- sizeprocs, avs_dx_surface_vars, ISOTROPIC_3D_MANTLE)
-
- !--- Reset the path to zero and perform the actual write to disk
- call adios_set_path (adios_handle, "", ier)
- call adios_close(adios_handle, ier)
-
- !--- Clean up temporary arrays -------------------------
- call free_AVS_DX_global_data_adios(myrank, avs_dx_global_vars)
- call free_AVS_DX_global_faces_data_adios(myrank, avs_dx_global_faces_vars, &
- ISOTROPIC_3D_MANTLE)
- call free_AVS_DX_global_chunks_data_adios(myrank, avs_dx_global_chunks_vars, &
- ISOTROPIC_3D_MANTLE)
- call free_AVS_DX_surfaces_data_adios(myrank, avs_dx_surface_vars, &
- ISOTROPIC_3D_MANTLE)
-end subroutine crm_save_mesh_files_adios
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_absorb_adios.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_absorb_adios.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_absorb_adios.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,161 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!-------------------------------------------------------------------------------
-!> \file get_absorb_adios.f90
-!! \brief Function to write stacey boundary condition to disk with ADIOS.
-!! \author MPBL
-!-------------------------------------------------------------------------------
-
-!===============================================================================
-!> \brief Write stacey boundary conditions to a single file using ADIOS
-!!
-!! \param myrank The MPI rank of the current process
-!! \param iregion The region the absorbing conditon is written for. Check
-!! constant.h files to see what these regions are.
-!! \param nimin An array to be written
-!! \param nimax An array to be written
-!! \param njmin An array to be written
-!! \param njmax An array to be written
-!! \param nkmin_xi An array to be written
-!! \param nkmin_eta An array to be written
-!! \param NSPEC2DMAX_XMIN_XMAX Integer to compute the size of the arrays
-!! in argument
-!! \param NSPEC2DMAX_YMIN_YMAX Integer to compute the size of the arrays
-!! in argument
-!!
-!! \note This routine only call adios to write the file to disk, Note that he
-!! necessary data preparation is done by the get_absorb() routine.
-subroutine get_absorb_adios(myrank, iregion, nimin, nimax, njmin, njmax, &
- nkmin_xi, nkmin_eta, NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
-
- use mpi
- use adios_write_mod
- use meshfem3D_par, only: LOCAL_PATH
-
- ! Stacey, define flags for absorbing boundaries
- implicit none
-
- include "constants.h"
-
- integer :: myrank
- integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
-
- integer,dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nimin,nimax
- integer,dimension(2,NSPEC2DMAX_XMIN_XMAX) :: njmin,njmax
- integer,dimension(2,NSPEC2DMAX_XMIN_XMAX) :: nkmin_xi
- integer,dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nkmin_eta
-
- character(len=150) :: reg_name, outputname, group_name
- integer :: sizeprocs, comm, local_dim, ierr, iregion
- integer(kind=8) :: group_size_inc
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid
- integer(kind=8) :: adios_groupsize, adios_totalsize
-
- ! create a prefix for the file name such as LOCAL_PATH/regX_
- call create_name_database_adios(reg_name,iregion,LOCAL_PATH)
-
- ! Postpend the actual file name.
- outputname = trim(reg_name) // "stacey.bp"
-
- ! save these temporary arrays for the solver for Stacey conditions
- write(group_name,"('SPECFEM3D_GLOBE_STACEY_reg',i1)") iregion
- call world_size(sizeprocs) ! TODO keep it in parameters
- ! Alias COMM_WORLD to use ADIOS
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
- ! set the adios group size to 0 before incremented by calls to
- ! helpers functions.
- group_size_inc = 0
- call adios_declare_group(adios_group, group_name, &
- "", 0, adios_err)
- ! We set the transport method to 'MPI'. This seems to be the correct choice
- ! for now. We might want to move this to the constant.h file later on.
- call adios_select_method(adios_group, "MPI", "", "", adios_err)
-
- !--- Define ADIOS variables -----------------------------
- local_dim = 2*NSPEC2DMAX_XMIN_XMAX
- call define_adios_global_integer_1d_array(adios_group, "njmin", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "njmax", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "nkmin_xi", &
- local_dim, group_size_inc)
- local_dim = 2*NSPEC2DMAX_YMIN_YMAX
- call define_adios_global_integer_1d_array(adios_group, "nimin", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "nimax", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "nkmin_eta", &
- local_dim, group_size_inc)
-
- !--- Open an ADIOS handler to the restart file. ---------
- call adios_open (adios_handle, group_name, &
- outputname, "w", comm, adios_err);
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, adios_err)
-
- !--- Schedule writes for the previously defined ADIOS variables
- local_dim = 2*NSPEC2DMAX_XMIN_XMAX
- call adios_set_path (adios_handle, "njmin", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", njmin, adios_err)
-
- call adios_set_path (adios_handle, "njmax", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", njmax, adios_err)
-
- call adios_set_path (adios_handle, "nkmin_xi", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", nkmin_xi, adios_err)
-
- local_dim = 2*NSPEC2DMAX_YMIN_YMAX
- call adios_set_path (adios_handle, "nimin", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", nimin, adios_err)
-
- call adios_set_path (adios_handle, "nimax", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", nimax, adios_err)
-
- call adios_set_path (adios_handle, "nkmin_eta", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", nkmin_eta, adios_err)
-
- !--- Reset the path to zero and perform the actual write to disk
- call adios_set_path (adios_handle, "", adios_err)
- call adios_close(adios_handle, adios_err)
-
-end subroutine get_absorb_adios
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/save_arrays_solver_adios.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/save_arrays_solver_adios.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/save_arrays_solver_adios.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,1603 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!-------------------------------------------------------------------------------
-!> \file get_absorb_adios.f90
-!! \brief Function to write stacey boundary condition to disk with ADIOS.
-!! \author MPBL
-!-------------------------------------------------------------------------------
-
-!===============================================================================
-!> \brief Main routine to save the arrays from the mesher to the solver with the
-!! help of ADIOS
-!! \param myrank The MPI rank of the current process
-!! \param nspec Number of GLL points per element
-!! \param nglob Number of mesh points
-!! \param idoubling Array of information on every mesh point
-!! \param ibool Array of information on every mesh point
-!! \param iregion_code The region the absorbing conditon is written for. Check
-!! constant.h files to see what these regions are.
-!! \param xstore Array with the x coordinates of the mesh points
-!! \param ystore Array with the y coordinates of the mesh points
-!! \param zstore Array with the z coordinates of the mesh points
-!! \param NSPEC2DMAX_XMIN_XMAX Integer to compute the size of the arrays
-!! in argument
-!! \param NSPEC2DMAX_YMIN_YMAX Integer to compute the size of the arrays
-!! in argument
-!! \param NSPEC2D_TOP Integer to compute the size of the arrays
-!! in argument
-!! \param NSPEC2D_BOTTOM Integer to compute the size of the arrays
-!! in argument
-subroutine save_arrays_solver_adios(myrank,nspec,nglob,idoubling,ibool, &
- iregion_code,xstore,ystore,zstore, &
- NSPEC2DMAX_XMIN_XMAX, NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_TOP,NSPEC2D_BOTTOM)
-
- use mpi
- use adios_write_mod
-
- use constants
-
- use meshfem3D_models_par,only: &
- OCEANS,TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,ATTENUATION
-
- use meshfem3D_par,only: &
- NCHUNKS,ABSORBING_CONDITIONS,SAVE_MESH_FILES, LOCAL_PATH, &
- ADIOS_FOR_SOLVER_MESHFILES
-
- use create_regions_mesh_par2,only: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- rmassx,rmassy,rmassz,rmass_ocean_load, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
- jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top, &
- rho_vp,rho_vs, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- ispec_is_tiso,tau_s,T_c_source,tau_e_store,Qmu_store, &
- prname, nspec_actually, nspec_ani, nspec_stacey, nglob_xy, nglob_oceans
-
- implicit none
-
- integer :: myrank
- integer :: nspec,nglob
-
- ! doubling mesh flag
- integer, dimension(nspec) :: idoubling
- integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
- integer :: iregion_code
-
- ! arrays with the mesh in double precision
- double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
-
- ! boundary parameters locator
- integer :: NSPEC2D_TOP,NSPEC2D_BOTTOM, &
- NSPEC2DMAX_XMIN_XMAX, NSPEC2DMAX_YMIN_YMAX
-
- ! local parameters
- integer :: i,j,k,ispec,iglob,ier
- real(kind=CUSTOM_REAL),dimension(:),allocatable :: tmp_array_x, &
- tmp_array_y, tmp_array_z
-
- ! local parameters
- character(len=150) :: reg_name, outputname, group_name
- integer :: ierr, sizeprocs, comm, local_dim
- integer(kind=8) :: group_size_inc
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid
- integer(kind=8) :: adios_groupsize, adios_totalsize
-
- ! create a prefix for the file name such as LOCAL_PATH/regX_
- call create_name_database_adios(reg_name,iregion_code,LOCAL_PATH)
-
- !---------------------------------------------------------
- !--- Solver data arrays ----------------------------------
- !---------------------------------------------------------
-
- ! create the name for the database of the current slide and region
- outputname = trim(reg_name) // "solver_data.bp"
-
- ! save arrays for the solver to run.
- write(group_name,"('SPECFEM3D_GLOBE_ARRAYS_SOLVER_reg',i1)") iregion_code
- call world_size(sizeprocs) ! TODO keep it in parameters
- ! Alias COMM_WORLD to use ADIOS
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
- ! set the adios group size to 0 before incremented by calls to
- ! helpers functions.
- group_size_inc = 0
- call adios_declare_group(adios_group, group_name, &
- "", 0, adios_err)
- ! We set the transport method to 'MPI'. This seems to be the correct choice
- ! for now. We might want to move this to the constant.h file later on.
- call adios_select_method(adios_group, "MPI", "", "", adios_err)
-
- !--- Define ADIOS variables -----------------------------
- ! save nspec and nglob, to be used in combine_paraview_data
- call define_adios_integer_scalar (adios_group, "nspec", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "nglob", "", &
- group_size_inc)
-
- local_dim = nglob
- call define_adios_global_real_1d_array(adios_group, "xstore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "ystore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "zstore", &
- local_dim, group_size_inc)
-
- local_dim = NGLLX * NGLLY * NGLLZ * nspec
- call define_adios_global_real_1d_array(adios_group, "rhostore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "kappavstore", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "ibool", &
- local_dim, group_size_inc)
- if(iregion_code /= IREGION_OUTER_CORE) then
- if(.not. (ANISOTROPIC_3D_MANTLE .and. &
- iregion_code == IREGION_CRUST_MANTLE)) then
- call define_adios_global_real_1d_array(adios_group, "muvstore", &
- local_dim, group_size_inc)
- endif
- if(TRANSVERSE_ISOTROPY) then
- if(iregion_code == IREGION_CRUST_MANTLE .and. &
- .not. ANISOTROPIC_3D_MANTLE) then
- call define_adios_global_real_1d_array(adios_group, "kappahstore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "muhstore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "eta_anisostore", &
- local_dim, group_size_inc)
- endif
- endif
- endif
-
- local_dim = nspec
- call define_adios_global_integer_1d_array(adios_group, "idoubling", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "ispec_is_tiso", &
- local_dim, group_size_inc)
- local_dim = NGLLX * NGLLY * NGLLZ * nspec_actually
- call define_adios_global_real_1d_array(adios_group, "xixstore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "xiystore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "xizstore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "etaxstore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "etaystore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "etazstore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "gammaxstore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "gammaystore", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "gammazstore", &
- local_dim, group_size_inc)
-
- local_dim = NGLLX * NGLLY * NGLLZ * nspec_ani
- if(iregion_code /= IREGION_OUTER_CORE) then
- ! save anisotropy in the inner core only
- if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
- call define_adios_global_real_1d_array(adios_group, "c11store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c33store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c12store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c13store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c44store", &
- local_dim, group_size_inc)
- endif
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
- call define_adios_global_real_1d_array(adios_group, "c11store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c12store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c13store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c14store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c15store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c16store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c22store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c23store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c24store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c25store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c26store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c33store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c34store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c35store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c36store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c44store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c45store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c46store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c55store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c56store", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "c66store", &
- local_dim, group_size_inc)
- endif
- endif
-
- local_dim = NGLLX * NGLLY * NGLLZ * nspec_stacey
- if(ABSORBING_CONDITIONS) then
- if(iregion_code == IREGION_CRUST_MANTLE) then
- call define_adios_global_real_1d_array(adios_group, "rho_vp", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "rho_vs", &
- local_dim, group_size_inc)
- else if(iregion_code == IREGION_OUTER_CORE) then
- call define_adios_global_real_1d_array(adios_group, "rho_vp", &
- local_dim, group_size_inc)
- endif
- endif
-
- local_dim = nglob_xy
- if(NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. &
- iregion_code == IREGION_CRUST_MANTLE) then
- call define_adios_global_real_1d_array(adios_group, "rmassx", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "rmassy", &
- local_dim, group_size_inc)
- endif
- local_dim = nglob
- call define_adios_global_real_1d_array(adios_group, "rmassz", &
- local_dim, group_size_inc)
-
- local_dim = nglob_oceans
- if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
- call define_adios_global_real_1d_array(adios_group, "rmass_ocean_load", &
- local_dim, group_size_inc)
- endif
-
- !--- Open an ADIOS handler to the restart file. ---------
- call adios_open (adios_handle, group_name, &
- outputname, "w", comm, adios_err);
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, adios_err)
-
- ! mesh topology
-
- ! mesh arrays used in the solver to locate source and receivers
- ! and for anisotropy and gravity, save in single precision
- ! use tmp_array for temporary storage to perform conversion
- allocate(tmp_array_x(nglob),stat=ier)
- if( ier /=0 ) call exit_MPI(myrank,&
- 'error allocating temporary array for mesh topology')
- allocate(tmp_array_y(nglob),stat=ier)
- if( ier /=0 ) call exit_MPI(myrank,&
- 'error allocating temporary array for mesh topology')
- allocate(tmp_array_z(nglob),stat=ier)
- if( ier /=0 ) call exit_MPI(myrank,&
- 'error allocating temporary array for mesh topology')
-
- !--- x coordinate
- tmp_array_x(:) = 0._CUSTOM_REAL
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- tmp_array_x(iglob) = sngl(xstore(i,j,k,ispec))
- else
- tmp_array_x(iglob) = xstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
- !--- y coordinate
- tmp_array_y(:) = 0._CUSTOM_REAL
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- tmp_array_y(iglob) = sngl(ystore(i,j,k,ispec))
- else
- tmp_array_y(iglob) = ystore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
- !--- z coordinate
- tmp_array_z(:) = 0._CUSTOM_REAL
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- tmp_array_z(iglob) = sngl(zstore(i,j,k,ispec))
- else
- tmp_array_z(iglob) = zstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
-
- !--- Schedule writes for the previously defined ADIOS variables
- ! save nspec and nglob, to be used in combine_paraview_data
- call adios_write(adios_handle, "nspec", nspec, adios_err)
- call adios_write(adios_handle, "nglob", nglob, adios_err)
-
- local_dim = nglob
- call adios_set_path (adios_handle, "xstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", tmp_array_x, adios_err)
-
- call adios_set_path (adios_handle, "ystore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", tmp_array_y, adios_err)
-
- call adios_set_path (adios_handle, "zstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", tmp_array_z, adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * nspec
- call adios_set_path (adios_handle, "rhostore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", rhostore, adios_err)
-
- call adios_set_path (adios_handle, "kappavstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", kappavstore, adios_err)
-
- call adios_set_path (adios_handle, "ibool", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibool, adios_err)
-
- if(iregion_code /= IREGION_OUTER_CORE) then
- if(.not. (ANISOTROPIC_3D_MANTLE .and. &
- iregion_code == IREGION_CRUST_MANTLE)) then
- call adios_set_path (adios_handle, "muvstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", muvstore, adios_err)
- endif
- if(TRANSVERSE_ISOTROPY) then
- if(iregion_code == IREGION_CRUST_MANTLE .and. &
- .not. ANISOTROPIC_3D_MANTLE) then
- call adios_set_path (adios_handle, "kappahstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", kappahstore, adios_err)
-
- call adios_set_path (adios_handle, "muhstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", muhstore, adios_err)
-
- call adios_set_path (adios_handle, "eta_anisostore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", eta_anisostore, adios_err)
- endif
- endif
- endif
-
- local_dim = nspec
- call adios_set_path (adios_handle, "idoubling", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", idoubling, adios_err)
-
- call adios_set_path (adios_handle, "ispec_is_tiso", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ispec_is_tiso, adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * nspec_actually
- call adios_set_path (adios_handle, "xixstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", xixstore, adios_err)
-
- call adios_set_path (adios_handle, "xiystore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", xiystore, adios_err)
-
- call adios_set_path (adios_handle, "xizstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", xizstore, adios_err)
-
- call adios_set_path (adios_handle, "etaxstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", etaxstore, adios_err)
-
- call adios_set_path (adios_handle, "etaystore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", etaystore, adios_err)
-
- call adios_set_path (adios_handle, "etazstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", etazstore, adios_err)
-
- call adios_set_path (adios_handle, "gammaxstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", gammaxstore, adios_err)
-
- call adios_set_path (adios_handle, "gammaystore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", gammaystore, adios_err)
-
- call adios_set_path (adios_handle, "gammazstore", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", gammazstore, adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * nspec_ani
- if(iregion_code /= IREGION_OUTER_CORE) then
- ! save anisotropy in the inner core only
- if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
- call adios_set_path (adios_handle, "c11store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c11store, adios_err)
-
- call adios_set_path (adios_handle, "c33store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c33store, adios_err)
-
- call adios_set_path (adios_handle, "c12store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c12store, adios_err)
-
- call adios_set_path (adios_handle, "c13store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c13store, adios_err)
-
- call adios_set_path (adios_handle, "c44store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c44store, adios_err)
- endif
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
- call adios_set_path (adios_handle, "c11store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c11store, adios_err)
-
- call adios_set_path (adios_handle, "c12store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c12store, adios_err)
-
- call adios_set_path (adios_handle, "c13store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c13store, adios_err)
-
- call adios_set_path (adios_handle, "c14store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c14store, adios_err)
-
- call adios_set_path (adios_handle, "c15store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c15store, adios_err)
-
- call adios_set_path (adios_handle, "c16store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c16store, adios_err)
-
- call adios_set_path (adios_handle, "c22store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c22store, adios_err)
-
- call adios_set_path (adios_handle, "c23store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c23store, adios_err)
-
- call adios_set_path (adios_handle, "c24store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c24store, adios_err)
-
- call adios_set_path (adios_handle, "c25store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c25store, adios_err)
-
- call adios_set_path (adios_handle, "c26store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c26store, adios_err)
-
- call adios_set_path (adios_handle, "c33store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c33store, adios_err)
-
- call adios_set_path (adios_handle, "c34store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c34store, adios_err)
-
- call adios_set_path (adios_handle, "c35store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c35store, adios_err)
-
- call adios_set_path (adios_handle, "c36store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c36store, adios_err)
-
- call adios_set_path (adios_handle, "c44store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c44store, adios_err)
-
- call adios_set_path (adios_handle, "c45store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c45store, adios_err)
-
- call adios_set_path (adios_handle, "c46store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c46store, adios_err)
-
- call adios_set_path (adios_handle, "c55store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c55store, adios_err)
-
- call adios_set_path (adios_handle, "c56store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c56store, adios_err)
-
- call adios_set_path (adios_handle, "c66store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", c66store, adios_err)
- endif
- endif
-
- local_dim = NGLLX * NGLLY * NGLLZ * nspec_stacey
- if(ABSORBING_CONDITIONS) then
- if(iregion_code == IREGION_CRUST_MANTLE) then
- call adios_set_path (adios_handle, "rho_vp", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", rho_vp, adios_err)
-
- call adios_set_path (adios_handle, "rho_vs", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", rho_vs, adios_err)
-
- else if(iregion_code == IREGION_OUTER_CORE) then
- call adios_set_path (adios_handle, "rho_vp", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", rho_vp, adios_err)
- endif
- endif
-
- local_dim = nglob_xy
- if(NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. &
- iregion_code == IREGION_CRUST_MANTLE) then
- call adios_set_path (adios_handle, "rmassx", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", rmassx, adios_err)
-
- call adios_set_path (adios_handle, "rmassy", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", rmassy, adios_err)
- endif
-
- local_dim = nglob
- call adios_set_path (adios_handle, "rmassz", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", rmassz, adios_err)
-
- local_dim = nglob_oceans
- if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
- call adios_set_path (adios_handle, "rmass_ocean_load", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", rmass_ocean_load, adios_err)
- if(minval(rmass_ocean_load) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the oceans')
- endif
-
- !--- Reset the path to zero and perform the actual write to disk
- call adios_set_path (adios_handle, "", adios_err)
- call adios_close(adios_handle, adios_err)
-
- ! Clean the temporary arrays containing the node information
- deallocate(tmp_array_x)
- deallocate(tmp_array_y)
- deallocate(tmp_array_z)
-
- !---------------------------------------------------------
- !--- Boundary arrays -------------------------------------
- !---------------------------------------------------------
-
- ! Postpend the actual file name.
- outputname = trim(reg_name) // "boundary.bp"
-
- ! save boundary arrays in ADIOS files
- write(group_name,"('SPECFEM3D_GLOBE_BOUNDARY_reg',i1)") iregion_code
- ! set the adios group size to 0 before incremented by calls to
- ! helpers functions.
- group_size_inc = 0
- call adios_declare_group(adios_group, group_name, &
- "", 0, adios_err)
- call adios_select_method(adios_group, "MPI", "", "", adios_err)
-
- !--- Define ADIOS variables -----------------------------
- call define_adios_integer_scalar (adios_group, "nspec2D_xmin", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "nspec2D_xmax", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "nspec2D_ymin", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "nspec2D_ymax", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "NSPEC2D_BOTTOM", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "NSPEC2D_TOP", "", &
- group_size_inc)
-
- !local_dim = NSPEC2DMAX_XMIN_YMAX
- local_dim = size (ibelm_xmin)
- call define_adios_global_integer_1d_array(adios_group, "ibelm_xmin", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "ibelm_xmax", &
- local_dim, group_size_inc)
-
- !local_dim = NSPEC2DMAX_YMIN_YMAX
- local_dim = size (ibelm_ymin)
- call define_adios_global_integer_1d_array(adios_group, "ibelm_ymin", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "ibelm_ymax", &
- local_dim, group_size_inc)
-
- !local_dim = NSPEC2D_BOTTOM
- local_dim = size (ibelm_bottom)
- call define_adios_global_integer_1d_array(adios_group, "ibelm_bottom", &
- local_dim, group_size_inc)
-
- !local_dim = NSPEC2D_TOP
- local_dim = size (ibelm_top)
- call define_adios_global_integer_1d_array(adios_group, "ibelm_top", &
- local_dim, group_size_inc)
-
- !local_dim = NDIM*NGLLY*NGLLZ*NSPEC2DMAX_XMIN_XMAX
- local_dim = size (normal_xmin)
- call define_adios_global_real_1d_array(adios_group, "normal_xmin", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "normal_xmax", &
- local_dim, group_size_inc)
-
- !local_dim = NDIM*NGLLX*NGLLZ*NSPEC2DMAX_YMIN_YMAX
- local_dim = size (normal_ymin)
- call define_adios_global_real_1d_array(adios_group, "normal_ymin", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "normal_ymax", &
- local_dim, group_size_inc)
-
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_BOTTOM
- local_dim = size (normal_bottom)
- call define_adios_global_real_1d_array(adios_group, "normal_bottom", &
- local_dim, group_size_inc)
-
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_TOP
- local_dim = size (normal_top)
- call define_adios_global_real_1d_array(adios_group, "normal_top", &
- local_dim, group_size_inc)
-
- !local_dim = NGLLY*NGLLZ*NSPEC2DMAX_XMIN_XMAX
- local_dim = size (jacobian2D_xmin)
- call define_adios_global_real_1d_array(adios_group, "jacobian2D_xmin", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "jacobian2D_xmax", &
- local_dim, group_size_inc)
- !local_dim = NDIM*NGLLX*NGLLZ*NSPEC2DMAX_YMIN_YMAX
- local_dim = size (jacobian2D_ymin)
- call define_adios_global_real_1d_array(adios_group, "jacobian2D_ymin", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "jacobian2D_ymax", &
- local_dim, group_size_inc)
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_BOTTOM
- local_dim = size (jacobian2D_bottom)
- call define_adios_global_real_1d_array(adios_group, "jacobian2D_bottom", &
- local_dim, group_size_inc)
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_TOP
- local_dim = size (jacobian2D_top)
- call define_adios_global_real_1d_array(adios_group, "jacobian2D_top", &
- local_dim, group_size_inc)
-
- !--- Open an ADIOS handler to the restart file. ---------
- call adios_open (adios_handle, group_name, &
- outputname, "w", comm, adios_err);
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, adios_err)
-
- !--- Schedule writes for the previously defined ADIOS variables
- call adios_write(adios_handle, "nspec2D_xmin", nspec2D_xmin, adios_err)
- call adios_write(adios_handle, "nspec2D_xmax", nspec2D_xmax, adios_err)
- call adios_write(adios_handle, "nspec2D_ymin", nspec2D_ymin, adios_err)
- call adios_write(adios_handle, "nspec2D_ymax", nspec2D_ymax, adios_err)
- call adios_write(adios_handle, "NSPEC2D_BOTTOM", NSPEC2D_BOTTOM, adios_err)
- call adios_write(adios_handle, "NSPEC2D_TOP", NSPEC2D_TOP, adios_err)
-
- !local_dim = NSPEC2DMAX_XMIN_XMAX
- local_dim = size (ibelm_xmin)
- call adios_set_path (adios_handle, "ibelm_xmin", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_xmin, adios_err)
- call adios_set_path (adios_handle, "ibelm_xmax", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_xmax, adios_err)
-
- !local_dim = NSPEC2DMAX_YMIN_YMAX
- local_dim = size (ibelm_ymin)
- call adios_set_path (adios_handle, "ibelm_ymin", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_ymin, adios_err)
- call adios_set_path (adios_handle, "ibelm_ymax", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_ymax, adios_err)
-
- !local_dim = NSPEC2D_BOTTOM
- local_dim = size (ibelm_bottom)
- call adios_set_path (adios_handle, "ibelm_bottom", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_bottom, adios_err)
-
- !local_dim = NSPEC2D_TOP
- local_dim = size (ibelm_top)
- call adios_set_path (adios_handle, "ibelm_top", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_top, adios_err)
-
- !local_dim = NDIM*NGLLY*NGLLZ*NSPEC2DMAX_XMIN_XMAX
- local_dim = size (normal_xmin)
- call adios_set_path (adios_handle, "normal_xmin", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", normal_xmin, adios_err)
- call adios_set_path (adios_handle, "normal_xmax", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", normal_xmax, adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLZ*NSPEC2DMAX_YMIN_YMAX
- local_dim = size (normal_ymin)
- call adios_set_path (adios_handle, "normal_ymin", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", normal_ymin, adios_err)
- call adios_set_path (adios_handle, "normal_ymax", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", normal_ymax, adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_BOTTOM
- local_dim = size (normal_bottom)
- call adios_set_path (adios_handle, "normal_bottom", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", normal_bottom, adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_TOP
- local_dim = size (normal_top)
- call adios_set_path (adios_handle, "normal_top", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", normal_top, adios_err)
-
- !local_dim = NGLLY*NGLLZ*NSPEC2DMAX_XMIN_XMAX
- local_dim = size (jacobian2D_xmin)
- call adios_set_path (adios_handle, "jacobian2D_xmin", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", jacobian2D_xmin, adios_err)
- call adios_set_path (adios_handle, "jacobian2D_xmax", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", jacobian2D_xmax, adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLZ*NSPEC2DMAX_YMIN_YMAX
- local_dim = size (jacobian2D_ymin)
- call adios_set_path (adios_handle, "jacobian2D_ymin", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", jacobian2D_ymin, adios_err)
- call adios_set_path (adios_handle, "jacobian2D_ymax", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", jacobian2D_ymax, adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_BOTTOM
- local_dim = size (jacobian2D_bottom)
- call adios_set_path (adios_handle, "jacobian2D_bottom", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", jacobian2D_bottom, adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_TOP
- local_dim = size (jacobian2D_top)
- call adios_set_path (adios_handle, "jacobian2D_top", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", jacobian2D_top, adios_err)
-
- !--- Reset the path to zero and perform the actual write to disk
- call adios_set_path (adios_handle, "", adios_err)
- call adios_close(adios_handle, adios_err)
-
- !---------------------------------------------------------
- !--- Attenuation arrays ----------------------------------
- !---------------------------------------------------------
- if(ATTENUATION) then
- outputname = trim(reg_name) // "attenuation.bp"
- write(group_name,"('SPECFEM3D_GLOBE_ATTENUATION_reg',i1)") iregion_code
- group_size_inc = 0
- call adios_declare_group(adios_group, group_name, &
- "", 0, adios_err)
- call adios_select_method(adios_group, "MPI", "", "", adios_err)
-
- !--- Define ADIOS variables -----------------------------
- call define_adios_double_scalar(adios_group, "T_c_source", "", &
- group_size_inc)
-
- local_dim = size(tau_s)
- call define_adios_global_double_1d_array(adios_group, "tau_s", &
- local_dim, group_size_inc)
- local_dim = size(tau_e_store)
- call define_adios_global_double_1d_array(adios_group, "tau_e_store", &
- local_dim, group_size_inc)
- local_dim = size(Qmu_store)
- call define_adios_global_double_1d_array(adios_group, "Qmu_store", &
- local_dim, group_size_inc)
-
- !--- Open an ADIOS handler to the restart file. ---------
- call adios_open (adios_handle, group_name, &
- outputname, "w", comm, adios_err);
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, adios_err)
-
- !--- Schedule writes for the previously defined ADIOS variables
- call adios_write(adios_handle, "T_c_source", T_c_source, adios_err)
-
- local_dim = size (tau_s)
- call adios_set_path (adios_handle, "tau_s", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", tau_s, adios_err)
- local_dim = size (tau_e_store)
- call adios_set_path (adios_handle, "tau_e_store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", tau_e_store, adios_err)
- local_dim = size (Qmu_store)
- call adios_set_path (adios_handle, "Qmu_store", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", Qmu_store, adios_err)
-
- !--- Reset the path to zero and perform the actual write to disk
- call adios_set_path (adios_handle, "", adios_err)
- call adios_close(adios_handle, adios_err)
- endif
-
- !---------------------------------------------------------
- !--- dvp arrays ------------------------------------------
- !---------------------------------------------------------
- if(HETEROGEN_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
- outputname = trim(reg_name) // "dvp.bp"
- write(group_name,"('SPECFEM3D_GLOBE_DVP_reg',i1)") iregion_code
- group_size_inc = 0
- call adios_declare_group(adios_group, group_name, &
- "", 0, adios_err)
- call adios_select_method(adios_group, "MPI", "", "", adios_err)
-
- !--- Define ADIOS variables -----------------------------
- local_dim = size (dvpstore)
- call define_adios_global_real_1d_array(adios_group, "dvp", &
- local_dim, group_size_inc)
- !--- Open an ADIOS handler to the restart file. ---------
- call adios_open (adios_handle, group_name, &
- outputname, "w", comm, adios_err);
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, adios_err)
- call adios_set_path (adios_handle, "dvp", adios_err)
- !--- Schedule writes for the previously defined ADIOS variables
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", dvpstore, adios_err)
-
- !--- Reset the path to zero and perform the actual write to disk
- call adios_set_path (adios_handle, "", adios_err)
- call adios_close(adios_handle, adios_err)
- endif
-
- !---------------------------------------------------------
- !--- mehsfiles arrays ------------------------------------
- !---------------------------------------------------------
- ! uncomment for vp & vs model storage
- if( SAVE_MESH_FILES ) then
- ! outputs model files in binary format
- if (ADIOS_FOR_SOLVER_MESHFILES) then
- call save_arrays_solver_meshfiles_adios(myrank,iregion_code, &
- reg_name, nspec)
- else
- call save_arrays_solver_meshfiles(myrank,nspec)
- endif
- endif
-
-end subroutine save_arrays_solver_adios
-
-
-!===============================================================================
-!> \brief Save the meshfiles that will be used by the solver in an ADIOS format.
-!!
-!! \param myrank The MPI rank of the current process.
-!! \param iregion_code Code of the region considered. See constant.h for details
-!! \param reg_name Output file prefix with the name of the region included
-!! \param nspec Number of GLL points per spectral elements
-subroutine save_arrays_solver_meshfiles_adios(myrank, iregion_code, &
- reg_name, nspec)
-
- ! outputs model files in binary format
- use mpi
- use adios_write_mod
- use constants
-
- use meshfem3D_models_par,only: &
- TRANSVERSE_ISOTROPY,ATTENUATION
-
- use create_regions_mesh_par2,only: &
- rhostore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- Qmu_store, &
- prname
-
- implicit none
-
- integer :: myrank, nspec, iregion_code
- character(len=150) :: reg_name
-
- ! local parameters
- integer :: i,j,k,ispec,ier
- real(kind=CUSTOM_REAL) :: scaleval1,scaleval2
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable :: temp_store
-
- ! local parameters
- character(len=150) :: outputname, group_name
- integer :: ierr, sizeprocs, comm, local_dim
- integer(kind=8) :: group_size_inc
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid
- integer(kind=8) :: adios_groupsize, adios_totalsize
-
- ! scaling factors to re-dimensionalize units
- scaleval1 = sngl( sqrt(PI*GRAV*RHOAV)*(R_EARTH/1000.0d0) )
- scaleval2 = sngl( RHOAV/1000.0d0 )
-
- call world_size(sizeprocs) ! TODO keep it in parameters
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- ! isotropic model
- outputname = trim(reg_name) // "solver_meshfiles.bp"
- write(group_name,"('SPECFEM3D_GLOBE_solver_meshfiles_reg',i1)") iregion_code
-
- group_size_inc = 0
-
- call adios_declare_group(adios_group, group_name, &
- "", 0, adios_err)
- call adios_select_method(adios_group, "MPI", "", "", adios_err)
-
- !--- Define ADIOS variables -----------------------------
- !--- vp arrays -------------------------------------------
- local_dim = size (kappavstore)
- call define_adios_global_real_1d_array(adios_group, "vp", &
- local_dim, group_size_inc)
- !--- vs arrays -------------------------------------------
- local_dim = size (rhostore)
- call define_adios_global_real_1d_array(adios_group, "vs", &
- local_dim, group_size_inc)
- !--- rho arrays ------------------------------------------
- local_dim = size (rhostore)
- call define_adios_global_real_1d_array(adios_group, "rho", &
- local_dim, group_size_inc)
- ! transverse isotropic model
- if( TRANSVERSE_ISOTROPY ) then
- !--- vpv arrays ----------------------------------------
- local_dim = size (kappavstore)
- call define_adios_global_real_1d_array(adios_group, "vpv", &
- local_dim, group_size_inc)
- !--- vph arrays ----------------------------------------
- local_dim = size (kappavstore)
- call define_adios_global_real_1d_array(adios_group, "vph", &
- local_dim, group_size_inc)
- !--- vsv arrays ----------------------------------------
- local_dim = size (rhostore)
- call define_adios_global_real_1d_array(adios_group, "vsv", &
- local_dim, group_size_inc)
- !--- vsh arrays ----------------------------------------
- local_dim = size (rhostore)
- call define_adios_global_real_1d_array(adios_group, "vsh", &
- local_dim, group_size_inc)
- !--- eta arrays ----------------------------------------
- local_dim = size (eta_anisostore)
- call define_adios_global_real_1d_array(adios_group, "eta", &
- local_dim, group_size_inc)
- endif
- if( ATTENUATION ) then
- !--- Qmu arrays ----------------------------------------
- local_dim = NGLLX * NGLLY * NGLLZ * nspec
- call define_adios_global_real_1d_array(adios_group, "qmu", &
- local_dim, group_size_inc)
- endif
-
- !--- Open an ADIOS handler to the restart file. ---------
- call adios_open (adios_handle, group_name, &
- outputname, "w", comm, adios_err);
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, adios_err)
-
- !--- Schedule writes for the previously defined ADIOS variables
- !--- vp arrays -------------------------------------------
- local_dim = size (kappavstore)
- call adios_set_path (adios_handle, "vp", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- sqrt( (kappavstore+4.*muvstore/3.)/rhostore )*scaleval1, &
- adios_err)
- !--- vs arrays -------------------------------------------
- local_dim = size (rhostore)
- call adios_set_path (adios_handle, "vs", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- sqrt( muvstore/rhostore )*scaleval1, &
- adios_err)
- !--- rho arrays ------------------------------------------
- local_dim = size (rhostore)
- call adios_set_path (adios_handle, "rho", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- rhostore *scaleval2, &
- adios_err)
-
- ! transverse isotropic model
- if( TRANSVERSE_ISOTROPY ) then
- !--- vpv arrays ----------------------------------------
- local_dim = size (kappavstore)
- call adios_set_path (adios_handle, "vpv", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- sqrt( (kappavstore+4.*muvstore/3.)/rhostore )*scaleval1, &
- adios_err)
- !--- vph arrays ----------------------------------------
- local_dim = size (kappavstore)
- call adios_set_path (adios_handle, "vph", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- sqrt( (kappahstore+4.*muhstore/3.)/rhostore )*scaleval1, &
- adios_err)
- !--- vsv arrays ----------------------------------------
- local_dim = size (rhostore)
- call adios_set_path (adios_handle, "vsv", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- sqrt( muvstore/rhostore )*scaleval1, &
- adios_err)
- !--- vsh arrays ----------------------------------------
- local_dim = size (rhostore)
- call adios_set_path (adios_handle, "vsh", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- sqrt( muhstore/rhostore )*scaleval1, &
- adios_err)
- !--- eta arrays ----------------------------------------
- local_dim = size (eta_anisostore)
- call adios_set_path (adios_handle, "eta", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- eta_anisostore, &
- adios_err)
- endif ! TRANSVERSE_ISOTROPY
-
- ! shear attenuation
- if( ATTENUATION ) then
- !-------------------------------------------------------
- !--- Qmu arrays ----------------------------------------
- !-------------------------------------------------------
- ! saves Qmu_store to full custom_real array
- ! uses temporary array
- allocate(temp_store(NGLLX,NGLLY,NGLLZ,nspec))
- if (USE_3D_ATTENUATION_ARRAYS) then
- ! attenuation arrays are fully 3D
- if(CUSTOM_REAL == SIZE_REAL) then
- temp_store(:,:,:,:) = sngl(Qmu_store(:,:,:,:))
- else
- temp_store(:,:,:,:) = Qmu_store(:,:,:,:)
- endif
- else
- ! attenuation array dimensions: Q_mustore(1,1,1,nspec)
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- temp_store(i,j,k,ispec) = sngl(Qmu_store(1,1,1,ispec))
- else
- temp_store(i,j,k,ispec) = Qmu_store(1,1,1,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
- endif
-
- local_dim = NGLLX * NGLLY * NGLLZ * nspec
- call adios_set_path (adios_handle, "qmu", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- temp_store, &
- adios_err)
-
- ! frees temporary memory
- deallocate(temp_store)
- endif ! ATTENUATION
-
- !--- Reset the path to zero and perform the actual write to disk
- call adios_set_path (adios_handle, "", adios_err)
- call adios_close(adios_handle, adios_err)
-
-end subroutine save_arrays_solver_meshfiles_adios
-
-
-!===============================================================================
-!> \brief Save the arrays use by the solver for MPI communications.
-!!
-!! \param myrank The MPI rank of the current process.
-!! \param iregion_code Code of the region considered. See constant.h for details
-!! \param LOCAL_PATH The full path to the output directory
-!! \param num_interfaces The number of interfaces between processors
-!! \param max_nibool_interfaces
-!! \param my_neighbours
-!! \param nibool_interfaces
-!! \param ibool_interfaces
-!! \param nspec_inner Number of spectral elements in the inner core
-!! \param nspec_outer Number of spectral elemetns in the outer core
-!! \param num_phase_ispec
-!! \param phase_ispec_inner
-!! \param num_colors_inner Number of colors for GPU computing in the inner core.
-!! \param num_colors_outer Number of colors for GPU computing in the outer core.
-subroutine save_MPI_arrays_adios(myrank,iregion_code,LOCAL_PATH, &
- num_interfaces,max_nibool_interfaces, my_neighbours,nibool_interfaces, &
- ibool_interfaces, nspec_inner,nspec_outer, num_phase_ispec, &
- phase_ispec_inner, num_colors_outer,num_colors_inner, num_elem_colors)
-
- use mpi
- use adios_write_mod
- implicit none
-
- include "constants.h"
-
- integer :: iregion_code,myrank
- character(len=150) :: LOCAL_PATH
- ! MPI interfaces
- integer :: num_interfaces,max_nibool_interfaces
- integer, dimension(num_interfaces) :: my_neighbours
- integer, dimension(num_interfaces) :: nibool_interfaces
- integer, dimension(max_nibool_interfaces,num_interfaces) :: &
- ibool_interfaces
- ! inner/outer elements
- integer :: nspec_inner,nspec_outer
- integer :: num_phase_ispec
- integer,dimension(num_phase_ispec,2) :: phase_ispec_inner
- ! mesh coloring
- integer :: num_colors_outer,num_colors_inner
- integer, dimension(num_colors_outer + num_colors_inner) :: &
- num_elem_colors
-
- ! local parameters
- character(len=150) :: prname, outputname, group_name
- integer :: ierr, sizeprocs, comm, local_dim
- integer(kind=8) :: group_size_inc
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid
- integer(kind=8) :: adios_groupsize, adios_totalsize
-
- ! create the name for the database of the current slide and region
- call create_name_database_adios(prname,iregion_code,LOCAL_PATH)
-
- outputname = trim(prname) // "solver_data_mpi.bp"
- write(group_name,"('SPECFEM3D_GLOBE_MPI_ARRAYS_reg',i1)") iregion_code
- call world_size(sizeprocs) ! TODO keep it in parameters
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
- group_size_inc = 0
- call adios_declare_group(adios_group, group_name, &
- "", 0, adios_err)
- call adios_select_method(adios_group, "MPI", "", "", adios_err)
-
- !--- Define ADIOS variables -----------------------------
- !! MPI interfaces
- call define_adios_integer_scalar (adios_group, "num_interfaces", "", &
- group_size_inc)
- if( num_interfaces > 0 ) then
- call define_adios_integer_scalar(adios_group, "max_nibool_interfaces", &
- "", group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "my_neighbours", &
- num_interfaces, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "nibool_interfaces",&
- num_interfaces, group_size_inc)
- local_dim = max_nibool_interfaces*num_interfaces
- call define_adios_global_integer_1d_array(adios_group, "ibool_interfaces", &
- local_dim, group_size_inc)
- endif
-
- ! inner/outer elements
- call define_adios_integer_scalar (adios_group, "nspec_inner", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "nspec_outer", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "num_phase_ispec", "", &
- group_size_inc)
- if(num_phase_ispec > 0 ) then
- local_dim = num_phase_ispec * 2
- call define_adios_global_integer_1d_array(adios_group, "phase_ispec_inner", &
- local_dim, group_size_inc)
- endif
-
- ! mesh coloring
- if( USE_MESH_COLORING_GPU ) then
- call define_adios_integer_scalar (adios_group, "num_colors_outer", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "num_colors_inner", "", &
- group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "num_elem_colors", &
- num_colors_outer + num_colors_inner, group_size_inc)
- endif
-
- !--- Open an ADIOS handler to the restart file. ---------
- call adios_open (adios_handle, group_name, &
- outputname, "w", comm, adios_err);
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, adios_err)
-
- !--- Schedule writes for the previously defined ADIOS variables
- ! MPI interfaces
- call adios_write(adios_handle, "num_interfaces", num_interfaces, adios_err)
- if( num_interfaces > 0 ) then
- call adios_write(adios_handle, "max_nibool_interfaces", &
- max_nibool_interfaces, adios_err)
-
- local_dim = num_interfaces
-
- call adios_set_path (adios_handle, "my_neighbours", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", my_neighbours, adios_err)
-
- call adios_set_path (adios_handle, "nibool_interfaces", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", nibool_interfaces, adios_err)
-
- local_dim = max_nibool_interfaces * num_interfaces
-
- call adios_set_path (adios_handle, "ibool_interfaces", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- ibool_interfaces, adios_err)
- call adios_set_path (adios_handle, "", adios_err)
- endif
-
- ! inner/outer elements
- call adios_write(adios_handle, "nspec_inner", nspec_inner, adios_err)
- call adios_write(adios_handle, "nspec_outer", nspec_outer, adios_err)
- call adios_write(adios_handle, "num_phase_ispec", num_phase_ispec, adios_err)
-
- if(num_phase_ispec > 0 ) then
- local_dim = num_phase_ispec * 2
- call adios_set_path (adios_handle, "phase_ispec_inner", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- phase_ispec_inner, adios_err)
- call adios_set_path (adios_handle, "", adios_err)
- endif
-
- ! mesh coloring
- if( USE_MESH_COLORING_GPU ) then
- call adios_write(adios_handle, "num_colors_outer", nspec_inner, adios_err)
- call adios_write(adios_handle, "num_colors_inner", nspec_inner, adios_err)
- local_dim = num_colors_outer + num_colors_inner
- call adios_set_path (adios_handle, "num_elem_colors", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", &
- num_elem_colors, adios_err)
- call adios_set_path (adios_handle, "", adios_err)
- endif
-
- !--- Reset the path to zero and perform the actual write to disk
- call adios_close(adios_handle, adios_err)
-
-end subroutine save_MPI_arrays_adios
-
-
-!===============================================================================
-!> \brief Write boundary conditions (MOHO, 400, 600) to a single ADIOS file.
-subroutine save_arrays_solver_boundary_adios()
-
-! saves arrays for boundaries such as MOHO, 400 and 670 discontinuities
- use mpi
-
- use meshfem3d_par,only: &
- myrank, LOCAL_PATH
-
- use meshfem3D_models_par,only: &
- HONOR_1D_SPHERICAL_MOHO
- !SAVE_BOUNDARY_MESH,HONOR_1D_SPHERICAL_MOHO,SUPPRESS_CRUSTAL_MESH
-
- use create_regions_mesh_par2, only: &
- NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670, &
- ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
- ibelm_670_top,ibelm_670_bot,normal_moho,normal_400,normal_670, &
- ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot, &
- ispec2D_670_top,ispec2D_670_bot, &
- prname
-
- implicit none
- include "constants.h"
-
- ! local parameters
- ! local parameters
- character(len=150) :: outputname, group_name
- integer :: ierr, sizeprocs, comm, local_dim
- integer(kind=8) :: group_size_inc
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid
- integer(kind=8) :: adios_groupsize, adios_totalsize
-
- ! first check the number of surface elements are the same for Moho, 400, 670
- if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
- if (ispec2D_moho_top /= NSPEC2D_MOHO .or. ispec2D_moho_bot /= NSPEC2D_MOHO) &
- call exit_mpi(myrank, 'Not the same number of Moho surface elements')
- endif
- if (ispec2D_400_top /= NSPEC2D_400 .or. ispec2D_400_bot /= NSPEC2D_400) &
- call exit_mpi(myrank,'Not the same number of 400 surface elements')
- if (ispec2D_670_top /= NSPEC2D_670 .or. ispec2D_670_bot /= NSPEC2D_670) &
- call exit_mpi(myrank,'Not the same number of 670 surface elements')
-
- outputname = trim(LOCAL_PATH) // "/boundary_disc.bp"
- group_name = "SPECFEM3D_GLOBE_BOUNDARY_DISC"
- call world_size(sizeprocs) ! TODO keep it in parameters
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
- group_size_inc = 0
- call adios_declare_group(adios_group, group_name, &
- "", 0, adios_err)
- call adios_select_method(adios_group, "MPI", "", "", adios_err)
-
- !--- Define ADIOS variables -----------------------------
- call define_adios_integer_scalar (adios_group, "NSPEC2D_MOHO", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "NSPEC2D_400", "", &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "NSPEC2D_670", "", &
- group_size_inc)
-
- local_dim = NSPEC2D_MOHO
- call define_adios_global_integer_1d_array(adios_group, "ibelm_moho_top", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "ibelm_moho_bot", &
- local_dim, group_size_inc)
- local_dim = NSPEC2D_400
- call define_adios_global_integer_1d_array(adios_group, "ibelm_400_top", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "ibelm_400_bot", &
- local_dim, group_size_inc)
- local_dim = NSPEC2D_670
- call define_adios_global_integer_1d_array(adios_group, "ibelm_670_top", &
- local_dim, group_size_inc)
- call define_adios_global_integer_1d_array(adios_group, "ibelm_670_bot", &
- local_dim, group_size_inc)
- local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_MOHO
- call define_adios_global_real_1d_array(adios_group, "normal_moho", &
- local_dim, group_size_inc)
- local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_400
- call define_adios_global_real_1d_array(adios_group, "normal_400", &
- local_dim, group_size_inc)
- local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_670
- call define_adios_global_real_1d_array(adios_group, "normal_670", &
- local_dim, group_size_inc)
-
- !--- Open an ADIOS handler to the restart file. ---------
- call adios_open (adios_handle, group_name, &
- outputname, "w", comm, adios_err);
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, adios_err)
-
- !--- Schedule writes for the previously defined ADIOS variables
- call adios_write(adios_handle, "NSPEC2D_MOHO", NSPEC2D_MOHO, adios_err)
- call adios_write(adios_handle, "NSPEC2D_400", NSPEC2D_400, adios_err)
- call adios_write(adios_handle, "NSPEC2D_670", NSPEC2D_670, adios_err)
-
- local_dim = NSPEC2D_MOHO
- call adios_set_path (adios_handle, "ibelm_moho_top", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_moho_top, adios_err)
- call adios_set_path (adios_handle, "ibelm_moho_bot", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_moho_bot, adios_err)
-
- local_dim = NSPEC2D_400
- call adios_set_path (adios_handle, "ibelm_400_top", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_400_top, adios_err)
- call adios_set_path (adios_handle, "ibelm_400_bot", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_400_bot, adios_err)
-
- local_dim = NSPEC2D_670
- call adios_set_path (adios_handle, "ibelm_670_top", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_670_top, adios_err)
- call adios_set_path (adios_handle, "ibelm_670_bot", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", ibelm_670_bot, adios_err)
-
- local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_MOHO
- call adios_set_path (adios_handle, "normal_moho", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", normal_moho, adios_err)
-
- local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_400
- call adios_set_path (adios_handle, "normal_400", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", normal_400, adios_err)
-
- local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_670
- call adios_set_path (adios_handle, "normal_670", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", normal_670, adios_err)
-
- !--- Reset the path to zero and perform the actual write to disk
- call adios_set_path (adios_handle, "", adios_err)
- call adios_close(adios_handle, adios_err)
-end subroutine save_arrays_solver_boundary_adios
-
-!-------------------------------------------------------------------------------
-!> Write local, global and offset dimensions to ADIOS
-!! \param adios_handle Handle to the adios file
-!! \param local_dim Number of elements to be written by one process
-!! \param sizeprocs Number of MPI processes
-subroutine write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- use adios_write_mod
-
- implicit none
-
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: sizeprocs, local_dim, myrank
-
- integer :: adios_err
-
- call adios_write(adios_handle, "local_dim", local_dim, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_write(adios_handle, "global_dim", local_dim*sizeprocs, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_write(adios_handle, "offset", local_dim*myrank, adios_err)
- call check_adios_err(myrank,adios_err)
-end subroutine write_1D_global_array_adios_dims
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_chunks_data_adios.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_chunks_data_adios.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_chunks_data_adios.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,1145 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! create AVS or DX 2D data for the faces of the global chunks,
-! to be recombined in postprocessing
-
-module AVS_DX_global_chunks_mod
-
- implicit none
-
- type avs_dx_global_chunks_t
- integer(kind=4) :: npoin, nspecface
- real(kind=4), dimension(:), allocatable :: x_adios, y_adios, z_adios
- integer(kind=4), dimension(:), allocatable :: idoubling, iglob1, iglob2, &
- iglob3, iglob4
- real, dimension(:), allocatable :: vmin, vmax
- real, dimension(:), allocatable :: dvp, dvs
- endtype
-
-contains
-
-
-subroutine define_AVS_DX_global_chunks_data(adios_group, &
- myrank,prname,nspec,iboun,ibool, &
- idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- group_size_inc, avs_dx_adios)
- use mpi
- use adios_write_mod
-
- implicit none
-
- include "constants.h"
-
- integer(kind=8), intent(in) :: adios_group
- integer(kind=8), intent(inout) :: group_size_inc
-
- integer :: myrank
-
- ! processor identification
- character(len=150) :: prname
-
- integer :: nspec
-
- logical iboun(6,nspec)
-
- integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer idoubling(nspec)
-
- double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
-
- integer :: npointot
- ! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
- ! logical mask used to output global points only once
- logical mask_ibool(npointot)
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
-
- ! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
- logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
- R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- integer iregion_code
-
- ! local parameters
- integer ispec
- integer i,j,k,np
- integer, dimension(8) :: iglobval
- integer npoin,numpoin,nspecface,ispecface
-
- real(kind=CUSTOM_REAL) vmin,vmax
-
- double precision r,rho,vp,vs,Qkappa,Qmu
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
- real(kind=CUSTOM_REAL) dvp,dvs
-
- type(avs_dx_global_chunks_t), intent(inout) :: avs_dx_adios
-
- integer :: ierr
-
- mask_ibool(:) = .false.
-
- nspecface = 0
-
- ! mark global AVS or DX points
- do ispec=1,nspec
- ! only if on face
- if(iboun(1,ispec) .or. iboun(2,ispec) .or. &
- iboun(3,ispec) .or. iboun(4,ispec)) then
- iglobval(1)=ibool(1,1,1,ispec)
- iglobval(2)=ibool(NGLLX,1,1,ispec)
- iglobval(3)=ibool(NGLLX,NGLLY,1,ispec)
- iglobval(4)=ibool(1,NGLLY,1,ispec)
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
- ! face xi = xi_min
- if(iboun(1,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(1)) = .true.
- mask_ibool(iglobval(4)) = .true.
- mask_ibool(iglobval(8)) = .true.
- mask_ibool(iglobval(5)) = .true.
- endif
-
- ! face xi = xi_max
- if(iboun(2,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(2)) = .true.
- mask_ibool(iglobval(3)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(6)) = .true.
- endif
-
- ! face eta = eta_min
- if(iboun(3,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(1)) = .true.
- mask_ibool(iglobval(2)) = .true.
- mask_ibool(iglobval(6)) = .true.
- mask_ibool(iglobval(5)) = .true.
- endif
-
- ! face eta = eta_max
- if(iboun(4,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(4)) = .true.
- mask_ibool(iglobval(3)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(8)) = .true.
- endif
-
- endif
- enddo
-
- ! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
- avs_dx_adios%npoin = npoin
- avs_dx_adios%nspecface = nspecface
-
- allocate(avs_dx_adios%x_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating x_adios.")
- allocate(avs_dx_adios%y_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating y_adios.")
- allocate(avs_dx_adios%z_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating z_adios.")
-
- allocate(avs_dx_adios%vmin(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating vmin.")
- allocate(avs_dx_adios%vmax(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating vmax.")
-
- ! Allocate temporary arrays for AVS/DX elements.
- allocate(avs_dx_adios%idoubling(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating idoubling.")
- allocate(avs_dx_adios%iglob1(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob1.")
- allocate(avs_dx_adios%iglob2(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob2.")
- allocate(avs_dx_adios%iglob3(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob3.")
- allocate(avs_dx_adios%iglob4(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob4.")
-
- !--- Variables for '...AVS_DXpointschunk.txt'
- call define_adios_global_real_1d_array(adios_group, "points_chunks/x_value", &
- npoin, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "points_chunks/y_value", &
- npoin, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "points_chunks/z_value", &
- npoin, group_size_inc)
- !--- Variables for '...AVS_DXpointschunk_stability.txt'
- call define_adios_global_real_1d_array(adios_group, &
- "points_chunks_stability/vmin", npoin, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "points_chunks_stability/vmax", npoin, group_size_inc)
- !--- Variables for AVS_DXelementschunks.txt
- call define_adios_global_real_1d_array(adios_group, &
- "elements_chunks/idoubling", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_chunks/num_ibool_AVS_DX_iglob1", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_chunks/num_ibool_AVS_DX_iglob2", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_chunks/num_ibool_AVS_DX_iglob3", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_chunks/num_ibool_AVS_DX_iglob4", nspecface, group_size_inc)
-
- !--- Variables for AVS_DXelementschunks_dvp_dvs.txt
- if(ISOTROPIC_3D_MANTLE) then
- allocate(avs_dx_adios%dvp(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating dvp.")
- allocate(avs_dx_adios%dvs(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating dvs.")
- call define_adios_global_real_1d_array(adios_group, &
- "elements_chunks/dvp", dvp, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_chunks/dvp", dvs, group_size_inc)
- endif
-
-end subroutine define_AVS_DX_global_chunks_data
-
-!===============================================================================
-subroutine prepare_AVS_DX_global_chunks_data_adios(myrank,prname,nspec, &
- iboun,ibool, idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- avs_dx_adios)
-
- implicit none
-
- include "constants.h"
-
- integer :: myrank
-
- ! processor identification
- character(len=150) :: prname
-
- integer :: nspec
-
- logical iboun(6,nspec)
-
- integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer idoubling(nspec)
-
- double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
-
- integer :: npointot
- ! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
- ! logical mask used to output global points only once
- logical mask_ibool(npointot)
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
-
- ! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
- logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
- R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- integer iregion_code
-
- ! local parameters
- integer ispec
- integer i,j,k,np
- integer, dimension(8) :: iglobval
- integer npoin,numpoin,nspecface,ispecface
-
- real(kind=CUSTOM_REAL) vmin,vmax
-
- double precision r,rho,vp,vs,Qkappa,Qmu
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
- real(kind=CUSTOM_REAL) dvp,dvs
-
- type(avs_dx_global_chunks_t), intent(inout) :: avs_dx_adios ! out for adios_write
-
-
- ! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- nspecface = 0
-
- ! mark global AVS or DX points
- do ispec=1,nspec
- ! only if on face
- if(iboun(1,ispec) .or. iboun(2,ispec) .or. &
- iboun(3,ispec) .or. iboun(4,ispec)) then
- iglobval(1)=ibool(1,1,1,ispec)
- iglobval(2)=ibool(NGLLX,1,1,ispec)
- iglobval(3)=ibool(NGLLX,NGLLY,1,ispec)
- iglobval(4)=ibool(1,NGLLY,1,ispec)
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
- ! face xi = xi_min
- if(iboun(1,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(1)) = .true.
- mask_ibool(iglobval(4)) = .true.
- mask_ibool(iglobval(8)) = .true.
- mask_ibool(iglobval(5)) = .true.
- endif
-
- ! face xi = xi_max
- if(iboun(2,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(2)) = .true.
- mask_ibool(iglobval(3)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(6)) = .true.
- endif
-
- ! face eta = eta_min
- if(iboun(3,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(1)) = .true.
- mask_ibool(iglobval(2)) = .true.
- mask_ibool(iglobval(6)) = .true.
- mask_ibool(iglobval(5)) = .true.
- endif
-
- ! face eta = eta_max
- if(iboun(4,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglobval(4)) = .true.
- mask_ibool(iglobval(3)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(8)) = .true.
- endif
-
- endif
- enddo
-
- ! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
- ! number of points in AVS or DX file
- write(10,*) npoin
-
- ! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- ! output global AVS or DX points
- numpoin = 0
- do ispec=1,nspec
- ! only if on face
- if(iboun(1,ispec) .or. iboun(2,ispec) .or. &
- iboun(3,ispec) .or. iboun(4,ispec)) then
- iglobval(1)=ibool(1,1,1,ispec)
- iglobval(2)=ibool(NGLLX,1,1,ispec)
- iglobval(3)=ibool(NGLLX,NGLLY,1,ispec)
- iglobval(4)=ibool(1,NGLLY,1,ispec)
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
- ! face xi = xi_min
- if(iboun(1,ispec)) then
-
- if(.not. mask_ibool(iglobval(1))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(1)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,1,ispec))
-
- vmax = sqrt((kappavstore(1,1,1,ispec) &
- + 4.*muvstore(1,1,1,ispec)/3.)/rhostore(1,1,1,ispec))
- vmin = sqrt(muvstore(1,1,1,ispec)/rhostore(1,1,1,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,1,1,ispec)**2 + ystore(1,1,1,ispec)**2 &
- + zstore(1,1,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(4))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(4)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,1,ispec))
-
- vmax = sqrt((kappavstore(1,NGLLY,1,ispec) &
- +4.*muvstore(1,NGLLY,1,ispec)/3.)/rhostore(1,NGLLY,1,ispec))
- vmin = sqrt(muvstore(1,NGLLY,1,ispec)/rhostore(1,NGLLY,1,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,NGLLY,1,ispec)**2 + ystore(1,NGLLY,1,ispec)**2 &
- + zstore(1,NGLLY,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(8))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(8)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,NGLLZ,ispec))
-
- vmax = sqrt((kappavstore(1,NGLLY,NGLLZ,ispec) &
- +4.*muvstore(1,NGLLY,NGLLZ,ispec)/3.) &
- / rhostore(1,NGLLY,NGLLZ,ispec))
- vmin = sqrt(muvstore(1,NGLLY,NGLLZ,ispec) &
- / rhostore(1,NGLLY,NGLLZ,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,NGLLY,NGLLZ,ispec)**2 &
- + ystore(1,NGLLY,NGLLZ,ispec)**2 &
- + zstore(1,NGLLY,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
-
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(5))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(5)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,NGLLZ,ispec))
-
- vmax = sqrt((kappavstore(1,1,NGLLZ,ispec) &
- +4.*muvstore(1,1,NGLLZ,ispec)/3.)/rhostore(1,1,NGLLZ,ispec))
- vmin = sqrt(muvstore(1,1,NGLLZ,ispec)/rhostore(1,1,NGLLZ,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,1,NGLLZ,ispec)**2 + ystore(1,1,NGLLZ,ispec)**2 &
- + zstore(1,1,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- mask_ibool(iglobval(1)) = .true.
- mask_ibool(iglobval(4)) = .true.
- mask_ibool(iglobval(8)) = .true.
- mask_ibool(iglobval(5)) = .true.
- endif
-
- ! face xi = xi_max
- if(iboun(2,ispec)) then
-
- if(.not. mask_ibool(iglobval(2))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(2)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,1,ispec))
-
- vmax = sqrt((kappavstore(NGLLX,1,1,ispec) &
- +4.*muvstore(NGLLX,1,1,ispec)/3.)/rhostore(NGLLX,1,1,ispec))
- vmin = sqrt(muvstore(NGLLX,1,1,ispec)/rhostore(NGLLX,1,1,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,1,1,ispec)**2 + ystore(NGLLX,1,1,ispec)**2 &
- + zstore(NGLLX,1,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(3))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(3)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,1,ispec))
-
- vmax = sqrt((kappavstore(NGLLX,NGLLY,1,ispec) &
- + 4.*muvstore(NGLLX,NGLLY,1,ispec)/3.) &
- / rhostore(NGLLX,NGLLY,1,ispec))
- vmin = sqrt(muvstore(NGLLX,NGLLY,1,ispec) &
- / rhostore(NGLLX,NGLLY,1,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,NGLLY,1,ispec)**2 &
- + ystore(NGLLX,NGLLY,1,ispec)**2 &
- + zstore(NGLLX,NGLLY,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(7))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(7)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
-
- vmax = sqrt((kappavstore(NGLLX,NGLLY,NGLLZ,ispec) &
- + 4.*muvstore(NGLLX,NGLLY,NGLLZ,ispec)/3.) &
- / rhostore(NGLLX,NGLLY,NGLLZ,ispec))
- vmin = sqrt(muvstore(NGLLX,NGLLY,NGLLZ,ispec) &
- / rhostore(NGLLX,NGLLY,NGLLZ,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,NGLLY,NGLLZ,ispec)**2 &
- + ystore(NGLLX,NGLLY,NGLLZ,ispec)**2 &
- + zstore(NGLLX,NGLLY,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(6))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(6)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,NGLLZ,ispec))
-
- vmax = sqrt((kappavstore(NGLLX,1,NGLLZ,ispec) &
- + 4.*muvstore(NGLLX,1,NGLLZ,ispec)/3.) &
- / rhostore(NGLLX,1,NGLLZ,ispec))
- vmin = sqrt(muvstore(NGLLX,1,NGLLZ,ispec) &
- / rhostore(NGLLX,1,NGLLZ,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,1,NGLLZ,ispec)**2 &
- + ystore(NGLLX,1,NGLLZ,ispec)**2 &
- + zstore(NGLLX,1,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- mask_ibool(iglobval(2)) = .true.
- mask_ibool(iglobval(3)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(6)) = .true.
- endif
-
- ! face eta = eta_min
- if(iboun(3,ispec)) then
-
- if(.not. mask_ibool(iglobval(1))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(1)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,1,ispec))
-
- vmax = sqrt((kappavstore(1,1,1,ispec) &
- + 4.*muvstore(1,1,1,ispec)/3.)/rhostore(1,1,1,ispec))
- vmin = sqrt(muvstore(1,1,1,ispec)/rhostore(1,1,1,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,1,1,ispec)**2 &
- + ystore(1,1,1,ispec)**2 + zstore(1,1,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(2))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(2)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,1,ispec))
-
- vmax = sqrt((kappavstore(NGLLX,1,1,ispec) &
- +4.*muvstore(NGLLX,1,1,ispec)/3.)/rhostore(NGLLX,1,1,ispec))
- vmin = sqrt(muvstore(NGLLX,1,1,ispec)/rhostore(NGLLX,1,1,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,1,1,ispec)**2 &
- + ystore(NGLLX,1,1,ispec)**2 + zstore(NGLLX,1,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin = vmin
- avs_dx_adios%vmax = vmax
- endif
-
- if(.not. mask_ibool(iglobval(6))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(6)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,NGLLZ,ispec))
-
- vmax = sqrt((kappavstore(NGLLX,1,NGLLZ,ispec) &
- + 4.*muvstore(NGLLX,1,NGLLZ,ispec)/3.) &
- / rhostore(NGLLX,1,NGLLZ,ispec))
- vmin = sqrt(muvstore(NGLLX,1,NGLLZ,ispec) &
- / rhostore(NGLLX,1,NGLLZ,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,1,NGLLZ,ispec)**2 &
- + ystore(NGLLX,1,NGLLZ,ispec)**2 &
- + zstore(NGLLX,1,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(5))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(5)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,NGLLZ,ispec))
-
- vmax = sqrt((kappavstore(1,1,NGLLZ,ispec) &
- + 4.*muvstore(1,1,NGLLZ,ispec)/3.) &
- / rhostore(1,1,NGLLZ,ispec))
- vmin = sqrt(muvstore(1,1,NGLLZ,ispec)/rhostore(1,1,NGLLZ,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,1,NGLLZ,ispec)**2 &
- + ystore(1,1,NGLLZ,ispec)**2 + zstore(1,1,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- mask_ibool(iglobval(1)) = .true.
- mask_ibool(iglobval(2)) = .true.
- mask_ibool(iglobval(6)) = .true.
- mask_ibool(iglobval(5)) = .true.
- endif
-
- ! face eta = eta_max
- if(iboun(4,ispec)) then
-
- if(.not. mask_ibool(iglobval(4))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(4)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,1,ispec))
-
- vmax = sqrt((kappavstore(1,NGLLY,1,ispec) &
- + 4.*muvstore(1,NGLLY,1,ispec)/3.)/rhostore(1,NGLLY,1,ispec))
- vmin = sqrt(muvstore(1,NGLLY,1,ispec)/rhostore(1,NGLLY,1,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,NGLLY,1,ispec)**2 &
- + ystore(1,NGLLY,1,ispec)**2 + zstore(1,NGLLY,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(3))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(3)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,1,ispec))
-
- vmax = sqrt((kappavstore(NGLLX,NGLLY,1,ispec) &
- + 4.*muvstore(NGLLX,NGLLY,1,ispec)/3.) &
- / rhostore(NGLLX,NGLLY,1,ispec))
- vmin = sqrt(muvstore(NGLLX,NGLLY,1,ispec) &
- / rhostore(NGLLX,NGLLY,1,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,NGLLY,1,ispec)**2 &
- + ystore(NGLLX,NGLLY,1,ispec)**2 &
- + zstore(NGLLX,NGLLY,1,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
-
- if(vmin == 0.0) vmin=vmax
-
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(7))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(7)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
-
- vmax = sqrt((kappavstore(NGLLX,NGLLY,NGLLZ,ispec) &
- + 4.*muvstore(NGLLX,NGLLY,NGLLZ,ispec)/3.) &
- / rhostore(NGLLX,NGLLY,NGLLZ,ispec))
- vmin = sqrt(muvstore(NGLLX,NGLLY,NGLLZ,ispec) &
- / rhostore(NGLLX,NGLLY,NGLLZ,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(NGLLX,NGLLY,NGLLZ,ispec)**2 &
- + ystore(NGLLX,NGLLY,NGLLZ,ispec)**2 &
- + zstore(NGLLX,NGLLY,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- if(.not. mask_ibool(iglobval(8))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(8)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,NGLLZ,ispec))
-
- vmax = sqrt((kappavstore(1,NGLLY,NGLLZ,ispec) &
- + 4.*muvstore(1,NGLLY,NGLLZ,ispec)/3.) &
- / rhostore(1,NGLLY,NGLLZ,ispec))
- vmin = sqrt(muvstore(1,NGLLY,NGLLZ,ispec) &
- / rhostore(1,NGLLY,NGLLZ,ispec))
- ! particular case of the outer core (muvstore contains 1/rho)
- if(idoubling(ispec) == IFLAG_OUTER_CORE_NORMAL) then
- r = dsqrt(xstore(1,NGLLY,NGLLZ,ispec)**2 &
- + ystore(1,NGLLY,NGLLZ,ispec)**2 &
- + zstore(1,NGLLY,NGLLZ,ispec)**2)
- call prem_display_outer_core(myrank,r,rho,vp,vs, &
- Qkappa,Qmu,idoubling(ispec))
- vmax = vp
- vmin = vp
- endif
- if(vmin == 0.0) vmin=vmax
-
- avs_dx_adios%vmin(numpoin) = vmin
- avs_dx_adios%vmax(numpoin) = vmax
- endif
-
- mask_ibool(iglobval(4)) = .true.
- mask_ibool(iglobval(3)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(8)) = .true.
- endif
-
- endif
- enddo
-
-! check that number of global points output is okay
- if(numpoin /= npoin) &
- call exit_MPI(myrank,&
- 'incorrect number of global points in AVS or DX file creation')
-
- ! output global AVS or DX elements
- ispecface = 0
- do ispec=1,nspec
- ! only if on face
- if(iboun(1,ispec) .or. iboun(2,ispec) .or. &
- iboun(3,ispec) .or. iboun(4,ispec)) then
- iglobval(1)=ibool(1,1,1,ispec)
- iglobval(2)=ibool(NGLLX,1,1,ispec)
- iglobval(3)=ibool(NGLLX,NGLLY,1,ispec)
- iglobval(4)=ibool(1,NGLLY,1,ispec)
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
- ! include lateral variations if needed
-
- if(ISOTROPIC_3D_MANTLE) then
- ! pick a point within the element and get its radius
- r=dsqrt(xstore(2,2,2,ispec)**2+ystore(2,2,2,ispec)**2 &
- +zstore(2,2,2,ispec)**2)
-
- if(r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then
- ! average over the element
- dvp = 0.0
- dvs = 0.0
- np =0
- do k=2,NGLLZ-1
- do j=2,NGLLY-1
- do i=2,NGLLX-1
- np=np+1
- x=xstore(i,j,k,ispec)
- y=ystore(i,j,k,ispec)
- z=zstore(i,j,k,ispec)
- r=dsqrt(x*x+y*y+z*z)
- ! take out ellipticity
- if(ELLIPTICITY) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi_dummy)
- cost=dcos(theta)
- p20=0.5d0*(3.0d0*cost*cost-1.0d0)
- call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
- factor=ONE-(TWO/3.0d0)*ell*p20
- r=r/factor
- endif
-
-
- ! get reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
- call meshfem3D_models_get1D_val(myrank,iregion_code, &
- idoubling(ispec), &
- r,rho,vpv,vph,vsv,vsh,eta_aniso, &
- Qkappa,Qmu,RICB,RCMB, &
- RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
- RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- ! calculates isotropic values
- vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
- + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
- vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
- + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
-
- if( abs(rhostore(i,j,k,ispec))< 1.e-20 ) then
- print*,' attention: rhostore close to zero', &
- rhostore(i,j,k,ispec),r,i,j,k,ispec
- dvp = 0.0
- dvs = 0.0
- else if( abs(sngl(vp))< 1.e-20 ) then
- print*,' attention: vp close to zero', &
- sngl(vp),r,i,j,k,ispec
- dvp = 0.0
- else if( abs(sngl(vs))< 1.e-20 ) then
- print*,' attention: vs close to zero', &
- sngl(vs),r,i,j,k,ispec
- dvs = 0.0
- else
- dvp = dvp + (sqrt((kappavstore(i,j,k,ispec) &
- +4.*muvstore(i,j,k,ispec)/3.)/rhostore(i,j,k,ispec)) &
- - sngl(vp))/sngl(vp)
- dvs = dvs + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) &
- - sngl(vs))/sngl(vs)
- endif
-
- enddo
- enddo
- enddo
- dvp = dvp / np
- dvs = dvs / np
- else
- dvp = 0.0
- dvs = 0.0
- endif
- endif
-
- ! face xi = xi_min
- if(iboun(1,ispec)) then
- ispecface = ispecface + 1
- avs_dx_adios%idoubling(ispecface) = idoubling(ispec)
- avs_dx_adios%iglob1(ispecface) = num_ibool_AVS_DX(iglobval(1))
- avs_dx_adios%iglob2(ispecface) = num_ibool_AVS_DX(iglobval(4))
- avs_dx_adios%iglob3(ispecface) = num_ibool_AVS_DX(iglobval(8))
- avs_dx_adios%iglob4(ispecface) = num_ibool_AVS_DX(iglobval(5))
- if(ISOTROPIC_3D_MANTLE) then
- avs_dx_adios%dvp(ispecface) = dvp
- avs_dx_adios%dvs(ispecface) = dvs
- endif
- endif
-
- ! face xi = xi_max
- if(iboun(2,ispec)) then
- ispecface = ispecface + 1
- avs_dx_adios%idoubling(ispecface) = idoubling(ispec)
- avs_dx_adios%iglob1(ispecface)= num_ibool_AVS_DX(iglobval(2))
- avs_dx_adios%iglob2(ispecface) = num_ibool_AVS_DX(iglobval(3))
- avs_dx_adios%iglob3(ispecface) = num_ibool_AVS_DX(iglobval(7))
- avs_dx_adios%iglob4(ispecface) = num_ibool_AVS_DX(iglobval(6))
- if(ISOTROPIC_3D_MANTLE) then
- avs_dx_adios%dvp(ispecface) = dvp
- avs_dx_adios%dvs(ispecface) = dvs
- endif
- endif
-
- ! face eta = eta_min
- if(iboun(3,ispec)) then
- ispecface = ispecface + 1
- avs_dx_adios%idoubling(ispecface) = idoubling(ispec)
- avs_dx_adios%iglob1(ispecface) = num_ibool_AVS_DX(iglobval(1))
- avs_dx_adios%iglob2(ispecface) = num_ibool_AVS_DX(iglobval(2))
- avs_dx_adios%iglob3(ispecface) = num_ibool_AVS_DX(iglobval(6))
- avs_dx_adios%iglob4(ispecface) = num_ibool_AVS_DX(iglobval(5))
- if(ISOTROPIC_3D_MANTLE) then
- avs_dx_adios%dvp(ispecface) = dvp
- avs_dx_adios%dvs(ispecface) = dvs
- endif
- endif
-
- ! face eta = eta_max
- if(iboun(4,ispec)) then
- ispecface = ispecface + 1
- avs_dx_adios%idoubling(ispecface) = idoubling(ispec)
- avs_dx_adios%iglob1(ispecface) = num_ibool_AVS_DX(iglobval(4))
- avs_dx_adios%iglob2(ispecface) = num_ibool_AVS_DX(iglobval(3))
- avs_dx_adios%iglob3(ispecface) = num_ibool_AVS_DX(iglobval(7))
- avs_dx_adios%iglob4(ispecface) = num_ibool_AVS_DX(iglobval(8))
- if(ISOTROPIC_3D_MANTLE) then
- avs_dx_adios%dvp(ispecface) = dvp
- avs_dx_adios%dvs(ispecface) = dvs
- endif
- endif
-
- endif
- enddo
-
- ! check that number of surface elements output is okay
- if(ispecface /= nspecface) &
- call exit_MPI(myrank, &
- 'incorrect number of surface elements in AVS or DX file creation')
-
-end subroutine prepare_AVS_DX_global_chunks_data_adios
-
-!===============================================================================
-subroutine write_AVS_DX_global_chunks_data_adios(adios_handle, myrank, &
- sizeprocs, avs_dx_adios, ISOTROPIC_3D_MANTLE)
- use mpi
- use adios_write_mod
- implicit none
- !--- Arguments
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: myrank, sizeprocs
- type(avs_dx_global_chunks_t), intent(inout) :: avs_dx_adios ! out for adios_write
- logical ISOTROPIC_3D_MANTLE
- !--- Variables
- integer :: npoin, nspec
- integer :: ierr
-
- npoin = avs_dx_adios%npoin
- nspec = avs_dx_adios%nspecface
-
- call adios_set_path(adios_handle, "points_chunks/x_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%x_adios, ierr)
-
- call adios_set_path(adios_handle, "points_chunks/y_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%y_adios, ierr)
-
- call adios_set_path(adios_handle, "points_chunks/z_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%z_adios, ierr)
-
-
- call adios_set_path(adios_handle, "points_chunks/vmin", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%vmin, ierr)
-
- call adios_set_path(adios_handle, "points_chunks/vmax", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%vmax, ierr)
-
-
- call adios_set_path(adios_handle, "elements_chunks/idoubling", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%idoubling, ierr)
-
-
- call adios_set_path(adios_handle, &
- "elements_chunks/num_ibool_AVS_DX_iglob1", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob1, ierr)
-
- call adios_set_path(adios_handle, &
- "elements_chunks/num_ibool_AVS_DX_iglob2", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob2, ierr)
-
- call adios_set_path(adios_handle, &
- "elements_chunks/num_ibool_AVS_DX_iglob3", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob3, ierr)
-
- call adios_set_path(adios_handle, &
- "elements_chunks/num_ibool_AVS_DX_iglob4", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob4, ierr)
-
-
- if(ISOTROPIC_3D_MANTLE) then
- call adios_set_path(adios_handle, "elements_chunks/dvp", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%dvp, ierr)
- call adios_set_path(adios_handle, "elements_chunks/dvs", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%dvs, ierr)
- endif
-
-end subroutine write_AVS_DX_global_chunks_data_adios
-
-!===============================================================================
-subroutine free_AVS_DX_global_chunks_data_adios(myrank, avs_dx_adios, &
- ISOTROPIC_3D_MANTLE)
- implicit none
- !--- Arguments
- integer, intent(in) :: myrank
- type(avs_dx_global_chunks_t), intent(inout) :: avs_dx_adios
- logical ISOTROPIC_3D_MANTLE
- !--- Variables
- !--- Variables
- integer :: ierr
-
- deallocate(avs_dx_adios%x_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating x_adios.")
- deallocate(avs_dx_adios%y_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating y_adios.")
- deallocate(avs_dx_adios%z_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating z_adios.")
-
- deallocate(avs_dx_adios%vmin, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating vmin.")
- deallocate(avs_dx_adios%vmax, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating vmax.")
-
- deallocate(avs_dx_adios%idoubling, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob1.")
- deallocate(avs_dx_adios%iglob1, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob1.")
- deallocate(avs_dx_adios%iglob2, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob2.")
- deallocate(avs_dx_adios%iglob3, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob3.")
- deallocate(avs_dx_adios%iglob4, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob4.")
-
- if(ISOTROPIC_3D_MANTLE) then
- deallocate(avs_dx_adios%dvp, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating dvp.")
- deallocate(avs_dx_adios%dvs, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating dvs.")
- endif
-
- avs_dx_adios%npoin = 0
- avs_dx_adios%nspecface = 0
-end subroutine free_AVS_DX_global_chunks_data_adios
-
-end module
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_data_adios.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_data_adios.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_data_adios.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,470 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!-------------------------------------------------------------------------------
-!> \file write_AVS_DX_global_adios.f90
-!! \brief Define a module to hold global AVS/DX data (points and elements) and
-!! provides function to deal with them.
-!! \author MPBL
-!-------------------------------------------------------------------------------
-
-!===============================================================================
-!> AVS_DX_global_mod module. Hold and write to ADIOS file global data (points
-!! and elements).
-module AVS_DX_global_mod
-
- implicit none
-
- ! ADIOS Arrays to write down
- type avs_dx_global_t
- integer(kind=4) :: npoin, nspec
- real(kind=4), dimension(:), allocatable :: x_adios, y_adios, z_adios
- integer(kind=4), dimension(:), allocatable :: idoubling, iglob1, iglob2, &
- iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
- endtype
-
-contains
-
-!===============================================================================
-!> Allocate the structure that hold data to be written; initialize adios vars.
-!! \param adios_group ADIOS group where the variables belong
-!! \param group_size_inc The size of the ADIOS group to increment
-!! \param avs_dx_adios The structure holding the data to be allocated
-subroutine define_AVS_DX_global_data_adios(adios_group, myrank, nspec, ibool, &
- npointot, mask_ibool, group_size_inc, avs_dx_adios)
- use mpi
- use adios_write_mod
- implicit none
- include "constants.h"
- !--- Arguments -------------------------------------------
- integer(kind=8), intent(in) :: adios_group
- integer(kind=4), intent(in) :: nspec, npointot, myrank
- integer(kind=4), intent(in) :: ibool(NGLLX,NGLLY,NGLLZ,nspec)
- logical, intent(inout) :: mask_ibool(npointot)
- integer(kind=8), intent(inout) :: group_size_inc
- type(avs_dx_global_t), intent(inout) :: avs_dx_adios
- !--- Variables -------------------------------------------
- integer ispec, npoin, ierr
- integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
-
- mask_ibool(:) = .false.
-
- ! mark global AVS or DX points
- do ispec=1,nspec
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob5) = .true.
- mask_ibool(iglob6) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob8) = .true.
- enddo
-
- ! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
- avs_dx_adios%npoin = npoin
- avs_dx_adios%nspec = nspec
- ! Allocate temporary arrays for AVS/DX points
- allocate(avs_dx_adios%x_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating x_adios.")
- allocate(avs_dx_adios%y_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating y_adios.")
- allocate(avs_dx_adios%z_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating z_adios.")
-
- ! Allocate temporary arrays for AVS/DX elements.
- allocate(avs_dx_adios%idoubling(nspec), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating idoubling.")
- allocate(avs_dx_adios%iglob1(nspec), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob1.")
- allocate(avs_dx_adios%iglob2(nspec), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob2.")
- allocate(avs_dx_adios%iglob3(nspec), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob3.")
- allocate(avs_dx_adios%iglob4(nspec), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob4.")
- allocate(avs_dx_adios%iglob5(nspec), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob5.")
- allocate(avs_dx_adios%iglob6(nspec), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob6.")
- allocate(avs_dx_adios%iglob7(nspec), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob7.")
- allocate(avs_dx_adios%iglob8(nspec), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob8.")
-
- !--- Variables for '...AVS_DXpoints.txt'
- call define_adios_global_real_1d_array(adios_group, "points/x_value", &
- npoin, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "points/y_value", &
- npoin, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "points/z_value", &
- npoin, group_size_inc)
- !--- Variables for AVS_DXelements.txt
- call define_adios_global_real_1d_array(adios_group, "elements/idoubling", &
- nspec, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements/num_ibool_AVS_DX_iglob1", nspec, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements/num_ibool_AVS_DX_iglob2", nspec, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements/num_ibool_AVS_DX_iglob3", nspec, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements/num_ibool_AVS_DX_iglob4", nspec, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements/num_ibool_AVS_DX_iglob5", nspec, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements/num_ibool_AVS_DX_iglob6", nspec, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements/num_ibool_AVS_DX_iglob7", nspec, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements/num_ibool_AVS_DX_iglob8", nspec, group_size_inc)
-
-end subroutine define_AVS_DX_global_data_adios
-
-
-!===============================================================================
-!> Prepare the global AVS/DX data to be written; fill the structure.
-!! \param adios_handle The handle to the ADIOS file to be written.
-!! \param myrank The MPI rank of the current process.
-!! \param avs_dx_adios The structure to be filled.
-!!
-!! Create AVS or DX 3D data for the slice, to be recombined in postprocessing.
-subroutine prepare_AVS_DX_global_data_adios(adios_handle, myrank, &
- nspec, ibool, idoubling, xstore, ystore, zstore, num_ibool_AVS_DX, &
- mask_ibool, npointot, avs_dx_adios)
- use mpi
- use adios_write_mod
-
- implicit none
-
- include "constants.h"
-
- integer(kind=8), intent(in) :: adios_handle
- integer nspec,myrank
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- ! logical mask used to output global points only once
- integer npointot
- logical mask_ibool(npointot)
-
- ! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
-
- integer ispec
- integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
- integer npoin,numpoin
-
- type(avs_dx_global_t), intent(inout) :: avs_dx_adios
-
- integer :: ierr
-
-! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
-! mark global AVS or DX points
- do ispec=1,nspec
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob5) = .true.
- mask_ibool(iglob6) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob8) = .true.
- enddo
-
- ! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
- ! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- ! fill the structure with global AVS or DX points
- numpoin = 0
- do ispec=1,nspec
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
- if(.not. mask_ibool(iglob1)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob1) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob2)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob2) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob3)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob3) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob4)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob4) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob5)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob5) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob6)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob6) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob7)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob7) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob8)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob8) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,NGLLZ,ispec))
- endif
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob5) = .true.
- mask_ibool(iglob6) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob8) = .true.
- enddo
-
- ! check that number of global points output is okay
- if(numpoin /= npoin) &
- call exit_MPI(myrank, &
- 'incorrect number of global points in AVS or DX file creation')
-
- ! AVS or DX elements
- do ispec=1,nspec
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
-
- avs_dx_adios%iglob1 = num_ibool_AVS_DX(iglob1)
- avs_dx_adios%iglob2 = num_ibool_AVS_DX(iglob2)
- avs_dx_adios%iglob3 = num_ibool_AVS_DX(iglob3)
- avs_dx_adios%iglob4 = num_ibool_AVS_DX(iglob4)
- avs_dx_adios%iglob5 = num_ibool_AVS_DX(iglob5)
- avs_dx_adios%iglob6 = num_ibool_AVS_DX(iglob6)
- avs_dx_adios%iglob7 = num_ibool_AVS_DX(iglob7)
- avs_dx_adios%iglob8 = num_ibool_AVS_DX(iglob8)
- enddo
- avs_dx_adios%idoubling = idoubling
-end subroutine prepare_AVS_DX_global_data_adios
-
-!===============================================================================
-!> Schedule write to ADIOS file for global AVS/DX data
-!! \param adios_handle The handle to the ADIOS file we want to write into
-!! \param nspec Number of spectral elements
-!! \avs_dx_adios Structure with the data that have to be wrtten
-subroutine write_AVS_DX_global_data_adios(adios_handle, myrank, &
- sizeprocs, avs_dx_adios)
- use mpi
- use adios_write_mod
- implicit none
- !--- Arguments
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: myrank, sizeprocs
- type(avs_dx_global_t), intent(inout) :: avs_dx_adios ! out for adios_write
- !--- Variables
- integer :: npoin, nspec
- integer :: ierr
-
- npoin = avs_dx_adios%npoin
- nspec = avs_dx_adios%nspec
-
- call adios_set_path(adios_handle, "points/x_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%x_adios, ierr)
-
- call adios_set_path(adios_handle, "points/y_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%y_adios, ierr)
-
- call adios_set_path(adios_handle, "points/z_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%z_adios, ierr)
-
-
- call adios_set_path(adios_handle, "elements/idoubling", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%idoubling, ierr)
-
-
- call adios_set_path(adios_handle, "elements/num_ibool_AVS_DX_iglob1", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob1, ierr)
-
- call adios_set_path(adios_handle, "elements/num_ibool_AVS_DX_iglob2", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob2, ierr)
-
- call adios_set_path(adios_handle, "elements/num_ibool_AVS_DX_iglob3", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob3, ierr)
-
- call adios_set_path(adios_handle, "elements/num_ibool_AVS_DX_iglob4", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob4, ierr)
-
- call adios_set_path(adios_handle, "elements/num_ibool_AVS_DX_iglob5", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob5, ierr)
-
- call adios_set_path(adios_handle, "elements/num_ibool_AVS_DX_iglob6", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob6, ierr)
-
- call adios_set_path(adios_handle, "elements/num_ibool_AVS_DX_iglob7", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob7, ierr)
-
- call adios_set_path(adios_handle, "elements/num_ibool_AVS_DX_iglob1", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob8, ierr)
-end subroutine write_AVS_DX_global_data_adios
-
-!===============================================================================
-!> Free temporary structure filled to write AVS/DX global variable to file.
-!! \param myrank The MPI rank of the process
-!! \param avs_dx_adios The structure holding AVS/DX information
-subroutine free_AVS_DX_global_data_adios(myrank, avs_dx_adios)
- implicit none
- !--- Arguments
- integer, intent(in) :: myrank
- type(avs_dx_global_t), intent(inout) :: avs_dx_adios
- !--- Variables
- integer :: ierr
-
- deallocate(avs_dx_adios%x_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating x_adios.")
- deallocate(avs_dx_adios%y_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating y_adios.")
- deallocate(avs_dx_adios%z_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating z_adios.")
-
- deallocate(avs_dx_adios%idoubling, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob1.")
- deallocate(avs_dx_adios%iglob1, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob1.")
- deallocate(avs_dx_adios%iglob2, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob2.")
- deallocate(avs_dx_adios%iglob3, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob3.")
- deallocate(avs_dx_adios%iglob4, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob4.")
- deallocate(avs_dx_adios%iglob5, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob5.")
- deallocate(avs_dx_adios%iglob6, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob6.")
- deallocate(avs_dx_adios%iglob7, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob7.")
- deallocate(avs_dx_adios%iglob8, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob8.")
-
- avs_dx_adios%npoin = 0
- avs_dx_adios%nspec = 0
-end subroutine free_AVS_DX_global_data_adios
-
-end module AVS_DX_global_mod
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_faces_data_adios.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_faces_data_adios.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_global_faces_data_adios.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,825 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!-------------------------------------------------------------------------------
-!> \file write_AVS_DX_global_faces_data_adios.f90
-!! \brief create AVS or DX 2D data for the faces of the slice,
-!! to be recombined in postprocessing
-!! \author MPBL
-!-------------------------------------------------------------------------------
-
-!===============================================================================
-module AVS_DX_global_faces_mod
-
- implicit none
-
- type avs_dx_global_faces_t
- integer(kind=4) :: npoin, nspecface
- real(kind=4), dimension(:), allocatable :: x_adios, y_adios, z_adios
- integer(kind=4), dimension(:), allocatable :: idoubling, iglob1, iglob2, &
- iglob3, iglob4
- real, dimension(:), allocatable :: dvp, dvs
- endtype
-
-contains
-
-!===============================================================================
-subroutine define_AVS_DX_global_faces_data_adios (adios_group, &
- myrank, prname, nspec, iMPIcut_xi,iMPIcut_eta, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- group_size_inc, avs_dx_adios)
- use mpi
- use adios_write_mod
-
- implicit none
- include "constants.h"
-
- integer(kind=8), intent(in) :: adios_group
- integer(kind=8), intent(inout) :: group_size_inc
-
- integer nspec,myrank
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
- logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
-
- logical iMPIcut_xi(2,nspec)
- logical iMPIcut_eta(2,nspec)
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
- R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to output global points only once
- integer npointot
- logical mask_ibool(npointot)
-
-! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
-
- integer ispec
- integer i,j,k,np
- integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
- integer npoin,numpoin,nspecface,ispecface
-
- double precision r,rho,vp,vs,Qkappa,Qmu
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
- real(kind=CUSTOM_REAL) dvp,dvs
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
-! processor identification
- character(len=150) prname
-
- integer iregion_code
-
- type(avs_dx_global_faces_t), intent(inout) :: avs_dx_adios
-
- integer :: ierr
-
- ! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- nspecface = 0
-
- ! mark global AVS or DX points
- do ispec=1,nspec
- ! only if on face
- if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
- iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
-
- ! face xi = xi_min
- if(iMPIcut_xi(1,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob8) = .true.
- mask_ibool(iglob5) = .true.
- endif
-
- ! face xi = xi_max
- if(iMPIcut_xi(2,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob6) = .true.
- endif
-
- ! face eta = eta_min
- if(iMPIcut_eta(1,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob6) = .true.
- mask_ibool(iglob5) = .true.
- endif
-
- ! face eta = eta_max
- if(iMPIcut_eta(2,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob8) = .true.
- endif
- endif
- enddo
- ! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
- avs_dx_adios%npoin = npoin
- avs_dx_adios%nspecface = nspecface
-
- allocate(avs_dx_adios%x_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating x_adios.")
- allocate(avs_dx_adios%y_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating y_adios.")
- allocate(avs_dx_adios%z_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating z_adios.")
-
- ! Allocate temporary arrays for AVS/DX elements.
- allocate(avs_dx_adios%idoubling(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating idoubling.")
- allocate(avs_dx_adios%iglob1(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob1.")
- allocate(avs_dx_adios%iglob2(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob2.")
- allocate(avs_dx_adios%iglob3(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob3.")
- allocate(avs_dx_adios%iglob4(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob4.")
-
- !--- Variables for '...AVS_DXpointsfaces.txt'
- call define_adios_global_real_1d_array(adios_group, "points_faces/x_value", &
- npoin, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "points_faces/y_value", &
- npoin, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "points_faces/z_value", &
- npoin, group_size_inc)
- !--- Variables for AVS_DXelementsfaces.txt
- call define_adios_global_real_1d_array(adios_group, &
- "elements_faces/idoubling", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_faces/num_ibool_AVS_DX_iglob1", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_faces/num_ibool_AVS_DX_iglob2", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_faces/num_ibool_AVS_DX_iglob3", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_faces/num_ibool_AVS_DX_iglob4", nspecface, group_size_inc)
-
- if(ISOTROPIC_3D_MANTLE) then
- allocate(avs_dx_adios%dvp(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating dvp.")
- allocate(avs_dx_adios%dvs(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating dvs.")
- call define_adios_global_real_1d_array(adios_group, &
- "elements_faces/dvp", dvp, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_faces/dvp", dvs, group_size_inc)
- endif
-
-end subroutine define_AVS_DX_global_faces_data_adios
-
-!===============================================================================
-subroutine prepare_AVS_DX_global_faces_data_adios (myrank, prname, nspec, &
- iMPIcut_xi,iMPIcut_eta, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- avs_dx_adios)
-
- implicit none
-
- include "constants.h"
-
- integer nspec,myrank
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
- logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
-
- logical iMPIcut_xi(2,nspec)
- logical iMPIcut_eta(2,nspec)
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
- R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to output global points only once
- integer npointot
- logical mask_ibool(npointot)
-
-! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
-
- integer ispec
- integer i,j,k,np
- integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
- integer npoin,numpoin,nspecface,ispecface
-
- double precision r,rho,vp,vs,Qkappa,Qmu
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
- real(kind=CUSTOM_REAL) dvp,dvs
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
-! processor identification
- character(len=150) prname
-
- integer iregion_code
-
- type(avs_dx_global_faces_t), intent(inout) :: avs_dx_adios
-
- ! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- nspecface = 0
-
-! mark global AVS or DX points
- do ispec=1,nspec
- ! only if on face
- if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
- iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
-
- ! face xi = xi_min
- if(iMPIcut_xi(1,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob8) = .true.
- mask_ibool(iglob5) = .true.
- endif
-
- ! face xi = xi_max
- if(iMPIcut_xi(2,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob6) = .true.
- endif
-
- ! face eta = eta_min
- if(iMPIcut_eta(1,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob6) = .true.
- mask_ibool(iglob5) = .true.
- endif
-
- ! face eta = eta_max
- if(iMPIcut_eta(2,ispec)) then
- nspecface = nspecface + 1
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob8) = .true.
- endif
-
- endif
- enddo
-
- ! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
- ! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- ! output global AVS or DX points
- numpoin = 0
- do ispec=1,nspec
- ! only if on face
- if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
- iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
-
- ! face xi = xi_min
- if(iMPIcut_xi(1,ispec)) then
- if(.not. mask_ibool(iglob1)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob1) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob4)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob4) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob8)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob8) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob5)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob5) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,NGLLZ,ispec))
- endif
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob8) = .true.
- mask_ibool(iglob5) = .true.
- endif
-
- ! face xi = xi_max
- if(iMPIcut_xi(2,ispec)) then
- if(.not. mask_ibool(iglob2)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob2) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob3)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob3) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob7)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob7) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob6)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob6) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,NGLLZ,ispec))
- endif
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob6) = .true.
- endif
-
- ! face eta = eta_min
- if(iMPIcut_eta(1,ispec)) then
- if(.not. mask_ibool(iglob1)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob1) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob2)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob2) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,1,ispec))
- endif
- if(.not. mask_ibool(iglob6)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob6) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob5)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob5) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,NGLLZ,ispec))
- endif
- mask_ibool(iglob1) = .true.
- mask_ibool(iglob2) = .true.
- mask_ibool(iglob6) = .true.
- mask_ibool(iglob5) = .true.
- endif
-
- ! face eta = eta_max
- if(iMPIcut_eta(2,ispec)) then
- if(.not. mask_ibool(iglob4)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob4) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob3)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob3) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,1,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,1,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,1,ispec))
- endif
- if(.not. mask_ibool(iglob7)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob7) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
- endif
- if(.not. mask_ibool(iglob8)) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglob8) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,NGLLZ,ispec))
- endif
- mask_ibool(iglob4) = .true.
- mask_ibool(iglob3) = .true.
- mask_ibool(iglob7) = .true.
- mask_ibool(iglob8) = .true.
- endif
-
- endif
- enddo
-
- ! check that number of global points output is okay
- if(numpoin /= npoin) &
- call exit_MPI(myrank, &
- 'incorrect number of global points in AVS or DX file creation')
-
- ! output global AVS or DX elements
-
- ispecface = 0
- do ispec=1,nspec
-! print *, ispecface, nspecface
- ! only if on face
- if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
- iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
-if (iglob1 > npointot) print *, myrank, "problem with iglob1", iglob1, npointot
-if (iglob2 > npointot) print *, myrank, "problem with iglob2", iglob2, npointot
-if (iglob3 > npointot) print *, myrank, "problem with iglob3", iglob3, npointot
-if (iglob4 > npointot) print *, myrank, "problem with iglob4", iglob4, npointot
-if (iglob5 > npointot) print *, myrank, "problem with iglob5", iglob5, npointot
-if (iglob6 > npointot) print *, myrank, "problem with iglob6", iglob6, npointot
-if (iglob7 > npointot) print *, myrank, "problem with iglob7", iglob7, npointot
-if (iglob8 > npointot) print *, myrank, "problem with iglob8", iglob8, npointot
-
-if (iglob1 < 0) print *, myrank, "problem with iglob1", iglob1, npointot
-if (iglob2 < 0) print *, myrank, "problem with iglob2", iglob2, npointot
-if (iglob3 < 0) print *, myrank, "problem with iglob3", iglob3, npointot
-if (iglob4 < 0) print *, myrank, "problem with iglob4", iglob4, npointot
-if (iglob5 < 0) print *, myrank, "problem with iglob5", iglob5, npointot
-if (iglob6 < 0) print *, myrank, "problem with iglob6", iglob6, npointot
-if (iglob7 < 0) print *, myrank, "problem with iglob7", iglob7, npointot
-if (iglob8 < 0) print *, myrank, "problem with iglob8", iglob8, npointot
-
- ! include lateral variations if needed
- if(ISOTROPIC_3D_MANTLE) then
- ! pick a point within the element and get its radius
- r = dsqrt(xstore(2,2,2,ispec)**2 &
- + ystore(2,2,2,ispec)**2 &
- + zstore(2,2,2,ispec)**2)
-
- if(r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then
- ! average over the element
- dvp = 0.0
- dvs = 0.0
- np =0
- do k=2,NGLLZ-1
- do j=2,NGLLY-1
- do i=2,NGLLX-1
- np=np+1
- x=xstore(i,j,k,ispec)
- y=ystore(i,j,k,ispec)
- z=zstore(i,j,k,ispec)
- r=dsqrt(x*x+y*y+z*z)
- ! take out ellipticity
- if(ELLIPTICITY) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi_dummy)
- cost=dcos(theta)
- p20=0.5d0*(3.0d0*cost*cost-1.0d0)
- call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
- factor=ONE-(TWO/3.0d0)*ell*p20
- r=r/factor
- endif
-
- ! gets reference model values:rho,vpv,vph,vsv,vsh and eta_aniso
- call meshfem3D_models_get1D_val(myrank, iregion_code, &
- idoubling(ispec), r, rho, vpv, vph, vsv, vsh, eta_aniso, &
- Qkappa, Qmu, RICB, RCMB, RTOPDDOUBLEPRIME, R80, R120, &
- R220, R400, R600, R670, R771, RMOHO, RMIDDLE_CRUST, ROCEAN)
-
- ! calculates isotropic values
- vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
- + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
- vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
- + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
-
- if( abs(rhostore(i,j,k,ispec))< 1.e-20 ) then
- print*,'attention: rhostore close to zero', &
- rhostore(i,j,k,ispec),r,i,j,k,ispec
- dvp = 0.0
- dvs = 0.0
- else if( abs(sngl(vp))< 1.e-20 ) then
- print*,' attention: vp close to zero',sngl(vp),r,i,j,k,ispec
- dvp = 0.0
- else if( abs(sngl(vs))< 1.e-20 ) then
- print*,' attention: vs close to zero',sngl(vs),r,i,j,k,ispec
- dvs = 0.0
- else
- dvp = dvp + (sqrt((kappavstore(i,j,k,ispec) &
- +4.*muvstore(i,j,k,ispec)/3.)/rhostore(i,j,k,ispec)) &
- - sngl(vp))/sngl(vp)
- dvs = dvs &
- + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) &
- - sngl(vs))/sngl(vs)
- endif
-
- enddo
- enddo
- enddo
- dvp = dvp / np
- dvs = dvs / np
- else
- dvp = 0.0
- dvs = 0.0
- endif
- endif
-
- ! face xi = xi_min
- if(iMPIcut_xi(1,ispec)) then
- ispecface = ispecface + 1
- avs_dx_adios%idoubling(ispecface) = idoubling(ispec)
- avs_dx_adios%iglob1(ispecface) = num_ibool_AVS_DX(iglob1)
- avs_dx_adios%iglob2(ispecface) = num_ibool_AVS_DX(iglob4)
- avs_dx_adios%iglob3(ispecface) = num_ibool_AVS_DX(iglob8)
- avs_dx_adios%iglob4(ispecface) = num_ibool_AVS_DX(iglob5)
- if(ISOTROPIC_3D_MANTLE) then
- avs_dx_adios%dvp(ispecface) = dvp
- avs_dx_adios%dvs(ispecface) = dvs
- endif
- endif
-
- ! face xi = xi_max
- if(iMPIcut_xi(2,ispec)) then
- ispecface = ispecface + 1
- avs_dx_adios%idoubling(ispecface) = idoubling(ispec)
- avs_dx_adios%iglob1(ispecface)= num_ibool_AVS_DX(iglob2)
- avs_dx_adios%iglob2(ispecface) = num_ibool_AVS_DX(iglob3)
- avs_dx_adios%iglob3(ispecface) = num_ibool_AVS_DX(iglob7)
- avs_dx_adios%iglob4(ispecface) = num_ibool_AVS_DX(iglob6)
- if(ISOTROPIC_3D_MANTLE) then
- avs_dx_adios%dvp(ispecface) = dvp
- avs_dx_adios%dvs(ispecface) = dvs
- endif
- endif
-
- ! face eta = eta_min
- if(iMPIcut_eta(1,ispec)) then
- ispecface = ispecface + 1
- avs_dx_adios%idoubling(ispecface) = idoubling(ispec)
- avs_dx_adios%iglob1(ispecface) = num_ibool_AVS_DX(iglob1)
- avs_dx_adios%iglob2(ispecface) = num_ibool_AVS_DX(iglob2)
- avs_dx_adios%iglob3(ispecface) = num_ibool_AVS_DX(iglob6)
- avs_dx_adios%iglob4(ispecface) = num_ibool_AVS_DX(iglob5)
- if(ISOTROPIC_3D_MANTLE) then
- avs_dx_adios%dvp(ispecface) = dvp
- avs_dx_adios%dvs(ispecface) = dvs
- endif
- endif
-
- ! face eta = eta_max
- if(iMPIcut_eta(2,ispec)) then
- ispecface = ispecface + 1
- avs_dx_adios%idoubling(ispecface) = idoubling(ispec)
- avs_dx_adios%iglob1(ispecface) = num_ibool_AVS_DX(iglob4)
- avs_dx_adios%iglob2(ispecface) = num_ibool_AVS_DX(iglob3)
- avs_dx_adios%iglob3(ispecface) = num_ibool_AVS_DX(iglob7)
- avs_dx_adios%iglob4(ispecface) = num_ibool_AVS_DX(iglob8)
- if(ISOTROPIC_3D_MANTLE) then
- avs_dx_adios%dvp(ispecface) = dvp
- avs_dx_adios%dvs(ispecface) = dvs
- endif
- endif
-
- endif
- enddo
-
- ! check that number of surface elements output is okay
- if(ispecface /= nspecface) &
- call exit_MPI(myrank,&
- 'incorrect number of surface elements in AVS or DX file creation')
-
-end subroutine prepare_AVS_DX_global_faces_data_adios
-
-!===============================================================================
-subroutine write_AVS_DX_global_faces_data_adios(adios_handle, myrank, &
- sizeprocs, avs_dx_adios, ISOTROPIC_3D_MANTLE)
- use mpi
- use adios_write_mod
- implicit none
- !--- Arguments
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: myrank, sizeprocs
- type(avs_dx_global_faces_t), intent(inout) :: avs_dx_adios ! out for adios_write
- logical ISOTROPIC_3D_MANTLE
- !--- Variables
- integer :: npoin, nspec
- integer :: ierr
-
- npoin = avs_dx_adios%npoin
- nspec = avs_dx_adios%nspecface
-
- call adios_set_path(adios_handle, "points_faces/x_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%x_adios, ierr)
-
- call adios_set_path(adios_handle, "points_faces/y_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%y_adios, ierr)
-
- call adios_set_path(adios_handle, "points_faces/z_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%z_adios, ierr)
-
-
- call adios_set_path(adios_handle, "elements_faces/idoubling", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%idoubling, ierr)
-
-
- call adios_set_path(adios_handle, &
- "elements_faces/num_ibool_AVS_DX_iglob1", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob1, ierr)
-
- call adios_set_path(adios_handle, &
- "elements_faces/num_ibool_AVS_DX_iglob2", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob2, ierr)
-
- call adios_set_path(adios_handle, &
- "elements_faces/num_ibool_AVS_DX_iglob3", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob3, ierr)
-
- call adios_set_path(adios_handle, &
- "elements_faces/num_ibool_AVS_DX_iglob4", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob4, ierr)
-
-
- if(ISOTROPIC_3D_MANTLE) then
- call adios_set_path(adios_handle, "elements_faces/dvp", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%dvp, ierr)
- call adios_set_path(adios_handle, "elements_faces/dvs", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%dvs, ierr)
- endif
-
-end subroutine write_AVS_DX_global_faces_data_adios
-
-!===============================================================================
-subroutine free_AVS_DX_global_faces_data_adios(myrank, avs_dx_adios, &
- ISOTROPIC_3D_MANTLE)
- implicit none
- !--- Arguments
- integer, intent(in) :: myrank
- type(avs_dx_global_faces_t), intent(inout) :: avs_dx_adios
- logical ISOTROPIC_3D_MANTLE
- !--- Variables
- !--- Variables
- integer :: ierr
-
- deallocate(avs_dx_adios%x_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating x_adios.")
- deallocate(avs_dx_adios%y_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating y_adios.")
- deallocate(avs_dx_adios%z_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating z_adios.")
-
- deallocate(avs_dx_adios%idoubling, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob1.")
- deallocate(avs_dx_adios%iglob1, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob1.")
- deallocate(avs_dx_adios%iglob2, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob2.")
- deallocate(avs_dx_adios%iglob3, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob3.")
- deallocate(avs_dx_adios%iglob4, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob4.")
-
- if(ISOTROPIC_3D_MANTLE) then
- deallocate(avs_dx_adios%dvp, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating dvp.")
- deallocate(avs_dx_adios%dvs, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating dvs.")
- endif
-
- avs_dx_adios%npoin = 0
- avs_dx_adios%nspecface = 0
-end subroutine free_AVS_DX_global_faces_data_adios
-
-end module
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_surface_data_adios.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_surface_data_adios.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/write_AVS_DX_surface_data_adios.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,577 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! create AVS or DX 2D data for the surface of the model
-! to be recombined in postprocessing
-
-module AVS_DX_surface_mod
-
- implicit none
-
- type avs_dx_surface_t
- integer(kind=4) :: npoin, nspecface
- real(kind=4), dimension(:), allocatable :: x_adios, y_adios, z_adios
- integer(kind=4), dimension(:), allocatable :: idoubling, iglob1, iglob2, &
- iglob3, iglob4
- real, dimension(:), allocatable :: dvp, dvs
- endtype
-
-contains
-
-subroutine define_AVS_DX_surfaces_data_adios(adios_group, &
- myrank,prname,nspec,iboun, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,npointot,&
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- group_size_inc, avs_dx_adios)
- use mpi
- use adios_write_mod
-
- implicit none
-
- include "constants.h"
-
- integer(kind=8), intent(in) :: adios_group
- integer(kind=8), intent(inout) :: group_size_inc
-
- integer nspec,myrank
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
- logical iboun(6,nspec)
- logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
- R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- double precision r,rho,vp,vs,Qkappa,Qmu
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
- real(kind=CUSTOM_REAL) dvp,dvs
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to output global points only once
- integer npointot
- logical mask_ibool(npointot)
-
-! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
-
- integer ispec
- integer i,j,k,np
- integer, dimension(8) :: iglobval
- integer npoin,numpoin,nspecface,ispecface
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
-! processor identification
- character(len=150) prname
-
- integer iregion_code
-
- type(avs_dx_surface_t), intent(inout) :: avs_dx_adios
-
- integer :: ierr
-
- ! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- nspecface = 0
-
- ! mark global AVS or DX points
- do ispec=1,nspec
- ! only if at the surface (top plane)
- if(iboun(6,ispec)) then
-
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
- ! element is at the surface
- nspecface = nspecface + 1
- mask_ibool(iglobval(5)) = .true.
- mask_ibool(iglobval(6)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(8)) = .true.
- endif
- enddo
-
-! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
- avs_dx_adios%npoin = npoin
- avs_dx_adios%nspecface = nspecface
-
- allocate(avs_dx_adios%x_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating x_adios.")
- allocate(avs_dx_adios%y_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating y_adios.")
- allocate(avs_dx_adios%z_adios(npoin), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating z_adios.")
-
- ! Allocate temporary arrays for AVS/DX elements.
- allocate(avs_dx_adios%idoubling(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating idoubling.")
- allocate(avs_dx_adios%iglob1(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob1.")
- allocate(avs_dx_adios%iglob2(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob2.")
- allocate(avs_dx_adios%iglob3(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob3.")
- allocate(avs_dx_adios%iglob4(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating iglob4.")
-
- !--- Variables for '...AVS_DXpointschunk.txt'
- call define_adios_global_real_1d_array(adios_group, &
- "points_surfaces/x_value", npoin, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "points_surfaces/y_value", npoin, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "points_surfaces/z_value", npoin, group_size_inc)
- !--- Variables for AVS_DXelementschunks.txt
- call define_adios_global_real_1d_array(adios_group, &
- "elements_surfaces/idoubling", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_surfaces/num_ibool_AVS_DX_iglob1", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_surfaces/num_ibool_AVS_DX_iglob2", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_surfaces/num_ibool_AVS_DX_iglob3", nspecface, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_surfaces/num_ibool_AVS_DX_iglob4", nspecface, group_size_inc)
-
- !--- Variables for AVS_DXelementschunks_dvp_dvs.txt
- if(ISOTROPIC_3D_MANTLE) then
- allocate(avs_dx_adios%dvp(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating dvp.")
- allocate(avs_dx_adios%dvs(nspecface), stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error allocating dvs.")
- call define_adios_global_real_1d_array(adios_group, &
- "elements_surfaces/dvp", dvp, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "elements_surfaces/dvp", dvs, group_size_inc)
- endif
-
-end subroutine define_AVS_DX_surfaces_data_adios
-
-!===============================================================================
-subroutine prepare_AVS_DX_surfaces_data_adios(myrank,prname,nspec,iboun, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,npointot,&
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code, &
- avs_dx_adios)
-
- implicit none
-
- include "constants.h"
-
- integer nspec,myrank
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
- logical iboun(6,nspec)
- logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
-
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
- R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- double precision r,rho,vp,vs,Qkappa,Qmu
- double precision vpv,vph,vsv,vsh,eta_aniso
- double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
- real(kind=CUSTOM_REAL) dvp,dvs
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! logical mask used to output global points only once
- integer npointot
- logical mask_ibool(npointot)
-
-! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
-
- integer ispec
- integer i,j,k,np
- integer, dimension(8) :: iglobval
- integer npoin,numpoin,nspecface,ispecface
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
-! processor identification
- character(len=150) prname
-
- integer iregion_code
-
- type(avs_dx_surface_t), intent(inout) :: avs_dx_adios
-
- ! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- nspecface = 0
-
- ! mark global AVS or DX points
- do ispec=1,nspec
- ! only if at the surface (top plane)
- if(iboun(6,ispec)) then
-
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
- ! element is at the surface
- nspecface = nspecface + 1
- mask_ibool(iglobval(5)) = .true.
- mask_ibool(iglobval(6)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(8)) = .true.
-
- endif
- enddo
-
- ! count global number of AVS or DX points
- npoin = count(mask_ibool(:))
-
- ! erase the logical mask used to mark points already found
- mask_ibool(:) = .false.
-
- ! output global AVS or DX points
- numpoin = 0
- do ispec=1,nspec
- ! only if at the surface
- if(iboun(6,ispec)) then
-
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
- ! top face
- if(iboun(6,ispec)) then
-
- if(.not. mask_ibool(iglobval(5))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(5)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,1,NGLLZ,ispec))
- endif
-
- if(.not. mask_ibool(iglobval(6))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(6)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,1,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,1,NGLLZ,ispec))
- endif
-
- if(.not. mask_ibool(iglobval(7))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(7)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
- endif
-
- if(.not. mask_ibool(iglobval(8))) then
- numpoin = numpoin + 1
- num_ibool_AVS_DX(iglobval(8)) = numpoin
- avs_dx_adios%x_adios(numpoin) = sngl(xstore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%y_adios(numpoin) = sngl(ystore(1,NGLLY,NGLLZ,ispec))
- avs_dx_adios%z_adios(numpoin) = sngl(zstore(1,NGLLY,NGLLZ,ispec))
- endif
-
- mask_ibool(iglobval(5)) = .true.
- mask_ibool(iglobval(6)) = .true.
- mask_ibool(iglobval(7)) = .true.
- mask_ibool(iglobval(8)) = .true.
- endif
-
- endif
- enddo
-
- ! check that number of global points output is okay
- if(numpoin /= npoin) &
- call exit_MPI(myrank, &
- 'incorrect number of global points in AVS or DX file creation')
-
- ! output global AVS or DX elements
- ispecface = 0
- do ispec=1,nspec
- ! only if at the surface
- if(iboun(6,ispec)) then
-
- iglobval(5)=ibool(1,1,NGLLZ,ispec)
- iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
- iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
-
- if(ISOTROPIC_3D_MANTLE) then
- ! pick a point within the element and get its radius
- r=dsqrt(xstore(2,2,2,ispec)**2 &
- + ystore(2,2,2,ispec)**2+zstore(2,2,2,ispec)**2)
-
- if(r > RCMB/R_EARTH .and. r < R_UNIT_SPHERE) then
- ! average over the element
- dvp = 0.0
- dvs = 0.0
- np =0
- do k=2,NGLLZ-1
- do j=2,NGLLY-1
- do i=2,NGLLX-1
- np=np+1
- x=xstore(i,j,k,ispec)
- y=ystore(i,j,k,ispec)
- z=zstore(i,j,k,ispec)
- r=dsqrt(x*x+y*y+z*z)
- ! take out ellipticity
- if(ELLIPTICITY) then
- call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi_dummy)
- cost=dcos(theta)
- p20=0.5d0*(3.0d0*cost*cost-1.0d0)
- call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
- factor=ONE-(TWO/3.0d0)*ell*p20
- r=r/factor
- endif
-
- ! gets reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
- call meshfem3D_models_get1D_val(myrank,iregion_code, &
- idoubling(ispec), &
- r,rho,vpv,vph,vsv,vsh,eta_aniso, &
- Qkappa,Qmu,RICB,RCMB, &
- RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
- RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- ! calculates isotropic values
- vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
- + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
- vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
- + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
-
- if( abs(rhostore(i,j,k,ispec))< 1.e-20 ) then
- print*,' attention: rhostore close to zero', &
- rhostore(i,j,k,ispec),r,i,j,k,ispec
- dvp = 0.0
- dvs = 0.0
- else if( abs(sngl(vp))< 1.e-20 ) then
- print*,' attention: vp close to zero',sngl(vp),r,i,j,k,ispec
- dvp = 0.0
- else if( abs(sngl(vs))< 1.e-20 ) then
- print*,' attention: vs close to zero',sngl(vs),r,i,j,k,ispec
- dvs = 0.0
- else
- dvp = dvp + (sqrt((kappavstore(i,j,k,ispec) &
- + 4.*muvstore(i,j,k,ispec)/3.) &
- / rhostore(i,j,k,ispec)) - sngl(vp))/sngl(vp)
- dvs = dvs &
- + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) &
- - sngl(vs))/sngl(vs)
- endif
-
- enddo
- enddo
- enddo
- dvp = dvp / np
- dvs = dvs / np
- else
- dvp = 0.0
- dvs = 0.0
- endif
- endif
-
- ! top face
- ispecface = ispecface + 1
- avs_dx_adios%idoubling(ispecface) = idoubling(ispec)
- avs_dx_adios%iglob1(ispecface) = num_ibool_AVS_DX(iglobval(5))
- avs_dx_adios%iglob2(ispecface) = num_ibool_AVS_DX(iglobval(6))
- avs_dx_adios%iglob3(ispecface) = num_ibool_AVS_DX(iglobval(7))
- avs_dx_adios%iglob4(ispecface) = num_ibool_AVS_DX(iglobval(8))
- if(ISOTROPIC_3D_MANTLE) then
- avs_dx_adios%dvp(ispecface) = dvp
- avs_dx_adios%dvs(ispecface) = dvs
- endif
-
- endif
- enddo
-
- ! check that number of surface elements output is okay
- if(ispecface /= nspecface) &
- call exit_MPI(myrank,'&
- incorrect number of surface elements in AVS or DX file creation')
-
-end subroutine prepare_AVS_DX_surfaces_data_adios
-
-!===============================================================================
-subroutine write_AVS_DX_surfaces_data_adios(adios_handle, myrank, &
- sizeprocs, avs_dx_adios, ISOTROPIC_3D_MANTLE)
- use mpi
- use adios_write_mod
- implicit none
- !--- Arguments
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: myrank, sizeprocs
- type(avs_dx_surface_t), intent(inout) :: avs_dx_adios ! out for adios_write
- logical ISOTROPIC_3D_MANTLE
- !--- Variables
- integer :: npoin, nspec
- integer :: ierr
-
- npoin = avs_dx_adios%npoin
- nspec = avs_dx_adios%nspecface
-
- call adios_set_path(adios_handle, "points_surfaces/x_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%x_adios, ierr)
-
- call adios_set_path(adios_handle, "points_surfaces/y_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%y_adios, ierr)
-
- call adios_set_path(adios_handle, "points_surfaces/z_value", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- npoin, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%z_adios, ierr)
-
-
- call adios_set_path(adios_handle, "elements_surfaces/idoubling", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%idoubling, ierr)
-
-
- call adios_set_path(adios_handle, &
- "elements_surfaces/num_ibool_AVS_DX_iglob1", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob1, ierr)
-
- call adios_set_path(adios_handle, &
- "elements_surfaces/num_ibool_AVS_DX_iglob2", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob2, ierr)
-
- call adios_set_path(adios_handle, &
- "elements_surfaces/num_ibool_AVS_DX_iglob3", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob3, ierr)
-
- call adios_set_path(adios_handle, &
- "elements_surfaces/num_ibool_AVS_DX_iglob4", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%iglob4, ierr)
-
-
- if(ISOTROPIC_3D_MANTLE) then
- call adios_set_path(adios_handle, "elements_surfaces/dvp", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%dvp, ierr)
- call adios_set_path(adios_handle, "elements_surfaces/dvs", ierr)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- nspec, sizeprocs)
- call adios_write(adios_handle, "array", avs_dx_adios%dvs, ierr)
- endif
-end subroutine write_AVS_DX_surfaces_data_adios
-
-!===============================================================================
-subroutine free_AVS_DX_surfaces_data_adios(myrank, avs_dx_adios, &
- ISOTROPIC_3D_MANTLE)
- implicit none
- !--- Arguments
- integer, intent(in) :: myrank
- type(avs_dx_surface_t), intent(inout) :: avs_dx_adios
- logical ISOTROPIC_3D_MANTLE
- !--- Variables
- !--- Variables
- integer :: ierr
-
- deallocate(avs_dx_adios%x_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating x_adios.")
- deallocate(avs_dx_adios%y_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating y_adios.")
- deallocate(avs_dx_adios%z_adios, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, "Error deallocating z_adios.")
-
- deallocate(avs_dx_adios%idoubling, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob1.")
- deallocate(avs_dx_adios%iglob1, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob1.")
- deallocate(avs_dx_adios%iglob2, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob2.")
- deallocate(avs_dx_adios%iglob3, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob3.")
- deallocate(avs_dx_adios%iglob4, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating num_ibool_AVS_DX_iglob4.")
-
- if(ISOTROPIC_3D_MANTLE) then
- deallocate(avs_dx_adios%dvp, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating dvp.")
- deallocate(avs_dx_adios%dvs, stat=ierr)
- if (ierr /= 0) call exit_MPI(myrank, &
- "Error deallocating dvs.")
- endif
-
- avs_dx_adios%npoin = 0
- avs_dx_adios%nspecface = 0
-end subroutine free_AVS_DX_surfaces_data_adios
-
-
-end module
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/adios_helpers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/adios_helpers.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/adios_helpers.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,356 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
-!-------------------------------------------------------------------------------
-!> \file adios_helpers.f90
-!! \brief Helpers to set up adios features.
-!! \author MPBL
-!-------------------------------------------------------------------------------
-
-!===============================================================================
-!> Get the ADIOS error message from an adios error number if there is an error.
-!! \param adios_err The error code considered.
-subroutine check_adios_err(myrank, adios_err)
- use adios_read_mod
- implicit none
- integer, intent(in) :: myrank, adios_err
- character(len=1024) :: msg
-
- if (adios_err /= 0) then
- call adios_errmsg(msg)
- print *, "process: ", myrank, ", error: ", msg
- stop
- endif
-end subroutine check_adios_err
-
-
-!===============================================================================
-!> Define an ADIOS scalar double precision variable and autoincrement
-!! the adios group size by (8).
-!! \param adios_group The adios group where the variables belongs
-!! \param name The variable to be defined
-!! \param path The logical path structuring the data and containing
-!! the variable
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-subroutine define_adios_double_scalar (adios_group, name, path, group_size_inc)
- use adios_write_mod
- implicit none
- ! Arguments
- integer(kind=8), intent(in) :: adios_group
- character(len=*), intent(in) :: name, path
- integer(kind=8), intent(inout) :: group_size_inc
- ! Local Variables
- integer(kind=8) :: varid ! dummy variable, adios use var name
-
- ! adios: 6 == real(kind=8)
- call adios_define_var (adios_group, name, path, 6, "", "", "", varid)
- group_size_inc = group_size_inc + 8
-end subroutine define_adios_double_scalar
-
-!===============================================================================
-!> Define an ADIOS scalar integer variable and autoincrement the adios
-!! group size by (4).
-!! \param adios_group The adios group where the variables belongs
-!! \param name The variable to be defined
-!! \param path The logical path structuring the data and containing
-!! the variable
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-subroutine define_adios_integer_scalar (adios_group, name, path, group_size_inc)
- use adios_write_mod
- implicit none
- ! Arguments
- integer(kind=8), intent(in) :: adios_group
- character(len=*), intent(in) :: name, path
- integer(kind=8), intent(inout) :: group_size_inc
- ! Local Variables
- integer(kind=8) :: varid ! dummy variable, adios use var name
-
- ! adios: 2 == integer(kind=4)
- call adios_define_var (adios_group, name, path, adios_integer, "", "", "", varid)
- group_size_inc = group_size_inc + 4
-end subroutine define_adios_integer_scalar
-
-!===============================================================================
-!> Define an ADIOS scalar byte variable and autoincrement the adios
-!! group size by (1).
-!! \param adios_group The adios group where the variables belongs
-!! \param name The variable to be defined
-!! \param path The logical path structuring the data and containing
-!! the variable
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-subroutine define_adios_byte_scalar (adios_group, name, path, group_size_inc)
- use adios_write_mod
- implicit none
- ! Arguments
- integer(kind=8), intent(in) :: adios_group
- character(len=*), intent(in) :: name, path
- integer(kind=8), intent(inout) :: group_size_inc
- ! Local Variables
- integer(kind=8) :: varid ! dummy variable, adios use var name
-
- ! adios: 0 == byte == any_data_type(kind=1)
- call adios_define_var (adios_group, name, path, 0, "", "", "", varid)
- group_size_inc = group_size_inc + 1
-end subroutine define_adios_byte_scalar
-
-!===============================================================================
-!> Define a local ADIOS array of integers and autoincrement the adios
-!! group size by (4 * number of elements).
-!! \param adios_group The adios group where the variables belongs
-!! \param name The variable to be defined
-!! \param path The logical path structuring the data and containing
-!! the variable
-!! \param dim The number of elements in the 1D array. Required to
-!! correctly increment adios group size.
-!! \param dim_str The "stringified" version of dim. Needed by adios
-!! to define variables
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-subroutine define_adios_integer_local_array1D (adios_group, name, path, dim, dim_str, group_size_inc)
- use adios_write_mod
- implicit none
- ! Arguments
- integer(kind=8), intent(in) :: adios_group
- character(len=*), intent(in) :: name, path, dim_str
- integer(kind=8), intent(inout) :: group_size_inc
- integer, intent(in) :: dim
- ! Local Variables
- integer(kind=8) :: varid ! dummy variable, adios use var name
-
- ! adios: 2 == integer
- call adios_define_var (adios_group, name, path, 2, dim_str, "", "", varid)
- group_size_inc = group_size_inc + 4*dim
-end subroutine define_adios_integer_local_array1D
-
-!===============================================================================
-!> Define a local ADIOS array of doubles and autoincrement the adios
-!! group size by (8 * number of elements).
-!! \param adios_group The adios group where the variables belongs
-!! \param name The variable to be defined
-!! \param path The logical path structuring the data and containing
-!! the variable
-!! \param dim The number of elements in the 1D array. Required to
-!! correctly increment adios group size.
-!! \param dim_str The "stringified" version of dim. Needed by adios
-!! to define variables
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-subroutine define_adios_double_local_array1D (adios_group, name, path, dim, dim_str, group_size_inc)
- use adios_write_mod
- implicit none
- ! Arguments
- integer(kind=8), intent(in) :: adios_group
- character(len=*), intent(in) :: name, path, dim_str
- integer(kind=8), intent(inout) :: group_size_inc
- integer, intent(in) :: dim
- ! Local Variables
- integer(kind=8) :: varid ! dummy variable, adios use var name
-
- ! adios: 6 == real(kind=8)
- call adios_define_var (adios_group, name, path, 6, dim_str, "", "", varid)
- group_size_inc = group_size_inc + 8*dim
-end subroutine define_adios_double_local_array1D
-
-!===============================================================================
-!> Define a local ADIOS string and autoincrement the adios
-!! group size by (1 * string's length).
-!! \param adios_group The adios group where the variables belongs
-!! \param name The variable to be defined
-!! \param path The logical path structuring the data and containing
-!! the variable
-!! \param len The length of the string(number of character. in Fortran
-!! it does not include a final '\0' -- null -- character)
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-!! \note Adios string are scalar values counting for (1) byte. It is
-!! mandatory to increase the group size by the length of the
-!! string in order not to overlap 'data regions'.
-subroutine define_adios_string (adios_group, name, path, length, group_size_inc)
- use adios_write_mod
- implicit none
- ! Arguments
- integer(kind=8), intent(in) :: adios_group
- character(len=*), intent(in) :: name, path
- integer(kind=8), intent(inout) :: group_size_inc
- integer :: length
- ! Local Variables
- integer(kind=8) :: varid ! dummy variable, adios use var name
-
- ! adios: 9 == string
- call adios_define_var (adios_group, name, path, 9, "", "", "", varid)
- group_size_inc = group_size_inc + 1*length
-end subroutine define_adios_string
-
-!===============================================================================
-!> Define a global ADIOS 1D real array and autoincrement the adios
-!! group size.
-!! \param adios_group The adios group where the variables belongs
-!! \param array_name The variable to be defined. This is actually the path for
-!! ADIOS. The values are stored in array_name/array
-!! \param len The local dimension of the array.
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-!! \note This function define local, global and offset sizes as well as the
-!! array to store the values in.
-subroutine define_adios_global_real_1d_array(adios_group, array_name, &
- local_dim, group_size_inc)
- use adios_write_mod
- implicit none
- ! Parameters
- integer(kind=8), intent(in) :: adios_group
- character(len=*), intent(in) :: array_name
- integer, intent(in) :: local_dim
- integer(kind=8), intent(inout) :: group_size_inc
- ! Variables
- integer(kind=8) :: var_id
-
- call define_adios_integer_scalar (adios_group, "local_dim", array_name, &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "global_dim", array_name, &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "offset", array_name, &
- group_size_inc)
-! call adios_define_var(adios_group, "array", array_name, 6, &
-! "local_dim", "global_dim", "offset", var_id)
- call adios_define_var(adios_group, "array", array_name, 5, &
- array_name // "/local_dim", array_name // "/global_dim", &
- array_name // "/offset", var_id)
- group_size_inc = group_size_inc + local_dim*4
-end subroutine define_adios_global_real_1d_array
-
-!===============================================================================
-!> Define a global ADIOS 1D integer array and autoincrement the adios
-!! group size.
-!! \param adios_group The adios group where the variables belongs
-!! \param array_name The variable to be defined. This is actually the path for
-!! ADIOS. The values are stored in array_name/array
-!! \param len The local dimension of the array.
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-!! \note This function define local, global and offset sizes as well as the
-!! array to store the values in.
-subroutine define_adios_global_integer_1d_array(adios_group, array_name, &
- local_dim, group_size_inc)
- use adios_write_mod
- implicit none
- ! Parameters
- integer(kind=8), intent(in) :: adios_group
- character(len=*), intent(in) :: array_name
- integer, intent(in) :: local_dim
- integer(kind=8), intent(inout) :: group_size_inc
- ! Variables
- integer(kind=8) :: var_id
-
- call define_adios_integer_scalar (adios_group, "local_dim", array_name, &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "global_dim", array_name, &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "offset", array_name, &
- group_size_inc)
-! call adios_define_var(adios_group, "array", array_name, 6, &
-! "local_dim", "global_dim", "offset", var_id)
- call adios_define_var(adios_group, "array", array_name, 2, &
- array_name // "/local_dim", array_name // "/global_dim", &
- array_name // "/offset", var_id)
- group_size_inc = group_size_inc + local_dim*4
-end subroutine define_adios_global_integer_1d_array
-
-!===============================================================================
-!> Define a global ADIOS 1D logical array and autoincrement the adios
-!! group size.
-!! \param adios_group The adios group where the variables belongs
-!! \param array_name The variable to be defined. This is actually the path for
-!! ADIOS. The values are stored in array_name/array
-!! \param len The local dimension of the array.
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-!! \note This function define local, global and offset sizes as well as the
-!! array to store the values in.
-subroutine define_adios_global_logical_1d_array(adios_group, array_name, &
- local_dim, group_size_inc)
- use adios_write_mod
- implicit none
- ! Parameters
- integer(kind=8), intent(in) :: adios_group
- character(len=*), intent(in) :: array_name
- integer, intent(in) :: local_dim
- integer(kind=8), intent(inout) :: group_size_inc
- ! Variables
- integer(kind=8) :: var_id
-
- call define_adios_integer_scalar (adios_group, "local_dim", array_name, &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "global_dim", array_name, &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "offset", array_name, &
- group_size_inc)
-! call adios_define_var(adios_group, "array", array_name, 6, &
-! "local_dim", "global_dim", "offset", var_id)
- call adios_define_var(adios_group, "array", array_name, 1, &
- array_name // "/local_dim", array_name // "/global_dim", &
- array_name // "/offset", var_id)
- group_size_inc = group_size_inc + local_dim*1
-end subroutine define_adios_global_logical_1d_array
-
-!===============================================================================
-!> Define a global ADIOS 1D real array and autoincrement the adios
-!! group size.
-!! \param adios_group The adios group where the variables belongs
-!! \param array_name The variable to be defined. This is actually the path for
-!! ADIOS. The values are stored in array_name/array
-!! \param len The local dimension of the array.
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-!! \note This function define local, global and offset sizes as well as the
-!! array to store the values in.
-subroutine define_adios_global_double_1d_array(adios_group, array_name, &
- local_dim, group_size_inc)
- use adios_write_mod
- implicit none
- ! Parameters
- integer(kind=8), intent(in) :: adios_group
- character(len=*), intent(in) :: array_name
- integer, intent(in) :: local_dim
- integer(kind=8), intent(inout) :: group_size_inc
- ! Variables
- integer(kind=8) :: var_id
-
- call define_adios_integer_scalar (adios_group, "local_dim", array_name, &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "global_dim", array_name, &
- group_size_inc)
- call define_adios_integer_scalar (adios_group, "offset", array_name, &
- group_size_inc)
- call adios_define_var(adios_group, "array", array_name, 6, &
- array_name // "/local_dim", array_name // "/global_dim", &
- array_name // "/offset", var_id)
- group_size_inc = group_size_inc + local_dim*8
-end subroutine define_adios_global_double_1d_array
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/adios_manager.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/adios_manager.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/adios_manager.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,51 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!> @brief Initialize ADIOS and setup the xml output file
-subroutine adios_setup()
- use adios_write_mod, only: adios_init
-
- implicit none
- integer :: adios_err, sizeMB
-
- call adios_init_noxml (adios_err);
- sizeMB = 200 ! TODO 200MB is surely not the right size for the adios buffer
- call adios_allocate_buffer (sizeMB , adios_err)
-end subroutine adios_setup
-
-!> @brief Finalize ADIOS. Must be called once everything is written down.
-subroutine adios_cleanup()
- use mpi
- use adios_write_mod, only: adios_finalize
-
- implicit none
- integer :: myrank
- integer :: adios_err, ierr
-
- call MPI_Comm_rank(MPI_COMM_WORLD, myrank, ierr)
- call adios_finalize (myrank, adios_err)
-end subroutine adios_cleanup
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/check_simulation_stability.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/check_simulation_stability.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/check_simulation_stability.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -109,8 +109,7 @@
write(IMAIN,*) 'Max non-dimensional potential Ufluid in fluid in all slices for back prop.= ',Ufluidnorm_all
endif
-!! DK DK for UNDO_ATTENUATION
-
+ ! this is in the case of restart files, when a given run consists of several partial runs
! information about the current run only
SHOW_SEPARATE_RUN_INFORMATION = NUMBER_OF_RUNS > 1 .and. NUMBER_OF_THIS_RUN < NUMBER_OF_RUNS
it_run = it - it_begin + 1
@@ -267,7 +266,7 @@
write(IMAIN,*)
! write time stamp file to give information about progression of simulation
-!! DK DK UNDO_ATTENUATION
+!! DK DK for UNDO_ATTENUATION
if(SIMULATION_TYPE == 1) then
! write(outputname,"('/timestamp',i6.6)") it
write(outputname,"('/timestamp_forward',i6.6)") it
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_add_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_add_sources.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_add_sources.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -61,11 +61,12 @@
double precision :: stf
real(kind=CUSTOM_REAL) :: stf_used
integer :: isource,i,j,k,iglob,ispec
+ double precision :: f0
+
double precision, external :: comp_source_time_function
- double precision :: f0
double precision, external :: comp_source_time_function_rickr
-!for LDDRK
+! for LDDRK
integer :: istage
do isource = 1,NSOURCES
@@ -253,71 +254,70 @@
do i=1,NGLLX
iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec))
+ ! adds adjoint source acting at this time step (it):
+ !
+ ! note: we use index iadj_vec(it) which is the corresponding time step
+ ! for the adjoint source acting at this time step (it)
+ !
+ ! see routine: setup_sources_receivers_adjindx() how this adjoint index array is set up
+ !
+ ! e.g. total length NSTEP = 3000, chunk length NTSTEP_BETWEEN_READ_ADJSRC= 1000
+ ! then for it=1,..1000, first block has iadjsrc(1,1) with start = 2001 and end = 3000;
+ ! corresponding iadj_vec(it) goes from
+ ! iadj_vec(1) = 1000, iadj_vec(2) = 999 to iadj_vec(1000) = 1,
+ ! that is, originally the idea was
+ ! adj_sourcearrays(.. iadj_vec(1) ) corresponds to adjoint source trace at time index 3000
+ ! adj_sourcearrays(.. iadj_vec(2) ) corresponds to adjoint source trace at time index 2999
+ ! ..
+ ! adj_sourcearrays(.. iadj_vec(1000) ) corresponds to adjoint source trace at time index 2001
+ ! then a new block will be read, etc, and it is going down till to adjoint source trace at time index 1
+ !
+ ! now comes the tricky part:
+ ! adjoint source traces are based on the seismograms from the forward run;
+ ! such seismograms have a time step index 1 which corresponds to time -t0
+ ! then time step index 2 which corresponds to -t0 + DT, and
+ ! the last time step in the file at time step NSTEP corresponds to time -t0 + (NSTEP-1)*DT
+ ! (see how we add the sources to the simulation in compute_add_sources() and
+ ! how we write/save the seismograms and wavefields at the end of the time loop).
+ !
+ ! then you use that seismogram and take e.g. the velocity of it for a travetime adjoint source
+ !
+ ! now we read it in again, and remember the last time step in
+ ! the file at NSTEP corresponds to -t0 + (NSTEP-1)*DT
+ !
+ ! the same time step is saved for the forward wavefields to reconstruct them;
+ ! however, the Newmark time scheme acts at the very beginning of this time loop
+ ! such that we have the backward/reconstructed wavefield updated by
+ ! a single time step into the direction -DT and b_displ(it=1) would corresponds to -t0 + (NSTEP-1)*DT - DT
+ ! after the Newmark (predictor) time step update.
+ ! however, we will read the backward/reconstructed wavefield at the end of the first time loop,
+ ! such that b_displ(it=1) corresponds to -t0 + (NSTEP-1)*DT (which is the one saved in the files).
+ !
+ ! for the kernel calculations, we want:
+ ! adjoint wavefield at time t, starting from 0 to T
+ ! and forward wavefield at time T-t, starting from T down to 0
+ ! let's say time 0 corresponds to -t0 = -t0 + (it - 1)*DT at it=1
+ ! and time T corresponds to -t0 + (NSTEP-1)*DT at it = NSTEP
+ !
+ ! as seen before, the time for the forward wavefield b_displ(it=1) would then
+ ! correspond to time -t0 + (NSTEP-1)*DT - DT, which is T - DT.
+ ! the corresponding time for the adjoint wavefield thus would be 0 + DT
+ ! and the adjoint source index would be iadj_vec(it+1)
+ ! however, iadj_vec(it+1) which would go from 999 down to 0. 0 is out of bounds.
+ ! we thus would have to read in the adjoint source trace beginning from 2999 down to 0.
+ ! index 0 is not defined in the adjoint source trace, and would be set to zero.
+ !
+ ! however, since this complicates things, we read the backward/reconstructed
+ ! wavefield at the end of the first time loop, such that b_displ(it=1) corresponds to -t0 + (NSTEP-1)*DT.
+ ! assuming that until that end the backward/reconstructed wavefield and adjoint fields
+ ! have a zero contribution to adjoint kernels.
+ accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
+ + adj_sourcearrays(:,i,j,k,irec_local,iadj_vec(it))
- ! adds adjoint source acting at this time step (it):
- !
- ! note: we use index iadj_vec(it) which is the corresponding time step
- ! for the adjoint source acting at this time step (it)
- !
- ! see routine: setup_sources_receivers_adjindx() how this adjoint index array is set up
- !
- ! e.g. total length NSTEP = 3000, chunk length NTSTEP_BETWEEN_READ_ADJSRC= 1000
- ! then for it=1,..1000, first block has iadjsrc(1,1) with start = 2001 and end = 3000;
- ! corresponding iadj_vec(it) goes from
- ! iadj_vec(1) = 1000, iadj_vec(2) = 999 to iadj_vec(1000) = 1,
- ! that is, originally the idea was
- ! adj_sourcearrays(.. iadj_vec(1) ) corresponds to adjoint source trace at time index 3000
- ! adj_sourcearrays(.. iadj_vec(2) ) corresponds to adjoint source trace at time index 2999
- ! ..
- ! adj_sourcearrays(.. iadj_vec(1000) ) corresponds to adjoint source trace at time index 2001
- ! then a new block will be read, etc, and it is going down till to adjoint source trace at time index 1
- !
- ! now comes the tricky part:
- ! adjoint source traces are based on the seismograms from the forward run;
- ! such seismograms have a time step index 1 which corresponds to time -t0
- ! then time step index 2 which corresponds to -t0 + DT, and
- ! the last time step in the file at time step NSTEP corresponds to time -t0 + (NSTEP-1)*DT
- ! (see how we add the sources to the simulation in compute_add_sources() and
- ! how we write/save the seismograms and wavefields at the end of the time loop).
- !
- ! then you use that seismogram and take e.g. the velocity of it for a travetime adjoint source
- !
- ! now we read it in again, and remember the last time step in
- ! the file at NSTEP corresponds to -t0 + (NSTEP-1)*DT
- !
- ! the same time step is saved for the forward wavefields to reconstruct them;
- ! however, the Newark time scheme acts at the very beginning of this time loop
- ! such that we have the backward/reconstructed wavefield updated by
- ! a single time step into the direction -DT and b_displ(it=1) would corresponds to -t0 + (NSTEP-1)*DT - DT
- ! after the Newark (predictor) time step update.
- ! however, we will read the backward/reconstructed wavefield at the end of the first time loop,
- ! such that b_displ(it=1) corresponds to -t0 + (NSTEP-1)*DT (which is the one saved in the files).
- !
- ! for the kernel calculations, we want:
- ! adjoint wavefield at time t, starting from 0 to T
- ! and forward wavefield at time T-t, starting from T down to 0
- ! let's say time 0 corresponds to -t0 = -t0 + (it - 1)*DT at it=1
- ! and time T corresponds to -t0 + (NSTEP-1)*DT at it = NSTEP
- !
- ! as seen before, the time for the forward wavefield b_displ(it=1) would then
- ! correspond to time -t0 + (NSTEP-1)*DT - DT, which is T - DT.
- ! the corresponding time for the adjoint wavefield thus would be 0 + DT
- ! and the adjoint source index would be iadj_vec(it+1)
- ! however, iadj_vec(it+1) which would go from 999 down to 0. 0 is out of bounds.
- ! we thus would have to read in the adjoint source trace beginning from 2999 down to 0.
- ! index 0 is not defined in the adjoint source trace, and would be set to zero.
- !
- ! however, since this complicates things, we read the backward/reconstructed
- ! wavefield at the end of the first time loop, such that b_displ(it=1) corresponds to -t0 + (NSTEP-1)*DT.
- ! assuming that until that end the backward/reconstructed wavefield and adjoint fields
- ! have a zero contribution to adjoint kernels.
- accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
- + adj_sourcearrays(:,i,j,k,irec_local,iadj_vec(it))
-
+ enddo
enddo
enddo
- enddo
- endif
+ endif
enddo
@@ -363,8 +363,9 @@
double precision :: stf
real(kind=CUSTOM_REAL) :: stf_used
integer :: isource,i,j,k,iglob,ispec
+ double precision :: f0
+
double precision, external :: comp_source_time_function
- double precision :: f0
double precision, external :: comp_source_time_function_rickr
do isource = 1,NSOURCES
@@ -442,4 +443,3 @@
end subroutine compute_add_sources_backward
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_arrays_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_arrays_source.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_arrays_source.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -26,43 +26,43 @@
!=====================================================================
subroutine compute_arrays_source(ispec_selected_source, &
- xi_source,eta_source,gamma_source,sourcearray, &
- Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- xigll,yigll,zigll,nspec)
+ xi_source,eta_source,gamma_source,sourcearray, &
+ Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ xigll,yigll,zigll,nspec)
implicit none
include "constants.h"
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+
integer ispec_selected_source,nspec
- double precision xi_source,eta_source,gamma_source
- double precision Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision :: xi_source,eta_source,gamma_source
+ double precision :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xix,xiy,xiz,etax,etay,etaz, &
gammax,gammay,gammaz
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
-
- double precision xixd,xiyd,xizd,etaxd,etayd,etazd,gammaxd,gammayd,gammazd
-
-! Gauss-Lobatto-Legendre points of integration and weights
+ ! Gauss-Lobatto-Legendre points of integration and weights
double precision, dimension(NGLLX) :: xigll
double precision, dimension(NGLLY) :: yigll
double precision, dimension(NGLLZ) :: zigll
-! source arrays
+ ! local parameters
+ double precision :: xixd,xiyd,xizd,etaxd,etayd,etazd,gammaxd,gammayd,gammazd
+ ! source arrays
double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
double precision, dimension(NGLLX,NGLLY,NGLLZ) :: G11,G12,G13,G21,G22,G23,G31,G32,G33
double precision, dimension(NGLLX) :: hxis,hpxis
double precision, dimension(NGLLY) :: hetas,hpetas
double precision, dimension(NGLLZ) :: hgammas,hpgammas
- integer k,l,m
+ integer :: k,l,m
-! calculate G_ij for general source location
-! the source does not necessarily correspond to a Gauss-Lobatto point
+ ! calculate G_ij for general source location
+ ! the source does not necessarily correspond to a Gauss-Lobatto point
do m=1,NGLLZ
do l=1,NGLLY
do k=1,NGLLX
@@ -117,7 +117,6 @@
!================================================================
-
subroutine compute_arrays_source_adjoint(myrank, adj_source_file, &
xi_receiver,eta_receiver,gamma_receiver, nu,adj_sourcearray, &
xigll,yigll,zigll,NSTEP_BLOCK,iadjsrc,it_sub_adj,NSTEP_SUB_ADJ, &
@@ -183,7 +182,7 @@
it_end = iadjsrc(it_sub_adj,1)+NSTEP_BLOCK-1
- ! unfortunately, things become more tricky because of the Newark time scheme at
+ ! unfortunately, things become more tricky because of the Newmark time scheme at
! the very beginning of the time loop. however, when we read in the backward/reconstructed
! wavefields at the end of the first time loop, we can use the adjoint source index from 3000 down to 1.
!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_boundary_kernel.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_boundary_kernel.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_boundary_kernel.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -27,7 +27,6 @@
subroutine compute_boundary_kernel(displ,accel,b_displ,nspec,iregion_code, &
ystore,zstore,ibool,ispec_is_tiso, &
- !--- idoubling, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz, &
rhostore,kappavstore,muvstore,kappahstore,muhstore,eta_anisostore, &
@@ -232,8 +231,7 @@
! ==========================================================================================
-
-subroutine compute_stress_from_strain(dsdx,sigma,i,j,k,ispec,iregion_code, &
+ subroutine compute_stress_from_strain(dsdx,sigma,i,j,k,ispec,iregion_code, &
kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
@@ -276,7 +274,6 @@
integer :: iglob
-
! --- precompute sum ---
duxdxl_plus_duydyl = dsdx(1,1) + dsdx(2,2)
@@ -635,6 +632,4 @@
sigma(3,1) = sigma(1,3)
sigma(3,2) = sigma(2,3)
-
-
end subroutine compute_stress_from_strain
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_coupling.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_coupling.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_coupling.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -26,11 +26,11 @@
!=====================================================================
subroutine compute_coupling_fluid_CMB(displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- nspec_top)
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ nspec_top)
implicit none
@@ -58,21 +58,20 @@
real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n,nx,ny,nz,weight
integer :: i,j,k,k_corresp,ispec,ispec2D,iglob_cm,iglob_oc,ispec_selected
-
! for surface elements exactly on the CMB
do ispec2D = 1,nspec_top !NSPEC2D_TOP(IREGION_OUTER_CORE)
ispec = ibelm_top_outer_core(ispec2D)
+ ispec_selected = ibelm_bottom_crust_mantle(ispec2D)
! only for DOFs exactly on the CMB (top of these elements)
k = NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- ! get displacement on the solid side using pointwise matching
- ispec_selected = ibelm_bottom_crust_mantle(ispec2D)
+ ! get displacement on the solid side using pointwise matching
+ k_corresp = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
! corresponding points are located at the bottom of the mantle
- k_corresp = 1
iglob_cm = ibool_crust_mantle(i,j,k_corresp,ispec_selected)
displ_x = displ_crust_mantle(1,iglob_cm)
@@ -142,18 +141,19 @@
! for surface elements exactly on the ICB
do ispec2D = 1, nspec_bottom ! NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
+
ispec = ibelm_bottom_outer_core(ispec2D)
+ ispec_selected = ibelm_top_inner_core(ispec2D)
! only for DOFs exactly on the ICB (bottom of these elements)
k = 1
+ ! get displacement on the solid side using pointwise matching
+ k_corresp = NGLLZ
+
do j = 1,NGLLY
do i = 1,NGLLX
- ! get displacement on the solid side using pointwise matching
- ispec_selected = ibelm_top_inner_core(ispec2D)
-
! corresponding points are located at the bottom of the mantle
- k_corresp = NGLLZ
iglob_ic = ibool_inner_core(i,j,k_corresp,ispec_selected)
displ_x = displ_inner_core(1,iglob_ic)
@@ -230,16 +230,15 @@
do ispec2D = 1,nspec_bottom ! NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
ispec = ibelm_bottom_crust_mantle(ispec2D)
+ ispec_selected = ibelm_top_outer_core(ispec2D)
! only for DOFs exactly on the CMB (bottom of these elements)
k = 1
+ ! get potential on the fluid side using pointwise matching
+ k_corresp = NGLLZ
+
do j = 1,NGLLY
do i = 1,NGLLX
-
- ! get velocity potential on the fluid side using pointwise matching
- ispec_selected = ibelm_top_outer_core(ispec2D)
- k_corresp = NGLLZ
-
! get normal at the CMB
nx = normal_top_outer_core(1,i,j,ispec2D)
ny = normal_top_outer_core(2,i,j,ispec2D)
@@ -247,14 +246,15 @@
! get global point number
! corresponding points are located at the top of the outer core
- iglob_oc = ibool_outer_core(i,j,NGLLZ,ispec_selected)
+ iglob_oc = ibool_outer_core(i,j,k_corresp,ispec_selected)
iglob_mantle = ibool_crust_mantle(i,j,k,ispec)
! compute pressure, taking gravity into account
if(GRAVITY_VAL) then
pressure = RHO_TOP_OC * (- accel_outer_core(iglob_oc) &
+ minus_g_cmb *(displ_crust_mantle(1,iglob_mantle)*nx &
- + displ_crust_mantle(2,iglob_mantle)*ny + displ_crust_mantle(3,iglob_mantle)*nz))
+ + displ_crust_mantle(2,iglob_mantle)*ny &
+ + displ_crust_mantle(3,iglob_mantle)*nz))
else
pressure = - RHO_TOP_OC * accel_outer_core(iglob_oc)
endif
@@ -319,16 +319,15 @@
do ispec2D = 1,nspec_top ! NSPEC2D_TOP(IREGION_INNER_CORE)
ispec = ibelm_top_inner_core(ispec2D)
+ ispec_selected = ibelm_bottom_outer_core(ispec2D)
! only for DOFs exactly on the ICB (top of these elements)
k = NGLLZ
+ ! get velocity potential on the fluid side using pointwise matching
+ k_corresp = 1
+
do j = 1,NGLLY
do i = 1,NGLLX
-
- ! get velocity potential on the fluid side using pointwise matching
- ispec_selected = ibelm_bottom_outer_core(ispec2D)
- k_corresp = 1
-
! get normal at the ICB
nx = normal_bottom_outer_core(1,i,j,ispec2D)
ny = normal_bottom_outer_core(2,i,j,ispec2D)
@@ -343,7 +342,7 @@
if(GRAVITY_VAL) then
pressure = RHO_BOTTOM_OC * (- accel_outer_core(iglob) &
+ minus_g_icb *(displ_inner_core(1,iglob_inner_core)*nx &
- + displ_inner_core(2,iglob_inner_core)*ny + displ_inner_core(3,iglob_inner_core)*nz))
+ + displ_inner_core(2,iglob_inner_core)*ny + displ_inner_core(3,iglob_inner_core)*nz))
else
pressure = - RHO_BOTTOM_OC * accel_outer_core(iglob)
endif
@@ -384,7 +383,7 @@
! mass matrices
!
- ! in the case of Stacey boundary conditions, add C*delta/2 contribution to the mass matrix
+ ! in the case of Stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
! on the Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
!
@@ -442,7 +441,6 @@
! make updated component of right-hand side
! we divide by rmass_crust_mantle() which is 1 / M
! we use the total force which includes the Coriolis term above
-
force_normal_comp = accel_crust_mantle(1,iglob)*nx / rmassx_crust_mantle(iglob) + &
accel_crust_mantle(2,iglob)*ny / rmassy_crust_mantle(iglob) + &
accel_crust_mantle(3,iglob)*nz / rmassz_crust_mantle(iglob)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_element.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_element.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_element.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -75,7 +75,7 @@
! to allow for optimization of cache access by compiler
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
- real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(vx,vy,vz,vnspec) :: one_minus_sum_beta
! gravity
double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
@@ -1092,8 +1092,8 @@
if(ATTENUATION_VAL .and. ( PARTIAL_PHYS_DISPERSION_ONLY .eqv. .false. ) ) then
! note: fortran passes pointers to array location, thus R_memory(1,1,...) should be fine
- call compute_element_att_stress( R_memory(1,1,i,j,k,ispec), &
- sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz)
+ call compute_element_att_stress(R_memory(1,1,i,j,k,ispec), &
+ sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz)
endif ! ATTENUATION_VAL
@@ -1643,7 +1643,7 @@
enddo
- end subroutine compute_element_strain_undo_att_Dev
+ end subroutine compute_element_strain_undo_att_Dev
!
!--------------------------------------------------------------------------------------------
@@ -1825,9 +1825,8 @@
enddo
enddo
-
-
end subroutine compute_element_strain_att_Dev
+
!=====================================================================
subroutine compute_element_strain_undo_att_noDev(ispec,nglob,nspec,displ,hprime_xx,hprime_yy,hprime_zz,ibool,&
@@ -1968,6 +1967,7 @@
enddo ! NGLLZ
end subroutine compute_element_strain_undo_att_noDev
+
!=====================================================================
subroutine compute_element_strain_att_noDev(ispec,nglob,nspec,displ,veloc,deltat,hprime_xx,hprime_yy,hprime_zz,ibool,&
@@ -2017,8 +2017,6 @@
real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
-
-
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_acoustic.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_acoustic.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_acoustic.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,347 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_forces_acoustic()
-
- use specfem_par
- use specfem_par_crustmantle,only: displ_crust_mantle,b_displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle
- use specfem_par_innercore,only: displ_inner_core,b_displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core
- use specfem_par_outercore
- implicit none
-
- ! local parameters
- real(kind=CUSTOM_REAL) :: time,b_time
- ! non blocking MPI
- ! iphase: iphase = 1 is for computing outer elements in the outer_core,
- ! iphase = 2 is for computing inner elements in the outer core (former icall parameter)
- integer :: iphase
- logical :: phase_is_inner
-
- ! compute internal forces in the fluid region
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
- else
- time = (dble(it-1)*DT-t0)*scale_t_inv
- endif
- if (SIMULATION_TYPE == 3) then
- ! note on backward/reconstructed wavefields:
- ! b_time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
- ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
- ! to a time (NSTEP - (it-1) - 1)*DT - t0
- ! for reconstructing the rotational contributions
- if(CUSTOM_REAL == SIZE_REAL) then
- b_time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
- else
- b_time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
- endif
- endif
-
- ! ****************************************************
- ! big loop over all spectral elements in the fluid
- ! ****************************************************
-
- ! distinguishes two runs: for elements on MPI interfaces, and elements within the partitions
- do iphase=1,2
-
- ! first, iphase == 1 for points on MPI interfaces (thus outer elements)
- ! second, iphase == 2 for points purely inside partition (thus inner elements)
- !
- ! compute all the outer elements first, then sends out non blocking MPI communication
- ! and continues computing inner elements (overlapping)
- if( iphase == 1 ) then
- phase_is_inner = .false.
- else
- phase_is_inner = .true.
- endif
-
- if( .not. GPU_MODE ) then
- ! on CPU
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- NSPEC_OUTER_CORE_ROTATION,NGLOB_OUTER_CORE, &
- A_array_rotation,B_array_rotation, &
- displ_outer_core,accel_outer_core, &
- div_displ_outer_core,phase_is_inner)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- NSPEC_OUTER_CORE_ROTATION,NGLOB_OUTER_CORE, &
- A_array_rotation,B_array_rotation, &
- displ_outer_core,accel_outer_core, &
- div_displ_outer_core,phase_is_inner)
- endif
-
- ! adjoint / kernel runs
- if (SIMULATION_TYPE == 3) then
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(b_time,b_deltat,b_two_omega_earth, &
- NSPEC_OUTER_CORE_ROT_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- b_A_array_rotation,b_B_array_rotation, &
- b_displ_outer_core,b_accel_outer_core, &
- b_div_displ_outer_core,phase_is_inner)
- else
- call compute_forces_outer_core(b_time,b_deltat,b_two_omega_earth, &
- NSPEC_OUTER_CORE_ROT_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- b_A_array_rotation,b_B_array_rotation, &
- b_displ_outer_core,b_accel_outer_core, &
- b_div_displ_outer_core,phase_is_inner)
- endif
- endif
-
- else
- ! on GPU
- ! includes both forward and adjoint/kernel simulations
- call compute_forces_outer_core_cuda(Mesh_pointer,iphase,time,b_time)
- endif
-
-
- ! computes additional contributions to acceleration field
- if( iphase == 1 ) then
-
- ! Stacey absorbing boundaries
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) call compute_stacey_outer_core()
-
- ! ****************************************************
- ! ********** add matching with solid part **********
- ! ****************************************************
- ! only for elements in first matching layer in the fluid
- if( .not. GPU_MODE ) then
- ! on CPU
- !---
- !--- couple with mantle at the top of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) &
- call compute_coupling_fluid_CMB(displ_crust_mantle,b_displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_OUTER_CORE))
-
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) &
- call compute_coupling_fluid_ICB(displ_inner_core,b_displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
-
- else
- ! on GPU
- !---
- !--- couple with mantle at the top of the outer core
- !---
- if( ACTUALLY_COUPLE_FLUID_CMB ) &
- call compute_coupling_fluid_cmb_cuda(Mesh_pointer)
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if( ACTUALLY_COUPLE_FLUID_ICB ) &
- call compute_coupling_fluid_icb_cuda(Mesh_pointer)
-
- endif
- endif ! iphase == 1
-
- ! assemble all the contributions between slices using MPI
- ! in outer core
- if( iphase == 1 ) then
- ! sends out MPI interface data (non-blocking)
-
- if(.NOT. GPU_MODE) then
- ! on CPU
- call assemble_MPI_scalar_s(NPROCTOT_VAL,NGLOB_OUTER_CORE, &
- accel_outer_core, &
- buffer_send_scalar_outer_core,buffer_recv_scalar_outer_core, &
- num_interfaces_outer_core,max_nibool_interfaces_oc, &
- nibool_interfaces_outer_core,ibool_interfaces_outer_core,&
- my_neighbours_outer_core, &
- request_send_scalar_oc,request_recv_scalar_oc)
- else
- ! on GPU
- ! outer core
- call assemble_MPI_scalar_send_cuda(NPROCTOT_VAL, &
- buffer_send_scalar_outer_core,buffer_recv_scalar_outer_core, &
- num_interfaces_outer_core,max_nibool_interfaces_oc, &
- nibool_interfaces_outer_core,&
- my_neighbours_outer_core, &
- request_send_scalar_oc,request_recv_scalar_oc, &
- 1) ! <-- 1 == fwd accel
- endif
-
- ! adjoint simulations
- if( SIMULATION_TYPE == 3 ) then
- if(.NOT. GPU_MODE) then
- ! on CPU
- call assemble_MPI_scalar_s(NPROCTOT_VAL,NGLOB_OUTER_CORE, &
- b_accel_outer_core, &
- b_buffer_send_scalar_outer_core,b_buffer_recv_scalar_outer_core, &
- num_interfaces_outer_core,max_nibool_interfaces_oc, &
- nibool_interfaces_outer_core,ibool_interfaces_outer_core,&
- my_neighbours_outer_core, &
- b_request_send_scalar_oc,b_request_recv_scalar_oc)
- else
- ! on GPU
- ! outer core
- call assemble_MPI_scalar_send_cuda(NPROCTOT_VAL, &
- b_buffer_send_scalar_outer_core,b_buffer_recv_scalar_outer_core, &
- num_interfaces_outer_core,max_nibool_interfaces_oc, &
- nibool_interfaces_outer_core,&
- my_neighbours_outer_core, &
- b_request_send_scalar_oc,b_request_recv_scalar_oc, &
- 3) ! <-- 3 == adjoint b_accel
- endif ! GPU
- endif ! SIMULATION_TYPE == 3
-
- else
- ! make sure the last communications are finished and processed
- ! waits for send/receive requests to be completed and assembles values
- if(.NOT. GPU_MODE) then
- ! on CPU
- call assemble_MPI_scalar_w(NPROCTOT_VAL,NGLOB_OUTER_CORE, &
- accel_outer_core, &
- buffer_recv_scalar_outer_core,num_interfaces_outer_core,&
- max_nibool_interfaces_oc, &
- nibool_interfaces_outer_core,ibool_interfaces_outer_core, &
- request_send_scalar_oc,request_recv_scalar_oc)
- else
- ! on GPU
- call assemble_MPI_scalar_write_cuda(NPROCTOT_VAL, &
- buffer_recv_scalar_outer_core, &
- num_interfaces_outer_core,max_nibool_interfaces_oc, &
- request_send_scalar_oc,request_recv_scalar_oc, &
- 1) ! <-- 1 == fwd accel
- endif
-
- ! adjoint simulations
- if( SIMULATION_TYPE == 3 ) then
- if(.NOT. GPU_MODE) then
- ! on CPU
- call assemble_MPI_scalar_w(NPROCTOT_VAL,NGLOB_OUTER_CORE, &
- b_accel_outer_core, &
- b_buffer_recv_scalar_outer_core,num_interfaces_outer_core,&
- max_nibool_interfaces_oc, &
- nibool_interfaces_outer_core,ibool_interfaces_outer_core, &
- b_request_send_scalar_oc,b_request_recv_scalar_oc)
- else
- ! on GPU
- call assemble_MPI_scalar_write_cuda(NPROCTOT_VAL, &
- b_buffer_recv_scalar_outer_core, &
- num_interfaces_outer_core,max_nibool_interfaces_oc, &
- b_request_send_scalar_oc,b_request_recv_scalar_oc, &
- 3) ! <-- 3 == adjoint b_accel
- endif
- endif ! SIMULATION_TYPE == 3
- endif ! iphase == 1
-
- enddo ! iphase
-
- ! Newmark time scheme:
- ! corrector terms for fluid parts
- ! (multiply by the inverse of the mass matrix and update velocity)
- if(.NOT. GPU_MODE) then
- ! on CPU
- call compute_forces_ac_update_veloc(NGLOB_OUTER_CORE,veloc_outer_core,accel_outer_core, &
- deltatover2,rmass_outer_core)
-
- ! adjoint / kernel runs
- if (SIMULATION_TYPE == 3) &
- call compute_forces_ac_update_veloc(NGLOB_OUTER_CORE_ADJOINT,b_veloc_outer_core,b_accel_outer_core, &
- b_deltatover2,rmass_outer_core)
-
- else
- ! on GPU
- call kernel_3_outer_core_cuda(Mesh_pointer, &
- deltatover2,SIMULATION_TYPE,b_deltatover2)
- endif
-
- end subroutine compute_forces_acoustic
-
-!=====================================================================
-
- subroutine compute_forces_ac_update_veloc(NGLOB,veloc_outer_core,accel_outer_core, &
- deltatover2,rmass_outer_core)
-
- use constants_solver,only: CUSTOM_REAL
-
-#ifdef _HANDOPT
- use specfem_par,only: imodulo_NGLOB_OUTER_CORE
-#endif
-
- implicit none
-
- integer :: NGLOB
-
- ! velocity potential
- real(kind=CUSTOM_REAL), dimension(NGLOB) :: veloc_outer_core,accel_outer_core
-
- ! mass matrix
- real(kind=CUSTOM_REAL), dimension(NGLOB) :: rmass_outer_core
-
- real(kind=CUSTOM_REAL) :: deltatover2
-
- ! local parameters
- integer :: i
-
- ! Newmark time scheme
- ! multiply by the inverse of the mass matrix and update velocity
-
-#ifdef _HANDOPT_NEWMARK
-! way 2:
- ! outer core
- if(imodulo_NGLOB_OUTER_CORE >= 1) then
- do i=1,imodulo_NGLOB_OUTER_CORE
- accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
- enddo
- endif
- do i=imodulo_NGLOB_OUTER_CORE+1,NGLOB,3
- accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
-
- accel_outer_core(i+1) = accel_outer_core(i+1)*rmass_outer_core(i+1)
- veloc_outer_core(i+1) = veloc_outer_core(i+1) + deltatover2*accel_outer_core(i+1)
-
- accel_outer_core(i+2) = accel_outer_core(i+2)*rmass_outer_core(i+2)
- veloc_outer_core(i+2) = veloc_outer_core(i+2) + deltatover2*accel_outer_core(i+2)
- enddo
-#else
-! way 1:
- do i=1,NGLOB
- accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
- enddo
-#endif
-
- end subroutine compute_forces_ac_update_veloc
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -98,7 +98,6 @@
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store
- ! attenuation
! memory variables for attenuation
! memory variables R_ij are stored at the local rather than global level
! to allow for optimization of cache access by compiler
@@ -165,11 +164,8 @@
! for gravity
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
- integer :: ispec
- integer :: i,j,k
- integer :: iglob1
+ integer :: ispec,i,j,k,iglob1
-
! this for non blocking MPI
integer :: iphase,icall
@@ -239,46 +235,12 @@
! big loop over all spectral elements in the solid
! ****************************************************
-!$OMP PARALLEL DEFAULT(NONE) SHARED(xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
-!$OMP one_minus_sum_beta,epsilon_trace_over_3,c11store,c12store,c13store,c14store,c15store, &
-!$OMP c16store,c22store,c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
-!$OMP c36store,c44store,c45store,c46store,c55store,c56store,c66store,ispec_is_tiso, &
-!$OMP kappavstore,muvstore,kappahstore,muhstore,eta_anisostore,ibool,ystore,zstore, &
-!$OMP R_memory,xstore,minus_gravity_table,minus_deriv_gravity_table,density_table, &
-!$OMP displ_crust_mantle,wgll_cube,accel_inner_core,hprime_xxt,hprime_xx,idoubling_inner_core, &
-!$OMP addressing,iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,vx,vy,vz,vnspec, &
-!$OMP iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle,npoin2D_faces_crust_mantle, &
-!$OMP npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle,iboolfaces_crust_mantle,iboolcorner_crust_mantle,iboolleft_xi_inner_core, &
-!$OMP iboolright_xi_inner_core,ibool_inner_core, &
-!$OMP iboolleft_eta_inner_core,iboolright_eta_inner_core,npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
-!$OMP iboolfaces_inner_core,accel_crust_mantle, &
-!$OMP iboolcorner_inner_core,iprocfrom_faces,iprocto_faces,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-!$OMP buffer_send_faces,buffer_received_faces, &
-!$OMP buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
-!$OMP sender_from_slices_to_cube,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
-!$OMP ibelm_bottom_inner_core,hprimewgll_xx,hprimewgll_xxt,wgllwgll_xy,wgllwgll_xz, &
-!$OMP wgllwgll_yz,INCLUDE_CENTRAL_CUBE,alphaval,betaval,epsilondev,gammaval,factor_common, &
-!$OMP myrank,ichunk,iphase,iphase_CC,icall,iproc_xi,iproc_eta,is_on_a_slice_edge_crust_mantle, &
-!$OMP npoin2D_cube_from_slices,nb_msgs_theor_in_cube,receiver_cube_from_slices, &
-!$OMP npoin2D_max_all_CM_IC ) &
-!$OMP PRIVATE(k,j,ispec,fac1,fac2,fac3,sum_terms,iend,ispec_glob, &
-!$OMP C1_mxm_m2_m1_5points,A1_mxm_m2_m1_5points,B2_m1_m2_5points,C3_m1_m2_5points, &
-!$OMP B3_m1_m2_5points,C2_mxm_m2_m1_5points,E1_m1_m2_5points,E2_m1_m2_5points,A2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points, &
-!$OMP A3_mxm_m2_m1_5points,B1_m1_m2_5points, &
-!$OMP C2_m1_m2_5points,C1_m1_m2_5points,E3_m1_m2_5points,E1_mxm_m2_m1_5points,E2_mxm_m2_m1_5points,E3_mxm_m2_m1_5points, &
-!$OMP tempx1,tempx2,tempx3, &
-!$OMP newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3, &
-!$OMP dummyx_loc,dummyy_loc,dummyz_loc,rho_s_H,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
-!$OMP iglob1,epsilondev_loc)
-
do ispec_glob = 1,NSPEC_CRUST_MANTLE,ELEMENTS_NONBLOCKING_CM_IC
! process the non-blocking communications every ELEMENTS_NONBLOCKING elements
if (icall == 2) then
if(iphase <= 7) then
-!$OMP BARRIER
-!$OMP MASTER
call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
iproc_xi,iproc_eta,ichunk,addressing, &
iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
@@ -294,20 +256,14 @@
NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_CM, &
NGLOB1D_RADIAL_IC,NCHUNKS_VAL,iphase)
-!$OMP END MASTER
-!$OMP BARRIER
endif
if(INCLUDE_CENTRAL_CUBE) then
if(iphase > 7 .and. iphase_CC <= 4) then
-!$OMP BARRIER
-!$OMP MASTER
call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,accel_inner_core,NDIM,iphase_CC)
-!$OMP END MASTER
-!$OMP BARRIER
endif
endif
@@ -315,7 +271,6 @@
iend = min(ispec_glob+ELEMENTS_NONBLOCKING_CM_IC-1,NSPEC_CRUST_MANTLE)
-!$OMP DO SCHEDULE(runtime)
do ispec=ispec_glob,iend
! hide communications by computing the edges first
@@ -328,129 +283,131 @@
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
- iglob1 = ibool(i,j,k,ispec)
- dummyx_loc(i,j,k) = displ_crust_mantle(1,iglob1)
- dummyy_loc(i,j,k) = displ_crust_mantle(2,iglob1)
- dummyz_loc(i,j,k) = displ_crust_mantle(3,iglob1)
+ iglob1 = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ_crust_mantle(1,iglob1)
+ dummyy_loc(i,j,k) = displ_crust_mantle(2,iglob1)
+ dummyz_loc(i,j,k) = displ_crust_mantle(3,iglob1)
enddo
enddo
enddo
do j=1,m2
- do i=1,m1
- C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B1_m1_m2_5points(5,j)
+ do i=1,m1
+ C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B1_m1_m2_5points(5,j)
- C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B2_m1_m2_5points(5,j)
+ C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B2_m1_m2_5points(5,j)
- C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B3_m1_m2_5points(5,j)
- enddo
+ C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B3_m1_m2_5points(5,j)
+ enddo
enddo
do j=1,m1
- do i=1,m1
- ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyx_loc(i,5,k)*hprime_xxT(5,j)
+ do i=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyx_loc(i,5,k)*hprime_xxT(5,j)
- tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyy_loc(i,5,k)*hprime_xxT(5,j)
+ tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyy_loc(i,5,k)*hprime_xxT(5,j)
- tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyz_loc(i,5,k)*hprime_xxT(5,j)
- enddo
- enddo
+ tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ enddo
+ enddo
enddo
do j=1,m1
- do i=1,m2
- C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ do i=1,m2
+ C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- enddo
+ C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ enddo
enddo
!
! compute either isotropic, transverse isotropic or anisotropic elements
!
if(ANISOTROPIC_3D_MANTLE_VAL) then
- ! anisotropic element
- call compute_element_aniso(ispec, &
- minus_gravity_table,density_table,minus_deriv_gravity_table, &
- xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- wgll_cube, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ibool, &
- R_memory, &
- one_minus_sum_beta,vx,vy,vz,vnspec, &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
- dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
+ ! anisotropic element
+
+ call compute_element_aniso(ispec, &
+ minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ wgll_cube, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ ibool, &
+ R_memory, &
+ one_minus_sum_beta,vx,vy,vz,vnspec, &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
+ dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
else
- if( .not. ispec_is_tiso(ispec) ) then
- ! isotropic element
- call compute_element_iso(ispec, &
- minus_gravity_table,density_table,minus_deriv_gravity_table, &
- xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- wgll_cube, &
- kappavstore,muvstore, &
- ibool, &
- R_memory, &
- one_minus_sum_beta,vx,vy,vz,vnspec, &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
- dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
- else
- ! transverse isotropic element
- call compute_element_tiso(ispec, &
- minus_gravity_table,density_table,minus_deriv_gravity_table, &
- xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- wgll_cube, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- ibool, &
- R_memory, &
- one_minus_sum_beta,vx,vy,vz,vnspec, &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
- dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
- endif ! .not. ispec_is_tiso
+ if( .not. ispec_is_tiso(ispec) ) then
+ ! isotropic element
+ call compute_element_iso(ispec, &
+ minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ wgll_cube, &
+ kappavstore,muvstore, &
+ ibool, &
+ R_memory, &
+ one_minus_sum_beta,vx,vy,vz,vnspec, &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
+ dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ ! transverse isotropic element
+
+ call compute_element_tiso(ispec, &
+ minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ wgll_cube, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ ibool, &
+ R_memory, &
+ one_minus_sum_beta,vx,vy,vz,vnspec, &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
+ dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
+ endif ! .not. ispec_is_tiso
endif
! subroutines adapted from Deville, Fischer and Mund, High-order methods
@@ -459,22 +416,22 @@
do j=1,m2
do i=1,m1
E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
+ hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
+ hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
+ hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
enddo
enddo
@@ -483,22 +440,22 @@
! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
do k = 1,NGLLX
newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
- tempx2(i,2,k)*hprimewgll_xx(2,j) + &
- tempx2(i,3,k)*hprimewgll_xx(3,j) + &
- tempx2(i,4,k)*hprimewgll_xx(4,j) + &
- tempx2(i,5,k)*hprimewgll_xx(5,j)
+ tempx2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempx2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempx2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempx2(i,5,k)*hprimewgll_xx(5,j)
newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
- tempy2(i,2,k)*hprimewgll_xx(2,j) + &
- tempy2(i,3,k)*hprimewgll_xx(3,j) + &
- tempy2(i,4,k)*hprimewgll_xx(4,j) + &
- tempy2(i,5,k)*hprimewgll_xx(5,j)
+ tempy2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempy2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempy2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempy2(i,5,k)*hprimewgll_xx(5,j)
newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
- tempz2(i,2,k)*hprimewgll_xx(2,j) + &
- tempz2(i,3,k)*hprimewgll_xx(3,j) + &
- tempz2(i,4,k)*hprimewgll_xx(4,j) + &
- tempz2(i,5,k)*hprimewgll_xx(5,j)
+ tempz2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempz2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempz2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempz2(i,5,k)*hprimewgll_xx(5,j)
enddo
enddo
enddo
@@ -506,22 +463,22 @@
do j=1,m1
do i=1,m2
E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
enddo
enddo
@@ -575,21 +532,18 @@
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,epsilondev_loc_nplus1)
! updates R_memory
call compute_element_att_memory_cr(ispec,R_memory, &
- vx,vy,vz,vnspec,factor_common, &
- alphaval,betaval,gammaval, &
- c44store,muvstore, &
- epsilondev_loc_nplus1,epsilondev_loc,&
- istage,R_memory_lddrk,tau_sigma_CUSTOM_REAL,deltat)
+ vx,vy,vz,vnspec,factor_common, &
+ alphaval,betaval,gammaval, &
+ c44store,muvstore, &
+ epsilondev_loc_nplus1,epsilondev_loc,&
+ istage,R_memory_lddrk,tau_sigma_CUSTOM_REAL,deltat)
endif
! end ispec loop
enddo
-!$OMP enddo
-! end ispec_globe strided loop
enddo ! spectral element loop NSPEC_CRUST_MANTLE
-!$OMP END PARALLEL
end subroutine compute_forces_crust_mantle_Dev
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_elastic.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_elastic.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_elastic.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,856 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine compute_forces_elastic()
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore,only: accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- ibelm_top_outer_core,ibelm_bottom_outer_core, &
- ibool_outer_core
- use specfem_par_movie
- implicit none
-
- ! local parameters
- ! non blocking MPI
- ! iphase: iphase = 1 is for computing outer elements in the crust_mantle and inner_core regions,
- ! iphase = 2 is for computing inner elements (former icall parameter)
- integer :: iphase
- logical :: phase_is_inner
-
-
-!daniel: att - debug
-! integer :: iglob
-! logical,parameter :: DEBUG = .false.
-! if( DEBUG ) then
-! iglob = ibool_crust_mantle(1,1,1,100)
-! if( SIMULATION_TYPE == 1) then
-! if( it == NSTEP .and. myrank == 0 ) then
-! print*,'last step',it,'Rxx:',R_xx_crust_mantle(1,1,1,1,100),epsilondev_xx_crust_mantle(1,1,1,100), &
-! displ_crust_mantle(1,iglob),displ_crust_mantle(2,iglob),displ_crust_mantle(3,iglob)
-! endif
-! if( it == NSTEP-1 .and. myrank == 0 ) then
-! print*,'second last step',it,'Rxx:',R_xx_crust_mantle(1,1,1,1,100),epsilondev_xx_crust_mantle(1,1,1,100), &
-! displ_crust_mantle(1,iglob),displ_crust_mantle(2,iglob),displ_crust_mantle(3,iglob)
-! endif
-! if( it == NSTEP-2 .and. myrank == 0 ) then
-! print*,'third last step',it,'Rxx:',R_xx_crust_mantle(1,1,1,1,100),epsilondev_xx_crust_mantle(1,1,1,100), &
-! displ_crust_mantle(1,iglob),displ_crust_mantle(2,iglob),displ_crust_mantle(3,iglob)
-! endif
-! else if( SIMULATION_TYPE == 3 ) then
-! if( it == 1 .and. myrank == 0 ) then
-! print*,'first step',it,'Rxx:',b_R_xx_crust_mantle(1,1,1,1,100),b_epsilondev_xx_crust_mantle(1,1,1,100), &
-! b_displ_crust_mantle(1,iglob),b_displ_crust_mantle(2,iglob),b_displ_crust_mantle(3,iglob)
-! endif
-! if( it == 2 .and. myrank == 0 ) then
-! print*,'second step',it,'Rxx:',b_R_xx_crust_mantle(1,1,1,1,100),b_epsilondev_xx_crust_mantle(1,1,1,100), &
-! b_displ_crust_mantle(1,iglob),b_displ_crust_mantle(2,iglob),b_displ_crust_mantle(3,iglob)
-! endif
-! if( it == 3 .and. myrank == 0 ) then
-! print*,'third step',it,'Rxx:',b_R_xx_crust_mantle(1,1,1,1,100),b_epsilondev_xx_crust_mantle(1,1,1,100), &
-! b_displ_crust_mantle(1,iglob),b_displ_crust_mantle(2,iglob),b_displ_crust_mantle(3,iglob)
-! endif
-! endif
-! endif
-
-
- ! ****************************************************
- ! big loop over all spectral elements in the solid
- ! ****************************************************
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- ! distinguishes two runs: for elements on MPI interfaces, and elements within the partitions
- do iphase = 1,2
-
- ! first, iphase == 1 for points on MPI interfaces (thus outer elements)
- ! second, iphase == 2 for points purely inside partition (thus inner elements)
- !
- ! compute all the outer elements first, then sends out non blocking MPI communication
- ! and continues computing inner elements (overlapping)
- if( iphase == 1 ) then
- phase_is_inner = .false.
- else
- phase_is_inner = .true.
- endif
-
-
- if( .NOT. GPU_MODE ) then
- ! on CPU
-
- ! compute internal forces in the solid regions
- ! note: for anisotropy and gravity, x y and z contain r theta and phi
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville (2002) optimizations
- ! crust/mantle region
- call compute_forces_crust_mantle_Dev( NSPEC_CRUST_MANTLE_STR_OR_ATT,NGLOB_CRUST_MANTLE, &
- NSPEC_CRUST_MANTLE_ATTENUAT, &
- deltat, &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
- phase_is_inner, &
- R_xx_crust_mantle,R_yy_crust_mantle,R_xy_crust_mantle, &
- R_xz_crust_mantle,R_yz_crust_mantle, &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle,epsilondev_xy_crust_mantle, &
- epsilondev_xz_crust_mantle,epsilondev_yz_crust_mantle, &
- eps_trace_over_3_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5), .false. )
- ! inner core region
- call compute_forces_inner_core_Dev( NSPEC_INNER_CORE_STR_OR_ATT,NGLOB_INNER_CORE, &
- NSPEC_INNER_CORE_ATTENUATION, &
- deltat, &
- displ_inner_core,veloc_inner_core,accel_inner_core, &
- phase_is_inner, &
- R_xx_inner_core,R_yy_inner_core,R_xy_inner_core,R_xz_inner_core,R_yz_inner_core, &
- epsilondev_xx_inner_core,epsilondev_yy_inner_core,epsilondev_xy_inner_core, &
- epsilondev_xz_inner_core,epsilondev_yz_inner_core, &
- eps_trace_over_3_inner_core,&
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5), .false. )
-
- else
- ! no Deville optimization
- ! crust/mantle region
- call compute_forces_crust_mantle( NSPEC_CRUST_MANTLE_STR_OR_ATT,NGLOB_CRUST_MANTLE, &
- NSPEC_CRUST_MANTLE_ATTENUAT, &
- deltat, &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
- phase_is_inner, &
- R_xx_crust_mantle,R_yy_crust_mantle,R_xy_crust_mantle, &
- R_xz_crust_mantle,R_yz_crust_mantle, &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle,epsilondev_xy_crust_mantle, &
- epsilondev_xz_crust_mantle,epsilondev_yz_crust_mantle, &
- eps_trace_over_3_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- ! inner core region
- call compute_forces_inner_core( NSPEC_INNER_CORE_STR_OR_ATT,NGLOB_INNER_CORE, &
- NSPEC_INNER_CORE_ATTENUATION, &
- deltat, &
- displ_inner_core,veloc_inner_core,accel_inner_core, &
- phase_is_inner, &
- R_xx_inner_core,R_yy_inner_core,R_xy_inner_core,R_xz_inner_core,R_yz_inner_core, &
- epsilondev_xx_inner_core,epsilondev_yy_inner_core,epsilondev_xy_inner_core, &
- epsilondev_xz_inner_core,epsilondev_yz_inner_core, &
- eps_trace_over_3_inner_core,&
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
-
- endif
-
- ! adjoint / kernel runs
- if (SIMULATION_TYPE == 3 ) then
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville (2002) optimizations
- ! crust/mantle region
- call compute_forces_crust_mantle_Dev( NSPEC_CRUST_MANTLE_ADJOINT,NGLOB_CRUST_MANTLE_ADJOINT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT, &
- b_deltat, &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
- phase_is_inner, &
- b_R_xx_crust_mantle,b_R_yy_crust_mantle,b_R_xy_crust_mantle, &
- b_R_xz_crust_mantle,b_R_yz_crust_mantle, &
- b_epsilondev_xx_crust_mantle,b_epsilondev_yy_crust_mantle,&
- b_epsilondev_xy_crust_mantle, &
- b_epsilondev_xz_crust_mantle,b_epsilondev_yz_crust_mantle, &
- b_eps_trace_over_3_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5), .true. )
- ! inner core region
- call compute_forces_inner_core_Dev( NSPEC_INNER_CORE_ADJOINT,NGLOB_INNER_CORE_ADJOINT, &
- NSPEC_INNER_CORE_STR_AND_ATT, &
- b_deltat, &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
- phase_is_inner, &
- b_R_xx_inner_core,b_R_yy_inner_core,b_R_xy_inner_core, &
- b_R_xz_inner_core,b_R_yz_inner_core, &
- b_epsilondev_xx_inner_core,b_epsilondev_yy_inner_core,b_epsilondev_xy_inner_core, &
- b_epsilondev_xz_inner_core,b_epsilondev_yz_inner_core, &
- b_eps_trace_over_3_inner_core,&
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5), .true. )
-
- else
- ! no Deville optimization
- ! crust/mantle region
- call compute_forces_crust_mantle( NSPEC_CRUST_MANTLE_ADJOINT,NGLOB_CRUST_MANTLE_ADJOINT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT, &
- b_deltat, &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
- phase_is_inner, &
- b_R_xx_crust_mantle,b_R_yy_crust_mantle,b_R_xy_crust_mantle, &
- b_R_xz_crust_mantle,b_R_yz_crust_mantle, &
- b_epsilondev_xx_crust_mantle,b_epsilondev_yy_crust_mantle,&
- b_epsilondev_xy_crust_mantle, &
- b_epsilondev_xz_crust_mantle,b_epsilondev_yz_crust_mantle, &
- b_eps_trace_over_3_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
-
- ! inner core region
- call compute_forces_inner_core( NSPEC_INNER_CORE_ADJOINT,NGLOB_INNER_CORE_ADJOINT, &
- NSPEC_INNER_CORE_STR_AND_ATT, &
- b_deltat, &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
- phase_is_inner, &
- b_R_xx_inner_core,b_R_yy_inner_core,b_R_xy_inner_core, &
- b_R_xz_inner_core,b_R_yz_inner_core, &
- b_epsilondev_xx_inner_core,b_epsilondev_yy_inner_core,b_epsilondev_xy_inner_core, &
- b_epsilondev_xz_inner_core,b_epsilondev_yz_inner_core, &
- b_eps_trace_over_3_inner_core,&
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
- endif !SIMULATION_TYPE == 3
-
- else
- ! on GPU
- ! contains both forward SIM_TYPE==1 and backward SIM_TYPE==3 simulations
- ! for crust/mantle
- call compute_forces_crust_mantle_cuda(Mesh_pointer,iphase)
- ! for inner core
- call compute_forces_inner_core_cuda(Mesh_pointer,iphase)
- endif ! GPU_MODE
-
-
- ! computes additional contributions to acceleration field
- if( iphase == 1 ) then
-
- ! absorbing boundaries
- ! Stacey
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) call compute_stacey_crust_mantle()
-
- ! add the sources
-
- ! add adjoint sources
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- if( nadj_rec_local > 0 ) call compute_add_sources_adjoint()
- endif
-
- ! add the sources
- select case( NOISE_TOMOGRAPHY )
- case( 0 )
- ! regular forward or backward simulation, no noise tomography simulation
- ! adds sources for forward simulation
- if (SIMULATION_TYPE == 1 .and. nsources_local > 0) &
- call compute_add_sources()
- ! add sources for backward/reconstructed wavefield
- if (SIMULATION_TYPE == 3 .and. nsources_local > 0) &
- call compute_add_sources_backward()
-
- case( 1 )
- ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
- ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
- ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
- ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
- call noise_add_source_master_rec()
-
- case( 2 )
- ! second step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to drive the ensemble forward wavefield
- call noise_read_add_surface_movie(NGLOB_CRUST_MANTLE,accel_crust_mantle,NSTEP-it+1)
- ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
- ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
- ! note the ensemble forward sources are generally distributed on the surface of the earth
- ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
- ! therefore, we must add it here, before applying the inverse of mass matrix
-
- case( 3 )
- ! third step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to reconstruct the ensemble forward wavefield
- ! the ensemble adjoint wavefield is done as usual
- ! note instead of "NSTEP-it+1", now we us "it", since reconstruction is a reversal of reversal
- call noise_read_add_surface_movie(NGLOB_CRUST_MANTLE_ADJOINT,b_accel_crust_mantle,it)
-
- end select
-
-
- ! ****************************************************
- ! ********** add matching with fluid part **********
- ! ****************************************************
- ! only for elements in first matching layer in the solid
- if( .not. GPU_MODE ) then
- ! on CPU
- !---
- !--- couple with outer core at the bottom of the mantle
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) &
- call compute_coupling_CMB_fluid(displ_crust_mantle,b_displ_crust_mantle, &
- accel_crust_mantle,b_accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- RHO_TOP_OC,minus_g_cmb, &
- SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
-
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) &
- call compute_coupling_ICB_fluid(displ_inner_core,b_displ_inner_core, &
- accel_inner_core,b_accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- RHO_BOTTOM_OC,minus_g_icb, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_INNER_CORE))
-
- else
- ! on GPU
- !---
- !--- couple with outer core at the bottom of the mantle
- !---
- if( ACTUALLY_COUPLE_FLUID_CMB ) &
- call compute_coupling_cmb_fluid_cuda(Mesh_pointer)
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if( ACTUALLY_COUPLE_FLUID_ICB ) &
- call compute_coupling_icb_fluid_cuda(Mesh_pointer)
-
- endif
- endif ! iphase == 1
-
- ! assemble all the contributions between slices using MPI
-
- ! crust/mantle and inner core handled in the same call
- ! in order to reduce the number of MPI messages by 2
-
- if( iphase == 1 ) then
- ! sends out MPI interface data
- if(.NOT. GPU_MODE) then
- ! on CPU
- ! sends accel values to corresponding MPI interface neighbors
- ! crust mantle
- call assemble_MPI_vector_s(NPROCTOT_VAL,NGLOB_CRUST_MANTLE, &
- accel_crust_mantle, &
- buffer_send_vector_crust_mantle,buffer_recv_vector_crust_mantle, &
- num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
- nibool_interfaces_crust_mantle,ibool_interfaces_crust_mantle,&
- my_neighbours_crust_mantle, &
- request_send_vector_cm,request_recv_vector_cm)
- ! inner core
- call assemble_MPI_vector_s(NPROCTOT_VAL,NGLOB_INNER_CORE, &
- accel_inner_core, &
- buffer_send_vector_inner_core,buffer_recv_vector_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
- my_neighbours_inner_core, &
- request_send_vector_ic,request_recv_vector_ic)
- else
- ! on GPU
- ! crust mantle
- call assemble_MPI_vector_send_cuda(NPROCTOT_VAL, &
- buffer_send_vector_crust_mantle,buffer_recv_vector_crust_mantle, &
- num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
- nibool_interfaces_crust_mantle,&
- my_neighbours_crust_mantle, &
- request_send_vector_cm,request_recv_vector_cm, &
- IREGION_CRUST_MANTLE, &
- 1) ! <-- 1 == fwd accel
- ! inner core
- call assemble_MPI_vector_send_cuda(NPROCTOT_VAL, &
- buffer_send_vector_inner_core,buffer_recv_vector_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,&
- my_neighbours_inner_core, &
- request_send_vector_ic,request_recv_vector_ic, &
- IREGION_INNER_CORE, &
- 1)
- endif ! GPU_MODE
-
- ! adjoint / kernel runs
- if (SIMULATION_TYPE == 3) then
- if(.NOT. GPU_MODE) then
- ! on CPU
- ! sends accel values to corresponding MPI interface neighbors
- ! crust mantle
- call assemble_MPI_vector_s(NPROCTOT_VAL,NGLOB_CRUST_MANTLE, &
- b_accel_crust_mantle, &
- b_buffer_send_vector_cm,b_buffer_recv_vector_cm, &
- num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
- nibool_interfaces_crust_mantle,ibool_interfaces_crust_mantle,&
- my_neighbours_crust_mantle, &
- b_request_send_vector_cm,b_request_recv_vector_cm)
- ! inner core
- call assemble_MPI_vector_s(NPROCTOT_VAL,NGLOB_INNER_CORE, &
- b_accel_inner_core, &
- b_buffer_send_vector_inner_core,b_buffer_recv_vector_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
- my_neighbours_inner_core, &
- b_request_send_vector_ic,b_request_recv_vector_ic)
- else
- ! on GPU
- ! crust mantle
- call assemble_MPI_vector_send_cuda(NPROCTOT_VAL, &
- b_buffer_send_vector_cm,b_buffer_recv_vector_cm, &
- num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
- nibool_interfaces_crust_mantle,&
- my_neighbours_crust_mantle, &
- b_request_send_vector_cm,b_request_recv_vector_cm, &
- IREGION_CRUST_MANTLE, &
- 3) ! <-- 3 == adjoint b_accel
- ! inner core
- call assemble_MPI_vector_send_cuda(NPROCTOT_VAL, &
- b_buffer_send_vector_inner_core,b_buffer_recv_vector_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,&
- my_neighbours_inner_core, &
- b_request_send_vector_ic,b_request_recv_vector_ic, &
- IREGION_INNER_CORE, &
- 3)
- endif ! GPU
- endif ! SIMULATION_TYPE == 3
-
- else
- ! waits for send/receive requests to be completed and assembles values
- if(.NOT. GPU_MODE) then
- ! on CPU
- ! crust mantle
- call assemble_MPI_vector_w(NPROCTOT_VAL,NGLOB_CRUST_MANTLE, &
- accel_crust_mantle, &
- buffer_recv_vector_crust_mantle,num_interfaces_crust_mantle,&
- max_nibool_interfaces_cm, &
- nibool_interfaces_crust_mantle,ibool_interfaces_crust_mantle, &
- request_send_vector_cm,request_recv_vector_cm)
- ! inner core
- call assemble_MPI_vector_w(NPROCTOT_VAL,NGLOB_INNER_CORE, &
- accel_inner_core, &
- buffer_recv_vector_inner_core,num_interfaces_inner_core,&
- max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,ibool_interfaces_inner_core, &
- request_send_vector_ic,request_recv_vector_ic)
- else
- ! on GPU
- ! crust mantle
- call assemble_MPI_vector_write_cuda(NPROCTOT_VAL, &
- buffer_recv_vector_crust_mantle, &
- num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
- request_send_vector_cm,request_recv_vector_cm, &
- IREGION_CRUST_MANTLE, &
- 1) ! <-- 1 == fwd accel
- ! inner core
- call assemble_MPI_vector_write_cuda(NPROCTOT_VAL, &
- buffer_recv_vector_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- request_send_vector_ic,request_recv_vector_ic, &
- IREGION_INNER_CORE, &
- 1)
- endif
-
-
- ! adjoint / kernel runs
- if (SIMULATION_TYPE == 3) then
- ! waits for send/receive requests to be completed and assembles values
- if(.NOT. GPU_MODE) then
- ! on CPU
- ! crust mantle
- call assemble_MPI_vector_w(NPROCTOT_VAL,NGLOB_CRUST_MANTLE, &
- b_accel_crust_mantle, &
- b_buffer_recv_vector_cm,num_interfaces_crust_mantle,&
- max_nibool_interfaces_cm, &
- nibool_interfaces_crust_mantle,ibool_interfaces_crust_mantle, &
- b_request_send_vector_cm,b_request_recv_vector_cm)
- ! inner core
- call assemble_MPI_vector_w(NPROCTOT_VAL,NGLOB_INNER_CORE, &
- b_accel_inner_core, &
- b_buffer_recv_vector_inner_core,num_interfaces_inner_core,&
- max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,ibool_interfaces_inner_core, &
- b_request_send_vector_ic,b_request_recv_vector_ic)
-
- else
- ! on GPU
- ! crust mantle
- call assemble_MPI_vector_write_cuda(NPROCTOT_VAL, &
- b_buffer_recv_vector_cm, &
- num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
- b_request_send_vector_cm,b_request_recv_vector_cm, &
- IREGION_CRUST_MANTLE, &
- 3) ! <-- 3 == adjoint b_accel
- ! inner core
- call assemble_MPI_vector_write_cuda(NPROCTOT_VAL,&
- b_buffer_recv_vector_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- b_request_send_vector_ic,b_request_recv_vector_ic, &
- IREGION_INNER_CORE, &
- 3)
- endif
- endif ! SIMULATION_TYPE == 3
- endif ! iphase == 1
-
- enddo ! iphase
-
- ! updates (only) acceleration w/ rotation in the crust/mantle region (touches oceans)
- if(.NOT. GPU_MODE) then
- ! on CPU
- call compute_forces_el_update_accel(NGLOB_CRUST_MANTLE,NGLOB_XY_CM,veloc_crust_mantle,accel_crust_mantle, &
- two_omega_earth, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
- NCHUNKS_VAL,ABSORBING_CONDITIONS)
- ! adjoint / kernel runs
- if (SIMULATION_TYPE == 3) &
- call compute_forces_el_update_accel(NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_XY_CM,b_veloc_crust_mantle,b_accel_crust_mantle, &
- b_two_omega_earth, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
- NCHUNKS_VAL,ABSORBING_CONDITIONS)
- else
- ! on GPU
- call kernel_3_a_cuda(Mesh_pointer, &
- deltatover2,SIMULATION_TYPE,b_deltatover2,NCHUNKS_VAL)
- endif
-
- ! couples ocean with crust mantle
- ! (updates acceleration with ocean load approximation)
- if( OCEANS_VAL ) then
- if(.NOT. GPU_MODE) then
- ! on CPU
- call compute_coupling_ocean(accel_crust_mantle,b_accel_crust_mantle, &
- rmassx_crust_mantle, rmassy_crust_mantle, rmassz_crust_mantle, &
- rmass_ocean_load,normal_top_crust_mantle, &
- ibool_crust_mantle,ibelm_top_crust_mantle, &
- updated_dof_ocean_load,NGLOB_XY_CM, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- ABSORBING_CONDITIONS)
-
- else
- ! on GPU
- call compute_coupling_ocean_cuda(Mesh_pointer,NCHUNKS_VAL)
- endif
- endif
-
- ! Newmark time scheme:
- ! corrector terms for elastic parts
- ! (updates velocity)
- if(.NOT. GPU_MODE ) then
- ! on CPU
- call compute_forces_el_update_veloc(NGLOB_CRUST_MANTLE,veloc_crust_mantle,accel_crust_mantle, &
- NGLOB_INNER_CORE,veloc_inner_core,accel_inner_core, &
- deltatover2,two_omega_earth,rmass_inner_core)
- ! adjoint / kernel runs
- if (SIMULATION_TYPE == 3) &
- call compute_forces_el_update_veloc(NGLOB_CRUST_MANTLE_ADJOINT,b_veloc_crust_mantle,b_accel_crust_mantle, &
- NGLOB_INNER_CORE_ADJOINT,b_veloc_inner_core,b_accel_inner_core, &
- b_deltatover2,b_two_omega_earth,rmass_inner_core)
- else
- ! on GPU
- call kernel_3_b_cuda(Mesh_pointer, &
- deltatover2,SIMULATION_TYPE,b_deltatover2)
- endif
-
-
-!daniel: att - debug
-! if( DEBUG ) then
-! if( SIMULATION_TYPE == 1) then
-! if( it > NSTEP - 1000 .and. myrank == 0 ) then
-! print*,'it',it,'Rxx:',R_xx_crust_mantle(1,1,1,1,100),epsilondev_xx_crust_mantle(1,1,1,100)
-! endif
-! else if( SIMULATION_TYPE == 3 ) then
-! if( it <= 1000 .and. myrank == 0 ) then
-! print*,'it',it,'Rxx:',b_R_xx_crust_mantle(1,1,1,1,100),b_epsilondev_xx_crust_mantle(1,1,1,100)
-! endif
-! endif
-! endif
-
- end subroutine compute_forces_elastic
-
-
-!=====================================================================
-
- subroutine compute_forces_el_update_accel(NGLOB,NGLOB_XY,veloc_crust_mantle,accel_crust_mantle, &
- two_omega_earth, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
- NCHUNKS_VAL,ABSORBING_CONDITIONS)
-
- use constants_solver,only: CUSTOM_REAL,NDIM
-
-#ifdef _HANDOPT
- use specfem_par,only: imodulo_NGLOB_CRUST_MANTLE4
-#endif
-
- implicit none
-
- integer :: NGLOB,NGLOB_XY,NCHUNKS_VAL
-
- ! velocity & acceleration
- ! crust/mantle region
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: veloc_crust_mantle,accel_crust_mantle
-
- ! mass matrices
- !
- ! in the case of stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
- ! on Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
- ! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
- !
- ! if absorbing_conditions are not set or if NCHUNKS=6, only one mass matrix is needed
- ! for the sake of performance, only "rmassz" array will be filled and "rmassx" & "rmassy" will be obsolete
- real(kind=CUSTOM_REAL), dimension(NGLOB_XY) :: rmassx_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_XY) :: rmassy_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB) :: rmassz_crust_mantle
-
- real(kind=CUSTOM_REAL) :: two_omega_earth
-
- logical :: ABSORBING_CONDITIONS
-
- ! local parameters
- integer :: i
-
- ! updates acceleration w/ rotation in crust/mantle region only
-
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
-#ifdef _HANDOPT_NEWMARK
- ! way 2:
- if(imodulo_NGLOB_CRUST_MANTLE4 >= 1) then
- do i=1,imodulo_NGLOB_CRUST_MANTLE4
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
- endif
- do i=imodulo_NGLOB_CRUST_MANTLE4+1,NGLOB,4
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
-
- accel_crust_mantle(1,i+1) = accel_crust_mantle(1,i+1)*rmassx_crust_mantle(i+1) &
- + two_omega_earth*veloc_crust_mantle(2,i+1)
- accel_crust_mantle(2,i+1) = accel_crust_mantle(2,i+1)*rmassy_crust_mantle(i+1) &
- - two_omega_earth*veloc_crust_mantle(1,i+1)
- accel_crust_mantle(3,i+1) = accel_crust_mantle(3,i+1)*rmassz_crust_mantle(i+1)
-
- accel_crust_mantle(1,i+2) = accel_crust_mantle(1,i+2)*rmassx_crust_mantle(i+2) &
- + two_omega_earth*veloc_crust_mantle(2,i+2)
- accel_crust_mantle(2,i+2) = accel_crust_mantle(2,i+2)*rmassy_crust_mantle(i+2) &
- - two_omega_earth*veloc_crust_mantle(1,i+2)
- accel_crust_mantle(3,i+2) = accel_crust_mantle(3,i+2)*rmassz_crust_mantle(i+2)
-
- accel_crust_mantle(1,i+3) = accel_crust_mantle(1,i+3)*rmassx_crust_mantle(i+3) &
- + two_omega_earth*veloc_crust_mantle(2,i+3)
- accel_crust_mantle(2,i+3) = accel_crust_mantle(2,i+3)*rmassy_crust_mantle(i+3) &
- - two_omega_earth*veloc_crust_mantle(1,i+3)
- accel_crust_mantle(3,i+3) = accel_crust_mantle(3,i+3)*rmassz_crust_mantle(i+3)
- enddo
-#else
- ! way 1:
- do i=1,NGLOB
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-#endif
-
- else
-
-#ifdef _HANDOPT_NEWMARK
- ! way 2:
- if(imodulo_NGLOB_CRUST_MANTLE4 >= 1) then
- do i=1,imodulo_NGLOB_CRUST_MANTLE4
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
- endif
- do i=imodulo_NGLOB_CRUST_MANTLE4+1,NGLOB,4
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
-
- accel_crust_mantle(1,i+1) = accel_crust_mantle(1,i+1)*rmassz_crust_mantle(i+1) &
- + two_omega_earth*veloc_crust_mantle(2,i+1)
- accel_crust_mantle(2,i+1) = accel_crust_mantle(2,i+1)*rmassz_crust_mantle(i+1) &
- - two_omega_earth*veloc_crust_mantle(1,i+1)
- accel_crust_mantle(3,i+1) = accel_crust_mantle(3,i+1)*rmassz_crust_mantle(i+1)
-
- accel_crust_mantle(1,i+2) = accel_crust_mantle(1,i+2)*rmassz_crust_mantle(i+2) &
- + two_omega_earth*veloc_crust_mantle(2,i+2)
- accel_crust_mantle(2,i+2) = accel_crust_mantle(2,i+2)*rmassz_crust_mantle(i+2) &
- - two_omega_earth*veloc_crust_mantle(1,i+2)
- accel_crust_mantle(3,i+2) = accel_crust_mantle(3,i+2)*rmassz_crust_mantle(i+2)
-
- accel_crust_mantle(1,i+3) = accel_crust_mantle(1,i+3)*rmassz_crust_mantle(i+3) &
- + two_omega_earth*veloc_crust_mantle(2,i+3)
- accel_crust_mantle(2,i+3) = accel_crust_mantle(2,i+3)*rmassz_crust_mantle(i+3) &
- - two_omega_earth*veloc_crust_mantle(1,i+3)
- accel_crust_mantle(3,i+3) = accel_crust_mantle(3,i+3)*rmassz_crust_mantle(i+3)
- enddo
-#else
- ! way 1:
- do i=1,NGLOB
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + two_omega_earth*veloc_crust_mantle(2,i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - two_omega_earth*veloc_crust_mantle(1,i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-#endif
-
- endif
-
- end subroutine compute_forces_el_update_accel
-
-
-!=====================================================================
-
- subroutine compute_forces_el_update_veloc(NGLOB_CM,veloc_crust_mantle,accel_crust_mantle, &
- NGLOB_IC,veloc_inner_core,accel_inner_core, &
- deltatover2,two_omega_earth,rmass_inner_core)
-
- use constants_solver,only: CUSTOM_REAL,NDIM
-
-#ifdef _HANDOPT
- use specfem_par,only: imodulo_NGLOB_CRUST_MANTLE4,imodulo_NGLOB_INNER_CORE
-#endif
-
- implicit none
-
- integer :: NGLOB_CM,NGLOB_IC
-
- ! acceleration & velocity
- ! crust/mantle region
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CM) :: veloc_crust_mantle,accel_crust_mantle
- ! inner core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_IC) :: veloc_inner_core,accel_inner_core
-
- ! mass matrix
- real(kind=CUSTOM_REAL), dimension(NGLOB_IC) :: rmass_inner_core
-
- real(kind=CUSTOM_REAL) :: deltatover2,two_omega_earth
-
- ! local parameters
- integer :: i
-
- ! Newmark time scheme:
- !
- ! note:
- ! - crust/mantle region
- ! needs only velocity corrector terms
- ! (acceleration already updated before)
- ! - inner core region
- ! needs both, acceleration update & velocity corrector terms
-
-#ifdef _HANDOPT_NEWMARK
-! way 2:
- ! crust/mantle region
- if( imodulo_NGLOB_CRUST_MANTLE4 >= 1 ) then
- do i=1,imodulo_NGLOB_CRUST_MANTLE4
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- enddo
- endif
- do i=imodulo_NGLOB_CRUST_MANTLE4+1,NGLOB_CM,4
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i+1) = veloc_crust_mantle(:,i+1) + deltatover2*accel_crust_mantle(:,i+1)
- veloc_crust_mantle(:,i+2) = veloc_crust_mantle(:,i+2) + deltatover2*accel_crust_mantle(:,i+2)
- veloc_crust_mantle(:,i+3) = veloc_crust_mantle(:,i+3) + deltatover2*accel_crust_mantle(:,i+3)
- enddo
-
- ! inner core region
- if(imodulo_NGLOB_INNER_CORE >= 1) then
- do i=1,imodulo_NGLOB_INNER_CORE
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
- enddo
- endif
- do i=imodulo_NGLOB_INNER_CORE+1,NGLOB_IC,3
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
-
- accel_inner_core(1,i+1) = accel_inner_core(1,i+1)*rmass_inner_core(i+1) &
- + two_omega_earth*veloc_inner_core(2,i+1)
- accel_inner_core(2,i+1) = accel_inner_core(2,i+1)*rmass_inner_core(i+1) &
- - two_omega_earth*veloc_inner_core(1,i+1)
- accel_inner_core(3,i+1) = accel_inner_core(3,i+1)*rmass_inner_core(i+1)
-
- veloc_inner_core(:,i+1) = veloc_inner_core(:,i+1) + deltatover2*accel_inner_core(:,i+1)
-
- accel_inner_core(1,i+2) = accel_inner_core(1,i+2)*rmass_inner_core(i+2) &
- + two_omega_earth*veloc_inner_core(2,i+2)
- accel_inner_core(2,i+2) = accel_inner_core(2,i+2)*rmass_inner_core(i+2) &
- - two_omega_earth*veloc_inner_core(1,i+2)
- accel_inner_core(3,i+2) = accel_inner_core(3,i+2)*rmass_inner_core(i+2)
-
- veloc_inner_core(:,i+2) = veloc_inner_core(:,i+2) + deltatover2*accel_inner_core(:,i+2)
- enddo
-#else
-! way 1:
- ! mantle
- do i=1,NGLOB_CM
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- enddo
- ! inner core
- do i=1,NGLOB_IC
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
- enddo
-#endif
-
- end subroutine compute_forces_el_update_veloc
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -105,7 +105,8 @@
double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
-! local parameters
+ ! local parameters
+
! Deville
! manually inline the calls to the Deville et al. (2002) routines
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
@@ -306,72 +307,72 @@
enddo
do j=1,m2
- do i=1,m1
- C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B1_m1_m2_5points(5,j)
+ do i=1,m1
+ C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B1_m1_m2_5points(5,j)
- C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B2_m1_m2_5points(5,j)
+ C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B2_m1_m2_5points(5,j)
- C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B3_m1_m2_5points(5,j)
- enddo
+ C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B3_m1_m2_5points(5,j)
+ enddo
enddo
do j=1,m1
- do i=1,m1
- ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyx_loc(i,5,k)*hprime_xxT(5,j)
+ do i=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyx_loc(i,5,k)*hprime_xxT(5,j)
- tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyy_loc(i,5,k)*hprime_xxT(5,j)
+ tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyy_loc(i,5,k)*hprime_xxT(5,j)
- tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyz_loc(i,5,k)*hprime_xxT(5,j)
- enddo
- enddo
+ tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ enddo
+ enddo
enddo
do j=1,m1
- do i=1,m2
- C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ do i=1,m2
+ C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- enddo
+ C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ enddo
enddo
do k=1,NGLLZ
@@ -618,17 +619,17 @@
endif ! end of section with gravity terms
! form dot product with test vector, non-symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl) ! this goes to accel_x
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl) ! this goes to accel_y
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl) ! this goes to accel_z
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl) ! this goes to accel_x
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl) ! this goes to accel_y
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl) ! this goes to accel_z
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl) ! this goes to accel_x
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl) ! this goes to accel_y
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl) ! this goes to accel_z
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl) ! this goes to accel_x
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl) ! this goes to accel_y
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl) ! this goes to accel_z
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl) ! this goes to accel_x
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl) ! this goes to accel_y
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl) ! this goes to accel_z
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl) ! this goes to accel_x
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl) ! this goes to accel_y
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl) ! this goes to accel_z
enddo
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core_Dev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core_Dev.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core_Dev.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -78,20 +78,22 @@
logical MOVIE_VOLUME
+ ! local parameters
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: tempx1,tempx2,tempx3
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: newtempx1,newtempx2,newtempx3
-! for gravity
- integer int_radius
- double precision radius,theta,phi,gxl,gyl,gzl
- double precision cos_theta,sin_theta,cos_phi,sin_phi
+ ! for gravity
+ integer :: int_radius
+ double precision :: radius,theta,phi,gxl,gyl,gzl
+ double precision :: cos_theta,sin_theta,cos_phi,sin_phi
double precision, dimension(NRAD_GRAVITY) :: minus_rho_g_over_kappa_fluid
double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: gravity_term
real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: xstore,ystore,zstore
-! for the Euler scheme for rotation
- real(kind=CUSTOM_REAL) time,deltat,two_omega_earth
+ ! for the Euler scheme for rotation
+ real(kind=CUSTOM_REAL) :: time,deltat,two_omega_earth
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
A_array_rotation,B_array_rotation
@@ -99,13 +101,12 @@
ux_rotation,uy_rotation,dpotentialdx_with_rot,dpotentialdy_with_rot
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: source_euler_A,source_euler_B
- integer ispec,iglob
- integer i,j,k
+ integer :: ispec,iglob
+ integer :: i,j,k
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) :: dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) :: sum_terms
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
- real(kind=CUSTOM_REAL) sum_terms
-
! manually inline the calls to the Deville et al. (2002) routines
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc
@@ -283,7 +284,6 @@
enddo
-
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
@@ -403,18 +403,18 @@
endif
if(istage == 1)then
- ! divergence of displacement field with gravity on
- ! note: these calculations are only considered for SIMULATION_TYPE == 1 .and. SAVE_FORWARD
- ! and one has set MOVIE_VOLUME_TYPE == 4 when MOVIE_VOLUME is .true.;
- ! in case of SIMULATION_TYPE == 3, it gets overwritten by compute_kernels_outer_core()
- if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. MOVIE_VOLUME) then
- div_displfluid(i,j,k,ispec) = &
- minus_rho_g_over_kappa_fluid(int_radius) &
- * (dpotentialdx_with_rot * gxl &
- + dpotentialdy_with_rot * gyl &
- + dpotentialdzl * gzl)
- endif
+ ! divergence of displacement field with gravity on
+ ! note: these calculations are only considered for SIMULATION_TYPE == 1 .and. SAVE_FORWARD
+ ! and one has set MOVIE_VOLUME_TYPE == 4 when MOVIE_VOLUME is .true.;
+ ! in case of SIMULATION_TYPE == 3, it gets overwritten by compute_kernels_outer_core()
+ if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. MOVIE_VOLUME) then
+ div_displfluid(i,j,k,ispec) = &
+ minus_rho_g_over_kappa_fluid(int_radius) &
+ * (dpotentialdx_with_rot * gxl &
+ + dpotentialdy_with_rot * gyl &
+ + dpotentialdzl * gzl)
endif
+ endif
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_kernels.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_kernels.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -25,7 +25,6 @@
!
!=====================================================================
-
subroutine compute_kernels_crust_mantle(ibool_crust_mantle, &
rho_kl_crust_mantle,beta_kl_crust_mantle, &
alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
@@ -46,7 +45,6 @@
real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
cijkl_kl_crust_mantle
-
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
accel_crust_mantle,displ_crust_mantle
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
@@ -58,7 +56,7 @@
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
! local parameters
- real(kind=CUSTOM_REAL),dimension(21) :: prod !, cijkl_kl_local
+ real(kind=CUSTOM_REAL),dimension(21) :: prod
real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_matrix,b_epsilondev_loc_matrix
@@ -280,8 +278,7 @@
tempz3l = tempz3l + b_vector_displ_outer_core(3,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
enddo
-
- !deviatoric strain
+ ! deviatoric strain
b_epsilondev_loc(1) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
@@ -310,9 +307,8 @@
+ xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
- endif !deviatoric kernel check
+ endif ! deviatoric kernel check
-
tempx1l = 0._CUSTOM_REAL
tempx2l = 0._CUSTOM_REAL
tempx3l = 0._CUSTOM_REAL
@@ -353,8 +349,7 @@
vector_displ_outer_core(2,iglob) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
vector_displ_outer_core(3,iglob) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
- !deviatoric kernel check
+ ! deviatoric kernel check
if( deviatoric_outercore ) then
tempx1l = 0._CUSTOM_REAL
@@ -384,8 +379,7 @@
tempz3l = tempz3l + vector_displ_outer_core(3,ibool_outer_core(i,j,l,ispec)) * hprime_zz(k,l)
enddo
-
- !deviatoric strain
+ ! deviatoric strain
epsilondev_loc(1) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
- ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
@@ -420,10 +414,8 @@
+ 2 * (epsilondev_loc(3)*b_epsilondev_loc(3) + epsilondev_loc(4)*b_epsilondev_loc(4) + &
epsilondev_loc(5)*b_epsilondev_loc(5)) )
- endif !deviatoric kernel check
+ endif ! deviatoric kernel check
-
-
rho_kl_outer_core(i,j,k,ispec) = rho_kl_outer_core(i,j,k,ispec) &
+ deltat * dot_product(vector_accel_outer_core(:,iglob), b_vector_displ_outer_core(:,iglob))
@@ -435,7 +427,6 @@
alpha_kl_outer_core(i,j,k,ispec) = alpha_kl_outer_core(i,j,k,ispec) &
+ deltat * div_displ_outer_core(i,j,k,ispec) * b_div_displ_outer_core(i,j,k,ispec)
-
enddo
enddo
enddo
@@ -448,7 +439,6 @@
!-------------------------------------------------------------------------------------------------
!
-
subroutine compute_kernels_inner_core(ibool_inner_core, &
rho_kl_inner_core,beta_kl_inner_core, &
alpha_kl_inner_core, &
@@ -456,7 +446,6 @@
deltat,displ_inner_core,hprime_xx,hprime_xxT,&
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
-
implicit none
include "constants.h"
@@ -533,13 +522,11 @@
!-------------------------------------------------------------------------------------------------
!
! Subroutines to compute the kernels for the 21 elastic coefficients
-! Last modified 19/04/2007
-!-------------------------------------------------------------------
subroutine compute_strain_product(prod,eps_trace_over_3,epsdev,&
- b_eps_trace_over_3,b_epsdev)
+ b_eps_trace_over_3,b_epsdev)
- ! Purpose : compute the 21 strain products at a grid point
+ ! Purpose: compute the 21 strain products at a grid point
! (ispec,i,j,k fixed) and at a time t to compute then the kernels cij_kl (Voigt notation)
! (eq. 15 of Tromp et al., 2005)
! prod(1)=eps11*eps11 -> c11, prod(2)=eps11eps22 -> c12, prod(3)=eps11eps33 -> c13, ...
@@ -548,8 +535,6 @@
! This then gives how the 21 kernels are organized
! For crust_mantle
- ! Modif 09/11/2005
-
implicit none
include "constants.h"
@@ -577,15 +562,15 @@
! Computing the 21 strain products without assuming eps(i)*b_eps(j) = eps(j)*b_eps(i)
p=1
do i=1,6
- do j=i,6
- prod(p)=eps(i)*b_eps(j)
- if(j>i) then
- prod(p)=prod(p)+eps(j)*b_eps(i)
- if(j>3 .and. i<4) prod(p)=prod(p)*2
- endif
- if(i>3) prod(p)=prod(p)*4
- p=p+1
- enddo
+ do j=i,6
+ prod(p)=eps(i)*b_eps(j)
+ if(j>i) then
+ prod(p)=prod(p)+eps(j)*b_eps(i)
+ if(j>3 .and. i<4) prod(p) = prod(p) * 2.0_CUSTOM_REAL
+ endif
+ if(i>3) prod(p) = prod(p) * 4.0_CUSTOM_REAL
+ p=p+1
+ enddo
enddo
end subroutine compute_strain_product
@@ -995,19 +980,19 @@
! local parameters
integer :: i,j,k,ispec,iglob
- ! crust_mantle
- do ispec = 1, NSPEC_CRUST_MANTLE
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool_crust_mantle(i,j,k,ispec)
+ ! crust_mantle
+ do ispec = 1, NSPEC_CRUST_MANTLE
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec)
- ! approximates hessian
- ! term with adjoint acceleration and backward/reconstructed acceleration
- hess_kl_crust_mantle(i,j,k,ispec) = hess_kl_crust_mantle(i,j,k,ispec) &
- + deltat * (accel_crust_mantle(1,iglob) * b_accel_crust_mantle(1,iglob) &
- + accel_crust_mantle(2,iglob) * b_accel_crust_mantle(2,iglob) &
- + accel_crust_mantle(3,iglob) * b_accel_crust_mantle(3,iglob) )
+ ! approximates hessian
+ ! term with adjoint acceleration and backward/reconstructed acceleration
+ hess_kl_crust_mantle(i,j,k,ispec) = hess_kl_crust_mantle(i,j,k,ispec) &
+ + deltat * (accel_crust_mantle(1,iglob) * b_accel_crust_mantle(1,iglob) &
+ + accel_crust_mantle(2,iglob) * b_accel_crust_mantle(2,iglob) &
+ + accel_crust_mantle(3,iglob) * b_accel_crust_mantle(3,iglob) )
enddo
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_seismograms.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_seismograms.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -376,7 +376,6 @@
shdur_der(irec_local) = shdur_der(irec_local) + eps_m_s * Hp_deltat
-
enddo
end subroutine compute_seismograms_adjoint
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/get_attenuation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/get_attenuation.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/get_attenuation.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -25,8 +25,10 @@
!
!=====================================================================
- subroutine get_attenuation_model_3D(myrank, prname, one_minus_sum_beta, &
- factor_common, scale_factor, tau_s, vnspec)
+ subroutine get_attenuation_model_3D(myrank, prname, &
+ one_minus_sum_beta, &
+ factor_common, &
+ scale_factor, tau_s, vnspec)
implicit none
@@ -75,26 +77,26 @@
T_c_source = 1000.0d0 / T_c_source
T_c_source = T_c_source / scale_t
- do ispec = 1, vnspec
- do k = 1, NGLLZ
+ do ispec = 1, vnspec
+ do k = 1, NGLLZ
do j = 1, NGLLY
- do i = 1, NGLLX
- tau_e(:) = factor_common(:,i,j,k,ispec)
- Q_mu = scale_factor(i,j,k,ispec)
+ do i = 1, NGLLX
+ tau_e(:) = factor_common(:,i,j,k,ispec)
+ Q_mu = scale_factor(i,j,k,ispec)
- ! Determine the factor_common and one_minus_sum_beta from tau_s and tau_e
- call get_attenuation_property_values(tau_s, tau_e, fc, omsb)
+ ! Determine the factor_common and one_minus_sum_beta from tau_s and tau_e
+ call get_attenuation_property_values(tau_s, tau_e, fc, omsb)
- factor_common(:,i,j,k,ispec) = fc(:)
- one_minus_sum_beta(i,j,k,ispec) = omsb
+ factor_common(:,i,j,k,ispec) = fc(:)
+ one_minus_sum_beta(i,j,k,ispec) = omsb
- ! Determine the "scale_factor" from tau_s, tau_e, central source frequency, and Q
- call get_attenuation_scale_factor(myrank, T_c_source, tau_e, tau_s, Q_mu, sf)
- scale_factor(i,j,k,ispec) = sf
- enddo
+ ! Determine the "scale_factor" from tau_s, tau_e, central source frequency, and Q
+ call get_attenuation_scale_factor(myrank, T_c_source, tau_e, tau_s, Q_mu, sf)
+ scale_factor(i,j,k,ispec) = sf
+ enddo
enddo
- enddo
- enddo
+ enddo
+ enddo
end subroutine get_attenuation_model_3D
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/get_event_info.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/get_event_info.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/get_event_info.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -127,33 +127,26 @@
!--- arguments of the subroutine below
- integer, intent(out) :: yr,jda,ho,mi
+ integer, intent(in) :: NSOURCES
+ integer, intent(out) :: yr,jda,ho,mi
+ double precision, intent(out) :: sec
+ double precision, intent(out) :: tshift_cmt,t_shift
+ double precision, intent(out) :: elat_pde,elon_pde,depth_pde
real, intent(out) :: mb
+ double precision, intent(out) :: cmt_lat,cmt_lon,cmt_depth,cmt_hdur
- double precision, intent(out) :: sec,tshift_cmt,t_shift
- double precision, intent(out) :: elat_pde,elon_pde,depth_pde,cmt_lat,cmt_lon,cmt_depth,cmt_hdur
-
- !integer, intent(in) :: LENGTH_REGION_NAME
- !character(len=LENGTH_REGION_NAME), intent(out) :: region ! event name for SAC header
-
character(len=20), intent(out) :: event_name ! event name for SAC header
- integer, intent(in) :: NSOURCES
-
-!--- local variables here
-
- integer ios,mo,da,julian_day
- integer isource
-
+ ! local parameters
+ integer :: ios,mo,da,julian_day
+ integer :: isource
double precision, dimension(NSOURCES) :: t_s,hdur,lat,lon,depth
character(len=20), dimension(NSOURCES) :: e_n
+ real :: ms
+ character(len=5) :: datasource
+ character(len=150) :: string,CMTSOLUTION
- real ms
-
- character(len=5) datasource
- character(len=150) string,CMTSOLUTION
-
!
!---- read hypocenter info
!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/initialize_simulation.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/initialize_simulation.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -133,7 +133,7 @@
! local parameters
integer, dimension(MAX_NUM_REGIONS) :: NSPEC_computed,NGLOB_computed, &
- NSPEC2D_XI,NSPEC2D_ETA,NSPEC1D_RADIAL
+ NSPEC2D_XI,NSPEC2D_ETA,NSPEC1D_RADIAL
logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
@@ -142,19 +142,20 @@
integer :: ratio_divide_central_cube
integer :: sizeprocs
- integer :: ier,i,j,ios
+ integer :: ier,i,j
+ integer :: ios
integer :: NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,NPROC_XI,NPROC_ETA
double precision :: RMOHO_FICTITIOUS_IN_MESHER,R120,R_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,&
- CENTER_LATITUDE_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,ANGULAR_WIDTH_XI_IN_DEGREES,&
- GAMMA_ROTATION_AZIMUTH
+ CENTER_LATITUDE_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,ANGULAR_WIDTH_XI_IN_DEGREES,&
+ GAMMA_ROTATION_AZIMUTH
integer :: REFERENCE_1D_MODEL,THREE_D_MODEL
logical :: TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS, &
- ATTENUATION,ATTENUATION_3D,ROTATION,ELLIPTICITY,GRAVITY,CASE_3D,ISOTROPIC_3D_MANTLE, &
+ ATTENUATION,ATTENUATION_3D,ROTATION,ELLIPTICITY, &
+ GRAVITY,CASE_3D,ISOTROPIC_3D_MANTLE, &
HETEROGEN_3D_MANTLE,CRUSTAL,INFLATE_CENTRAL_CUBE
-
character(len=150) :: MODEL,dummystring
! sizeprocs returns number of processes started (should be equal to NPROCTOT).
@@ -186,7 +187,9 @@
MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE, &
+ LOCAL_PATH,MODEL, &
+ SIMULATION_TYPE,SAVE_FORWARD, &
NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
NSPEC_computed,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX, &
NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
@@ -236,7 +239,7 @@
REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL,&
+ ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL, &
PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
@@ -289,7 +292,8 @@
tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
write(IMAIN,*)
- write(IMAIN,*) 'model:'
+ ! model user parameters
+ write(IMAIN,*) 'model: ',trim(MODEL)
! model mesh parameters
if(ISOTROPIC_3D_MANTLE) then
@@ -412,7 +416,10 @@
endif
! user output
- if( myrank == 0 ) write(IMAIN,*) 'incorporates ATTENUATION for time-reversed simulation'
+ if( myrank == 0 ) then
+ write(IMAIN,*) 'incorporates ATTENUATION for time-reversed simulation'
+ write(IMAIN,*)
+ endif
endif
! checks adjoint array dimensions
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/iterate_time.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/iterate_time.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/iterate_time.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,655 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine iterate_time()
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
- use specfem_par_movie
- implicit none
-
- ! timing
- double precision, external :: wtime
-
-!
-! s t a r t t i m e i t e r a t i o n s
-!
-
- ! synchronize all processes to make sure everybody is ready to start time loop
- call sync_all()
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'Starting time iteration loop...'
- write(IMAIN,*)
- endif
-
- ! create an empty file to monitor the start of the simulation
- if(myrank == 0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/starttimeloop.txt',status='unknown',action='write')
- write(IOUT,*) 'hello, starting time loop'
- close(IOUT)
- endif
-
- ! initialize variables for writing seismograms
- seismo_offset = it_begin-1
- seismo_current = 0
-
-#ifdef _HANDOPT
- imodulo_NGLOB_CRUST_MANTLE = mod(NGLOB_CRUST_MANTLE,3)
- imodulo_NGLOB_CRUST_MANTLE4 = mod(NGLOB_CRUST_MANTLE,4)
- imodulo_NGLOB_INNER_CORE = mod(NGLOB_INNER_CORE,3)
- imodulo_NGLOB_OUTER_CORE = mod(NGLOB_OUTER_CORE,3)
-#endif
-
- ! get MPI starting time
- time_start = wtime()
-
- ! *********************************************************
- ! ************* MAIN LOOP OVER THE TIME STEPS *************
- ! *********************************************************
-
- do it = it_begin,it_end
-
- ! simulation status output and stability check
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
- call it_check_stability()
- endif
-
- ! update displacement using Newmark time scheme
- call it_update_displacement_scheme()
-
- ! acoustic solver for outer core
- ! (needs to be done first, before elastic one)
- call compute_forces_acoustic()
-
- ! elastic solver for crust/mantle and inner core
- call compute_forces_elastic()
-
- ! restores last time snapshot saved for backward/reconstruction of wavefields
- ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
- ! and adjoint sources will become more complicated
- ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
- if( SIMULATION_TYPE == 3 .and. it == 1 ) then
- call read_forward_arrays()
- endif
-
- ! write the seismograms with time shift
- if( nrec_local > 0 .or. ( WRITE_SEISMOGRAMS_BY_MASTER .and. myrank == 0 ) ) then
- call write_seismograms()
- endif
-
- ! adjoint simulations: kernels
- if( SIMULATION_TYPE == 3 ) then
- call compute_kernels()
- endif
-
- ! outputs movie files
- call write_movie_output()
-
- ! first step of noise tomography, i.e., save a surface movie at every time step
- ! modified from the subroutine 'write_movie_surface'
- if( NOISE_TOMOGRAPHY == 1 ) then
- call noise_save_surface_movie()
- endif
-
- ! updates vtk window
- if( VTK_MODE ) then
- call it_update_vtkwindow()
- endif
-
- enddo ! end of main time loop
-
- !
- !---- end of time iteration loop
- !
-
- call it_print_elapsed_time()
-
- ! Transfer fields from GPU card to host for further analysis
- if(GPU_MODE) call it_transfer_from_GPU()
-
- end subroutine iterate_time
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine it_update_displacement_scheme()
-
-! explicit Newmark time scheme with acoustic & elastic domains:
-! (see e.g. Hughes, 1987; Chaljub et al., 2003)
-!
-! chi(t+delta_t) = chi(t) + delta_t chi_dot(t) + 1/2 delta_t**2 chi_dot_dot(t)
-! chi_dot(t+delta_t) = chi_dot(t) + 1/2 delta_t chi_dot_dot(t) + 1/2 delta_t chi_dot_dot(t+delta_t)
-! chi_dot_dot(t+delta_t) = 1/M_acoustic( -K_acoustic chi(t+delta) + B_acoustic u(t+delta_t) + f(t+delta_t) )
-!
-! u(t+delta_t) = u(t) + delta_t v(t) + 1/2 delta_t**2 a(t)
-! v(t+delta_t) = v(t) + 1/2 delta_t a(t) + 1/2 delta_t a(t+delta_t)
-! a(t+delta_t) = 1/M_elastic ( -K_elastic u(t+delta) + B_elastic chi_dot_dot(t+delta_t) + f( t+delta_t) )
-!
-! where
-! chi, chi_dot, chi_dot_dot are acoustic (fluid) potentials ( dotted with respect to time)
-! u, v, a are displacement,velocity & acceleration
-! M is mass matrix, K stiffness matrix and B boundary term for acoustic/elastic domains
-! f denotes a source term (acoustic/elastic)
-!
-! note that this stage calculates the predictor terms
-!
-! for
-! potential chi_dot(t+delta) requires + 1/2 delta_t chi_dot_dot(t+delta_t)
-! at a later stage (corrector) once where chi_dot_dot(t+delta) is calculated
-! and similar,
-! velocity v(t+delta_t) requires + 1/2 delta_t a(t+delta_t)
-! at a later stage once where a(t+delta) is calculated
-! also:
-! boundary term B_elastic requires chi_dot_dot(t+delta)
-! thus chi_dot_dot has to be updated first before the elastic boundary term is considered
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
- implicit none
-
- ! local parameters
- integer :: i
-
- ! updates wavefields
- if( .not. GPU_MODE) then
- ! on CPU
-
- ! Newmark time scheme update
-#ifdef _HANDOPT_NEWMARK
-! way 2:
-! One common technique in computational science to help enhance pipelining is loop unrolling
-!
-! we're accessing NDIM=3 components at each line,
-! that is, for an iteration, the register must contain
-! NDIM * displ_ + NDIM * veloc_ + NDIM * accel + deltat + deltatsq..
-! in most cases a real (CUSTOM_REAL) value will have 4 bytes,
-! assuming a default cache size of about 128 bytes, we unroll here in steps of 3, thus 29 reals or 118 bytes,
-! rather than with steps of 4
- ! mantle
- if(imodulo_NGLOB_CRUST_MANTLE >= 1) then
- do i = 1,imodulo_NGLOB_CRUST_MANTLE
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
-
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
-
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- endif
- do i = imodulo_NGLOB_CRUST_MANTLE+1,NGLOB_CRUST_MANTLE, 3 ! in steps of 3
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
- displ_crust_mantle(:,i+1) = displ_crust_mantle(:,i+1) &
- + deltat*veloc_crust_mantle(:,i+1) + deltatsqover2*accel_crust_mantle(:,i+1)
- displ_crust_mantle(:,i+2) = displ_crust_mantle(:,i+2) &
- + deltat*veloc_crust_mantle(:,i+2) + deltatsqover2*accel_crust_mantle(:,i+2)
-
-
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i+1) = veloc_crust_mantle(:,i+1) &
- + deltatover2*accel_crust_mantle(:,i+1)
- veloc_crust_mantle(:,i+2) = veloc_crust_mantle(:,i+2) &
- + deltatover2*accel_crust_mantle(:,i+2)
-
- ! set acceleration to zero
- ! note: we do initialize acceleration in this loop since it is read already into the cache,
- ! otherwise it would have to be read in again for this explicitly,
- ! which would make this step more expensive
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- accel_crust_mantle(:,i+1) = 0._CUSTOM_REAL
- accel_crust_mantle(:,i+2) = 0._CUSTOM_REAL
- enddo
-
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- displ_outer_core(i) = displ_outer_core(i) &
- + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
-
- veloc_outer_core(i) = veloc_outer_core(i) &
- + deltatover2*accel_outer_core(i)
-
- accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
-
- ! inner core
- if(imodulo_NGLOB_INNER_CORE >= 1) then
- do i = 1,imodulo_NGLOB_INNER_CORE
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
-
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
- endif
- do i = imodulo_NGLOB_INNER_CORE+1,NGLOB_INNER_CORE, 3 ! in steps of 3
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
- displ_inner_core(:,i+1) = displ_inner_core(:,i+1) &
- + deltat*veloc_inner_core(:,i+1) + deltatsqover2*accel_inner_core(:,i+1)
- displ_inner_core(:,i+2) = displ_inner_core(:,i+2) &
- + deltat*veloc_inner_core(:,i+2) + deltatsqover2*accel_inner_core(:,i+2)
-
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
- veloc_inner_core(:,i+1) = veloc_inner_core(:,i+1) &
- + deltatover2*accel_inner_core(:,i+1)
- veloc_inner_core(:,i+2) = veloc_inner_core(:,i+2) &
- + deltatover2*accel_inner_core(:,i+2)
-
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- accel_inner_core(:,i+1) = 0._CUSTOM_REAL
- accel_inner_core(:,i+2) = 0._CUSTOM_REAL
- enddo
-#else
-! way 1:
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- displ_outer_core(i) = displ_outer_core(i) &
- + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) &
- + deltatover2*accel_outer_core(i)
- accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
-#endif
-
- ! backward field
- if (SIMULATION_TYPE == 3) then
-
-#ifdef _HANDOPT_NEWMARK
-! way 2:
- ! mantle
- if(imodulo_NGLOB_CRUST_MANTLE >= 1) then
- do i=1,imodulo_NGLOB_CRUST_MANTLE
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- endif
- do i=imodulo_NGLOB_CRUST_MANTLE+1,NGLOB_CRUST_MANTLE,3
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_displ_crust_mantle(:,i+1) = b_displ_crust_mantle(:,i+1) &
- + b_deltat*b_veloc_crust_mantle(:,i+1) + b_deltatsqover2*b_accel_crust_mantle(:,i+1)
- b_displ_crust_mantle(:,i+2) = b_displ_crust_mantle(:,i+2) &
- + b_deltat*b_veloc_crust_mantle(:,i+2) + b_deltatsqover2*b_accel_crust_mantle(:,i+2)
-
-
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i+1) = b_veloc_crust_mantle(:,i+1) &
- + b_deltatover2*b_accel_crust_mantle(:,i+1)
- b_veloc_crust_mantle(:,i+2) = b_veloc_crust_mantle(:,i+2) &
- + b_deltatover2*b_accel_crust_mantle(:,i+2)
-
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- b_accel_crust_mantle(:,i+1) = 0._CUSTOM_REAL
- b_accel_crust_mantle(:,i+2) = 0._CUSTOM_REAL
- enddo
-
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- b_displ_outer_core(i) = b_displ_outer_core(i) &
- + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) &
- + b_deltatover2*b_accel_outer_core(i)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
-
- ! inner core
- if(imodulo_NGLOB_INNER_CORE >= 1) then
- do i=1,imodulo_NGLOB_INNER_CORE
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
- endif
- do i=imodulo_NGLOB_INNER_CORE+1,NGLOB_INNER_CORE,3
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_displ_inner_core(:,i+1) = b_displ_inner_core(:,i+1) &
- + b_deltat*b_veloc_inner_core(:,i+1) + b_deltatsqover2*b_accel_inner_core(:,i+1)
- b_displ_inner_core(:,i+2) = b_displ_inner_core(:,i+2) &
- + b_deltat*b_veloc_inner_core(:,i+2) + b_deltatsqover2*b_accel_inner_core(:,i+2)
-
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i+1) = b_veloc_inner_core(:,i+1) &
- + b_deltatover2*b_accel_inner_core(:,i+1)
- b_veloc_inner_core(:,i+2) = b_veloc_inner_core(:,i+2) &
- + b_deltatover2*b_accel_inner_core(:,i+2)
-
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- b_accel_inner_core(:,i+1) = 0._CUSTOM_REAL
- b_accel_inner_core(:,i+2) = 0._CUSTOM_REAL
- enddo
-#else
-! way 1:
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- b_displ_outer_core(i) = b_displ_outer_core(i) &
- + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) &
- + b_deltatover2*b_accel_outer_core(i)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
-#endif
- endif ! SIMULATION_TYPE == 3
- else
- ! on GPU
- ! Includes SIM_TYPE 1 & 3
-
- ! outer core region
- call it_update_displacement_oc_cuda(Mesh_pointer, &
- deltat, deltatsqover2, deltatover2, &
- b_deltat, b_deltatsqover2, b_deltatover2)
- ! inner core region
- call it_update_displacement_ic_cuda(Mesh_pointer, &
- deltat, deltatsqover2, deltatover2, &
- b_deltat, b_deltatsqover2, b_deltatover2)
-
- ! crust/mantle region
- call it_update_displacement_cm_cuda(Mesh_pointer, &
- deltat, deltatsqover2, deltatover2, &
- b_deltat, b_deltatsqover2, b_deltatover2)
- endif
-
- end subroutine it_update_displacement_scheme
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine it_print_elapsed_time()
-
- use specfem_par
- implicit none
-
- ! local parameters
- integer :: ihours,iminutes,iseconds,int_tCPU
- ! timing
- double precision, external :: wtime
-
- if(myrank == 0) then
- ! elapsed time since beginning of the simulation
- tCPU = wtime() - time_start
-
- int_tCPU = int(tCPU)
- ihours = int_tCPU / 3600
- iminutes = (int_tCPU - 3600*ihours) / 60
- iseconds = int_tCPU - 3600*ihours - 60*iminutes
- write(IMAIN,*) 'Time-Loop Complete. Timing info:'
- write(IMAIN,*) 'Total elapsed time in seconds = ',tCPU
- write(IMAIN,"(' Total elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
- endif
- end subroutine it_print_elapsed_time
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine it_check_stability()
-
-! computes the maximum of the norm of the displacement
-! in all the slices using an MPI reduction
-! and output timestamp file to check that simulation is running fine
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
- use specfem_par_movie
- implicit none
-
- ! compute the maximum of the norm of the displacement
- ! in all the slices using an MPI reduction
- ! and output timestamp file to check that simulation is running fine
- call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
- b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
- eps_trace_over_3_crust_mantle, &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle,epsilondev_xy_crust_mantle, &
- epsilondev_xz_crust_mantle,epsilondev_yz_crust_mantle, &
- SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
- myrank)
-
- ! debug output
- !if( maxval(displ_crust_mantle(1,:)**2 + &
- ! displ_crust_mantle(2,:)**2 + displ_crust_mantle(3,:)**2) > 1.e4 ) then
- ! print*,'slice',myrank
- ! print*,' crust_mantle displ:', maxval(displ_crust_mantle(1,:)), &
- ! maxval(displ_crust_mantle(2,:)),maxval(displ_crust_mantle(3,:))
- ! print*,' indxs: ',maxloc( displ_crust_mantle(1,:)),maxloc( displ_crust_mantle(2,:)),maxloc( displ_crust_mantle(3,:))
- ! indx = maxloc( displ_crust_mantle(3,:) )
- ! rval = xstore_crust_mantle(indx(1))
- ! thetaval = ystore_crust_mantle(indx(1))
- ! phival = zstore_crust_mantle(indx(1))
- ! !thetaval = PI_OVER_TWO-datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dsin(dble(thetaval))))
- ! print*,'r/lat/lon:',rval*R_EARTH_KM,90.0-thetaval*180./PI,phival*180./PI
- ! call rthetaphi_2_xyz(rval,thetaval,phival,xstore_crust_mantle(indx(1)),&
- ! ystore_crust_mantle(indx(1)),zstore_crust_mantle(indx(1)))
- ! print*,'x/y/z:',rval,thetaval,phival
- ! call exit_MPI(myrank,'error stability')
- !endif
-
- end subroutine it_check_stability
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine it_transfer_from_GPU()
-
-! transfers fields on GPU back onto CPU
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
- implicit none
-
- ! to store forward wave fields
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
-
- call transfer_fields_cm_from_device(NDIM*NGLOB_CRUST_MANTLE, &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
- Mesh_pointer)
- call transfer_fields_ic_from_device(NDIM*NGLOB_INNER_CORE, &
- displ_inner_core,veloc_inner_core,accel_inner_core, &
- Mesh_pointer)
- call transfer_fields_oc_from_device(NGLOB_OUTER_CORE, &
- displ_outer_core,veloc_outer_core,accel_outer_core, &
- Mesh_pointer)
-
- call transfer_strain_cm_from_device(Mesh_pointer,eps_trace_over_3_crust_mantle, &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle, &
- epsilondev_xy_crust_mantle,epsilondev_xz_crust_mantle, &
- epsilondev_yz_crust_mantle)
- call transfer_strain_ic_from_device(Mesh_pointer,eps_trace_over_3_inner_core, &
- epsilondev_xx_inner_core,epsilondev_yy_inner_core, &
- epsilondev_xy_inner_core,epsilondev_xz_inner_core, &
- epsilondev_yz_inner_core)
-
- if (ROTATION_VAL) then
- call transfer_rotation_from_device(Mesh_pointer,A_array_rotation,B_array_rotation)
- endif
-
- ! note: for kernel simulations (SIMULATION_TYPE == 3), attenuation is
- ! only mimicking effects on phase shifts, but not on amplitudes.
- ! flag USE_ATTENUATION_MIMIC will have to be set to true in this case.
- !
- ! arrays b_R_xx, ... are not used when USE_ATTENUATION_MIMIC is set,
- ! therefore no need to transfer arrays from GPU to CPU
- !if (ATTENUATION) then
- !endif
-
- else if (SIMULATION_TYPE == 3) then
- ! to store kernels
- call transfer_kernels_oc_to_host(Mesh_pointer, &
- rho_kl_outer_core,&
- alpha_kl_outer_core,NSPEC_OUTER_CORE)
- call transfer_kernels_cm_to_host(Mesh_pointer, &
- rho_kl_crust_mantle, &
- alpha_kl_crust_mantle, &
- beta_kl_crust_mantle, &
- cijkl_kl_crust_mantle,NSPEC_CRUST_MANTLE)
- call transfer_kernels_ic_to_host(Mesh_pointer, &
- rho_kl_inner_core, &
- alpha_kl_inner_core, &
- beta_kl_inner_core,NSPEC_INNER_CORE)
-
- ! specific noise strength kernel
- if( NOISE_TOMOGRAPHY == 3 ) then
- call transfer_kernels_noise_to_host(Mesh_pointer,Sigma_kl_crust_mantle,NSPEC_CRUST_MANTLE)
- endif
-
- ! approximative hessian for preconditioning kernels
- if ( APPROXIMATE_HESS_KL ) then
- call transfer_kernels_hess_cm_tohost(Mesh_pointer,hess_kl_crust_mantle,NSPEC_CRUST_MANTLE)
- endif
- endif
-
- ! frees allocated memory on GPU
- call prepare_cleanup_device(Mesh_pointer,NCHUNKS_VAL)
-
- end subroutine it_transfer_from_GPU
-
-!=====================================================================
-
-
- subroutine it_update_vtkwindow()
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_movie
-
- implicit none
-
- real :: currenttime
- integer :: iglob,inum
- real(kind=CUSTOM_REAL),dimension(1):: dummy
-
- ! vtk rendering at frame interval
- if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0 ) then
-
- ! user output
- !if( myrank == 0 ) print*," vtk rendering..."
-
- ! updates time
- currenttime = sngl((it-1)*DT-t0)
-
- ! transfers fields from GPU to host
- if( GPU_MODE ) then
- !if( myrank == 0 ) print*," vtk: transfering velocity from gpu"
- call transfer_veloc_cm_from_device(NDIM*NGLOB_CRUST_MANTLE,veloc_crust_mantle,Mesh_pointer)
- endif
-
- ! updates wavefield
- !if( myrank == 0 ) print*," vtk: it = ",it," out of ",it_end," - norm of velocity field"
- inum = 0
- vtkdata(:) = 0.0
- do iglob = 1,NGLOB_CRUST_MANTLE
- if( vtkmask(iglob) .eqv. .true. ) then
- inum = inum + 1
- ! stores norm of velocity vector
- vtkdata(inum) = sqrt(veloc_crust_mantle(1,iglob)**2 &
- + veloc_crust_mantle(2,iglob)**2 &
- + veloc_crust_mantle(3,iglob)**2)
- endif
- enddo
-
- ! updates for multiple mpi process
- if( NPROCTOT_VAL > 1 ) then
- if( myrank == 0 ) then
- ! gather data
- call gatherv_all_cr(vtkdata,size(vtkdata),&
- vtkdata_all,vtkdata_points_all,vtkdata_offset_all, &
- vtkdata_numpoints_all,NPROCTOT_VAL)
- ! updates vtk window
- call visualize_vtkdata(it,currenttime,vtkdata_all)
- else
- ! all other process just send data
- call gatherv_all_cr(vtkdata,size(vtkdata),&
- dummy,vtkdata_points_all,vtkdata_offset_all, &
- 1,NPROCTOT_VAL)
- endif
- else
- ! serial run
- ! updates vtk window
- call visualize_vtkdata(it,currenttime,vtkdata)
- endif
-
- endif
-
- end subroutine it_update_vtkwindow
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/locate_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/locate_receivers.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/locate_receivers.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -40,7 +40,7 @@
implicit none
-! standard include of the MPI library
+ ! standard include of the MPI library
include 'mpif.h'
include "constants.h"
@@ -55,26 +55,31 @@
integer nspl
double precision rspl(NR),espl(NR),espl2(NR)
- integer nspec,nglob,nrec,myrank,nrec_found
+ integer nrec,myrank
+ integer nspec,nglob
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ ! arrays containing coordinates of the points
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
integer yr,jda,ho,mi
double precision sec
+ double precision theta_source,phi_source
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
integer NSTEP
double precision DT
-! arrays containing coordinates of the points
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
-
! Gauss-Lobatto-Legendre points of integration
double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
- character(len=*) rec_filename
+ character(len=*) rec_filename
! use integer array to store values
integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+ ! local parameters
+ integer :: nrec_found
integer, allocatable, dimension(:) :: ix_initial_guess,iy_initial_guess,iz_initial_guess
integer iorientation
@@ -97,7 +102,6 @@
double precision sint,cost,sinp,cosp
double precision r0,p20
double precision theta,phi
- double precision theta_source,phi_source
double precision dist
double precision xi,eta,gamma,dx,dy,dz,dxi,deta,dgamma
@@ -156,14 +160,13 @@
double precision, allocatable, dimension(:) :: final_distance_subset
integer, allocatable, dimension(:) :: ispec_selected_rec_subset
-! **************
+ ! get MPI starting time
+ time_start = MPI_WTIME()
-! make sure we clean the array before the gather
+ ! make sure we clean the array before the gather
ispec_selected_rec(:) = 0
-! get MPI starting time
- time_start = MPI_WTIME()
-
+ ! user output
if(myrank == 0) then
write(IMAIN,*)
write(IMAIN,*) '********************'
@@ -199,7 +202,7 @@
! read that STATIONS file on the master
if(myrank == 0) then
- call get_value_string(STATIONS, 'solver.STATIONS', rec_filename)
+ call get_value_string(STATIONS, 'solver.STATIONS', trim(rec_filename))
open(unit=1,file=STATIONS,status='old',action='read',iostat=ier)
if( ier /= 0 ) call exit_MPI(myrank,'error opening STATIONS file')
@@ -321,13 +324,17 @@
enddo
-! ellipticity
- r0=1.0d0
+ ! normalized receiver radius
+ r0 = R_UNIT_SPHERE
+
+ ! finds elevation of receiver
+ if(TOPOGRAPHY) then
+ call get_topo_bathy(stlat(irec),stlon(irec),elevation,ibathy_topo)
+ r0 = r0 + elevation/R_EARTH
+ endif
+
+ ! ellipticity
if(ELLIPTICITY) then
- if(TOPOGRAPHY) then
- call get_topo_bathy(stlat(irec),stlon(irec),elevation,ibathy_topo)
- r0 = r0 + elevation/R_EARTH
- endif
cost=cos(theta)
p20=0.5d0*(3.0d0*cost*cost-1.0d0)
call spline_evaluation(rspl,espl,espl2,nspl,r0,ell)
@@ -391,7 +398,10 @@
! Harvard format does not support the network name
! therefore only the station name is included below
! compute total number of samples for normal modes with 1 sample per second
- open(unit=1,file=trim(OUTPUT_FILES)//'/RECORDHEADERS',status='unknown')
+ open(unit=1,file=trim(OUTPUT_FILES)//'/RECORDHEADERS', &
+ status='unknown',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening file RECORDHEADERS')
+
nsamp = nint(dble(NSTEP-1)*DT)
do irec = 1,nrec
@@ -483,30 +493,33 @@
! define coordinates of the control points of the element
do ia=1,NGNOD
+ iax = 0
if(iaddx(ia) == 0) then
iax = 1
else if(iaddx(ia) == 1) then
- iax = (NGLLX+1)/2
+ iax = MIDX
else if(iaddx(ia) == 2) then
iax = NGLLX
else
call exit_MPI(myrank,'incorrect value of iaddx')
endif
+ iay = 0
if(iaddy(ia) == 0) then
iay = 1
else if(iaddy(ia) == 1) then
- iay = (NGLLY+1)/2
+ iay = MIDY
else if(iaddy(ia) == 2) then
iay = NGLLY
else
call exit_MPI(myrank,'incorrect value of iaddy')
endif
+ iaz = 0
if(iaddr(ia) == 0) then
iaz = 1
else if(iaddr(ia) == 1) then
- iaz = (NGLLZ+1)/2
+ iaz = MIDZ
else if(iaddr(ia) == 2) then
iaz = NGLLZ
else
@@ -539,13 +552,17 @@
! gamma does not change since we know the receiver is exactly on the surface
dxi = xix*dx + xiy*dy + xiz*dz
deta = etax*dx + etay*dy + etaz*dz
- if(RECEIVERS_CAN_BE_BURIED) dgamma = gammax*dx + gammay*dy + gammaz*dz
! update values
xi = xi + dxi
eta = eta + deta
- if(RECEIVERS_CAN_BE_BURIED) gamma = gamma + dgamma
+ ! buried receivers vary in z depth
+ if(RECEIVERS_CAN_BE_BURIED) then
+ dgamma = gammax*dx + gammay*dy + gammaz*dz
+ gamma = gamma + dgamma
+ endif
+
! impose that we stay in that element
! (useful if user gives a receiver outside the mesh for instance)
! we can go slightly outside the [1,1] segment since with finite elements
@@ -581,7 +598,8 @@
! compute final distance between asked and found (converted to km)
final_distance(irec) = dsqrt((x_target(irec)-x_found(irec))**2 + &
- (y_target(irec)-y_found(irec))**2 + (z_target(irec)-z_found(irec))**2)*R_EARTH/1000.d0
+ (y_target(irec)-y_found(irec))**2 + &
+ (z_target(irec)-z_found(irec))**2)*R_EARTH/1000.d0
final_distance_subset(irec_in_this_subset) = final_distance(irec)
@@ -621,7 +639,7 @@
! mapping from station number in current subset to real station number in all the subsets
irec = irec_in_this_subset + irec_already_done
- distmin = HUGEVAL
+ distmin = HUGEVAL
do iprocloop = 0,NPROCTOT-1
if(final_distance_all(irec_in_this_subset,iprocloop) < distmin) then
distmin = final_distance_all(irec_in_this_subset,iprocloop)
@@ -668,7 +686,7 @@
if(final_distance(irec) == HUGEVAL) call exit_MPI(myrank,'error locating receiver')
- if(DISPLAY_DETAILS_STATIONS) then
+ if(DISPLAY_DETAILS_STATIONS .or. final_distance(irec) > 0.01d0 ) then
write(IMAIN,*)
write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec)
write(IMAIN,*) ' original latitude: ',sngl(stlat(irec))
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/locate_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/locate_sources.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/locate_sources.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -30,14 +30,14 @@
!----
subroutine locate_sources(NSOURCES,myrank,nspec,nglob,ibool,&
- xstore,ystore,zstore,xigll,yigll,zigll, &
- NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
- sec,tshift_cmt,min_tshift_cmt_original,yr,jda,ho,mi,theta_source,phi_source, &
- NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- islice_selected_source,ispec_selected_source, &
- xi_source,eta_source,gamma_source, nu_source, &
- rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION, &
- LOCAL_PATH,SIMULATION_TYPE)
+ xstore,ystore,zstore,xigll,yigll,zigll, &
+ NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
+ sec,tshift_cmt,min_tshift_cmt_original,yr,jda,ho,mi,theta_source,phi_source, &
+ NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source, nu_source, &
+ rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION, &
+ LOCAL_PATH,SIMULATION_TYPE)
implicit none
@@ -89,7 +89,7 @@
character(len=150) :: LOCAL_PATH
integer :: SIMULATION_TYPE
-! local parameters
+ ! local parameters
integer isource
integer iprocloop
integer i,j,k,ispec,iglob
@@ -174,19 +174,21 @@
! mask source region (mask values are between 0 and 1, with 0 around sources)
real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable :: mask_source
-! **************
+ ! get MPI starting time for all sources
+ time_start = MPI_WTIME()
-! make sure we clean the future final array
+ ! make sure we clean the future final array
ispec_selected_source(:) = 0
+ final_distance_source(:) = HUGEVAL
-! get the base pathname for output files
+ ! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-! read all the sources
+ ! read all the sources
if(myrank == 0) call get_cmt(yr,jda,ho,mi,sec,tshift_cmt,hdur,lat,long,depth,moment_tensor, &
DT,NSOURCES,min_tshift_cmt_original)
-! broadcast the information read on the master to the nodes
+ ! broadcast the information read on the master to the nodes
call MPI_BCAST(yr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(jda,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(ho,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
@@ -206,15 +208,13 @@
! define topology of the control element
call hex_nodes(iaddx,iaddy,iaddr)
-! initializes source mask
+ ! initializes source mask
if( SAVE_SOURCE_MASK .and. SIMULATION_TYPE == 3 ) then
- allocate( mask_source(NGLLX,NGLLY,NGLLZ,NSPEC) )
+ allocate(mask_source(NGLLX,NGLLY,NGLLZ,NSPEC),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating mask source array')
mask_source(:,:,:,:) = 1.0_CUSTOM_REAL
endif
-! get MPI starting time for all sources
- time_start = MPI_WTIME()
-
! loop on all the sources
! gather source information in subsets to reduce memory requirements
@@ -225,24 +225,24 @@
! or if there are fewer sources than the maximum size of a subset)
NSOURCES_SUBSET_current_size = min(NSOURCES_SUBSET_MAX, NSOURCES - isources_already_done)
-! allocate arrays specific to each subset
- allocate(final_distance_source_subset(NSOURCES_SUBSET_current_size), &
- ispec_selected_source_subset(NSOURCES_SUBSET_current_size), &
- ispec_selected_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
- xi_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
- eta_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
- gamma_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
- final_distance_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
- x_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
- y_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
- z_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
- xi_source_subset(NSOURCES_SUBSET_current_size), &
- eta_source_subset(NSOURCES_SUBSET_current_size), &
- gamma_source_subset(NSOURCES_SUBSET_current_size), &
- x_found_source(NSOURCES_SUBSET_current_size), &
- y_found_source(NSOURCES_SUBSET_current_size), &
- z_found_source(NSOURCES_SUBSET_current_size),stat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error allocating temporary source arrays')
+ ! allocate arrays specific to each subset
+ allocate(final_distance_source_subset(NSOURCES_SUBSET_current_size), &
+ ispec_selected_source_subset(NSOURCES_SUBSET_current_size), &
+ ispec_selected_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
+ xi_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
+ eta_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
+ gamma_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
+ final_distance_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
+ x_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
+ y_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
+ z_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1), &
+ xi_source_subset(NSOURCES_SUBSET_current_size), &
+ eta_source_subset(NSOURCES_SUBSET_current_size), &
+ gamma_source_subset(NSOURCES_SUBSET_current_size), &
+ x_found_source(NSOURCES_SUBSET_current_size), &
+ y_found_source(NSOURCES_SUBSET_current_size), &
+ z_found_source(NSOURCES_SUBSET_current_size),stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating temporary source arrays')
! make sure we clean the subset array before the gather
ispec_selected_source_subset(:) = 0
@@ -331,95 +331,104 @@
! normalized source radius
r0 = R_UNIT_SPHERE
- if(ELLIPTICITY) then
- if(TOPOGRAPHY) then
- call get_topo_bathy(lat(isource),long(isource),elevation,ibathy_topo)
- r0 = r0 + elevation/R_EARTH
- endif
- dcost = dcos(theta)
- p20 = 0.5d0*(3.0d0*dcost*dcost-1.0d0)
- radius = r0 - depth(isource)*1000.0d0/R_EARTH
- call spline_evaluation(rspl,espl,espl2,nspl,radius,ell)
- r0 = r0*(1.0d0-(2.0d0/3.0d0)*ell*p20)
- endif
+ ! finds elevation of position
+ if(TOPOGRAPHY) then
+ call get_topo_bathy(lat(isource),long(isource),elevation,ibathy_topo)
+ r0 = r0 + elevation/R_EARTH
+ endif
+ if(ELLIPTICITY) then
+ dcost = dcos(theta)
+ p20 = 0.5d0*(3.0d0*dcost*dcost-1.0d0)
+ radius = r0 - depth(isource)*1000.0d0/R_EARTH
+ call spline_evaluation(rspl,espl,espl2,nspl,radius,ell)
+ r0 = r0*(1.0d0-(2.0d0/3.0d0)*ell*p20)
+ endif
-! compute the Cartesian position of the source
- r_target_source = r0 - depth(isource)*1000.0d0/R_EARTH
- x_target_source = r_target_source*dsin(theta)*dcos(phi)
- y_target_source = r_target_source*dsin(theta)*dsin(phi)
- z_target_source = r_target_source*dcos(theta)
+ ! subtracts source depth (given in km)
+ r_target_source = r0 - depth(isource)*1000.0d0/R_EARTH
- ! would only output desired target locations
- !if(myrank == 0) write(IOVTK,*) sngl(x_target_source),sngl(y_target_source),sngl(z_target_source)
+ ! compute the Cartesian position of the source
+ x_target_source = r_target_source*dsin(theta)*dcos(phi)
+ y_target_source = r_target_source*dsin(theta)*dsin(phi)
+ z_target_source = r_target_source*dcos(theta)
-! set distance to huge initial value
- distmin = HUGEVAL
+ ! debug
+ ! would only output desired target locations
+ !if(myrank == 0) write(IOVTK,*) sngl(x_target_source),sngl(y_target_source),sngl(z_target_source)
+ ! set distance to huge initial value
+ distmin = HUGEVAL
+
! compute typical size of elements at the surface
typical_size = TWO_PI * R_UNIT_SPHERE / (4.*NEX_XI)
! use 10 times the distance as a criterion for source detection
typical_size = 10. * typical_size
-! flag to check that we located at least one target element
- located_target = .false.
+ ! flag to check that we located at least one target element
+ located_target = .false.
+ ix_initial_guess_source = 0
+ iy_initial_guess_source = 0
+ iz_initial_guess_source = 0
- do ispec = 1,nspec
+ do ispec = 1,nspec
- ! exclude elements that are too far from target
- iglob = ibool(1,1,1,ispec)
- dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
- + (y_target_source - dble(ystore(iglob)))**2 &
- + (z_target_source - dble(zstore(iglob)))**2)
- if(USE_DISTANCE_CRITERION .and. dist > typical_size) cycle
-
+ ! exclude elements that are too far from target
+ if( USE_DISTANCE_CRITERION ) then
+ iglob = ibool(MIDX,MIDY,MIDZ,ispec)
+ dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
+ + (y_target_source - dble(ystore(iglob)))**2 &
+ + (z_target_source - dble(zstore(iglob)))**2)
+ if(dist > typical_size) cycle
+ endif
located_target = .true.
- ! define the interval in which we look for points
- if(USE_FORCE_POINT_SOURCE) then
- ! force sources will be put on an exact GLL point
- imin = 1
- imax = NGLLX
+ ! define the interval in which we look for points
+ if(USE_FORCE_POINT_SOURCE) then
+ ! force sources will be put on an exact GLL point
+ imin = 1
+ imax = NGLLX
- jmin = 1
- jmax = NGLLY
+ jmin = 1
+ jmax = NGLLY
- kmin = 1
- kmax = NGLLZ
+ kmin = 1
+ kmax = NGLLZ
- else
- ! double-couple CMTSOLUTION
- ! loop only on points inside the element
- ! exclude edges to ensure this point is not shared with other elements
- imin = 2
- imax = NGLLX - 1
+ else
+ ! double-couple CMTSOLUTION
+ ! loop only on points inside the element
+ ! exclude edges to ensure this point is not shared with other elements
+ imin = 2
+ imax = NGLLX - 1
- jmin = 2
- jmax = NGLLY - 1
+ jmin = 2
+ jmax = NGLLY - 1
- kmin = 2
- kmax = NGLLZ - 1
- endif
- do k = kmin,kmax
- do j = jmin,jmax
- do i = imin,imax
+ kmin = 2
+ kmax = NGLLZ - 1
+ endif
- ! keep this point if it is closer to the receiver
- iglob = ibool(i,j,k,ispec)
- dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
- +(y_target_source - dble(ystore(iglob)))**2 &
- +(z_target_source - dble(zstore(iglob)))**2)
- if(dist < distmin) then
- distmin = dist
- ispec_selected_source_subset(isource_in_this_subset) = ispec
- ix_initial_guess_source = i
- iy_initial_guess_source = j
- iz_initial_guess_source = k
- endif
+ do k = kmin,kmax
+ do j = jmin,jmax
+ do i = imin,imax
+ ! keep this point if it is closer to the receiver
+ iglob = ibool(i,j,k,ispec)
+ dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
+ +(y_target_source - dble(ystore(iglob)))**2 &
+ +(z_target_source - dble(zstore(iglob)))**2)
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_source_subset(isource_in_this_subset) = ispec
+ ix_initial_guess_source = i
+ iy_initial_guess_source = j
+ iz_initial_guess_source = k
+ endif
+
+ enddo
+ enddo
enddo
- enddo
- enddo
! calculates a gaussian mask around source point
if( SAVE_SOURCE_MASK .and. SIMULATION_TYPE == 3 ) then
@@ -435,14 +444,14 @@
! find the best (xi,eta,gamma) for the source
! *******************************************
- ! if we have not located a target element, the source is not in this slice
- ! therefore use first element only for fictitious iterative search
- if(.not. located_target) then
- ispec_selected_source_subset(isource_in_this_subset)=1
- ix_initial_guess_source = 2
- iy_initial_guess_source = 2
- iz_initial_guess_source = 2
- endif
+ ! if we have not located a target element, the source is not in this slice
+ ! therefore use first element only for fictitious iterative search
+ if(.not. located_target) then
+ ispec_selected_source_subset(isource_in_this_subset)=1
+ ix_initial_guess_source = MIDX
+ iy_initial_guess_source = MIDY
+ iz_initial_guess_source = MIDZ
+ endif
! for point sources, the location will be exactly at a GLL point
! otherwise this tries to find best location
@@ -473,45 +482,48 @@
eta = yigll(iy_initial_guess_source)
gamma = zigll(iz_initial_guess_source)
- ! define coordinates of the control points of the element
- do ia=1,NGNOD
+ ! define coordinates of the control points of the element
+ do ia=1,NGNOD
- if(iaddx(ia) == 0) then
- iax = 1
- else if(iaddx(ia) == 1) then
- iax = (NGLLX+1)/2
- else if(iaddx(ia) == 2) then
- iax = NGLLX
- else
- call exit_MPI(myrank,'incorrect value of iaddx')
- endif
+ iax = 0
+ if(iaddx(ia) == 0) then
+ iax = 1
+ else if(iaddx(ia) == 1) then
+ iax = MIDX
+ else if(iaddx(ia) == 2) then
+ iax = NGLLX
+ else
+ call exit_MPI(myrank,'incorrect value of iaddx')
+ endif
- if(iaddy(ia) == 0) then
- iay = 1
- else if(iaddy(ia) == 1) then
- iay = (NGLLY+1)/2
- else if(iaddy(ia) == 2) then
- iay = NGLLY
- else
- call exit_MPI(myrank,'incorrect value of iaddy')
- endif
+ iay = 0
+ if(iaddy(ia) == 0) then
+ iay = 1
+ else if(iaddy(ia) == 1) then
+ iay = MIDY
+ else if(iaddy(ia) == 2) then
+ iay = NGLLY
+ else
+ call exit_MPI(myrank,'incorrect value of iaddy')
+ endif
- if(iaddr(ia) == 0) then
- iaz = 1
- else if(iaddr(ia) == 1) then
- iaz = (NGLLZ+1)/2
- else if(iaddr(ia) == 2) then
- iaz = NGLLZ
- else
- call exit_MPI(myrank,'incorrect value of iaddr')
- endif
+ iaz = 0
+ if(iaddr(ia) == 0) then
+ iaz = 1
+ else if(iaddr(ia) == 1) then
+ iaz = MIDZ
+ else if(iaddr(ia) == 2) then
+ iaz = NGLLZ
+ else
+ call exit_MPI(myrank,'incorrect value of iaddr')
+ endif
- iglob = ibool(iax,iay,iaz,ispec_selected_source_subset(isource_in_this_subset))
- xelm(ia) = dble(xstore(iglob))
- yelm(ia) = dble(ystore(iglob))
- zelm(ia) = dble(zstore(iglob))
+ iglob = ibool(iax,iay,iaz,ispec_selected_source_subset(isource_in_this_subset))
+ xelm(ia) = dble(xstore(iglob))
+ yelm(ia) = dble(ystore(iglob))
+ zelm(ia) = dble(zstore(iglob))
- enddo
+ enddo
! iterate to solve the non linear system
do iter_loop = 1,NUM_ITER
@@ -681,35 +693,35 @@
- datan(1.006760466d0*dcos(theta_source(isource))/dmax1(TINYVAL,dsin(theta_source(isource))))
if(phi_source(isource)>PI) phi_source(isource)=phi_source(isource)-TWO_PI
- write(IMAIN,*)
- write(IMAIN,*) 'original (requested) position of the source:'
- write(IMAIN,*)
- write(IMAIN,*) ' latitude: ',lat(isource)
- write(IMAIN,*) ' longitude: ',long(isource)
- write(IMAIN,*) ' depth: ',depth(isource),' km'
- write(IMAIN,*)
+ write(IMAIN,*)
+ write(IMAIN,*) 'original (requested) position of the source:'
+ write(IMAIN,*)
+ write(IMAIN,*) ' latitude: ',lat(isource)
+ write(IMAIN,*) ' longitude: ',long(isource)
+ write(IMAIN,*) ' depth: ',depth(isource),' km'
+ write(IMAIN,*)
- ! compute real position of the source
- write(IMAIN,*) 'position of the source that will be used:'
- write(IMAIN,*)
- write(IMAIN,*) ' latitude: ',(PI/2.0d0-colat_source)*180.0d0/PI
- write(IMAIN,*) ' longitude: ',phi_source(isource)*180.0d0/PI
- write(IMAIN,*) ' depth: ',(r0-r_found_source)*R_EARTH/1000.0d0,' km'
- write(IMAIN,*)
+ ! compute real position of the source
+ write(IMAIN,*) 'position of the source that will be used:'
+ write(IMAIN,*)
+ write(IMAIN,*) ' latitude: ',(PI_OVER_TWO-colat_source)*RADIANS_TO_DEGREES
+ write(IMAIN,*) ' longitude: ',phi_source(isource)*180.0d0/PI
+ write(IMAIN,*) ' depth: ',(r0-r_found_source)*R_EARTH/1000.0d0,' km'
+ write(IMAIN,*)
- ! display error in location estimate
- write(IMAIN,*) 'error in location of the source: ',sngl(final_distance_source(isource)),' km'
+ ! display error in location estimate
+ write(IMAIN,*) 'error in location of the source: ',sngl(final_distance_source(isource)),' km'
- ! add warning if estimate is poor
- ! (usually means source outside the mesh given by the user)
- if(final_distance_source(isource) > 50.d0) then
- write(IMAIN,*)
- write(IMAIN,*) '*****************************************************'
- write(IMAIN,*) '*****************************************************'
- write(IMAIN,*) '***** WARNING: source location estimate is poor *****'
- write(IMAIN,*) '*****************************************************'
- write(IMAIN,*) '*****************************************************'
- endif
+ ! add warning if estimate is poor
+ ! (usually means source outside the mesh given by the user)
+ if(final_distance_source(isource) > 50.d0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '***** WARNING: source location estimate is poor *****'
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '*****************************************************'
+ endif
! print source time function and spectrum
if(PRINT_SOURCE_TIME_FUNCTION) then
@@ -796,18 +808,18 @@
endif !PRINT_SOURCE_TIME_FUNCTION
- enddo ! end of loop on all the sources within current source subset
+ enddo ! end of loop on all the sources within current source subset
- endif ! end of section executed by main process only
+ endif ! end of section executed by main process only
-! deallocate arrays specific to each subset
- deallocate(final_distance_source_subset)
- deallocate(ispec_selected_source_subset)
- deallocate(ispec_selected_source_all)
- deallocate(xi_source_all,eta_source_all,gamma_source_all,final_distance_source_all)
- deallocate(x_found_source_all,y_found_source_all,z_found_source_all)
- deallocate(xi_source_subset,eta_source_subset,gamma_source_subset)
- deallocate(x_found_source,y_found_source,z_found_source)
+ ! deallocate arrays specific to each subset
+ deallocate(final_distance_source_subset)
+ deallocate(ispec_selected_source_subset)
+ deallocate(ispec_selected_source_all)
+ deallocate(xi_source_all,eta_source_all,gamma_source_all,final_distance_source_all)
+ deallocate(x_found_source_all,y_found_source_all,z_found_source_all)
+ deallocate(xi_source_subset,eta_source_subset,gamma_source_subset)
+ deallocate(x_found_source,y_found_source,z_found_source)
enddo ! end of loop over all source subsets
@@ -848,7 +860,6 @@
!-------------------------------------------------------------------------------------------------
!
-
subroutine calc_mask_source(mask_source,ispec,NSPEC,typical_size, &
x_target_source,y_target_source,z_target_source, &
ibool,xstore,ystore,zstore,NGLOB)
@@ -918,12 +929,148 @@
character(len=150) :: LOCAL_PATH
! local parameters
+ integer :: ier
character(len=150) :: prname
! stores into file
call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
- open(unit=27,file=trim(prname)//'mask_source.bin',status='unknown',form='unformatted',action='write')
+ open(unit=27,file=trim(prname)//'mask_source.bin', &
+ status='unknown',form='unformatted',action='write',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening mask_source.bin file')
write(27) mask_source
close(27)
end subroutine save_mask_source
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine print_stf(NSOURCES,isource,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ tshift_cmt,hdur,min_tshift_cmt_original,NSTEP,DT)
+
+! prints source time function
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSOURCES,isource
+
+ double precision,dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision,dimension(NSOURCES) :: tshift_cmt,hdur
+
+ double precision :: min_tshift_cmt_original
+ integer :: NSTEP
+ double precision :: DT
+
+
+ ! local parameters
+ integer :: it,iom,ier
+ double precision :: scalar_moment
+ double precision :: t0, hdur_gaussian(NSOURCES)
+ double precision :: t_cmt_used(NSOURCES)
+ double precision time_source,om
+ double precision :: f0
+
+ double precision, external :: comp_source_time_function,comp_source_spectrum
+ double precision, external :: comp_source_time_function_rickr
+
+ character(len=150) :: OUTPUT_FILES
+ character(len=150) :: plot_file
+
+ ! number of points to plot the source time function and spectrum
+ integer, parameter :: NSAMP_PLOT_SOURCE = 1000
+
+ ! user output
+ write(IMAIN,*)
+ write(IMAIN,*) 'printing the source-time function'
+
+ ! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ ! print the source-time function
+ if(NSOURCES == 1) then
+ plot_file = '/plot_source_time_function.txt'
+ else
+ if(isource < 10) then
+ write(plot_file,"('/plot_source_time_function',i1,'.txt')") isource
+ else if(isource < 100) then
+ write(plot_file,"('/plot_source_time_function',i2,'.txt')") isource
+ else
+ write(plot_file,"('/plot_source_time_function',i3,'.txt')") isource
+ endif
+ endif
+
+ ! output file
+ open(unit=27,file=trim(OUTPUT_FILES)//plot_file, &
+ status='unknown',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(0,'error opening plot_source_time_function file')
+
+ scalar_moment = Mxx(isource)**2 + Myy(isource)**2 + Mzz(isource)**2 &
+ + Mxy(isource)**2 + Mxz(isource)**2 + Myz(isource)**2
+ scalar_moment = dsqrt(scalar_moment/2.0d0)
+
+ ! define t0 as the earliest start time
+ ! note: this calculation here is only used for outputting the plot_source_time_function file
+ ! (see setup_sources_receivers.f90)
+ t0 = - 1.5d0*minval( tshift_cmt(:) - hdur(:) )
+ if( USE_FORCE_POINT_SOURCE ) t0 = - 1.2d0 * minval(tshift_cmt(:) - 1.0d0/hdur(:))
+
+ t_cmt_used(:) = tshift_cmt(:)
+ if( USER_T0 > 0.d0 ) then
+ if( t0 <= USER_T0 + min_tshift_cmt_original ) then
+ t_cmt_used(:) = tshift_cmt(:) + min_tshift_cmt_original
+ t0 = USER_T0
+ endif
+ endif
+ ! convert the half duration for triangle STF to the one for gaussian STF
+ ! note: this calculation here is only used for outputting the plot_source_time_function file
+ ! (see setup_sources_receivers.f90)
+ hdur_gaussian(:) = hdur(:)/SOURCE_DECAY_MIMIC_TRIANGLE
+
+ ! writes out source time function to file
+ do it=1,NSTEP
+ time_source = dble(it-1)*DT-t0-t_cmt_used(isource)
+ if( USE_FORCE_POINT_SOURCE ) then
+ ! Ricker source time function
+ f0 = hdur(isource)
+ write(27,*) sngl(dble(it-1)*DT-t0), &
+ sngl(FACTOR_FORCE_SOURCE*comp_source_time_function_rickr(time_source,f0))
+ else
+ ! Gaussian source time function
+ write(27,*) sngl(dble(it-1)*DT-t0), &
+ sngl(scalar_moment*comp_source_time_function(time_source,hdur_gaussian(isource)))
+ endif
+ enddo
+ close(27)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'printing the source spectrum'
+
+ ! print the spectrum of the derivative of the source from 0 to 1/8 Hz
+ if(NSOURCES == 1) then
+ plot_file = '/plot_source_spectrum.txt'
+ else
+ if(isource < 10) then
+ write(plot_file,"('/plot_source_spectrum',i1,'.txt')") isource
+ else if(isource < 100) then
+ write(plot_file,"('/plot_source_spectrum',i2,'.txt')") isource
+ else
+ write(plot_file,"('/plot_source_spectrum',i3,'.txt')") isource
+ endif
+ endif
+
+ open(unit=27,file=trim(OUTPUT_FILES)//plot_file, &
+ status='unknown',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(0,'error opening plot_source_spectrum file')
+
+ do iom=1,NSAMP_PLOT_SOURCE
+ om=TWO_PI*(1.0d0/8.0d0)*(iom-1)/dble(NSAMP_PLOT_SOURCE-1)
+ write(27,*) sngl(om/TWO_PI), &
+ sngl(scalar_moment*om*comp_source_spectrum(om,hdur(isource)))
+ enddo
+ close(27)
+
+ end subroutine print_stf
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/noise_tomography.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/noise_tomography.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/noise_tomography.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -83,6 +83,7 @@
include 'mpif.h'
include "precision.h"
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
! input parameters
@@ -106,9 +107,9 @@
real(kind=CUSTOM_REAL) :: normal_x_noise_out,normal_y_noise_out,normal_z_noise_out,mask_noise_out
character(len=150) :: filename
real(kind=CUSTOM_REAL), dimension(nmovie_points) :: &
- store_val_x,store_val_y,store_val_z, store_val_ux,store_val_uy,store_val_uz
+ val_x,val_y,val_z,val_ux,val_uy,val_uz
real(kind=CUSTOM_REAL), dimension(nmovie_points,0:NPROCTOT_VAL-1) :: &
- store_val_x_all,store_val_y_all,store_val_z_all, store_val_ux_all,store_val_uy_all,store_val_uz_all
+ val_x_all,val_y_all,val_z_all,val_ux_all,val_uy_all,val_uz_all
! read master receiver ID -- the ID in DATA/STATIONS
@@ -176,24 +177,24 @@
do i = 1,NGLLX,NIT
ipoin = ipoin + 1
iglob = ibool_crust_mantle(i,j,k,ispec)
- store_val_x(ipoin) = xstore_crust_mantle(iglob)
- store_val_y(ipoin) = ystore_crust_mantle(iglob)
- store_val_z(ipoin) = zstore_crust_mantle(iglob)
- store_val_ux(ipoin) = mask_noise(ipoin)
- store_val_uy(ipoin) = mask_noise(ipoin)
- store_val_uz(ipoin) = mask_noise(ipoin)
+ val_x(ipoin) = xstore_crust_mantle(iglob)
+ val_y(ipoin) = ystore_crust_mantle(iglob)
+ val_z(ipoin) = zstore_crust_mantle(iglob)
+ val_ux(ipoin) = mask_noise(ipoin)
+ val_uy(ipoin) = mask_noise(ipoin)
+ val_uz(ipoin) = mask_noise(ipoin)
enddo
enddo
enddo
! gather info on master proc
ispec = nmovie_points
- call MPI_GATHER(store_val_x,ispec,CUSTOM_MPI_TYPE,store_val_x_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_y,ispec,CUSTOM_MPI_TYPE,store_val_y_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_z,ispec,CUSTOM_MPI_TYPE,store_val_z_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_ux,ispec,CUSTOM_MPI_TYPE,store_val_ux_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_uy,ispec,CUSTOM_MPI_TYPE,store_val_uy_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(store_val_uz,ispec,CUSTOM_MPI_TYPE,store_val_uz_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(val_x,ispec,CUSTOM_MPI_TYPE,val_x_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(val_y,ispec,CUSTOM_MPI_TYPE,val_y_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(val_z,ispec,CUSTOM_MPI_TYPE,val_z_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(val_ux,ispec,CUSTOM_MPI_TYPE,val_ux_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(val_uy,ispec,CUSTOM_MPI_TYPE,val_uy_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(val_uz,ispec,CUSTOM_MPI_TYPE,val_uz_all,ispec,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
! save maks_noise data to disk in home directory
! this file can be viewed the same way as surface movie data (xcreate_movie_AVS_DX)
@@ -204,12 +205,12 @@
status='unknown',form='unformatted',action='write',iostat=ios)
if( ios /= 0 ) call exit_MPI(myrank,'error opening output file mask_noise')
- write(IOUT_NOISE) store_val_x_all
- write(IOUT_NOISE) store_val_y_all
- write(IOUT_NOISE) store_val_z_all
- write(IOUT_NOISE) store_val_ux_all
- write(IOUT_NOISE) store_val_uy_all
- write(IOUT_NOISE) store_val_uz_all
+ write(IOUT_NOISE) val_x_all
+ write(IOUT_NOISE) val_y_all
+ write(IOUT_NOISE) val_z_all
+ write(IOUT_NOISE) val_ux_all
+ write(IOUT_NOISE) val_uy_all
+ write(IOUT_NOISE) val_uz_all
close(IOUT_NOISE)
endif
@@ -223,11 +224,14 @@
! subroutine for NOISE TOMOGRAPHY
! check for consistency of the parameters
+
subroutine check_parameters_noise(myrank,NOISE_TOMOGRAPHY,SIMULATION_TYPE,SAVE_FORWARD, &
NUMBER_OF_RUNS, NUMBER_OF_THIS_RUN,ROTATE_SEISMOGRAMS_RT, &
SAVE_ALL_SEISMOS_IN_ONE_FILE, USE_BINARY_FOR_LARGE_FILE, &
MOVIE_COARSE,LOCAL_PATH,NSPEC_TOP,NSTEP)
+
implicit none
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
! input parameters
@@ -432,17 +436,17 @@
! adds noise source (only if this proc carries the noise)
- if(myrank == islice_selected_rec(irec_master_noise)) then
- ! adds noise source contributions
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec_master_noise))
- accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
- + noise_sourcearray(:,i,j,k,it)
+ if(myrank == islice_selected_rec(irec_master_noise)) then
+ ! adds noise source contributions
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec_master_noise))
+ accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
+ + noise_sourcearray(:,i,j,k,it)
+ enddo
enddo
enddo
- enddo
endif
end subroutine add_source_master_rec_noise
@@ -483,90 +487,26 @@
real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,nspec_top) :: noise_surface_movie
! get coordinates of surface mesh and surface displacement
- do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
- ispec = ibelm_top_crust_mantle(ispec2D)
- k = NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool_crust_mantle(i,j,k,ispec)
- noise_surface_movie(:,i,j,ispec2D) = displ_crust_mantle(:,iglob)
+ do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ ispec = ibelm_top_crust_mantle(ispec2D)
+ k = NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+ noise_surface_movie(:,i,j,ispec2D) = displ_crust_mantle(:,iglob)
+ enddo
enddo
enddo
- enddo
! save surface motion to disk
call write_abs(9,noise_surface_movie,CUSTOM_REAL*NDIM*NGLLX*NGLLY*nspec_top,it)
end subroutine noise_save_surface_movie
-!!!!! original implementation, not used anymore (but kept here for references) !!!!!
-! subroutine noise_save_surface_movie_original(myrank,nmovie_points,displ_crust_mantle, &
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
-! store_val_x,store_val_y,store_val_z, &
-! store_val_ux,store_val_uy,store_val_uz, &
-! ibelm_top_crust_mantle,ibool_crust_mantle,nspec_top, &
-! NIT,it,LOCAL_PATH)
-! implicit none
-! include 'mpif.h'
-! include "precision.h"
-! include "constants.h"
-! include "OUTPUT_FILES/values_from_mesher.h"
-! ! input parameters
-! integer :: myrank,nmovie_points,nspec_top,NIT,it
-! integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
-! integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle
-! real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
-! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
-! character(len=150) :: LOCAL_PATH
-! ! output parameters
-! ! local parameters
-! integer :: ipoin,ispec2D,ispec,i,j,k,iglob
-! real(kind=CUSTOM_REAL), dimension(nmovie_points) :: &
-! store_val_x,store_val_y,store_val_z, &
-! store_val_ux,store_val_uy,store_val_uz
-! character(len=150) :: outputname
!
+!-------------------------------------------------------------------------------------------------
!
-! ! get coordinates of surface mesh and surface displacement
-! ipoin = 0
-! do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
-! ispec = ibelm_top_crust_mantle(ispec2D)
-!
-! k = NGLLZ
-!
-! ! loop on all the points inside the element
-! do j = 1,NGLLY,NIT
-! do i = 1,NGLLX,NIT
-! ipoin = ipoin + 1
-! iglob = ibool_crust_mantle(i,j,k,ispec)
-! store_val_x(ipoin) = xstore_crust_mantle(iglob)
-! store_val_y(ipoin) = ystore_crust_mantle(iglob)
-! store_val_z(ipoin) = zstore_crust_mantle(iglob)
-! store_val_ux(ipoin) = displ_crust_mantle(1,iglob)
-! store_val_uy(ipoin) = displ_crust_mantle(2,iglob)
-! store_val_uz(ipoin) = displ_crust_mantle(3,iglob)
-! enddo
-! enddo
-!
-! enddo
-!
-! ! save surface motion to disk
-! ! LOCAL storage is better than GLOBAL, because we have to save the 'movie' at every time step
-! ! also note that the surface movie does NOT have to be shared with other nodes/CPUs
-! ! change LOCAL_PATH specified in "DATA/Par_file"
-! write(outputname,"('/proc',i6.6,'_surface_movie',i6.6)") myrank, it
-! open(unit=IOUT_NOISE,file=trim(LOCAL_PATH)//outputname,status='unknown',form='unformatted',action='write')
-! write(IOUT_NOISE) store_val_ux
-! write(IOUT_NOISE) store_val_uy
-! write(IOUT_NOISE) store_val_uz
-! close(IOUT_NOISE)
-! end subroutine noise_save_surface_movie_original
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
! subroutine for NOISE TOMOGRAPHY
! step 2/3: calculate/reconstructe the "ensemble forward wavefield"
! read surface movie (displacement) at every time steps, injected as the source of "ensemble forward wavefield"
@@ -587,7 +527,9 @@
ibelm_top_crust_mantle,ibool_crust_mantle, &
nspec_top,noise_surface_movie, &
it,jacobian2D_top_crust_mantle,wgllwgll_xy)
+
implicit none
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
! input parameters
@@ -608,9 +550,9 @@
call read_abs(9,noise_surface_movie,CUSTOM_REAL*NDIM*NGLLX*NGLLY*nspec_top,it)
! get coordinates of surface mesh and surface displacement
- ipoin = 0
- do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
- ispec = ibelm_top_crust_mantle(ispec2D)
+ ipoin = 0
+ do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ ispec = ibelm_top_crust_mantle(ispec2D)
k = NGLLZ
@@ -625,90 +567,26 @@
noise_surface_movie(3,i,j,ispec2D) * normal_z_noise(ipoin)
- accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + eta * mask_noise(ipoin) * normal_x_noise(ipoin) &
- * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
- accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + eta * mask_noise(ipoin) * normal_y_noise(ipoin) &
- * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
- accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + eta * mask_noise(ipoin) * normal_z_noise(ipoin) &
- * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
+ accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) &
+ + eta * mask_noise(ipoin) * normal_x_noise(ipoin) &
+ * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
+ accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) &
+ + eta * mask_noise(ipoin) * normal_y_noise(ipoin) &
+ * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
+ accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) &
+ + eta * mask_noise(ipoin) * normal_z_noise(ipoin) &
+ * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
+ enddo
enddo
+
enddo
- enddo
-
end subroutine noise_read_add_surface_movie
-!!!!! original implementation, not used anymore (but kept here for references) !!!!!
-! subroutine noise_read_add_surface_movie_original(myrank,nmovie_points,accel_crust_mantle, &
-! normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
-! store_val_ux,store_val_uy,store_val_uz, &
-! ibelm_top_crust_mantle,ibool_crust_mantle,nspec_top, &
-! NIT,it,LOCAL_PATH,jacobian2D_top_crust_mantle,wgllwgll_xy)
-! implicit none
-! include 'mpif.h'
-! include "precision.h"
-! include "constants.h"
-! include "OUTPUT_FILES/values_from_mesher.h"
-! ! input parameters
-! integer :: myrank,nmovie_points,nspec_top,NIT,it
-! integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
-! integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: jacobian2D_top_crust_mantle
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle ! both input and output
-! real(kind=CUSTOM_REAL), dimension(nmovie_points) :: normal_x_noise,normal_y_noise,normal_z_noise, mask_noise
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
-! character(len=150) :: LOCAL_PATH
-! ! output parameters
-! ! local parameters
-! integer :: ipoin,ispec2D,ispec,i,j,k,iglob,ios
-! real(kind=CUSTOM_REAL), dimension(nmovie_points) :: store_val_ux,store_val_uy,store_val_uz
-! real(kind=CUSTOM_REAL) :: eta
-! character(len=150) :: outputname
!
+!-------------------------------------------------------------------------------------------------
!
-! ! read surface movie
-! write(outputname,"('/proc',i6.6,'_surface_movie',i6.6)") myrank, it
-! open(unit=IIN_NOISE,file=trim(LOCAL_PATH)//outputname,status='old',form='unformatted',action='read',iostat=ios)
-! if( ios /= 0) call exit_MPI(myrank,'file '//trim(outputname)//' does NOT exist!')
-! read(IIN_NOISE) store_val_ux
-! read(IIN_NOISE) store_val_uy
-! read(IIN_NOISE) store_val_uz
-! close(IIN_NOISE)
-!
-! ! get coordinates of surface mesh and surface displacement
-! ipoin = 0
-! do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
-! ispec = ibelm_top_crust_mantle(ispec2D)
-!
-! k = NGLLZ
-!
-! ! loop on all the points inside the element
-! do j = 1,NGLLY,NIT
-! do i = 1,NGLLX,NIT
-! ipoin = ipoin + 1
-! iglob = ibool_crust_mantle(i,j,k,ispec)
-!
-! eta = store_val_ux(ipoin) * normal_x_noise(ipoin) + &
-! store_val_uy(ipoin) * normal_y_noise(ipoin) + &
-! store_val_uz(ipoin) * normal_z_noise(ipoin)
-!
-! accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + eta * mask_noise(ipoin) * normal_x_noise(ipoin) &
-! * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
-! accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + eta * mask_noise(ipoin) * normal_y_noise(ipoin) &
-! * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
-! accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + eta * mask_noise(ipoin) * normal_z_noise(ipoin) &
-! * wgllwgll_xy(i,j) * jacobian2D_top_crust_mantle(i,j,ispec2D)
-! enddo
-! enddo
-!
-! enddo
-!
-! end subroutine noise_read_add_surface_movie_original
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
! subroutine for NOISE TOMOGRAPHY
! step 3: constructing noise source strength kernel
!
@@ -726,7 +604,9 @@
normal_x_noise,normal_y_noise,normal_z_noise, &
nspec_top,noise_surface_movie, &
ibelm_top_crust_mantle)
+
implicit none
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
! input parameters
@@ -750,107 +630,42 @@
! noise source strength kernel
! to keep similar structure to other kernels, the source strength kernel is saved as a volumetric kernel
! but only updated at the surface, because the noise is generated there
- ipoin = 0
- do ispec2D = 1, nspec_top
- ispec = ibelm_top_crust_mantle(ispec2D)
+ ipoin = 0
+ do ispec2D = 1, NSPEC_TOP
+ ispec = ibelm_top_crust_mantle(ispec2D)
- k = NGLLZ
+ k = NGLLZ
- ! loop on all the points inside the element
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool_crust_mantle(i,j,k,ispec)
+ ! loop on all the points inside the element
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ iglob = ibool_crust_mantle(i,j,k,ispec)
- eta = noise_surface_movie(1,i,j,ispec2D) * normal_x_noise(ipoin) + &
- noise_surface_movie(2,i,j,ispec2D) * normal_y_noise(ipoin) + &
- noise_surface_movie(3,i,j,ispec2D) * normal_z_noise(ipoin)
+ eta = noise_surface_movie(1,i,j,ispec2D) * normal_x_noise(ipoin) + &
+ noise_surface_movie(2,i,j,ispec2D) * normal_y_noise(ipoin) + &
+ noise_surface_movie(3,i,j,ispec2D) * normal_z_noise(ipoin)
- Sigma_kl_crust_mantle(i,j,k,ispec) = Sigma_kl_crust_mantle(i,j,k,ispec) &
- + deltat * eta * ( normal_x_noise(ipoin) * displ_crust_mantle(1,iglob) &
- + normal_y_noise(ipoin) * displ_crust_mantle(2,iglob) &
- + normal_z_noise(ipoin) * displ_crust_mantle(3,iglob) )
+ Sigma_kl_crust_mantle(i,j,k,ispec) = Sigma_kl_crust_mantle(i,j,k,ispec) &
+ + deltat * eta * ( normal_x_noise(ipoin) * displ_crust_mantle(1,iglob) &
+ + normal_y_noise(ipoin) * displ_crust_mantle(2,iglob) &
+ + normal_z_noise(ipoin) * displ_crust_mantle(3,iglob) )
+ enddo
enddo
enddo
- enddo
-
end subroutine compute_kernels_strength_noise
-!!!!! original implementation, not used anymore (but kept here for references) !!!!!
-! subroutine compute_kernels_strength_noise_original(myrank,ibool_crust_mantle, &
-! Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
-! nmovie_points,normal_x_noise,normal_y_noise,normal_z_noise, &
-! nspec_top,ibelm_top_crust_mantle,LOCAL_PATH)
-! implicit none
-! include "constants.h"
-! include "OUTPUT_FILES/values_from_mesher.h"
-! ! input parameters
-! integer :: myrank,nmovie_points,it,nspec_top
-! integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
-! integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-! real(kind=CUSTOM_REAL) :: deltat
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: displ_crust_mantle
-! real(kind=CUSTOM_REAL), dimension(nmovie_points) :: normal_x_noise,normal_y_noise,normal_z_noise
-! character(len=150) :: LOCAL_PATH
-! ! output parameters
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
-! Sigma_kl_crust_mantle
-! ! local parameters
-! integer :: i,j,k,ispec,iglob,ipoin,ispec2D,ios
-! real(kind=CUSTOM_REAL) :: eta
-! real(kind=CUSTOM_REAL), dimension(nmovie_points) :: store_val_ux,store_val_uy,store_val_uz
-! character(len=150) :: outputname
!
+!-------------------------------------------------------------------------------------------------
!
-! ! read surface movie, needed for Sigma_kl_crust_mantle
-! write(outputname,"('/proc',i6.6,'_surface_movie',i6.6)") myrank, it
-! open(unit=IIN_NOISE,file=trim(LOCAL_PATH)//outputname,status='old',form='unformatted',action='read',iostat=ios)
-! if( ios /= 0) call exit_MPI(myrank,'file '//trim(outputname)//' does NOT exist!')
-!
-! read(IIN_NOISE) store_val_ux
-! read(IIN_NOISE) store_val_uy
-! read(IIN_NOISE) store_val_uz
-! close(IIN_NOISE)
-!
-! ! noise source strength kernel
-! ! to keep similar structure to other kernels, the source strength kernel is saved as a volumetric kernel
-! ! but only updated at the surface, because the noise is generated there
-! ipoin = 0
-! do ispec2D = 1, nspec_top
-! ispec = ibelm_top_crust_mantle(ispec2D)
-!
-! k = NGLLZ
-!
-! ! loop on all the points inside the element
-! do j = 1,NGLLY
-! do i = 1,NGLLX
-! ipoin = ipoin + 1
-! iglob = ibool_crust_mantle(i,j,k,ispec)
-!
-! eta = store_val_ux(ipoin) * normal_x_noise(ipoin) + &
-! store_val_uy(ipoin) * normal_y_noise(ipoin) + &
-! store_val_uz(ipoin) * normal_z_noise(ipoin)
-!
-! Sigma_kl_crust_mantle(i,j,k,ispec) = Sigma_kl_crust_mantle(i,j,k,ispec) &
-! + deltat * eta * ( normal_x_noise(ipoin) * displ_crust_mantle(1,iglob) &
-! + normal_y_noise(ipoin) * displ_crust_mantle(2,iglob) &
-! + normal_z_noise(ipoin) * displ_crust_mantle(3,iglob) )
-! enddo
-! enddo
-!
-! enddo
-!
-! end subroutine compute_kernels_strength_noise_original
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
-
! subroutine for NOISE TOMOGRAPHY
! step 3: save noise source strength kernel
subroutine save_kernels_strength_noise(myrank,LOCAL_PATH,Sigma_kl_crust_mantle)
+
implicit none
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
! input parameters
@@ -872,7 +687,3 @@
close(IOUT_NOISE)
end subroutine save_kernels_strength_noise
-
-! =============================================================================================================
-! =============================================================================================================
-! =============================================================================================================
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/prepare_timerun.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/prepare_timerun.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/prepare_timerun.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -418,7 +418,6 @@
if (SIMULATION_TYPE == 3) b_two_omega_earth = 0._CUSTOM_REAL
endif
-
end subroutine prepare_timerun_constants
!
@@ -529,7 +528,6 @@
end subroutine prepare_timerun_gravity
-
!
!-------------------------------------------------------------------------------------------------
!
@@ -581,7 +579,6 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
muvstore_inner_core
-
integer SIMULATION_TYPE
logical MOVIE_VOLUME
@@ -641,7 +638,8 @@
scale_factor = factor_scale_crust_mantle(i,j,k,ispec)
if(ANISOTROPIC_3D_MANTLE_VAL) then
- scale_factor_minus_one = scale_factor - 1.
+ scale_factor_minus_one = scale_factor - 1.d0
+
mul = c44store_crust_mantle(i,j,k,ispec)
c11store_crust_mantle(i,j,k,ispec) = c11store_crust_mantle(i,j,k,ispec) &
+ FOUR_THIRDS * scale_factor_minus_one * mul
@@ -666,6 +664,7 @@
! store the original value of \mu to comput \mu*\eps
muvstore_crust_mantle_3dmovie(i,j,k,ispec)=muvstore_crust_mantle(i,j,k,ispec)
endif
+
muvstore_crust_mantle(i,j,k,ispec) = muvstore_crust_mantle(i,j,k,ispec) * scale_factor
! scales transverse isotropic values for mu_h
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_arrays_solver.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_arrays_solver.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -43,66 +43,57 @@
implicit none
include "constants.h"
-
include "OUTPUT_FILES/values_from_mesher.h"
- integer iregion_code,myrank
+ integer :: iregion_code,myrank
+ integer :: nspec,nglob,nglob_xy
+ integer :: nspec_iso,nspec_tiso,nspec_ani
-! flags to know if we should read Vs and anisotropy arrays
- logical READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,OCEANS,ABSORBING_CONDITIONS
+ ! Stacey
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,nspec):: rho_vp,rho_vs
- character(len=150) LOCAL_PATH
-
- integer nspec,nglob,nglob_xy
-
- integer nspec_iso,nspec_tiso,nspec_ani
-
real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-! material properties
- real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec_iso)
- real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec_iso)
- real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec_iso)
+ ! material properties
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,nspec_iso) :: &
+ rhostore,kappavstore,muvstore
-! additional arrays for anisotropy stored only where needed to save memory
- real(kind=CUSTOM_REAL) kappahstore(NGLLX,NGLLY,NGLLZ,nspec_tiso)
- real(kind=CUSTOM_REAL) muhstore(NGLLX,NGLLY,NGLLZ,nspec_tiso)
- real(kind=CUSTOM_REAL) eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec_tiso)
+ ! additional arrays for anisotropy stored only where needed to save memory
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,nspec_tiso) :: &
+ kappahstore,muhstore,eta_anisostore
-! additional arrays for full anisotropy
+ ! additional arrays for full anisotropy
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
c11store,c12store,c13store,c14store,c15store,c16store, &
c22store,c23store,c24store,c25store,c26store,c33store,c34store, &
c35store,c36store,c44store,c45store,c46store,c55store,c56store,c66store
-! Stacey
- real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec)
+ ! global addressing
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: idoubling
+ logical, dimension(nspec) :: ispec_is_tiso
-! mass matrices and additional ocean load mass matrix
- real(kind=CUSTOM_REAL), dimension(nglob) :: rmass_ocean_load
-
+ ! mass matrices and additional ocean load mass matrix
real(kind=CUSTOM_REAL), dimension(nglob_xy) :: rmassx,rmassy
real(kind=CUSTOM_REAL), dimension(nglob) :: rmassz
+ real(kind=CUSTOM_REAL), dimension(nglob) :: rmass_ocean_load
-! global addressing
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ ! flags to know if we should read Vs and anisotropy arrays
+ logical :: READ_KAPPA_MU,READ_TISO,ABSORBING_CONDITIONS,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS
- integer, dimension(nspec) :: idoubling
+ character(len=150) :: LOCAL_PATH
-! this for non blocking MPI
+ ! local parameters
+ ! processor identification
+ character(len=150) :: prname
+
+ ! this for non blocking MPI
logical, dimension(nspec) :: is_on_a_slice_edge
- logical, dimension(nspec) :: ispec_is_tiso
-
-! processor identification
- character(len=150) prname
-
-! create the name for the database of the current slide and region
+ ! create the name for the database of the current slide and region
call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
open(unit=IIN,file=prname(1:len_trim(prname))//'solver_data_1.bin', &
@@ -118,13 +109,13 @@
read(IIN) gammay
read(IIN) gammaz
-! model arrays
+ ! model arrays
read(IIN) rhostore
read(IIN) kappavstore
if(READ_KAPPA_MU) read(IIN) muvstore
-! for anisotropy, gravity and rotation
+ ! for anisotropy, gravity and rotation
if(TRANSVERSE_ISOTROPY .and. READ_TISO) then
read(IIN) kappahstore
@@ -164,7 +155,7 @@
read(IIN) c66store
endif
-! Stacey
+ ! Stacey
if(ABSORBING_CONDITIONS) then
if(iregion_code == IREGION_CRUST_MANTLE) then
@@ -176,14 +167,14 @@
endif
-! mass matrices
-!
-! in the case of stacey boundary conditions, add C*delta/2 contribution to the mass matrix
-! on the Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
-! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
-!
-! if absorbing_conditions are not set or if NCHUNKS=6, only one mass matrix is needed
-! for the sake of performance, only "rmassz" array will be filled and "rmassx" & "rmassy" will be obsolete
+ ! mass matrices
+ !
+ ! in the case of stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
+ ! on the Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
+ ! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
+ !
+ ! if absorbing_conditions are not set or if NCHUNKS=6, only one mass matrix is needed
+ ! for the sake of performance, only "rmassz" array will be filled and "rmassx" & "rmassy" will be obsolete
if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS .and. iregion_code == IREGION_CRUST_MANTLE) then
read(IIN) rmassx
read(IIN) rmassy
@@ -191,10 +182,10 @@
read(IIN) rmassz
-! read additional ocean load mass matrix
+ ! read additional ocean load mass matrix
if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) read(IIN) rmass_ocean_load
- close(IIN)
+ close(IIN) ! solver_data.bin
! read coordinates of the mesh
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_arrays_solver_adios.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_arrays_solver_adios.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_arrays_solver_adios.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,455 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!===============================================================================
-!> \brief Read adios arrays created by the mesher (file: regX_solver_data.bp)
-subroutine read_arrays_solver_adios(iregion_code,myrank, &
- nspec,nglob,nglob_xy, &
- nspec_iso,nspec_tiso,nspec_ani, &
- rho_vp,rho_vs,xstore,ystore,zstore, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- rhostore, kappavstore,muvstore,kappahstore,muhstore,eta_anisostore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ibool,idoubling,ispec_is_tiso, &
- rmassx,rmassy,rmassz,rmass_ocean_load, &
- READ_KAPPA_MU,READ_TISO, &
- ABSORBING_CONDITIONS,LOCAL_PATH)
-
- use mpi
- use adios_read_mod
- implicit none
-
- include "constants.h"
- include "OUTPUT_FILES/values_from_mesher.h"
-
- integer :: iregion_code,myrank
- integer :: nspec,nglob,nglob_xy
- integer :: nspec_iso,nspec_tiso,nspec_ani
-
- ! Stacey
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,nspec):: rho_vp,rho_vs
-
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-
- ! material properties
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,nspec_iso) :: &
- rhostore,kappavstore,muvstore
-
- ! additional arrays for anisotropy stored only where needed to save memory
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,nspec_tiso) :: &
- kappahstore,muhstore,eta_anisostore
-
- ! additional arrays for full anisotropy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store,c34store, &
- c35store,c36store,c44store,c45store,c46store,c55store,c56store,c66store
-
- ! global addressing
- integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: idoubling
- logical, dimension(nspec) :: ispec_is_tiso
-
- ! mass matrices and additional ocean load mass matrix
- real(kind=CUSTOM_REAL), dimension(nglob_xy) :: rmassx,rmassy
- real(kind=CUSTOM_REAL), dimension(nglob) :: rmassz
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
-
- ! flags to know if we should read Vs and anisotropy arrays
- logical :: READ_KAPPA_MU,READ_TISO,ABSORBING_CONDITIONS
-
- character(len=150) :: LOCAL_PATH, file_name
-
- ! local parameters
- integer :: ierr, comm, lnspec, lnglob, local_dim
- ! processor identification
- character(len=150) :: prname
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid
- integer(kind=8) :: adios_groupsize, adios_totalsize
- integer :: vars_count, attrs_count, current_step, last_step, vsteps
- character(len=128), dimension(:), allocatable :: adios_names
- integer(kind=8), dimension(1) :: start, count
-
- integer(kind=8), dimension(256),target :: selections
- integer :: sel_num, i
- integer(kind=8), pointer :: sel => null()
-
- sel_num = 0
-
- ! create a prefix for the file name such as LOCAL_PATH/regX_
- call create_name_database_adios(prname, iregion_code, LOCAL_PATH)
-
- ! Postpend the actual file name.
- file_name= trim(prname) // "solver_data.bp"
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- ! Setup the ADIOS library to read the file
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
- ! read coordinates of the mesh
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "nspec", 0, 1, &
- lnspec, adios_err)
- call adios_schedule_read(adios_handle, sel, "nglob", 0, 1, &
- lnglob, adios_err)
- !call adios_get_scalar(adios_handle, "nspec", lnspec, adios_err)
- !call adios_get_scalar(adios_handle, "nglob", lnglob, adios_err)
- !call adios_perform_reads(adios_handle, adios_err)
- !call check_adios_err(myrank,adios_err)
-
-
- ! mesh coordinates
- local_dim = nglob
- start(1) = local_dim*myrank; count(1) = local_dim
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "xstore/array", 0, 1, &
- xstore, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ystore/array", 0, 1, &
- ystore, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "zstore/array", 0, 1, &
- zstore, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "rmassz/array", 0, 1, &
- rmassz, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !call adios_perform_reads(adios_handle, adios_err)
- !call check_adios_err(myrank,adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * nspec_iso
- start(1) = local_dim*myrank; count(1) = local_dim
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "rhostore/array", 0, 1, &
- rhostore, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "kappavstore/array", 0, 1, &
- kappavstore, adios_err)
- call check_adios_err(myrank,adios_err)
- if(READ_KAPPA_MU) then
- call adios_schedule_read(adios_handle, sel, "muvstore/array", 0, 1, &
- muvstore, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- !call adios_perform_reads(adios_handle, adios_err)
- !call check_adios_err(myrank,adios_err)
-
- if(TRANSVERSE_ISOTROPY_VAL .and. READ_TISO) then
- local_dim = NGLLX * NGLLY * NGLLZ * nspec_tiso
- start(1) = local_dim*myrank; count(1) = local_dim
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "kappahstore/array", 0, 1, &
- kappahstore, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "muhstore/array", 0, 1, &
- muhstore, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "eta_anisostore/array", 0, 1, &
- eta_anisostore, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- !call adios_perform_reads(adios_handle, adios_err)
- !call check_adios_err(myrank,adios_err)
-
- local_dim = nspec
- start(1) = local_dim*myrank; count(1) = local_dim
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "idoubling/array", 0, 1, &
- idoubling, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ispec_is_tiso/array", 0, 1, &
- ispec_is_tiso, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !call adios_perform_reads(adios_handle, adios_err)
- !call check_adios_err(myrank,adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * nspec
- start(1) = local_dim*myrank; count(1) = local_dim
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibool/array", 0, 1, &
- ibool, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "xixstore/array", 0, 1, &
- xix, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "xiystore/array", 0, 1, &
- xiy, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "xizstore/array", 0, 1, &
- xiz, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "etaxstore/array", 0, 1, &
- etax, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "etaystore/array", 0, 1, &
- etay, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "etazstore/array", 0, 1, &
- etaz, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "gammaxstore/array", 0, 1, &
- gammax, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "gammaystore/array", 0, 1, &
- gammay, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "gammazstore/array", 0, 1, &
- gammaz, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !call adios_perform_reads(adios_handle, adios_err)
- !call check_adios_err(myrank,adios_err)
-
-
- if(ANISOTROPIC_INNER_CORE_VAL .and. iregion_code == IREGION_INNER_CORE) then
- local_dim = NGLLX * NGLLY * NGLLZ * nspec_ani
- start(1) = local_dim*myrank; count(1) = local_dim
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_boundingbox (sel , 1, start, count)
-
- call adios_schedule_read(adios_handle, sel, "c11store/array", 0, 1, &
- c11store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c12store/array", 0, 1, &
- c12store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c13store/array", 0, 1, &
- c13store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c33store/array", 0, 1, &
- c33store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c44store/array", 0, 1, &
- c44store, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- if(ANISOTROPIC_3D_MANTLE_VAL .and. iregion_code == IREGION_CRUST_MANTLE) then
- local_dim = NGLLX * NGLLY * NGLLZ * nspec_ani
- start(1) = local_dim*myrank; count(1) = local_dim
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_boundingbox (sel , 1, start, count)
-
- call adios_schedule_read(adios_handle, sel, "c11store/array", 0, 1, &
- c11store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c12store/array", 0, 1, &
- c12store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c13store/array", 0, 1, &
- c13store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c14store/array", 0, 1, &
- c14store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c15store/array", 0, 1, &
- c15store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c16store/array", 0, 1, &
- c16store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c22store/array", 0, 1, &
- c22store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c23store/array", 0, 1, &
- c23store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c24store/array", 0, 1, &
- c24store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c25store/array", 0, 1, &
- c25store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c26store/array", 0, 1, &
- c26store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c33store/array", 0, 1, &
- c33store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c34store/array", 0, 1, &
- c34store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c35store/array", 0, 1, &
- c35store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c36store/array", 0, 1, &
- c36store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c44store/array", 0, 1, &
- c44store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c45store/array", 0, 1, &
- c45store, adios_err)
- call adios_schedule_read(adios_handle, sel, "c46store/array", 0, 1, &
- c46store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c55store/array", 0, 1, &
- c55store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c56store/array", 0, 1, &
- c56store, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "c66store/array", 0, 1, &
- c66store, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- !call adios_perform_reads(adios_handle, adios_err)
- !call check_adios_err(myrank,adios_err)
-
- ! Stacey
- if(ABSORBING_CONDITIONS) then
- local_dim = NGLLX * NGLLY * NGLLZ * nspec ! nspec_stacey in meshfem3D
- start(1) = local_dim*myrank; count(1) = local_dim
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_boundingbox (sel , 1, start, count)
-
- if(iregion_code == IREGION_CRUST_MANTLE) then
- call adios_schedule_read(adios_handle, sel, "rho_vp/array", 0, 1, &
- rho_vp, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "rho_vs/array", 0, 1, &
- rho_vs, adios_err)
- call check_adios_err(myrank,adios_err)
- else if(iregion_code == IREGION_OUTER_CORE) then
- call adios_schedule_read(adios_handle, sel, "rho_vp/array", 0, 1, &
- rho_vp, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- endif
-
- ! mass matrices
- !
- ! in the case of stacey boundary conditions, add C*deltat/2 contribution to
- ! the mass matrix on Stacey edges for the crust_mantle and outer_core regions
- ! but not for the inner_core region thus the mass matrix must be replaced by
- ! three mass matrices including the "C" damping matrix
- !
- ! if absorbing_conditions are not set or if NCHUNKS=6, only one mass matrix
- ! is needed for the sake of performance, only "rmassz" array will be filled
- ! and "rmassx" & "rmassy" will be obsolete
- !call adios_perform_reads(adios_handle, adios_err)
- !call check_adios_err(myrank,adios_err)
-
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS .and. &
- iregion_code == IREGION_CRUST_MANTLE) then
-
- local_dim = nglob_xy
- start(1) = local_dim*myrank; count(1) = local_dim
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_boundingbox (sel , 1, start, count)
-
- call adios_schedule_read(adios_handle, sel, "rmassx/array", 0, 1, &
- rmassx, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "rmassy/array", 0, 1, &
- rmassy, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- !call adios_perform_reads(adios_handle, adios_err)
- !call check_adios_err(myrank,adios_err)
-
- ! read additional ocean load mass matrix
- if(OCEANS_VAL .and. iregion_code == IREGION_CRUST_MANTLE) then
- local_dim = NGLOB_CRUST_MANTLE_OCEANS ! nglob_oceans
- start(1) = local_dim*myrank; count(1) = local_dim
- sel_num = sel_num+1
- sel => selections(sel_num)
- call adios_selection_boundingbox (sel , 1, start, count)
-
- call adios_schedule_read(adios_handle, sel, "rmass_ocean_load/array", &
- 0, 1, rmass_ocean_load, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !call adios_perform_reads(adios_handle, adios_err)
- !call check_adios_err(myrank,adios_err)
- endif
-
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
-
- ! Clean everything and close the ADIOS file
- do i = 1, sel_num
- sel => selections(i)
- call adios_selection_delete(sel)
- enddo
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call MPI_Barrier(comm, ierr)
- ! checks dimensions
- if( lnspec /= nspec ) then
- print*,'error file dimension: nspec in file = ',lnspec, &
- ' but nspec desired:',nspec
- print*,'please check file ', file_name
- call exit_mpi(myrank,'error dimensions in solver_data.bp')
- endif
- if( lnglob /= nglob ) then
- print*,'error file dimension: nglob in file = ',lnglob, &
- ' but nglob desired:',nglob
- print*,'please check file ', file_name
- call exit_mpi(myrank,'error dimensions in solver_data.bp')
- endif
-
-end subroutine read_arrays_solver_adios
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_attenuation_adios.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_attenuation_adios.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_attenuation_adios.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,127 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
-!===============================================================================
-!> \brief Read adios attenuation arrays created by the mesher
-! (regX_attenuation.bp)
-subroutine read_attenuation_adios(myrank, prname, &
- factor_common, scale_factor, tau_s, vx, vy, vz, vnspec, T_c_source)
-
- use adios_read_mod
- use specfem_par,only: ATTENUATION_VAL
-
- implicit none
-
- include 'constants.h'
- include 'mpif.h'
-
- integer :: myrank
-
- integer :: vx,vy,vz,vnspec
- double precision, dimension(vx,vy,vz,vnspec) :: scale_factor
- double precision, dimension(N_SLS,vx,vy,vz,vnspec) :: factor_common
- double precision, dimension(N_SLS) :: tau_s
-
- character(len=150) :: prname
-
- ! local parameters
- integer :: i,j,k,ispec,ier
- double precision, dimension(N_SLS) :: tau_e, fc
- double precision :: omsb, Q_mu, sf, T_c_source, scale_t
- integer :: sizeprocs, comm, ierr
- character(len=150) :: file_name
- integer(kind=8) :: group_size_inc
- integer :: local_dim, global_dim, offset
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid, sel
- integer(kind=8) :: adios_groupsize, adios_totalsize
- integer :: vars_count, attrs_count, current_step, last_step, vsteps
- character(len=128), dimension(:), allocatable :: adios_names
- integer(kind=8), dimension(1) :: start, count
-
- ! checks if attenuation is on and anything to do
- if( .not. ATTENUATION_VAL) return
-
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- ! All of the following reads use the output parameters as their temporary arrays
- ! use the filename to determine the actual contents of the read
- file_name= trim(prname) // "attenuation.bp"
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "T_c_source", 0, 1, &
- T_c_source, adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = size (tau_s)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "tau_s/array", 0, 1, &
- tau_s, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = size (factor_common)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "tau_e_store/array", 0, 1, &
- factor_common, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = size (scale_factor)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "Qmu_store/array", 0, 1, &
- scale_factor, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- ! Close ADIOS handler to the restart file.
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
-end subroutine read_attenuation_adios
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -46,6 +46,9 @@
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
+ ! local parameters
+ character(len=150) outputname
+
integer myrank,NSTEP
integer SIMULATION_TYPE
@@ -85,9 +88,6 @@
character(len=150) LOCAL_PATH
- !local parameters
- character(len=150) outputname
-
! define correct time steps if restart files
if(NUMBER_OF_RUNS < 1 .or. NUMBER_OF_RUNS > NSTEP) &
stop 'number of restart runs can not be less than 1 or greater than NSTEP'
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays_adios.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays_adios.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays_adios.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,442 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!-------------------------------------------------------------------------------
-!> \file read_forward_arrays_adios.F90
-!! \brief Read saved forward arrays with the help of the ADIOS library.
-!-------------------------------------------------------------------------------
-
-!-------------------------------------------------------------------------------
-!> \brief Read forward arrays from an ADIOS file.
-!> \note read_intermediate_forward_arrays_adios()
-!! and read_forward_arrays_adios() are not factorized, because
-!> the latest read the bp file in "b_" prefixed arrays
-subroutine read_intermediate_forward_arrays_adios()
- ! External imports
- use mpi
- use adios_read_mod
- ! Internal imports
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
- ! Local parameters
- integer :: sizeprocs, comm, ierr
- character(len=150) :: file_name
- integer(kind=8) :: group_size_inc
- integer :: local_dim, global_dim, offset
-! integer, parameter :: num_arrays = 9 ! TODO correct number
-! character(len=256), dimension(num_arrays) :: local_dims1, local_dims2, &
-! global_dims1, global_dims2, offsets1, offsets2, array_name
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid, sel
- integer(kind=8) :: adios_groupsize, adios_totalsize
- integer :: vars_count, attrs_count, current_step, last_step, vsteps
- character(len=128), dimension(:), allocatable :: adios_names
- integer(kind=8), dimension(1) :: start, count
-
-
- file_name = trim(LOCAL_TMP_PATH) // "/dump_all_arrays_adios.bp"
- call world_size(sizeprocs)
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
-
- local_dim = NDIM * NGLOB_CRUST_MANTLE
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "displ_crust_mantle/array", 0, 1, &
- displ_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "veloc_crust_mantle/array", 0, 1, &
- veloc_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "accel_crust_mantle/array", 0, 1, &
- accel_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- ! NOTE: perform reads before changing selection, otherwise it will segfault
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NDIM * NGLOB_INNER_CORE
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "displ_inner_core/array", 0, 1, &
- displ_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "veloc_inner_core/array", 0, 1, &
- veloc_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "accel_inner_core/array", 0, 1, &
- accel_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NGLOB_OUTER_CORE
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "displ_outer_core/array", 0, 1, &
- displ_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "veloc_outer_core/array", 0, 1, &
- veloc_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "accel_outer_core/array", 0, 1, &
- accel_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_CRUST_MANTLE_STR_OR_ATT
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xx_crust_mantle/array",&
- 0, 1, epsilondev_xx_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_yy_crust_mantle/array",&
- 0, 1, epsilondev_yy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xy_crust_mantle/array",&
- 0, 1, epsilondev_xy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xz_crust_mantle/array",&
- 0, 1, epsilondev_xz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_yz_crust_mantle/array",&
- 0, 1, epsilondev_yz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_INNER_CORE_STR_OR_ATT
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xx_inner_core/array",&
- 0, 1, epsilondev_xx_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_yy_inner_core/array",&
- 0, 1, epsilondev_yy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xy_inner_core/array",&
- 0, 1, epsilondev_xy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xz_inner_core/array",&
- 0, 1, epsilondev_xz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_yz_inner_core/array",&
- 0, 1, epsilondev_yz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_OUTER_CORE_ROTATION
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "A_array_rotation/array", 0, 1, &
- A_array_rotation, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "B_array_rotation/array", 0, 1, &
- B_array_rotation, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = N_SLS*NGLLX*NGLLY*NGLLZ*NSPEC_CRUST_MANTLE_ATTENUAT
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "R_xx_crust_mantle/array", 0, 1, &
- R_xx_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_yy_crust_mantle/array", 0, 1, &
- R_yy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_xy_crust_mantle/array", 0, 1, &
- R_xy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_xz_crust_mantle/array", 0, 1, &
- R_xz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_yz_crust_mantle/array", 0, 1, &
- R_yz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = N_SLS*NGLLX*NGLLY*NGLLZ*NSPEC_INNER_CORE_ATTENUATION
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "R_xx_inner_core/array", 0, 1, &
- R_xx_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_yy_inner_core/array", 0, 1, &
- R_yy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_xy_inner_core/array", 0, 1, &
- R_xy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_xz_inner_core/array", 0, 1, &
- R_xz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_yz_inner_core/array", 0, 1, &
- R_yz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- ! Close ADIOS handler to the restart file.
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call MPI_Barrier(comm, ierr)
-
-end subroutine read_intermediate_forward_arrays_adios
-
-!-------------------------------------------------------------------------------
-!> \brief Read forward arrays from an ADIOS file.
-!> \note read_intermediate_forward_arrays_adios()
-!! and read_forward_arrays_adios() are not factorized, because
-!> the latest read the bp file in "b_" prefixed arrays
-subroutine read_forward_arrays_adios()
- ! External imports
- use mpi
- use adios_read_mod
- ! Internal imports
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
- ! Local parameters
- integer :: sizeprocs, comm, ierr
- character(len=150) :: file_name
- integer(kind=8) :: group_size_inc
- integer :: local_dim, global_dim, offset
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid, sel
- integer(kind=8) :: adios_groupsize, adios_totalsize
- integer :: vars_count, attrs_count, current_step, last_step, vsteps
- character(len=128), dimension(:), allocatable :: adios_names
- integer(kind=8), dimension(1) :: start, count
-
-
- file_name = trim(LOCAL_TMP_PATH) // "/save_forward_arrays.bp"
- call world_size(sizeprocs)
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
-
- local_dim = NDIM * NGLOB_CRUST_MANTLE
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "displ_crust_mantle/array", 0, 1, &
- b_displ_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "veloc_crust_mantle/array", 0, 1, &
- b_veloc_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "accel_crust_mantle/array", 0, 1, &
- b_accel_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- ! NOTE: perform reads before changing selection, otherwise it will segfault
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NDIM * NGLOB_INNER_CORE
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "displ_inner_core/array", 0, 1, &
- b_displ_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "veloc_inner_core/array", 0, 1, &
- b_veloc_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "accel_inner_core/array", 0, 1, &
- b_accel_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NGLOB_OUTER_CORE
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "displ_outer_core/array", 0, 1, &
- b_displ_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "veloc_outer_core/array", 0, 1, &
- b_veloc_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "accel_outer_core/array", 0, 1, &
- b_accel_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_CRUST_MANTLE_STR_OR_ATT
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xx_crust_mantle/array",&
- 0, 1, b_epsilondev_xx_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_yy_crust_mantle/array",&
- 0, 1, b_epsilondev_yy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xy_crust_mantle/array",&
- 0, 1, b_epsilondev_xy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xz_crust_mantle/array",&
- 0, 1, b_epsilondev_xz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_yz_crust_mantle/array",&
- 0, 1, b_epsilondev_yz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_INNER_CORE_STR_OR_ATT
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xx_inner_core/array",&
- 0, 1, b_epsilondev_xx_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_yy_inner_core/array",&
- 0, 1, b_epsilondev_yy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xy_inner_core/array",&
- 0, 1, b_epsilondev_xy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_xz_inner_core/array",&
- 0, 1, b_epsilondev_xz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "epsilondev_yz_inner_core/array",&
- 0, 1, b_epsilondev_yz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- if (ROTATION_VAL) then
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_OUTER_CORE_ROTATION
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "A_array_rotation/array", 0, 1, &
- b_A_array_rotation, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "B_array_rotation/array", 0, 1, &
- b_B_array_rotation, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- if (ATTENUATION_VAL) then
- local_dim = N_SLS*NGLLX*NGLLY*NGLLZ*NSPEC_CRUST_MANTLE_ATTENUAT
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "R_xx_crust_mantle/array", 0, 1, &
- b_R_xx_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_yy_crust_mantle/array", 0, 1, &
- b_R_yy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_xy_crust_mantle/array", 0, 1, &
- b_R_xy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_xz_crust_mantle/array", 0, 1, &
- b_R_xz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_yz_crust_mantle/array", 0, 1, &
- b_R_yz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = N_SLS*NGLLX*NGLLY*NGLLZ*NSPEC_INNER_CORE_ATTENUATION
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "R_xx_inner_core/array", 0, 1, &
- b_R_xx_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_yy_inner_core/array", 0, 1, &
- b_R_yy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_xy_inner_core/array", 0, 1, &
- b_R_xy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_xz_inner_core/array", 0, 1, &
- b_R_xz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "R_yz_inner_core/array", 0, 1, &
- b_R_yz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- ! Close ADIOS handler to the restart file.
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call MPI_Barrier(comm, ierr)
-
-end subroutine read_forward_arrays_adios
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -176,6 +176,7 @@
call sync_all()
! crust and mantle
+
if(ANISOTROPIC_3D_MANTLE_VAL) then
READ_KAPPA_MU = .false.
READ_TISO = .false.
@@ -309,7 +310,6 @@
!-------------------------------------------------------------------------------------------------
!
-
subroutine read_mesh_databases_addressing(myrank, &
iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, &
iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
@@ -772,7 +772,9 @@
! read info for vertical edges for central cube matching in inner core
open(unit=27,file=prname(1:len_trim(prname))//'boundary.bin', &
- status='old',form='unformatted',action='read')
+ status='old',form='unformatted',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening inner_core boundary.bin file')
+
read(27) nspec2D_xmin_inner_core
read(27) nspec2D_xmax_inner_core
read(27) nspec2D_ymin_inner_core
@@ -798,7 +800,9 @@
call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
open(unit=27,file=prname(1:len_trim(prname))//'boundary_disc.bin', &
- status='old',form='unformatted',action='read')
+ status='old',form='unformatted',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening boundary_disc.bin file')
+
read(27) njunk1,njunk2,njunk3
if (njunk1 /= NSPEC2D_MOHO .and. njunk2 /= NSPEC2D_400 .and. njunk3 /= NSPEC2D_670) &
call exit_mpi(myrank, 'Error reading ibelm_disc.bin file')
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases_adios.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases_adios.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases_adios.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,1438 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
-!===============================================================================
-!> \brief Read adios boundary arrays created by the mesher
-!! (file: regX_boundary.bp)
-subroutine read_mesh_databases_coupling_adios()
- use adios_read_mod
-
-! to couple mantle with outer core
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
-
- include 'mpif.h'
-
- ! local parameters
- integer :: njunk1,njunk2,njunk3
- integer :: sizeprocs, comm, ierr
- character(len=150) :: file_name
- integer(kind=8) :: group_size_inc
- integer :: local_dim, global_dim, offset
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid, sel
- integer(kind=8) :: adios_groupsize, adios_totalsize
- integer :: vars_count, attrs_count, current_step, last_step, vsteps
- character(len=128), dimension(:), allocatable :: adios_names
- integer(kind=8), dimension(1) :: start, count
-
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- ! crust and mantle
- ! create name of database
- call create_name_database_adios(prname, IREGION_CRUST_MANTLE, LOCAL_PATH)
- file_name= trim(prname) // "boundary.bp"
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "nspec2D_xmin", 0, 1, &
- nspec2D_xmin_crust_mantle, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec2D_xmax", 0, 1, &
- nspec2D_xmax_crust_mantle, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec2D_ymin", 0, 1, &
- nspec2D_ymin_crust_mantle, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec2D_ymax", 0, 1, &
- nspec2D_ymax_crust_mantle, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_xmin", &
- !nspec2D_xmin_crust_mantle, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_xmax", &
- !nspec2D_xmax_crust_mantle, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_ymin", &
- !nspec2D_ymin_crust_mantle, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_ymax", &
- !nspec2D_ymax_crust_mantle, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2DMAX_XMIN_XMAX_CM
- local_dim = size (ibelm_xmin_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_xmin/array", 0, 1, &
- ibelm_xmin_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ibelm_xmax/array", 0, 1, &
- ibelm_xmax_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2DMAX_YMIN_YMAX_CM
- local_dim = size (ibelm_ymin_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_ymin/array", 0, 1, &
- ibelm_ymin_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ibelm_ymax/array", 0, 1, &
- ibelm_ymax_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2D_BOTTOM_CM
- local_dim = size (ibelm_bottom_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_bottom/array", 0, 1, &
- ibelm_bottom_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2D_TOP_CM
- local_dim = size (ibelm_top_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_top/array", 0, 1, &
- ibelm_top_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NDIM*NGLLY*NGLLZ*NSPEC2DMAX_XMIN_XMAX_CM
- local_dim = size (normal_xmin_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_xmin/array", 0, 1, &
- normal_xmin_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "normal_xmax/array", 0, 1, &
- normal_xmax_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLZ*NSPEC2DMAX_YMIN_YMAX_CM
- local_dim = size (normal_ymin_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_ymin/array", 0, 1, &
- normal_ymin_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "normal_ymax/array", 0, 1, &
- normal_ymax_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_BOTTOM_CM
- local_dim = size (ibelm_bottom_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_bottom/array", 0, 1, &
- normal_bottom_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_TOP_CM
- local_dim = size (ibelm_top_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_top/array", 0, 1, &
- normal_top_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NGLLY*NGLLZ*NSPEC2DMAX_XMIN_XMAX_CM
- local_dim = size (jacobian2D_xmin_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_xmin/array", 0, 1, &
- jacobian2D_xmin_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_xmax/array", 0, 1, &
- jacobian2D_xmax_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NGLLX*NGLLZ*NSPEC2DMAX_YMIN_YMAX_CM
- local_dim = size (jacobian2D_ymin_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_ymin/array", 0, 1, &
- jacobian2D_ymin_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_ymax/array", 0, 1, &
- jacobian2D_ymax_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NGLLX*NGLLY*NSPEC2D_BOTTOM_CM
- local_dim = size (jacobian2D_bottom_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_bottom/array", 0, 1, &
- jacobian2D_bottom_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NGLLX*NGLLY*NSPEC2D_TOP_CM
- local_dim = size (jacobian2D_top_crust_mantle)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_top/array", 0, 1, &
- jacobian2D_top_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-! boundary parameters
-
- ! Close ADIOS handler to the restart file.
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
- ! read parameters to couple fluid and solid regions
- !
- ! outer core
-
- ! create name of database
- call create_name_database_adios(prname, IREGION_OUTER_CORE, LOCAL_PATH)
- file_name= trim(prname) // "boundary.bp"
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "nspec2D_xmin", 0, 1, &
- nspec2D_xmin_outer_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec2D_xmax", 0, 1, &
- nspec2D_xmax_outer_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec2D_ymin", 0, 1, &
- nspec2D_ymin_outer_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec2D_ymax", 0, 1, &
- nspec2D_ymax_outer_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_xmin", &
- !nspec2D_xmin_outer_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_xmax", &
- !nspec2D_xmax_outer_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_ymin", &
- !nspec2D_ymin_outer_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_ymax", &
- !nspec2D_ymax_outer_core, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- nspec2D_zmin_outer_core = NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
-
- !local_dim = NSPEC2DMAX_XMIN_XMAX_OC
- local_dim = size (ibelm_xmin_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_xmin/array", 0, 1, &
- ibelm_xmin_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ibelm_xmax/array", 0, 1, &
- ibelm_xmax_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2DMAX_YMIN_YMAX_OC
- local_dim = size (ibelm_ymin_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_ymin/array", 0, 1, &
- ibelm_ymin_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ibelm_ymax/array", 0, 1, &
- ibelm_ymax_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2D_BOTTOM_OC
- local_dim = size (ibelm_bottom_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_bottom/array", 0, 1, &
- ibelm_bottom_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2D_TOP_OC
- local_dim = size (ibelm_top_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_top/array", 0, 1, &
- ibelm_top_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NDIM*NGLLY*NGLLZ*NSPEC2DMAX_XMIN_XMAX_OC
- local_dim = size (normal_xmin_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_xmin/array", 0, 1, &
- normal_xmin_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "normal_xmax/array", 0, 1, &
- normal_xmax_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLZ*NSPEC2DMAX_YMIN_YMAX_OC
- local_dim = size (normal_ymin_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_ymin/array", 0, 1, &
- normal_ymin_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "normal_ymax/array", 0, 1, &
- normal_ymax_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_BOTTOM_OC
- local_dim = size (normal_bottom_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_bottom/array", 0, 1, &
- normal_bottom_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_TOP_OC
- local_dim = size (normal_top_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_top/array", 0, 1, &
- normal_top_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NGLLY*NGLLZ*NSPEC2DMAX_XMIN_XMAX_OC
- local_dim = size (jacobian2D_xmin_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_xmin/array", 0, 1, &
- jacobian2D_xmin_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_xmax/array", 0, 1, &
- jacobian2D_xmax_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NGLLX*NGLLZ*NSPEC2DMAX_YMIN_YMAX_OC
- local_dim = size (jacobian2D_ymin_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_ymin/array", 0, 1, &
- jacobian2D_ymin_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_ymax/array", 0, 1, &
- jacobian2D_ymax_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
-
- !local_dim = NGLLX*NGLLY*NSPEC2D_BOTTOM_OC
- local_dim = size (jacobian2D_bottom_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_bottom/array", 0, 1, &
- jacobian2D_bottom_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NGLLX*NGLLY*NSPEC2D_TOP_OC
- local_dim = size (jacobian2D_top_outer_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "jacobian2D_top/array", 0, 1, &
- jacobian2D_top_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- ! boundary parameters
-
- ! Close ADIOS handler to the restart file.
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
-
- ! inner core
-
- ! create name of database
- call create_name_database_adios(prname, IREGION_INNER_CORE, LOCAL_PATH)
- file_name= trim(prname) // "boundary.bp"
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "nspec2D_xmin", 0, 1, &
- nspec2D_xmin_inner_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec2D_xmax", 0, 1, &
- nspec2D_xmax_inner_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec2D_ymin", 0, 1, &
- nspec2D_ymin_inner_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec2D_ymax", 0, 1, &
- nspec2D_ymax_inner_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_xmin", &
- !nspec2D_xmin_inner_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_xmax", &
- !nspec2D_xmax_inner_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_ymin", &
- !nspec2D_ymin_inner_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec2D_ymax", &
- !nspec2D_ymax_inner_core, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2DMAX_XMIN_XMAX_IC
- local_dim = size (ibelm_xmin_inner_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_xmin/array", 0, 1, &
- ibelm_xmin_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ibelm_xmax/array", 0, 1, &
- ibelm_xmax_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2DMAX_YMIN_YMAX_IC
- local_dim = size (ibelm_ymin_inner_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_ymin/array", 0, 1, &
- ibelm_ymin_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ibelm_ymax/array", 0, 1, &
- ibelm_ymax_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2D_BOTTOM_IC
- local_dim = size (ibelm_bottom_inner_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_bottom/array", 0, 1, &
- ibelm_bottom_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- !local_dim = NSPEC2D_TOP_IC
- local_dim = size (ibelm_top_inner_core)
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_top/array", 0, 1, &
- ibelm_top_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- ! Close ADIOS handler to the restart file.
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
- ! -- Boundary Mesh for crust and mantle ---
- if (SAVE_BOUNDARY_MESH .and. SIMULATION_TYPE == 3) then
- file_name = LOCAL_PATH // "boundary_disc.bp"
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "NSPEC2D_MOHO", 0, 1, &
- njunk1, adios_err)
- call adios_schedule_read(adios_handle, sel, "NSPEC2D_400", 0, 1, &
- njunk2, adios_err)
- call adios_schedule_read(adios_handle, sel, "NSPEC2D_670", 0, 1, &
- njunk3, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- if (njunk1 /= NSPEC2D_MOHO .and. njunk2 /= NSPEC2D_400 .and. &
- njunk3 /= NSPEC2D_670) &
- call exit_mpi(myrank, 'Error reading boundary_disc.bp file')
-
- local_dim = NSPEC2D_MOHO
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_moho_top/array", 0, 1, &
- ibelm_moho_bot, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ibelm_moho_bot/array", 0, 1, &
- ibelm_moho_top, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NSPEC2D_400
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_400_top/array", 0, 1, &
- ibelm_400_bot, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ibelm_400_bot/array", 0, 1, &
- ibelm_400_top, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NSPEC2D_670
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "ibelm_670_top/array", 0, 1, &
- ibelm_670_bot, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "ibelm_670_bot/array", 0, 1, &
- ibelm_670_top, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_MOHO
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_moho/array", 0, 1, &
- normal_moho, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_400
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_400/array", 0, 1, &
- normal_400, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NDIM*NGLLX*NGLLY*NSPEC2D_670
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "normal_670/array", 0, 1, &
- normal_670, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- ! Close ADIOS handler to the restart file.
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
- k_top = 1
- k_bot = NGLLZ
-
- ! initialization
- moho_kl = 0.; d400_kl = 0.; d670_kl = 0.; cmb_kl = 0.; icb_kl = 0.
- endif
-
-end subroutine read_mesh_databases_coupling_adios
-
-subroutine read_mesh_databases_addressing_adios()
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
-
- include 'mpif.h'
-
- ! local parameters
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
- integer, dimension(0:NPROCTOT_VAL-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
- integer :: ierr,iproc,iproc_read,iproc_xi,iproc_eta
-
- ! open file with global slice number addressing
- if(myrank == 0) then
- open(unit=IIN,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read',iostat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank,'error opening addressing.txt')
-
- do iproc = 0,NPROCTOT_VAL-1
- read(IIN,*) iproc_read,ichunk,iproc_xi,iproc_eta
-
- if(iproc_read /= iproc) call exit_MPI(myrank,'incorrect slice number read')
-
- addressing(ichunk,iproc_xi,iproc_eta) = iproc
- ichunk_slice(iproc) = ichunk
- iproc_xi_slice(iproc) = iproc_xi
- iproc_eta_slice(iproc) = iproc_eta
- enddo
- close(IIN)
- endif
-
- ! broadcast the information read on the master to the nodes
- call MPI_BCAST(addressing,NCHUNKS_VAL*NPROC_XI_VAL*NPROC_ETA_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
- call MPI_BCAST(ichunk_slice,NPROCTOT_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
- call MPI_BCAST(iproc_xi_slice,NPROCTOT_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
- call MPI_BCAST(iproc_eta_slice,NPROCTOT_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
-
- ! output a topology map of slices - fix 20x by nproc
- if (myrank == 0 ) then
- if( NCHUNKS_VAL == 6 .and. NPROCTOT_VAL < 1000 ) then
- write(IMAIN,*) 'Spatial distribution of the slices'
- do iproc_xi = NPROC_XI_VAL-1, 0, -1
- write(IMAIN,'(20x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_AB
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- do iproc_xi = NPROC_XI_VAL-1, 0, -1
- write(IMAIN,'(1x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_BC
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(3x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_AC
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(3x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_BC_ANTIPODE
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- do iproc_xi = NPROC_XI_VAL-1, 0, -1
- write(IMAIN,'(20x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_AB_ANTIPODE
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- do iproc_xi = NPROC_XI_VAL-1, 0, -1
- write(IMAIN,'(20x)',advance='no')
- do iproc_eta = NPROC_ETA_VAL -1, 0, -1
- ichunk = CHUNK_AC_ANTIPODE
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- endif
- endif
-
- ! determine chunk number and local slice coordinates using addressing
- ! (needed for stacey conditions)
- ichunk = ichunk_slice(myrank)
-
-end subroutine read_mesh_databases_addressing_adios
-
-
-!===============================================================================
-!> \brief Read crust mantle MPI arrays from an ADIOS file.
-subroutine read_mesh_databases_MPI_CM_adios()
- ! External imports
- use mpi
- use adios_read_mod
- ! Internal imports
- use specfem_par
- use specfem_par_crustmantle
- implicit none
-
- ! local parameters
- integer :: sizeprocs, comm, ierr
- character(len=150) :: file_name
- integer(kind=8) :: group_size_inc
- integer :: local_dim, global_dim, offset
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid, sel
- integer(kind=8) :: adios_groupsize, adios_totalsize
- integer :: vars_count, attrs_count, current_step, last_step, vsteps
- character(len=128), dimension(:), allocatable :: adios_names
- integer(kind=8), dimension(1) :: start, count
-
- ! create the name for the database of the current slide and region
- call create_name_database_adios(prname, IREGION_CRUST_MANTLE, LOCAL_PATH)
-
- file_name= trim(prname) // "solver_data_mpi.bp"
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
- ! MPI interfaces
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "num_interfaces", 0, 1, &
- num_interfaces_crust_mantle, adios_err)
- !call adios_get_scalar(adios_handle, "num_interfaces", &
- !num_interfaces_crust_mantle, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- allocate(my_neighbours_crust_mantle(num_interfaces_crust_mantle), &
- nibool_interfaces_crust_mantle(num_interfaces_crust_mantle), &
- stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array my_neighbours_crust_mantle etc.')
-
- if( num_interfaces_crust_mantle > 0 ) then
- call adios_selection_writeblock(sel, myrank)
- !call adios_get_scalar(adios_handle, "max_nibool_interfaces", &
- !max_nibool_interfaces_cm, adios_err)
- call adios_schedule_read(adios_handle, sel, "max_nibool_interfaces", 0, 1, &
- max_nibool_interfaces_cm, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- allocate(ibool_interfaces_crust_mantle(max_nibool_interfaces_cm, &
- num_interfaces_crust_mantle), stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array ibool_interfaces_crust_mantle')
-
- local_dim = num_interfaces_crust_mantle
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "my_neighbours/array", 0, 1, &
- my_neighbours_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "nibool_interfaces/array", &
- 0, 1, nibool_interfaces_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = max_nibool_interfaces_cm * num_interfaces_crust_mantle
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, &
- "ibool_interfaces/array", 0, 1, &
- ibool_interfaces_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- else
- ! dummy array
- max_nibool_interfaces_cm = 0
- allocate(ibool_interfaces_crust_mantle(0,0),stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array dummy ibool_interfaces_crust_mantle')
- endif
-
- ! inner / outer elements
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "nspec_inner", &
- 0, 1, nspec_inner_crust_mantle, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec_outer", &
- 0, 1, nspec_outer_crust_mantle, adios_err)
- call adios_schedule_read(adios_handle, sel, "num_phase_ispec", &
- 0, 1, num_phase_ispec_crust_mantle, adios_err)
- !call adios_get_scalar(adios_handle, "nspec_inner", &
- !nspec_inner_crust_mantle, adios_err)
- !call adios_get_scalar(adios_handle, "nspec_outer", &
- !nspec_outer_crust_mantle, adios_err)
- !call adios_get_scalar(adios_handle, "num_phase_ispec", &
- !num_phase_ispec_crust_mantle, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- if( num_phase_ispec_crust_mantle < 0 ) &
- call exit_mpi(myrank,'error num_phase_ispec_crust_mantle is < zero')
-
- allocate(phase_ispec_inner_crust_mantle(num_phase_ispec_crust_mantle,2),&
- stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array phase_ispec_inner_crust_mantle')
-
- if(num_phase_ispec_crust_mantle > 0 ) then
- local_dim = num_phase_ispec_crust_mantle * 2
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, &
- "phase_ispec_inner/array", 0, 1, &
- phase_ispec_inner_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- ! mesh coloring for GPUs
- if( USE_MESH_COLORING_GPU ) then
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "num_colors_outer", &
- 0, 1, num_colors_outer_crust_mantle, adios_err)
- call adios_schedule_read(adios_handle, sel, "num_colors_inner", &
- 0, 1, num_colors_inner_crust_mantle, adios_err)
- !call adios_get_scalar(adios_handle, "num_colors_outer", &
- !num_colors_outer_crust_mantle, adios_err)
- !call adios_get_scalar(adios_handle, "num_colors_inner", &
- !num_colors_inner_crust_mantle, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- ! colors
-
- allocate(num_elem_colors_crust_mantle(num_colors_outer_crust_mantle +&
- num_colors_inner_crust_mantle), stat=ierr)
- if( ierr /= 0 ) &
- call exit_mpi(myrank,'error allocating num_elem_colors_crust_mantle array')
-
- local_dim = num_colors_outer_crust_mantle + num_colors_inner_crust_mantle
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, &
- "num_elem_colors/array", 0, 1, &
- num_elem_colors_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- else
- ! allocates dummy arrays
- num_colors_outer_crust_mantle = 0
- num_colors_inner_crust_mantle = 0
- allocate(num_elem_colors_crust_mantle(num_colors_outer_crust_mantle + &
- num_colors_inner_crust_mantle), stat=ierr)
- if( ierr /= 0 ) &
- call exit_mpi(myrank, &
- 'error allocating num_elem_colors_crust_mantle array')
- endif
- ! Close ADIOS handler to the restart file.
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call MPI_Barrier(comm, ierr)
-
-end subroutine read_mesh_databases_MPI_CM_adios
-
-!===============================================================================
-!> \brief Read outer core MPI arrays from an ADIOS file.
-subroutine read_mesh_databases_MPI_OC_adios()
- use mpi
- use adios_read_mod
- use specfem_par
- use specfem_par_outercore
- implicit none
-
- ! local parameters
- integer :: sizeprocs, comm, ierr
- character(len=150) :: file_name
- integer(kind=8) :: group_size_inc
- integer :: local_dim, global_dim, offset
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid, sel
- integer(kind=8) :: adios_groupsize, adios_totalsize
- integer :: vars_count, attrs_count, current_step, last_step, vsteps
- character(len=128), dimension(:), allocatable :: adios_names
- integer(kind=8), dimension(1) :: start, count
-
- ! create the name for the database of the current slide and region
- call create_name_database_adios(prname, IREGION_OUTER_CORE, LOCAL_PATH)
-
- file_name= trim(prname) // "solver_data_mpi.bp"
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
- ! MPI interfaces
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "num_interfaces", &
- 0, 1, num_interfaces_outer_core, adios_err)
- !call adios_get_scalar(adios_handle, "num_interfaces", &
- !num_interfaces_outer_core, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- allocate(my_neighbours_outer_core(num_interfaces_outer_core), &
- nibool_interfaces_outer_core(num_interfaces_outer_core), &
- stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array my_neighbours_outer_coreetc.')
-
- if( num_interfaces_outer_core> 0 ) then
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "max_nibool_interfaces", &
- 0, 1, max_nibool_interfaces_oc, adios_err)
- !call adios_get_scalar(adios_handle, "max_nibool_interfaces", &
- !max_nibool_interfaces_oc, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- allocate(ibool_interfaces_outer_core(max_nibool_interfaces_oc, &
- num_interfaces_outer_core), stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array ibool_interfaces_outer_core')
-
- local_dim = num_interfaces_outer_core
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "my_neighbours/array", 0, 1, &
- my_neighbours_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "nibool_interfaces/array", &
- 0, 1, nibool_interfaces_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = max_nibool_interfaces_oc * num_interfaces_outer_core
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, &
- "ibool_interfaces/array", 0, 1, &
- ibool_interfaces_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- else
- ! dummy array
- max_nibool_interfaces_oc = 0
- allocate(ibool_interfaces_outer_core(0,0),stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array dummy ibool_interfaces_outer_core')
- endif
-
- ! inner / outer elements
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "nspec_inner", &
- 0, 1, nspec_inner_outer_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec_outer", &
- 0, 1, nspec_outer_outer_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "num_phase_ispec", &
- 0, 1, num_phase_ispec_outer_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec_inner", &
- !nspec_inner_outer_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec_outer", &
- !nspec_outer_outer_core, adios_err)
- !call adios_get_scalar(adios_handle, "num_phase_ispec", &
- !num_phase_ispec_outer_core, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- if( num_phase_ispec_outer_core< 0 ) &
- call exit_mpi(myrank,'error num_phase_ispec_outer_core is < zero')
-
- allocate(phase_ispec_inner_outer_core(num_phase_ispec_outer_core,2),&
- stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array phase_ispec_inner_outer_core')
-
- if(num_phase_ispec_outer_core> 0 ) then
- local_dim = num_phase_ispec_outer_core * 2
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, &
- "phase_ispec_inner/array", 0, 1, &
- phase_ispec_inner_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- ! mesh coloring for GPUs
- if( USE_MESH_COLORING_GPU ) then
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "num_colors_outer", &
- 0, 1, num_colors_outer_outer_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "num_colors_inner", &
- 0, 1, num_colors_inner_outer_core, adios_err)
- !call adios_get_scalar(adios_handle, "num_colors_outer", &
- !num_colors_outer_outer_core, adios_err)
- !call adios_get_scalar(adios_handle, "num_colors_inner", &
- !num_colors_inner_outer_core, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- ! colors
-
- allocate(num_elem_colors_outer_core(num_colors_outer_outer_core+&
- num_colors_inner_outer_core), stat=ierr)
- if( ierr /= 0 ) &
- call exit_mpi(myrank,'error allocating num_elem_colors_outer_core array')
-
- local_dim = num_colors_outer_outer_core+ num_colors_inner_outer_core
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, &
- "num_elem_colors/array", 0, 1, &
- num_elem_colors_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- else
- ! allocates dummy arrays
- num_colors_outer_outer_core = 0
- num_colors_inner_outer_core = 0
- allocate(num_elem_colors_outer_core(num_colors_outer_outer_core+ &
- num_colors_inner_outer_core), stat=ierr)
- if( ierr /= 0 ) &
- call exit_mpi(myrank, &
- 'error allocating num_elem_colors_outer_core array')
- endif
- ! Close ADIOS handler to the restart file.
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call MPI_Barrier(comm, ierr)
-
-end subroutine read_mesh_databases_MPI_OC_adios
-
-
-!===============================================================================
-!> \brief Read outer core MPI arrays from an ADIOS file.
-subroutine read_mesh_databases_MPI_IC_adios()
- use mpi
- use adios_read_mod
-
- use specfem_par
- use specfem_par_innercore
- implicit none
-
- ! local parameters
- integer :: sizeprocs, comm, ierr
- character(len=150) :: file_name
- integer(kind=8) :: group_size_inc
- integer :: local_dim, global_dim, offset
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid, sel
- integer(kind=8) :: adios_groupsize, adios_totalsize
- integer :: vars_count, attrs_count, current_step, last_step, vsteps
- character(len=128), dimension(:), allocatable :: adios_names
- integer(kind=8), dimension(1) :: start, count
-
- ! create the name for the database of the current slide and region
- call create_name_database_adios(prname, IREGION_INNER_CORE, LOCAL_PATH)
-
- file_name= trim(prname) // "solver_data_mpi.bp"
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
-
- ! MPI interfaces
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "num_interfaces", &
- 0, 1, num_interfaces_inner_core, adios_err)
- !call adios_get_scalar(adios_handle, "num_interfaces", &
- !num_interfaces_inner_core, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- allocate(my_neighbours_inner_core(num_interfaces_inner_core), &
- nibool_interfaces_inner_core(num_interfaces_inner_core), &
- stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array my_neighbours_inner_core etc.')
-
- if( num_interfaces_inner_core > 0 ) then
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "max_nibool_interfaces", &
- 0, 1, max_nibool_interfaces_ic, adios_err)
- !call adios_get_scalar(adios_handle, "max_nibool_interfaces", &
- !max_nibool_interfaces_ic, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- allocate(ibool_interfaces_inner_core(max_nibool_interfaces_ic, &
- num_interfaces_inner_core), stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array ibool_interfaces_inner_core')
-
- local_dim = num_interfaces_inner_core
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "my_neighbours/array", 0, 1, &
- my_neighbours_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "nibool_interfaces/array", &
- 0, 1, nibool_interfaces_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = max_nibool_interfaces_ic * num_interfaces_inner_core
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, &
- "ibool_interfaces/array", 0, 1, &
- ibool_interfaces_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- else
- ! dummy array
- max_nibool_interfaces_ic = 0
- allocate(ibool_interfaces_inner_core(0,0),stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array dummy ibool_interfaces_inner_core')
- endif
-
- ! inner / outer elements
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "nspec_inner", &
- 0, 1, nspec_inner_inner_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "nspec_outer", &
- 0, 1, nspec_outer_inner_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "num_phase_ispec", &
- 0, 1, num_phase_ispec_inner_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec_inner", &
- !nspec_inner_inner_core, adios_err)
- !call adios_get_scalar(adios_handle, "nspec_outer", &
- !nspec_outer_inner_core, adios_err)
- !call adios_get_scalar(adios_handle, "num_phase_ispec", &
- !num_phase_ispec_inner_core, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- if( num_phase_ispec_inner_core < 0 ) &
- call exit_mpi(myrank,'error num_phase_ispec_inner_core is < zero')
-
- allocate(phase_ispec_inner_inner_core(num_phase_ispec_inner_core,2),&
- stat=ierr)
- if( ierr /= 0 ) call exit_mpi(myrank, &
- 'error allocating array phase_ispec_inner_inner_core')
-
- if(num_phase_ispec_inner_core > 0 ) then
- local_dim = num_phase_ispec_inner_core * 2
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, &
- "phase_ispec_inner/array", 0, 1, &
- phase_ispec_inner_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
-
- ! mesh coloring for GPUs
- if( USE_MESH_COLORING_GPU ) then
- call adios_selection_writeblock(sel, myrank)
- call adios_schedule_read(adios_handle, sel, "num_colors_outer", &
- 0, 1, num_colors_outer_inner_core, adios_err)
- call adios_schedule_read(adios_handle, sel, "num_colors_inner", &
- 0, 1, num_colors_inner_inner_core, adios_err)
- !call adios_get_scalar(adios_handle, "num_colors_outer", &
- !num_colors_outer_inner_core, adios_err)
- !call adios_get_scalar(adios_handle, "num_colors_inner", &
- !num_colors_inner_inner_core, adios_err)
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- ! colors
-
- allocate(num_elem_colors_inner_core(num_colors_outer_inner_core +&
- num_colors_inner_inner_core), stat=ierr)
- if( ierr /= 0 ) &
- call exit_mpi(myrank,'error allocating num_elem_colors_inner_core array')
-
- local_dim = num_colors_outer_inner_core + num_colors_inner_inner_core
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, &
- "num_elem_colors/array", 0, 1, &
- num_elem_colors_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- else
- ! allocates dummy arrays
- num_colors_outer_inner_core = 0
- num_colors_inner_inner_core = 0
- allocate(num_elem_colors_inner_core(num_colors_outer_inner_core + &
- num_colors_inner_inner_core), stat=ierr)
- if( ierr /= 0 ) &
- call exit_mpi(myrank, &
- 'error allocating num_elem_colors_inner_core array')
- endif
- ! Close ADIOS handler to the restart file.
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call MPI_Barrier(comm, ierr)
-
-end subroutine read_mesh_databases_MPI_IC_adios
-
-
-!===============================================================================
-!> \brief Read Stacey BC arrays from an ADIOS file.
-subroutine read_mesh_databases_stacey_adios()
-
- use mpi
- use adios_read_mod
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
-
- ! local parameters
- integer :: ierr, comm, lnspec, lnglob, local_dim
- ! processor identification
- character(len=150) :: reg_name, file_name
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid, sel
- integer(kind=8) :: adios_groupsize, adios_totalsize
- integer :: vars_count, attrs_count, current_step, last_step, vsteps
- character(len=128), dimension(:), allocatable :: adios_names
- integer(kind=8), dimension(1) :: start, count
-
- ! crust and mantle
-
- ! create name of database
- call create_name_database_adios(reg_name, IREGION_CRUST_MANTLE, LOCAL_PATH)
-
- file_name= trim(reg_name) // "stacey.bp"
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
- ! read arrays for Stacey conditions
-
- local_dim = 2*NSPEC2DMAX_XMIN_XMAX_CM
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "njmin/array", 0, 1, &
- njmin_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "njmax/array", 0, 1, &
- njmax_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "nkmin_xi/array", 0, 1, &
- nkmin_xi_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = 2*NSPEC2DMAX_YMIN_YMAX_CM
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "nimin/array", 0, 1, &
- nimin_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "nimax/array", 0, 1, &
- nimax_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "nkmin_eta/array", 0, 1, &
- nkmin_eta_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
- ! outer core
-
- ! create name of database
- call create_name_database_adios(reg_name, IREGION_OUTER_CORE, LOCAL_PATH)
-
- file_name= trim(reg_name) // "stacey.bp"
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
-
- call adios_read_init_method (ADIOS_READ_METHOD_BP, comm, &
- "verbose=1", adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_open_file (adios_handle, file_name, 0, comm, ierr)
- call check_adios_err(myrank,adios_err)
- ! read arrays for Stacey conditions
-
- local_dim = 2*NSPEC2DMAX_XMIN_XMAX_OC
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "njmin/array", 0, 1, &
- njmin_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "njmax/array", 0, 1, &
- njmax_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "nkmin_xi/array", 0, 1, &
- nkmin_xi_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = 2*NSPEC2DMAX_YMIN_YMAX_OC
- start(1) = local_dim*myrank; count(1) = local_dim
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "nimin/array", 0, 1, &
- nimin_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "nimax/array", 0, 1, &
- nimax_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_selection_boundingbox (sel , 1, start, count)
- call adios_schedule_read(adios_handle, sel, "nkmin_eta/array", 0, 1, &
- nkmin_eta_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_perform_reads(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_selection_delete(sel)
- call adios_read_close(adios_handle, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_read_finalize_method(ADIOS_READ_METHOD_BP, adios_err)
- call check_adios_err(myrank,adios_err)
-
-end subroutine read_mesh_databases_stacey_adios
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -25,7 +25,7 @@
!
!=====================================================================
- subroutine save_forward_arrays(myrank,SIMULATION_TYPE,SAVE_FORWARD, &
+subroutine save_forward_arrays(myrank,SIMULATION_TYPE,SAVE_FORWARD, &
NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
displ_inner_core,veloc_inner_core,accel_inner_core, &
@@ -65,7 +65,6 @@
! local parameters
character(len=150) outputname
-
! save files to local disk or tape system if restart file
if(NUMBER_OF_RUNS > 1 .and. NUMBER_OF_THIS_RUN < NUMBER_OF_RUNS) then
write(outputname,"('dump_all_arrays',i6.6)") myrank
@@ -110,11 +109,11 @@
close(55)
endif
- end subroutine save_forward_arrays
-!
+end subroutine save_forward_arrays
+
!=====================================================================
- subroutine save_forward_arrays_undoatt(myrank,SIMULATION_TYPE,SAVE_FORWARD,NUMBER_OF_RUNS, &
+subroutine save_forward_arrays_undoatt(myrank,SIMULATION_TYPE,SAVE_FORWARD,NUMBER_OF_RUNS, &
displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
displ_inner_core,veloc_inner_core,accel_inner_core, &
displ_outer_core,veloc_outer_core,accel_outer_core, &
@@ -183,5 +182,5 @@
close(55)
endif
- end subroutine save_forward_arrays_undoatt
+end subroutine save_forward_arrays_undoatt
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays_adios.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays_adios.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays_adios.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,592 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!-------------------------------------------------------------------------------
-!> \file save_forward_arrays_adios.F90
-!! \brief Save forward arrays with the help of the ADIOS library.
-!! \author MPBL
-!-------------------------------------------------------------------------------
-
-!-------------------------------------------------------------------------------
-!> \brief Write intermediate forward arrays in an ADIOS file.
-!!
-!! This subroutine is only used when NUMBER_OF_RUNS > 1 and
-!! NUMBER_OF_THIS_RUN < NUMBER_OF_RUNS.
-subroutine save_intermediate_forward_arrays_adios()
- ! External imports
- use mpi
- use adios_write_mod
- ! Internal imports
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
- ! Local parameters
- integer :: sizeprocs, comm, ierr
- character(len=150) :: outputname
- integer(kind=8) :: group_size_inc
- integer :: local_dim, global_dim, offset
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid
- integer(kind=8) :: adios_groupsize, adios_totalsize
-
- outputname = trim(LOCAL_TMP_PATH) // "/dump_all_arrays_adios.bp"
- call world_size(sizeprocs) ! TODO keep it in parameters
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
- group_size_inc = 0
- call adios_declare_group(adios_group, "SPECFEM3D_GLOBE_FORWARD_ARRAYS", &
- "", 1, adios_err)
-! call check_adios_err(myrank,adios_err)
- call adios_select_method(adios_group, "MPI", "", "", adios_err)
-! call check_adios_err(myrank,adios_err)
-
- ! Define ADIOS variables
- call define_common_forward_arrays_adios(adios_group, group_size_inc)
- call define_rotation_forward_arrays_adios(adios_group, group_size_inc)
- call define_attenuation_forward_arrays_adios(adios_group, group_size_inc)
-
- ! Open an ADIOS handler to the restart file.
- call adios_open (adios_handle, "SPECFEM3D_GLOBE_FORWARD_ARRAYS", &
- outputname, "w", comm, adios_err);
-! call check_adios_err(myrank,adios_err)
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, adios_err)
-! call check_adios_err(myrank,adios_err)
-
- ! Issue the order to write the previously defined variable to the ADIOS file
- call write_common_forward_arrays_adios(adios_handle, sizeprocs)
- call write_rotation_forward_arrays_adios(adios_handle, sizeprocs)
- call write_attenuation_forward_arrays_adios(adios_handle, sizeprocs)
- ! Reset the path to its original value to avoid bugs.
- call adios_set_path (adios_handle, "", adios_err)
-! call check_adios_err(myrank,adios_err)
-
- ! Close ADIOS handler to the restart file.
- call adios_close(adios_handle, adios_err)
-! call check_adios_err(myrank,adios_err)
-end subroutine save_intermediate_forward_arrays_adios
-
-!-------------------------------------------------------------------------------
-!> \brief Write selected forward arrays in an ADIOS file.
-!!
-!! This subroutine is only used for forward simualtions when
-!! SAVE_FORWARD is set to .true. It dumps the same arrays than
-!! save_intermediate_forward_arrays_adios() execpt than some arrays
-!! are only dumped if ROTATION and ATTENUATION are set to .true.
-subroutine save_forward_arrays_adios()
- ! External imports
- use mpi
- use adios_write_mod
- ! Internal imports
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
- ! Local parameters
- integer :: sizeprocs, comm, ierr
- character(len=150) :: outputname
- integer(kind=8) :: group_size_inc
- integer :: local_dim, global_dim, offset
-! integer, parameter :: num_arrays = 9 ! TODO correct number
-! character(len=256), dimension(num_arrays) :: local_dims1, local_dims2, &
-! global_dims1, global_dims2, offsets1, offsets2, array_name
- ! ADIOS variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid
- integer(kind=8) :: adios_groupsize, adios_totalsize
-
- outputname = trim(LOCAL_TMP_PATH) // "/save_forward_arrays.bp"
- call world_size(sizeprocs)
- call MPI_Comm_dup (MPI_COMM_WORLD, comm, ierr)
- group_size_inc = 0
-
- call adios_declare_group(adios_group, "SPECFEM3D_GLOBE_FORWARD_ARRAYS", &
- "", 1, adios_err)
-! call check_adios_err(myrank,adios_err)
- call adios_select_method(adios_group, "MPI", "", "", adios_err)
-! call check_adios_err(myrank,adios_err)
-
- ! Define ADIOS variables
- call define_common_forward_arrays_adios(adios_group, group_size_inc)
- ! conditional definition of vars seem to mess with the group size,
- ! even if the variables are conditionnaly written.
-! if (ROTATION_VAL) then
- call define_rotation_forward_arrays_adios(adios_group, group_size_inc)
-! endif
-! if (ATTENUATION_VAL) then
- call define_attenuation_forward_arrays_adios(adios_group, group_size_inc)
-! endif
-
- ! Open an ADIOS handler to the restart file.
- call adios_open (adios_handle, "SPECFEM3D_GLOBE_FORWARD_ARRAYS", &
- outputname, "w", comm, adios_err);
-! call check_adios_err(myrank,adios_err)
- call adios_group_size (adios_handle, group_size_inc, &
- adios_totalsize, adios_err)
-! call check_adios_err(myrank,adios_err)
-
- ! Issue the order to write the previously defined variable to the ADIOS file
- call write_common_forward_arrays_adios(adios_handle, sizeprocs)
- if (ROTATION_VAL) then
- call write_rotation_forward_arrays_adios(adios_handle, sizeprocs)
- endif
- if (ATTENUATION_VAL) then
- call write_attenuation_forward_arrays_adios(adios_handle, sizeprocs)
- endif
- ! Reset the path to its original value to avoid bugs.
- call adios_set_path (adios_handle, "", adios_err)
-! call check_adios_err(myrank,adios_err)
-
- ! Close ADIOS handler to the restart file.
- call adios_close(adios_handle, adios_err)
-! call check_adios_err(myrank,adios_err)
-end subroutine save_forward_arrays_adios
-
-!-------------------------------------------------------------------------------
-!> Define ADIOS forward arrays that are always dumped.
-!! \param adios_group The adios group where the variables belongs
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-subroutine define_common_forward_arrays_adios(adios_group, group_size_inc)
- use adios_write_mod
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
-
- integer(kind=8), intent(in) :: adios_group
- integer(kind=8), intent(inout) :: group_size_inc
-
- integer :: local_dim
-
- local_dim = NDIM * NGLOB_CRUST_MANTLE
- call define_adios_global_real_1d_array(adios_group, "displ_crust_mantle", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "veloc_crust_mantle", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "accel_crust_mantle", &
- local_dim, group_size_inc)
-
- local_dim = NDIM * NGLOB_INNER_CORE
- call define_adios_global_real_1d_array(adios_group, "displ_inner_core", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "veloc_inner_core", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "accel_inner_core", &
- local_dim, group_size_inc)
-
- local_dim = NGLOB_OUTER_CORE
- call define_adios_global_real_1d_array(adios_group, "displ_outer_core", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "veloc_outer_core", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "accel_outer_core", &
- local_dim, group_size_inc)
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_CRUST_MANTLE_STR_OR_ATT
- call define_adios_global_real_1d_array(adios_group, &
- "epsilondev_xx_crust_mantle", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "epsilondev_yy_crust_mantle", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "epsilondev_xy_crust_mantle", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "epsilondev_xz_crust_mantle", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "epsilondev_yz_crust_mantle", local_dim, group_size_inc)
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_INNER_CORE_STR_OR_ATT
- call define_adios_global_real_1d_array(adios_group, &
- "epsilondev_xx_inner_core", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "epsilondev_yy_inner_core", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "epsilondev_xy_inner_core", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "epsilondev_xz_inner_core", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "epsilondev_yz_inner_core", local_dim, group_size_inc)
-end subroutine define_common_forward_arrays_adios
-
-!-------------------------------------------------------------------------------
-!> Define ADIOS forward arrays that are dumped if ROTATION is true.
-!! \param adios_group The adios group where the variables belongs
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-subroutine define_rotation_forward_arrays_adios(adios_group, group_size_inc)
- use adios_write_mod
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
-
- integer(kind=8), intent(in) :: adios_group
- integer(kind=8), intent(inout) :: group_size_inc
-
- integer :: local_dim
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_OUTER_CORE_ROTATION
- call define_adios_global_real_1d_array(adios_group, &
- "A_array_rotation", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "B_array_rotation", local_dim, group_size_inc)
-end subroutine define_rotation_forward_arrays_adios
-
-!-------------------------------------------------------------------------------
-!> Define ADIOS forward arrays that are dumped if ATTENUATION is true.
-!! \param adios_group The adios group where the variables belongs
-!! \param group_size_inc The inout adios group size to increment
-!! with the size of the variable
-subroutine define_attenuation_forward_arrays_adios(adios_group, group_size_inc)
- use adios_write_mod
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
-
- integer(kind=8), intent(in) :: adios_group
- integer(kind=8), intent(inout) :: group_size_inc
-
- integer :: local_dim
-
- local_dim = N_SLS*NGLLX*NGLLY*NGLLZ*NSPEC_CRUST_MANTLE_ATTENUAT
- call define_adios_global_real_1d_array(adios_group, &
- "R_xx_crust_mantle", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "R_yy_crust_mantle", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "R_xy_crust_mantle", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "R_xz_crust_mantle", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "R_yz_crust_mantle", local_dim, group_size_inc)
-
- local_dim = N_SLS*NGLLX*NGLLY*NGLLZ*NSPEC_INNER_CORE_ATTENUATION
- call define_adios_global_real_1d_array(adios_group, &
- "R_xx_inner_core", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "R_yy_inner_core", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "R_xy_inner_core", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "R_xz_inner_core", local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, &
- "R_yz_inner_core", local_dim, group_size_inc)
-end subroutine define_attenuation_forward_arrays_adios
-
-!-------------------------------------------------------------------------------
-!> Schedule writes of ADIOS forward arrays that are always dumped.
-!! \param adios_handle The handle to the adios bp file
-!! \param group_size_inc The number of MPI processes involved in the writting
-subroutine write_common_forward_arrays_adios(adios_handle, sizeprocs)
- use adios_write_mod
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
-
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: sizeprocs
-
- integer :: local_dim, adios_err
-
- local_dim = NDIM * NGLOB_CRUST_MANTLE
- call adios_set_path (adios_handle, "displ_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", displ_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "veloc_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", veloc_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "accel_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", accel_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NDIM * NGLOB_INNER_CORE
- call adios_set_path (adios_handle, "displ_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", displ_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "veloc_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", veloc_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "accel_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", accel_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_set_path (adios_handle, "", adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NGLOB_OUTER_CORE
- call adios_set_path (adios_handle, "displ_outer_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", displ_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "veloc_outer_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", veloc_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "accel_outer_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", accel_outer_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_CRUST_MANTLE_STR_OR_ATT
- call adios_set_path (adios_handle, "epsilondev_xx_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", epsilondev_xx_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "epsilondev_yy_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", epsilondev_yy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "epsilondev_xy_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", epsilondev_xy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "epsilondev_xz_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", epsilondev_xz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "epsilondev_yz_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", epsilondev_yz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_INNER_CORE_STR_OR_ATT
- call adios_set_path (adios_handle, "epsilondev_xx_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", epsilondev_xx_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "epsilondev_yy_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", epsilondev_yy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "epsilondev_xy_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", epsilondev_xy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "epsilondev_xz_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", epsilondev_xz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "epsilondev_yz_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", epsilondev_yz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-end subroutine write_common_forward_arrays_adios
-
-!-------------------------------------------------------------------------------
-!> Schedule writes of ADIOS forward arrays that are dumped if ROTATION is true.
-!! \param adios_handle The handle to the adios bp file
-!! \param group_size_inc The number of MPI processes involved in the writting
-subroutine write_rotation_forward_arrays_adios(adios_handle, sizeprocs)
- use adios_write_mod
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
-
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: sizeprocs
-
- integer :: local_dim, adios_err
-
- local_dim = NGLLX * NGLLY * NGLLZ * NSPEC_OUTER_CORE_ROTATION
- call adios_set_path (adios_handle, "A_array_rotation", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", A_array_rotation, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "B_array_rotation", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", B_array_rotation, adios_err)
- call check_adios_err(myrank,adios_err)
-end subroutine write_rotation_forward_arrays_adios
-
-!-------------------------------------------------------------------------------
-!> Schedule writes of ADIOS forward arrays that are dumped if ATTENUATION
-!! is true.
-!! \param adios_handle The handle to the adios bp file
-!! \param group_size_inc The number of MPI processes involved in the writting
-subroutine write_attenuation_forward_arrays_adios(adios_handle, sizeprocs)
- use adios_write_mod
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
-
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: sizeprocs
-
- integer :: local_dim, adios_err
-
- local_dim = N_SLS*NGLLX*NGLLY*NGLLZ*NSPEC_CRUST_MANTLE_ATTENUAT
- call adios_set_path (adios_handle, "R_xx_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", R_xx_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "R_yy_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", R_yy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "R_xy_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", R_xy_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "R_xz_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", R_xz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "R_yz_crust_mantle", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", R_yz_crust_mantle, adios_err)
- call check_adios_err(myrank,adios_err)
-
- local_dim = N_SLS*NGLLX*NGLLY*NGLLZ*NSPEC_INNER_CORE_ATTENUATION
- call adios_set_path (adios_handle, "R_xx_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", R_xx_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "R_yy_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", R_yy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "R_xy_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", R_xy_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "R_xz_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", R_xz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-
- call adios_set_path (adios_handle, "R_yz_inner_core", adios_err)
- call check_adios_err(myrank,adios_err)
- call write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- call adios_write(adios_handle, "array", R_yz_inner_core, adios_err)
- call check_adios_err(myrank,adios_err)
-end subroutine write_attenuation_forward_arrays_adios
-
-!-------------------------------------------------------------------------------
-!> Write local, global and offset dimensions to ADIOS
-!! \param adios_handle Handle to the adios file
-!! \param local_dim Number of elements to be written by one process
-!! \param sizeprocs Number of MPI processes
-subroutine write_1D_global_array_adios_dims(adios_handle, local_dim, sizeprocs)
- use adios_write_mod
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
-
- implicit none
-
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: sizeprocs, local_dim
-
- integer :: adios_err
-
- call adios_write(adios_handle, "local_dim", local_dim, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_write(adios_handle, "global_dim", local_dim*sizeprocs, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_write(adios_handle, "offset", local_dim*myrank, adios_err)
- call check_adios_err(myrank,adios_err)
-end subroutine write_1D_global_array_adios_dims
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_kernels.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_kernels.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -155,9 +155,6 @@
! Get A,C,F,L,N,eta from kappa,mu
! element can have transverse isotropy if between d220 and Moho
- !if( .not. (TRANSVERSE_ISOTROPY_VAL .and. &
- ! (idoubling_crust_mantle(ispec) == IFLAG_80_MOHO .or. &
- ! idoubling_crust_mantle(ispec) == IFLAG_220_80))) then
if( .not. ispec_is_tiso_crust_mantle(ispec) ) then
! layer with no transverse isotropy
@@ -536,6 +533,7 @@
enddo
call create_name_database(prname,myrank,IREGION_OUTER_CORE,LOCAL_PATH)
+
open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) rho_kl_outer_core
close(27)
@@ -543,7 +541,7 @@
write(27) alpha_kl_outer_core
close(27)
- !deviatoric kernel check
+ ! deviatoric kernel check
if( deviatoric_outercore ) then
open(unit=27,file=trim(prname)//'mu_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) beta_kl_outer_core
@@ -608,6 +606,7 @@
enddo
call create_name_database(prname,myrank,IREGION_INNER_CORE,LOCAL_PATH)
+
open(unit=27,file=trim(prname)//'rho_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) rho_kl_inner_core
close(27)
@@ -687,10 +686,8 @@
write(27) icb_kl
close(27)
-
end subroutine save_kernels_boundary_kl
-
!
!-------------------------------------------------------------------------------------------------
!
@@ -759,7 +756,6 @@
close(27)
enddo
-
end subroutine save_kernels_source_derivatives
!
@@ -795,6 +791,7 @@
! stores into file
call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
+
open(unit=27,file=trim(prname)//'hess_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) hess_kl_crust_mantle
close(27)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/setup_sources_receivers.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/setup_sources_receivers.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -40,7 +40,6 @@
SIMULATION_TYPE,RECEIVERS_CAN_BE_BURIED,MOVIE_SURFACE,MOVIE_VOLUME, &
HDUR_MOVIE,OUTPUT_FILES,LOCAL_PATH)
-
implicit none
include 'mpif.h'
@@ -129,8 +128,8 @@
! locate sources in the mesh
call locate_sources(NSOURCES,myrank,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,ibool_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xigll,yigll,zigll,NPROCTOT_VAL,ELLIPTICITY_VAL,TOPOGRAPHY, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xigll,yigll,zigll,NPROCTOT_VAL,ELLIPTICITY_VAL,TOPOGRAPHY, &
sec,tshift_cmt,min_tshift_cmt_original,yr,jda,ho,mi,theta_source,phi_source, &
NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
islice_selected_source,ispec_selected_source, &
@@ -138,7 +137,8 @@
rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION, &
LOCAL_PATH,SIMULATION_TYPE)
- if(abs(minval(tshift_cmt)) > TINYVAL) call exit_MPI(myrank,'one tshift_cmt must be zero, others must be positive')
+ if(abs(minval(tshift_cmt)) > TINYVAL) &
+ call exit_MPI(myrank,'one tshift_cmt must be zero, others must be positive')
! filter source time function by Gaussian with hdur = HDUR_MOVIE when outputing movies or shakemaps
if (MOVIE_SURFACE .or. MOVIE_VOLUME ) then
@@ -260,6 +260,9 @@
enddo
endif
+ ! counter for adjoint receiver stations in local slice, used to allocate adjoint source arrays
+ nadj_rec_local = 0
+
! counts receivers for adjoint simulations
if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
! by Ebru
@@ -268,8 +271,6 @@
comp(2) = bic(1:2)//'E'
comp(3) = bic(1:2)//'Z'
- ! counter for adjoint receiver stations in local slice, used to allocate adjoint source arrays
- nadj_rec_local = 0
! temporary counter to check if any files are found at all
nadj_files_found = 0
do irec = 1,nrec
@@ -349,34 +350,26 @@
write(system_command, &
"('sed -e ',a1,'s/POINTS.*/POINTS',i6,' float/',a1,' < ',a,' > ',a)")&
"'",NSOURCES + nrec,"'",trim(filename),trim(filename_new)
-!! DK DK removed call to "system", which is not portable: we impose to conform strictly to the Fortran2003 standard;
-!! DK DK the developer who wrote this command should find another way (in Fortran, without a system call)
-! call system(system_command)
+ call system(system_command)
! only extract receiver locations and remove temporary file
filename_new = trim(OUTPUT_FILES)//'/receiver.vtk'
write(system_command, &
"('awk ',a1,'{if(NR<5) print $0;if(NR==6)print ',a1,'POINTS',i6,' float',a1,';if(NR>5+',i6,')print $0}',a1,' < ',a,' > ',a)")&
"'",'"',nrec,'"',NSOURCES,"'",trim(filename),trim(filename_new)
-!! DK DK removed call to "system", which is not portable: we impose to conform strictly to the Fortran2003 standard;
-!! DK DK the developer who wrote this command should find another way (in Fortran, without a system call)
-! call system(system_command)
+ call system(system_command)
! only extract source locations and remove temporary file
filename_new = trim(OUTPUT_FILES)//'/source.vtk'
write(system_command, &
"('awk ',a1,'{if(NR< 6 + ',i6,') print $0}END{print}',a1,' < ',a,' > ',a,'; rm -f ',a)")&
"'",NSOURCES,"'",trim(filename),trim(filename_new),trim(filename)
-!! DK DK removed call to "system", which is not portable: we impose to conform strictly to the Fortran2003 standard;
-!! DK DK the developer who wrote this command should find another way (in Fortran, without a system call)
-! call system(system_command)
+ call system(system_command)
-
write(IMAIN,*)
write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP
write(IMAIN,*)
-
if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
endif
@@ -386,7 +379,6 @@
!-------------------------------------------------------------------------------------------------
!
-
subroutine setup_sources_receivers_srcarr(NSOURCES,myrank, &
ispec_selected_source,islice_selected_source, &
xi_source,eta_source,gamma_source, &
@@ -418,7 +410,6 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES) :: sourcearrays
-
! local parameters
integer :: isource
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
@@ -446,12 +437,10 @@
end subroutine setup_sources_receivers_srcarr
-
!
!-------------------------------------------------------------------------------------------------
!
-
subroutine setup_sources_receivers_adjindx(NSTEP,NSTEP_SUB_ADJ, &
NTSTEP_BETWEEN_READ_ADJSRC, &
iadjsrc,iadjsrc_len,iadj_vec)
@@ -466,7 +455,6 @@
integer, dimension(NSTEP_SUB_ADJ) :: iadjsrc_len
integer, dimension(NSTEP) :: iadj_vec
-
! local parameters
integer :: iadj_block,it,it_sub_adj
@@ -516,7 +504,7 @@
! e.g.: first block 1 has iadjsrc_len = 1000 with start at 2001 and end at 3000
! so iadj_vec(1) = 1000 - 0, iadj_vec(2) = 1000 - 1, ..., to iadj_vec(1000) = 1000 - 999 = 1
! then for block 2, iadjsrc_len = 1000 with start at 1001 and end at 2000
- ! so iadj_vec(1001) = 1000 - 0, iad_vec(1002) = 1000 - 1, .. and so on again down to 1
+ ! so iadj_vec(1001) = 1000 - 0, iadj_vec(1002) = 1000 - 1, .. and so on again down to 1
! then block 3 and your guess is right now... iadj_vec(2001) to iadj_vec(3000) is 1000 down to 1. :)
iadj_vec(it) = iadjsrc_len(it_sub_adj) - mod(it-1,NTSTEP_BETWEEN_READ_ADJSRC)
enddo
@@ -527,7 +515,6 @@
!-------------------------------------------------------------------------------------------------
!
-
subroutine setup_sources_receivers_intp(NSOURCES,myrank, &
islice_selected_source, &
xi_source,eta_source,gamma_source, &
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -27,14 +27,11 @@
!
! United States and French Government Sponsorship Acknowledged.
-!! DK DK to turn OpenMP on
-!#define USE_OPENMP
-
program xspecfem3D
implicit none
-! standard include of the MPI library
+ ! standard include of the MPI library
include 'mpif.h'
include "constants.h"
@@ -965,12 +962,7 @@
integer :: iteration_on_subset,it_of_this_subset,j,irec_local,k
integer :: it_temp,seismo_current_temp
real(kind=CUSTOM_REAL), dimension(3) :: seismograms_temp
- logical :: undo_att_sim_type_3
- undo_att_sim_type_3 = .false.
-
-
-
! *************************************************
! ************** PROGRAM STARTS HERE **************
! *************************************************
@@ -1007,7 +999,7 @@
! passing them along as arguments to the routine makes the code slower.
! it seems that this stack/heap criterion is more complicated.
!
-! another reason why modules are avoided is to make the code thread safe.
+! another reason why the use of modules is restricted is to make the code thread safe.
! having different threads access the same data structure and modifying it at the same time
! would lead to problems. passing arguments is a way to avoid such complications.
!
@@ -1034,16 +1026,7 @@
!-------------------------------------------------------------------------------------------------
!
! initialize the MPI communicator and start the NPROCTOT MPI processes.
-!! DK DK when turning OpenMP on, use this instead:
-!! DK DK from http://mpi.deino.net/mpi_functions/MPI_Init_thread.html
-!! DK DK MPI_THREAD_FUNNELED: the process may be multi-threaded, but only the main thread will make MPI calls
-!! DK DK (all MPI calls are funneled to the main thread).
-#ifdef USE_OPENMP
- integer :: iprovided
- call MPI_INIT_THREAD(MPI_THREAD_FUNNELED,iprovided,ier)
-#else
call MPI_INIT(ier)
-#endif
! force Flush-To-Zero if available to avoid very slow Gradual Underflow trapping
call force_ftz()
@@ -2348,8 +2331,6 @@
if(SIMULATION_TYPE == 3)then
- undo_att_sim_type_3 = .true.
-
allocate(b_displ_crust_mantle_store_buffer(NDIM,NGLOB_CRUST_MANTLE,NT_DUMP_ATTENUATION),stat=ier)
if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_displ_crust_mantle_store_buffer')
allocate(b_displ_outer_core_store_buffer(NGLOB_OUTER_CORE,NT_DUMP_ATTENUATION),stat=ier)
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D_par.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D_par.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D_par.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,753 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-!
-! United States and French Government Sponsorship Acknowledged.
-
-module constants_solver
-
- include "constants.h"
-
- ! include values created by the mesher
- ! done for performance only using static allocation to allow for loop unrolling
- include "OUTPUT_FILES/values_from_mesher.h"
-
-end module constants_solver
-
-!=====================================================================
-
-module specfem_par
-
-! main parameter module for specfem simulations
-
- use constants_solver
-
- implicit none
-
- !-----------------------------------------------------------------
- ! GLL points & weights
- !-----------------------------------------------------------------
-
- ! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll,wxgll
- double precision, dimension(NGLLY) :: yigll,wygll
- double precision, dimension(NGLLZ) :: zigll,wzgll
-
- ! product of weights for gravity term
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
-
- ! array with derivatives of Lagrange polynomials and precalculated products
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
-
- !-----------------------------------------------------------------
- ! attenuation parameters
- !-----------------------------------------------------------------
-
- ! memory variables and standard linear solids for attenuation
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval, betaval, gammaval
- ! ADJOINT
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: b_alphaval, b_betaval, b_gammaval
-
- ! attenuation: predictor
- double precision, dimension(N_SLS) :: tau_sigma_dble
-
- !-----------------------------------------------------------------
- ! topography/bathymetry & oceans
- !-----------------------------------------------------------------
-
- ! use integer array to store values
- integer, dimension(:,:),allocatable :: ibathy_topo
-
- ! additional mass matrix for ocean load
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
-
- ! flag to mask ocean-bottom degrees of freedom for ocean load
- logical, dimension(NGLOB_CRUST_MANTLE_OCEANS) :: updated_dof_ocean_load
-
- integer :: npoin_oceans
- integer, dimension(:),allocatable :: ibool_ocean_load
- real(kind=CUSTOM_REAL), dimension(:,:),allocatable :: normal_ocean_load
- real(kind=CUSTOM_REAL), dimension(:),allocatable :: rmass_ocean_load_selected
-
- !-----------------------------------------------------------------
- ! ellipticity
- !-----------------------------------------------------------------
-
- ! for ellipticity
- integer :: nspl
- double precision,dimension(NR) :: rspl,espl,espl2
-
- !-----------------------------------------------------------------
- ! rotation
- !-----------------------------------------------------------------
-
- ! non-dimensionalized rotation rate of the Earth times two
- real(kind=CUSTOM_REAL) :: two_omega_earth
-
- ! for the Euler scheme for rotation
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
- A_array_rotation,B_array_rotation
-
- !ADJOINT
- real(kind=CUSTOM_REAL) b_two_omega_earth
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
- b_A_array_rotation,b_B_array_rotation
-
- !-----------------------------------------------------------------
- ! gravity
- !-----------------------------------------------------------------
-
- ! lookup table every km for gravity
- real(kind=CUSTOM_REAL) :: minus_g_cmb,minus_g_icb
- double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table, &
- minus_deriv_gravity_table,density_table,d_ln_density_dr_table,minus_rho_g_over_kappa_fluid
-
- !-----------------------------------------------------------------
- ! sources
- !-----------------------------------------------------------------
-
- ! parameters for the source
- integer :: NSOURCES,nsources_local
- integer, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
- double precision, dimension(:,:,:) ,allocatable:: nu_source
-
- double precision, dimension(:), allocatable :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
- double precision, dimension(:), allocatable :: xi_source,eta_source,gamma_source
- double precision, dimension(:), allocatable :: tshift_cmt,hdur,hdur_gaussian
- double precision, dimension(:), allocatable :: theta_source,phi_source
- double precision :: t0
-
- !-----------------------------------------------------------------
- ! receivers
- !-----------------------------------------------------------------
-
- ! receiver information
- integer :: nrec,nrec_local
- integer, dimension(:), allocatable :: islice_selected_rec,ispec_selected_rec
- integer, dimension(:), allocatable :: number_receiver_global
- double precision, dimension(:), allocatable :: xi_receiver,eta_receiver,gamma_receiver
- double precision, dimension(:,:,:), allocatable :: nu
- double precision, allocatable, dimension(:) :: stlat,stlon,stele,stbur
- character(len=MAX_LENGTH_STATION_NAME), dimension(:), allocatable :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(:), allocatable :: network_name
- character(len=150) :: STATIONS,rec_filename
-
- ! Lagrange interpolators at receivers
- double precision, dimension(:,:), allocatable :: hxir_store,hetar_store,hgammar_store
-
- !ADJOINT
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: adj_sourcearrays
- integer :: nrec_simulation, nadj_rec_local
- integer :: NSTEP_SUB_ADJ ! to read input in chunks
- integer, dimension(:,:), allocatable :: iadjsrc ! to read input in chunks
- integer, dimension(:), allocatable :: iadjsrc_len,iadj_vec
- ! source frechet derivatives
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: moment_der
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: sloc_der
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: stshift_der, shdur_der
- double precision, dimension(:,:), allocatable :: hpxir_store,hpetar_store,hpgammar_store
- integer :: nadj_hprec_local
-
- !-----------------------------------------------------------------
- ! seismograms
- !-----------------------------------------------------------------
-
- ! seismograms
- integer :: it_begin,it_end,nit_written
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms
- integer :: seismo_offset, seismo_current
-
- ! for SAC headers for seismograms
- integer :: yr_SAC,jda_SAC,ho_SAC,mi_SAC
- double precision :: sec_SAC
- real :: mb_SAC
- double precision :: t_cmt_SAC,t_shift_SAC
- double precision :: elat_SAC,elon_SAC,depth_SAC, &
- cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC
- character(len=20) :: event_name_SAC
-
- !-----------------------------------------------------------------
- ! file parameters
- !-----------------------------------------------------------------
-
- ! parameters read from parameter file
- double precision DT,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- ANGULAR_WIDTH_XI_IN_DEGREES
-
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,&
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- logical ONE_CRUST,TOPOGRAPHY,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
-
- character(len=150) :: OUTPUT_FILES,LOCAL_PATH,LOCAL_TMP_PATH,MODEL
- ! process/partition name
- character(len=150) :: prname
-
-
- !-----------------------------------------------------------------
- ! mesh
- !-----------------------------------------------------------------
-
- ! this for all the regions
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_BOTTOM,NSPEC2D_TOP
-
- ! computed in read_compute_parameters
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
- !-----------------------------------------------------------------
- ! MPI partitions
- !-----------------------------------------------------------------
-
- ! proc numbers for MPI
- integer :: myrank
- integer :: ichunk ! needed for stacey boundaries
-
- ! time loop timing
- double precision :: time_start,tCPU
-
- !-----------------------------------------------------------------
- ! assembly
- !-----------------------------------------------------------------
-
- ! collected MPI interfaces
- ! MPI crust/mantle mesh
- integer :: num_interfaces_crust_mantle
- integer :: max_nibool_interfaces_cm
- integer, dimension(:), allocatable :: my_neighbours_crust_mantle,nibool_interfaces_crust_mantle
- integer, dimension(:,:), allocatable :: ibool_interfaces_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_send_vector_crust_mantle,buffer_recv_vector_crust_mantle
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_buffer_send_vector_cm,b_buffer_recv_vector_cm
-
- integer, dimension(:), allocatable :: request_send_vector_cm,request_recv_vector_cm
- integer, dimension(:), allocatable :: b_request_send_vector_cm,b_request_recv_vector_cm
-
- ! MPI inner core mesh
- integer :: num_interfaces_inner_core
- integer :: max_nibool_interfaces_ic
- integer, dimension(:), allocatable :: my_neighbours_inner_core,nibool_interfaces_inner_core
- integer, dimension(:,:), allocatable :: ibool_interfaces_inner_core
-
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_send_vector_inner_core,buffer_recv_vector_inner_core
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_buffer_send_vector_inner_core,b_buffer_recv_vector_inner_core
-
- integer, dimension(:), allocatable :: request_send_vector_ic,request_recv_vector_ic
- integer, dimension(:), allocatable :: b_request_send_vector_ic,b_request_recv_vector_ic
-
- ! MPI outer core mesh
- integer :: num_interfaces_outer_core
- integer :: max_nibool_interfaces_oc
- integer, dimension(:), allocatable :: my_neighbours_outer_core,nibool_interfaces_outer_core
- integer, dimension(:,:), allocatable :: ibool_interfaces_outer_core
-
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_scalar_outer_core,buffer_recv_scalar_outer_core
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_buffer_send_scalar_outer_core,b_buffer_recv_scalar_outer_core
-
- integer, dimension(:), allocatable :: request_send_scalar_oc,request_recv_scalar_oc
- integer, dimension(:), allocatable :: b_request_send_scalar_oc,b_request_recv_scalar_oc
-
- !-----------------------------------------------------------------
- ! gpu
- !-----------------------------------------------------------------
-
- ! CUDA mesh pointer<->integer wrapper
- integer(kind=8) :: Mesh_pointer
- logical :: GPU_MODE
-
- !-----------------------------------------------------------------
- ! ADIOS
- !-----------------------------------------------------------------
-
- logical :: ADIOS_ENABLED, ADIOS_FOR_FORWARD_ARRAYS, ADIOS_FOR_MPI_ARRAYS, &
- ADIOS_FOR_ARRAYS_SOLVER, ADIOS_FOR_SOLVER_MESHFILES, ADIOS_FOR_AVS_DX
-
- !-----------------------------------------------------------------
- ! time scheme
- !-----------------------------------------------------------------
-
- integer :: it
-
- ! Newmark time scheme parameters and non-dimensionalization
- double precision :: scale_t,scale_t_inv,scale_displ,scale_veloc
- real(kind=CUSTOM_REAL) :: deltat,deltatover2,deltatsqover2
- ! ADJOINT
- real(kind=CUSTOM_REAL) :: b_deltat,b_deltatover2,b_deltatsqover2
-
-#ifdef _HANDOPT
- integer :: imodulo_NGLOB_CRUST_MANTLE,imodulo_NGLOB_CRUST_MANTLE4, &
- imodulo_NGLOB_INNER_CORE,imodulo_NGLOB_OUTER_CORE
-#endif
-
-end module specfem_par
-
-
-!=====================================================================
-
-module specfem_par_crustmantle
-
-! parameter module for elastic solver in crust/mantle region
-
- use constants_solver
- implicit none
-
- ! ----------------- crust, mantle and oceans ---------------------
- ! mesh parameters
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
-
- ! arrays for isotropic elements stored only where needed to save space
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle
-
- ! arrays for anisotropic elements stored only where needed to save space
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
-
- ! arrays for full anisotropy only when needed
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle
-
- ! flag for transversely isotropic elements
- logical, dimension(NSPEC_CRUST_MANTLE) :: ispec_is_tiso_crust_mantle
-
- ! mass matrices
- !
- ! in the case of stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
- ! on Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
- ! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
- !
- ! if absorbing_conditions are not set or if NCHUNKS=6, only one mass matrix is needed
- ! for the sake of performance, only "rmassz" array will be filled and "rmassx" & "rmassy" will be obsolete
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmassx_crust_mantle
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmassy_crust_mantle
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmassz_crust_mantle
- integer :: NGLOB_XY_CM
-
- ! displacement, velocity, acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
-
- ! ADJOINT
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
-
- ! memory variables and standard linear solids for attenuation
- real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT4) :: &
- one_minus_sum_beta_crust_mantle, factor_scale_crust_mantle
- real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT4) :: &
- factor_common_crust_mantle
- real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: &
- R_xx_crust_mantle,R_yy_crust_mantle,R_xy_crust_mantle,R_xz_crust_mantle,R_yz_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle,epsilondev_xy_crust_mantle, &
- epsilondev_xz_crust_mantle,epsilondev_yz_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
- eps_trace_over_3_crust_mantle
-
- ! ADJOINT
- real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: &
- b_R_xx_crust_mantle,b_R_yy_crust_mantle,b_R_xy_crust_mantle,b_R_xz_crust_mantle,b_R_yz_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- b_epsilondev_xx_crust_mantle,b_epsilondev_yy_crust_mantle,b_epsilondev_xy_crust_mantle, &
- b_epsilondev_xz_crust_mantle,b_epsilondev_yz_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- b_eps_trace_over_3_crust_mantle
-
- ! for crust/oceans coupling
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
- integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: &
- jacobian2D_bottom_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: &
- jacobian2D_top_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_CM) :: &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2DMAX_YMIN_YMAX_CM) :: &
- normal_ymin_crust_mantle,normal_ymax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: &
- normal_bottom_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: &
- normal_top_crust_mantle
-
- ! Stacey
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: &
- rho_vp_crust_mantle,rho_vs_crust_mantle
- integer :: nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_CM) :: nimin_crust_mantle,nimax_crust_mantle,nkmin_eta_crust_mantle
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_CM) :: njmin_crust_mantle,njmax_crust_mantle,nkmin_xi_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: absorb_xmin_crust_mantle, &
- absorb_xmax_crust_mantle, absorb_ymin_crust_mantle, absorb_ymax_crust_mantle
-
- integer :: reclen_xmin_crust_mantle, reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle
-
- ! kernels
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- rho_kl_crust_mantle,beta_kl_crust_mantle, alpha_kl_crust_mantle, Sigma_kl_crust_mantle
- ! For anisotropic kernels (see compute_kernels.f90 for a definition of the array)
- real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- cijkl_kl_crust_mantle
- ! approximate hessian
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: hess_kl_crust_mantle
-
- ! Boundary Mesh and Kernels
- integer :: k_top,k_bot,iregion_code
- integer, dimension(NSPEC2D_MOHO) :: ibelm_moho_top,ibelm_moho_bot
- integer, dimension(NSPEC2D_400) :: ibelm_400_top,ibelm_400_bot
- integer, dimension(NSPEC2D_670) :: ibelm_670_top,ibelm_670_bot
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO) :: normal_moho
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_400) :: normal_400
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_670) :: normal_670
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO) :: moho_kl, moho_kl_top, moho_kl_bot
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_400) :: d400_kl, d400_kl_top, d400_kl_bot
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_670) :: d670_kl, d670_kl_top, d670_kl_bot
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_CMB) :: cmb_kl, cmb_kl_top, cmb_kl_bot
-
- ! NOISE_TOMOGRAPHY
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: noise_sourcearray
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
- normal_x_noise,normal_y_noise,normal_z_noise, mask_noise
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: noise_surface_movie
- integer :: irec_master_noise
- integer :: NSPEC_TOP
-
- ! inner / outer elements crust/mantle region
- integer :: num_phase_ispec_crust_mantle
- integer :: nspec_inner_crust_mantle,nspec_outer_crust_mantle
- integer, dimension(:,:), allocatable :: phase_ispec_inner_crust_mantle
-
- ! mesh coloring
- integer :: num_colors_outer_crust_mantle,num_colors_inner_crust_mantle
- integer,dimension(:),allocatable :: num_elem_colors_crust_mantle
-
-end module specfem_par_crustmantle
-
-!=====================================================================
-
-module specfem_par_innercore
-
-! parameter module for elastic solver in inner core region
-
- use constants_solver
- implicit none
-
- ! ----------------- inner core ---------------------
- ! mesh parameters
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
- xix_inner_core,xiy_inner_core,xiz_inner_core,&
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core
-
- ! material parameters
- ! (note: muvstore also needed for attenuation in case of anisotropic inner core)
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
- rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: &
- xstore_inner_core,ystore_inner_core,zstore_inner_core
-
- ! arrays for inner-core anisotropy only when needed
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core
-
- ! local to global mapping
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
-
- ! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_inner_core
-
- ! displacement, velocity, acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
- displ_inner_core,veloc_inner_core,accel_inner_core
- ! ADJOINT
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
-
- ! memory variables and standard linear solids for attenuation
- real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT5) :: &
- one_minus_sum_beta_inner_core, factor_scale_inner_core
- real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: &
- factor_common_inner_core
- real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
- R_xx_inner_core,R_yy_inner_core,R_xy_inner_core,R_xz_inner_core,R_yz_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: &
- epsilondev_xx_inner_core,epsilondev_yy_inner_core,epsilondev_xy_inner_core, &
- epsilondev_xz_inner_core,epsilondev_yz_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STRAIN_ONLY) :: &
- eps_trace_over_3_inner_core
-
- ! ADJOINT
- real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: &
- b_R_xx_inner_core,b_R_yy_inner_core,b_R_xy_inner_core,b_R_xz_inner_core,b_R_yz_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- b_epsilondev_xx_inner_core,b_epsilondev_yy_inner_core,b_epsilondev_xy_inner_core, &
- b_epsilondev_xz_inner_core,b_epsilondev_yz_inner_core
-
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- b_eps_trace_over_3_inner_core
-
- ! coupling/boundary surfaces
- integer :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
- nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
- integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
- integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
-
- ! adjoint kernels
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- rho_kl_inner_core,beta_kl_inner_core, alpha_kl_inner_core
-
- ! Boundary Mesh and Kernels
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_ICB) :: icb_kl, icb_kl_top, icb_kl_bot
- logical :: fluid_solid_boundary
-
- ! inner / outer elements inner core region
- integer :: num_phase_ispec_inner_core
- integer :: nspec_inner_inner_core,nspec_outer_inner_core
- integer, dimension(:,:), allocatable :: phase_ispec_inner_inner_core
-
- ! mesh coloring
- integer :: num_colors_outer_inner_core,num_colors_inner_inner_core
- integer,dimension(:),allocatable :: num_elem_colors_inner_core
-
-end module specfem_par_innercore
-
-!=====================================================================
-
-module specfem_par_outercore
-
-! parameter module for acoustic solver in outer core region
-
- use constants_solver
- implicit none
-
- ! ----------------- outer core ---------------------
- ! mesh parameters
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
- xix_outer_core,xiy_outer_core,xiz_outer_core,&
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
- xstore_outer_core,ystore_outer_core,zstore_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
- rhostore_outer_core,kappavstore_outer_core
-
- ! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_outer_core
-
- ! velocity potential
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
- displ_outer_core,veloc_outer_core,accel_outer_core
-
- ! ADJOINT
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
-
- ! Stacey
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_STACEY) :: vp_outer_core
- integer :: nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- nspec2D_zmin_outer_core
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_OC) :: nimin_outer_core,nimax_outer_core,nkmin_eta_outer_core
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_OC) :: njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core
-
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: absorb_xmin_outer_core, &
- absorb_xmax_outer_core, absorb_ymin_outer_core, absorb_ymax_outer_core, &
- absorb_zmin_outer_core
-
- integer :: reclen_xmin_outer_core, reclen_xmax_outer_core, &
- reclen_ymin_outer_core, reclen_ymax_outer_core
- integer :: reclen_zmin
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_OUTER_CORE_ADJOINT) :: &
- vector_accel_outer_core,vector_displ_outer_core,b_vector_displ_outer_core
-
- ! arrays to couple with the fluid regions by pointwise matching
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
- integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
- integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: normal_xmin_outer_core,normal_xmax_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: normal_ymin_outer_core,normal_ymax_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core
-
- ! adjoint kernels
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: &
- rho_kl_outer_core,alpha_kl_outer_core
-
- ! kernel runs
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: &
- div_displ_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: &
- b_div_displ_outer_core
-
- ! check for deviatoric kernel for outer core region
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: beta_kl_outer_core
- integer :: nspec_beta_kl_outer_core
- logical,parameter:: deviatoric_outercore = .false.
-
- ! inner / outer elements outer core region
- integer :: num_phase_ispec_outer_core
- integer :: nspec_inner_outer_core,nspec_outer_outer_core
- integer, dimension(:,:), allocatable :: phase_ispec_inner_outer_core
-
- ! mesh coloring
- integer :: num_colors_outer_outer_core,num_colors_inner_outer_core
- integer,dimension(:),allocatable :: num_elem_colors_outer_core
-
-end module specfem_par_outercore
-
-
-!=====================================================================
-
-module specfem_par_movie
-
-! parameter module for movies/shakemovies
-
- use constants_solver
-
- implicit none
-
- ! to save movie frames
- integer :: nmovie_points,NIT
-
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
- store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz
-
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all
-
- ! to save movie volume
- double precision :: scalingval
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_3DMOVIE) :: &
- muvstore_crust_mantle_3dmovie
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_3DMOVIE) :: &
- Iepsilondev_xx_crust_mantle,Iepsilondev_yy_crust_mantle,Iepsilondev_xy_crust_mantle, &
- Iepsilondev_xz_crust_mantle,Iepsilondev_yz_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_3DMOVIE) :: &
- Ieps_trace_over_3_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: nu_3dmovie
-
- integer :: npoints_3dmovie,nspecel_3dmovie
- integer, dimension(NGLOB_CRUST_MANTLE_3DMOVIE) :: num_ibool_3dmovie
-
- logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_3DMOVIE) :: mask_3dmovie
- logical, dimension(NGLOB_CRUST_MANTLE_3DMOVIE) :: mask_ibool
-
- ! vtk run-time visualization
-#ifdef WITH_VTK
- ! vtk window
- logical, parameter :: VTK_MODE = .true.
-#else
- logical, parameter :: VTK_MODE = .false.
-#endif
- real,dimension(:),allocatable :: vtkdata
- logical,dimension(:),allocatable :: vtkmask
- ! multi-mpi processes, gather data arrays on master
- real,dimension(:),allocatable :: vtkdata_all
- integer,dimension(:),allocatable :: vtkdata_points_all
- integer,dimension(:),allocatable :: vtkdata_offset_all
- integer :: vtkdata_numpoints_all
- real :: vtkdata_source_x,vtkdata_source_y,vtkdata_source_z
-
-end module specfem_par_movie
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_volume.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_volume.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_volume.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -31,7 +31,7 @@
subroutine count_points_movie_volume(prname,ibool_crust_mantle, xstore_crust_mantle,ystore_crust_mantle, &
zstore_crust_mantle,MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
MOVIE_COARSE,npoints_3dmovie,nspecel_3dmovie,num_ibool_3dmovie, &
- mask_ibool_3dmovie,mask_3dmovie)
+ mask_ibool,mask_3dmovie)
implicit none
@@ -48,62 +48,63 @@
! output
integer :: npoints_3dmovie,nspecel_3dmovie
integer, dimension(NGLOB_CRUST_MANTLE) :: num_ibool_3dmovie
- logical, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool_3dmovie
+ logical, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool
logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
! variables
- integer :: ipoints_3dmovie,ispecel_3dmovie,ispec,iglob,i,j,k,NIT
+ integer :: ipoints_3dmovie,ispecel_3dmovie,ispec,iglob,i,j,k,iNIT
real(kind=custom_real) :: rval,thetaval,phival
if(MOVIE_COARSE) then
- NIT = NGLLX-1
+ iNIT = NGLLX-1
else
- NIT = 1
+ iNIT = 1
endif
ipoints_3dmovie=0
num_ibool_3dmovie(:) = -99
ispecel_3dmovie = 0
- mask_ibool_3dmovie(:)=.false.
+ mask_ibool(:)=.false.
mask_3dmovie(:,:,:,:)=.false.
! create name of database
open(unit=IOUT,file=trim(prname)//'movie3D_info.txt',status='unknown')
!find and count points within given region for storing movie
- do ispec = 1,NSPEC_CRUST_MANTLE
- !output element if center of element is in the given region
- iglob = ibool_crust_mantle((NGLLX+1)/2,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
- rval = xstore_crust_mantle(iglob)
- thetaval = ystore_crust_mantle(iglob)
- phival = zstore_crust_mantle(iglob)
- ! we alread changed xyz back to rthetaphi
- if( (rval < MOVIE_TOP .and. rval > MOVIE_BOTTOM) .and. &
- (thetaval > MOVIE_NORTH .and. thetaval < MOVIE_SOUTH) .and. &
- ( (phival < MOVIE_EAST .and. phival > MOVIE_WEST) .or. &
- ( (MOVIE_EAST < MOVIE_WEST) .and. (phival >MOVIE_EAST .or. phival < MOVIE_WEST) ) ) ) then
- ispecel_3dmovie=ispecel_3dmovie+1
- do k=1,NGLLZ,NIT
- do j=1,NGLLY,NIT
- do i=1,NGLLX,NIT
- iglob = ibool_crust_mantle(i,j,k,ispec)
- if(.not. mask_ibool_3dmovie(iglob)) then
- ipoints_3dmovie = ipoints_3dmovie + 1
- mask_ibool_3dmovie(iglob)=.true.
- mask_3dmovie(i,j,k,ispec)=.true.
- num_ibool_3dmovie(iglob)= ipoints_3dmovie
- endif
- enddo !i
- enddo !j
- enddo !k
- endif !in region
- enddo !ispec
- npoints_3dmovie=ipoints_3dmovie
- nspecel_3dmovie=ispecel_3dmovie
+ do ispec = 1,NSPEC_CRUST_MANTLE
+ !output element if center of element is in the given region
+ iglob = ibool_crust_mantle((NGLLX+1)/2,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ rval = xstore_crust_mantle(iglob)
+ thetaval = ystore_crust_mantle(iglob)
+ phival = zstore_crust_mantle(iglob)
- write(IOUT,*) npoints_3dmovie, nspecel_3dmovie
- close(IOUT)
+ ! we already changed xyz back to rthetaphi
+ if( (rval < MOVIE_TOP .and. rval > MOVIE_BOTTOM) .and. &
+ (thetaval > MOVIE_NORTH .and. thetaval < MOVIE_SOUTH) .and. &
+ ( (phival < MOVIE_EAST .and. phival > MOVIE_WEST) .or. &
+ ( (MOVIE_EAST < MOVIE_WEST) .and. (phival >MOVIE_EAST .or. phival < MOVIE_WEST) ) ) ) then
+ ispecel_3dmovie=ispecel_3dmovie+1
+ do k=1,NGLLZ,iNIT
+ do j=1,NGLLY,iNIT
+ do i=1,NGLLX,iNIT
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+ if(.not. mask_ibool(iglob)) then
+ ipoints_3dmovie = ipoints_3dmovie + 1
+ mask_ibool(iglob)=.true.
+ mask_3dmovie(i,j,k,ispec)=.true.
+ num_ibool_3dmovie(iglob)= ipoints_3dmovie
+ endif
+ enddo !i
+ enddo !j
+ enddo !k
+ endif !in region
+ enddo !ispec
+ npoints_3dmovie=ipoints_3dmovie
+ nspecel_3dmovie=ispecel_3dmovie
+ write(IOUT,*) npoints_3dmovie, nspecel_3dmovie
+ close(IOUT)
+
end subroutine count_points_movie_volume
!
@@ -115,7 +116,7 @@
subroutine write_movie_volume_mesh(npoints_3dmovie,prname,ibool_crust_mantle,xstore_crust_mantle, &
ystore_crust_mantle,zstore_crust_mantle, muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,mask_ibool_3dmovie,num_ibool_3dmovie,nu_3dmovie,MOVIE_COARSE)
+ mask_3dmovie,mask_ibool,num_ibool_3dmovie,nu_3dmovie,MOVIE_COARSE)
implicit none
@@ -129,7 +130,7 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_3DMOVIE) :: muvstore_crust_mantle_3dmovie
character(len=150) :: prname
logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
- logical, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool_3dmovie
+ logical, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool
logical :: MOVIE_COARSE
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
@@ -139,23 +140,23 @@
!variables
integer :: ipoints_3dmovie,ispecele,ispec,i,j,k,iglob,iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
- integer :: n1,n2,n3,n4,n5,n6,n7,n8,NIT
+ integer :: n1,n2,n3,n4,n5,n6,n7,n8,iNIT
real(kind=CUSTOM_REAL) :: rval,thetaval,phival,xval,yval,zval,st,ct,sp,cp
real(kind=CUSTOM_REAL), dimension(npoints_3dmovie) :: store_val3D_x,store_val3D_y, store_val3D_z
if(NDIM /= 3) stop 'movie volume output requires NDIM = 3'
if(MOVIE_COARSE) then
- NIT = NGLLX-1
+ iNIT = NGLLX-1
else
- NIT = 1
+ iNIT = 1
endif
ipoints_3dmovie=0
do ispec=1,NSPEC_CRUST_MANTLE
- do k=1,NGLLZ,NIT
- do j=1,NGLLY,NIT
- do i=1,NGLLX,NIT
+ do k=1,NGLLZ,iNIT
+ do j=1,NGLLY,iNIT
+ do i=1,NGLLX,iNIT
if(mask_3dmovie(i,j,k,ispec)) then
ipoints_3dmovie=ipoints_3dmovie+1
iglob= ibool_crust_mantle(i,j,k,ispec)
@@ -219,20 +220,20 @@
else
iglob=ibool_crust_mantle(3,3,3,ispec)
endif
- if(mask_ibool_3dmovie(iglob)) then !this element is in the region
+ if(mask_ibool(iglob)) then !this element is in the region
ispecele = ispecele+1
- do k=1,NGLLZ-1,NIT
- do j=1,NGLLY-1,NIT
- do i=1,NGLLX-1,NIT
+ do k=1,NGLLZ-1,iNIT
+ do j=1,NGLLY-1,iNIT
+ do i=1,NGLLX-1,iNIT
! if(mask_3dmovie(i,j,k,ispec)) then
iglob1 = ibool_crust_mantle(i,j,k,ispec)
- iglob2 = ibool_crust_mantle(i+NIT,j,k,ispec)
- iglob3 = ibool_crust_mantle(i+NIT,j+NIT,k,ispec)
- iglob4 = ibool_crust_mantle(i,j+NIT,k,ispec)
- iglob5 = ibool_crust_mantle(i,j,k+NIT,ispec)
- iglob6 = ibool_crust_mantle(i+NIT,j,k+NIT,ispec)
- iglob7 = ibool_crust_mantle(i+NIT,j+NIT,k+NIT,ispec)
- iglob8 = ibool_crust_mantle(i,j+NIT,k+NIT,ispec)
+ iglob2 = ibool_crust_mantle(i+iNIT,j,k,ispec)
+ iglob3 = ibool_crust_mantle(i+iNIT,j+iNIT,k,ispec)
+ iglob4 = ibool_crust_mantle(i,j+iNIT,k,ispec)
+ iglob5 = ibool_crust_mantle(i,j,k+iNIT,ispec)
+ iglob6 = ibool_crust_mantle(i+iNIT,j,k+iNIT,ispec)
+ iglob7 = ibool_crust_mantle(i+iNIT,j+iNIT,k+iNIT,ispec)
+ iglob8 = ibool_crust_mantle(i,j+iNIT,k+iNIT,ispec)
n1 = num_ibool_3dmovie(iglob1)-1
n2 = num_ibool_3dmovie(iglob2)-1
n3 = num_ibool_3dmovie(iglob3)-1
@@ -258,7 +259,8 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine write_movie_volume_strains(myrank,npoints_3dmovie,LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ subroutine write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
it,muvstore_crust_mantle_3dmovie,mask_3dmovie,nu_3dmovie,&
hprime_xx,hprime_yy,hprime_zz,ibool_crust_mantle,&
xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
@@ -297,7 +299,7 @@
! variables
character(len=150) prname
- integer :: ipoints_3dmovie,i,j,k,ispec,NIT
+ integer :: ipoints_3dmovie,i,j,k,ispec,iNIT
real(kind=CUSTOM_REAL) :: muv_3dmovie
real(kind=CUSTOM_REAL),dimension(3,3) :: eps_loc,eps_loc_new
real(kind=CUSTOM_REAL),dimension(:),allocatable :: store_val3d_NN,store_val3d_EE,store_val3d_ZZ,&
@@ -305,16 +307,19 @@
character(len=1) movie_prefix
- allocate(store_val3d_NN(npoints_3dmovie))
- allocate(store_val3d_EE(npoints_3dmovie))
- allocate(store_val3d_ZZ(npoints_3dmovie))
- allocate(store_val3d_NE(npoints_3dmovie))
- allocate(store_val3d_NZ(npoints_3dmovie))
- allocate(store_val3d_EZ(npoints_3dmovie))
-
! check
if(NDIM /= 3) call exit_MPI(myrank, 'write_movie_volume requires NDIM = 3')
+ ! allocates arrays
+ allocate(store_val3d_NN(npoints_3dmovie), &
+ store_val3d_EE(npoints_3dmovie), &
+ store_val3d_ZZ(npoints_3dmovie), &
+ store_val3d_NE(npoints_3dmovie), &
+ store_val3d_NZ(npoints_3dmovie), &
+ store_val3d_EZ(npoints_3dmovie), &
+ stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating store_val3d_ .. arrays')
+
if(MOVIE_VOLUME_TYPE == 1) then
movie_prefix='E' ! strain
else if(MOVIE_VOLUME_TYPE == 2) then
@@ -323,12 +328,13 @@
movie_prefix='P' ! potency, or integral of strain x \mu
endif
if(MOVIE_COARSE) then
- NIT = NGLLX-1
+ iNIT = NGLLX-1
else
- NIT = 1
+ iNIT = 1
endif
write(prname,"('proc',i6.6)") myrank
+
ipoints_3dmovie=0
do ispec=1,NSPEC_CRUST_MANTLE
call compute_element_strain_undo_att_noDev(ispec,nglob_crust_mantle,NSPEC_CRUST_MANTLE,&
@@ -338,9 +344,9 @@
gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,&
epsilondev_loc_crust_mantle,eps_trace_over_3_loc_crust_mantle)
- do k=1,NGLLZ,NIT
- do j=1,NGLLY,NIT
- do i=1,NGLLX,NIT
+ do k=1,NGLLZ,iNIT
+ do j=1,NGLLY,iNIT
+ do i=1,NGLLX,iNIT
if(mask_3dmovie(i,j,k,ispec)) then
ipoints_3dmovie=ipoints_3dmovie+1
muv_3dmovie=muvstore_crust_mantle_3dmovie(i,j,k,ispec)
@@ -406,6 +412,9 @@
write(27) store_val3d_EZ(1:npoints_3dmovie)
close(27)
+ deallocate(store_val3d_NN,store_val3d_EE,store_val3d_ZZ, &
+ store_val3d_NE,store_val3d_NZ,store_val3d_EZ)
+
end subroutine write_movie_volume_strains
!
@@ -424,21 +433,28 @@
include "OUTPUT_FILES/values_from_mesher.h"
! input
- integer :: myrank,npoints_3dmovie,MOVIE_VOLUME_TYPE,it
+ integer :: myrank,it
+ integer :: npoints_3dmovie
+ integer :: MOVIE_VOLUME_TYPE
+ logical :: MOVIE_COARSE
+
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
real(kind=CUSTOM_REAL), dimension(3,NGLOB_CRUST_MANTLE) :: vector_crust_mantle
+
+ logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
+
+ double precision :: scalingval
real(kind=CUSTOM_REAL), dimension(3,3,npoints_3dmovie) :: nu_3dmovie
- double precision :: scalingval
+ character(len=150) LOCAL_PATH
+
real(kind=CUSTOM_REAL) :: scalingval_to_use
+
+ ! local parameters
real(kind=CUSTOM_REAL), dimension(3) :: vector_local,vector_local_new
- logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
- logical :: MOVIE_COARSE
- character(len=150) LOCAL_PATH
+ integer :: ipoints_3dmovie,i,j,k,ispec,iNIT,iglob
+ real(kind=CUSTOM_REAL), dimension(:),allocatable :: store_val3d_N,store_val3d_E,store_val3d_Z
- ! variables
- integer :: ipoints_3dmovie,i,j,k,ispec,NIT,iglob
- real(kind=CUSTOM_REAL),dimension(:),allocatable :: store_val3d_N,store_val3d_E,store_val3d_Z
character(len=150) outputname
character(len=2) movie_prefix
@@ -446,9 +462,11 @@
if(NDIM /= 3) call exit_MPI(myrank,'write_movie_volume requires NDIM = 3')
! allocates arrays
- allocate(store_val3d_N(npoints_3dmovie))
- allocate(store_val3d_E(npoints_3dmovie))
- allocate(store_val3d_Z(npoints_3dmovie))
+ allocate(store_val3d_N(npoints_3dmovie), &
+ store_val3d_E(npoints_3dmovie), &
+ store_val3d_Z(npoints_3dmovie), &
+ stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating store_val3d_N,.. movie arrays')
if(MOVIE_VOLUME_TYPE == 5) then
movie_prefix='DI' ! displacement
@@ -457,9 +475,9 @@
endif
if(MOVIE_COARSE) then
- NIT = NGLLX-1
+ iNIT = NGLLX-1
else
- NIT = 1
+ iNIT = 1
endif
if(CUSTOM_REAL == SIZE_REAL) then
@@ -471,9 +489,9 @@
ipoints_3dmovie = 0
do ispec=1,NSPEC_CRUST_MANTLE
- do k=1,NGLLZ,NIT
- do j=1,NGLLY,NIT
- do i=1,NGLLX,NIT
+ do k=1,NGLLZ,iNIT
+ do j=1,NGLLY,iNIT
+ do i=1,NGLLX,iNIT
if(mask_3dmovie(i,j,k,ispec)) then
ipoints_3dmovie=ipoints_3dmovie+1
iglob = ibool_crust_mantle(i,j,k,ispec)
@@ -507,6 +525,7 @@
write(27) store_val3d_Z(1:npoints_3dmovie)
close(27)
+ deallocate(store_val3d_N,store_val3d_E,store_val3d_Z)
end subroutine write_movie_volume_vector
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_output_SAC.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_output_SAC.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_output_SAC.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -257,6 +257,7 @@
CMPAZ = sngl(modulo(phi_dble,360.d0)) ! phi is calculated above (see call distaz())
CMPINC =90.00
else if(iorientation == 5) then !T
+ phi_dble = phi
CMPAZ = sngl(modulo(phi_dble+90.d0,360.d0)) ! phi is calculated above (see call distaz())
CMPINC =90.00
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_seismograms.f90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_seismograms.f90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -160,12 +160,12 @@
if(total_seismos_local/= nrec_local) call exit_MPI(myrank,'incorrect total number of receivers saved')
- write_time = MPI_WTIME() - write_time_begin
-
+ ! user output
if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'Writing the seismograms in parallel took ',write_time,' seconds'
- write(IMAIN,*)
+ write_time = MPI_WTIME() - write_time_begin
+ write(IMAIN,*)
+ write(IMAIN,*) 'Writing the seismograms in parallel took ',write_time,' seconds'
+ write(IMAIN,*)
endif
! now only the master process does the writing of seismograms and
@@ -176,13 +176,13 @@
if(myrank == 0) then ! on the master, gather all the seismograms
- ! create one large file instead of one small file per station to avoid file system overload
- if(OUTPUT_SEISMOS_ASCII_TEXT .and. SAVE_ALL_SEISMOS_IN_ONE_FILE) then
- write(sisname,'(A)') '/all_seismograms'
+ ! create one large file instead of one small file per station to avoid file system overload
+ if(OUTPUT_SEISMOS_ASCII_TEXT .and. SAVE_ALL_SEISMOS_IN_ONE_FILE) then
+ write(sisname,'(A)') '/all_seismograms'
- if(USE_BINARY_FOR_LARGE_FILE) then
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='unknown',form='unformatted',action='write')
+ if(USE_BINARY_FOR_LARGE_FILE) then
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='unknown',form='unformatted',action='write')
else
open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
form='unformatted',position='append',action='write')
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_specfem_adios_header.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_specfem_adios_header.F90 2013-07-02 02:26:51 UTC (rev 22485)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_specfem_adios_header.F90 2013-07-02 15:37:49 UTC (rev 22486)
@@ -1,761 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-
-!> \file write_par_header_ADIOS.F90
-!! \brief Write in the adios file a group with all the parameters that insure
-!! reproductibility
-
-#include "config.fh"
-
-!
-!-------------------------------------------------------------------------------
-!
-
-!> @brief Write simulation parameters into ADIOS result file header.
-!!
-!! Write the ADIOS header containing values to ensure reproductibility of
-!! the simulation. These values come form the following files :
-!! DATA/Par_file, DATA/CMTSOLUTION, DATA/STATIONS
-subroutine write_specfem_header_adios()
- use mpi
- use adios_write_mod
- use specfem_par, only : myrank, NSOURCES
-
- implicit none
- include "constants.h"
-
- !-------------------------------------------------------------------
- ! local parameters
- !-------------------------------------------------------------------
- ! parameters read from parameter file (cf. DATA/Par_file)
- integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC, &
- NTSTEP_BETWEEN_FRAMES, NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, &
- NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, MOVIE_VOLUME_TYPE, &
- MOVIE_START,MOVIE_STOP, NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
- NOISE_TOMOGRAPHY
-
- double precision :: ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES, &
- GAMMA_ROTATION_AZIMUTH, HDUR_MOVIE,MOVIE_TOP_KM,MOVIE_BOTTOM_KM, &
- MOVIE_EAST_DEG,MOVIE_WEST_DEG,MOVIE_NORTH_DEG,MOVIE_SOUTH_DEG, &
- RECORD_LENGTH_IN_MINUTES
-
- logical :: ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE, RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION, SAVE_MESH_FILES,ATTENUATION,ATTENUATION_NEW, &
- ABSORBING_CONDITIONS,SAVE_FORWARD, OUTPUT_SEISMOS_ASCII_TEXT, &
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
-
- ! values from CMTSOLUTION -------------------------------
- ! integer :: NSOURCES -> in specfem_par module
- integer, dimension(NSOURCES) :: yr, mo, da, ho, mi
- double precision, dimension(NSOURCES) :: sec, t_shift, hdur, lat, long, depth
- double precision, dimension(NSOURCES) :: mrr, mtt, mpp, mrt, mrp, mtp
- integer :: event_name_length, datasource_length
- character(len=16):: event_name
- character(len=:), allocatable :: datasource ! F03 feature
-
- ! values from STATIONS ----------------------------------
- integer :: NSTATIONS
- integer :: station_name_length, network_name_length ! for later reading
- character(len=:), allocatable :: station_name, network_name
- double precision, allocatable, dimension(:) :: stlat, stlon, stele, stbur
-
- character(len=150) :: OUTPUT_FILES,LOCAL_PATH,LOCAL_TMP_PATH,MODEL
-
- ! Adios variables
- integer :: adios_err
- integer(kind=8) :: adios_group, adios_handle, varid
- integer(kind=8) :: adios_groupsize, adios_totalsize
- ! TODO: find a better name once the use of ADIOS is more completely
- ! implemented
- character(len=256):: filename = "OUTPUT_FILES/header_specfem3d_globe.bp"
- integer(kind=8) :: group_size_inc
- integer :: model_length ! for later reading of MODEL
- integer :: isource, irec, ier
-
-
- ! only the master needs to read the values to be written
- if(myrank == 0) then
- call adios_declare_group (adios_group, "SPECFEM3D_GLOBE_HEADER", &
- "", 0, adios_err)
- call adios_select_method (adios_group, "MPI", "", "", adios_err)
-
- group_size_inc = 0 ! Adios group size. Incremented by adios_helpers
-
- !-- *** Define variables used to configure specfem
- call define_solver_info_variables (adios_group, group_size_inc)
-
- !--*** Values read from DATA/Par_file ***
- ! extract all unmodified values from the Par_file
- call read_parameter_file(OUTPUT_FILES, &
- LOCAL_PATH, LOCAL_TMP_PATH, MODEL, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS, NTSTEP_BETWEEN_READ_ADJSRC, &
- NTSTEP_BETWEEN_FRAMES, NTSTEP_BETWEEN_OUTPUT_INFO, NUMBER_OF_RUNS, &
- NUMBER_OF_THIS_RUN, NCHUNKS, SIMULATION_TYPE, MOVIE_VOLUME_TYPE, &
- MOVIE_START, MOVIE_STOP, NEX_XI, NEX_ETA, NPROC_XI, NPROC_ETA, &
- ANGULAR_WIDTH_XI_IN_DEGREES, ANGULAR_WIDTH_ETA_IN_DEGREES, &
- CENTER_LONGITUDE_IN_DEGREES, CENTER_LATITUDE_IN_DEGREES, &
- GAMMA_ROTATION_AZIMUTH, HDUR_MOVIE, MOVIE_TOP_KM, MOVIE_BOTTOM_KM, &
- RECORD_LENGTH_IN_MINUTES, MOVIE_EAST_DEG, MOVIE_WEST_DEG, &
- MOVIE_NORTH_DEG, MOVIE_SOUTH_DEG, ELLIPTICITY, GRAVITY, ROTATION, &
- TOPOGRAPHY, OCEANS, MOVIE_SURFACE, MOVIE_VOLUME, MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED, PRINT_SOURCE_TIME_FUNCTION, SAVE_MESH_FILES, &
- ATTENUATION, ATTENUATION_NEW, ABSORBING_CONDITIONS, SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT, OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY, ROTATE_SEISMOGRAMS_RT, &
- WRITE_SEISMOGRAMS_BY_MASTER, SAVE_ALL_SEISMOS_IN_ONE_FILE, &
- USE_BINARY_FOR_LARGE_FILE, NOISE_TOMOGRAPHY)
-
- model_length = len(MODEL)
- ! define adios variables for the Par_file
- call define_par_file_variables (adios_group, group_size_inc, model_length)
-
- !--*** Values read from DATA/CMTSOLUTION ***--
- call read_raw_cmtsolution (yr, mo, da, ho, mi, sec, t_shift, hdur, lat, &
- long, depth, mrr, mtt, mpp, mrt, mrp, mtp, event_name_length, &
- event_name, datasource_length, datasource)
- call define_cmtsolution_variables (adios_group, group_size_inc, NSOURCES, &
- event_name_length, datasource_length)
-
- !--*** Values read from DATA/STATIONS
- call read_raw_stations (NSTATIONS, stlat, stlon, stele, stbur, &
- station_name_length, station_name, network_name_length, network_name)
- call define_stations_variables (adios_group, group_size_inc, NSTATIONS, &
- station_name_length, network_name_length)
-
- ! open the file where the headers have to be written
- call adios_open (adios_handle, "SPECFEM3D_GLOBE_HEADER", filename, "w", &
- MPI_COMM_SELF, adios_err);
- ! The group size have been auto-incremented
- adios_groupsize = group_size_inc
- call adios_group_size (adios_handle, adios_groupsize, &
- adios_totalsize, adios_err)
-
- ! Write variables from 'config.h'
- call write_adios_solver_info_variables (adios_handle)
-
- ! Write variables from 'Par_file'
- call write_adios_par_file_variables (adios_handle, &
- ANGULAR_WIDTH_XI_IN_DEGREES, ANGULAR_WIDTH_ETA_IN_DEGREES, &
- CENTER_LONGITUDE_IN_DEGREES, CENTER_LATITUDE_IN_DEGREES, &
- GAMMA_ROTATION_AZIMUTH, HDUR_MOVIE, MOVIE_TOP_KM, MOVIE_BOTTOM_KM, &
- MOVIE_EAST_DEG, MOVIE_WEST_DEG, MOVIE_NORTH_DEG, MOVIE_SOUTH_DEG, &
- RECORD_LENGTH_IN_MINUTES, NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC, NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO, NUMBER_OF_RUNS, NUMBER_OF_THIS_RUN,NCHUNKS,&
- SIMULATION_TYPE, MOVIE_VOLUME_TYPE, MOVIE_START, MOVIE_STOP, NEX_XI, &
- NEX_ETA, NPROC_XI, NPROC_ETA, NOISE_TOMOGRAPHY, ELLIPTICITY, GRAVITY, &
- ROTATION, TOPOGRAPHY, OCEANS, MOVIE_SURFACE, MOVIE_VOLUME,MOVIE_COARSE,&
- RECEIVERS_CAN_BE_BURIED, PRINT_SOURCE_TIME_FUNCTION, SAVE_MESH_FILES, &
- ATTENUATION, ATTENUATION_NEW, ABSORBING_CONDITIONS, SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT, OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY, ROTATE_SEISMOGRAMS_RT, &
- WRITE_SEISMOGRAMS_BY_MASTER, SAVE_ALL_SEISMOS_IN_ONE_FILE, &
- USE_BINARY_FOR_LARGE_FILE, model_length, MODEL)
-
- ! Write variables from 'CMTSOLUTION'
- call write_adios_cmtsolution_variables (adios_handle, &
- NSOURCES, yr, mo, da, ho, mi, sec, t_shift, hdur, lat, long, depth, &
- mrr, mtt, mpp, mrt, mrp, mtp, event_name_length, event_name, &
- datasource_length, datasource)
-
- ! Write variables from 'STATIONS'
- call write_adios_stations_variables (adios_handle, &
- NSTATIONS, stlat, stlon, stele, stbur, station_name_length, &
- station_name, network_name_length, network_name)
-
- call adios_close (adios_handle, adios_err)
-
- deallocate(datasource)
- deallocate(station_name)
- deallocate(network_name)
- deallocate(stlat)
- deallocate(stlon)
- deallocate(stele)
- deallocate(stbur)
- endif
-
-! Imbricated/contained subroutines. The initial thougth was to do a module with
-! public access to the write_specfem_header_adios routine and private access to
-! the other routines. The problem then is the files compilation order that
-! should be done very carefully. This require modifications of the Makefile
-! which is not currently designed to do that.
-contains
-
-!> \brief Define ADIOS variable to store values from 'setup/config.h'. Store
-!! configuration parameters to insure reproductibility
-!! \param adios_group The ADIOS entity grouping variables for data transferts
-!! \param group_size_inc The group size to increment wrt. the variable size
-subroutine define_solver_info_variables (adios_group, group_size_inc)
- implicit none
- ! Parameters
- integer(kind=8), intent(in) :: adios_group
- integer(kind=8), intent(inout) :: group_size_inc
- ! Variables
- integer :: pkg_str_len, conf_flags_len
-
- pkg_str_len = len_trim(PACKAGE_STRING)
- conf_flags_len = len_trim(CONFIGURE_FLAGS)
- call define_adios_integer_scalar (adios_group, "package_string_length", &
- "/solver_info", group_size_inc)
- call define_adios_string (adios_group, "package_name", "/solver_info", &
- pkg_str_len, group_size_inc)
- call define_adios_integer_scalar (adios_group, "conf_flags_len", &
- "/solver_info", group_size_inc)
- call define_adios_string (adios_group, "conf_flags", "/solver_info", &
- conf_flags_len, group_size_inc)
-end subroutine define_solver_info_variables
-
-!> \brief Define ADIOS variable to store values from the Par_file
-!! \param adios_group The ADIOS entity grouping variables for data transferts
-!! \param group_size_inc The group size to increment wrt. the variable size
-!! \param model_length The number of character of the MODEL string.
-!! Usefull for reading back the MODEL
-subroutine define_par_file_variables (adios_group, group_size_inc, model_length)
- implicit none
- ! Parameters
- integer(kind=8), intent(in) :: adios_group
- integer(kind=8), intent(inout) :: group_size_inc
- integer, intent(in) :: model_length ! for later reading of MODEL
-
- !-- double precision variables
- call define_adios_double_scalar (adios_group, "ANGULAR_WIDTH_XI_IN_DEGREES", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "ANGULAR_WIDTH_ETA_IN_DEGREES", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "CENTER_LONGITUDE_IN_DEGREES", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "CENTER_LATITUDE_IN_DEGREES", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "GAMMA_ROTATION_AZIMUTH", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "HDUR_MOVIE", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "MOVIE_TOP_KM", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "MOVIE_BOTTOM_KM", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "MOVIE_EAST_DEG", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "MOVIE_WEST_DEG", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "MOVIE_NORTH_DEG", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "MOVIE_SOUTH_DEG", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_double_scalar (adios_group, "RECORD_LENGTH_IN_MINUTES", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- !-- integer variables
- call define_adios_integer_scalar (adios_group, "NTSTEP_BETWEEN_OUTPUT_SEISMOS", &
- "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NTSTEP_BETWEEN_READ_ADJSRC", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NTSTEP_BETWEEN_FRAMES", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NTSTEP_BETWEEN_OUTPUT_INFO", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NUMBER_OF_RUNS", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NUMBER_OF_THIS_RUN", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NCHUNKS", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "SIMULATION_TYPE", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "MOVIE_VOLUME_TYPE", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "MOVIE_START", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "MOVIE_STOP", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NEX_XI", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NEX_ETA", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NPROC_XI", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NPROC_ETA", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_integer_scalar (adios_group, "NOISE_TOMOGRAPHY", "/specfem3D_globe_parameter_file", group_size_inc)
- !-- logical variables
- call define_adios_byte_scalar (adios_group, "ELLIPTICITY", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "GRAVITY", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "ROTATION", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "TOPOGRAPHY", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "OCEANS", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "MOVIE_SURFACE", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "MOVIE_VOLUME", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "MOVIE_COARSE", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "RECEIVERS_CAN_BE_BURIED", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "PRINT_SOURCE_TIME_FUNCTION", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "SAVE_MESH_FILES", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "ATTENUATION", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "ATTENUATION_NEW", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "ABSORBING_CONDITIONS", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "SAVE_FORWARD", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "OUTPUT_SEISMOS_ASCII_TEXT", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "OUTPUT_SEISMOS_SAC_ALPHANUM", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "OUTPUT_SEISMOS_SAC_BINARY", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "ROTATE_SEISMOGRAMS_RT", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "WRITE_SEISMOGRAMS_BY_MASTER", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "SAVE_ALL_SEISMOS_IN_ONE_FILE", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_byte_scalar (adios_group, "USE_BINARY_FOR_LARGE_FILE", "/specfem3D_globe_parameter_file", group_size_inc)
- !-- string variables
- call define_adios_integer_scalar (adios_group, "model_length", "/specfem3D_globe_parameter_file", group_size_inc)
- call define_adios_string (adios_group, "MODEL", "/specfem3D_globe_parameter_file", model_length, group_size_inc)
-end subroutine define_par_file_variables
-
-
-!> \brief Define ADIOS variable to store values from the CMTSOLUTION file
-!! \param adios_group The ADIOS entity grouping variables for data transferts
-!! \param group_size_inc The group size to increment wrt. the variable size
-!! \param NSOURCES The number of sources. Needed to define array sizes.
-!! \param datasource_length The number of character of the datasource string.
-!! Usefull for reading back the datasources.
-subroutine define_cmtsolution_variables (adios_group, group_size_inc, NSOURCES,&
- event_name_length, datasource_length)
- implicit none
- integer(kind=8), intent(in) :: adios_group
- integer(kind=8), intent(inout) :: group_size_inc
- integer, intent(in) :: NSOURCES, datasource_length, event_name_length
-
- !-- Number of SOURCES inside the CMTSOLUTION file
- call define_adios_integer_scalar (adios_group, "NSOURCES", "/CMTSOLUTION", group_size_inc)
- !-- double precision arrays
- call define_adios_double_local_array1D (adios_group, "second", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "time_shift", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "half_duration", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "latitude", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "longitude", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "depth", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "mrr", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "mtt", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "mpp", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "mrt", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "mrp", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "mtp", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- !-- integer arrays
- call define_adios_integer_local_array1D (adios_group, "year", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_integer_local_array1D (adios_group, "month", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_integer_local_array1D (adios_group, "day", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_integer_local_array1D (adios_group, "hour", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- call define_adios_integer_local_array1D (adios_group, "minute", "/CMTSOLUTION", NSOURCES, "NSOURCES", group_size_inc)
- !-- string
- call define_adios_integer_scalar (adios_group, "event_name_length", "/CMTSOLUTION", group_size_inc)
- call define_adios_string (adios_group, "event_name", "/CMTSOLUTION", event_name_length, group_size_inc)
- call define_adios_integer_scalar (adios_group, "datasource_length", "/CMTSOLUTION", group_size_inc)
- call define_adios_string (adios_group, "datasource", "/CMTSOLUTION", datasource_length, group_size_inc)
-end subroutine define_cmtsolution_variables
-
-!> \brief Define ADIOS variable to store values from the STATIONS file
-!! \param adios_group The ADIOS entity grouping variables for data transferts
-!! \param group_size_inc The group size to increment wrt. the variable size
-!! \param NSTATIONS The number of stations. Needed to define array sizes.
-!! \param station_name_length The number of character of the station_name
-!! string. Usefull for reading back the stations.
-!! \param network_name_length The number of character of the station_name
-!! string. Usefull for reading back the networks.
-subroutine define_stations_variables (adios_group, group_size_inc, NSTATIONS,&
- station_name_length, network_name_length)
- implicit none
- integer(kind=8), intent(in) :: adios_group
- integer(kind=8), intent(inout) :: group_size_inc
- integer, intent(in) :: NSTATIONS, station_name_length, network_name_length
-
- !-- Number of STATIONS inside the STATIONS file
- call define_adios_integer_scalar (adios_group, "NSTATIONS", "/STATIONS", group_size_inc)
- !-- double precision arrays
- call define_adios_double_local_array1D (adios_group, "station_latitude", "/STATIONS", NSTATIONS, "NSTATIONS", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "station_longitude", "/STATIONS", NSTATIONS, "NSTATIONS", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "station_elevation", "/STATIONS", NSTATIONS, "NSTATIONS", group_size_inc)
- call define_adios_double_local_array1D (adios_group, "station_burial", "/STATIONS", NSTATIONS, "NSTATIONS", group_size_inc)
- !-- string
- call define_adios_integer_scalar (adios_group, "station_name_length", "/STATIONS", group_size_inc)
- call define_adios_integer_scalar (adios_group, "network_name_length", "/STATIONS", group_size_inc)
- call define_adios_string (adios_group, "station_name", "/STATIONS", station_name_length, group_size_inc)
- call define_adios_string (adios_group, "network_name", "/STATIONS", network_name_length, group_size_inc)
-end subroutine define_stations_variables
-
-!> \brief Read the 'CMTSOLUTION file' and do not modify nor transform variables
-!! \param yr Array to store the year of the events
-!! \param mo Array to store the month of the events
-!! \param da Array to store the day of the events
-!! \param ho Array to store the hour of the events
-!! \param mi Array to store the minute of the events
-!! \param sec Array to store the second of the events
-!! \param t_shift Array to store the time shift at the beginning of the events
-!! \param hdur Array to store the duration of the events
-!! \param lat Array to store the latitude of the events
-!! \param long Array to store the longitude of the events
-!! \param depth Arrays to store the depth of the events
-!! \param mrr Arrays to store the mrr component of the events
-!! \param mtt Arrays to store the mtt component of the events
-!! \param mpp Arrays to store the mpp component of the events
-!! \param mrt Arrays to store the mrt component of the events
-!! \param mrp Arrays to store the mrp component of the events
-!! \param mtp Arrays to store the mtp component of the events
-!! \param event_name_length Variable for keeping the size of the event_name
-!! string
-!! \param event_name Strings to store the event name
-!! \param datasource_length Variable for keeping the size of the datasource
-!! string
-!! \param datasource String in which the different datasource names are
-!! concatenated
-!> \note This subroutine and get_cmt.f90 are redundant. Might be factorized in
-!! the future. For now we do not want the value modification from get_cmt
-subroutine read_raw_cmtsolution (yr, mo, da, ho, mi, sec, t_shift, hdur, lat, &
- long, depth, mrr, mtt, mpp, mrt, mrp, mtp, event_name_length, event_name, &
- datasource_length, datasource)
- implicit none
- ! Parameters
- integer, dimension(NSOURCES), intent(out) :: yr, mo, da, ho, mi
- double precision, dimension(NSOURCES), intent(out) :: sec, t_shift, hdur, lat, long, depth
- double precision, dimension(NSOURCES), intent(out) :: mrr, mtt, mpp, mrt, mrp, mtp
- integer, intent(inout) :: event_name_length, datasource_length
- character(len=16), intent(out) :: event_name
- character(len=:), allocatable, intent(out) :: datasource ! F03 feature
- ! Local variables
- character(len=5) :: datasource_tmp
- character(len=256) :: CMTSOLUTION, string
- ! extract all unmodified values from CMTSOLUTION
- ! get_cmt() routine modify the read values
- ! TODO factorize what follows and get_cmt.f90 and probably one or two other
- ! routines
- call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
- open(unit=1,file=CMTSOLUTION,status='old',action='read')
- datasource_length = 4*NSOURCES ! a datasource is 4 character, by convention
- allocate(character(len=(datasource_length)) :: datasource, stat=ier)
- if (ier /=0) &
- call exit_MPI (myrank, &
- "error allocating datasource string for adios header")
- datasource = ""
- ! ADIOS only (1) byte for a string. This may cause data overwriting.
- ! => increase the generate by the string size -1
- adios_groupsize = adios_groupsize + 4*NSOURCES - 1
- do isource=1,NSOURCES
-
- read(1,"(a256)") string
- ! skips empty lines
- do while( len_trim(string) == 0 )
- read(1,"(a256)") string
- enddo
- ! read header with event information
- read(string,"(a4,i5,i3,i3,i3,i3,f6.2)") datasource_tmp,yr(isource), &
- mo(isource),da(isource),ho(isource),mi(isource),sec(isource)
- datasource = datasource // datasource_tmp
- ! read event name
- read(1,"(a)") string
- read(string(12:len_trim(string)),*) event_name
- ! read time shift
- read(1,"(a)") string
- read(string(12:len_trim(string)),*) t_shift(isource)
- ! read half duration
- read(1,"(a)") string
- read(string(15:len_trim(string)),*) hdur(isource)
- ! read latitude
- read(1,"(a)") string
- read(string(10:len_trim(string)),*) lat(isource)
- ! read longitude
- read(1,"(a)") string
- read(string(11:len_trim(string)),*) long(isource)
- ! read depth
- read(1,"(a)") string
- read(string(7:len_trim(string)),*) depth(isource)
- ! read Mrr
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) mrr(isource)
- ! read Mtt
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) mtt(isource)
- ! read Mpp
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) mpp(isource)
- ! read Mrt
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) mrt(isource)
- ! read Mrp
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) mrp(isource)
- ! read Mtp
- read(1,"(a)") string
- read(string(5:len_trim(string)),*) mtp(isource)
- enddo
- close(1)
- event_name_length = len_trim(event_name)
-end subroutine read_raw_cmtsolution
-
-!> \brief Reads information form the 'STATIONS' file without modifying anything
-!! \param NSTATIONS How many stations are used
-!! \param stlat Array to store the latitude of the stations
-!! \param stlon Array to store the longitude of the stations
-!! \param stele Array to store the elevation of the stations
-!! \param stbur Array to store the burial of the statisons
-!! \param station_name_length Variable to keep the length of the station_name
-!! string
-!! \param station_name String in which the different station names are
-!! concatenated
-!! \param network_name_length Variable to keep the length of the network_name
-!! string
-!! \param network_name String in which the different network names are
-!! concatenated
-subroutine read_raw_stations (NSTATIONS, stlat, stlon, stele, stbur, &
- station_name_length, station_name, network_name_length, network_name)
- implicit none
- ! Parameters
- integer :: NSTATIONS
- integer, intent(inout) :: station_name_length, network_name_length ! for later reading
- character(len=:), allocatable, intent(out) :: station_name, network_name
- double precision, allocatable, dimension(:), intent(out) :: stlat, stlon, stele, stbur
- ! Local variables
- character(len=MAX_LENGTH_STATION_NAME) :: station_name_tmp
- character(len=MAX_LENGTH_NETWORK_NAME) :: network_name_tmp
- character(len=256) :: STATIONS, string
-
- ! Extract values from STATIONS File
- call get_value_string(STATIONS, 'solver.STATIONS', 'DATA/STATIONS')
- open(unit=1,file=STATIONS,iostat=ier,status='old',action='read')
- NSTATIONS = 0
- do while(ier == 0)
- read(1,"(a)",iostat=ier) string
- if(ier == 0) NSTATIONS = NSTATIONS + 1
- enddo
- allocate (character (len=(MAX_LENGTH_STATION_NAME*NSTATIONS)) :: station_name)
- allocate (character (len=(MAX_LENGTH_NETWORK_NAME*NSTATIONS)) :: network_name)
- allocate (stlat (NSTATIONS))
- allocate (stlon (NSTATIONS))
- allocate (stele (NSTATIONS))
- allocate (stbur (NSTATIONS))
- station_name = ""
- network_name = ""
- rewind(1)
- do irec = 1,NSTATIONS
- read(1,*,iostat=ier) station_name_tmp, network_name_tmp, &
- stlat(irec), stlon(irec), &
- stele(irec), stbur(irec)
- if( ier /= 0 ) then
- write(IMAIN,*) 'error reading in station ',irec
- call exit_MPI(myrank,'error reading in station in STATIONS file')
- endif
- station_name = station_name // trim(station_name_tmp) // " "
- network_name = network_name // trim(network_name_tmp) // " "
- enddo
- close(1)
- station_name = trim(station_name)
- network_name = trim(network_name)
- station_name_length = len(station_name)
- network_name_length = len(network_name)
-end subroutine read_raw_stations
-
-!> \brief Wrapper to write the 'config.h' variables into the adios header
-!! \param adios_handle The handle to the file where the variable should be
-!! written
-subroutine write_adios_solver_info_variables (adios_handle)
- implicit none
- ! Parameters
- integer(kind=8), intent(in) :: adios_handle
- ! Variables
- integer :: pkg_str_len, conf_flags_len, adios_err
- character(len=:), allocatable :: pkg_str
- character(len=:), allocatable :: conf_flags
-
- pkg_str = trim(PACKAGE_STRING)
- conf_flags = trim(CONFIGURE_FLAGS)
-
- pkg_str_len = len_trim(PACKAGE_STRING)
- conf_flags_len = len_trim(CONFIGURE_FLAGS)
- call adios_write (adios_handle, "package_string_length", pkg_str_len, adios_err)
- call adios_write (adios_handle, "package_name", pkg_str, adios_err)
- call adios_write (adios_handle, "conf_flags_len", conf_flags_len, adios_err)
- call adios_write (adios_handle, "conf_flags", conf_flags, adios_err)
-end subroutine write_adios_solver_info_variables
-
-!> \brief Wrapper to write the 'Par_file' variables into the adios header
-!! \param adios_handle The handle to the file where the variable should be
-!! written
-subroutine write_adios_par_file_variables (adios_handle, &
- ANGULAR_WIDTH_XI_IN_DEGREES, ANGULAR_WIDTH_ETA_IN_DEGREES, &
- CENTER_LONGITUDE_IN_DEGREES, CENTER_LATITUDE_IN_DEGREES, &
- GAMMA_ROTATION_AZIMUTH, HDUR_MOVIE, MOVIE_TOP_KM, MOVIE_BOTTOM_KM, &
- MOVIE_EAST_DEG, MOVIE_WEST_DEG, MOVIE_NORTH_DEG, MOVIE_SOUTH_DEG, &
- RECORD_LENGTH_IN_MINUTES, NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC, NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO, NUMBER_OF_RUNS, NUMBER_OF_THIS_RUN, NCHUNKS, &
- SIMULATION_TYPE, MOVIE_VOLUME_TYPE, MOVIE_START, MOVIE_STOP, NEX_XI, &
- NEX_ETA, NPROC_XI, NPROC_ETA, NOISE_TOMOGRAPHY, ELLIPTICITY, GRAVITY, &
- ROTATION, TOPOGRAPHY, OCEANS, MOVIE_SURFACE, MOVIE_VOLUME, MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED, PRINT_SOURCE_TIME_FUNCTION, SAVE_MESH_FILES, &
- ATTENUATION, ATTENUATION_NEW, ABSORBING_CONDITIONS, SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT, OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY, ROTATE_SEISMOGRAMS_RT, &
- WRITE_SEISMOGRAMS_BY_MASTER, SAVE_ALL_SEISMOS_IN_ONE_FILE, &
- USE_BINARY_FOR_LARGE_FILE, model_length, MODEL)
- implicit none
- ! Parameters
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC, NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, NUMBER_OF_THIS_RUN,NCHUNKS, &
- SIMULATION_TYPE, MOVIE_VOLUME_TYPE, MOVIE_START,MOVIE_STOP, NEX_XI, &
- NEX_ETA,NPROC_XI,NPROC_ETA, NOISE_TOMOGRAPHY
- double precision, intent(in) :: ANGULAR_WIDTH_XI_IN_DEGREES, &
- ANGULAR_WIDTH_ETA_IN_DEGREES, CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES, GAMMA_ROTATION_AZIMUTH, HDUR_MOVIE, &
- MOVIE_TOP_KM,MOVIE_BOTTOM_KM, MOVIE_EAST_DEG,MOVIE_WEST_DEG, &
- MOVIE_NORTH_DEG,MOVIE_SOUTH_DEG, RECORD_LENGTH_IN_MINUTES
- logical, intent(in) :: ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
- MOVIE_SURFACE, MOVIE_VOLUME,MOVIE_COARSE, RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION, SAVE_MESH_FILES,ATTENUATION,ATTENUATION_NEW, &
- ABSORBING_CONDITIONS,SAVE_FORWARD, OUTPUT_SEISMOS_ASCII_TEXT, &
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
- integer, intent(in) :: model_length
- character(len=*), intent(in) :: MODEL
- ! Local variables
- integer :: adios_err
-
- call adios_write (adios_handle, "ANGULAR_WIDTH_XI_IN_DEGREES", ANGULAR_WIDTH_XI_IN_DEGREES, adios_err)
- call adios_write (adios_handle, "ANGULAR_WIDTH_ETA_IN_DEGREES", ANGULAR_WIDTH_ETA_IN_DEGREES, adios_err)
- call adios_write (adios_handle, "CENTER_LONGITUDE_IN_DEGREES", CENTER_LONGITUDE_IN_DEGREES, adios_err)
- call adios_write (adios_handle, "CENTER_LATITUDE_IN_DEGREES", CENTER_LATITUDE_IN_DEGREES, adios_err)
- call adios_write (adios_handle, "GAMMA_ROTATION_AZIMUTH", GAMMA_ROTATION_AZIMUTH, adios_err)
- call adios_write (adios_handle, "HDUR_MOVIE", HDUR_MOVIE, adios_err)
- call adios_write (adios_handle, "MOVIE_TOP_KM", MOVIE_TOP_KM, adios_err)
- call adios_write (adios_handle, "MOVIE_BOTTOM_KM", MOVIE_BOTTOM_KM, adios_err)
- call adios_write (adios_handle, "MOVIE_EAST_DEG", MOVIE_EAST_DEG, adios_err)
- call adios_write (adios_handle, "MOVIE_WEST_DEG", MOVIE_WEST_DEG, adios_err)
- call adios_write (adios_handle, "MOVIE_NORTH_DEG", MOVIE_NORTH_DEG, adios_err)
- call adios_write (adios_handle, "MOVIE_SOUTH_DEG", MOVIE_SOUTH_DEG, adios_err)
- call adios_write (adios_handle, "RECORD_LENGTH_IN_MINUTES", RECORD_LENGTH_IN_MINUTES, adios_err)
- call adios_write (adios_handle, "NTSTEP_BETWEEN_OUTPUT_SEISMOS", NTSTEP_BETWEEN_OUTPUT_SEISMOS, adios_err)
- call adios_write (adios_handle, "NTSTEP_BETWEEN_READ_ADJSRC", NTSTEP_BETWEEN_READ_ADJSRC, adios_err)
- call adios_write (adios_handle, "NTSTEP_BETWEEN_FRAMES", NTSTEP_BETWEEN_FRAMES, adios_err)
- call adios_write (adios_handle, "NTSTEP_BETWEEN_OUTPUT_INFO", NTSTEP_BETWEEN_OUTPUT_INFO, adios_err)
- call adios_write (adios_handle, "NUMBER_OF_RUNS", NUMBER_OF_RUNS, adios_err)
- call adios_write (adios_handle, "NUMBER_OF_THIS_RUN", NUMBER_OF_THIS_RUN, adios_err)
- call adios_write (adios_handle, "NCHUNKS", NCHUNKS, adios_err)
- call adios_write (adios_handle, "SIMULATION_TYPE", SIMULATION_TYPE, adios_err)
- call adios_write (adios_handle, "MOVIE_VOLUME_TYPE", MOVIE_VOLUME_TYPE, adios_err)
- call adios_write (adios_handle, "MOVIE_START", MOVIE_START, adios_err)
- call adios_write (adios_handle, "MOVIE_STOP", MOVIE_STOP, adios_err)
- call adios_write (adios_handle, "NEX_XI", NEX_XI, adios_err)
- call adios_write (adios_handle, "NEX_ETA", NEX_ETA, adios_err)
- call adios_write (adios_handle, "NPROC_XI", NPROC_XI, adios_err)
- call adios_write (adios_handle, "NPROC_ETA", NPROC_ETA, adios_err)
- call adios_write (adios_handle, "NOISE_TOMOGRAPHY", NOISE_TOMOGRAPHY, adios_err)
- call adios_write (adios_handle, "ELLIPTICITY", ELLIPTICITY, adios_err)
- call adios_write (adios_handle, "GRAVITY", GRAVITY, adios_err)
- call adios_write (adios_handle, "ROTATION", ROTATION, adios_err)
- call adios_write (adios_handle, "TOPOGRAPHY", TOPOGRAPHY, adios_err)
- call adios_write (adios_handle, "OCEANS", OCEANS, adios_err)
- call adios_write (adios_handle, "MOVIE_SURFACE", MOVIE_SURFACE, adios_err)
- call adios_write (adios_handle, "MOVIE_VOLUME", MOVIE_VOLUME, adios_err)
- call adios_write (adios_handle, "MOVIE_COARSE", MOVIE_COARSE, adios_err)
- call adios_write (adios_handle, "RECEIVERS_CAN_BE_BURIED", RECEIVERS_CAN_BE_BURIED, adios_err)
- call adios_write (adios_handle, "PRINT_SOURCE_TIME_FUNCTION", PRINT_SOURCE_TIME_FUNCTION, adios_err)
- call adios_write (adios_handle, "SAVE_MESH_FILES", SAVE_MESH_FILES, adios_err)
- call adios_write (adios_handle, "ATTENUATION", ATTENUATION, adios_err)
- call adios_write (adios_handle, "ATTENUATION_NEW", ATTENUATION_NEW, adios_err)
- call adios_write (adios_handle, "ABSORBING_CONDITIONS", ABSORBING_CONDITIONS, adios_err)
- call adios_write (adios_handle, "SAVE_FORWARD", SAVE_FORWARD, adios_err)
- call adios_write (adios_handle, "OUTPUT_SEISMOS_ASCII_TEXT", OUTPUT_SEISMOS_ASCII_TEXT, adios_err)
- call adios_write (adios_handle, "OUTPUT_SEISMOS_SAC_ALPHANUM", OUTPUT_SEISMOS_SAC_ALPHANUM, adios_err)
- call adios_write (adios_handle, "OUTPUT_SEISMOS_SAC_BINARY", OUTPUT_SEISMOS_SAC_BINARY, adios_err)
- call adios_write (adios_handle, "ROTATE_SEISMOGRAMS_RT", ROTATE_SEISMOGRAMS_RT, adios_err)
- call adios_write (adios_handle, "WRITE_SEISMOGRAMS_BY_MASTER", WRITE_SEISMOGRAMS_BY_MASTER, adios_err)
- call adios_write (adios_handle, "SAVE_ALL_SEISMOS_IN_ONE_FILE", SAVE_ALL_SEISMOS_IN_ONE_FILE, adios_err)
- call adios_write (adios_handle, "USE_BINARY_FOR_LARGE_FILE", USE_BINARY_FOR_LARGE_FILE, adios_err)
- call adios_write (adios_handle, "model_length", model_length, adios_err)
- call adios_write (adios_handle, "MODEL", MODEL, adios_err)
-end subroutine write_adios_par_file_variables
-
-!> \brief Wrapper to write the 'CMTSOLUTION' variables into the adios header
-!! \param adios_handle The handle to the file where the variable should be
-!! written
-subroutine write_adios_cmtsolution_variables (adios_handle, &
- NSOURCES, yr, mo, da, ho, mi, sec, t_shift, hdur, lat, long, depth, &
- mrr, mtt, mpp, mrt, mrp, mtp, event_name_length, event_name, &
- datasource_length, datasource)
- implicit none
- ! Parameters
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in) :: NSOURCES
- integer, dimension(NSOURCES), intent(in) :: yr, mo, da, ho, mi
- double precision, dimension(NSOURCES), intent(in) :: sec, t_shift, hdur, &
- lat, long, depth
- double precision, dimension(NSOURCES), intent(in) :: mrr, mtt, mpp, &
- mrt, mrp, mtp
- integer, intent(in) :: event_name_length, datasource_length
- character(len=16), intent(in) :: event_name
- character(len=:), allocatable, intent(in) :: datasource ! F03 feature
- ! Local variables
- integer :: adios_err
-
- call adios_write (adios_handle, "NSOURCES", NSOURCES, adios_err)
- call adios_write (adios_handle, "year", yr, adios_err)
- call adios_write (adios_handle, "month", mo, adios_err)
- call adios_write (adios_handle, "day", da, adios_err)
- call adios_write (adios_handle, "hour", ho, adios_err)
- call adios_write (adios_handle, "minute", mi, adios_err)
- call adios_write (adios_handle, "second", sec, adios_err)
- call adios_write (adios_handle, "time_shift", t_shift, adios_err)
- call adios_write (adios_handle, "half_duration", hdur, adios_err)
- call adios_write (adios_handle, "latitude", lat, adios_err)
- call adios_write (adios_handle, "longitude", long, adios_err)
- call adios_write (adios_handle, "depth", depth, adios_err)
- call adios_write (adios_handle, "mrr", mrr, adios_err)
- call adios_write (adios_handle, "mtt", mtt, adios_err)
- call adios_write (adios_handle, "mpp", mpp, adios_err)
- call adios_write (adios_handle, "mrt", mrt, adios_err)
- call adios_write (adios_handle, "mrp", mrp, adios_err)
- call adios_write (adios_handle, "mtp", mtp, adios_err)
- call adios_write (adios_handle, "event_name_length", event_name_length, adios_err)
- call adios_write (adios_handle, "event_name", event_name, adios_err)
- call adios_write (adios_handle, "datasource_length", datasource_length, adios_err)
- call adios_write (adios_handle, "datasource", datasource, adios_err)
-end subroutine write_adios_cmtsolution_variables
-
-!> \brief Wrapper to write the 'STATIONS' variables into the adios header
-!! \param adios_handle The handle to the file where the variable should be
-!! written
-subroutine write_adios_stations_variables (adios_handle, &
- NSTATIONS, stlat, stlon, stele, stbur, station_name_length, station_name, &
- network_name_length, network_name)
- implicit none
- ! Parameters
- integer(kind=8), intent(in) :: adios_handle
- integer, intent(in):: NSTATIONS
- integer, intent(in):: station_name_length, network_name_length ! for later reading
- character(len=:), allocatable, intent(in) :: station_name, network_name
- double precision, allocatable, dimension(:), intent(in) :: stlat, stlon, &
- stele, stbur
- ! Local variables
- integer :: adios_err
-
- call adios_write (adios_handle, "NSTATIONS", NSTATIONS, adios_err)
- call adios_write (adios_handle, "station_latitude", stlat, adios_err)
- call adios_write (adios_handle, "station_longitude", stlon, adios_err)
- call adios_write (adios_handle, "station_elevation", stele, adios_err)
- call adios_write (adios_handle, "station_burial", stbur, adios_err)
- call adios_write (adios_handle, "station_name_length", station_name_length, adios_err)
- call adios_write (adios_handle, "network_name_length", network_name_length, adios_err)
- call adios_write (adios_handle, "station_name", station_name, adios_err)
- call adios_write (adios_handle, "network_name", network_name, adios_err)
-end subroutine write_adios_stations_variables
-
-
-end subroutine write_specfem_header_adios
More information about the CIG-COMMITS
mailing list