[cig-commits] r22769 - in seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src: cuda meshfem3D shared specfem3D
danielpeter at geodynamics.org
danielpeter at geodynamics.org
Wed Sep 4 06:17:07 PDT 2013
Author: danielpeter
Date: 2013-09-04 06:17:07 -0700 (Wed, 04 Sep 2013)
New Revision: 22769
Added:
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element_att_memory.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time_undoatt.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/update_displacement_LDDRK.f90
Removed:
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/create_central_cube_buffers.f90
Modified:
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/compute_kernels_cuda.cu
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/it_update_displacement_cuda.cu
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/mesh_constants_cuda.h
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/prepare_mesh_constants_cuda.cu
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver_adios.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/get_timestep_and_layers.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/memory_eval.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/read_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/read_parameter_file.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/save_header_file.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_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_element_strain.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_acoustic_calling_routine.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_crust_mantle_noDev.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_inner_core_noDev.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_forces_outer_core_noDev.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_viscoelastic_calling_routine.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_seismograms.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_stacey_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_stacey_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/finalize_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_sources.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_arrays_solver_adios.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/rules.mk
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/save_forward_arrays.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/update_displacement_Newmark.f90
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_seismograms.f90
Log:
adds LDDRK time scheme routines; adds files compute_element_att_memory.F90, update_displacement_LDDRK.f90, iterate_time_undoatt.F90 and deletes create_central_cube_buffers.f90 in solver
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/compute_kernels_cuda.cu
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/compute_kernels_cuda.cu 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/compute_kernels_cuda.cu 2013-09-04 13:17:07 UTC (rev 22769)
@@ -247,6 +247,11 @@
mp->NSPEC_CRUST_MANTLE,
deltat);
+ // checks if strain is available
+ if( mp->undo_attenuation ){
+ exit_on_error("compute_kernels_cm_cuda not implemented yet for UNDO_ATTENUATION");
+ }
+
if(! mp->anisotropic_kl){
// isotropic kernels
compute_kernels_iso_cudakernel<<<grid,threads>>>(mp->d_epsilondev_xx_crust_mantle,
@@ -323,6 +328,12 @@
mp->d_rho_kl_inner_core,
mp->NSPEC_INNER_CORE,
deltat);
+
+ // checks if strain is available
+ if( mp->undo_attenuation ){
+ exit_on_error("compute_kernels_ic_cuda not implemented yet for UNDO_ATTENUATION");
+ }
+
// isotropic kernels (shear, bulk)
compute_kernels_iso_cudakernel<<<grid,threads>>>(mp->d_epsilondev_xx_inner_core,
mp->d_epsilondev_yy_inner_core,
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/it_update_displacement_cuda.cu
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/it_update_displacement_cuda.cu 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/it_update_displacement_cuda.cu 2013-09-04 13:17:07 UTC (rev 22769)
@@ -518,18 +518,18 @@
mp->NGLOB_INNER_CORE,
deltatover2,
mp->two_omega_earth,
- mp->d_rmass_inner_core,
- mp->d_rmass_inner_core,
- mp->d_rmass_inner_core);
+ mp->d_rmassx_inner_core,
+ mp->d_rmassy_inner_core,
+ mp->d_rmassz_inner_core);
}else if( *FORWARD_OR_ADJOINT == 3 ){
kernel_3_cuda_device<<< grid, threads>>>(mp->d_b_veloc_inner_core,
mp->d_b_accel_inner_core,
mp->NGLOB_INNER_CORE,
deltatover2,
mp->b_two_omega_earth,
- mp->d_rmass_inner_core,
- mp->d_rmass_inner_core,
- mp->d_rmass_inner_core);
+ mp->d_rmassx_inner_core,
+ mp->d_rmassy_inner_core,
+ mp->d_rmassz_inner_core);
}
#ifdef ENABLE_VERY_SLOW_ERROR_CHECKING
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/mesh_constants_cuda.h
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/mesh_constants_cuda.h 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/mesh_constants_cuda.h 2013-09-04 13:17:07 UTC (rev 22769)
@@ -411,7 +411,9 @@
// model parameters
realw* d_rhostore_inner_core;
realw* d_kappavstore_inner_core; realw* d_muvstore_inner_core;
- realw* d_rmass_inner_core;
+ realw* d_rmassx_inner_core;
+ realw* d_rmassy_inner_core;
+ realw* d_rmassz_inner_core;
// global indexing
int* d_ibool_inner_core;
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/prepare_mesh_constants_cuda.cu
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/prepare_mesh_constants_cuda.cu 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/prepare_mesh_constants_cuda.cu 2013-09-04 13:17:07 UTC (rev 22769)
@@ -627,13 +627,24 @@
// backward/reconstructed fields
if( mp->simulation_type == 3 ){
- copy_todevice_realw((void**)&mp->d_b_epsilondev_xx_crust_mantle,b_epsilondev_xx_crust_mantle,R_size);
- copy_todevice_realw((void**)&mp->d_b_epsilondev_yy_crust_mantle,b_epsilondev_yy_crust_mantle,R_size);
- copy_todevice_realw((void**)&mp->d_b_epsilondev_xy_crust_mantle,b_epsilondev_xy_crust_mantle,R_size);
- copy_todevice_realw((void**)&mp->d_b_epsilondev_xz_crust_mantle,b_epsilondev_xz_crust_mantle,R_size);
- copy_todevice_realw((void**)&mp->d_b_epsilondev_yz_crust_mantle,b_epsilondev_yz_crust_mantle,R_size);
- //strain
- copy_todevice_realw((void**)&mp->d_b_eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle,R_size);
+ if( mp->undo_attenuation ){
+ // strain will be computed locally based on displacement wavefield
+ // only uses pointers to already allocated arrays
+ mp->d_b_epsilondev_xx_crust_mantle = mp->d_epsilondev_xx_crust_mantle;
+ mp->d_b_epsilondev_yy_crust_mantle = mp->d_epsilondev_yy_crust_mantle;
+ mp->d_b_epsilondev_xy_crust_mantle = mp->d_epsilondev_xy_crust_mantle;
+ mp->d_b_epsilondev_xz_crust_mantle = mp->d_epsilondev_xz_crust_mantle;
+ mp->d_b_epsilondev_yz_crust_mantle = mp->d_epsilondev_yz_crust_mantle;
+ mp->d_b_eps_trace_over_3_crust_mantle = mp->d_eps_trace_over_3_crust_mantle;
+ }else{
+ copy_todevice_realw((void**)&mp->d_b_epsilondev_xx_crust_mantle,b_epsilondev_xx_crust_mantle,R_size);
+ copy_todevice_realw((void**)&mp->d_b_epsilondev_yy_crust_mantle,b_epsilondev_yy_crust_mantle,R_size);
+ copy_todevice_realw((void**)&mp->d_b_epsilondev_xy_crust_mantle,b_epsilondev_xy_crust_mantle,R_size);
+ copy_todevice_realw((void**)&mp->d_b_epsilondev_xz_crust_mantle,b_epsilondev_xz_crust_mantle,R_size);
+ copy_todevice_realw((void**)&mp->d_b_epsilondev_yz_crust_mantle,b_epsilondev_yz_crust_mantle,R_size);
+ //strain
+ copy_todevice_realw((void**)&mp->d_b_eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle,R_size);
+ }
}
// inner_core
@@ -650,13 +661,24 @@
// backward/reconstructed fields
if( mp->simulation_type == 3 ){
- copy_todevice_realw((void**)&mp->d_b_epsilondev_xx_inner_core,b_epsilondev_xx_inner_core,R_size);
- copy_todevice_realw((void**)&mp->d_b_epsilondev_yy_inner_core,b_epsilondev_yy_inner_core,R_size);
- copy_todevice_realw((void**)&mp->d_b_epsilondev_xy_inner_core,b_epsilondev_xy_inner_core,R_size);
- copy_todevice_realw((void**)&mp->d_b_epsilondev_xz_inner_core,b_epsilondev_xz_inner_core,R_size);
- copy_todevice_realw((void**)&mp->d_b_epsilondev_yz_inner_core,b_epsilondev_yz_inner_core,R_size);
- // strain
- copy_todevice_realw((void**)&mp->d_b_eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core,R_size);
+ if( mp->undo_attenuation ){
+ // strain will be computed locally based on displacement wavefield
+ // only uses pointers to already allocated arrays
+ mp->d_b_epsilondev_xx_inner_core = mp->d_epsilondev_xx_inner_core;
+ mp->d_b_epsilondev_yy_inner_core = mp->d_epsilondev_yy_inner_core;
+ mp->d_b_epsilondev_xy_inner_core = mp->d_epsilondev_xy_inner_core;
+ mp->d_b_epsilondev_xz_inner_core = mp->d_epsilondev_xz_inner_core;
+ mp->d_b_epsilondev_yz_inner_core = mp->d_epsilondev_yz_inner_core;
+ mp->d_b_eps_trace_over_3_inner_core = mp->d_eps_trace_over_3_inner_core;
+ }else{
+ copy_todevice_realw((void**)&mp->d_b_epsilondev_xx_inner_core,b_epsilondev_xx_inner_core,R_size);
+ copy_todevice_realw((void**)&mp->d_b_epsilondev_yy_inner_core,b_epsilondev_yy_inner_core,R_size);
+ copy_todevice_realw((void**)&mp->d_b_epsilondev_xy_inner_core,b_epsilondev_xy_inner_core,R_size);
+ copy_todevice_realw((void**)&mp->d_b_epsilondev_xz_inner_core,b_epsilondev_xz_inner_core,R_size);
+ copy_todevice_realw((void**)&mp->d_b_epsilondev_yz_inner_core,b_epsilondev_yz_inner_core,R_size);
+ // strain
+ copy_todevice_realw((void**)&mp->d_b_eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core,R_size);
+ }
}
}
@@ -1338,11 +1360,14 @@
// mass matrices
+ copy_todevice_realw((void**)&mp->d_rmassz_crust_mantle,h_rmassz,size_glob);
if( *NCHUNKS_VAL != 6 && mp->absorbing_conditions){
copy_todevice_realw((void**)&mp->d_rmassx_crust_mantle,h_rmassx,size_glob);
copy_todevice_realw((void**)&mp->d_rmassy_crust_mantle,h_rmassy,size_glob);
+ }else{
+ mp->d_rmassx_crust_mantle = mp->d_rmassz_crust_mantle;
+ mp->d_rmassy_crust_mantle = mp->d_rmassz_crust_mantle;
}
- copy_todevice_realw((void**)&mp->d_rmassz_crust_mantle,h_rmassz,size_glob);
// kernels
if( mp->simulation_type == 3 ){
@@ -1589,7 +1614,7 @@
realw* h_etax, realw* h_etay, realw* h_etaz,
realw* h_gammax, realw* h_gammay, realw* h_gammaz,
realw* h_rho, realw* h_kappav, realw* h_muv,
- realw* h_rmass,
+ realw* h_rmassx,realw* h_rmassy,realw* h_rmassz,
int* h_ibool,
realw* h_xstore, realw* h_ystore, realw* h_zstore,
realw *c11store,realw *c12store,realw *c13store,
@@ -1766,7 +1791,9 @@
#endif
// mass matrix
- copy_todevice_realw((void**)&mp->d_rmass_inner_core,h_rmass,size_glob);
+ copy_todevice_realw((void**)&mp->d_rmassx_inner_core,h_rmassx,size_glob);
+ copy_todevice_realw((void**)&mp->d_rmassy_inner_core,h_rmassy,size_glob);
+ copy_todevice_realw((void**)&mp->d_rmassz_inner_core,h_rmassz,size_glob);
// kernels
if( mp->simulation_type == 3 ){
@@ -1915,7 +1942,7 @@
cudaFree(mp->d_eps_trace_over_3_crust_mantle);
cudaFree(mp->d_eps_trace_over_3_inner_core);
- if( mp->simulation_type == 3 ){
+ if( mp->simulation_type == 3 && ! mp->undo_attenuation ){
cudaFree(mp->d_b_epsilondev_xx_crust_mantle);
cudaFree(mp->d_b_epsilondev_yy_crust_mantle);
cudaFree(mp->d_b_epsilondev_xy_crust_mantle);
@@ -2244,7 +2271,9 @@
cudaFree(mp->d_beta_kl_inner_core);
}
// mass matrix
- cudaFree(mp->d_rmass_inner_core);
+ cudaFree(mp->d_rmassx_inner_core);
+ cudaFree(mp->d_rmassy_inner_core);
+ cudaFree(mp->d_rmassz_inner_core);
// oceans
if( mp->oceans ){
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c 2013-09-04 13:17:07 UTC (rev 22769)
@@ -591,7 +591,7 @@
realw* h_etax, realw* h_etay, realw* h_etaz,
realw* h_gammax, realw* h_gammay, realw* h_gammaz,
realw* h_rho, realw* h_kappav, realw* h_muv,
- realw* h_rmass,
+ realw* h_rmassx,realw* h_rmassy,realw* h_rmassz,
int* h_ibool,
realw* h_xstore, realw* h_ystore, realw* h_zstore,
realw *c11store,realw *c12store,realw *c13store,
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -48,7 +48,7 @@
use meshfem3D_par,only: &
NCHUNKS,ABSORBING_CONDITIONS, &
- ROTATION,EXACT_MASS_MATRIX_FOR_ROTATION,USE_LDDRK
+ ROTATION,EXACT_MASS_MATRIX_FOR_ROTATION
use create_regions_mesh_par,only: &
wxgll,wygll,wzgll
@@ -175,28 +175,37 @@
endif
! then make the corrections to the copied mass matrices if needed
- if(ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. .not. USE_LDDRK) then
+ if( ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION ) then
call create_mass_matrices_rotation(myrank,nspec,ibool,idoubling,iregion_code)
endif
! absorbing boundaries
! add C*deltat/2 contribution to the mass matrices on the Stacey edges
- if(NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. .not. USE_LDDRK ) then
- call create_mass_matrices_Stacey(myrank,nspec,ibool,iregion_code, &
- NSPEC2D_BOTTOM)
+ if( NCHUNKS /= 6 .and. ABSORBING_CONDITIONS ) then
+ call create_mass_matrices_Stacey(myrank,nspec,ibool,iregion_code,NSPEC2D_BOTTOM)
endif
! check that mass matrix is positive
- ! note: in fictitious elements it is still zero
- if(minval(rmassz(:)) < 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassz matrix term')
-
- ! check that the additional mass matrices are strictly positive, if they exist
- if(nglob_xy == nglob) then
- if(minval(rmassx) <= 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassx matrix term')
- if(minval(rmassy) <= 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassy matrix term')
-
- if(minval(b_rmassx) <= 0._CUSTOM_REAL) call exit_MPI(myrank,'negative b_rmassx matrix term')
- if(minval(b_rmassy) <= 0._CUSTOM_REAL) call exit_MPI(myrank,'negative b_rmassy matrix term')
+ if( iregion_code == IREGION_INNER_CORE ) then
+ ! note: in fictitious elements mass matrix is still zero
+ if(minval(rmassz(:)) < 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassz matrix term')
+ ! check that the additional mass matrices are positive, if they exist
+ if(nglob_xy == nglob) then
+ if(minval(rmassx) < 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassx matrix term')
+ if(minval(rmassy) < 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassy matrix term')
+ if(minval(b_rmassx) < 0._CUSTOM_REAL) call exit_MPI(myrank,'negative b_rmassx matrix term')
+ if(minval(b_rmassy) < 0._CUSTOM_REAL) call exit_MPI(myrank,'negative b_rmassy matrix term')
+ endif
+ else
+ ! no ficticious elements, mass matrix must be strictly positive
+ if(minval(rmassz(:)) <= 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassz matrix term')
+ ! check that the additional mass matrices are strictly positive, if they exist
+ if(nglob_xy == nglob) then
+ if(minval(rmassx) <= 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassx matrix term')
+ if(minval(rmassy) <= 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassy matrix term')
+ if(minval(b_rmassx) <= 0._CUSTOM_REAL) call exit_MPI(myrank,'negative b_rmassx matrix term')
+ if(minval(b_rmassy) <= 0._CUSTOM_REAL) call exit_MPI(myrank,'negative b_rmassy matrix term')
+ endif
endif
! save ocean load mass matrix as well if oceans
@@ -776,7 +785,7 @@
use constants
use meshfem3D_models_par,only: &
- TOPOGRAPHY,ibathy_topo
+ TOPOGRAPHY,ibathy_topo,CASE_3D
use meshfem3D_par,only: &
RHO_OCEANS
@@ -807,6 +816,25 @@
integer :: ispec,i,j,k,iglob,ispec2D
+ logical :: do_ocean_load
+
+ ! initializes
+ do_ocean_load = .false.
+
+ ! note: old version (5.1.5)
+ ! only for models where 3D crustal stretching was used (even without topography?)
+ if( USE_VERSION_5_1_5 ) then
+ if( CASE_3D ) then
+ do_ocean_load = .true.
+ endif
+ else
+ ! note: new version:
+ ! for 3D Earth with topography, compute local height of oceans
+ if( TOPOGRAPHY ) then
+ do_ocean_load = .true.
+ endif
+ endif
+
! create ocean load mass matrix for degrees of freedom at ocean bottom
rmass_ocean_load(:) = 0._CUSTOM_REAL
@@ -824,15 +852,9 @@
do j = 1,NGLLY
do i = 1,NGLLX
- ! note: old version (5.1.4)
- ! only for models where 3D crustal stretching was used (even without topography?)
- !if( CASE_3D ) then
-
- ! note: new version:
! for 3D Earth with topography, compute local height of oceans
- if( TOPOGRAPHY ) then
+ if( do_ocean_load ) then
-
! get coordinates of current point
xval = xstore(i,j,k,ispec)
yval = ystore(i,j,k,ispec)
@@ -841,17 +863,29 @@
! map to latitude and longitude for bathymetry routine
! slightly move points to avoid roundoff problem when exactly on the polar axis
call xyz_2_rthetaphi_dble(xval,yval,zval,rval,theta,phi)
-!! DK DK Jul 2013: added a test to only do this if we are on the axis
- if(abs(theta) > 89.99d0) then
- theta = theta + 0.0000001d0
- phi = phi + 0.0000001d0
+
+ if( USE_VERSION_5_1_5 ) then
+ !continue
+ else
+ ! adds small margins
+ !! DK DK Jul 2013: added a test to only do this if we are on the axis
+ if(abs(theta) > 89.99d0) then
+ theta = theta + 0.0000001d0
+ phi = phi + 0.0000001d0
+ endif
endif
+
call reduce(theta,phi)
! convert the geocentric colatitude to a geographic colatitude
- if( .not. ASSUME_PERFECT_SPHERE) then
+ if( USE_VERSION_5_1_5 ) then
theta = PI_OVER_TWO - &
- datan(1.006760466d0*dcos(theta)/dmax1(TINYVAL,dsin(theta)))
+ datan(1.006760466d0*dcos(theta)/dmax1(TINYVAL,dsin(theta)))
+ else
+ if( .not. ASSUME_PERFECT_SPHERE) then
+ theta = PI_OVER_TWO - &
+ datan(1.006760466d0*dcos(theta)/dmax1(TINYVAL,dsin(theta)))
+ endif
endif
! get geographic latitude and longitude in degrees
@@ -897,5 +931,5 @@
! add regular mass matrix to ocean load contribution
rmass_ocean_load(:) = rmass_ocean_load(:) + rmassz(:)
+ end subroutine create_mass_matrices_ocean_load
- end subroutine create_mass_matrices_ocean_load
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.F90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -56,7 +56,7 @@
NGLOB1D_RADIAL_CORNER, &
NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
ADIOS_ENABLED,ADIOS_FOR_ARRAYS_SOLVER, &
- ROTATION,EXACT_MASS_MATRIX_FOR_ROTATION,USE_LDDRK
+ ROTATION,EXACT_MASS_MATRIX_FOR_ROTATION
use meshfem3D_models_par,only: &
SAVE_BOUNDARY_MESH,SUPPRESS_CRUSTAL_MESH,REGIONAL_MOHO_MESH, &
@@ -305,7 +305,7 @@
! copy the theoretical number of points for the second pass
nglob = nglob_theor
- if(NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. (.not. USE_LDDRK)) then
+ if( NCHUNKS /= 6 .and. ABSORBING_CONDITIONS ) then
select case(iregion_code)
case( IREGION_CRUST_MANTLE )
nglob_xy = nglob
@@ -316,15 +316,13 @@
nglob_xy = 1
endif
- if( .not. USE_LDDRK )then
- if( ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION )then
- select case(iregion_code)
- case( IREGION_CRUST_MANTLE,IREGION_INNER_CORE )
- nglob_xy = nglob
- case( IREGION_OUTER_CORE )
- nglob_xy = 1
- endselect
- endif
+ if( ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION ) then
+ select case(iregion_code)
+ case( IREGION_CRUST_MANTLE,IREGION_INNER_CORE )
+ nglob_xy = nglob
+ case( IREGION_OUTER_CORE )
+ nglob_xy = 1
+ endselect
endif
allocate(rmassx(nglob_xy), &
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -34,7 +34,7 @@
use constants,only: &
NGNOD,R_EARTH_KM,R_EARTH,R_UNIT_SPHERE, &
- PI_OVER_TWO,RADIANS_TO_DEGREES,TINYVAL,SMALLVAL,ONE
+ PI_OVER_TWO,RADIANS_TO_DEGREES,TINYVAL,SMALLVAL,ONE,USE_VERSION_5_1_5
use meshfem3D_par,only: &
RMOHO_FICTITIOUS_IN_MESHER,R220,RMIDDLE_CRUST
@@ -96,15 +96,19 @@
! nevertheless its moho depth should be set and will be used in linear stretching
if( moho < TINYVAL ) call exit_mpi(myrank,'error moho depth to honor')
- ! limits moho depth to a threshold value to avoid stretching problems
- if( moho < MOHO_MINIMUM ) then
- print*,'moho value exceeds minimum: ',moho,MOHO_MINIMUM,'in km: ',moho*R_EARTH_KM
- moho = MOHO_MINIMUM
+ if( USE_VERSION_5_1_5 ) then
+ ! continue
+ else
+ ! limits moho depth to a threshold value to avoid stretching problems
+ if( moho < MOHO_MINIMUM ) then
+ print*,'moho value exceeds minimum: ',moho,MOHO_MINIMUM,'in km: ',moho*R_EARTH_KM
+ moho = MOHO_MINIMUM
+ endif
+ if( moho > MOHO_MAXIMUM ) then
+ print*,'moho value exceeds maximum: ',moho,MOHO_MAXIMUM,'in km: ',moho*R_EARTH_KM
+ moho = MOHO_MAXIMUM
+ endif
endif
- if( moho > MOHO_MAXIMUM ) then
- print*,'moho value exceeds maximum: ',moho,MOHO_MAXIMUM,'in km: ',moho*R_EARTH_KM
- moho = MOHO_MAXIMUM
- endif
! radius of moho depth (normalized)
moho = ONE - moho
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -37,7 +37,7 @@
use meshfem3D_par,only: &
NCHUNKS,ABSORBING_CONDITIONS,SAVE_MESH_FILES, &
- USE_LDDRK,ROTATION,EXACT_MASS_MATRIX_FOR_ROTATION
+ ROTATION,EXACT_MASS_MATRIX_FOR_ROTATION
use create_regions_mesh_par2,only: &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
@@ -243,29 +243,24 @@
!
! 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(.not. USE_LDDRK)then
- if((NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE)) then
- write(IOUT) rmassx
- write(IOUT) rmassy
- endif
+ if( ((NCHUNKS /= 6 .and. ABSORBING_CONDITIONS) .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ ((ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION) .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ ((ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION) .and. iregion_code == IREGION_INNER_CORE)) then
+ write(IOUT) rmassx
+ write(IOUT) rmassy
endif
write(IOUT) rmassz
! mass matrices for backward simulation when ROTATION is .true.
- if(.not. USE_LDDRK)then
- if(EXACT_MASS_MATRIX_FOR_ROTATION)then
- if((ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION .and. iregion_code == IREGION_INNER_CORE))then
- write(IOUT) b_rmassx
- write(IOUT) b_rmassy
- endif
+ if(EXACT_MASS_MATRIX_FOR_ROTATION)then
+ if((ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ (ROTATION .and. iregion_code == IREGION_INNER_CORE))then
+ write(IOUT) b_rmassx
+ write(IOUT) b_rmassy
endif
endif
-
! additional ocean load mass matrix if oceans and if we are in the crust
if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) write(IOUT) rmass_ocean_load
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver_adios.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver_adios.F90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver_adios.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -69,7 +69,7 @@
use meshfem3D_par,only: &
NCHUNKS,ABSORBING_CONDITIONS,SAVE_MESH_FILES, LOCAL_PATH, &
ADIOS_ENABLED,ADIOS_FOR_SOLVER_MESHFILES, &
- USE_LDDRK,ROTATION,EXACT_MASS_MATRIX_FOR_ROTATION
+ ROTATION,EXACT_MASS_MATRIX_FOR_ROTATION
use create_regions_mesh_par2,only: &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
@@ -286,15 +286,13 @@
endif
local_dim = nglob_xy
- if(.not. USE_LDDRK)then
- if((NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE)) 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
+ if((NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ (ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ (ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE)) 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", &
@@ -302,15 +300,13 @@
! mass matrices for backward simulation when ROTATION is .true.
local_dim = nglob_xy
- if(.not. USE_LDDRK)then
- if(EXACT_MASS_MATRIX_FOR_ROTATION)then
- if((ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION .and. iregion_code == IREGION_INNER_CORE))then
- call define_adios_global_real_1d_array(adios_group, "b_rmassx", &
- local_dim, group_size_inc)
- call define_adios_global_real_1d_array(adios_group, "b_rmassy", &
- local_dim, group_size_inc)
- endif
+ if(EXACT_MASS_MATRIX_FOR_ROTATION)then
+ if((ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ (ROTATION .and. iregion_code == IREGION_INNER_CORE))then
+ call define_adios_global_real_1d_array(adios_group, "b_rmassx", &
+ local_dim, group_size_inc)
+ call define_adios_global_real_1d_array(adios_group, "b_rmassy", &
+ local_dim, group_size_inc)
endif
endif
@@ -676,20 +672,18 @@
! mass matrices
local_dim = nglob_xy
- if(.not. USE_LDDRK)then
- if((NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE)) 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)
+ if((NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ (ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ (ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE)) 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
+ 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
@@ -700,20 +694,18 @@
! mass matrices for backward simulation when ROTATION is .true.
local_dim = nglob_xy
- if(.not. USE_LDDRK)then
- if(EXACT_MASS_MATRIX_FOR_ROTATION)then
- if((ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION .and. iregion_code == IREGION_INNER_CORE))then
- call adios_set_path (adios_handle, "b_rmassx", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", b_rmassx, adios_err)
+ if(EXACT_MASS_MATRIX_FOR_ROTATION)then
+ if((ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ (ROTATION .and. iregion_code == IREGION_INNER_CORE))then
+ call adios_set_path (adios_handle, "b_rmassx", adios_err)
+ call write_1D_global_array_adios_dims(adios_handle, myrank, &
+ local_dim, sizeprocs)
+ call adios_write(adios_handle, "array", b_rmassx, adios_err)
- call adios_set_path (adios_handle, "b_rmassy", adios_err)
- call write_1D_global_array_adios_dims(adios_handle, myrank, &
- local_dim, sizeprocs)
- call adios_write(adios_handle, "array", b_rmassy, adios_err)
- endif
+ call adios_set_path (adios_handle, "b_rmassy", adios_err)
+ call write_1D_global_array_adios_dims(adios_handle, myrank, &
+ local_dim, sizeprocs)
+ call adios_write(adios_handle, "array", b_rmassy, adios_err)
endif
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/get_timestep_and_layers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/get_timestep_and_layers.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/get_timestep_and_layers.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -26,38 +26,17 @@
!=====================================================================
- subroutine get_timestep_and_layers(DT,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,R_CENTRAL_CUBE, &
- NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
- ANISOTROPIC_INNER_CORE)
+ subroutine get_timestep_and_layers(NEX_MAX)
-
use constants
+ use shared_parameters
implicit none
- ! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
+ integer,intent(in) :: NEX_MAX
- integer 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
-
- integer NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL,THREE_D_MODEL
-
- double precision DT
- double precision R_CENTRAL_CUBE
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
-
- logical ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL,ANISOTROPIC_INNER_CORE
-
! local variables
- integer multiplication_factor
+ integer :: multiplication_factor
!----
!---- case prem_onecrust by default
@@ -445,4 +424,14 @@
endif
+! the maximum CFL of LDDRK is significantly higher than that of the Newmark scheme,
+! in a ratio that is theoretically 1.327 / 0.697 = 1.15 / 0.604 = 1.903 for a solid with Poisson's ratio = 0.25
+! and for a fluid (see the manual of the 2D code, SPECFEM2D, Tables 4.1 and 4.2, and that ratio does not
+! depend on whether we are in 2D or in 3D). However in practice a ratio of about 1.5 to 1.7 is often safer
+! (for instance for models with a large range of Poisson's ratio values).
+! Since the code computes the time step using the Newmark scheme, for LDDRK we simply
+! multiply that time step by this ratio when LDDRK is on and when flag INCREASE_CFL_FOR_LDDRK is true.
+ if(USE_LDDRK .and. INCREASE_CFL_FOR_LDDRK) DT = DT * RATIO_BY_WHICH_TO_INCREASE_IT
+
+
end subroutine get_timestep_and_layers
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/memory_eval.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/memory_eval.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/memory_eval.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -49,7 +49,7 @@
use constants
use shared_parameters,only: ATT1,ATT2,ATT3, &
APPROXIMATE_HESS_KL,ANISOTROPIC_KL,NOISE_TOMOGRAPHY, &
- USE_LDDRK,EXACT_MASS_MATRIX_FOR_ROTATION, &
+ EXACT_MASS_MATRIX_FOR_ROTATION, &
OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE, &
TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,TOPOGRAPHY, &
ONE_CRUST,NCHUNKS, &
@@ -323,7 +323,7 @@
static_memory_size = static_memory_size + &
12.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_INNER_CORE)*dble(CUSTOM_REAL)
- ! xstore_inner_core,ystore_inner_core,zstore_inner_core,rmass_inner_core
+ ! xstore_inner_core,ystore_inner_core,zstore_inner_core,rmassz_inner_core
static_memory_size = static_memory_size + &
4.d0*NGLOB(IREGION_INNER_CORE)*dble(CUSTOM_REAL)
@@ -510,30 +510,32 @@
! for the sake of performance, only "rmassz" array will be filled and "rmassx" & "rmassy" will be fictitious / unused
NGLOB_XY_CM = 1
NGLOB_XY_IC = 1
- if(NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. .not. USE_LDDRK) then
+ if( NCHUNKS /= 6 .and. ABSORBING_CONDITIONS ) then
NGLOB_XY_CM = NGLOB(IREGION_CRUST_MANTLE)
else
NGLOB_XY_CM = 1
endif
- if(.not. USE_LDDRK .and. EXACT_MASS_MATRIX_FOR_ROTATION) then
- if(ROTATION) then
- NGLOB_XY_CM = NGLOB(IREGION_CRUST_MANTLE)
- NGLOB_XY_IC = NGLOB(IREGION_INNER_CORE)
- endif
+ if(ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION) then
+ NGLOB_XY_CM = NGLOB(IREGION_CRUST_MANTLE)
+ NGLOB_XY_IC = NGLOB(IREGION_INNER_CORE)
endif
! rmassx_crust_mantle,rmassy_crust_mantle for EXACT_MASS_MATRIX_FOR_ROTATION and/or ABSORBING_CONDITIONS
static_memory_size = static_memory_size + 2.d0*NGLOB_XY_CM*4.d0*dble(CUSTOM_REAL)
- ! b_rmassx_crust_mantle,b_rmassy_crust_mantle for EXACT_MASS_MATRIX_FOR_ROTATION and/or ABSORBING_CONDITIONS
- static_memory_size = static_memory_size + 2.d0*NGLOB_XY_CM*4.d0*dble(CUSTOM_REAL)
+ if( SIMULATION_TYPE == 3 ) then
+ ! b_rmassx_crust_mantle,b_rmassy_crust_mantle for EXACT_MASS_MATRIX_FOR_ROTATION and/or ABSORBING_CONDITIONS
+ static_memory_size = static_memory_size + 2.d0*NGLOB_XY_CM*4.d0*dble(CUSTOM_REAL)
+ endif
! rmassx_inner_core,rmassy_inner_core for EXACT_MASS_MATRIX_FOR_ROTATION and/or ABSORBING_CONDITIONS
static_memory_size = static_memory_size + 2.d0*NGLOB_XY_IC*4.d0*dble(CUSTOM_REAL)
- ! b_rmassx_inner_core,b_rmassy_inner_core for EXACT_MASS_MATRIX_FOR_ROTATION and/or ABSORBING_CONDITIONS
- static_memory_size = static_memory_size + 2.d0*NGLOB_XY_IC*4.d0*dble(CUSTOM_REAL)
+ if( SIMULATION_TYPE == 3 ) then
+ ! b_rmassx_inner_core,b_rmassy_inner_core for EXACT_MASS_MATRIX_FOR_ROTATION and/or ABSORBING_CONDITIONS
+ static_memory_size = static_memory_size + 2.d0*NGLOB_XY_IC*4.d0*dble(CUSTOM_REAL)
+ endif
end subroutine memory_eval
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/read_compute_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/read_compute_parameters.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/read_compute_parameters.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -107,15 +107,7 @@
! sets time step size and number of layers
! right distribution is determined based upon maximum value of NEX
NEX_MAX = max(NEX_XI,NEX_ETA)
- call get_timestep_and_layers(DT,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,R_CENTRAL_CUBE, &
- NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
- ANISOTROPIC_INNER_CORE)
+ call get_timestep_and_layers(NEX_MAX)
! initial guess : compute total number of time steps, rounded to next multiple of 100
NSTEP = 100 * (int(RECORD_LENGTH_IN_MINUTES * 60.d0 / (100.d0*DT)) + 1)
@@ -130,7 +122,9 @@
endif
!! DK DK make sure NSTEP is a multiple of NT_DUMP_ATTENUATION
- if(UNDO_ATTENUATION .and. mod(NSTEP,NT_DUMP_ATTENUATION) /= 0) NSTEP = (NSTEP/NT_DUMP_ATTENUATION + 1)*NT_DUMP_ATTENUATION
+ if(UNDO_ATTENUATION .and. mod(NSTEP,NT_DUMP_ATTENUATION) /= 0) then
+ NSTEP = (NSTEP/NT_DUMP_ATTENUATION + 1)*NT_DUMP_ATTENUATION
+ endif
! subsets used to save seismograms must not be larger than the whole time series,
! otherwise we waste memory
@@ -138,9 +132,10 @@
! computes a default hdur_movie that creates nice looking movies.
! Sets HDUR_MOVIE as the minimum period the mesh can resolve
- if(HDUR_MOVIE <= TINYVAL) &
+ if(HDUR_MOVIE <= TINYVAL) then
HDUR_MOVIE = 1.2d0*max(240.d0/NEX_XI*18.d0*ANGULAR_WIDTH_XI_IN_DEGREES/90.d0, &
240.d0/NEX_ETA*18.d0*ANGULAR_WIDTH_ETA_IN_DEGREES/90.d0)
+ endif
! checks parameters
call rcp_check_parameters()
@@ -307,6 +302,10 @@
if(UNDO_ATTENUATION .and. MOVIE_VOLUME .and. MOVIE_VOLUME_TYPE == 4 ) &
stop 'MOVIE_VOLUME_TYPE == 4 is not implemented for UNDO_ATTENUATION in order to save memory'
+ !! DK DK this should not be difficult to fix and test, but not done yet by lack of time
+ if( UNDO_ATTENUATION .and. NUMBER_OF_RUNS /= 1) &
+ stop 'NUMBER_OF_RUNS should be == 1 for now when using UNDO_ATTENUATION'
+
if(UNDO_ATTENUATION .and. NUMBER_OF_THIS_RUN > 1) &
stop 'we currently do not support NUMBER_OF_THIS_RUN > 1 in the case of UNDO_ATTENUATION'
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/read_parameter_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/read_parameter_file.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/read_parameter_file.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -272,21 +272,40 @@
endif
endif
-!daniel debug: status of implementation
+!----------------------------------------------
+!
+! status of implementation
+!
+!----------------------------------------------
+!daniel debug:
+! please remove these security checks only after validating new features
!! DK DK July 2013: temporary, the time for Matthieu Lefebvre to merge his ADIOS implementation
- if( ADIOS_ENABLED ) then
+ if( ADIOS_ENABLED ) &
stop 'ADIOS_ENABLED support not implemented yet'
- endif
- if( USE_LDDRK ) then
- stop 'USE_LDDRK support not implemented yet'
- endif
- if( EXACT_MASS_MATRIX_FOR_ROTATION ) then
- stop 'EXACT_MASS_MATRIX_FOR_ROTATION support not implemented yet'
- endif
- if( UNDO_ATTENUATION ) then
+ if( ADIOS_ENABLED .and. GPU_MODE ) &
+ stop 'ADIOS_ENABLED support not implemented yet'
+
+ !if( USE_LDDRK ) &
+ ! stop 'USE_LDDRK support not implemented yet'
+ if( USE_LDDRK .and. SIMULATION_TYPE == 3 ) &
+ stop 'USE_LDDRK support not implemented yet for SIMULATION_TYPE == 3'
+ if( USE_LDDRK .and. GPU_MODE ) &
+ stop 'USE_LDDRK support not implemented yet for GPU simulations'
+
+ if( EXACT_MASS_MATRIX_FOR_ROTATION .and. GPU_MODE ) &
+ stop 'EXACT_MASS_MATRIX_FOR_ROTATION support not implemented yet for GPU simulations'
+
+ if( UNDO_ATTENUATION ) &
stop 'UNDO_ATTENUATION support not implemented yet'
- endif
+ if( UNDO_ATTENUATION .and. NOISE_TOMOGRAPHY > 0 ) &
+ stop 'UNDO_ATTENUATION support not implemented yet for noise simulations'
+ if( UNDO_ATTENUATION .and. MOVIE_VOLUME .and. MOVIE_VOLUME_TYPE == 4 ) &
+ stop 'UNDO_ATTENUATION support not implemented yet for MOVIE_VOLUME_TYPE == 4 simulations'
+ if( UNDO_ATTENUATION .and. GPU_MODE ) &
+ stop 'UNDO_ATTENUATION support not implemented yet for GPU simulations'
+ if( UNDO_ATTENUATION .and. SIMULATION_TYPE == 3 .and. (MOVIE_VOLUME .or. MOVIE_SURFACE) ) &
+ stop 'UNDO_ATTENUATION support not implemented yet for SIMULATION_TYPE == 3 and movie simulations'
end subroutine read_parameter_file
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/save_header_file.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/save_header_file.F90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/save_header_file.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -75,7 +75,7 @@
NPROC_XI,NPROC_ETA, &
SAVE_REGULAR_KL, &
PARTIAL_PHYS_DISPERSION_ONLY, &
- ABSORBING_CONDITIONS,USE_LDDRK,EXACT_MASS_MATRIX_FOR_ROTATION, &
+ ABSORBING_CONDITIONS,EXACT_MASS_MATRIX_FOR_ROTATION, &
ATTENUATION_1D_WITH_3D_STORAGE, &
ATT1,ATT2,ATT3,ATT4,ATT5, &
MOVIE_VOLUME
@@ -468,6 +468,7 @@
else
write(IOUT,*) 'logical, parameter :: PARTIAL_PHYS_DISPERSION_ONLY_VAL = .false.'
endif
+ write(IOUT,*)
write(IOUT,*) 'integer, parameter :: NPROC_XI_VAL = ',NPROC_XI
write(IOUT,*) 'integer, parameter :: NPROC_ETA_VAL = ',NPROC_ETA
@@ -561,17 +562,15 @@
NGLOB_XY_CM = 1
NGLOB_XY_IC = 1
- if(NCHUNKS /= 6 .and. ABSORBING_CONDITIONS .and. .not. USE_LDDRK) then
+ if( NCHUNKS /= 6 .and. ABSORBING_CONDITIONS ) then
NGLOB_XY_CM = NGLOB(IREGION_CRUST_MANTLE)
else
NGLOB_XY_CM = 1
endif
- if( .not. USE_LDDRK .and. EXACT_MASS_MATRIX_FOR_ROTATION ) then
- if(ROTATION) then
- NGLOB_XY_CM = NGLOB(IREGION_CRUST_MANTLE)
- NGLOB_XY_IC = NGLOB(IREGION_INNER_CORE)
- endif
+ if( ROTATION .and. EXACT_MASS_MATRIX_FOR_ROTATION ) then
+ NGLOB_XY_CM = NGLOB(IREGION_CRUST_MANTLE)
+ NGLOB_XY_IC = NGLOB(IREGION_INNER_CORE)
endif
write(IOUT,*) 'integer, parameter :: NGLOB_XY_CM = ',NGLOB_XY_CM
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_add_sources.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -315,6 +315,15 @@
double precision, external :: comp_source_time_function
double precision, external :: comp_source_time_function_rickr
+ integer :: it_tmp
+
+ ! iteration step
+ if( UNDO_ATTENUATION ) then
+ it_tmp = iteration_on_subset * NT_DUMP_ATTENUATION - it_of_this_subset + 1
+ else
+ it_tmp = it
+ endif
+
if( .not. GPU_MODE ) then
! on CPU
do isource = 1,NSOURCES
@@ -351,7 +360,7 @@
!endif
! This is the expression of a Ricker; should be changed according maybe to the Par_file.
- stf_used = FACTOR_FORCE_SOURCE * comp_source_time_function_rickr(dble(NSTEP-it)*DT-t0-tshift_cmt(isource),f0)
+ stf_used = FACTOR_FORCE_SOURCE * comp_source_time_function_rickr(dble(NSTEP-it_tmp)*DT-t0-tshift_cmt(isource),f0)
! e.g. we use nu_source(3,:) here if we want a source normal to the surface.
! note: time step is now at NSTEP-it
@@ -361,7 +370,7 @@
else
! see note above: time step corresponds now to NSTEP-it
- stf = comp_source_time_function(dble(NSTEP-it)*DT-t0-tshift_cmt(isource),hdur_gaussian(isource))
+ stf = comp_source_time_function(dble(NSTEP-it_tmp)*DT-t0-tshift_cmt(isource),hdur_gaussian(isource))
! distinguish between single and double precision for reals
if(CUSTOM_REAL == SIZE_REAL) then
@@ -396,12 +405,12 @@
if(USE_FORCE_POINT_SOURCE) then
do isource = 1,NSOURCES
stf_pre_compute(isource) = &
- FACTOR_FORCE_SOURCE * comp_source_time_function_rickr(dble(NSTEP-it)*DT-t0-tshift_cmt(isource),f0)
+ FACTOR_FORCE_SOURCE * comp_source_time_function_rickr(dble(NSTEP-it_tmp)*DT-t0-tshift_cmt(isource),f0)
enddo
else
do isource = 1,NSOURCES
stf_pre_compute(isource) = &
- comp_source_time_function(dble(NSTEP-it)*DT-t0-tshift_cmt(isource),hdur_gaussian(isource))
+ comp_source_time_function(dble(NSTEP-it_tmp)*DT-t0-tshift_cmt(isource),hdur_gaussian(isource))
enddo
endif
! adds sources: only implements SIMTYPE=3 (and NOISE_TOM=0)
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_coupling.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -363,7 +363,7 @@
nspec_top)
use constants_solver
- use specfem_par,only: ABSORBING_CONDITIONS,EXACT_MASS_MATRIX_FOR_ROTATION,USE_LDDRK
+! use specfem_par,only: ABSORBING_CONDITIONS,EXACT_MASS_MATRIX_FOR_ROTATION
implicit none
@@ -395,15 +395,16 @@
! local parameters
real(kind=CUSTOM_REAL) :: force_normal_comp
real(kind=CUSTOM_REAL) :: additional_term_x,additional_term_y,additional_term_z
- real(kind=CUSTOM_REAL) :: additional_term
+! real(kind=CUSTOM_REAL) :: additional_term
real(kind=CUSTOM_REAL) :: nx,ny,nz
integer :: i,j,k,ispec,ispec2D,iglob
! initialize the updates
updated_dof_ocean_load(:) = .false.
- if((NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS .or. &
- (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION)) .and. (.not. USE_LDDRK)) then
+!daniel debug: check not needed anymore
+! if( (NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) .or. &
+! (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION) ) then
! for surface elements exactly at the top of the crust (ocean bottom)
do ispec2D = 1,nspec_top !NSPEC2D_TOP(IREGION_CRUST_MANTLE)
@@ -430,9 +431,9 @@
! 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)
+ 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)
additional_term_x = (rmass_ocean_load(iglob) - rmassx_crust_mantle(iglob)) * force_normal_comp
additional_term_y = (rmass_ocean_load(iglob) - rmassy_crust_mantle(iglob)) * force_normal_comp
@@ -451,53 +452,53 @@
enddo
enddo
- else
-
- ! for surface elements exactly at the top of the crust (ocean bottom)
- do ispec2D = 1,nspec_top !NSPEC2D_TOP(IREGION_CRUST_MANTLE)
-
- ispec = ibelm_top_crust_mantle(ispec2D)
-
- ! only for DOFs exactly at the top of the crust (ocean bottom)
- k = NGLLZ
-
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- ! get global point number
- iglob = ibool_crust_mantle(i,j,k,ispec)
-
- ! only update once
- if(.not. updated_dof_ocean_load(iglob)) then
-
- ! get normal
- nx = normal_top_crust_mantle(1,i,j,ispec2D)
- ny = normal_top_crust_mantle(2,i,j,ispec2D)
- nz = normal_top_crust_mantle(3,i,j,ispec2D)
-
- ! 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 + &
- accel_crust_mantle(2,iglob)*ny + &
- accel_crust_mantle(3,iglob)*nz) / rmassz_crust_mantle(iglob)
-
- additional_term = (rmass_ocean_load(iglob) - rmassz_crust_mantle(iglob)) * force_normal_comp
-
- accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + additional_term * nx
- accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + additional_term * ny
- accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + additional_term * nz
-
- ! done with this point
- updated_dof_ocean_load(iglob) = .true.
-
- endif
-
- enddo
- enddo
- enddo
-
- endif
-
+! else
+!
+! ! for surface elements exactly at the top of the crust (ocean bottom)
+! do ispec2D = 1,nspec_top !NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+!
+! ispec = ibelm_top_crust_mantle(ispec2D)
+!
+! ! only for DOFs exactly at the top of the crust (ocean bottom)
+! k = NGLLZ
+!
+! do j = 1,NGLLY
+! do i = 1,NGLLX
+!
+! ! get global point number
+! iglob = ibool_crust_mantle(i,j,k,ispec)
+!
+! ! only update once
+! if(.not. updated_dof_ocean_load(iglob)) then
+!
+! ! get normal
+! nx = normal_top_crust_mantle(1,i,j,ispec2D)
+! ny = normal_top_crust_mantle(2,i,j,ispec2D)
+! nz = normal_top_crust_mantle(3,i,j,ispec2D)
+!
+! ! 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 + &
+! accel_crust_mantle(2,iglob)*ny + &
+! accel_crust_mantle(3,iglob)*nz) / rmassz_crust_mantle(iglob)
+!
+! additional_term = (rmass_ocean_load(iglob) - rmassz_crust_mantle(iglob)) * force_normal_comp
+!
+! accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + additional_term * nx
+! accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + additional_term * ny
+! accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + additional_term * nz
+!
+! ! done with this point
+! updated_dof_ocean_load(iglob) = .true.
+!
+! endif
+!
+! enddo
+! enddo
+! enddo
+!
+! endif
+!
end subroutine compute_coupling_ocean
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -25,6 +25,14 @@
!
!=====================================================================
+
+!--------------------------------------------------------------------------------------------
+!
+! isotropic element
+!
+!--------------------------------------------------------------------------------------------
+
+
subroutine compute_element_iso(ispec, &
minus_gravity_table,density_table,minus_deriv_gravity_table, &
xstore,ystore,zstore, &
@@ -364,10 +372,13 @@
end subroutine compute_element_iso
+!--------------------------------------------------------------------------------------------
!
-!--------------------------------------------------------------------------------------------------
+! transversely isotropic element
!
+!--------------------------------------------------------------------------------------------
+
subroutine compute_element_tiso(ispec, &
minus_gravity_table,density_table,minus_deriv_gravity_table, &
xstore,ystore,zstore, &
@@ -900,10 +911,14 @@
end subroutine compute_element_tiso
-!
+
!--------------------------------------------------------------------------------------------
!
+! anisotropic element
+!
+!--------------------------------------------------------------------------------------------
+
subroutine compute_element_aniso(ispec, &
minus_gravity_table,density_table,minus_deriv_gravity_table, &
xstore,ystore,zstore, &
@@ -1272,14 +1287,22 @@
end subroutine compute_element_aniso
+!--------------------------------------------------------------------------------------------
!
+! helper functions
+!
!--------------------------------------------------------------------------------------------
!
+! please leave this routine in this file, to help compilers inlining this function...
+!
subroutine compute_element_att_stress(R_xx_loc,R_yy_loc,R_xy_loc,R_xz_loc,R_yz_loc, &
sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz)
+! updates stress with attenuation correction
+
+
use constants_solver,only: CUSTOM_REAL,N_SLS
implicit none
@@ -1314,298 +1337,4 @@
end subroutine compute_element_att_stress
-!
-!--------------------------------------------------------------------------------------------
-!
- subroutine compute_element_att_memory_cm(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
- vnspec,factor_common, &
- alphaval,betaval,gammaval, &
- c44store,muvstore, &
- 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
-
-! convention for attenuation
-! term in xx = 1
-! term in yy = 2
-! term in xy = 3
-! term in xz = 4
-! term in yz = 5
-! term in zz not computed since zero trace
-! This is because we only implement Q_\mu attenuation and not Q_\kappa.
-! Note that this does *NOT* imply that there is no attenuation for P waves
-! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
-! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
-! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
-! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
-
- use constants_solver
-
- implicit none
-
- ! element id
- integer :: ispec
-
- ! 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
- real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION) :: R_xx,R_yy,R_xy,R_xz,R_yz
-
- ! variable sized array variables
- integer :: vnspec
-
- real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1_VAL,ATT2_VAL,ATT3_VAL,vnspec) :: factor_common
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: c44store
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: muvstore
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
-
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
-
- logical :: is_backward_field
-
-! local parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_c44_muv
- integer :: i_SLS
-
- ! 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
-
- do i_SLS = 1,N_SLS
-
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) 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
-
- R_xx(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xx(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xx(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(1,:,:,:))
-
- R_yy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yy(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(2,:,:,:))
-
- R_xy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xy(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(3,:,:,:))
-
- R_xz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xz(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(4,:,:,:))
-
- R_yz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yz(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(5,:,:,:))
-
- enddo ! i_SLS
-
- end subroutine compute_element_att_memory_cm
-
-!
-!--------------------------------------------------------------------------------------------
-!
-
- subroutine compute_element_att_memory_ic(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
- vnspec,factor_common, &
- alphaval,betaval,gammaval, &
- muvstore, &
- 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
-
-! convention for attenuation
-! term in xx = 1
-! term in yy = 2
-! term in xy = 3
-! term in xz = 4
-! term in yz = 5
-! term in zz not computed since zero trace
-! This is because we only implement Q_\mu attenuation and not Q_\kappa.
-! Note that this does *NOT* imply that there is no attenuation for P waves
-! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
-! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
-! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
-! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
-
- use constants_solver
-
- implicit none
-
- ! element id
- integer :: ispec
-
- real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
- R_xx,R_yy,R_xy,R_xz,R_yz
-
- ! variable sized array variables
- integer :: vnspec
-
- real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1_VAL,ATT2_VAL,ATT3_VAL,vnspec) :: factor_common
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: muvstore
-
-! real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
-
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
-
- logical :: is_backward_field
-
-! local parameters
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_use
-
- integer :: i_SLS
-
- ! 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
-
- do i_SLS = 1,N_SLS
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) 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(:,:,:) * &
-! (betaval(i_SLS) * epsilondev(i_memory,:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
-! enddo
-
- R_xx(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xx(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xx(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(1,:,:,:))
-
- R_yy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yy(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(2,:,:,:))
-
- R_xy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xy(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(3,:,:,:))
-
- R_xz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xz(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(4,:,:,:))
-
- R_yz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yz(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(5,:,:,:))
-
- enddo
-
- end subroutine compute_element_att_memory_ic
-
-!
-!--------------------------------------------------------------------------------------------
-!
-
- subroutine compute_element_att_mem_up_cm(ispec,i,j,k, &
- R_xx_loc,R_yy_loc,R_xy_loc,R_xz_loc,R_yz_loc, &
- epsilondev_loc,c44_muv,is_backward_field)
-! crust mantle
-! update memory variables based upon the Runge-Kutta scheme
-
-
-!daniel: att - debug update
- use specfem_par,only: tau_sigma_dble,deltat,b_deltat
-
- use specfem_par_crustmantle,only: factor_common=>factor_common_crust_mantle
-
- use constants_solver
-
- implicit none
-
- ! element id
- integer :: ispec,i,j,k
-
- ! 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
-! real(kind=CUSTOM_REAL), dimension(5,N_SLS) :: R_memory_loc
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: R_xx_loc
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: R_yy_loc
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: R_xy_loc
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: R_xz_loc
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: R_yz_loc
-
- real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
- real(kind=CUSTOM_REAL) :: c44_muv
-
- logical :: is_backward_field
- double precision :: dt,kappa
-
-! local parameters
- real(kind=CUSTOM_REAL) :: factor_common_c44_muv
- integer :: i_SLS
-
- if( .not. is_backward_field ) then
- dt = dble(deltat)
- else
- ! backward/reconstruction: reverse time
- dt = dble(b_deltat)
- endif
-
- do i_SLS = 1,N_SLS
-
- ! runge-kutta scheme to update memory variables R(t)
- if( .false. ) then
-! classical RK 4: R'(t) = - 1/tau * R(t)
-!
-! Butcher RK4:
-! 0 |
-! 1/2 | 1/2
-! 1/2 | 0 1/2
-! 1 | 0 1
-! -----------------------------------------------------------------------------
-! 1/6 1/3 1/3 1/6
- kappa = - dt/tau_sigma_dble(i_SLS)
-
- R_xx_loc(i_SLS) = R_xx_loc(i_SLS) * &
- (1.0d0 + kappa*(1.d0 + 0.5d0*kappa*(1.d0 + 1.0d0/6.0d0*kappa*(1.d0 + 1.0d0/24.0d0*kappa))))
- R_yy_loc(i_SLS) = R_yy_loc(i_SLS) * &
- (1.0d0 + kappa*(1.d0 + 0.5d0*kappa*(1.d0 + 1.0d0/6.0d0*kappa*(1.d0 + 1.0d0/24.0d0*kappa))))
- R_xy_loc(i_SLS) = R_xy_loc(i_SLS) * &
- (1.0d0 + kappa*(1.d0 + 0.5d0*kappa*(1.d0 + 1.0d0/6.0d0*kappa*(1.d0 + 1.0d0/24.0d0*kappa))))
- R_xz_loc(i_SLS) = R_xz_loc(i_SLS) * &
- (1.0d0 + kappa*(1.d0 + 0.5d0*kappa*(1.d0 + 1.0d0/6.0d0*kappa*(1.d0 + 1.0d0/24.0d0*kappa))))
- R_yz_loc(i_SLS) = R_yz_loc(i_SLS) * &
- (1.0d0 + kappa*(1.d0 + 0.5d0*kappa*(1.d0 + 1.0d0/6.0d0*kappa*(1.d0 + 1.0d0/24.0d0*kappa))))
- endif
-
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) then
- factor_common_c44_muv = factor_common(i_SLS,i,j,k,ispec) * c44_muv
- else
- factor_common_c44_muv = factor_common(i_SLS,1,1,1,ispec) * c44_muv
- endif
-
- ! adds contributions from current strain
- R_xx_loc(i_SLS) = R_xx_loc(i_SLS) + 0.5d0 * dt * dble(factor_common_c44_muv) * dble(epsilondev_loc(1))
- R_yy_loc(i_SLS) = R_yy_loc(i_SLS) + 0.5d0 * dt * dble(factor_common_c44_muv) * dble(epsilondev_loc(2))
- R_xy_loc(i_SLS) = R_xy_loc(i_SLS) + 0.5d0 * dt * dble(factor_common_c44_muv) * dble(epsilondev_loc(3))
- R_xz_loc(i_SLS) = R_xz_loc(i_SLS) + 0.5d0 * dt * dble(factor_common_c44_muv) * dble(epsilondev_loc(4))
- R_yz_loc(i_SLS) = R_yz_loc(i_SLS) + 0.5d0 * dt * dble(factor_common_c44_muv) * dble(epsilondev_loc(5))
-
- enddo ! i_SLS
-
- end subroutine compute_element_att_mem_up_cm
-
Added: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element_att_memory.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element_att_memory.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element_att_memory.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -0,0 +1,576 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 6 . 0
+! --------------------------------------------------
+!
+! 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
+! August 2013
+!
+! 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.
+!
+!=====================================================================
+
+
+!--------------------------------------------------------------------------------------------
+!
+! crust/mantle region
+!
+!--------------------------------------------------------------------------------------------
+
+
+ subroutine compute_element_att_memory_cm(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ vx,vy,vz,vnspec,factor_common, &
+ alphaval,betaval,gammaval, &
+ c44store,muvstore, &
+ 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
+
+! convention for attenuation
+! term in xx = 1
+! term in yy = 2
+! term in xy = 3
+! term in xz = 4
+! term in yz = 5
+! term in zz not computed since zero trace
+! This is because we only implement Q_\mu attenuation and not Q_\kappa.
+! Note that this does *NOT* imply that there is no attenuation for P waves
+! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
+! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
+! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
+! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
+
+ use constants_solver
+
+ implicit none
+
+ ! element id
+ integer :: ispec
+
+ ! 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
+ real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION) :: R_xx,R_yy,R_xy,R_xz,R_yz
+
+ ! variable sized array variables
+ integer :: vx,vy,vz,vnspec
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS,vx,vy,vz,vnspec) :: factor_common
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: c44store
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: muvstore
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+
+ logical :: is_backward_field
+
+! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_c44_muv
+ integer :: i_SLS
+
+ ! 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
+
+ do i_SLS = 1,N_SLS
+
+ ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
+ if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) 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
+
+ R_xx(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xx(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
+ (betaval(i_SLS) * epsilondev_xx(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(1,:,:,:))
+
+ R_yy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yy(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
+ (betaval(i_SLS) * epsilondev_yy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(2,:,:,:))
+
+ R_xy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xy(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
+ (betaval(i_SLS) * epsilondev_xy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(3,:,:,:))
+
+ R_xz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xz(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
+ (betaval(i_SLS) * epsilondev_xz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(4,:,:,:))
+
+ R_yz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yz(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
+ (betaval(i_SLS) * epsilondev_yz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(5,:,:,:))
+
+ enddo ! i_SLS
+
+ end subroutine compute_element_att_memory_cm
+
+
+!
+!--------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_element_att_memory_cm_lddrk(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk, &
+ vx,vy,vz,vnspec,factor_common, &
+ c44store,muvstore, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz, &
+ epsilondev_loc, &
+ deltat)
+! crust mantle
+! update memory variables based upon the Runge-Kutta scheme
+
+! convention for attenuation
+! term in xx = 1
+! term in yy = 2
+! term in xy = 3
+! term in xz = 4
+! term in yz = 5
+! term in zz not computed since zero trace
+! This is because we only implement Q_\mu attenuation and not Q_\kappa.
+! Note that this does *NOT* imply that there is no attenuation for P waves
+! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
+! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
+! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
+! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
+
+ use constants_solver
+ use specfem_par,only: ALPHA_LDDRK,BETA_LDDRK,tau_sigma_CUSTOM_REAL,istage
+
+ implicit none
+
+ ! element id
+ integer :: ispec
+
+ ! 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
+ real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION) :: R_xx,R_yy,R_xy,R_xz,R_yz
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION) :: &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk
+
+ ! variable sized array variables
+ integer :: vx,vy,vz,vnspec
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS,vx,vy,vz,vnspec) :: factor_common
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: c44store
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: muvstore
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+
+ real(kind=CUSTOM_REAL) :: deltat
+
+! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_c44_muv
+ integer :: i_SLS
+
+ ! 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
+
+ do i_SLS = 1,N_SLS
+
+ ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
+ if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) 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
+
+ R_xx_lddrk(i_SLS,:,:,:,ispec) = ALPHA_LDDRK(istage) * R_xx_lddrk(i_SLS,:,:,:,ispec) &
+ + deltat * ( factor_common_c44_muv(:,:,:) * epsilondev_loc(1,:,:,:) &
+ - R_xx(i_SLS,:,:,:,ispec)*(1._CUSTOM_REAL/tau_sigma_CUSTOM_REAL(i_SLS)) )
+
+ R_yy_lddrk(i_SLS,:,:,:,ispec) = ALPHA_LDDRK(istage) * R_yy_lddrk(i_SLS,:,:,:,ispec) &
+ + deltat * ( factor_common_c44_muv(:,:,:) * epsilondev_loc(2,:,:,:) &
+ - R_yy(i_SLS,:,:,:,ispec)*(1._CUSTOM_REAL/tau_sigma_CUSTOM_REAL(i_SLS)) )
+
+ R_xy_lddrk(i_SLS,:,:,:,ispec) = ALPHA_LDDRK(istage) * R_xy_lddrk(i_SLS,:,:,:,ispec) &
+ + deltat * ( factor_common_c44_muv(:,:,:) * epsilondev_loc(3,:,:,:) &
+ - R_xy(i_SLS,:,:,:,ispec)*(1._CUSTOM_REAL/tau_sigma_CUSTOM_REAL(i_SLS)) )
+
+ R_xz_lddrk(i_SLS,:,:,:,ispec) = ALPHA_LDDRK(istage) * R_xz_lddrk(i_SLS,:,:,:,ispec) &
+ + deltat * ( factor_common_c44_muv(:,:,:) * epsilondev_loc(4,:,:,:) &
+ - R_xz(i_SLS,:,:,:,ispec)*(1._CUSTOM_REAL/tau_sigma_CUSTOM_REAL(i_SLS)) )
+
+ R_yz_lddrk(i_SLS,:,:,:,ispec) = ALPHA_LDDRK(istage) * R_yz_lddrk(i_SLS,:,:,:,ispec) &
+ + deltat * ( factor_common_c44_muv(:,:,:) * epsilondev_loc(5,:,:,:) &
+ - R_yz(i_SLS,:,:,:,ispec)*(1._CUSTOM_REAL/tau_sigma_CUSTOM_REAL(i_SLS)) )
+
+ R_xx(i_SLS,:,:,:,ispec) = R_xx(i_SLS,:,:,:,ispec) + BETA_LDDRK(istage) * R_xx_lddrk(i_SLS,:,:,:,ispec)
+ R_yy(i_SLS,:,:,:,ispec) = R_yy(i_SLS,:,:,:,ispec) + BETA_LDDRK(istage) * R_yy_lddrk(i_SLS,:,:,:,ispec)
+ R_xy(i_SLS,:,:,:,ispec) = R_xy(i_SLS,:,:,:,ispec) + BETA_LDDRK(istage) * R_xy_lddrk(i_SLS,:,:,:,ispec)
+ R_xz(i_SLS,:,:,:,ispec) = R_xz(i_SLS,:,:,:,ispec) + BETA_LDDRK(istage) * R_xz_lddrk(i_SLS,:,:,:,ispec)
+ R_yz(i_SLS,:,:,:,ispec) = R_yz(i_SLS,:,:,:,ispec) + BETA_LDDRK(istage) * R_yz_lddrk(i_SLS,:,:,:,ispec)
+
+ enddo ! i_SLS
+
+ end subroutine compute_element_att_memory_cm_lddrk
+
+
+
+!--------------------------------------------------------------------------------------------
+!
+! inner core region
+!
+!--------------------------------------------------------------------------------------------
+
+
+ subroutine compute_element_att_memory_ic(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ vx,vy,vz,vnspec,factor_common, &
+ alphaval,betaval,gammaval, &
+ muvstore, &
+ 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
+
+! convention for attenuation
+! term in xx = 1
+! term in yy = 2
+! term in xy = 3
+! term in xz = 4
+! term in yz = 5
+! term in zz not computed since zero trace
+! This is because we only implement Q_\mu attenuation and not Q_\kappa.
+! Note that this does *NOT* imply that there is no attenuation for P waves
+! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
+! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
+! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
+! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
+
+ use constants_solver
+
+ implicit none
+
+ ! element id
+ integer :: ispec
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
+ R_xx,R_yy,R_xy,R_xz,R_yz
+
+ ! variable sized array variables
+ integer :: vx,vy,vz,vnspec
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS,vx,vy,vz,vnspec) :: factor_common
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: muvstore
+
+! real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+
+ logical :: is_backward_field
+
+! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_use
+
+ integer :: i_SLS
+
+ ! 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
+
+ ! note: epsilondev_loc is calculated based on displ( n + 1 ), thus corresponds to strain at time (n + 1)
+ ! epsilondev_xx,.. are stored from previous step, thus corresponds now to strain at time n
+
+ do i_SLS = 1,N_SLS
+
+ ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
+ if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) 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(:,:,:) * &
+! (betaval(i_SLS) * epsilondev(i_memory,:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
+! enddo
+
+ R_xx(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xx(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
+ (betaval(i_SLS) * epsilondev_xx(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(1,:,:,:))
+
+ R_yy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yy(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
+ (betaval(i_SLS) * epsilondev_yy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(2,:,:,:))
+
+ R_xy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xy(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
+ (betaval(i_SLS) * epsilondev_xy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(3,:,:,:))
+
+ R_xz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xz(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
+ (betaval(i_SLS) * epsilondev_xz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(4,:,:,:))
+
+ R_yz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yz(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
+ (betaval(i_SLS) * epsilondev_yz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(5,:,:,:))
+
+ enddo
+
+ end subroutine compute_element_att_memory_ic
+
+
+!
+!--------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_element_att_memory_ic_lddrk(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk, &
+ vx,vy,vz,vnspec,factor_common, &
+ muvstore, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz, &
+ epsilondev_loc, &
+ deltat)
+! inner core
+! update memory variables based upon the Runge-Kutta scheme
+
+! convention for attenuation
+! term in xx = 1
+! term in yy = 2
+! term in xy = 3
+! term in xz = 4
+! term in yz = 5
+! term in zz not computed since zero trace
+! This is because we only implement Q_\mu attenuation and not Q_\kappa.
+! Note that this does *NOT* imply that there is no attenuation for P waves
+! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
+! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
+! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
+! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
+
+ use constants_solver
+ use specfem_par,only: ALPHA_LDDRK,BETA_LDDRK,tau_sigma_CUSTOM_REAL,istage
+
+ implicit none
+
+ ! element id
+ integer :: ispec
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
+ R_xx,R_yy,R_xy,R_xz,R_yz
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk
+
+ ! variable sized array variables
+ integer :: vx,vy,vz,vnspec
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS,vx,vy,vz,vnspec) :: factor_common
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: muvstore
+
+! real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+
+ real(kind=CUSTOM_REAL) :: deltat
+
+! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_use
+
+ integer :: i_SLS
+ integer :: i,j,k
+
+ ! 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
+
+ ! note: epsilondev_loc is calculated based on displ( n + 1 ), thus corresponds to strain at time (n + 1)
+ ! epsilondev_xx,.. are stored from previous step, thus corresponds now to strain at time n
+
+ do i_SLS = 1,N_SLS
+
+ ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
+ if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) 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 k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ R_xx_lddrk(i_SLS,i,j,k,ispec) = ALPHA_LDDRK(istage) * R_xx_lddrk(i_SLS,i,j,k,ispec) &
+ + deltat * ( factor_common_use(i,j,k)*epsilondev_loc(1,i,j,k) &
+ - R_xx(i_SLS,i,j,k,ispec)*(1.0_CUSTOM_REAL/tau_sigma_CUSTOM_REAL(i_SLS)) )
+
+ R_yy_lddrk(i_SLS,i,j,k,ispec) = ALPHA_LDDRK(istage) * R_yy_lddrk(i_SLS,i,j,k,ispec) &
+ + deltat * ( factor_common_use(i,j,k)*epsilondev_loc(2,i,j,k) &
+ - R_yy(i_SLS,i,j,k,ispec)*(1.0_CUSTOM_REAL/tau_sigma_CUSTOM_REAL(i_SLS)) )
+
+ R_xy_lddrk(i_SLS,i,j,k,ispec) = ALPHA_LDDRK(istage) * R_xy_lddrk(i_SLS,i,j,k,ispec) &
+ + deltat * ( factor_common_use(i,j,k)*epsilondev_loc(3,i,j,k) &
+ - R_xy(i_SLS,i,j,k,ispec)*(1.0_CUSTOM_REAL/tau_sigma_CUSTOM_REAL(i_SLS)) )
+
+ R_xz_lddrk(i_SLS,i,j,k,ispec) = ALPHA_LDDRK(istage) * R_xz_lddrk(i_SLS,i,j,k,ispec) &
+ + deltat * ( factor_common_use(i,j,k)*epsilondev_loc(4,i,j,k) &
+ - R_xz(i_SLS,i,j,k,ispec)*(1.0_CUSTOM_REAL/tau_sigma_CUSTOM_REAL(i_SLS)) )
+
+ R_yz_lddrk(i_SLS,i,j,k,ispec) = ALPHA_LDDRK(istage) * R_yz_lddrk(i_SLS,i,j,k,ispec) &
+ + deltat * ( factor_common_use(i,j,k)*epsilondev_loc(5,i,j,k) &
+ - R_yz(i_SLS,i,j,k,ispec)*(1.0_CUSTOM_REAL/tau_sigma_CUSTOM_REAL(i_SLS)) )
+
+ R_xx(i_SLS,i,j,k,ispec) = R_xx(i_SLS,i,j,k,ispec) + BETA_LDDRK(istage) * R_xx_lddrk(i_SLS,i,j,k,ispec)
+ R_yy(i_SLS,i,j,k,ispec) = R_yy(i_SLS,i,j,k,ispec) + BETA_LDDRK(istage) * R_yy_lddrk(i_SLS,i,j,k,ispec)
+ R_xy(i_SLS,i,j,k,ispec) = R_xy(i_SLS,i,j,k,ispec) + BETA_LDDRK(istage) * R_xy_lddrk(i_SLS,i,j,k,ispec)
+ R_xz(i_SLS,i,j,k,ispec) = R_xz(i_SLS,i,j,k,ispec) + BETA_LDDRK(istage) * R_xz_lddrk(i_SLS,i,j,k,ispec)
+ R_yz(i_SLS,i,j,k,ispec) = R_yz(i_SLS,i,j,k,ispec) + BETA_LDDRK(istage) * R_yz_lddrk(i_SLS,i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine compute_element_att_memory_ic_lddrk
+
+
+!
+!--------------------------------------------------------------------------------------------
+!
+! helper functions
+!
+
+
+ subroutine compute_element_att_mem_up_cm(ispec,i,j,k, &
+ R_xx_loc,R_yy_loc,R_xy_loc,R_xz_loc,R_yz_loc, &
+ epsilondev_loc,c44_muv,is_backward_field)
+! crust mantle
+! update memory variables based upon the Runge-Kutta scheme
+
+
+!daniel: att - debug update
+ use specfem_par,only: tau_sigma_dble,deltat,b_deltat
+
+ use specfem_par_crustmantle,only: factor_common=>factor_common_crust_mantle
+
+ use constants_solver
+
+ implicit none
+
+ ! element id
+ integer :: ispec,i,j,k
+
+ ! 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
+! real(kind=CUSTOM_REAL), dimension(5,N_SLS) :: R_memory_loc
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: R_xx_loc
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: R_yy_loc
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: R_xy_loc
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: R_xz_loc
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: R_yz_loc
+
+ real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
+ real(kind=CUSTOM_REAL) :: c44_muv
+
+ logical :: is_backward_field
+ double precision :: dt,kappa
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: factor_common_c44_muv
+ integer :: i_SLS
+
+ if( .not. is_backward_field ) then
+ dt = dble(deltat)
+ else
+ ! backward/reconstruction: reverse time
+ dt = dble(b_deltat)
+ endif
+
+ do i_SLS = 1,N_SLS
+
+ ! runge-kutta scheme to update memory variables R(t)
+ if( .false. ) then
+! classical RK 4: R'(t) = - 1/tau * R(t)
+!
+! Butcher RK4:
+! 0 |
+! 1/2 | 1/2
+! 1/2 | 0 1/2
+! 1 | 0 1
+! -----------------------------------------------------------------------------
+! 1/6 1/3 1/3 1/6
+ kappa = - dt/tau_sigma_dble(i_SLS)
+
+ R_xx_loc(i_SLS) = R_xx_loc(i_SLS) * &
+ (1.0d0 + kappa*(1.d0 + 0.5d0*kappa*(1.d0 + 1.0d0/6.0d0*kappa*(1.d0 + 1.0d0/24.0d0*kappa))))
+ R_yy_loc(i_SLS) = R_yy_loc(i_SLS) * &
+ (1.0d0 + kappa*(1.d0 + 0.5d0*kappa*(1.d0 + 1.0d0/6.0d0*kappa*(1.d0 + 1.0d0/24.0d0*kappa))))
+ R_xy_loc(i_SLS) = R_xy_loc(i_SLS) * &
+ (1.0d0 + kappa*(1.d0 + 0.5d0*kappa*(1.d0 + 1.0d0/6.0d0*kappa*(1.d0 + 1.0d0/24.0d0*kappa))))
+ R_xz_loc(i_SLS) = R_xz_loc(i_SLS) * &
+ (1.0d0 + kappa*(1.d0 + 0.5d0*kappa*(1.d0 + 1.0d0/6.0d0*kappa*(1.d0 + 1.0d0/24.0d0*kappa))))
+ R_yz_loc(i_SLS) = R_yz_loc(i_SLS) * &
+ (1.0d0 + kappa*(1.d0 + 0.5d0*kappa*(1.d0 + 1.0d0/6.0d0*kappa*(1.d0 + 1.0d0/24.0d0*kappa))))
+ endif
+
+ ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
+ if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) then
+ factor_common_c44_muv = factor_common(i_SLS,i,j,k,ispec) * c44_muv
+ else
+ factor_common_c44_muv = factor_common(i_SLS,1,1,1,ispec) * c44_muv
+ endif
+
+ ! adds contributions from current strain
+ R_xx_loc(i_SLS) = R_xx_loc(i_SLS) + 0.5d0 * dt * dble(factor_common_c44_muv) * dble(epsilondev_loc(1))
+ R_yy_loc(i_SLS) = R_yy_loc(i_SLS) + 0.5d0 * dt * dble(factor_common_c44_muv) * dble(epsilondev_loc(2))
+ R_xy_loc(i_SLS) = R_xy_loc(i_SLS) + 0.5d0 * dt * dble(factor_common_c44_muv) * dble(epsilondev_loc(3))
+ R_xz_loc(i_SLS) = R_xz_loc(i_SLS) + 0.5d0 * dt * dble(factor_common_c44_muv) * dble(epsilondev_loc(4))
+ R_yz_loc(i_SLS) = R_yz_loc(i_SLS) + 0.5d0 * dt * dble(factor_common_c44_muv) * dble(epsilondev_loc(5))
+
+ enddo ! i_SLS
+
+ end subroutine compute_element_att_mem_up_cm
+
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element_strain.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element_strain.F90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_element_strain.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -26,7 +26,8 @@
!=====================================================================
- subroutine compute_element_strain_undo_att_Dev(ispec,nglob,nspec, &
+
+ subroutine compute_element_strain_undo_att_Dev(ispec,nglob,nspec, &
displ,ibool, &
hprime_xx,hprime_xxT,&
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
@@ -53,6 +54,7 @@
! local variable
integer :: i,j,k,iglob
+ real(kind=CUSTOM_REAL) :: templ
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc
@@ -219,9 +221,10 @@
duzdyl_plus_duydzl = duzdyl + duydzl
! strains
- eps_trace_over_3_loc(ijk,1,1) = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(1,ijk,1,1) = duxdxl - eps_trace_over_3_loc(ijk,1,1)
- epsilondev_loc(2,ijk,1,1) = duydyl - eps_trace_over_3_loc(ijk,1,1)
+ templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ eps_trace_over_3_loc(ijk,1,1) = templ
+ epsilondev_loc(1,ijk,1,1) = duxdxl - templ
+ epsilondev_loc(2,ijk,1,1) = duydyl - templ
epsilondev_loc(3,ijk,1,1) = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
epsilondev_loc(4,ijk,1,1) = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
epsilondev_loc(5,ijk,1,1) = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
@@ -267,9 +270,10 @@
duzdyl_plus_duydzl = duzdyl + duydzl
! strains
- eps_trace_over_3_loc(i,j,k) = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(1,i,j,k) = duxdxl - eps_trace_over_3_loc(i,j,k)
- epsilondev_loc(2,i,j,k) = duydyl - eps_trace_over_3_loc(i,j,k)
+ templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ eps_trace_over_3_loc(i,j,k) = templ
+ epsilondev_loc(1,i,j,k) = duxdxl - templ
+ epsilondev_loc(2,i,j,k) = duydyl - templ
epsilondev_loc(3,i,j,k) = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
epsilondev_loc(4,i,j,k) = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
epsilondev_loc(5,i,j,k) = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
@@ -423,15 +427,24 @@
end subroutine compute_element_strain_undo_att_noDev
+!--------------------------------------------------------------------------------------------
!
+! strain separated into single xx,yy,xy,xz,yz-component arrays
+!
!--------------------------------------------------------------------------------------------
!
subroutine compute_element_strain_att_Dev(ispec,nglob,nspec, &
- displ,veloc,deltat,ibool, &
+ displ,veloc,deltat, &
+ ibool, &
hprime_xx,hprime_xxT,&
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- epsilondev_loc_nplus1,eps_trace_over_3_loc_nplus1)
+ epsilondev_xx_loc_nplus1, &
+ epsilondev_yy_loc_nplus1, &
+ epsilondev_xy_loc_nplus1, &
+ epsilondev_xz_loc_nplus1, &
+ epsilondev_yz_loc_nplus1, &
+ eps_trace_over_3_loc_nplus1)
use constants
@@ -447,7 +460,12 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_nplus1
+ !real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_nplus1
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xx_loc_nplus1
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_yy_loc_nplus1
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xy_loc_nplus1
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xz_loc_nplus1
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_yz_loc_nplus1
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: eps_trace_over_3_loc_nplus1
! local variable
@@ -613,11 +631,11 @@
templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
eps_trace_over_3_loc_nplus1 = templ
- epsilondev_loc_nplus1(1,ijk,1,1) = duxdxl - templ
- epsilondev_loc_nplus1(2,ijk,1,1) = duydyl - templ
- epsilondev_loc_nplus1(3,ijk,1,1) = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
- epsilondev_loc_nplus1(4,ijk,1,1) = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
- epsilondev_loc_nplus1(5,ijk,1,1) = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
+ epsilondev_xx_loc_nplus1(ijk,1,1) = duxdxl - templ
+ epsilondev_yy_loc_nplus1(ijk,1,1) = duydyl - templ
+ epsilondev_xy_loc_nplus1(ijk,1,1) = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
+ epsilondev_xz_loc_nplus1(ijk,1,1) = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
+ epsilondev_yz_loc_nplus1(ijk,1,1) = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
enddo
#else
do k=1,NGLLZ
@@ -661,11 +679,11 @@
templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
eps_trace_over_3_loc_nplus1 = templ
- epsilondev_loc_nplus1(1,i,j,k) = duxdxl - templ
- epsilondev_loc_nplus1(2,i,j,k) = duydyl - templ
- epsilondev_loc_nplus1(3,i,j,k) = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
- epsilondev_loc_nplus1(4,i,j,k) = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
- epsilondev_loc_nplus1(5,i,j,k) = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
+ epsilondev_xx_loc_nplus1(i,j,k) = duxdxl - templ
+ epsilondev_yy_loc_nplus1(i,j,k) = duydyl - templ
+ epsilondev_xy_loc_nplus1(i,j,k) = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
+ epsilondev_xz_loc_nplus1(i,j,k) = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
+ epsilondev_yz_loc_nplus1(i,j,k) = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
enddo
enddo
enddo
@@ -673,3 +691,161 @@
end subroutine compute_element_strain_att_Dev
+
+!
+!--------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_element_strain_att_noDev(ispec,nglob,nspec, &
+ displ,veloc,deltat, &
+ ibool, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ epsilondev_xx_loc_nplus1, &
+ epsilondev_yy_loc_nplus1, &
+ epsilondev_xy_loc_nplus1, &
+ epsilondev_xz_loc_nplus1, &
+ epsilondev_yz_loc_nplus1, &
+ eps_trace_over_3_loc_nplus1)
+
+ use constants
+
+ implicit none
+
+ integer :: ispec,nglob,nspec
+ real(kind=CUSTOM_REAL) :: deltat
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,nglob) :: displ,veloc
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ ! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX),intent(in) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY),intent(in) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ),intent(in) :: hprime_zz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+ !real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_nplus1
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xx_loc_nplus1
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_yy_loc_nplus1
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xy_loc_nplus1
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xz_loc_nplus1
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_yz_loc_nplus1
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: eps_trace_over_3_loc_nplus1
+
+ ! local variable
+ integer :: i,j,k,l,iglob
+ real(kind=CUSTOM_REAL) :: templ
+
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc
+
+ real(kind=CUSTOM_REAL) hp1,hp2,hp3
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ 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
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob) + deltat * veloc(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob) + deltat * veloc(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob) + deltat * veloc(3,iglob)
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ tempx1l = tempx1l + dummyx_loc(l,j,k)*hp1
+ tempy1l = tempy1l + dummyy_loc(l,j,k)*hp1
+ tempz1l = tempz1l + dummyz_loc(l,j,k)*hp1
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(j,l)
+ tempx2l = tempx2l + dummyx_loc(i,l,k)*hp2
+ tempy2l = tempy2l + dummyy_loc(i,l,k)*hp2
+ tempz2l = tempz2l + dummyz_loc(i,l,k)*hp2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(k,l)
+ tempx3l = tempx3l + dummyx_loc(i,j,l)*hp3
+ tempy3l = tempy3l + dummyy_loc(i,j,l)*hp3
+ tempz3l = tempz3l + dummyz_loc(i,j,l)*hp3
+ enddo
+
+ ! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+ ! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+
+ duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+
+ ! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
+
+ templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ eps_trace_over_3_loc_nplus1 = templ
+ epsilondev_xx_loc_nplus1(i,j,k) = duxdxl - templ
+ epsilondev_yy_loc_nplus1(i,j,k) = duydyl - templ
+ epsilondev_xy_loc_nplus1(i,j,k) = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
+ epsilondev_xz_loc_nplus1(i,j,k) = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
+ epsilondev_yz_loc_nplus1(i,j,k) = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_element_strain_att_noDev
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_acoustic_calling_routine.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_acoustic_calling_routine.F90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_acoustic_calling_routine.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -46,10 +46,20 @@
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)
+
+ ! current simulated time
+ if(USE_LDDRK)then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(it-1)*DT+dble(C_LDDRK(istage))*DT-t0)*scale_t_inv)
+ else
+ time = (dble(it-1)*DT+dble(C_LDDRK(istage))*DT-t0)*scale_t_inv
+ endif
else
- time = (dble(it-1)*DT-t0)*scale_t_inv
+ 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
endif
! ****************************************************
@@ -75,17 +85,19 @@
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)
+ NSPEC_OUTER_CORE_ROTATION,NGLOB_OUTER_CORE, &
+ A_array_rotation,B_array_rotation, &
+ A_array_rotation_lddrk,B_array_rotation_lddrk, &
+ 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)
+ NSPEC_OUTER_CORE_ROTATION,NGLOB_OUTER_CORE, &
+ A_array_rotation,B_array_rotation, &
+ A_array_rotation_lddrk,B_array_rotation_lddrk, &
+ displ_outer_core,accel_outer_core, &
+ div_displ_outer_core,phase_is_inner)
endif
else
! on GPU
@@ -161,12 +173,12 @@
! on GPU
! outer core
call assemble_MPI_scalar_send_cuda(Mesh_pointer,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
+ 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
else
! make sure the last communications are finished and processed
@@ -174,34 +186,33 @@
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)
+ 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(Mesh_pointer,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
+ 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
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 update_veloc_acoustic(NGLOB_OUTER_CORE,veloc_outer_core,accel_outer_core, &
- deltatover2,rmass_outer_core)
+ ! multiply by the inverse of the mass matrix
+ call it_multiply_accel_acoustic(NGLOB_OUTER_CORE,accel_outer_core,rmass_outer_core)
+
+ ! time schemes
+ if( USE_LDDRK ) then
+ ! runge-kutta scheme
+ call update_veloc_acoustic_lddrk()
else
- ! on GPU
- ! includes FORWARD_OR_ADJOINT == 1
- call kernel_3_outer_core_cuda(Mesh_pointer,deltatover2,1)
+ ! Newmark time scheme
+ call update_veloc_acoustic_newmark()
endif
end subroutine compute_forces_acoustic
@@ -241,12 +252,30 @@
! 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)
+
+ ! current simulated time
+ if(USE_LDDRK)then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ b_time = sngl((dble(NSTEP-it)*DT-dble(C_LDDRK(istage))*DT-t0)*scale_t_inv)
+ else
+ b_time = (dble(NSTEP-it)*DT-dble(C_LDDRK(istage))*DT-t0)*scale_t_inv
+ endif
else
- b_time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
+ 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
+ if(UNDO_ATTENUATION)then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ b_time = sngl((dble(NSTEP-(iteration_on_subset*NT_DUMP_ATTENUATION-it_of_this_subset+1))*DT-t0)*scale_t_inv)
+ else
+ b_time = (dble(NSTEP-(iteration_on_subset*NT_DUMP_ATTENUATION-it_of_this_subset+1))*DT-t0)*scale_t_inv
+ endif
+ endif
+
! ****************************************************
! big loop over all spectral elements in the fluid
! ****************************************************
@@ -271,16 +300,18 @@
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)
+ NSPEC_OUTER_CORE_ROT_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ b_A_array_rotation,b_B_array_rotation, &
+ b_A_array_rotation_lddrk,b_B_array_rotation_lddrk, &
+ 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)
+ NSPEC_OUTER_CORE_ROT_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ b_A_array_rotation,b_B_array_rotation, &
+ b_A_array_rotation_lddrk,b_B_array_rotation_lddrk, &
+ b_displ_outer_core,b_accel_outer_core, &
+ b_div_displ_outer_core,phase_is_inner)
endif
else
! on GPU
@@ -292,50 +323,56 @@
! 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_backward()
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ if(UNDO_ATTENUATION)then
+ call compute_stacey_outer_core_backward_undoatt()
+ else
+ call compute_stacey_outer_core_backward()
+ endif
+ endif
- ! ****************************************************
- ! ********** 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(b_displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- NSPEC2D_TOP(IREGION_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(b_displ_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ b_accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ 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(b_displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- 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,3)
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if( ACTUALLY_COUPLE_FLUID_ICB ) &
- call compute_coupling_fluid_icb_cuda(Mesh_pointer,3)
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) &
+ call compute_coupling_fluid_ICB(b_displ_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ b_accel_outer_core, &
+ normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
+ 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,3)
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if( ACTUALLY_COUPLE_FLUID_ICB ) &
+ call compute_coupling_fluid_icb_cuda(Mesh_pointer,3)
- endif
+ endif
endif ! iphase == 1
! assemble all the contributions between slices using MPI
@@ -387,18 +424,16 @@
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
- ! adjoint / kernel runs
- call update_veloc_acoustic(NGLOB_OUTER_CORE_ADJOINT,b_veloc_outer_core,b_accel_outer_core, &
- b_deltatover2,rmass_outer_core)
+ ! multiply by the inverse of the mass matrix
+ call it_multiply_accel_acoustic(NGLOB_OUTER_CORE_ADJOINT,b_accel_outer_core,b_rmass_outer_core)
+
+ ! time schemes
+ if( USE_LDDRK ) then
+ ! runge-kutta scheme
+ call update_veloc_acoustic_lddrk_backward()
else
- ! on GPU
- ! includes FORWARD_OR_ADJOINT == 3
- call kernel_3_outer_core_cuda(Mesh_pointer,b_deltatover2,3)
+ ! Newmark time scheme
+ call update_veloc_acoustic_newmark_backward()
endif
end subroutine compute_forces_acoustic_backward
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_crust_mantle_Dev.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -32,6 +32,7 @@
accel_crust_mantle, &
phase_is_inner, &
R_xx,R_yy,R_xy,R_xz,R_yz, &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk, &
epsilondev_xx,epsilondev_yy,epsilondev_xy, &
epsilondev_xz,epsilondev_yz, &
epsilon_trace_over_3, &
@@ -45,7 +46,7 @@
use specfem_par,only: &
hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
minus_gravity_table,density_table,minus_deriv_gravity_table, &
- COMPUTE_AND_STORE_STRAIN
+ COMPUTE_AND_STORE_STRAIN,USE_LDDRK
use specfem_par_crustmantle,only: &
xstore => xstore_crust_mantle,ystore => ystore_crust_mantle,zstore => zstore_crust_mantle, &
@@ -95,6 +96,8 @@
! memory variables R_ij are stored at the local rather than global level
! to allow for optimization of cache access by compiler
real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATT) :: R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATT) :: &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
@@ -161,12 +164,6 @@
integer :: num_elements,ispec_p
integer :: iphase
-! for LDDRK
-! integer :: istage
-! logical :: USE_LDDRK
-! real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION) :: R_memory_lddrk
-! real(kind=CUSTOM_REAL),dimension(N_SLS) :: tau_sigma_CUSTOM_REAL
-
#ifdef FORCE_VECTORIZATION
integer :: ijk
#endif
@@ -495,14 +492,24 @@
if( ATTENUATION_VAL .and. .not. PARTIAL_PHYS_DISPERSION_ONLY_VAL ) then
! updates R_memory
- call compute_element_att_memory_cm(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
- vnspec,factor_common, &
- alphaval,betaval,gammaval, &
- c44store,muvstore, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy, &
- epsilondev_xz,epsilondev_yz, &
- epsilondev_loc,is_backward_field)
-
+ if( USE_LDDRK ) then
+ call compute_element_att_memory_cm_lddrk(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk, &
+ ATT1_VAL,ATT2_VAL,ATT3_VAL,vnspec,factor_common, &
+ c44store,muvstore, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
+ epsilondev_xz,epsilondev_yz, &
+ epsilondev_loc, &
+ deltat)
+ else
+ call compute_element_att_memory_cm(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ ATT1_VAL,ATT2_VAL,ATT3_VAL,vnspec,factor_common, &
+ alphaval,betaval,gammaval, &
+ c44store,muvstore, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
+ 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_crust_mantle_noDev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_crust_mantle_noDev.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_crust_mantle_noDev.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -32,11 +32,12 @@
accel_crust_mantle, &
phase_is_inner, &
R_xx,R_yy,R_xy,R_xz,R_yz, &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk, &
epsilondev_xx,epsilondev_yy,epsilondev_xy, &
epsilondev_xz,epsilondev_yz, &
epsilon_trace_over_3, &
alphaval,betaval,gammaval, &
- factor_common,vnspec)
+ factor_common,vnspec,is_backward_field)
use constants_solver
@@ -44,7 +45,7 @@
hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
minus_gravity_table,density_table,minus_deriv_gravity_table, &
- COMPUTE_AND_STORE_STRAIN
+ COMPUTE_AND_STORE_STRAIN,USE_LDDRK
use specfem_par_crustmantle,only: &
xstore => xstore_crust_mantle,ystore => ystore_crust_mantle,zstore => zstore_crust_mantle, &
@@ -87,6 +88,8 @@
! memory variables R_ij are stored at the local rather than global level
! to allow for optimization of cache access by compiler
real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATT) :: R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATT) :: &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
@@ -99,12 +102,14 @@
! inner/outer element run flag
logical :: phase_is_inner
+ logical :: is_backward_field
+
! local parameters
! for attenuation
real(kind=CUSTOM_REAL) one_minus_sum_beta_use,minus_sum_beta
real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_c44_muv
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_c44_muv
real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
@@ -804,53 +809,25 @@
! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
if(ATTENUATION_VAL .and. .not. PARTIAL_PHYS_DISPERSION_ONLY_VAL ) then
-
-! use Runge-Kutta scheme to march in time
- do i_SLS = 1,N_SLS
-
-! 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
-
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL) 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
-
-! do i_memory = 1,5
-! R_memory(i_memory,i_SLS,:,:,:,ispec) = alphaval(i_SLS) * &
-! R_memory(i_memory,i_SLS,:,:,:,ispec) + &
-! factor_common_c44_muv * &
-! (betaval(i_SLS) * epsilondev(i_memory,:,:,:,ispec) + &
-! gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
-! enddo
-
- R_xx(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xx(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xx(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(1,:,:,:))
-
- R_yy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yy(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(2,:,:,:))
-
- R_xy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xy(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(3,:,:,:))
-
- R_xz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xz(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(4,:,:,:))
-
- R_yz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yz(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(5,:,:,:))
-
- enddo
+ ! updates R_memory
+ if( USE_LDDRK ) then
+ call compute_element_att_memory_cm_lddrk(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk, &
+ ATT1_VAL,ATT2_VAL,ATT3_VAL,vnspec,factor_common, &
+ c44store,muvstore, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
+ epsilondev_xz,epsilondev_yz, &
+ epsilondev_loc, &
+ deltat)
+ else
+ call compute_element_att_memory_cm(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ ATT1_VAL,ATT2_VAL,ATT3_VAL,vnspec,factor_common, &
+ alphaval,betaval,gammaval, &
+ c44store,muvstore, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
+ 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_inner_core_Dev.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_inner_core_Dev.F90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_inner_core_Dev.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -32,6 +32,7 @@
accel_inner_core, &
phase_is_inner, &
R_xx,R_yy,R_xy,R_xz,R_yz, &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk, &
epsilondev_xx,epsilondev_yy,epsilondev_xy, &
epsilondev_xz,epsilondev_yz, &
epsilon_trace_over_3,&
@@ -45,7 +46,7 @@
use specfem_par,only: &
hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
minus_gravity_table,density_table,minus_deriv_gravity_table, &
- COMPUTE_AND_STORE_STRAIN
+ COMPUTE_AND_STORE_STRAIN,USE_LDDRK
use specfem_par_innercore,only: &
xstore => xstore_inner_core,ystore => ystore_inner_core,zstore => zstore_inner_core, &
@@ -89,6 +90,9 @@
real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATT) :: &
R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATT) :: &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: epsilon_trace_over_3
@@ -337,9 +341,9 @@
epsilon_trace_over_3(i,j,k,ispec_strain) = templ
epsilondev_loc(1,i,j,k) = duxdxl - templ
epsilondev_loc(2,i,j,k) = duydyl - templ
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
+ epsilondev_loc(3,i,j,k) = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
+ epsilondev_loc(4,i,j,k) = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
+ epsilondev_loc(5,i,j,k) = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
endif
if(ANISOTROPIC_INNER_CORE_VAL) then
@@ -685,7 +689,11 @@
do j=1,NGLLY
do i=1,NGLLX
iglob = ibool(i,j,k,ispec)
- accel_inner_core(:,iglob) = accel_inner_core(:,iglob) + sum_terms(:,i,j,k)
+ ! do NOT use array syntax ":" for the three statements below
+ ! otherwise most compilers will not be able to vectorize the outer loop
+ accel_inner_core(1,iglob) = accel_inner_core(1,iglob) + sum_terms(1,i,j,k)
+ accel_inner_core(2,iglob) = accel_inner_core(2,iglob) + sum_terms(2,i,j,k)
+ accel_inner_core(3,iglob) = accel_inner_core(3,iglob) + sum_terms(3,i,j,k)
enddo
enddo
enddo
@@ -706,16 +714,25 @@
! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
if( ATTENUATION_VAL .and. .not. PARTIAL_PHYS_DISPERSION_ONLY_VAL ) then
-
! updates R_memory
- call compute_element_att_memory_ic(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
- vnspec,factor_common, &
- alphaval,betaval,gammaval, &
- muvstore, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy, &
- epsilondev_xz,epsilondev_yz, &
- epsilondev_loc,is_backward_field)
-
+ if( USE_LDDRK ) then
+ call compute_element_att_memory_ic_lddrk(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk, &
+ ATT1_VAL,ATT2_VAL,ATT3_VAL,vnspec,factor_common, &
+ muvstore, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
+ epsilondev_xz,epsilondev_yz, &
+ epsilondev_loc, &
+ deltat)
+ else
+ call compute_element_att_memory_ic(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ ATT1_VAL,ATT2_VAL,ATT3_VAL,vnspec,factor_common, &
+ alphaval,betaval,gammaval, &
+ muvstore, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
+ 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_inner_core_noDev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_inner_core_noDev.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_inner_core_noDev.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -32,11 +32,12 @@
accel_inner_core, &
phase_is_inner, &
R_xx,R_yy,R_xy,R_xz,R_yz, &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk, &
epsilondev_xx,epsilondev_yy,epsilondev_xy, &
epsilondev_xz,epsilondev_yz, &
epsilon_trace_over_3,&
alphaval,betaval,gammaval,factor_common, &
- vnspec)
+ vnspec,is_backward_field)
use constants_solver
@@ -44,7 +45,7 @@
hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
minus_gravity_table,density_table,minus_deriv_gravity_table, &
- COMPUTE_AND_STORE_STRAIN
+ COMPUTE_AND_STORE_STRAIN,USE_LDDRK
use specfem_par_innercore,only: &
xstore => xstore_inner_core,ystore => ystore_inner_core,zstore => zstore_inner_core, &
@@ -84,6 +85,8 @@
real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATT) :: R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATT) :: &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
@@ -92,18 +95,16 @@
! inner/outer element run flag
logical :: phase_is_inner
- ! local parameters
+ logical :: is_backward_field
+ ! local parameters
real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_use
- real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
- integer i_SLS
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
- integer ispec,iglob,ispec_strain
- integer i,j,k,l
+ integer :: ispec,iglob,ispec_strain
+ integer :: i,j,k,l
real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
@@ -126,6 +127,9 @@
real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+ real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
+ integer :: i_SLS
+
! for gravity
double precision radius,rho,minus_g,minus_dg
double precision minus_g_over_radius,minus_dg_plus_g_over_radius
@@ -163,450 +167,432 @@
! exclude fictitious elements in central cube
if(idoubling(ispec) /= IFLAG_IN_FICTITIOUS_CUBE) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
- tempy1l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
- tempz1l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l = tempx1l + displ_inner_core(1,iglob)*hp1
- tempy1l = tempy1l + displ_inner_core(2,iglob)*hp1
- tempz1l = tempz1l + displ_inner_core(3,iglob)*hp1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + displ_inner_core(1,iglob)*hp1
+ tempy1l = tempy1l + displ_inner_core(2,iglob)*hp1
+ tempz1l = tempz1l + displ_inner_core(3,iglob)*hp1
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l = tempx2l + displ_inner_core(1,iglob)*hp2
- tempy2l = tempy2l + displ_inner_core(2,iglob)*hp2
- tempz2l = tempz2l + displ_inner_core(3,iglob)*hp2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(j,l)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + displ_inner_core(1,iglob)*hp2
+ tempy2l = tempy2l + displ_inner_core(2,iglob)*hp2
+ tempz2l = tempz2l + displ_inner_core(3,iglob)*hp2
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l = tempx3l + displ_inner_core(1,iglob)*hp3
- tempy3l = tempy3l + displ_inner_core(2,iglob)*hp3
- tempz3l = tempz3l + displ_inner_core(3,iglob)*hp3
- enddo
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(k,l)
+ iglob = ibool(i,j,l,ispec)
+ tempx3l = tempx3l + displ_inner_core(1,iglob)*hp3
+ tempy3l = tempy3l + displ_inner_core(2,iglob)*hp3
+ tempz3l = tempz3l + displ_inner_core(3,iglob)*hp3
+ enddo
-! get derivatives of ux, uy and uz with respect to x, y and z
+ ! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
+ ! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
- ! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
+ duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
- duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+ duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
- duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
- duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
- duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+ duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
- duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
- duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
- duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+ ! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
- ! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
-
- ! compute deviatoric strain
- if (COMPUTE_AND_STORE_STRAIN) then
- if(NSPEC_INNER_CORE_STRAIN_ONLY == 1) then
- ispec_strain = 1
- else
- ispec_strain = ispec
+ ! compute deviatoric strain
+ if (COMPUTE_AND_STORE_STRAIN) then
+ if(NSPEC_INNER_CORE_STRAIN_ONLY == 1) then
+ ispec_strain = 1
+ else
+ ispec_strain = ispec
+ endif
+ epsilon_trace_over_3(i,j,k,ispec_strain) = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(1,i,j,k) = duxdxl - epsilon_trace_over_3(i,j,k,ispec_strain)
+ epsilondev_loc(2,i,j,k) = duydyl - epsilon_trace_over_3(i,j,k,ispec_strain)
+ epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
endif
- epsilon_trace_over_3(i,j,k,ispec_strain) = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(1,i,j,k) = duxdxl - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(2,i,j,k) = duydyl - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
- endif
- if(ANISOTROPIC_INNER_CORE_VAL) then
- ! elastic tensor for hexagonal symmetry in reduced notation:
- !
- ! c11 c12 c13 0 0 0
- ! c12 c11 c13 0 0 0
- ! c13 c13 c33 0 0 0
- ! 0 0 0 c44 0 0
- ! 0 0 0 0 c44 0
- ! 0 0 0 0 0 (c11-c12)/2
- !
- ! in terms of the A, C, L, N and F of Love (1927):
- !
- ! c11 = A
- ! c12 = A-2N
- ! c13 = F
- ! c33 = C
- ! c44 = L
- c11l = c11store(i,j,k,ispec)
- c12l = c12store(i,j,k,ispec)
- c13l = c13store(i,j,k,ispec)
- c33l = c33store(i,j,k,ispec)
- c44l = c44store(i,j,k,ispec)
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+ ! elastic tensor for hexagonal symmetry in reduced notation:
+ !
+ ! c11 c12 c13 0 0 0
+ ! c12 c11 c13 0 0 0
+ ! c13 c13 c33 0 0 0
+ ! 0 0 0 c44 0 0
+ ! 0 0 0 0 c44 0
+ ! 0 0 0 0 0 (c11-c12)/2
+ !
+ ! in terms of the A, C, L, N and F of Love (1927):
+ !
+ ! c11 = A
+ ! c12 = A-2N
+ ! c13 = F
+ ! c33 = C
+ ! c44 = L
+ c11l = c11store(i,j,k,ispec)
+ c12l = c12store(i,j,k,ispec)
+ c13l = c13store(i,j,k,ispec)
+ c33l = c33store(i,j,k,ispec)
+ c44l = c44store(i,j,k,ispec)
- ! use unrelaxed parameters if attenuation
- if(ATTENUATION_VAL) then
- if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) then
- minus_sum_beta = one_minus_sum_beta(i,j,k,ispec) - 1.0_CUSTOM_REAL
- else
- minus_sum_beta = one_minus_sum_beta(1,1,1,ispec) - 1.0_CUSTOM_REAL
+ ! use unrelaxed parameters if attenuation
+ if(ATTENUATION_VAL) then
+ if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) then
+ minus_sum_beta = one_minus_sum_beta(i,j,k,ispec) - 1.0_CUSTOM_REAL
+ else
+ minus_sum_beta = one_minus_sum_beta(1,1,1,ispec) - 1.0_CUSTOM_REAL
+ endif
+ mul = muvstore(i,j,k,ispec)
+ c11l = c11l + FOUR_THIRDS * minus_sum_beta * mul
+ c12l = c12l - TWO_THIRDS * minus_sum_beta * mul
+ c13l = c13l - TWO_THIRDS * minus_sum_beta * mul
+ c33l = c33l + FOUR_THIRDS * minus_sum_beta * mul
+ c44l = c44l + minus_sum_beta * mul
endif
- mul = muvstore(i,j,k,ispec)
- c11l = c11l + FOUR_THIRDS * minus_sum_beta * mul
- c12l = c12l - TWO_THIRDS * minus_sum_beta * mul
- c13l = c13l - TWO_THIRDS * minus_sum_beta * mul
- c33l = c33l + FOUR_THIRDS * minus_sum_beta * mul
- c44l = c44l + minus_sum_beta * mul
- endif
- sigma_xx = c11l*duxdxl + c12l*duydyl + c13l*duzdzl
- sigma_yy = c12l*duxdxl + c11l*duydyl + c13l*duzdzl
- sigma_zz = c13l*duxdxl + c13l*duydyl + c33l*duzdzl
- sigma_xy = 0.5*(c11l-c12l)*duxdyl_plus_duydxl
- sigma_xz = c44l*duzdxl_plus_duxdzl
- sigma_yz = c44l*duzdyl_plus_duydzl
- else
+ sigma_xx = c11l*duxdxl + c12l*duydyl + c13l*duzdzl
+ sigma_yy = c12l*duxdxl + c11l*duydyl + c13l*duzdzl
+ sigma_zz = c13l*duxdxl + c13l*duydyl + c33l*duzdzl
+ sigma_xy = 0.5*(c11l-c12l)*duxdyl_plus_duydxl
+ sigma_xz = c44l*duzdxl_plus_duxdzl
+ sigma_yz = c44l*duzdyl_plus_duydzl
+ else
- ! inner core with no anisotropy, use kappav and muv for instance
- ! layer with no anisotropy, use kappav and muv for instance
- kappal = kappavstore(i,j,k,ispec)
- mul = muvstore(i,j,k,ispec)
+ ! inner core with no anisotropy, use kappav and muv for instance
+ ! layer with no anisotropy, use kappav and muv for instance
+ kappal = kappavstore(i,j,k,ispec)
+ mul = muvstore(i,j,k,ispec)
- ! use unrelaxed parameters if attenuation
- if( ATTENUATION_VAL ) then
- if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) then
- mul = mul * one_minus_sum_beta(i,j,k,ispec)
- else
- mul = mul * one_minus_sum_beta(1,1,1,ispec)
+ ! use unrelaxed parameters if attenuation
+ if( ATTENUATION_VAL ) then
+ if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) then
+ mul = mul * one_minus_sum_beta(i,j,k,ispec)
+ else
+ mul = mul * one_minus_sum_beta(1,1,1,ispec)
+ endif
endif
- endif
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
- ! compute stress sigma
- sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+ ! compute stress sigma
+ sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
- endif
+ endif
- ! subtract memory variables if attenuation
- if( ATTENUATION_VAL .and. .not. PARTIAL_PHYS_DISPERSION_ONLY_VAL ) then
- do i_SLS = 1,N_SLS
- R_xx_val = R_xx(i_SLS,i,j,k,ispec)
- R_yy_val = R_yy(i_SLS,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val
- sigma_yy = sigma_yy - R_yy_val
- sigma_zz = sigma_zz + R_xx_val + R_yy_val
- sigma_xy = sigma_xy - R_xy(i_SLS,i,j,k,ispec)
- sigma_xz = sigma_xz - R_xz(i_SLS,i,j,k,ispec)
- sigma_yz = sigma_yz - R_yz(i_SLS,i,j,k,ispec)
- enddo
- endif
+ ! subtract memory variables if attenuation
+ if( ATTENUATION_VAL .and. .not. PARTIAL_PHYS_DISPERSION_ONLY_VAL ) then
+ do i_SLS = 1,N_SLS
+ R_xx_val = R_xx(i_SLS,i,j,k,ispec)
+ R_yy_val = R_yy(i_SLS,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val
+ sigma_yy = sigma_yy - R_yy_val
+ sigma_zz = sigma_zz + R_xx_val + R_yy_val
+ sigma_xy = sigma_xy - R_xy(i_SLS,i,j,k,ispec)
+ sigma_xz = sigma_xz - R_xz(i_SLS,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_yz(i_SLS,i,j,k,ispec)
+ enddo
+ endif
- ! define symmetric components of sigma for gravity
- sigma_yx = sigma_xy
- sigma_zx = sigma_xz
- sigma_zy = sigma_yz
+ ! define symmetric components of sigma for gravity
+ sigma_yx = sigma_xy
+ sigma_zx = sigma_xz
+ sigma_zy = sigma_yz
- ! compute non-symmetric terms for gravity
- if(GRAVITY_VAL) then
+ ! compute non-symmetric terms for gravity
+ if(GRAVITY_VAL) then
- ! use mesh coordinates to get theta and phi
- ! x y and z contain r theta and phi
- iglob = ibool(i,j,k,ispec)
- radius = dble(xstore(iglob))
- theta = dble(ystore(iglob))
- phi = dble(zstore(iglob))
+ ! use mesh coordinates to get theta and phi
+ ! x y and z contain r theta and phi
+ iglob = ibool(i,j,k,ispec)
+ radius = dble(xstore(iglob))
+ theta = dble(ystore(iglob))
+ phi = dble(zstore(iglob))
- ! make sure radius is never zero even for points at center of cube
- ! because we later divide by radius
- if(radius < 100.d0 / R_EARTH) radius = 100.d0 / R_EARTH
+ ! make sure radius is never zero even for points at center of cube
+ ! because we later divide by radius
+ if(radius < 100.d0 / R_EARTH) radius = 100.d0 / R_EARTH
- cos_theta = dcos(theta)
- sin_theta = dsin(theta)
- cos_phi = dcos(phi)
- sin_phi = dsin(phi)
+ cos_theta = dcos(theta)
+ sin_theta = dsin(theta)
+ cos_phi = dcos(phi)
+ sin_phi = dsin(phi)
- ! get g, rho and dg/dr=dg
- ! spherical components of the gravitational acceleration
- ! for efficiency replace with lookup table every 100 m in radial direction
- ! make sure we never use zero for point exactly at the center of the Earth
- int_radius = max(1,nint(radius * R_EARTH_KM * 10.d0))
- minus_g = minus_gravity_table(int_radius)
- minus_dg = minus_deriv_gravity_table(int_radius)
- rho = density_table(int_radius)
+ ! get g, rho and dg/dr=dg
+ ! spherical components of the gravitational acceleration
+ ! for efficiency replace with lookup table every 100 m in radial direction
+ ! make sure we never use zero for point exactly at the center of the Earth
+ int_radius = max(1,nint(radius * R_EARTH_KM * 10.d0))
+ minus_g = minus_gravity_table(int_radius)
+ minus_dg = minus_deriv_gravity_table(int_radius)
+ rho = density_table(int_radius)
- ! Cartesian components of the gravitational acceleration
- gxl = minus_g*sin_theta*cos_phi
- gyl = minus_g*sin_theta*sin_phi
- gzl = minus_g*cos_theta
+ ! Cartesian components of the gravitational acceleration
+ gxl = minus_g*sin_theta*cos_phi
+ gyl = minus_g*sin_theta*sin_phi
+ gzl = minus_g*cos_theta
- ! Cartesian components of gradient of gravitational acceleration
- ! obtained from spherical components
- minus_g_over_radius = minus_g / radius
- minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
+ ! Cartesian components of gradient of gravitational acceleration
+ ! obtained from spherical components
+ minus_g_over_radius = minus_g / radius
+ minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
- cos_theta_sq = cos_theta**2
- sin_theta_sq = sin_theta**2
- cos_phi_sq = cos_phi**2
- sin_phi_sq = sin_phi**2
+ cos_theta_sq = cos_theta**2
+ sin_theta_sq = sin_theta**2
+ cos_phi_sq = cos_phi**2
+ sin_phi_sq = sin_phi**2
- Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
- Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
- Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
- Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
- Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
- Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
+ Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
+ Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
+ Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
+ Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
+ Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
+ Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
- iglob = ibool(i,j,k,ispec)
+ iglob = ibool(i,j,k,ispec)
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
- ! get displacement and multiply by density to compute G tensor
- sx_l = rho * dble(displ_inner_core(1,iglob))
- sy_l = rho * dble(displ_inner_core(2,iglob))
- sz_l = rho * dble(displ_inner_core(3,iglob))
+ ! get displacement and multiply by density to compute G tensor
+ sx_l = rho * dble(displ_inner_core(1,iglob))
+ sy_l = rho * dble(displ_inner_core(2,iglob))
+ sz_l = rho * dble(displ_inner_core(3,iglob))
- ! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
- sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
- sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
+ ! compute G tensor from s . g and add to sigma (not symmetric)
+ sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
+ sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
+ sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
- sigma_xy = sigma_xy - sngl(sx_l * gyl)
- sigma_yx = sigma_yx - sngl(sy_l * gxl)
+ sigma_xy = sigma_xy - sngl(sx_l * gyl)
+ sigma_yx = sigma_yx - sngl(sy_l * gxl)
- sigma_xz = sigma_xz - sngl(sx_l * gzl)
- sigma_zx = sigma_zx - sngl(sz_l * gxl)
+ sigma_xz = sigma_xz - sngl(sx_l * gzl)
+ sigma_zx = sigma_zx - sngl(sz_l * gxl)
- sigma_yz = sigma_yz - sngl(sy_l * gzl)
- sigma_zy = sigma_zy - sngl(sz_l * gyl)
+ sigma_yz = sigma_yz - sngl(sy_l * gzl)
+ sigma_zy = sigma_zy - sngl(sz_l * gyl)
- ! precompute vector
- factor = dble(jacobianl) * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
- rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
- rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
+ ! precompute vector
+ factor = dble(jacobianl) * wgll_cube(i,j,k)
+ rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
+ rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
+ rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
- else
+ else
- ! get displacement and multiply by density to compute G tensor
- sx_l = rho * displ_inner_core(1,iglob)
- sy_l = rho * displ_inner_core(2,iglob)
- sz_l = rho * displ_inner_core(3,iglob)
+ ! get displacement and multiply by density to compute G tensor
+ sx_l = rho * displ_inner_core(1,iglob)
+ sy_l = rho * displ_inner_core(2,iglob)
+ sz_l = rho * displ_inner_core(3,iglob)
- ! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
- sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
- sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
+ ! compute G tensor from s . g and add to sigma (not symmetric)
+ sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
+ sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
+ sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
- sigma_xy = sigma_xy - sx_l * gyl
- sigma_yx = sigma_yx - sy_l * gxl
+ sigma_xy = sigma_xy - sx_l * gyl
+ sigma_yx = sigma_yx - sy_l * gxl
- sigma_xz = sigma_xz - sx_l * gzl
- sigma_zx = sigma_zx - sz_l * gxl
+ sigma_xz = sigma_xz - sx_l * gzl
+ sigma_zx = sigma_zx - sz_l * gxl
- sigma_yz = sigma_yz - sy_l * gzl
- sigma_zy = sigma_zy - sz_l * gyl
+ sigma_yz = sigma_yz - sy_l * gzl
+ sigma_zy = sigma_zy - sz_l * gyl
- ! precompute vector
- factor = jacobianl * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
- rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
- rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
+ ! precompute vector
+ factor = jacobianl * wgll_cube(i,j,k)
+ rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
+ rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
+ rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
- endif
+ endif
- endif ! end of section with gravity terms
+ 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)
+ ! 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)
- 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)
+ 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)
- 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)
+ 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)
+ enddo
enddo
enddo
- enddo
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
- tempx1l = 0._CUSTOM_REAL
- tempy1l = 0._CUSTOM_REAL
- tempz1l = 0._CUSTOM_REAL
+ tempx1l = 0._CUSTOM_REAL
+ tempy1l = 0._CUSTOM_REAL
+ tempz1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
- do l=1,NGLLX
- fac1 = hprimewgll_xx(l,i)
- tempx1l = tempx1l + tempx1(l,j,k)*fac1
- tempy1l = tempy1l + tempy1(l,j,k)*fac1
- tempz1l = tempz1l + tempz1(l,j,k)*fac1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ do l=1,NGLLX
+ fac1 = hprimewgll_xx(l,i)
+ tempx1l = tempx1l + tempx1(l,j,k)*fac1
+ tempy1l = tempy1l + tempy1(l,j,k)*fac1
+ tempz1l = tempz1l + tempz1(l,j,k)*fac1
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- fac2 = hprimewgll_yy(l,j)
- tempx2l = tempx2l + tempx2(i,l,k)*fac2
- tempy2l = tempy2l + tempy2(i,l,k)*fac2
- tempz2l = tempz2l + tempz2(i,l,k)*fac2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ fac2 = hprimewgll_yy(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- fac3 = hprimewgll_zz(l,k)
- tempx3l = tempx3l + tempx3(i,j,l)*fac3
- tempy3l = tempy3l + tempy3(i,j,l)*fac3
- tempz3l = tempz3l + tempz3(i,j,l)*fac3
- enddo
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ fac3 = hprimewgll_zz(l,k)
+ tempx3l = tempx3l + tempx3(i,j,l)*fac3
+ tempy3l = tempy3l + tempy3(i,j,l)*fac3
+ tempz3l = tempz3l + tempz3(i,j,l)*fac3
+ enddo
- fac1 = wgllwgll_yz(j,k)
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
- sum_terms(1,i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
- sum_terms(2,i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
- sum_terms(3,i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+ sum_terms(1,i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ sum_terms(2,i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ sum_terms(3,i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
- if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
+ if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
+ enddo
enddo
enddo
- enddo
- ! sum contributions from each element to the global mesh and add gravity terms
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- accel_inner_core(:,iglob) = accel_inner_core(:,iglob) + sum_terms(:,i,j,k)
+ ! sum contributions from each element to the global mesh and add gravity terms
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ accel_inner_core(:,iglob) = accel_inner_core(:,iglob) + sum_terms(:,i,j,k)
+ enddo
enddo
enddo
- enddo
-! use Runge-Kutta scheme to march memory variables in time
-! convention for attenuation
-! term in xx = 1
-! term in yy = 2
-! term in xy = 3
-! term in xz = 4
-! term in yz = 5
-! term in zz not computed since zero trace
-! This is because we only implement Q_\mu attenuation and not Q_\kappa.
-! Note that this does *NOT* imply that there is no attenuation for P waves
-! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
-! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
-! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
-! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
+ ! use Runge-Kutta scheme to march memory variables in time
+ ! convention for attenuation
+ ! term in xx = 1
+ ! term in yy = 2
+ ! term in xy = 3
+ ! term in xz = 4
+ ! term in yz = 5
+ ! term in zz not computed since zero trace
+ ! This is because we only implement Q_\mu attenuation and not Q_\kappa.
+ ! Note that this does *NOT* imply that there is no attenuation for P waves
+ ! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
+ ! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
+ ! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
+ ! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
- if( ATTENUATION_VAL .and. .not. PARTIAL_PHYS_DISPERSION_ONLY_VAL ) then
-
- do i_SLS = 1,N_SLS
-
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- if( ATTENUATION_3D_VAL .or. ATTENUATION_1D_WITH_3D_STORAGE_VAL ) then
- factor_common_use(:,:,:) = factor_common(i_SLS,:,:,:,ispec) * muvstore(:,:,:,ispec)
+ if( ATTENUATION_VAL .and. .not. PARTIAL_PHYS_DISPERSION_ONLY_VAL ) then
+ ! updates R_memory
+ if( USE_LDDRK ) then
+ call compute_element_att_memory_ic_lddrk(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ R_xx_lddrk,R_yy_lddrk,R_xy_lddrk,R_xz_lddrk,R_yz_lddrk, &
+ ATT1_VAL,ATT2_VAL,ATT3_VAL,vnspec,factor_common, &
+ muvstore, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
+ epsilondev_xz,epsilondev_yz, &
+ epsilondev_loc, &
+ deltat)
else
- factor_common_use(:,:,:) = factor_common(i_SLS,1,1,1,ispec) * muvstore(:,:,:,ispec)
+ call compute_element_att_memory_ic(ispec,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ ATT1_VAL,ATT2_VAL,ATT3_VAL,vnspec,factor_common, &
+ alphaval,betaval,gammaval, &
+ muvstore, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy, &
+ epsilondev_xz,epsilondev_yz, &
+ epsilondev_loc,is_backward_field)
endif
+ 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 * &
-! (betaval(i_SLS) * &
-! epsilondev(i_memory,:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
-! enddo
-
- R_xx(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xx(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xx(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(1,:,:,:))
-
- R_yy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yy(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(2,:,:,:))
-
- R_xy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xy(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(3,:,:,:))
-
- R_xz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xz(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(4,:,:,:))
-
- R_yz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yz(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(5,:,:,:))
-
- enddo
-
- endif
-
- if (COMPUTE_AND_STORE_STRAIN) then
! save deviatoric strain for Runge-Kutta scheme
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- epsilondev_xx(i,j,k,ispec) = epsilondev_loc(1,i,j,k)
- epsilondev_yy(i,j,k,ispec) = epsilondev_loc(2,i,j,k)
- epsilondev_xy(i,j,k,ispec) = epsilondev_loc(3,i,j,k)
- epsilondev_xz(i,j,k,ispec) = epsilondev_loc(4,i,j,k)
- epsilondev_yz(i,j,k,ispec) = epsilondev_loc(5,i,j,k)
+ if (COMPUTE_AND_STORE_STRAIN) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ epsilondev_xx(i,j,k,ispec) = epsilondev_loc(1,i,j,k)
+ epsilondev_yy(i,j,k,ispec) = epsilondev_loc(2,i,j,k)
+ epsilondev_xy(i,j,k,ispec) = epsilondev_loc(3,i,j,k)
+ epsilondev_xz(i,j,k,ispec) = epsilondev_loc(4,i,j,k)
+ epsilondev_yz(i,j,k,ispec) = epsilondev_loc(5,i,j,k)
+ enddo
enddo
enddo
- enddo
- endif
+ endif
- endif ! end test to exclude fictitious elements in central cube
+ endif ! end test to exclude fictitious elements in central cube
enddo ! spectral element loop
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_outer_core_Dev.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -26,10 +26,11 @@
!=====================================================================
subroutine compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- NSPEC,NGLOB, &
- A_array_rotation,B_array_rotation, &
- displfluid,accelfluid, &
- div_displfluid,phase_is_inner)
+ NSPEC,NGLOB, &
+ A_array_rotation,B_array_rotation, &
+ A_array_rotation_lddrk,B_array_rotation_lddrk, &
+ displfluid,accelfluid, &
+ div_displfluid,phase_is_inner)
! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
@@ -38,7 +39,8 @@
use specfem_par,only: &
hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
minus_rho_g_over_kappa_fluid,d_ln_density_dr_table, &
- MOVIE_VOLUME
+ MOVIE_VOLUME, &
+ USE_LDDRK,istage
use specfem_par_outercore,only: &
xstore => xstore_outer_core,ystore => ystore_outer_core,zstore => zstore_outer_core, &
@@ -60,8 +62,11 @@
! for the Euler scheme for rotation
real(kind=CUSTOM_REAL) time,deltat,two_omega_earth
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
A_array_rotation,B_array_rotation
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ A_array_rotation_lddrk,B_array_rotation_lddrk
! displacement and acceleration
real(kind=CUSTOM_REAL), dimension(NGLOB) :: displfluid,accelfluid
@@ -444,9 +449,18 @@
enddo
! update rotation term with Euler scheme
if(ROTATION_VAL) then
- ! use the source saved above
- A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + source_euler_A(:,:,:)
- B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + source_euler_B(:,:,:)
+ if(USE_LDDRK) then
+ ! use the source saved above
+ A_array_rotation_lddrk(:,:,:,ispec) = ALPHA_LDDRK(istage) * A_array_rotation_lddrk(:,:,:,ispec) + source_euler_A(:,:,:)
+ A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + BETA_LDDRK(istage) * A_array_rotation_lddrk(:,:,:,ispec)
+
+ B_array_rotation_lddrk(:,:,:,ispec) = ALPHA_LDDRK(istage) * B_array_rotation_lddrk(:,:,:,ispec) + source_euler_B(:,:,:)
+ B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + BETA_LDDRK(istage) * B_array_rotation_lddrk(:,:,:,ispec)
+ else
+ ! use the source saved above
+ A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + source_euler_A(:,:,:)
+ B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + source_euler_B(:,:,:)
+ endif
endif
#endif
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_outer_core_noDev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_outer_core_noDev.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_outer_core_noDev.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -26,10 +26,11 @@
!=====================================================================
subroutine compute_forces_outer_core(time,deltat,two_omega_earth, &
- NSPEC,NGLOB, &
- A_array_rotation,B_array_rotation, &
- displfluid,accelfluid, &
- div_displfluid,phase_is_inner)
+ NSPEC,NGLOB, &
+ A_array_rotation,B_array_rotation, &
+ A_array_rotation_lddrk,B_array_rotation_lddrk, &
+ displfluid,accelfluid, &
+ div_displfluid,phase_is_inner)
use constants_solver
@@ -37,7 +38,8 @@
hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
minus_rho_g_over_kappa_fluid,d_ln_density_dr_table, &
- MOVIE_VOLUME
+ MOVIE_VOLUME, &
+ USE_LDDRK,istage
use specfem_par_outercore,only: &
xstore => xstore_outer_core,ystore => ystore_outer_core,zstore => zstore_outer_core, &
@@ -55,8 +57,11 @@
! for the Euler scheme for rotation
real(kind=CUSTOM_REAL) time,deltat,two_omega_earth
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
A_array_rotation,B_array_rotation
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ A_array_rotation_lddrk,B_array_rotation_lddrk
! displacement and acceleration
real(kind=CUSTOM_REAL), dimension(NGLOB) :: displfluid,accelfluid
@@ -328,9 +333,18 @@
! update rotation term with Euler scheme
if(ROTATION_VAL) then
- ! use the source saved above
- A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + source_euler_A(:,:,:)
- B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + source_euler_B(:,:,:)
+ if(USE_LDDRK)then
+ ! use the source saved above
+ A_array_rotation_lddrk(:,:,:,ispec) = ALPHA_LDDRK(istage) * A_array_rotation_lddrk(:,:,:,ispec) + source_euler_A(:,:,:)
+ A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + BETA_LDDRK(istage) * A_array_rotation_lddrk(:,:,:,ispec)
+
+ B_array_rotation_lddrk(:,:,:,ispec) = ALPHA_LDDRK(istage) * B_array_rotation_lddrk(:,:,:,ispec) + source_euler_B(:,:,:)
+ B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + BETA_LDDRK(istage) * B_array_rotation_lddrk(:,:,:,ispec)
+ else
+ ! use the source saved above
+ A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + source_euler_A(:,:,:)
+ B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + source_euler_B(:,:,:)
+ endif
endif
enddo ! spectral element loop
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_viscoelastic_calling_routine.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_viscoelastic_calling_routine.F90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_forces_viscoelastic_calling_routine.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -84,6 +84,8 @@
phase_is_inner, &
R_xx_crust_mantle,R_yy_crust_mantle,R_xy_crust_mantle, &
R_xz_crust_mantle,R_yz_crust_mantle, &
+ R_xx_crust_mantle_lddrk,R_yy_crust_mantle_lddrk,R_xy_crust_mantle_lddrk, &
+ R_xz_crust_mantle_lddrk,R_yz_crust_mantle_lddrk, &
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, &
@@ -95,7 +97,10 @@
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, &
+ R_xx_inner_core,R_yy_inner_core,R_xy_inner_core, &
+ R_xz_inner_core,R_yz_inner_core, &
+ R_xx_inner_core_lddrk,R_yy_inner_core_lddrk,R_xy_inner_core_lddrk, &
+ R_xz_inner_core_lddrk,R_yz_inner_core_lddrk, &
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,&
@@ -111,23 +116,28 @@
phase_is_inner, &
R_xx_crust_mantle,R_yy_crust_mantle,R_xy_crust_mantle, &
R_xz_crust_mantle,R_yz_crust_mantle, &
+ R_xx_crust_mantle_lddrk,R_yy_crust_mantle_lddrk,R_xy_crust_mantle_lddrk, &
+ R_xz_crust_mantle_lddrk,R_yz_crust_mantle_lddrk, &
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,5) )
+ factor_common_crust_mantle,size(factor_common_crust_mantle,5), .false. )
! 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, &
+ R_xx_inner_core,R_yy_inner_core,R_xy_inner_core, &
+ R_xz_inner_core,R_yz_inner_core, &
+ R_xx_inner_core_lddrk,R_yy_inner_core_lddrk,R_xy_inner_core_lddrk, &
+ R_xz_inner_core_lddrk,R_yz_inner_core_lddrk, &
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,5) )
+ factor_common_inner_core,size(factor_common_inner_core,5), .false. )
endif
else
@@ -313,15 +323,21 @@
enddo ! iphase
- ! updates (only) acceleration w/ rotation in the crust/mantle region (touches oceans)
+ ! updates (only) acceleration w/ rotation in the crust/mantle and inner core region
if(.NOT. GPU_MODE) then
- ! on CPU
- call update_accel_elastic(NGLOB_CRUST_MANTLE,NGLOB_XY_CM,veloc_crust_mantle,accel_crust_mantle, &
- two_omega_earth,rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle)
+ ! on CPU
+ ! crust/mantle region
+ call it_multiply_accel_elastic(NGLOB_CRUST_MANTLE,veloc_crust_mantle,accel_crust_mantle, &
+ two_omega_earth, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle)
+ ! inner core region
+ call it_multiply_accel_elastic(NGLOB_INNER_CORE,veloc_inner_core,accel_inner_core, &
+ two_omega_earth, &
+ rmassx_inner_core,rmassy_inner_core,rmassz_inner_core)
else
- ! on GPU
- ! includes FORWARD_OR_ADJOINT == 1
- call update_accel_3_a_cuda(Mesh_pointer,deltatover2,NCHUNKS_VAL,1)
+ ! on GPU
+ ! includes FORWARD_OR_ADJOINT == 1
+ call update_accel_3_a_cuda(Mesh_pointer,deltatover2,NCHUNKS_VAL,1)
endif
! couples ocean with crust mantle
@@ -330,7 +346,7 @@
if(.NOT. GPU_MODE) then
! on CPU
call compute_coupling_ocean(accel_crust_mantle, &
- rmassx_crust_mantle, rmassy_crust_mantle, rmassz_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, &
@@ -342,18 +358,13 @@
endif
endif
- ! Newmark time scheme:
- ! corrector terms for elastic parts
- ! (updates velocity)
- if(.NOT. GPU_MODE ) then
- ! on CPU
- call update_veloc_elastic(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)
+ ! time scheme update
+ if( USE_LDDRK ) then
+ ! runge-kutta scheme
+ call update_veloc_elastic_lddrk()
else
- ! on GPU
- ! includes FORWARD_OR_ADJOINT == 1
- call update_veloc_3_b_cuda(Mesh_pointer,deltatover2,1)
+ ! Newmark time scheme
+ call update_veloc_elastic_newmark()
endif
end subroutine compute_forces_viscoelastic
@@ -458,6 +469,8 @@
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_R_xx_crust_mantle_lddrk,b_R_yy_crust_mantle_lddrk,b_R_xy_crust_mantle_lddrk, &
+ b_R_xz_crust_mantle_lddrk,b_R_yz_crust_mantle_lddrk, &
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, &
@@ -472,6 +485,8 @@
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_R_xx_inner_core_lddrk,b_R_yy_inner_core_lddrk,b_R_xy_inner_core_lddrk, &
+ b_R_xz_inner_core_lddrk,b_R_yz_inner_core_lddrk, &
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,&
@@ -488,12 +503,14 @@
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_R_xx_crust_mantle_lddrk,b_R_yy_crust_mantle_lddrk,b_R_xy_crust_mantle_lddrk, &
+ b_R_xz_crust_mantle_lddrk,b_R_yz_crust_mantle_lddrk, &
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,5) )
+ factor_common_crust_mantle,size(factor_common_crust_mantle,5), .true. )
! inner core region
call compute_forces_inner_core( NSPEC_INNER_CORE_ADJOINT,NGLOB_INNER_CORE_ADJOINT, &
@@ -503,11 +520,13 @@
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_R_xx_inner_core_lddrk,b_R_yy_inner_core_lddrk,b_R_xy_inner_core_lddrk, &
+ b_R_xz_inner_core_lddrk,b_R_yz_inner_core_lddrk, &
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,5) )
+ factor_common_inner_core,size(factor_common_inner_core,5), .true. )
endif
else
! on GPU
@@ -521,70 +540,75 @@
! 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_backward()
+ ! absorbing boundaries
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ if( UNDO_ATTENUATION ) then
+ call compute_stacey_crust_mantle_backward_undoatt()
+ else
+ call compute_stacey_crust_mantle_backward()
+ endif
+ endif
- ! add the sources
- select case( NOISE_TOMOGRAPHY )
- case( 0 )
- ! add sources for backward/reconstructed wavefield
- if( nsources_local > 0 ) &
- call compute_add_sources_backward()
+ ! add the sources
+ select case( NOISE_TOMOGRAPHY )
+ case( 0 )
+ ! add sources for backward/reconstructed wavefield
+ if( nsources_local > 0 ) &
+ call compute_add_sources_backward()
- 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)
+ 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
+ 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(b_displ_crust_mantle,b_accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- 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, &
- NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+ ! ****************************************************
+ ! ********** 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(b_displ_crust_mantle,b_accel_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ 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, &
+ 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(b_displ_inner_core,b_accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_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, &
- NSPEC2D_TOP(IREGION_INNER_CORE))
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) &
+ call compute_coupling_ICB_fluid(b_displ_inner_core,b_accel_inner_core, &
+ ibool_inner_core,ibelm_top_inner_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, &
+ 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,3)
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if( ACTUALLY_COUPLE_FLUID_ICB ) &
- call compute_coupling_icb_fluid_cuda(Mesh_pointer,3)
-
- endif
+ 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,3)
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if( ACTUALLY_COUPLE_FLUID_ICB ) &
+ call compute_coupling_icb_fluid_cuda(Mesh_pointer,3)
+ endif
endif ! iphase == 1
! assemble all the contributions between slices using MPI
@@ -677,12 +701,18 @@
enddo ! iphase
- ! updates (only) acceleration w/ rotation in the crust/mantle region (touches oceans)
+ ! updates (only) acceleration w/ rotation in the crust/mantle and inner core region
if(.NOT. GPU_MODE) then
! on CPU
! adjoint / kernel runs
- call update_accel_elastic(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)
+ ! crust/mantle region
+ call it_multiply_accel_elastic(NGLOB_CRUST_MANTLE_ADJOINT,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_two_omega_earth, &
+ b_rmassx_crust_mantle,b_rmassy_crust_mantle,b_rmassz_crust_mantle)
+ ! inner core region
+ call it_multiply_accel_elastic(NGLOB_INNER_CORE,b_veloc_inner_core,b_accel_inner_core, &
+ b_two_omega_earth, &
+ b_rmassx_inner_core,b_rmassy_inner_core,b_rmassz_inner_core)
else
! on GPU
! includes FORWARD_OR_ADJOINT == 3
@@ -695,7 +725,7 @@
if(.NOT. GPU_MODE) then
! on CPU
call compute_coupling_ocean(b_accel_crust_mantle, &
- rmassx_crust_mantle, rmassy_crust_mantle, rmassz_crust_mantle, &
+ b_rmassx_crust_mantle,b_rmassy_crust_mantle,b_rmassz_crust_mantle, &
rmass_ocean_load,normal_top_crust_mantle, &
ibool_crust_mantle,ibelm_top_crust_mantle, &
updated_dof_ocean_load,NGLOB_XY_CM, &
@@ -707,19 +737,13 @@
endif
endif
- ! Newmark time scheme:
- ! corrector terms for elastic parts
- ! (updates velocity)
- if(.NOT. GPU_MODE ) then
- ! on CPU
- ! adjoint / kernel runs
- call update_veloc_elastic(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)
+ ! time scheme update
+ if( USE_LDDRK ) then
+ ! runge-kutta scheme
+ call update_veloc_elastic_lddrk_backward()
else
- ! on GPU
- ! includes FORWARD_OR_ADJOINT == 3
- call update_veloc_3_b_cuda(Mesh_pointer,b_deltatover2,3)
+ ! Newmark time scheme
+ call update_veloc_elastic_newmark_backward()
endif
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_seismograms.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -404,3 +404,64 @@
enddo
end subroutine compute_seismograms_adjoint
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_seismograms_undoatt(seismo_current,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms)
+
+! re-orders seismogram entries
+
+ use specfem_par,only: CUSTOM_REAL,NDIM,NT_DUMP_ATTENUATION
+
+ implicit none
+
+ integer :: seismo_current
+ integer :: nrec_local
+ integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: &
+ seismograms
+
+ ! local parameters
+ integer :: i,j,k,irec_local
+ real(kind=CUSTOM_REAL), dimension(3) :: seismograms_temp
+
+ if(mod(NT_DUMP_ATTENUATION,2) == 0)then
+
+ do irec_local = 1,nrec_local
+ do i = 1,seismo_current/NT_DUMP_ATTENUATION
+ do j = 1,NT_DUMP_ATTENUATION/2
+ do k = 1,NDIM
+ seismograms_temp(k) = seismograms(k,irec_local,(i-1)*NT_DUMP_ATTENUATION + j)
+
+ seismograms(k,irec_local,(i-1)*NT_DUMP_ATTENUATION + j) = &
+ seismograms(k,irec_local,(i-1)*NT_DUMP_ATTENUATION + (NT_DUMP_ATTENUATION-j+1))
+
+ seismograms(k,irec_local,(i-1)*NT_DUMP_ATTENUATION + (NT_DUMP_ATTENUATION-j+1)) = seismograms_temp(k)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ else
+
+ do irec_local = 1,nrec_local
+ do i = 1,seismo_current/NT_DUMP_ATTENUATION
+ do j = 1,(NT_DUMP_ATTENUATION-1)/2
+ do k = 1,NDIM
+ seismograms_temp(k) = seismograms(k,irec_local,(i-1)*NT_DUMP_ATTENUATION + j)
+ seismograms(k,irec_local,(i-1)*NT_DUMP_ATTENUATION + j) = &
+ seismograms(k,irec_local,(i-1)*NT_DUMP_ATTENUATION + (NT_DUMP_ATTENUATION-j+1))
+ seismograms(k,irec_local,(i-1)*NT_DUMP_ATTENUATION + (NT_DUMP_ATTENUATION-j+1)) = seismograms_temp(k)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ end subroutine compute_seismograms_undoatt
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_stacey_crust_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_stacey_crust_mantle.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_stacey_crust_mantle.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -512,4 +512,260 @@
end subroutine compute_stacey_crust_mantle_backward
+!
+!-------------------------------------------------------------------------------------------------
+!
+ subroutine compute_stacey_crust_mantle_backward_undoatt()
+
+! stacey conditions for backward/reconstructed wavefields in UNDO_ATTENUATION case
+
+ use constants_solver
+
+ use specfem_par,only: &
+ ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
+ wgllwgll_xz,wgllwgll_yz
+
+ use specfem_par,only: GPU_MODE,Mesh_pointer
+
+ use specfem_par_crustmantle, only: &
+ b_veloc_crust_mantle,b_accel_crust_mantle, &
+ ibool_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle, &
+ normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+ rho_vp_crust_mantle,rho_vs_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle, &
+ ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ nimin_crust_mantle,nimax_crust_mantle, &
+ njmin_crust_mantle,njmax_crust_mantle, &
+ nkmin_xi_crust_mantle,nkmin_eta_crust_mantle, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ absorb_xmin_crust_mantle,absorb_xmax_crust_mantle, &
+ absorb_ymin_crust_mantle,absorb_ymax_crust_mantle
+
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: weight
+ real(kind=CUSTOM_REAL) :: vn,vx,vy,vz,nx,ny,nz,tx,ty,tz
+ integer :: i,j,k,ispec,iglob,ispec2D
+ !integer :: reclen1,reclen2
+
+ ! note: we use C functions for I/O as they still have a better performance than
+ ! Fortran, unformatted file I/O. however, using -assume byterecl together with Fortran functions
+ ! comes very close (only ~ 4 % slower ).
+ !
+ ! tests with intermediate storages (every 8 step) and/or asynchronious
+ ! file access (by process rank modulo 8) showed that the following,
+ ! simple approach is still fastest. (assuming that files are accessed on a local scratch disk)
+
+ ! checks
+ if( SIMULATION_TYPE /= 3 ) return
+ if( SAVE_FORWARD ) return
+
+ ! daniel debug
+ if( GPU_MODE ) stop 'error compute_stacey_crust_mantle_backward_undoatt not implemented yet for GPU simulations'
+
+ ! crust & mantle
+
+ ! xmin
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
+
+ if ( .NOT. GPU_MODE) then
+ ! on CPU
+ do ispec2D=1,nspec2D_xmin_crust_mantle
+
+ ispec=ibelm_xmin_crust_mantle(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi_crust_mantle(1,ispec2D) == 0 .or. njmin_crust_mantle(1,ispec2D) == 0) cycle
+
+ i=1
+ do k=nkmin_xi_crust_mantle(1,ispec2D),NGLLZ
+ do j=njmin_crust_mantle(1,ispec2D),njmax_crust_mantle(1,ispec2D)
+ iglob=ibool_crust_mantle(i,j,k,ispec)
+
+ vx = b_veloc_crust_mantle(1,iglob)
+ vy = b_veloc_crust_mantle(2,iglob)
+ vz = b_veloc_crust_mantle(3,iglob)
+
+ nx=normal_xmin_crust_mantle(1,j,k,ispec2D)
+ ny=normal_xmin_crust_mantle(2,j,k,ispec2D)
+ nz=normal_xmin_crust_mantle(3,j,k,ispec2D)
+
+ vn=vx*nx+vy*ny+vz*nz
+
+ tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
+ ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
+ tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
+
+ weight=jacobian2D_xmin_crust_mantle(j,k,ispec2D)*wgllwgll_yz(j,k)
+
+ b_accel_crust_mantle(1,iglob) = b_accel_crust_mantle(1,iglob) - tx*weight
+ b_accel_crust_mantle(2,iglob) = b_accel_crust_mantle(2,iglob) - ty*weight
+ b_accel_crust_mantle(3,iglob) = b_accel_crust_mantle(3,iglob) - tz*weight
+
+ enddo
+ enddo
+ enddo
+
+ else
+ ! on GPU
+ if( nspec2D_xmin_crust_mantle > 0 ) call compute_stacey_elastic_cuda(Mesh_pointer, &
+ absorb_xmin_crust_mantle, &
+ 0) ! <= xmin
+ endif
+
+ endif ! NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC
+
+ ! xmax
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB) then
+
+ if(.NOT. GPU_MODE ) then
+ ! on CPU
+ do ispec2D=1,nspec2D_xmax_crust_mantle
+
+ ispec=ibelm_xmax_crust_mantle(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi_crust_mantle(2,ispec2D) == 0 .or. njmin_crust_mantle(2,ispec2D) == 0) cycle
+
+ i=NGLLX
+ do k=nkmin_xi_crust_mantle(2,ispec2D),NGLLZ
+ do j=njmin_crust_mantle(2,ispec2D),njmax_crust_mantle(2,ispec2D)
+ iglob=ibool_crust_mantle(i,j,k,ispec)
+
+ vx = b_veloc_crust_mantle(1,iglob)
+ vy = b_veloc_crust_mantle(2,iglob)
+ vz = b_veloc_crust_mantle(3,iglob)
+
+ nx=normal_xmax_crust_mantle(1,j,k,ispec2D)
+ ny=normal_xmax_crust_mantle(2,j,k,ispec2D)
+ nz=normal_xmax_crust_mantle(3,j,k,ispec2D)
+
+ vn=vx*nx+vy*ny+vz*nz
+
+ tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
+ ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
+ tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
+
+ weight=jacobian2D_xmax_crust_mantle(j,k,ispec2D)*wgllwgll_yz(j,k)
+
+ b_accel_crust_mantle(1,iglob) = b_accel_crust_mantle(1,iglob) - tx*weight
+ b_accel_crust_mantle(2,iglob) = b_accel_crust_mantle(2,iglob) - ty*weight
+ b_accel_crust_mantle(3,iglob) = b_accel_crust_mantle(3,iglob) - tz*weight
+
+ enddo
+ enddo
+ enddo
+
+ else
+ ! on GPU
+ if( nspec2D_xmax_crust_mantle > 0 ) call compute_stacey_elastic_cuda(Mesh_pointer, &
+ absorb_xmax_crust_mantle, &
+ 1) ! <= xmin
+ endif
+
+ endif ! NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB
+
+ ! ymin
+
+ if( .NOT. GPU_MODE ) then
+ ! on CPU
+ do ispec2D=1,nspec2D_ymin_crust_mantle
+
+ ispec=ibelm_ymin_crust_mantle(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta_crust_mantle(1,ispec2D) == 0 .or. nimin_crust_mantle(1,ispec2D) == 0) cycle
+
+ j=1
+ do k=nkmin_eta_crust_mantle(1,ispec2D),NGLLZ
+ do i=nimin_crust_mantle(1,ispec2D),nimax_crust_mantle(1,ispec2D)
+ iglob=ibool_crust_mantle(i,j,k,ispec)
+
+ vx = b_veloc_crust_mantle(1,iglob)
+ vy = b_veloc_crust_mantle(2,iglob)
+ vz = b_veloc_crust_mantle(3,iglob)
+
+ nx=normal_ymin_crust_mantle(1,i,k,ispec2D)
+ ny=normal_ymin_crust_mantle(2,i,k,ispec2D)
+ nz=normal_ymin_crust_mantle(3,i,k,ispec2D)
+
+ vn=vx*nx+vy*ny+vz*nz
+
+ tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
+ ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
+ tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
+
+ weight=jacobian2D_ymin_crust_mantle(i,k,ispec2D)*wgllwgll_xz(i,k)
+
+ b_accel_crust_mantle(1,iglob) = b_accel_crust_mantle(1,iglob) - tx*weight
+ b_accel_crust_mantle(2,iglob) = b_accel_crust_mantle(2,iglob) - ty*weight
+ b_accel_crust_mantle(3,iglob) = b_accel_crust_mantle(3,iglob) - tz*weight
+
+ enddo
+ enddo
+ enddo
+
+ else
+ ! on GPU
+ if( nspec2D_ymin_crust_mantle > 0 ) call compute_stacey_elastic_cuda(Mesh_pointer, &
+ absorb_ymin_crust_mantle, &
+ 2) ! <= ymin
+ endif
+
+ ! ymax
+
+ if( .NOT. GPU_MODE ) then
+ ! on CPU
+ do ispec2D=1,nspec2D_ymax_crust_mantle
+
+ ispec=ibelm_ymax_crust_mantle(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta_crust_mantle(2,ispec2D) == 0 .or. nimin_crust_mantle(2,ispec2D) == 0) cycle
+
+ j=NGLLY
+ do k=nkmin_eta_crust_mantle(2,ispec2D),NGLLZ
+ do i=nimin_crust_mantle(2,ispec2D),nimax_crust_mantle(2,ispec2D)
+ iglob=ibool_crust_mantle(i,j,k,ispec)
+
+ vx = b_veloc_crust_mantle(1,iglob)
+ vy = b_veloc_crust_mantle(2,iglob)
+ vz = b_veloc_crust_mantle(3,iglob)
+
+ nx=normal_ymax_crust_mantle(1,i,k,ispec2D)
+ ny=normal_ymax_crust_mantle(2,i,k,ispec2D)
+ nz=normal_ymax_crust_mantle(3,i,k,ispec2D)
+
+ vn=vx*nx+vy*ny+vz*nz
+
+ tx=rho_vp_crust_mantle(i,j,k,ispec)*vn*nx+rho_vs_crust_mantle(i,j,k,ispec)*(vx-vn*nx)
+ ty=rho_vp_crust_mantle(i,j,k,ispec)*vn*ny+rho_vs_crust_mantle(i,j,k,ispec)*(vy-vn*ny)
+ tz=rho_vp_crust_mantle(i,j,k,ispec)*vn*nz+rho_vs_crust_mantle(i,j,k,ispec)*(vz-vn*nz)
+
+ weight=jacobian2D_ymax_crust_mantle(i,k,ispec2D)*wgllwgll_xz(i,k)
+
+ b_accel_crust_mantle(1,iglob) = b_accel_crust_mantle(1,iglob) - tx*weight
+ b_accel_crust_mantle(2,iglob) = b_accel_crust_mantle(2,iglob) - ty*weight
+ b_accel_crust_mantle(3,iglob) = b_accel_crust_mantle(3,iglob) - tz*weight
+
+ enddo
+ enddo
+ enddo
+
+ else
+ ! on GPU
+ if( nspec2D_ymax_crust_mantle > 0 ) call compute_stacey_elastic_cuda(Mesh_pointer, &
+ absorb_ymax_crust_mantle, &
+ 3) ! <= ymax
+ endif
+
+ end subroutine compute_stacey_crust_mantle_backward_undoatt
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_stacey_outer_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_stacey_outer_core.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_stacey_outer_core.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -507,3 +507,224 @@
end subroutine compute_stacey_outer_core_backward
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine compute_stacey_outer_core_backward_undoatt()
+
+ use constants_solver
+
+ use specfem_par,only: &
+ ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
+ wgllwgll_xz,wgllwgll_yz,wgllwgll_xy
+
+ use specfem_par,only: GPU_MODE,Mesh_pointer
+
+ use specfem_par_outercore,only: &
+ b_veloc_outer_core,b_accel_outer_core, &
+ ibool_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+ jacobian2D_bottom_outer_core, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core,nspec2D_zmin_outer_core, &
+ vp_outer_core, &
+ nimin_outer_core,nimax_outer_core,nkmin_eta_outer_core, &
+ njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core, &
+ absorb_zmin_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ ibelm_bottom_outer_core
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: sn,weight
+ integer :: i,j,k,ispec2D,ispec,iglob
+
+ ! checks
+ if( SIMULATION_TYPE /= 3 ) return
+ if( SAVE_FORWARD ) return
+
+ ! daniel debug
+ if( GPU_MODE ) stop 'error compute_stacey_outer_core_backward_undoatt not implemented yet for GPU simulations'
+
+ ! outer core
+
+ ! xmin
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
+
+ if( .NOT. GPU_MODE) then
+ ! on CPU
+ do ispec2D=1,nspec2D_xmin_outer_core
+
+ ispec=ibelm_xmin_outer_core(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi_outer_core(1,ispec2D) == 0 .or. njmin_outer_core(1,ispec2D) == 0) cycle
+
+ i=1
+ do k=nkmin_xi_outer_core(1,ispec2D),NGLLZ
+ do j=njmin_outer_core(1,ispec2D),njmax_outer_core(1,ispec2D)
+ iglob=ibool_outer_core(i,j,k,ispec)
+
+ sn = b_veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
+
+ weight = jacobian2D_xmin_outer_core(j,k,ispec2D)*wgllwgll_yz(j,k)
+
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - weight*sn
+
+ enddo
+ enddo
+ enddo
+
+ else
+ ! on GPU
+ if( nspec2D_xmin_outer_core > 0 ) call compute_stacey_acoustic_cuda(Mesh_pointer, &
+ absorb_xmin_outer_core, &
+ 4) ! <= xmin
+ endif
+
+ endif
+
+ ! xmax
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB) then
+
+ if( .NOT. GPU_MODE ) then
+ ! on CPU
+ do ispec2D=1,nspec2D_xmax_outer_core
+
+ ispec=ibelm_xmax_outer_core(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi_outer_core(2,ispec2D) == 0 .or. njmin_outer_core(2,ispec2D) == 0) cycle
+
+ i=NGLLX
+ do k=nkmin_xi_outer_core(2,ispec2D),NGLLZ
+ do j=njmin_outer_core(2,ispec2D),njmax_outer_core(2,ispec2D)
+ iglob=ibool_outer_core(i,j,k,ispec)
+
+ sn = b_veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
+
+ weight = jacobian2D_xmax_outer_core(j,k,ispec2D)*wgllwgll_yz(j,k)
+
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - weight*sn
+
+ enddo
+ enddo
+ enddo
+
+ else
+ ! on GPU
+ if( nspec2D_xmax_outer_core > 0 ) call compute_stacey_acoustic_cuda(Mesh_pointer, &
+ absorb_xmax_outer_core, &
+ 5) ! <= xmax
+ endif
+
+ endif
+
+ ! ymin
+
+ if( .NOT. GPU_MODE ) then
+ ! on CPU
+ do ispec2D=1,nspec2D_ymin_outer_core
+
+ ispec=ibelm_ymin_outer_core(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta_outer_core(1,ispec2D) == 0 .or. nimin_outer_core(1,ispec2D) == 0) cycle
+
+ j=1
+ do k=nkmin_eta_outer_core(1,ispec2D),NGLLZ
+ do i=nimin_outer_core(1,ispec2D),nimax_outer_core(1,ispec2D)
+ iglob=ibool_outer_core(i,j,k,ispec)
+
+ sn = b_veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
+
+ weight=jacobian2D_ymin_outer_core(i,k,ispec2D)*wgllwgll_xz(i,k)
+
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - weight*sn
+
+ enddo
+ enddo
+ enddo
+
+ else
+ ! on GPU
+ if( nspec2D_ymin_outer_core > 0 ) call compute_stacey_acoustic_cuda(Mesh_pointer, &
+ absorb_ymin_outer_core, &
+ 6) ! <= ymin
+ endif
+
+ ! ymax
+
+ if( .NOT. GPU_MODE ) then
+ ! on CPU
+ do ispec2D=1,nspec2D_ymax_outer_core
+
+ ispec=ibelm_ymax_outer_core(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta_outer_core(2,ispec2D) == 0 .or. nimin_outer_core(2,ispec2D) == 0) cycle
+
+ j=NGLLY
+ do k=nkmin_eta_outer_core(2,ispec2D),NGLLZ
+ do i=nimin_outer_core(2,ispec2D),nimax_outer_core(2,ispec2D)
+ iglob=ibool_outer_core(i,j,k,ispec)
+
+ sn = b_veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
+
+ weight=jacobian2D_ymax_outer_core(i,k,ispec2D)*wgllwgll_xz(i,k)
+
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - weight*sn
+
+ enddo
+ enddo
+ enddo
+
+ else
+ ! on GPU
+ if( nspec2D_ymax_outer_core > 0 ) call compute_stacey_acoustic_cuda(Mesh_pointer, &
+ absorb_ymax_outer_core, &
+ 7) ! <= ymax
+ endif
+
+ ! zmin
+
+ ! for surface elements exactly on the ICB
+
+ if( .NOT. GPU_MODE ) then
+ ! on CPU
+ do ispec2D = 1,nspec2D_zmin_outer_core
+
+ ispec = ibelm_bottom_outer_core(ispec2D)
+
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool_outer_core(i,j,k,ispec)
+
+ sn = b_veloc_outer_core(iglob)/vp_outer_core(i,j,k,ispec)
+
+ weight = jacobian2D_bottom_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - weight*sn
+
+ enddo
+ enddo
+ enddo
+
+ else
+ ! on GPU
+ if( nspec2D_zmin_outer_core > 0 ) call compute_stacey_acoustic_cuda(Mesh_pointer, &
+ absorb_zmin_outer_core, &
+ 8) ! <= zmin
+ endif
+
+ end subroutine compute_stacey_outer_core_backward_undoatt
+
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/create_central_cube_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/create_central_cube_buffers.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/create_central_cube_buffers.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -1,531 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 6 . 0
-! --------------------------------------------------
-!
-! 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
-! August 2013
-!
-! 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 buffers to assemble with central cube
-!
-
- subroutine create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
- NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- NSPEC2DMAX_XMIN_XMAX_INNER_CORE,NSPEC2DMAX_YMIN_YMAX_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE, &
- addressing,ibool_inner_core,idoubling_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
- ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
- nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices, &
- receiver_cube_from_slices,sender_from_slices_to_cube,ibool_central_cube, &
- buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
-
- use constants
-
- implicit none
-
- integer, intent(in) :: myrank,iproc_xi,iproc_eta,ichunk, &
- NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- NSPEC2DMAX_XMIN_XMAX_INNER_CORE,NSPEC2DMAX_YMIN_YMAX_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE
-
-! for addressing of the slices
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1), intent(in) :: addressing
-
-! mesh parameters
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE), intent(in) :: ibool_inner_core
-
-! local to global mapping
- integer, dimension(NSPEC_INNER_CORE), intent(in) :: idoubling_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE), intent(in) :: xstore_inner_core,ystore_inner_core,zstore_inner_core
-
-! boundary parameters locator
- integer, intent(in) :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_INNER_CORE), intent(in) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_INNER_CORE), intent(in) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE), intent(in) :: ibelm_bottom_inner_core
-
- integer, intent(in) :: nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices
-
-! for matching with central cube in inner core
- integer, intent(out) :: receiver_cube_from_slices
-
- integer, dimension(non_zero_nb_msgs_theor_in_cube), intent(out) :: sender_from_slices_to_cube
- integer, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices), intent(out) :: ibool_central_cube
- double precision, dimension(npoin2D_cube_from_slices,NDIM), intent(out) :: buffer_slices,buffer_slices2
- double precision, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM), intent(out) :: &
- buffer_all_cube_from_slices
-
-! local variables below
- integer i,j,k,ispec,ispec2D,iglob,ier
- integer sender,receiver,imsg,ipoin,iproc_xi_loop
-
- double precision x_target,y_target,z_target
- double precision x_current,y_current,z_current
-
-!--- processor to send information to in cube from slices
-
-! four vertical sides first
- if(ichunk == CHUNK_AC) then
- if (iproc_xi < floor(NPROC_XI/2.d0)) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1,iproc_eta)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB,0,iproc_eta)
- endif
- else if(ichunk == CHUNK_BC) then
- if (iproc_xi < floor(NPROC_XI/2.d0)) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_eta,NPROC_ETA-1)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB,iproc_eta,NPROC_ETA-1)
- endif
- else if(ichunk == CHUNK_AC_ANTIPODE) then
- if (iproc_xi <= ceiling((NPROC_XI/2.d0)-1)) then
- receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1,iproc_eta)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,0,iproc_eta)
- endif
- else if(ichunk == CHUNK_BC_ANTIPODE) then
- if (iproc_xi < floor(NPROC_XI/2.d0)) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,iproc_eta,0)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1-iproc_eta,0)
- endif
-! bottom of cube, direct correspondance but with inverted xi axis
- else if(ichunk == CHUNK_AB_ANTIPODE) then
- receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1-iproc_xi,iproc_eta)
- else if(ichunk == CHUNK_AB) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_xi,iproc_eta)
- endif
-
-
-!--- list of processors to receive information from in cube
-
-! only for slices in central cube
- if(ichunk == CHUNK_AB) then
-
-! initialize index of sender
- imsg = 0
-
-! define sender for xi = xi_min edge
- if(iproc_xi == 0) then
- do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
-! define sender for xi = xi_max edge
- if(iproc_xi == NPROC_XI-1) then
- do iproc_xi_loop = 0, floor((NPROC_XI-1)/2.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
-! define sender for eta = eta_min edge
- if(iproc_eta == 0) then
- do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,iproc_xi_loop,NPROC_ETA-1-iproc_xi)
- enddo
- endif
-
-! define sender for eta = eta_max edge
- if(iproc_eta == NPROC_ETA-1) then
- do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,iproc_xi_loop,iproc_xi)
- enddo
- endif
-
-! define sender for bottom edge
-! bottom of cube, direct correspondence but with inverted xi axis
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_xi,iproc_eta)
-
-! check that total number of faces found is correct
- if(imsg /= nb_msgs_theor_in_cube) call exit_MPI(myrank,'wrong number of faces found for central cube')
-
- else if(ichunk == CHUNK_AB_ANTIPODE) then
-
-! initialize index of sender
- imsg = 0
-
-! define sender for xi = xi_min edge
- if(iproc_xi == 0) then
- do iproc_xi_loop = ceiling(NPROC_XI/2.d0),NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
-! define sender for xi = xi_max edge
- if(iproc_xi == NPROC_XI-1) then
- do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
-! define sender for eta = eta_min edge
- if(iproc_eta == 0) then
- do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,iproc_xi_loop,iproc_xi)
- enddo
- endif
-
-! define sender for eta = eta_max edge
- if(iproc_eta == NPROC_ETA-1) then
- do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,iproc_xi_loop,NPROC_ETA-1-iproc_xi)
- enddo
- endif
-
-! define sender for bottom edge
-! bottom of cube, direct correspondence but with inverted xi axis
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AB,NPROC_XI-1-iproc_xi,iproc_eta)
-
-! check that total number of faces found is correct
- if(imsg /= nb_msgs_theor_in_cube) call exit_MPI(myrank,'wrong number of faces found for central cube')
-
- else
-
-! dummy value in slices
- sender_from_slices_to_cube(1) = -1
-
- endif
-
-
-! on chunk AB & AB ANTIPODE, receive all (except bottom) the messages from slices
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do imsg = 1,nb_msgs_theor_in_cube-1
-
-! receive buffers from slices
- sender = sender_from_slices_to_cube(imsg)
- call recv_dp(buffer_slices,NDIM*npoin2D_cube_from_slices,sender,itag)
-
-! copy buffer in 2D array for each slice
- buffer_all_cube_from_slices(imsg,:,:) = buffer_slices(:,:)
-
- enddo
- endif
-
-! send info to central cube from all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE ) then
-
-! for bottom elements in contact with central cube from the slices side
- ipoin = 0
- do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
-
- ispec = ibelm_bottom_inner_core(ispec2D)
-
-! only for DOFs exactly on surface of central cube (bottom of these elements)
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool_inner_core(i,j,k,ispec)
- buffer_slices(ipoin,1) = dble(xstore_inner_core(iglob))
- buffer_slices(ipoin,2) = dble(ystore_inner_core(iglob))
- buffer_slices(ipoin,3) = dble(zstore_inner_core(iglob))
- enddo
- enddo
- enddo
-
-! send buffer to central cube
- receiver = receiver_cube_from_slices
- call send_dp(buffer_slices,NDIM*npoin2D_cube_from_slices,receiver,itag)
-
- endif ! end sending info to central cube
-
-
-! exchange of their bottom faces between chunks AB and AB_ANTIPODE
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
- ipoin = 0
- do ispec = NSPEC_INNER_CORE, 1, -1
- if (idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE) then
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool_inner_core(i,j,k,ispec)
- buffer_slices(ipoin,1) = dble(xstore_inner_core(iglob))
- buffer_slices(ipoin,2) = dble(ystore_inner_core(iglob))
- buffer_slices(ipoin,3) = dble(zstore_inner_core(iglob))
- enddo
- enddo
- endif
- enddo
- if (ipoin /= npoin2D_cube_from_slices) call exit_MPI(myrank,'wrong number of points found for bottom CC AB or !AB')
-
- sender = sender_from_slices_to_cube(nb_msgs_theor_in_cube)
-
- call sendrecv_dp(buffer_slices,NDIM*npoin2D_cube_from_slices,receiver_cube_from_slices,itag, &
- buffer_slices2,NDIM*npoin2D_cube_from_slices,sender,itag)
-
- buffer_all_cube_from_slices(nb_msgs_theor_in_cube,:,:) = buffer_slices2(:,:)
-
- endif
-
-!--- now we need to find the points received and create indirect addressing
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do imsg = 1,nb_msgs_theor_in_cube
-
- do ipoin = 1,npoin2D_cube_from_slices
-
- x_target = buffer_all_cube_from_slices(imsg,ipoin,1)
- y_target = buffer_all_cube_from_slices(imsg,ipoin,2)
- z_target = buffer_all_cube_from_slices(imsg,ipoin,3)
-
-! x = x_min
- do ispec2D = 1,nspec2D_xmin_inner_core
-
- ispec = ibelm_xmin_inner_core(ispec2D)
-
-! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
-
- i = 1
- do k = 1,NGLLZ
- do j = 1,NGLLY
-
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
-
-! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
-
- enddo
- enddo
-
- enddo
-
-! x = x_max
- do ispec2D = 1,nspec2D_xmax_inner_core
-
- ispec = ibelm_xmax_inner_core(ispec2D)
-
-! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
-
- i = NGLLX
- do k = 1,NGLLZ
- do j = 1,NGLLY
-
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
-
-! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
-
- enddo
- enddo
-
- enddo
-
-! y = y_min
- do ispec2D = 1,nspec2D_ymin_inner_core
-
- ispec = ibelm_ymin_inner_core(ispec2D)
-
-! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
-
- j = 1
- do k = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
-
-! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
-
- enddo
- enddo
-
- enddo
-
-! y = y_max
- do ispec2D = 1,nspec2D_ymax_inner_core
-
- ispec = ibelm_ymax_inner_core(ispec2D)
-
-! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
-
- j = NGLLY
- do k = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
-
-! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
-
- enddo
- enddo
-
- enddo
-
-! bottom of cube
- do ispec = 1,NSPEC_INNER_CORE
-
-! loop on elements at the bottom of the cube only
- if(idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE) cycle
-
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
-
-! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
-
- enddo
- enddo
-
- enddo
-
-! check that a matching point is found in all cases
- call exit_MPI(myrank,'point never found in central cube')
-
- 100 continue
-
- enddo
- enddo
- endif
-
- end subroutine create_central_cube_buffers
-
-!
-!----------------------------------
-!
-
- subroutine comp_central_cube_buffer_size(iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM_INNER_CORE, &
- nb_msgs_theor_in_cube,npoin2D_cube_from_slices)
-
-!--- compute number of messages to expect in cube as well as their size
-!--- take into account vertical sides and bottom side
-
- use constants
-
- implicit none
-
- integer, intent(in) :: iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM_INNER_CORE
-
- integer, intent(out) :: nb_msgs_theor_in_cube,npoin2D_cube_from_slices
-
-! only for slices in central cube
- if(ichunk == CHUNK_AB) then
- if(NPROC_XI == 1) then
-! five sides if only one processor in cube
- nb_msgs_theor_in_cube = 5
- else
-! case of a corner
- if((iproc_xi == 0 .or. iproc_xi == NPROC_XI-1).and. &
- (iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1)) then
-! slices on both "vertical" faces plus one slice at the bottom
- nb_msgs_theor_in_cube = 2*(ceiling(NPROC_XI/2.d0)) + 1
-! case of an edge
- else if(iproc_xi == 0 .or. iproc_xi == NPROC_XI-1 .or. &
- iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1) then
-! slices on the "vertical" face plus one slice at the bottom
- nb_msgs_theor_in_cube = ceiling(NPROC_XI/2.d0) + 1
- else
-! bottom element only
- nb_msgs_theor_in_cube = 1
- endif
- endif
- else if(ichunk == CHUNK_AB_ANTIPODE) then
- if(NPROC_XI == 1) then
-! five sides if only one processor in cube
- nb_msgs_theor_in_cube = 5
- else
-! case of a corner
- if((iproc_xi == 0 .or. iproc_xi == NPROC_XI-1).and. &
- (iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1)) then
-! slices on both "vertical" faces plus one slice at the bottom
- nb_msgs_theor_in_cube = 2*(floor(NPROC_XI/2.d0)) + 1
-! case of an edge
- else if(iproc_xi == 0 .or. iproc_xi == NPROC_XI-1 .or. &
- iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1) then
-! slices on the "vertical" face plus one slice at the bottom
- nb_msgs_theor_in_cube = floor(NPROC_XI/2.d0) + 1
- else
-! bottom element only
- nb_msgs_theor_in_cube = 1
- endif
- endif
- else
-! not in chunk AB
- nb_msgs_theor_in_cube = 0
- endif
-
-! number of points to send or receive (bottom of slices)
- npoin2D_cube_from_slices = NSPEC2D_BOTTOM_INNER_CORE * NGLLX * NGLLY
-
- end subroutine comp_central_cube_buffer_size
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/finalize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/finalize_simulation.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/finalize_simulation.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -142,20 +142,83 @@
call save_kernels_source_derivatives()
endif
+ ! vtk visualization
+ if( VTK_MODE ) then
+ ! closes vtk window
+ if(myrank == 0 ) call finish_vtkwindow()
+ endif
+
! frees dynamically allocated memory
+ call finalize_simulation_cleanup()
+ ! close the main output file
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of the simulation'
+ write(IMAIN,*)
+ call flush_IMAIN()
+ close(IMAIN)
+ endif
+
+ ! synchronize all the processes to make sure everybody has finished
+ call sync_all()
+
+ if (ADIOS_ENABLED) then
+ call adios_cleanup()
+ endif
+ end subroutine finalize_simulation
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine finalize_simulation_cleanup()
+
+ use specfem_par
+ use specfem_par_crustmantle
+ use specfem_par_innercore
+ use specfem_par_outercore
+ use specfem_par_movie
+ implicit none
+
! mass matrices
- deallocate(rmassx_crust_mantle,rmassy_crust_mantle)
- deallocate(b_rmassx_crust_mantle,b_rmassy_crust_mantle)
+ ! crust/mantle
deallocate(rmassz_crust_mantle)
+ if( (NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) .or. &
+ (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION) ) then
+ deallocate(rmassx_crust_mantle,rmassy_crust_mantle)
+ else
+ nullify(rmassx_crust_mantle,rmassy_crust_mantle)
+ endif
+ if(SIMULATION_TYPE == 3 ) then
+ if( ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION ) then
+ deallocate(b_rmassx_crust_mantle,b_rmassy_crust_mantle)
+ else
+ nullify(b_rmassx_crust_mantle,b_rmassy_crust_mantle)
+ endif
+ nullify(b_rmassz_crust_mantle)
+ endif
+ ! outer core
deallocate(rmass_outer_core)
+ if(SIMULATION_TYPE == 3 ) nullify(b_rmass_outer_core)
- deallocate(rmassx_inner_core,rmassy_inner_core)
- deallocate(b_rmassx_inner_core,b_rmassy_inner_core)
- deallocate(rmass_inner_core)
+ ! inner core
+ deallocate(rmassz_inner_core)
+ if( ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION ) then
+ deallocate(rmassx_inner_core,rmassy_inner_core)
+ else
+ nullify(rmassx_inner_core,rmassy_inner_core)
+ endif
+ if(SIMULATION_TYPE == 3 ) then
+ if( ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION ) then
+ deallocate(b_rmassx_inner_core,b_rmassy_inner_core)
+ else
+ nullify(b_rmassx_inner_core,b_rmassy_inner_core)
+ endif
+ nullify(b_rmassz_inner_core)
+ endif
-
! mpi buffers
deallocate(buffer_send_vector_crust_mantle,buffer_recv_vector_crust_mantle, &
request_send_vector_cm,request_recv_vector_cm)
@@ -213,7 +276,6 @@
deallocate(station_name,network_name, &
stlat,stlon,stele,stbur)
deallocate(nu,number_receiver_global)
-
if( nrec_local > 0 ) then
deallocate(hxir_store, &
hetar_store, &
@@ -224,6 +286,7 @@
endif
deallocate(seismograms)
+ ! kernels
if (SIMULATION_TYPE == 3) then
if( APPROXIMATE_HESS_KL ) then
deallocate(hess_kl_crust_mantle)
@@ -249,9 +312,6 @@
! vtk visualization
if( VTK_MODE ) then
- ! closes/cleans up vtk window
- if(myrank == 0 ) call finish_vtkwindow()
-
! frees memory
deallocate(vtkdata,vtkmask)
if( NPROCTOT_VAL > 1 ) then
@@ -260,19 +320,4 @@
endif
endif
- ! close the main output file
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'End of the simulation'
- write(IMAIN,*)
- call flush_IMAIN()
- close(IMAIN)
- endif
-
- ! synchronize all the processes to make sure everybody has finished
- call sync_all()
-
- if (ADIOS_ENABLED) then
- call adios_cleanup()
- endif
- end subroutine finalize_simulation
+ end subroutine finalize_simulation_cleanup
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -71,35 +71,52 @@
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 check_stability()
- endif
+ do istage = 1, NSTAGE_TIME_SCHEME ! is equal to 1 if Newmark because only one stage then
- ! update displacement using Newmark time scheme
- call update_displacement_Newmark()
+ ! simulation status output and stability check
+ if((mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin + 4 .or. it == it_end) .and. istage == 1) then
+ call check_stability()
+ endif
- ! acoustic solver for outer core
- ! (needs to be done first, before elastic one)
- call compute_forces_acoustic()
+ if(USE_LDDRK)then
+ ! update displacement using runge-kutta time scheme
+ call update_displacement_lddrk()
+ else
+ ! update displacement using Newmark time scheme
+ call update_displacement_Newmark()
+ endif
- ! elastic solver for crust/mantle and inner core
- call compute_forces_viscoelastic()
-
- ! kernel simulations (forward and adjoint wavefields)
- if( SIMULATION_TYPE == 3 ) then
- ! reconstructs forward wavefields based on last store wavefield data
-
- ! update displacement using Newmark time scheme
- call update_displacement_Newmark_backward()
-
! acoustic solver for outer core
! (needs to be done first, before elastic one)
- call compute_forces_acoustic_backward()
+ call compute_forces_acoustic()
! elastic solver for crust/mantle and inner core
- call compute_forces_viscoelastic_backward()
+ call compute_forces_viscoelastic()
+ ! kernel simulations (forward and adjoint wavefields)
+ if( SIMULATION_TYPE == 3 ) then
+ ! reconstructs forward wavefields based on last stored wavefield data
+
+ if(USE_LDDRK)then
+ ! update displacement using runge-kutta time scheme
+ call update_displacement_lddrk_backward()
+ else
+ ! update displacement using Newmark time scheme
+ call update_displacement_Newmark_backward()
+ endif
+
+ ! acoustic solver for outer core
+ ! (needs to be done first, before elastic one)
+ call compute_forces_acoustic_backward()
+
+ ! elastic solver for crust/mantle and inner core
+ call compute_forces_viscoelastic_backward()
+ endif
+
+ enddo ! end of very big external loop on istage for all the stages of the LDDRK time scheme (only one stage if Newmark)
+
+ ! kernel simulations (forward and adjoint wavefields)
+ if( SIMULATION_TYPE == 3 ) then
! 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
@@ -148,7 +165,88 @@
!-------------------------------------------------------------------------------------------------
!
+ subroutine it_multiply_accel_elastic(NGLOB,veloc,accel, &
+ two_omega_earth, &
+ rmassx,rmassy,rmassz)
+! multiplies acceleration with inverse of mass matrices in crust/mantle,solid inner core region
+
+ use constants_solver,only: CUSTOM_REAL,NDIM
+
+ implicit none
+
+ integer :: NGLOB
+
+ ! velocity & acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: veloc,accel
+
+ real(kind=CUSTOM_REAL) :: two_omega_earth
+
+ ! mass matrices
+ real(kind=CUSTOM_REAL), dimension(NGLOB) :: rmassx,rmassy,rmassz
+
+ ! local parameters
+ integer :: i
+
+ ! note: 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
+
+ ! updates acceleration w/ rotation in elastic region
+
+ ! see input call, differs for corrected mass matrices for rmassx,rmassy,rmassz
+ do i=1,NGLOB
+ accel(1,i) = accel(1,i)*rmassx(i) + two_omega_earth*veloc(2,i)
+ accel(2,i) = accel(2,i)*rmassy(i) - two_omega_earth*veloc(1,i)
+ accel(3,i) = accel(3,i)*rmassz(i)
+ enddo
+
+ end subroutine it_multiply_accel_elastic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine it_multiply_accel_acoustic(NGLOB,accel,rmass)
+
+! multiplies acceleration with inverse of mass matrix in outer core region
+
+ use constants_solver,only: CUSTOM_REAL
+
+ implicit none
+
+ integer :: NGLOB
+
+ ! velocity & acceleration
+ ! crust/mantle region
+ real(kind=CUSTOM_REAL), dimension(NGLOB) :: accel
+
+ ! mass matrices
+ real(kind=CUSTOM_REAL), dimension(NGLOB) :: rmass
+
+ ! local parameters
+ integer :: i
+
+ ! note: mass matrices for fluid region has no stacey or rotation correction
+ ! it is also the same for forward and backward/reconstructed wavefields
+
+ do i=1,NGLOB
+ accel(i) = accel(i)*rmass(i)
+ enddo
+
+ end subroutine it_multiply_accel_acoustic
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
subroutine it_print_elapsed_time()
use specfem_par
Added: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time_undoatt.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time_undoatt.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time_undoatt.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -0,0 +1,497 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 6 . 0
+! --------------------------------------------------
+!
+! 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
+! August 2013
+!
+! 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_undoatt()
+
+ use specfem_par
+ use specfem_par_crustmantle
+ use specfem_par_innercore
+ use specfem_par_outercore
+ use specfem_par_movie
+ implicit none
+
+ ! local parameters
+ integer :: it_temp,seismo_current_temp
+ integer :: i,j,ier
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_displ_crust_mantle_store_buffer
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_displ_inner_core_store_buffer
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_displ_outer_core_store_buffer,b_accel_outer_core_store_buffer
+
+ ! timing
+ double precision, external :: wtime
+
+!
+! s t a r t t i m e i t e r a t i o n s
+!
+
+ ! checks
+ if( .not. UNDO_ATTENUATION ) return
+
+ ! 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 in undoing attenuation...'
+ write(IMAIN,*)
+ call flush_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_undoatt.txt',status='unknown',action='write')
+ write(IOUT,*) 'hello, starting time loop'
+ close(IOUT)
+ endif
+
+ if( SIMULATION_TYPE == 3 ) then
+ ! to switch between simulation type 1 mode and simulation type 3 mode
+ ! in exact undoing of attenuation
+ undo_att_sim_type_3 = .true.
+
+ !! DK DK to Daniel, July 2013: in the case of GPU_MODE it will be *crucial* to leave these arrays on the host
+ !! i.e. on the CPU, in order to be able to use all the (unused) memory of the host for them, since they are
+ !! (purposely) huge and designed to use almost all the memory available (by carefully optimizing the
+ !! value of NT_DUMP_ATTENUATION); when writing to these buffers, it will then be OK to use non-blocking writes
+ !! from the device to the host, since we do not reuse the content of these buffers until much later, in a second part
+ !! of the run; however when reading back from these buffers, the reads from host to device should then be blocking
+ !! because we then use the values read immediately (one value at a time, but to reduce the total number of reads
+ !! across the PCI-Express bus we could / should consider reading them 10 by 10 for instance (?) if that fits
+ !! in the memory of the GPU
+ allocate(b_displ_crust_mantle_store_buffer(NDIM,NGLOB_CRUST_MANTLE_ADJOINT,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_ADJOINT,NT_DUMP_ATTENUATION),stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_displ_outer_core_store_buffer')
+ allocate(b_accel_outer_core_store_buffer(NGLOB_OUTER_CORE_ADJOINT,NT_DUMP_ATTENUATION),stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_displ_outer_core_store_buffer')
+ allocate(b_displ_inner_core_store_buffer(NDIM,NGLOB_INNER_CORE_ADJOINT,NT_DUMP_ATTENUATION),stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_displ_inner_core_store_buffer')
+ endif
+
+ ! initialize variables for writing seismograms
+ seismo_offset = it_begin-1
+ seismo_current = 0
+
+ ! get MPI starting time
+ time_start = wtime()
+
+ ! *********************************************************
+ ! ************* MAIN LOOP OVER THE TIME STEPS *************
+ ! *********************************************************
+
+
+ it = 0
+ do iteration_on_subset = 1, NSTEP / NT_DUMP_ATTENUATION
+
+ ! wavefield storage
+ if( SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ ! saves forward wavefields
+ call save_forward_arrays_undoatt()
+
+ else if( SIMULATION_TYPE == 3 ) then
+ ! reads in last stored forward wavefield
+ call read_forward_arrays_undoatt()
+
+ ! note: after reading the restart files of displacement back from disk, recompute the strain from displacement;
+ ! this is better than storing the strain to disk as well, which would drastically increase I/O volume
+ ! computes strain based on current backward/reconstructed wavefield
+ if(COMPUTE_AND_STORE_STRAIN) call itu_compute_strain_att_backward()
+
+ ! intermediate storage of it and seismo_current positions
+ it_temp = it
+ seismo_current_temp = seismo_current
+ endif
+
+ ! forward and adjoint simulations
+ if(SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 2) then
+
+ ! subset loop
+ do it_of_this_subset = 1, NT_DUMP_ATTENUATION
+
+ it = it + 1
+
+ do istage = 1, NSTAGE_TIME_SCHEME ! is equal to 1 if Newmark because only one stage then
+
+ ! simulation status output and stability check
+ if((mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin + 4 .or. it == it_end) .and. istage == 1) then
+ call check_stability()
+ endif
+
+ if(USE_LDDRK)then
+ ! update displacement using runge-kutta time scheme
+ call update_displacement_lddrk()
+ else
+ ! update displacement using Newmark time scheme
+ call update_displacement_Newmark()
+ endif
+
+ ! 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_viscoelastic()
+
+ enddo ! istage
+
+ ! write the seismograms with time shift
+ if( nrec_local > 0 .or. ( WRITE_SEISMOGRAMS_BY_MASTER .and. myrank == 0 ) ) then
+ call write_seismograms()
+ 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 ! subset loop
+
+ else if( SIMULATION_TYPE == 3 ) then
+ ! kernel simulations
+
+ ! reconstructs forward wavefield based on last stored wavefield data
+ ! subset loop
+ do it_of_this_subset = 1, NT_DUMP_ATTENUATION
+
+ it = it + 1
+
+ do istage = 1, NSTAGE_TIME_SCHEME ! is equal to 1 if Newmark because only one stage then
+
+ ! simulation status output and stability check
+ if((mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin + 4 .or. it == it_end) .and. istage == 1) then
+ call check_stability()
+ endif
+
+ if(USE_LDDRK)then
+ ! update displacement using runge-kutta time scheme
+ call update_displacement_lddrk_backward()
+ else
+ ! update displacement using Newmark time scheme
+ call update_displacement_Newmark_backward()
+ endif
+
+ ! acoustic solver for outer core
+ ! (needs to be done first, before elastic one)
+ call compute_forces_acoustic_backward()
+
+ ! elastic solver for crust/mantle and inner core
+ call compute_forces_viscoelastic_backward()
+
+ enddo ! istage
+
+ ! write the seismograms with time shift
+ if( nrec_local > 0 .or. ( WRITE_SEISMOGRAMS_BY_MASTER .and. myrank == 0 ) ) then
+ call write_seismograms()
+ endif
+
+ ! stores wavefield in buffers
+ b_displ_crust_mantle_store_buffer(:,:,it_of_this_subset) = b_displ_crust_mantle(:,:)
+ b_displ_outer_core_store_buffer(:,it_of_this_subset) = b_displ_outer_core(:)
+ b_accel_outer_core_store_buffer(:,it_of_this_subset) = b_accel_outer_core(:)
+ b_displ_inner_core_store_buffer(:,:,it_of_this_subset) = b_displ_inner_core(:,:)
+
+ enddo ! subset loop
+
+ it = it_temp
+ seismo_current = seismo_current_temp
+
+ ! computes strain based on current adjoint wavefield
+ if(COMPUTE_AND_STORE_STRAIN) call itu_compute_strain_att()
+
+ ! adjoint wavefield simulation
+ do it_of_this_subset = 1, NT_DUMP_ATTENUATION
+
+ ! reads backward/reconstructed wavefield from buffers
+ ! crust/mantle
+ do i = 1, NDIM
+ do j =1,NGLOB_CRUST_MANTLE_ADJOINT
+ b_displ_crust_mantle(i,j) = b_displ_crust_mantle_store_buffer(i,j,NT_DUMP_ATTENUATION-it_of_this_subset+1)
+ enddo
+ enddo
+ ! outer core
+ do j =1,NGLOB_OUTER_CORE_ADJOINT
+ b_displ_outer_core(j) = b_displ_outer_core_store_buffer(j,NT_DUMP_ATTENUATION-it_of_this_subset+1)
+ b_accel_outer_core(j) = b_accel_outer_core_store_buffer(j,NT_DUMP_ATTENUATION-it_of_this_subset+1)
+ enddo
+ ! inner core
+ do i = 1, NDIM
+ do j =1,NGLOB_INNER_CORE_ADJOINT
+ b_displ_inner_core(i,j) = b_displ_inner_core_store_buffer(i,j,NT_DUMP_ATTENUATION-it_of_this_subset+1)
+ enddo
+ enddo
+
+ it = it + 1
+
+ do istage = 1, NSTAGE_TIME_SCHEME ! is equal to 1 if Newmark because only one stage then
+
+ ! simulation status output and stability check
+ if((mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin + 4 .or. it == it_end) .and. istage == 1) then
+ call check_stability()
+ endif
+
+ if(USE_LDDRK)then
+ ! update displacement using runge-kutta time scheme
+ call update_displacement_lddrk()
+ else
+ ! update displacement using Newmark time scheme
+ call update_displacement_Newmark()
+ endif
+
+ ! 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_viscoelastic()
+
+ enddo ! istage
+
+ ! write the seismograms with time shift
+ if( nrec_local > 0 .or. ( WRITE_SEISMOGRAMS_BY_MASTER .and. myrank == 0 ) ) then
+ call write_seismograms()
+ endif
+
+ ! kernel computation
+ ! adjoint simulations: kernels
+ call compute_kernels()
+
+ enddo ! subset loop
+
+ endif ! SIMULATION_TYPE == 3
+
+ enddo ! end of main time loop
+
+ !
+ !---- end of time iteration loop
+ !
+
+ ! frees undo_attenuation buffers
+ if( SIMULATION_TYPE == 3 ) then
+ deallocate(b_displ_crust_mantle_store_buffer, &
+ b_displ_outer_core_store_buffer, &
+ b_accel_outer_core_store_buffer, &
+ b_displ_inner_core_store_buffer)
+ endif
+
+ 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_undoatt
+
+
+!
+!--------------------------------------------------------------------------------------------
+!
+! strain for whole domain crust/mantle and inner core
+!
+!--------------------------------------------------------------------------------------------
+!
+
+ subroutine itu_compute_strain_att()
+
+ use specfem_par
+ use specfem_par_crustmantle
+ use specfem_par_innercore
+
+ implicit none
+ ! local parameters
+ integer :: ispec
+
+ ! checks
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+
+ ! inner core
+ do ispec = 1, NSPEC_INNER_CORE
+ call compute_element_strain_att_Dev(ispec,NGLOB_INNER_CORE,NSPEC_INNER_CORE, &
+ displ_inner_core,veloc_inner_core,0._CUSTOM_REAL, &
+ ibool_inner_core, &
+ hprime_xx,hprime_xxT, &
+ 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, &
+ epsilondev_xx_inner_core(1,1,1,ispec), &
+ epsilondev_yy_inner_core(1,1,1,ispec), &
+ epsilondev_xy_inner_core(1,1,1,ispec), &
+ epsilondev_xz_inner_core(1,1,1,ispec), &
+ epsilondev_yz_inner_core(1,1,1,ispec), &
+ eps_trace_over_3_inner_core(1,1,1,ispec))
+ enddo
+ ! crust mantle
+ do ispec = 1, NSPEC_crust_mantle
+ call compute_element_strain_att_Dev(ispec,NGLOB_CRUST_MANTLE,NSPEC_CRUST_MANTLE, &
+ displ_crust_mantle,veloc_crust_mantle,0._CUSTOM_REAL, &
+ ibool_crust_mantle, &
+ hprime_xx,hprime_xxT, &
+ 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, &
+ epsilondev_xx_crust_mantle(1,1,1,ispec), &
+ epsilondev_yy_crust_mantle(1,1,1,ispec), &
+ epsilondev_xy_crust_mantle(1,1,1,ispec), &
+ epsilondev_xz_crust_mantle(1,1,1,ispec), &
+ epsilondev_yz_crust_mantle(1,1,1,ispec), &
+ eps_trace_over_3_crust_mantle(1,1,1,ispec))
+ enddo
+
+ else
+
+ ! inner core
+ do ispec = 1, NSPEC_INNER_CORE
+ call compute_element_strain_att_noDev(ispec,NGLOB_INNER_CORE,NSPEC_INNER_CORE, &
+ displ_inner_core,veloc_inner_core,0._CUSTOM_REAL, &
+ ibool_inner_core, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ 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, &
+ epsilondev_xx_inner_core(1,1,1,ispec), &
+ epsilondev_yy_inner_core(1,1,1,ispec), &
+ epsilondev_xy_inner_core(1,1,1,ispec), &
+ epsilondev_xz_inner_core(1,1,1,ispec), &
+ epsilondev_yz_inner_core(1,1,1,ispec), &
+ eps_trace_over_3_inner_core(1,1,1,ispec))
+ enddo
+ ! crust mantle
+ do ispec = 1, NSPEC_CRUST_MANTLE
+ call compute_element_strain_att_noDev(ispec,NGLOB_CRUST_MANTLE,NSPEC_CRUST_MANTLE, &
+ displ_crust_mantle,veloc_crust_mantle,0._CUSTOM_REAL, &
+ ibool_crust_mantle, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ 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, &
+ epsilondev_xx_crust_mantle(1,1,1,ispec), &
+ epsilondev_yy_crust_mantle(1,1,1,ispec), &
+ epsilondev_xy_crust_mantle(1,1,1,ispec), &
+ epsilondev_xz_crust_mantle(1,1,1,ispec), &
+ epsilondev_yz_crust_mantle(1,1,1,ispec), &
+ eps_trace_over_3_crust_mantle(1,1,1,ispec))
+ enddo
+ endif
+
+ end subroutine itu_compute_strain_att
+
+!
+!--------------------------------------------------------------------------------------------
+!
+
+ subroutine itu_compute_strain_att_backward()
+
+ use specfem_par
+ use specfem_par_crustmantle
+ use specfem_par_innercore
+
+ implicit none
+ ! local parameters
+ integer :: ispec
+
+ ! checks
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+
+ ! inner core
+ do ispec = 1, NSPEC_INNER_CORE
+ call compute_element_strain_att_Dev(ispec,NGLOB_INNER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ b_displ_inner_core,b_veloc_inner_core,0._CUSTOM_REAL, &
+ ibool_inner_core, &
+ hprime_xx,hprime_xxT, &
+ 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, &
+ b_epsilondev_xx_inner_core(1,1,1,ispec), &
+ b_epsilondev_yy_inner_core(1,1,1,ispec), &
+ b_epsilondev_xy_inner_core(1,1,1,ispec), &
+ b_epsilondev_xz_inner_core(1,1,1,ispec), &
+ b_epsilondev_yz_inner_core(1,1,1,ispec), &
+ b_eps_trace_over_3_inner_core(1,1,1,ispec))
+ enddo
+ ! crust mantle
+ do ispec = 1, NSPEC_crust_mantle
+ call compute_element_strain_att_Dev(ispec,NGLOB_CRUST_MANTLE_ADJOINT,NSPEC_CRUST_MANTLE_ADJOINT, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,0._CUSTOM_REAL, &
+ ibool_crust_mantle, &
+ hprime_xx,hprime_xxT, &
+ 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, &
+ b_epsilondev_xx_crust_mantle(1,1,1,ispec), &
+ b_epsilondev_yy_crust_mantle(1,1,1,ispec), &
+ b_epsilondev_xy_crust_mantle(1,1,1,ispec), &
+ b_epsilondev_xz_crust_mantle(1,1,1,ispec), &
+ b_epsilondev_yz_crust_mantle(1,1,1,ispec), &
+ b_eps_trace_over_3_crust_mantle(1,1,1,ispec))
+ enddo
+
+ else
+
+ ! inner core
+ do ispec = 1, NSPEC_INNER_CORE
+ call compute_element_strain_att_noDev(ispec,NGLOB_INNER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ b_displ_inner_core,b_veloc_inner_core,0._CUSTOM_REAL, &
+ ibool_inner_core, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ 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, &
+ b_epsilondev_xx_inner_core(1,1,1,ispec), &
+ b_epsilondev_yy_inner_core(1,1,1,ispec), &
+ b_epsilondev_xy_inner_core(1,1,1,ispec), &
+ b_epsilondev_xz_inner_core(1,1,1,ispec), &
+ b_epsilondev_yz_inner_core(1,1,1,ispec), &
+ b_eps_trace_over_3_inner_core(1,1,1,ispec))
+ enddo
+ ! crust mantle
+ do ispec = 1, NSPEC_crust_mantle
+ call compute_element_strain_att_noDev(ispec,NGLOB_CRUST_MANTLE_ADJOINT,NSPEC_CRUST_MANTLE_ADJOINT, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,0._CUSTOM_REAL, &
+ ibool_crust_mantle, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ 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, &
+ b_epsilondev_xx_crust_mantle(1,1,1,ispec), &
+ b_epsilondev_yy_crust_mantle(1,1,1,ispec), &
+ b_epsilondev_xy_crust_mantle(1,1,1,ispec), &
+ b_epsilondev_xz_crust_mantle(1,1,1,ispec), &
+ b_epsilondev_yz_crust_mantle(1,1,1,ispec), &
+ b_eps_trace_over_3_crust_mantle(1,1,1,ispec))
+ enddo
+ endif
+
+ end subroutine itu_compute_strain_att_backward
+
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_sources.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -577,7 +577,7 @@
! checks that the gather operation went well
if(myrank == 0) then
if(minval(ispec_selected_source_all(:,:)) <= 0) then
- print*,'error ispec all:',NPROCTOT_VAL,NSOURCES_SUBSET_current_size
+ print*,'error ispec all: procs = ',NPROCTOT_VAL,'sources subset size = ',NSOURCES_SUBSET_current_size
print*,ispec_selected_source_all(:,:)
call exit_MPI(myrank,'gather operation failed for source')
endif
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/prepare_timerun.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -97,8 +97,14 @@
write(IMAIN,*)
write(IMAIN,*) 'Elapsed time for preparing timerun in seconds = ',sngl(tCPU)
write(IMAIN,*)
+ write(IMAIN,*)
write(IMAIN,*) 'time loop:'
write(IMAIN,*)
+ if(USE_LDDRK) then
+ write(IMAIN,*) ' scheme: LDDRK with',NSTAGE_TIME_SCHEME,'stages'
+ else
+ write(IMAIN,*) ' scheme: Newmark'
+ endif
write(IMAIN,*) ' time step: ',sngl(DT),' s'
write(IMAIN,*) 'number of time steps: ',NSTEP
write(IMAIN,*) 'total simulated time: ',sngl(((NSTEP-1)*DT-t0)/60.d0),' minutes'
@@ -176,6 +182,8 @@
write(IMAIN,*)
if(ROTATION_VAL) then
write(IMAIN,*) 'incorporating rotation'
+ if( EXACT_MASS_MATRIX_FOR_ROTATION ) &
+ write(IMAIN,*) 'using exact mass matrix for rotation'
else
write(IMAIN,*) 'no rotation'
endif
@@ -212,11 +220,20 @@
implicit none
if(myrank == 0 ) then
- write(IMAIN,*) "preparing mass matrices."
- write(IMAIN,*)
+ write(IMAIN,*) "preparing mass matrices"
call flush_IMAIN()
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
+
+
! mass matrices need to be assembled with MPI here once and for all
call prepare_timerun_rmass_assembly()
@@ -227,50 +244,50 @@
call exit_MPI(myrank,'negative mass matrix term for the oceans')
endif
+ ! checks mass matrices
+
! crust/mantle
- ! checks C*deltat/2 contribution to the mass matrices on Stacey edges
- if( .not. USE_LDDRK ) then
- if( ( NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS ) .or. &
- ( ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION ) ) then
- if(minval(rmassx_crust_mantle) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the crust_mantle')
- if(minval(rmassy_crust_mantle) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the crust_mantle')
- endif
- ! checks mass matrices for rotation
- if(ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION &
- .and. SIMULATION_TYPE == 3 .and. NGLOB_XY_CM > 0)then
- if(minval(b_rmassx_crust_mantle) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the b_crust_mantle')
- if(minval(b_rmassy_crust_mantle) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the b_crust_mantle')
- endif
+ if(minval(rmassx_crust_mantle) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the crust_mantle rmassx')
+ if(minval(rmassy_crust_mantle) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the crust_mantle rmassy')
+ if(minval(rmassz_crust_mantle) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the crust_mantle rmassz')
+ ! kernel simulations
+ if( SIMULATION_TYPE == 3 ) then
+ if(minval(b_rmassx_crust_mantle) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the b_crust_mantle b_rmassx')
+ if(minval(b_rmassy_crust_mantle) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the b_crust_mantle b_rmassy')
+ if(minval(b_rmassz_crust_mantle) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the b_crust_mantle b_rmassz')
endif
- if(minval(rmassz_crust_mantle) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the crust_mantle')
! inner core
! checks mass matrices for rotation
- if( .not. USE_LDDRK ) then
- if(ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. NGLOB_XY_IC > 0) then
- if(minval(rmassx_inner_core) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the rmassx_inner_core')
- if(minval(rmassy_inner_core) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the rmassy_inner_core')
- if( SIMULATION_TYPE == 3 .and. NGLOB_XY_IC > 0 ) then
- if(minval(b_rmassx_inner_core) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the b_rmassx_inner_core')
- if(minval(b_rmassy_inner_core) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the b_rmassy_inner_core')
- endif
- endif
+ if(minval(rmassx_inner_core) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the inner core rmassx')
+ if(minval(rmassy_inner_core) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the inner core rmassy')
+ if(minval(rmassz_inner_core) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the inner core rmassz')
+ ! kernel simulations
+ if( SIMULATION_TYPE == 3 ) then
+ if(minval(b_rmassx_inner_core) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the b_rmassx_inner_core')
+ if(minval(b_rmassy_inner_core) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the b_rmassy_inner_core')
+ if(minval(b_rmassz_inner_core) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the b_rmassz_inner_core')
endif
- if(minval(rmass_inner_core) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the inner core')
! outer core
if(minval(rmass_outer_core) <= 0._CUSTOM_REAL) &
- call exit_MPI(myrank,'negative mass matrix term for the outer core')
+ call exit_MPI(myrank,'negative mass matrix term for the outer core')
+ if( SIMULATION_TYPE == 3 ) then
+ if(minval(b_rmass_outer_core) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative mass matrix term for the outer core b_rmass')
+ endif
! mass matrix inversions
! for efficiency, invert final mass matrix once and for all on each slice
@@ -279,31 +296,28 @@
! mass matrices on Stacey edges
! crust/mantle
- if( .not. USE_LDDRK ) then
- if(((NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) .or. &
- (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION)) ) then
- rmassx_crust_mantle = 1._CUSTOM_REAL / rmassx_crust_mantle
- rmassy_crust_mantle = 1._CUSTOM_REAL / rmassy_crust_mantle
- endif
- if(ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION &
- .and. SIMULATION_TYPE == 3 .and. NGLOB_XY_CM > 0)then
+ if( ((NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) .or. &
+ (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION)) ) then
+ rmassx_crust_mantle = 1._CUSTOM_REAL / rmassx_crust_mantle
+ rmassy_crust_mantle = 1._CUSTOM_REAL / rmassy_crust_mantle
+ endif
+ if( SIMULATION_TYPE == 3 ) then
+ if( ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION )then
b_rmassx_crust_mantle = 1._CUSTOM_REAL / b_rmassx_crust_mantle
b_rmassy_crust_mantle = 1._CUSTOM_REAL / b_rmassy_crust_mantle
endif
endif
rmassz_crust_mantle = 1._CUSTOM_REAL / rmassz_crust_mantle
! inner core
- if(.not. USE_LDDRK)then
- if(ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. NGLOB_XY_IC > 0) then
- rmassx_inner_core = 1._CUSTOM_REAL / rmassx_inner_core
- rmassy_inner_core = 1._CUSTOM_REAL / rmassy_inner_core
- if(SIMULATION_TYPE == 3 .and. NGLOB_XY_IC > 0)then
- b_rmassx_inner_core = 1._CUSTOM_REAL / b_rmassx_inner_core
- b_rmassy_inner_core = 1._CUSTOM_REAL / b_rmassy_inner_core
- endif
- endif
+ if( ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION ) then
+ rmassx_inner_core = 1._CUSTOM_REAL / rmassx_inner_core
+ rmassy_inner_core = 1._CUSTOM_REAL / rmassy_inner_core
+ if( SIMULATION_TYPE == 3 ) then
+ b_rmassx_inner_core = 1._CUSTOM_REAL / b_rmassx_inner_core
+ b_rmassy_inner_core = 1._CUSTOM_REAL / b_rmassy_inner_core
+ endif
endif
- rmass_inner_core = 1._CUSTOM_REAL / rmass_inner_core
+ rmassz_inner_core = 1._CUSTOM_REAL / rmassz_inner_core
! outer core
rmass_outer_core = 1._CUSTOM_REAL / rmass_outer_core
@@ -333,9 +347,14 @@
endif
! crust and mantle
- if((NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS .or. &
- (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION)) .and. NGLOB_CRUST_MANTLE > 0 &
- .and. (.not. USE_LDDRK)) then
+ call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_CRUST_MANTLE, &
+ rmassz_crust_mantle, &
+ num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
+ nibool_interfaces_crust_mantle,ibool_interfaces_crust_mantle,&
+ my_neighbours_crust_mantle)
+
+ if( ((NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) .or. &
+ (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION)) .and. NGLOB_CRUST_MANTLE > 0 ) then
call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_CRUST_MANTLE, &
rmassx_crust_mantle, &
num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
@@ -349,9 +368,8 @@
my_neighbours_crust_mantle)
endif
- if(ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION &
- .and. .not. USE_LDDRK .and. NGLOB_XY_CM > 0)then
- if( SIMULATION_TYPE == 3 ) then
+ if( SIMULATION_TYPE == 3 ) then
+ if( (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION ) .and. NGLOB_XY_CM > 0)then
call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_XY_CM, &
b_rmassx_crust_mantle, &
num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
@@ -366,64 +384,60 @@
endif
endif
- call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_CRUST_MANTLE, &
- rmassz_crust_mantle, &
- num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
- nibool_interfaces_crust_mantle,ibool_interfaces_crust_mantle,&
- my_neighbours_crust_mantle)
! outer core
call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_OUTER_CORE, &
- rmass_outer_core, &
- num_interfaces_outer_core,max_nibool_interfaces_oc, &
- nibool_interfaces_outer_core,ibool_interfaces_outer_core,&
- my_neighbours_outer_core)
+ rmass_outer_core, &
+ num_interfaces_outer_core,max_nibool_interfaces_oc, &
+ nibool_interfaces_outer_core,ibool_interfaces_outer_core,&
+ my_neighbours_outer_core)
! inner core
- if(ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION &
- .and. (.not. USE_LDDRK) .and. NGLOB_XY_IC > 0)then
+ call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_INNER_CORE, &
+ rmassz_inner_core, &
+ num_interfaces_inner_core,max_nibool_interfaces_ic, &
+ nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
+ my_neighbours_inner_core)
+ if( ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION )then
call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_XY_IC, &
- rmassx_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
- my_neighbours_inner_core)
+ rmassx_inner_core, &
+ num_interfaces_inner_core,max_nibool_interfaces_ic, &
+ nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
+ my_neighbours_inner_core)
call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_XY_IC, &
- rmassy_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
- my_neighbours_inner_core)
+ rmassy_inner_core, &
+ num_interfaces_inner_core,max_nibool_interfaces_ic, &
+ nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
+ my_neighbours_inner_core)
- if(SIMULATION_TYPE == 3 .and. NGLOB_XY_IC > 0)then
+ if( SIMULATION_TYPE == 3 ) then
call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_XY_IC, &
- b_rmassx_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
- my_neighbours_inner_core)
+ b_rmassx_inner_core, &
+ num_interfaces_inner_core,max_nibool_interfaces_ic, &
+ nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
+ my_neighbours_inner_core)
call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_XY_IC, &
- b_rmassy_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
- my_neighbours_inner_core)
+ b_rmassy_inner_core, &
+ num_interfaces_inner_core,max_nibool_interfaces_ic, &
+ nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
+ my_neighbours_inner_core)
endif
-
endif
- call assemble_MPI_scalar(NPROCTOT_VAL,NGLOB_INNER_CORE, &
- rmass_inner_core, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
- my_neighbours_inner_core)
-
-
! mass matrix including central cube
if(INCLUDE_CENTRAL_CUBE) then
! suppress fictitious mass matrix elements in central cube
! because the slices do not compute all their spectral elements in the cube
- where(rmass_inner_core(:) <= 0.0_CUSTOM_REAL) rmass_inner_core = 1.0_CUSTOM_REAL
+ where(rmassz_inner_core(:) <= 0.0_CUSTOM_REAL) rmassz_inner_core = 1.0_CUSTOM_REAL
+
+ if( ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION )then
+ where(rmassx_inner_core(:) <= 0.0_CUSTOM_REAL) rmassx_inner_core = 1.0_CUSTOM_REAL
+ where(rmassy_inner_core(:) <= 0.0_CUSTOM_REAL) rmassy_inner_core = 1.0_CUSTOM_REAL
+ endif
endif
call sync_all()
@@ -498,12 +512,11 @@
! user output
if(myrank == 0 ) then
- write(IMAIN,*) "preparing movie surface."
- write(IMAIN,*)
+ write(IMAIN,*) "preparing movie surface"
call flush_IMAIN()
endif
- ! only output corners
+ ! only output corners
! note: for noise tomography, must NOT be coarse (have to be saved on all gll points)
if( MOVIE_COARSE .and. NOISE_TOMOGRAPHY == 0 ) then
! checks setup
@@ -581,8 +594,7 @@
integer :: ier
if(myrank == 0 ) then
- write(IMAIN,*) "preparing movie volume."
- write(IMAIN,*)
+ write(IMAIN,*) "preparing movie volume"
call flush_IMAIN()
endif
@@ -655,8 +667,7 @@
implicit none
if(myrank == 0 ) then
- write(IMAIN,*) "preparing constants."
- write(IMAIN,*)
+ write(IMAIN,*) "preparing constants"
call flush_IMAIN()
endif
@@ -705,9 +716,6 @@
endif
endif
- A_array_rotation = 0._CUSTOM_REAL
- B_array_rotation = 0._CUSTOM_REAL
-
if (SIMULATION_TYPE == 3) then
if(CUSTOM_REAL == SIZE_REAL) then
b_two_omega_earth = sngl(2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv))
@@ -720,6 +728,13 @@
if (SIMULATION_TYPE == 3) b_two_omega_earth = 0._CUSTOM_REAL
endif
+ if(UNDO_ATTENUATION) then
+ b_deltat = deltat
+ b_deltatover2 = deltatover2
+ b_deltatsqover2 = deltatsqover2
+ b_two_omega_earth = two_omega_earth
+ endif
+
call sync_all()
end subroutine prepare_timerun_constants
@@ -743,8 +758,7 @@
integer :: int_radius,idoubling,nspl_gravity
if(myrank == 0 ) then
- write(IMAIN,*) "preparing gravity arrays."
- write(IMAIN,*)
+ write(IMAIN,*) "preparing gravity arrays"
call flush_IMAIN()
endif
@@ -847,8 +861,7 @@
! get and store PREM attenuation model
if(myrank == 0 ) then
- write(IMAIN,*) "preparing attenuation."
- write(IMAIN,*)
+ write(IMAIN,*) "preparing attenuation"
call flush_IMAIN()
endif
@@ -1005,6 +1018,20 @@
endif
endif
+ if( USE_LDDRK ) then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ tau_sigma_CUSTOM_REAL(:) = sngl(tau_sigma_dble(:))
+ else
+ tau_sigma_CUSTOM_REAL(:) = tau_sigma_dble(:)
+ endif
+ endif
+
+ if(UNDO_ATTENUATION) then
+ b_alphaval = alphaval
+ b_betaval = betaval
+ b_gammaval = gammaval
+ endif
+
! synchronizes processes
call sync_all()
@@ -1027,34 +1054,33 @@
! local parameters
integer :: ier
+ real(kind=CUSTOM_REAL) :: init_value
if(myrank == 0 ) then
- write(IMAIN,*) "initializing wavefields."
- write(IMAIN,*)
+ write(IMAIN,*) "preparing wavefields"
call flush_IMAIN()
endif
+ ! put negligible initial value to avoid very slow underflow trapping
+ if(FIX_UNDERFLOW_PROBLEM) then
+ init_value = VERYSMALLVAL
+ else
+ init_value = 0._CUSTOM_REAL
+ endif
! initialize arrays to zero
- displ_crust_mantle(:,:) = 0._CUSTOM_REAL
+ displ_crust_mantle(:,:) = init_value
veloc_crust_mantle(:,:) = 0._CUSTOM_REAL
accel_crust_mantle(:,:) = 0._CUSTOM_REAL
- displ_outer_core(:) = 0._CUSTOM_REAL
+ displ_outer_core(:) = init_value
veloc_outer_core(:) = 0._CUSTOM_REAL
accel_outer_core(:) = 0._CUSTOM_REAL
- displ_inner_core(:,:) = 0._CUSTOM_REAL
+ displ_inner_core(:,:) = init_value
veloc_inner_core(:,:) = 0._CUSTOM_REAL
accel_inner_core(:,:) = 0._CUSTOM_REAL
- ! put negligible initial value to avoid very slow underflow trapping
- if(FIX_UNDERFLOW_PROBLEM) then
- displ_crust_mantle(:,:) = VERYSMALLVAL
- displ_outer_core(:) = VERYSMALLVAL
- displ_inner_core(:,:) = VERYSMALLVAL
- endif
-
! if doing benchmark runs to measure scaling of the code,
! set the initial field to 1 to make sure gradual underflow trapping does not slow down the code
if (DO_BENCHMARK_RUN_ONLY .and. SET_INITIAL_FIELD_TO_1_IN_BENCH) then
@@ -1071,6 +1097,7 @@
accel_inner_core(:,:) = 1._CUSTOM_REAL
endif
+ ! sensitivity kernels
if (SIMULATION_TYPE == 3) then
rho_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
beta_kl_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
@@ -1120,76 +1147,63 @@
! initialize to be on the save side for adjoint runs SIMULATION_TYPE==2
! crust/mantle
- eps_trace_over_3_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_xx_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_yy_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_xy_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_xz_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_yz_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
+ eps_trace_over_3_crust_mantle(:,:,:,:) = init_value
+ epsilondev_xx_crust_mantle(:,:,:,:) = init_value
+ epsilondev_yy_crust_mantle(:,:,:,:) = init_value
+ epsilondev_xy_crust_mantle(:,:,:,:) = init_value
+ epsilondev_xz_crust_mantle(:,:,:,:) = init_value
+ epsilondev_yz_crust_mantle(:,:,:,:) = init_value
! backward/reconstructed strain fields
- if( .not. UNDO_ATTENUATION ) then
- allocate(b_epsilondev_xx_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- b_epsilondev_yy_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- b_epsilondev_xy_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- b_epsilondev_xz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- b_epsilondev_yz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
- b_eps_trace_over_3_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT),stat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_epsilondev*** arrays for crust/mantle')
+ if( SIMULATION_TYPE == 3 ) then
+ if( UNDO_ATTENUATION ) then
+ ! for undo_attenuation, whenever strain is needed it will be computed locally.
+ ! pointers are using the allocated arrays for adjoint strain, however values stored in those arrays will be overwritten
+ ! crust/mantle
+ b_epsilondev_xx_crust_mantle => epsilondev_xx_crust_mantle
+ b_epsilondev_yy_crust_mantle => epsilondev_yy_crust_mantle
+ b_epsilondev_xy_crust_mantle => epsilondev_xy_crust_mantle
+ b_epsilondev_xz_crust_mantle => epsilondev_xz_crust_mantle
+ b_epsilondev_yz_crust_mantle => epsilondev_yz_crust_mantle
+ b_eps_trace_over_3_crust_mantle => eps_trace_over_3_crust_mantle
+ ! inner core
+ b_epsilondev_xx_inner_core => epsilondev_xx_inner_core
+ b_epsilondev_yy_inner_core => epsilondev_yy_inner_core
+ b_epsilondev_xy_inner_core => epsilondev_xy_inner_core
+ b_epsilondev_xz_inner_core => epsilondev_xz_inner_core
+ b_epsilondev_yz_inner_core => epsilondev_yz_inner_core
+ b_eps_trace_over_3_inner_core => eps_trace_over_3_inner_core
+ else
+ ! allocates actual arrays
+ allocate(b_epsilondev_xx_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ b_epsilondev_yy_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ b_epsilondev_xy_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ b_epsilondev_xz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ b_epsilondev_yz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT), &
+ b_eps_trace_over_3_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT),stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_epsilondev*** arrays for crust/mantle')
- allocate(b_epsilondev_xx_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT), &
- b_epsilondev_yy_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT), &
- b_epsilondev_xy_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT), &
- b_epsilondev_xz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT), &
- b_epsilondev_yz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT), &
- b_eps_trace_over_3_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT),stat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_epsilondev*** arrays for inner core')
- else
- ! dummy arrays
- allocate(b_epsilondev_xx_crust_mantle(1,1,1,1), &
- b_epsilondev_yy_crust_mantle(1,1,1,1), &
- b_epsilondev_xy_crust_mantle(1,1,1,1), &
- b_epsilondev_xz_crust_mantle(1,1,1,1), &
- b_epsilondev_yz_crust_mantle(1,1,1,1), &
- b_eps_trace_over_3_crust_mantle(1,1,1,1),stat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_epsilondev*** arrays for crust/mantle')
-
- allocate(b_epsilondev_xx_inner_core(1,1,1,1), &
- b_epsilondev_yy_inner_core(1,1,1,1), &
- b_epsilondev_xy_inner_core(1,1,1,1), &
- b_epsilondev_xz_inner_core(1,1,1,1), &
- b_epsilondev_yz_inner_core(1,1,1,1), &
- b_eps_trace_over_3_inner_core(1,1,1,1),stat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_epsilondev*** arrays for inner core')
+ allocate(b_epsilondev_xx_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT), &
+ b_epsilondev_yy_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT), &
+ b_epsilondev_xy_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT), &
+ b_epsilondev_xz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT), &
+ b_epsilondev_yz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT), &
+ b_eps_trace_over_3_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT),stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_epsilondev*** arrays for inner core')
+ endif
endif
+ ! to switch between simulation type 1 mode and simulation type 3 mode
+ ! in exact undoing of attenuation
+ undo_att_sim_type_3 = .false.
! inner core
- eps_trace_over_3_inner_core(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_xx_inner_core(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_yy_inner_core(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_xy_inner_core(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_xz_inner_core(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_yz_inner_core(:,:,:,:) = 0._CUSTOM_REAL
+ eps_trace_over_3_inner_core(:,:,:,:) = init_value
+ epsilondev_xx_inner_core(:,:,:,:) = init_value
+ epsilondev_yy_inner_core(:,:,:,:) = init_value
+ epsilondev_xy_inner_core(:,:,:,:) = init_value
+ epsilondev_xz_inner_core(:,:,:,:) = init_value
+ epsilondev_yz_inner_core(:,:,:,:) = init_value
-
-
- if(FIX_UNDERFLOW_PROBLEM) then
- ! crust/mantle
- eps_trace_over_3_crust_mantle(:,:,:,:) = VERYSMALLVAL
- epsilondev_xx_crust_mantle(:,:,:,:) = VERYSMALLVAL
- epsilondev_yy_crust_mantle(:,:,:,:) = VERYSMALLVAL
- epsilondev_xy_crust_mantle(:,:,:,:) = VERYSMALLVAL
- epsilondev_xz_crust_mantle(:,:,:,:) = VERYSMALLVAL
- epsilondev_yz_crust_mantle(:,:,:,:) = VERYSMALLVAL
- ! inner core
- eps_trace_over_3_inner_core(:,:,:,:) = VERYSMALLVAL
- epsilondev_xx_inner_core(:,:,:,:) = VERYSMALLVAL
- epsilondev_yy_inner_core(:,:,:,:) = VERYSMALLVAL
- epsilondev_xy_inner_core(:,:,:,:) = VERYSMALLVAL
- epsilondev_xz_inner_core(:,:,:,:) = VERYSMALLVAL
- epsilondev_yz_inner_core(:,:,:,:) = VERYSMALLVAL
- endif
-
if (COMPUTE_AND_STORE_STRAIN) then
if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3)) then
Iepsilondev_xx_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
@@ -1203,33 +1217,257 @@
! clear memory variables if attenuation
if(ATTENUATION_VAL) then
- R_xx_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
- R_yy_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
- R_xy_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
- R_xz_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
- R_yz_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
+ R_xx_crust_mantle(:,:,:,:,:) = init_value
+ R_yy_crust_mantle(:,:,:,:,:) = init_value
+ R_xy_crust_mantle(:,:,:,:,:) = init_value
+ R_xz_crust_mantle(:,:,:,:,:) = init_value
+ R_yz_crust_mantle(:,:,:,:,:) = init_value
- R_xx_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
- R_yy_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
- R_xy_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
- R_xz_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
- R_yz_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
+ R_xx_inner_core(:,:,:,:,:) = init_value
+ R_yy_inner_core(:,:,:,:,:) = init_value
+ R_xy_inner_core(:,:,:,:,:) = init_value
+ R_xz_inner_core(:,:,:,:,:) = init_value
+ R_yz_inner_core(:,:,:,:,:) = init_value
+ endif
- if(FIX_UNDERFLOW_PROBLEM) then
- R_xx_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
- R_yy_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
- R_xy_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
- R_xz_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
- R_yz_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
+ if(ROTATION_VAL) then
+ A_array_rotation = 0._CUSTOM_REAL
+ B_array_rotation = 0._CUSTOM_REAL
+ endif
- R_xx_inner_core(:,:,:,:,:) = VERYSMALLVAL
- R_yy_inner_core(:,:,:,:,:) = VERYSMALLVAL
- R_xy_inner_core(:,:,:,:,:) = VERYSMALLVAL
- R_xz_inner_core(:,:,:,:,:) = VERYSMALLVAL
- R_yz_inner_core(:,:,:,:,:) = VERYSMALLVAL
+ ! initializes backward/reconstructed arrays
+ if (SIMULATION_TYPE == 3) then
+ ! initializes wavefields
+ b_displ_crust_mantle = 0._CUSTOM_REAL
+ b_veloc_crust_mantle = 0._CUSTOM_REAL
+ b_accel_crust_mantle = 0._CUSTOM_REAL
+
+ b_displ_inner_core = 0._CUSTOM_REAL
+ b_veloc_inner_core = 0._CUSTOM_REAL
+ b_accel_inner_core = 0._CUSTOM_REAL
+
+ b_displ_outer_core = 0._CUSTOM_REAL
+ b_veloc_outer_core = 0._CUSTOM_REAL
+ b_accel_outer_core = 0._CUSTOM_REAL
+
+ b_epsilondev_xx_crust_mantle = 0._CUSTOM_REAL
+ b_epsilondev_yy_crust_mantle = 0._CUSTOM_REAL
+ b_epsilondev_xy_crust_mantle = 0._CUSTOM_REAL
+ b_epsilondev_xz_crust_mantle = 0._CUSTOM_REAL
+ b_epsilondev_yz_crust_mantle = 0._CUSTOM_REAL
+
+ b_epsilondev_xx_inner_core = 0._CUSTOM_REAL
+ b_epsilondev_yy_inner_core = 0._CUSTOM_REAL
+ b_epsilondev_xy_inner_core = 0._CUSTOM_REAL
+ b_epsilondev_xz_inner_core = 0._CUSTOM_REAL
+ b_epsilondev_yz_inner_core = 0._CUSTOM_REAL
+
+ if (ROTATION_VAL) then
+ b_A_array_rotation = 0._CUSTOM_REAL
+ b_B_array_rotation = 0._CUSTOM_REAL
endif
+
+ if (ATTENUATION_VAL) then
+ b_R_xx_crust_mantle = 0._CUSTOM_REAL
+ b_R_yy_crust_mantle = 0._CUSTOM_REAL
+ b_R_xy_crust_mantle = 0._CUSTOM_REAL
+ b_R_xz_crust_mantle = 0._CUSTOM_REAL
+ b_R_yz_crust_mantle = 0._CUSTOM_REAL
+
+ b_R_xx_inner_core = 0._CUSTOM_REAL
+ b_R_yy_inner_core = 0._CUSTOM_REAL
+ b_R_xy_inner_core = 0._CUSTOM_REAL
+ b_R_xz_inner_core = 0._CUSTOM_REAL
+ b_R_yz_inner_core = 0._CUSTOM_REAL
+ endif
endif
+ ! runge-kutta time scheme
+ if( USE_LDDRK )then
+
+ ! checks
+ if(SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. NOISE_TOMOGRAPHY /= 0) &
+ stop 'error: LDDRK is not implemented for adjoint tomography'
+
+ ! number of stages for scheme
+ NSTAGE_TIME_SCHEME = NSTAGE ! 6 stages
+
+ ! scheme wavefields
+ allocate(displ_crust_mantle_lddrk(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array displ_crust_mantle_lddrk'
+ allocate(veloc_crust_mantle_lddrk(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array veloc_crust_mantle_lddrk'
+ allocate(displ_outer_core_lddrk(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array displ_outer_core_lddrk'
+ allocate(veloc_outer_core_lddrk(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array veloc_outer_core_lddrk'
+ allocate(displ_inner_core_lddrk(NDIM,NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array displ_inner_core_lddrk'
+ allocate(veloc_inner_core_lddrk(NDIM,NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array veloc_inner_core_lddrk'
+
+ displ_crust_mantle_lddrk(:,:) = init_value
+ veloc_crust_mantle_lddrk(:,:) = 0._CUSTOM_REAL
+
+ displ_outer_core_lddrk(:) = init_value
+ veloc_outer_core_lddrk(:) = 0._CUSTOM_REAL
+
+ displ_inner_core_lddrk(:,:) = init_value
+ veloc_inner_core_lddrk(:,:) = 0._CUSTOM_REAL
+
+ if( SIMULATION_TYPE == 3 ) then
+ ! scheme adjoint wavefields
+ allocate(b_displ_crust_mantle_lddrk(NDIM,NGLOB_CRUST_MANTLE_ADJOINT),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_displ_crust_mantle_lddrk'
+ allocate(b_veloc_crust_mantle_lddrk(NDIM,NGLOB_CRUST_MANTLE_ADJOINT),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_veloc_crust_mantle_lddrk'
+ allocate(b_displ_outer_core_lddrk(NGLOB_OUTER_CORE_ADJOINT),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_displ_outer_core_lddrk'
+ allocate(b_veloc_outer_core_lddrk(NGLOB_OUTER_CORE_ADJOINT),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_veloc_outer_core_lddrk'
+ allocate(b_displ_inner_core_lddrk(NDIM,NGLOB_INNER_CORE_ADJOINT),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_displ_inner_core_lddrk'
+ allocate(b_veloc_inner_core_lddrk(NDIM,NGLOB_INNER_CORE_ADJOINT),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_veloc_inner_core_lddrk'
+ b_displ_crust_mantle_lddrk(:,:) = init_value
+ b_veloc_crust_mantle_lddrk(:,:) = 0._CUSTOM_REAL
+ b_displ_outer_core_lddrk(:) = init_value
+ b_veloc_outer_core_lddrk(:) = 0._CUSTOM_REAL
+ b_displ_inner_core_lddrk(:,:) = init_value
+ b_veloc_inner_core_lddrk(:,:) = 0._CUSTOM_REAL
+ endif
+
+ ! rotation in fluid outer core
+ allocate(A_array_rotation_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array A_array_rotation_lddrk'
+ allocate(B_array_rotation_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array B_array_rotation_lddrk'
+ if (ROTATION_VAL) then
+ A_array_rotation_lddrk(:,:,:,:) = 0._CUSTOM_REAL
+ B_array_rotation_lddrk(:,:,:,:) = 0._CUSTOM_REAL
+ endif
+ if( SIMULATION_TYPE == 3 ) then
+ allocate(b_A_array_rotation_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_A_array_rotation_lddrk'
+ allocate(b_B_array_rotation_lddrk(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_B_array_rotation_lddrk'
+ if (ROTATION_VAL) then
+ b_A_array_rotation_lddrk(:,:,:,:) = 0._CUSTOM_REAL
+ b_B_array_rotation_lddrk(:,:,:,:) = 0._CUSTOM_REAL
+ endif
+ endif
+
+ ! attenuation memory variables
+ ! crust/mantle
+ allocate(R_xx_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION), &
+ R_yy_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION), &
+ R_xy_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION), &
+ R_xz_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION), &
+ R_yz_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION), &
+ stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array R_memory_crust_mantle_lddrk'
+ ! inner core
+ allocate(R_xx_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION), &
+ R_yy_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION), &
+ R_xy_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION), &
+ R_xz_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION), &
+ R_yz_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION), &
+ stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array R_memory_inner_core_lddrk'
+ if(ATTENUATION_VAL) then
+ R_xx_crust_mantle_lddrk(:,:,:,:,:) = init_value
+ R_yy_crust_mantle_lddrk(:,:,:,:,:) = init_value
+ R_xy_crust_mantle_lddrk(:,:,:,:,:) = init_value
+ R_xz_crust_mantle_lddrk(:,:,:,:,:) = init_value
+ R_yz_crust_mantle_lddrk(:,:,:,:,:) = init_value
+
+ R_xx_inner_core_lddrk(:,:,:,:,:) = init_value
+ R_yy_inner_core_lddrk(:,:,:,:,:) = init_value
+ R_xy_inner_core_lddrk(:,:,:,:,:) = init_value
+ R_xz_inner_core_lddrk(:,:,:,:,:) = init_value
+ R_yz_inner_core_lddrk(:,:,:,:,:) = init_value
+ endif
+ if( SIMULATION_TYPE == 3 ) then
+ ! crust/mantle
+ allocate(b_R_xx_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT), &
+ b_R_yy_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT), &
+ b_R_xy_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT), &
+ b_R_xz_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT), &
+ b_R_yz_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT), &
+ stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array R_memory_crust_mantle_lddrk'
+ ! inner core
+ allocate(b_R_xx_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT), &
+ b_R_yy_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT), &
+ b_R_xy_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT), &
+ b_R_xz_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT), &
+ b_R_yz_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT), &
+ stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array R_memory_inner_core_lddrk'
+ if(ATTENUATION_VAL) then
+ b_R_xx_crust_mantle_lddrk(:,:,:,:,:) = init_value
+ b_R_yy_crust_mantle_lddrk(:,:,:,:,:) = init_value
+ b_R_xy_crust_mantle_lddrk(:,:,:,:,:) = init_value
+ b_R_xz_crust_mantle_lddrk(:,:,:,:,:) = init_value
+ b_R_yz_crust_mantle_lddrk(:,:,:,:,:) = init_value
+
+ b_R_xx_inner_core_lddrk(:,:,:,:,:) = init_value
+ b_R_yy_inner_core_lddrk(:,:,:,:,:) = init_value
+ b_R_xy_inner_core_lddrk(:,:,:,:,:) = init_value
+ b_R_xz_inner_core_lddrk(:,:,:,:,:) = init_value
+ b_R_yz_inner_core_lddrk(:,:,:,:,:) = init_value
+ endif
+ endif
+
+ else
+
+ ! default Newmark time scheme
+
+ ! only 1 stage for Newmark time scheme
+ NSTAGE_TIME_SCHEME = 1
+
+ ! dummy arrays needed for passing as function arguments
+ allocate(A_array_rotation_lddrk(NGLLX,NGLLY,NGLLZ,1),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array A_array_rotation_lddrk'
+ allocate(B_array_rotation_lddrk(NGLLX,NGLLY,NGLLZ,1),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array B_array_rotation_lddrk'
+ allocate(R_xx_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ R_yy_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ R_xy_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ R_xz_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ R_yz_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array R_memory_crust_mantle_lddrk'
+ allocate(R_xx_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ R_yy_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ R_xy_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ R_xz_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ R_yz_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array R_memory_inner_core_lddrk'
+ if( SIMULATION_TYPE == 3 ) then
+ allocate(b_A_array_rotation_lddrk(NGLLX,NGLLY,NGLLZ,1),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_A_array_rotation_lddrk'
+ allocate(b_B_array_rotation_lddrk(NGLLX,NGLLY,NGLLZ,1),stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_B_array_rotation_lddrk'
+ allocate(b_R_xx_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ b_R_yy_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ b_R_xy_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ b_R_xz_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ b_R_yz_crust_mantle_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_R_memory_crust_mantle_lddrk'
+ allocate(b_R_xx_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ b_R_yy_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ b_R_xy_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ b_R_xz_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ b_R_yz_inner_core_lddrk(N_SLS,NGLLX,NGLLY,NGLLZ,1), &
+ stat=ier)
+ if(ier /= 0) stop 'error: not enough memory to allocate array b_R_memory_inner_core_lddrk'
+ endif
+
+ endif
+
call sync_all()
end subroutine prepare_timerun_init_wavefield
@@ -1536,8 +1774,7 @@
if ( NOISE_TOMOGRAPHY /= 0 ) then
if(myrank == 0 ) then
- write(IMAIN,*) "preparing noise arrays."
- write(IMAIN,*)
+ write(IMAIN,*) "preparing noise arrays"
call flush_IMAIN()
endif
@@ -1594,8 +1831,7 @@
! user output
if(myrank == 0 ) then
- write(IMAIN,*) "preparing Fields and Constants on GPU Device."
- write(IMAIN,*)
+ write(IMAIN,*) "preparing Fields and Constants on GPU Device"
call flush_IMAIN()
endif
@@ -1934,7 +2170,7 @@
etax_inner_core,etay_inner_core,etaz_inner_core, &
gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
- rmass_inner_core, &
+ rmassx_inner_core,rmassy_inner_core,rmassz_inner_core, &
ibool_inner_core, &
xstore_inner_core,ystore_inner_core,zstore_inner_core, &
c11store_inner_core,c12store_inner_core,c13store_inner_core, &
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -28,24 +28,24 @@
! read arrays created by the mesher
subroutine read_arrays_solver(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, &
- b_rmassx,b_rmassy)
+ 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, &
+ b_rmassx,b_rmassy)
use constants_solver
use specfem_par,only: &
ABSORBING_CONDITIONS, &
LOCAL_PATH,ABSORBING_CONDITIONS,&
- EXACT_MASS_MATRIX_FOR_ROTATION,USE_LDDRK
+ EXACT_MASS_MATRIX_FOR_ROTATION
implicit none
@@ -88,9 +88,8 @@
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
+ logical :: READ_KAPPA_MU,READ_TISO
-! character(len=150) :: LOCAL_PATH
! local parameters
integer :: ier,lnspec,lnglob
@@ -206,26 +205,21 @@
!
! 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(.not. USE_LDDRK)then
- if((NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE)) then
- read(IIN) rmassx
- read(IIN) rmassy
- endif
+ if( ((NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ ((ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION) .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ ((ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION) .and. iregion_code == IREGION_INNER_CORE)) then
+ read(IIN) rmassx
+ read(IIN) rmassy
endif
read(IIN) rmassz
- if(.not. USE_LDDRK)then
- if((ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE))then
- read(IIN) b_rmassx
- read(IIN) b_rmassy
- endif
+ if( ((ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION) .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ ((ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION) .and. iregion_code == IREGION_INNER_CORE))then
+ read(IIN) b_rmassx
+ read(IIN) b_rmassy
endif
-
! read additional ocean load mass matrix
if(OCEANS_VAL .and. iregion_code == IREGION_CRUST_MANTLE) read(IIN) rmass_ocean_load
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver_adios.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver_adios.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver_adios.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -48,7 +48,7 @@
use specfem_par,only: &
ABSORBING_CONDITIONS,TRANSVERSE_ISOTROPY, &
ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS,LOCAL_PATH,ABSORBING_CONDITIONS,&
- EXACT_MASS_MATRIX_FOR_ROTATION,USE_LDDRK
+ EXACT_MASS_MATRIX_FOR_ROTATION
implicit none
@@ -392,10 +392,9 @@
!call adios_perform_reads(adios_handle, adios_err)
!call check_adios_err(myrank,adios_err)
- if(.not. USE_LDDRK)then
- if((NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE)) then
+ if( (NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE)) then
local_dim = nglob_xy
start(1) = local_dim*myrank; count(1) = local_dim
@@ -421,22 +420,20 @@
rmassz, adios_err)
call check_adios_err(myrank,adios_err)
- if(.not. USE_LDDRK)then
- if((ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
- (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE))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)
+ if( (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_CRUST_MANTLE) .or. &
+ (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION .and. iregion_code == IREGION_INNER_CORE))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, "b_rmassx/array", 0, 1, &
- b_rmassx, adios_err)
- call check_adios_err(myrank,adios_err)
- call adios_schedule_read(adios_handle, sel, "b_rmassy/array", 0, 1, &
- b_rmassy, adios_err)
- call check_adios_err(myrank,adios_err)
- endif
+ call adios_schedule_read(adios_handle, sel, "b_rmassx/array", 0, 1, &
+ b_rmassx, adios_err)
+ call check_adios_err(myrank,adios_err)
+ call adios_schedule_read(adios_handle, sel, "b_rmassy/array", 0, 1, &
+ b_rmassy, adios_err)
+ call check_adios_err(myrank,adios_err)
endif
!call adios_perform_reads(adios_handle, adios_err)
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_forward_arrays.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -40,7 +40,10 @@
integer :: ier
character(len=150) outputname
- ! checks
+ ! checks if anything to do
+ if( UNDO_ATTENUATION ) return
+
+ ! checks run/checkpoint number
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'
if(NUMBER_OF_THIS_RUN < 1 .or. NUMBER_OF_THIS_RUN > NUMBER_OF_RUNS) &
@@ -58,9 +61,6 @@
it_end = NSTEP
endif
- ! checks if anything to do
- if( UNDO_ATTENUATION ) return
-
! read files back from local disk or MT tape system if restart file
if(NUMBER_OF_THIS_RUN > 1) then
if( ADIOS_ENABLED .and. ADIOS_FOR_FORWARD_ARRAYS ) then
@@ -113,53 +113,6 @@
endif
endif
- ! initializes backward/reconstructed arrays
- if (SIMULATION_TYPE == 3) then
- ! initializes wavefields
- b_displ_crust_mantle = 0._CUSTOM_REAL
- b_veloc_crust_mantle = 0._CUSTOM_REAL
- b_accel_crust_mantle = 0._CUSTOM_REAL
-
- b_displ_inner_core = 0._CUSTOM_REAL
- b_veloc_inner_core = 0._CUSTOM_REAL
- b_accel_inner_core = 0._CUSTOM_REAL
-
- b_displ_outer_core = 0._CUSTOM_REAL
- b_veloc_outer_core = 0._CUSTOM_REAL
- b_accel_outer_core = 0._CUSTOM_REAL
-
- b_epsilondev_xx_crust_mantle = 0._CUSTOM_REAL
- b_epsilondev_yy_crust_mantle = 0._CUSTOM_REAL
- b_epsilondev_xy_crust_mantle = 0._CUSTOM_REAL
- b_epsilondev_xz_crust_mantle = 0._CUSTOM_REAL
- b_epsilondev_yz_crust_mantle = 0._CUSTOM_REAL
-
- b_epsilondev_xx_inner_core = 0._CUSTOM_REAL
- b_epsilondev_yy_inner_core = 0._CUSTOM_REAL
- b_epsilondev_xy_inner_core = 0._CUSTOM_REAL
- b_epsilondev_xz_inner_core = 0._CUSTOM_REAL
- b_epsilondev_yz_inner_core = 0._CUSTOM_REAL
-
- if (ROTATION_VAL) then
- b_A_array_rotation = 0._CUSTOM_REAL
- b_B_array_rotation = 0._CUSTOM_REAL
- endif
-
- if (ATTENUATION_VAL) then
- b_R_xx_crust_mantle = 0._CUSTOM_REAL
- b_R_yy_crust_mantle = 0._CUSTOM_REAL
- b_R_xy_crust_mantle = 0._CUSTOM_REAL
- b_R_xz_crust_mantle = 0._CUSTOM_REAL
- b_R_yz_crust_mantle = 0._CUSTOM_REAL
-
- b_R_xx_inner_core = 0._CUSTOM_REAL
- b_R_yy_inner_core = 0._CUSTOM_REAL
- b_R_xy_inner_core = 0._CUSTOM_REAL
- b_R_xz_inner_core = 0._CUSTOM_REAL
- b_R_yz_inner_core = 0._CUSTOM_REAL
- endif
- endif
-
end subroutine read_forward_arrays_startrun
!
@@ -181,6 +134,10 @@
integer :: ier
character(len=150) outputname
+ ! checks if anything to do
+ if( UNDO_ATTENUATION ) return
+
+ ! reads in file data
if( ADIOS_ENABLED .and. ADIOS_FOR_FORWARD_ARRAYS ) then
call read_forward_arrays_adios()
else
@@ -205,19 +162,17 @@
read(IIN) b_veloc_outer_core
read(IIN) b_accel_outer_core
- if( .not. UNDO_ATTENUATION ) then
- read(IIN) b_epsilondev_xx_crust_mantle
- read(IIN) b_epsilondev_yy_crust_mantle
- read(IIN) b_epsilondev_xy_crust_mantle
- read(IIN) b_epsilondev_xz_crust_mantle
- read(IIN) b_epsilondev_yz_crust_mantle
+ read(IIN) b_epsilondev_xx_crust_mantle
+ read(IIN) b_epsilondev_yy_crust_mantle
+ read(IIN) b_epsilondev_xy_crust_mantle
+ read(IIN) b_epsilondev_xz_crust_mantle
+ read(IIN) b_epsilondev_yz_crust_mantle
- read(IIN) b_epsilondev_xx_inner_core
- read(IIN) b_epsilondev_yy_inner_core
- read(IIN) b_epsilondev_xy_inner_core
- read(IIN) b_epsilondev_xz_inner_core
- read(IIN) b_epsilondev_yz_inner_core
- endif
+ read(IIN) b_epsilondev_xx_inner_core
+ read(IIN) b_epsilondev_yy_inner_core
+ read(IIN) b_epsilondev_xy_inner_core
+ read(IIN) b_epsilondev_xz_inner_core
+ read(IIN) b_epsilondev_yz_inner_core
if (ROTATION_VAL) then
read(IIN) b_A_array_rotation
@@ -288,7 +243,7 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine read_forward_arrays_undoatt(iteration_on_subset)
+ subroutine read_forward_arrays_undoatt()
! reads in saved wavefields
@@ -299,13 +254,16 @@
implicit none
- integer :: iteration_on_subset
-
! local parameters
+ integer :: iteration_on_subset_tmp
integer :: ier
character(len=150) :: outputname
- write(outputname,'(a,i6.6,a,i6.6,a)') 'proc',myrank,'_save_frame_at',iteration_on_subset,'.bin'
+ ! current subset iteration
+ iteration_on_subset_tmp = NSTEP/NT_DUMP_ATTENUATION - iteration_on_subset + 1
+
+ ! reads in saved wavefield
+ write(outputname,'(a,i6.6,a,i6.6,a)') 'proc',myrank,'_save_frame_at',iteration_on_subset_tmp,'.bin'
open(unit=IIN,file=trim(LOCAL_PATH)//'/'//outputname,status='old',action='read',form='unformatted',iostat=ier)
if( ier /= 0 ) call exit_MPI(myrank,'error opening file proc***_save_frame_at** for reading')
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_mesh_databases.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -169,6 +169,8 @@
allocate(rmassz_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
if(ier /= 0) stop 'error allocating rmassz in crust_mantle'
+ ! b_rmassx and b_rmassy will be different to rmassx and rmassy
+ ! needs new arrays
allocate(b_rmassx_crust_mantle(NGLOB_XY_CM), &
b_rmassy_crust_mantle(NGLOB_XY_CM),stat=ier)
if(ier /= 0) stop 'error allocating b_rmassx, b_rmassy in crust_mantle'
@@ -228,6 +230,35 @@
deallocate(dummy_idoubling)
+ ! mass matrix corrections
+ if( .not. ((NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) .or. &
+ (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION) ) ) then
+ ! uses single mass matrix without correction
+ ! frees pointer memory
+ deallocate(rmassx_crust_mantle,rmassy_crust_mantle)
+ ! re-associates with corresponding rmassz
+ rmassx_crust_mantle => rmassz_crust_mantle(:)
+ rmassy_crust_mantle => rmassz_crust_mantle(:)
+ endif
+
+ ! kernel simulations
+ if( SIMULATION_TYPE == 3 ) then
+ ! associates mass matrix used for backward/reconstructed wavefields
+ b_rmassz_crust_mantle => rmassz_crust_mantle
+ ! checks if we can take rmassx and rmassy (only differs for rotation correction)
+ if( .not. (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION) ) then
+ ! frees pointer memory
+ deallocate(b_rmassx_crust_mantle,b_rmassy_crust_mantle)
+ ! re-associates with corresponding rmassx,rmassy
+ b_rmassx_crust_mantle => rmassx_crust_mantle(:)
+ b_rmassy_crust_mantle => rmassy_crust_mantle(:)
+ endif
+ else
+ ! b_rmassx,b_rmassy not used anymore
+ deallocate(b_rmassx_crust_mantle,b_rmassy_crust_mantle)
+ endif
+
+
end subroutine read_mesh_databases_CM
!
@@ -340,6 +371,12 @@
& iboolmax does not equal nglob in outer core')
endif
+ ! kernel simulations
+ if( SIMULATION_TYPE == 3 ) then
+ ! associates mass matrix used for backward/reconstructed wavefields
+ b_rmass_outer_core => rmass_outer_core
+ endif
+
end subroutine read_mesh_databases_OC
!
@@ -391,9 +428,10 @@
rmassy_inner_core(NGLOB_XY_IC),stat=ier)
if(ier /= 0) stop 'error allocating rmassx, rmassy in inner_core'
- allocate(rmass_inner_core(NGLOB_INNER_CORE),stat=ier)
+ allocate(rmassz_inner_core(NGLOB_INNER_CORE),stat=ier)
if(ier /= 0) stop 'error allocating rmass in inner core'
+ ! b_rmassx and b_rmassy maybe different to rmassx,rmassy
allocate(b_rmassx_inner_core(NGLOB_XY_IC), &
b_rmassy_inner_core(NGLOB_XY_IC),stat=ier)
if(ier /= 0) stop 'error allocating b_rmassx, b_rmassy in inner_core'
@@ -418,7 +456,7 @@
c44store_inner_core,dummy_array,dummy_array, &
dummy_array,dummy_array,dummy_array, &
ibool_inner_core,idoubling_inner_core,dummy_ispec_is_tiso, &
- rmassx_inner_core,rmassy_inner_core,rmass_inner_core,rmass_ocean_load, &
+ rmassx_inner_core,rmassy_inner_core,rmassz_inner_core,rmass_ocean_load, &
READ_KAPPA_MU,READ_TISO, &
b_rmassx_inner_core,b_rmassy_inner_core)
else
@@ -440,7 +478,7 @@
c44store_inner_core,dummy_array,dummy_array, &
dummy_array,dummy_array,dummy_array, &
ibool_inner_core,idoubling_inner_core,dummy_ispec_is_tiso, &
- rmassx_inner_core,rmassy_inner_core,rmass_inner_core,rmass_ocean_load, &
+ rmassx_inner_core,rmassy_inner_core,rmassz_inner_core,rmass_ocean_load, &
READ_KAPPA_MU,READ_TISO, &
b_rmassx_inner_core,b_rmassy_inner_core)
endif
@@ -451,6 +489,33 @@
if(minval(ibool_inner_core(:,:,:,:)) /= 1 .or. maxval(ibool_inner_core(:,:,:,:)) /= NGLOB_INNER_CORE) &
call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in inner core')
+ ! mass matrix corrections
+ if( .not. ( ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION ) ) then
+ ! uses single mass matrix without correction
+ ! frees pointer memory
+ deallocate(rmassx_inner_core,rmassy_inner_core)
+ ! re-associates with corresponding rmassz
+ rmassx_inner_core => rmassz_inner_core(:)
+ rmassy_inner_core => rmassz_inner_core(:)
+ endif
+
+ ! kernel simulations
+ if( SIMULATION_TYPE == 3 ) then
+ ! associates mass matrix used for backward/reconstructed wavefields
+ b_rmassz_inner_core => rmassz_inner_core
+ ! checks if we can take rmassx and rmassy (only differs for rotation correction)
+ if( .not. (ROTATION_VAL .and. EXACT_MASS_MATRIX_FOR_ROTATION) ) then
+ ! frees pointer memory
+ deallocate(b_rmassx_inner_core,b_rmassy_inner_core)
+ ! re-associates with corresponding rmassx,rmassy
+ b_rmassx_inner_core => rmassx_inner_core
+ b_rmassy_inner_core => rmassy_inner_core
+ endif
+ else
+ ! b_rmassx,b_rmassy not used anymore
+ deallocate(b_rmassx_inner_core,b_rmassy_inner_core)
+ endif
+
end subroutine read_mesh_databases_IC
!
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/rules.mk
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/rules.mk 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/rules.mk 2013-09-04 13:17:07 UTC (rev 22769)
@@ -59,6 +59,7 @@
$O/compute_boundary_kernel.solverstatic.o \
$O/compute_coupling.solverstatic.o \
$O/compute_element.solverstatic.o \
+ $O/compute_element_att_memory.solverstatic.o \
$O/compute_element_strain.solverstatic.o \
$O/compute_forces_acoustic_calling_routine.solverstatic.o \
$O/compute_forces_viscoelastic_calling_routine.solverstatic.o \
@@ -76,9 +77,10 @@
$O/get_attenuation.solverstatic.o \
$O/initialize_simulation.solverstatic.o \
$O/iterate_time.solverstatic.o \
+ $O/iterate_time_undoatt.solverstatic.o \
$O/locate_receivers.solverstatic.o \
$O/locate_regular_points.solverstatic.o \
- $O/locate_sources.solver.o \
+ $O/locate_sources.solverstatic.o \
$O/noise_tomography.solverstatic.o \
$O/prepare_timerun.solverstatic.o \
$O/read_arrays_solver.solverstatic.o \
@@ -91,11 +93,12 @@
$O/setup_GLL_points.solverstatic.o \
$O/setup_sources_receivers.solverstatic.o \
$O/specfem3D.solverstatic.o \
+ $O/update_displacement_LDDRK.solverstatic.o \
$O/update_displacement_Newmark.solverstatic.o \
$O/write_movie_output.solverstatic.o \
$O/write_movie_volume.solverstatic.o \
$O/write_movie_surface.solverstatic.o \
- $O/write_seismograms.solver.o \
+ $O/write_seismograms.solverstatic.o \
$(EMPTY_MACRO)
# These files come from the shared directory
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/save_forward_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/save_forward_arrays.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/save_forward_arrays.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -125,19 +125,17 @@
write(IOUT) veloc_outer_core
write(IOUT) accel_outer_core
- if( .not. UNDO_ATTENUATION ) then
- write(IOUT) epsilondev_xx_crust_mantle
- write(IOUT) epsilondev_yy_crust_mantle
- write(IOUT) epsilondev_xy_crust_mantle
- write(IOUT) epsilondev_xz_crust_mantle
- write(IOUT) epsilondev_yz_crust_mantle
+ write(IOUT) epsilondev_xx_crust_mantle
+ write(IOUT) epsilondev_yy_crust_mantle
+ write(IOUT) epsilondev_xy_crust_mantle
+ write(IOUT) epsilondev_xz_crust_mantle
+ write(IOUT) epsilondev_yz_crust_mantle
- write(IOUT) epsilondev_xx_inner_core
- write(IOUT) epsilondev_yy_inner_core
- write(IOUT) epsilondev_xy_inner_core
- write(IOUT) epsilondev_xz_inner_core
- write(IOUT) epsilondev_yz_inner_core
- endif
+ write(IOUT) epsilondev_xx_inner_core
+ write(IOUT) epsilondev_yy_inner_core
+ write(IOUT) epsilondev_xy_inner_core
+ write(IOUT) epsilondev_xz_inner_core
+ write(IOUT) epsilondev_yz_inner_core
if (ROTATION_VAL) then
write(IOUT) A_array_rotation
@@ -168,7 +166,7 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine save_forward_arrays_undoatt(iteration_on_subset)
+ subroutine save_forward_arrays_undoatt()
use specfem_par
use specfem_par_crustmantle
@@ -177,56 +175,53 @@
implicit none
- integer :: iteration_on_subset
-
! local parameters
+ integer :: iteration_on_subset_tmp
integer :: ier
character(len=150) :: outputname
- ! save files to local disk or tape system if restart file
- if(NUMBER_OF_RUNS > 1) stop 'NUMBER_OF_RUNS > 1 is not support for undoing attenuation'
+ ! current subset iteration
+ iteration_on_subset_tmp = iteration_on_subset
- ! save last frame of the forward simulation
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
- write(outputname,'(a,i6.6,a,i6.6,a)') 'proc',myrank,'_save_frame_at',iteration_on_subset,'.bin'
- open(unit=IOUT,file=trim(LOCAL_PATH)//'/'//outputname,status='unknown',form='unformatted',action='write',iostat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error opening file proc***_save_frame_at** for writing')
+ ! saves frame of the forward simulation
- write(IOUT) displ_crust_mantle
- write(IOUT) veloc_crust_mantle
- write(IOUT) accel_crust_mantle
+ write(outputname,'(a,i6.6,a,i6.6,a)') 'proc',myrank,'_save_frame_at',iteration_on_subset_tmp,'.bin'
+ open(unit=IOUT,file=trim(LOCAL_PATH)//'/'//outputname,status='unknown',form='unformatted',action='write',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening file proc***_save_frame_at** for writing')
- write(IOUT) displ_inner_core
- write(IOUT) veloc_inner_core
- write(IOUT) accel_inner_core
+ write(IOUT) displ_crust_mantle
+ write(IOUT) veloc_crust_mantle
+ write(IOUT) accel_crust_mantle
- write(IOUT) displ_outer_core
- write(IOUT) veloc_outer_core
- write(IOUT) accel_outer_core
+ write(IOUT) displ_inner_core
+ write(IOUT) veloc_inner_core
+ write(IOUT) accel_inner_core
- if (ROTATION_VAL) then
- write(IOUT) A_array_rotation
- write(IOUT) B_array_rotation
- endif
+ write(IOUT) displ_outer_core
+ write(IOUT) veloc_outer_core
+ write(IOUT) accel_outer_core
- if (ATTENUATION_VAL) then
- write(IOUT) R_xx_crust_mantle
- write(IOUT) R_yy_crust_mantle
- write(IOUT) R_xy_crust_mantle
- write(IOUT) R_xz_crust_mantle
- write(IOUT) R_yz_crust_mantle
+ if (ROTATION_VAL) then
+ write(IOUT) A_array_rotation
+ write(IOUT) B_array_rotation
+ endif
- write(IOUT) R_xx_inner_core
- write(IOUT) R_yy_inner_core
- write(IOUT) R_xy_inner_core
- write(IOUT) R_xz_inner_core
- write(IOUT) R_yz_inner_core
- endif
+ if (ATTENUATION_VAL) then
+ write(IOUT) R_xx_crust_mantle
+ write(IOUT) R_yy_crust_mantle
+ write(IOUT) R_xy_crust_mantle
+ write(IOUT) R_xz_crust_mantle
+ write(IOUT) R_yz_crust_mantle
- close(IOUT)
-
+ write(IOUT) R_xx_inner_core
+ write(IOUT) R_yy_inner_core
+ write(IOUT) R_xy_inner_core
+ write(IOUT) R_xz_inner_core
+ write(IOUT) R_yz_inner_core
endif
+ close(IOUT)
+
end subroutine save_forward_arrays_undoatt
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/setup_sources_receivers.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -265,6 +265,16 @@
use specfem_par
implicit none
+ ! local parameters
+ logical :: is_initial_guess
+
+ ! checks if set by initial guess from read_compute_parameters() routine
+ if( NTSTEP_BETWEEN_OUTPUT_SEISMOS == NSTEP) then
+ is_initial_guess = .true.
+ else
+ is_initial_guess = .false.
+ endif
+
! from intial guess in read_compute_parameters:
! compute total number of time steps, rounded to next multiple of 100
! NSTEP = 100 * (int(RECORD_LENGTH_IN_MINUTES * 60.d0 / (100.d0*DT)) + 1)
@@ -281,7 +291,7 @@
! subsets used to save seismograms must not be larger than the whole time series,
! otherwise we waste memory
- if(NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP) NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP
+ if(NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP .or. is_initial_guess) NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP
! re-checks output steps?
!if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
@@ -745,8 +755,9 @@
allocate(seismograms(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
if(ier /= 0) stop 'error while allocating seismograms'
else
+ ! adjoint seismograms
allocate(seismograms(NDIM*NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
- if(ier /= 0) stop 'error while allocating seismograms'
+ if(ier /= 0) stop 'error while allocating adjoint seismograms'
! allocate Frechet derivatives array
allocate(moment_der(NDIM,NDIM,nrec_local),sloc_der(NDIM,nrec_local), &
stshift_der(nrec_local),shdur_der(nrec_local),stat=ier)
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -29,6 +29,8 @@
program xspecfem3D
+ use specfem_par
+
implicit none
!=======================================================================!
@@ -461,7 +463,11 @@
call prepare_timerun()
! steps through time iterations
- call iterate_time()
+ if( UNDO_ATTENUATION ) then
+ call iterate_time_undoatt()
+ else
+ call iterate_time()
+ endif
! saves last time frame and finishes kernel calculations
call finalize_simulation()
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D_par.F90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -119,15 +119,8 @@
! 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
@@ -274,23 +267,25 @@
integer :: it
- ! Newmark time scheme parameters and non-dimensionalization
+ ! non-dimensionalization
double precision :: scale_t,scale_t_inv,scale_displ,scale_veloc
+
+ ! time scheme parameters
real(kind=CUSTOM_REAL) :: deltat,deltatover2,deltatsqover2
! ADJOINT
real(kind=CUSTOM_REAL) :: b_deltat,b_deltatover2,b_deltatsqover2
- ! this is for LDDRK
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: displ_crust_mantle_lddrk,veloc_crust_mantle_lddrk
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: displ_outer_core_lddrk,veloc_outer_core_lddrk
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: displ_inner_core_lddrk,veloc_inner_core_lddrk
+ ! LDDRK time scheme
+ integer :: NSTAGE_TIME_SCHEME,istage
+ real(kind=CUSTOM_REAL),dimension(N_SLS) :: tau_sigma_CUSTOM_REAL
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: A_array_rotation_lddrk,B_array_rotation_lddrk
- real(kind=CUSTOM_REAL),dimension(:,:,:,:,:,:), allocatable :: R_memory_crust_mantle_lddrk
- real(kind=CUSTOM_REAL),dimension(:,:,:,:,:,:), allocatable :: R_memory_inner_core_lddrk
+ ! undo_attenuation
+ ! to switch between simulation type 1 mode and simulation type 3 mode
+ ! in exact undoing of attenuation
+ logical :: undo_att_sim_type_3
+ integer :: iteration_on_subset,it_of_this_subset
- integer :: NSTAGE_TIME_SCHEME,istage
-
+ ! serial i/o mesh reading
#ifdef USE_SERIAL_CASCADE_FOR_IOs
logical :: you_can_start_doing_IOs
#endif
@@ -348,16 +343,11 @@
!
! 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,rmassy_crust_mantle
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_rmassx_crust_mantle,b_rmassy_crust_mantle
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmassz_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: rmassx_crust_mantle,rmassy_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: b_rmassx_crust_mantle,b_rmassy_crust_mantle
-!daniel debug: static
-! real(kind=CUSTOM_REAL), dimension(NGLOB_XY_CM) :: rmassx_crust_mantle
-! real(kind=CUSTOM_REAL), dimension(NGLOB_XY_CM) :: rmassy_crust_mantle
-! real(kind=CUSTOM_REAL), dimension(NGLOB_XY_CM) :: b_rmassx_crust_mantle
-! real(kind=CUSTOM_REAL), dimension(NGLOB_XY_CM) :: b_rmassy_crust_mantle
-! real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmassz_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(:), allocatable,target :: rmassz_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: b_rmassz_crust_mantle
! displacement, velocity, acceleration
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
@@ -375,32 +365,24 @@
real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUATION) :: &
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) :: &
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT),target :: &
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) :: &
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY),target :: &
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(:,:,:,:),allocatable :: &
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),pointer :: &
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(:,:,:,:),allocatable :: &
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),pointer :: &
b_eps_trace_over_3_crust_mantle
-! daniel debug: static
-! 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
@@ -487,6 +469,17 @@
integer :: num_colors_outer_crust_mantle,num_colors_inner_crust_mantle
integer,dimension(:),allocatable :: num_elem_colors_crust_mantle
+ ! LDDRK time scheme
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: displ_crust_mantle_lddrk,veloc_crust_mantle_lddrk
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:,:), allocatable :: &
+ R_xx_crust_mantle_lddrk,R_yy_crust_mantle_lddrk,R_xy_crust_mantle_lddrk, &
+ R_xz_crust_mantle_lddrk,R_yz_crust_mantle_lddrk
+ ! adjoint
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_displ_crust_mantle_lddrk,b_veloc_crust_mantle_lddrk
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:,:), allocatable :: &
+ b_R_xx_crust_mantle_lddrk,b_R_yy_crust_mantle_lddrk,b_R_xy_crust_mantle_lddrk, &
+ b_R_xz_crust_mantle_lddrk,b_R_yz_crust_mantle_lddrk
+
end module specfem_par_crustmantle
!=====================================================================
@@ -524,16 +517,11 @@
integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_inner_core
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmassx_inner_core,rmassy_inner_core
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_rmassx_inner_core,b_rmassy_inner_core
+ real(kind=CUSTOM_REAL), dimension(:), allocatable,target :: rmassz_inner_core
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: b_rmassz_inner_core
-! daniel debug: static
-! real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
-! real(kind=CUSTOM_REAL), dimension(NGLOB_XY_IC) :: rmassx_inner_core
-! real(kind=CUSTOM_REAL), dimension(NGLOB_XY_IC) :: rmassy_inner_core
-! real(kind=CUSTOM_REAL), dimension(NGLOB_XY_IC) :: b_rmassx_inner_core
-! real(kind=CUSTOM_REAL), dimension(NGLOB_XY_IC) :: b_rmassy_inner_core
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: rmassx_inner_core,rmassy_inner_core
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: b_rmassx_inner_core,b_rmassy_inner_core
! displacement, velocity, acceleration
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
@@ -550,32 +538,24 @@
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) :: &
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT),target :: &
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) :: &
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STRAIN_ONLY),target :: &
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(:,:,:,:),allocatable :: &
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),pointer :: &
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(:,:,:,:),allocatable :: &
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),pointer :: &
b_eps_trace_over_3_inner_core
-!daniel debug: static
-! 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
@@ -601,6 +581,17 @@
integer :: num_colors_outer_inner_core,num_colors_inner_inner_core
integer,dimension(:),allocatable :: num_elem_colors_inner_core
+ ! LDDRK time scheme
+ real(kind=CUSTOM_REAL),dimension(:,:), allocatable :: displ_inner_core_lddrk,veloc_inner_core_lddrk
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:,:), allocatable :: &
+ R_xx_inner_core_lddrk,R_yy_inner_core_lddrk,R_xy_inner_core_lddrk, &
+ R_xz_inner_core_lddrk,R_yz_inner_core_lddrk
+ ! adjoint
+ real(kind=CUSTOM_REAL),dimension(:,:), allocatable :: b_displ_inner_core_lddrk,b_veloc_inner_core_lddrk
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:,:), allocatable :: &
+ b_R_xx_inner_core_lddrk,b_R_yy_inner_core_lddrk,b_R_xy_inner_core_lddrk, &
+ b_R_xz_inner_core_lddrk,b_R_yz_inner_core_lddrk
+
end module specfem_par_innercore
!=====================================================================
@@ -628,7 +619,8 @@
rhostore_outer_core,kappavstore_outer_core
! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_outer_core
+ real(kind=CUSTOM_REAL), dimension(:), allocatable,target :: rmass_outer_core
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: b_rmass_outer_core
! velocity potential
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
@@ -638,6 +630,14 @@
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
+ ! 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), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
+ b_A_array_rotation,b_B_array_rotation
+
+
! 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, &
@@ -697,6 +697,13 @@
integer :: num_colors_outer_outer_core,num_colors_inner_outer_core
integer,dimension(:),allocatable :: num_elem_colors_outer_core
+ ! LDDRK time scheme
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: displ_outer_core_lddrk,veloc_outer_core_lddrk
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: A_array_rotation_lddrk,B_array_rotation_lddrk
+ ! adjoint
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_displ_outer_core_lddrk,b_veloc_outer_core_lddrk
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_A_array_rotation_lddrk,b_B_array_rotation_lddrk
+
end module specfem_par_outercore
Added: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/update_displacement_LDDRK.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/update_displacement_LDDRK.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/update_displacement_LDDRK.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -0,0 +1,229 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 6 . 0
+! --------------------------------------------------
+!
+! 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
+! August 2013
+!
+! 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 update_displacement_lddrk()
+
+! low-memory Runge-Kutta time scheme
+
+ use specfem_par
+ use specfem_par_crustmantle
+ use specfem_par_innercore
+ use specfem_par_outercore
+
+ implicit none
+
+ ! mantle
+ accel_crust_mantle(:,:) = 0._CUSTOM_REAL
+ ! outer core
+ accel_outer_core(:) = 0._CUSTOM_REAL
+ ! inner core
+ accel_inner_core(:,:) = 0._CUSTOM_REAL
+
+ end subroutine update_displacement_lddrk
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine update_displacement_lddrk_backward()
+
+! low-memory Runge-Kutta time scheme
+
+ use specfem_par
+ use specfem_par_crustmantle
+ use specfem_par_innercore
+ use specfem_par_outercore
+
+ implicit none
+
+ ! checks
+ if( SIMULATION_TYPE /= 3 ) return
+
+ ! mantle
+ b_accel_crust_mantle(:,:) = 0._CUSTOM_REAL
+ ! outer core
+ b_accel_outer_core(:) = 0._CUSTOM_REAL
+ ! inner core
+ b_accel_inner_core(:,:) = 0._CUSTOM_REAL
+
+ end subroutine update_displacement_lddrk_backward
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+! acoustic domains
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine update_veloc_acoustic_lddrk()
+
+! updates acceleration, velocity and displacement in acoustic region (outer core)
+
+ use specfem_par
+ use specfem_par_outercore
+
+ implicit none
+
+ ! local parameters
+ integer :: i
+
+ do i=1,NGLOB_OUTER_CORE
+ veloc_outer_core_lddrk(i) = ALPHA_LDDRK(istage) * veloc_outer_core_lddrk(i) + deltat * accel_outer_core(i)
+
+ displ_outer_core_lddrk(i) = ALPHA_LDDRK(istage) * displ_outer_core_lddrk(i) + deltat * veloc_outer_core(i)
+
+ veloc_outer_core(i) = veloc_outer_core(i) + BETA_LDDRK(istage) * veloc_outer_core_lddrk(i)
+
+ displ_outer_core(i) = displ_outer_core(i) + BETA_LDDRK(istage) * displ_outer_core_lddrk(i)
+ enddo
+
+ end subroutine update_veloc_acoustic_lddrk
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine update_veloc_acoustic_lddrk_backward()
+
+! updates acceleration, velocity and displacement in acoustic region (outer core)
+
+ use specfem_par
+ use specfem_par_outercore
+
+ implicit none
+
+ ! local parameters
+ integer :: i
+
+ do i=1,NGLOB_OUTER_CORE
+ b_veloc_outer_core_lddrk(i) = ALPHA_LDDRK(istage) * b_veloc_outer_core_lddrk(i) + b_deltat * b_accel_outer_core(i)
+
+ b_displ_outer_core_lddrk(i) = ALPHA_LDDRK(istage) * b_displ_outer_core_lddrk(i) + b_deltat * b_veloc_outer_core(i)
+
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) + BETA_LDDRK(istage) * b_veloc_outer_core_lddrk(i)
+
+ b_displ_outer_core(i) = b_displ_outer_core(i) + BETA_LDDRK(istage) * b_displ_outer_core_lddrk(i)
+ enddo
+
+ end subroutine update_veloc_acoustic_lddrk_backward
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+! elastic domains
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine update_veloc_elastic_lddrk()
+
+! updates acceleration,velocity and displacement in elastic regions (crust/mantle,inner core)
+
+ use specfem_par
+ use specfem_par_crustmantle
+ use specfem_par_innercore
+
+ implicit none
+
+ ! local parameters
+ integer :: i
+
+ ! crust/mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ veloc_crust_mantle_lddrk(:,i) = ALPHA_LDDRK(istage) * veloc_crust_mantle_lddrk(:,i) &
+ + deltat * accel_crust_mantle(:,i)
+
+ displ_crust_mantle_lddrk(:,i) = ALPHA_LDDRK(istage) * displ_crust_mantle_lddrk(:,i) &
+ + deltat * veloc_crust_mantle(:,i)
+
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + BETA_LDDRK(istage) * veloc_crust_mantle_lddrk(:,i)
+
+ displ_crust_mantle(:,i) = displ_crust_mantle(:,i) + BETA_LDDRK(istage) * displ_crust_mantle_lddrk(:,i)
+ enddo
+
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ veloc_inner_core_lddrk(:,i) = ALPHA_LDDRK(istage) * veloc_inner_core_lddrk(:,i) &
+ + deltat * accel_inner_core(:,i)
+
+ displ_inner_core_lddrk(:,i) = ALPHA_LDDRK(istage) * displ_inner_core_lddrk(:,i) &
+ + deltat * veloc_inner_core(:,i)
+
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) + BETA_LDDRK(istage) * veloc_inner_core_lddrk(:,i)
+
+ displ_inner_core(:,i) = displ_inner_core(:,i) + BETA_LDDRK(istage) * displ_inner_core_lddrk(:,i)
+ enddo
+
+ end subroutine update_veloc_elastic_lddrk
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine update_veloc_elastic_lddrk_backward()
+
+! updates acceleration,velocity and displacement in elastic regions (crust/mantle,inner core)
+
+ use specfem_par
+ use specfem_par_crustmantle
+ use specfem_par_innercore
+
+ implicit none
+
+ ! local parameters
+ integer :: i
+
+ ! crust/mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_veloc_crust_mantle_lddrk(:,i) = ALPHA_LDDRK(istage) * b_veloc_crust_mantle_lddrk(:,i) &
+ + b_deltat * b_accel_crust_mantle(:,i)
+
+ b_displ_crust_mantle_lddrk(:,i) = ALPHA_LDDRK(istage) * b_displ_crust_mantle_lddrk(:,i) &
+ + b_deltat * b_veloc_crust_mantle(:,i)
+
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + BETA_LDDRK(istage) * b_veloc_crust_mantle_lddrk(:,i)
+
+ b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) + BETA_LDDRK(istage) * b_displ_crust_mantle_lddrk(:,i)
+ enddo
+
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_veloc_inner_core_lddrk(:,i) = ALPHA_LDDRK(istage) * b_veloc_inner_core_lddrk(:,i) &
+ + b_deltat * b_accel_inner_core(:,i)
+
+ b_displ_inner_core_lddrk(:,i) = ALPHA_LDDRK(istage) * b_displ_inner_core_lddrk(:,i) &
+ + b_deltat * b_veloc_inner_core(:,i)
+
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + BETA_LDDRK(istage) * b_veloc_inner_core_lddrk(:,i)
+
+ b_displ_inner_core(:,i) = b_displ_inner_core(:,i) + BETA_LDDRK(istage) * b_displ_inner_core_lddrk(:,i)
+ enddo
+
+ end subroutine update_veloc_elastic_lddrk_backward
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/update_displacement_Newmark.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/update_displacement_Newmark.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/update_displacement_Newmark.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -25,6 +25,11 @@
!
!=====================================================================
+!-------------------------------------------------------------------------------------------------
+!
+! predictor-step: acoustic & elastic domains
+!
+!-------------------------------------------------------------------------------------------------
subroutine update_displacement_Newmark()
@@ -199,10 +204,64 @@
end subroutine update_displ_acoustic
+!-------------------------------------------------------------------------------------------------
!
+! corrector-step: acoustic domains
+!
!-------------------------------------------------------------------------------------------------
+
+
+ subroutine update_veloc_acoustic_newmark()
+
+! Newmark correction for velocity in fluid outer core
+
+ use specfem_par
+ use specfem_par_outercore
+ implicit none
+
+ ! corrector terms for fluid parts to update velocity
+ if(.NOT. GPU_MODE) then
+ ! on CPU
+ call update_veloc_acoustic(NGLOB_OUTER_CORE,veloc_outer_core,accel_outer_core, &
+ deltatover2,rmass_outer_core)
+ else
+ ! on GPU
+ ! includes FORWARD_OR_ADJOINT == 1
+ call kernel_3_outer_core_cuda(Mesh_pointer,deltatover2,1)
+ endif
+
+ end subroutine update_veloc_acoustic_newmark
+
!
+!-------------------------------------------------------------------------------------------------
+!
+ subroutine update_veloc_acoustic_newmark_backward()
+
+! kernel simulations Newmark correction for velocity in fluid outer core
+
+ use specfem_par
+ use specfem_par_outercore
+ implicit none
+
+ ! corrector terms for fluid parts to update velocity
+ if(.NOT. GPU_MODE) then
+ ! on CPU
+ ! adjoint / kernel runs
+ call update_veloc_acoustic(NGLOB_OUTER_CORE_ADJOINT,b_veloc_outer_core,b_accel_outer_core, &
+ b_deltatover2,b_rmass_outer_core)
+ else
+ ! on GPU
+ ! includes FORWARD_OR_ADJOINT == 3
+ call kernel_3_outer_core_cuda(Mesh_pointer,b_deltatover2,3)
+ endif
+
+ end subroutine update_veloc_acoustic_newmark_backward
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
subroutine update_veloc_acoustic(NGLOB,veloc_outer_core,accel_outer_core, &
deltatover2,rmass_outer_core)
@@ -226,80 +285,73 @@
integer :: i
! Newmark time scheme
- ! multiply by the inverse of the mass matrix and update velocity
+ ! update velocity
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)
+ veloc_outer_core(i) = veloc_outer_core(i) + deltatover2 * accel_outer_core(i)
enddo
end subroutine update_veloc_acoustic
+
+!-------------------------------------------------------------------------------------------------
!
+! corrector-step: elastic domains
+!
!-------------------------------------------------------------------------------------------------
-!
- subroutine update_accel_elastic(NGLOB,NGLOB_XY,veloc_crust_mantle,accel_crust_mantle, &
- two_omega_earth, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle)
-! updates acceleration in crust/mantle region
+ subroutine update_veloc_elastic_newmark()
- use constants_solver,only: CUSTOM_REAL,NDIM,NCHUNKS_VAL
-
- use specfem_par,only: ABSORBING_CONDITIONS
-
+ use specfem_par
+ use specfem_par_crustmantle
+ use specfem_par_innercore
implicit none
- integer :: NGLOB,NGLOB_XY
+ ! corrector terms for elastic parts updates velocity
+ if(.NOT. GPU_MODE ) then
+ ! on CPU
+ call update_veloc_elastic(NGLOB_CRUST_MANTLE,veloc_crust_mantle,accel_crust_mantle, &
+ NGLOB_INNER_CORE,veloc_inner_core,accel_inner_core, &
+ deltatover2)
+ else
+ ! on GPU
+ ! includes FORWARD_OR_ADJOINT == 1
+ call update_veloc_3_b_cuda(Mesh_pointer,deltatover2,1)
- ! velocity & acceleration
- ! crust/mantle region
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: veloc_crust_mantle,accel_crust_mantle
+ 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
- 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
+ end subroutine update_veloc_elastic_newmark
- real(kind=CUSTOM_REAL) :: two_omega_earth
+!
+!-------------------------------------------------------------------------------------------------
+!
- ! local parameters
- integer :: i
+ subroutine update_veloc_elastic_newmark_backward()
- ! updates acceleration w/ rotation in crust/mantle region only
+ use specfem_par
+ use specfem_par_crustmantle
+ use specfem_par_innercore
+ implicit none
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ ! corrector terms for elastic parts updates velocity
- 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
-
+ if(.NOT. GPU_MODE ) then
+ ! on CPU
+ ! adjoint / kernel runs
+ ! uses corrected mass matrices for update
+ call update_veloc_elastic(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)
else
+ ! on GPU
+ ! includes FORWARD_OR_ADJOINT == 3
+ call update_veloc_3_b_cuda(Mesh_pointer,b_deltatover2,3)
- 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
- end subroutine update_accel_elastic
+ end subroutine update_veloc_elastic_newmark_backward
!
!-------------------------------------------------------------------------------------------------
@@ -307,7 +359,7 @@
subroutine update_veloc_elastic(NGLOB_CM,veloc_crust_mantle,accel_crust_mantle, &
NGLOB_IC,veloc_inner_core,accel_inner_core, &
- deltatover2,two_omega_earth,rmass_inner_core)
+ deltatover2)
! updates velocity in crust/mantle region, and acceleration and velocity in inner core
@@ -323,11 +375,8 @@
! 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
- real(kind=CUSTOM_REAL) :: deltatover2,two_omega_earth
-
! local parameters
integer :: i
@@ -340,39 +389,35 @@
! - inner core region
! needs both, acceleration update & velocity corrector terms
- ! mantle
+ ! crust/mantle
if(FORCE_VECTORIZATION_VAL) then
+
do i=1,NGLOB_CM * NDIM
veloc_crust_mantle(i,i) = veloc_crust_mantle(i,i) + deltatover2*accel_crust_mantle(i,i)
enddo
+
else
+
do i=1,NGLOB_CM
veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
enddo
+
endif
! inner core
if(FORCE_VECTORIZATION_VAL) then
- 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)
- enddo
+
do i=1,NGLOB_IC * NDIM
veloc_inner_core(i,1) = veloc_inner_core(i,1) + deltatover2*accel_inner_core(i,1)
enddo
+
else
+
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 update_veloc_elastic
+
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-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_movie_volume.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -100,14 +100,14 @@
!
subroutine movie_volume_integrate_strain(deltat,vnspec, &
- eps_trace_over_3, &
- epsilondev_xx,epsilondev_yy, &
- epsilondev_xy,epsilondev_xz, &
- epsilondev_yz, &
- Ieps_trace_over_3, &
- Iepsilondev_xx,Iepsilondev_yy, &
- Iepsilondev_xy,Iepsilondev_xz, &
- Iepsilondev_yz)
+ eps_trace_over_3, &
+ epsilondev_xx,epsilondev_yy, &
+ epsilondev_xy,epsilondev_xz, &
+ epsilondev_yz, &
+ Ieps_trace_over_3, &
+ Iepsilondev_xx,Iepsilondev_yy, &
+ Iepsilondev_xy,Iepsilondev_xz, &
+ Iepsilondev_yz)
use constants_solver
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_seismograms.f90 2013-09-04 00:03:07 UTC (rev 22768)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_seismograms.f90 2013-09-04 13:17:07 UTC (rev 22769)
@@ -91,11 +91,22 @@
endif ! nrec_local
+
! write the current or final seismograms
if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+
+ ! writes out seismogram files
if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+
+ ! stores seismograms in right order
+ if( UNDO_ATTENUATION .and. SIMULATION_TYPE == 3) then
+ call compute_seismograms_undoatt(seismo_current,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms)
+ endif
+
! writes out seismogram files
- call write_seismograms_to_file()
+ if( .not. undo_att_sim_type_3 ) then
+ call write_seismograms_to_file()
+ endif
! user output
if(myrank==0) then
@@ -104,15 +115,19 @@
write(IMAIN,*)
call flush_IMAIN()
endif
- else
+ else if( SIMULATION_TYPE == 2 ) then
if( nrec_local > 0 ) &
- call write_adj_seismograms(seismograms,number_receiver_global, &
- nrec_local,it,nit_written,DT, &
- NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,t0,LOCAL_TMP_PATH)
+ call write_adj_seismograms(nit_written)
nit_written = it
endif
- seismo_offset = seismo_offset + seismo_current
+
+ ! resets current seismogram position
+ if( .not. undo_att_sim_type_3 ) then
+ seismo_offset = seismo_offset + seismo_current
+ endif
+
seismo_current = 0
+
endif
end subroutine write_seismograms
@@ -508,20 +523,19 @@
! write adjoint seismograms to text files
- subroutine write_adj_seismograms(seismograms,number_receiver_global, &
- nrec_local,it,nit_written,DT,NSTEP, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,hdur,LOCAL_TMP_PATH)
+ subroutine write_adj_seismograms(nit_written)
use constants
+ use specfem_par,only: NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ DT,t0,LOCAL_TMP_PATH, &
+ seismograms,number_receiver_global,nrec_local, &
+ it
implicit none
- integer :: nrec_local,NSTEP,NTSTEP_BETWEEN_OUTPUT_SEISMOS,it,nit_written
- integer, dimension(nrec_local) :: number_receiver_global
- real(kind=CUSTOM_REAL), dimension(9,nrec_local,NSTEP) :: seismograms
- double precision :: hdur,DT
- character(len=150) :: LOCAL_TMP_PATH
+ integer :: nit_written
+ ! local parameters
integer :: irec,irec_local
integer :: iorientation,isample
@@ -589,9 +603,9 @@
do isample = nit_written+1,min(it,NSTEP)
! distinguish between single and double precision for reals
if(CUSTOM_REAL == SIZE_REAL) then
- write(IOUT,*) sngl(dble(isample-1)*DT - hdur),' ',seismograms(iorientation,irec_local,isample-nit_written)
+ write(IOUT,*) sngl(dble(isample-1)*DT - t0),' ',seismograms(iorientation,irec_local,isample-nit_written)
else
- write(IOUT,*) dble(isample-1)*DT - hdur,' ',seismograms(iorientation,irec_local,isample-nit_written)
+ write(IOUT,*) dble(isample-1)*DT - t0,' ',seismograms(iorientation,irec_local,isample-nit_written)
endif
enddo
More information about the CIG-COMMITS
mailing list