[cig-commits] r22443 - in seismo/3D/SPECFEM3D_GLOBE/trunk: . DATA src src/auxiliaries src/compute_optimized_dumping_undo_att src/create_header_file src/meshfem3D src/shared src/specfem3D
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Fri Jun 28 10:42:14 PDT 2013
Author: dkomati1
Date: 2013-06-28 10:42:14 -0700 (Fri, 28 Jun 2013)
New Revision: 22443
Added:
seismo/3D/SPECFEM3D_GLOBE/trunk/part1_classical.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/part1_undo_att.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/part2_classical.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/part2_undo_att.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/part3_kernel_computation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/Makefile
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/rules.mk
Removed:
seismo/3D/SPECFEM3D_GLOBE/trunk/yyyy_will_need_to_add_UNDO_ATT_NT_DUMP_to_all_EXAMPLE_Par_files
Modified:
seismo/3D/SPECFEM3D_GLOBE/trunk/DATA/Par_file
seismo/3D/SPECFEM3D_GLOBE/trunk/Makefile.in
seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_1D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_2D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_corners_chunks.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_faces_chunks.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/combine_AVS_DX.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/create_movie_AVS_DX.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/create_movie_GMT_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_header_file/create_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/broadcast_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/get_model_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/memory_eval.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/read_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/read_parameter_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/save_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/check_simulation_stability.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_coupling.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_element.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_noDev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_noDev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_seismograms.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_stacey_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_stacey_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/initialize_simulation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_volume.f90
Log:
done merging undoing of attenuation into the trunk; three new parameters have been added to the Par_file for that
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/DATA/Par_file 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/DATA/Par_file 2013-06-28 17:42:14 UTC (rev 22443)
@@ -54,6 +54,13 @@
# record length in minutes
RECORD_LENGTH_IN_MINUTES = 15.0d0
+# to undo attenuation for sensitivity kernel calculations or forward runs with SAVE_FORWARD
+# use one (and only one) of the two flags below. UNDO_ATTENUATION is much better (it is exact)
+# but requires a significant amount of disk space for temporary storage.
+PARTIAL_PHYS_DISPERSION_ONLY = .false.
+UNDO_ATTENUATION = .true.
+NT_DUMP_ATTENUATION = 100 # how often we dump restart files to undo attenuation, only needed when using UNDO_ATTENUATION
+
# save AVS or OpenDX movies
#MOVIE_COARSE saves movie only at corners of elements (SURFACE OR VOLUME)
#MOVIE_COARSE does not work with create_movie_AVS_DX
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/Makefile.in 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/Makefile.in 2013-06-28 17:42:14 UTC (rev 22443)
@@ -67,6 +67,7 @@
SUBDIRS = \
shared \
create_header_file \
+ compute_optimized_dumping_undo_att \
meshfem3D \
specfem3D \
auxiliaries
@@ -74,6 +75,7 @@
# default targets
DEFAULT = \
xcreate_header_file \
+ xcompute_optimized_dumping_undo_att \
xmeshfem3D \
xspecfem3D \
xcheck_buffers_1D \
@@ -88,11 +90,14 @@
all: default
-default: $(DEFAULT)
+default: change_date_of_calling_code $(DEFAULT)
backup:
cp -rp src setup DATA/Par_file* Makefile go_mesher* go_solver* mymachines bak
+change_date_of_calling_code:
+ touch src/specfem3D/specfem3D.F90
+
ifdef CLEAN
clean:
-rm -f $(foreach dir, $(CLEAN), $($(dir)_OBJECTS) $($(dir)_MODULES) $($(dir)_SHARED_OBJECTS) $($(dir)_TARGETS))
@@ -108,6 +113,7 @@
@echo " xmeshfem3D"
@echo " xspecfem3D"
@echo " xcreate_header_file"
+ @echo " xcompute_optimized_dumping_undo_att"
@echo " xcheck_buffers_1D"
@echo " xcheck_buffers_2D"
@echo " xcheck_buffers_corners_chunks"
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/part1_classical.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/part1_classical.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/part1_classical.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -0,0 +1,973 @@
+
+!! DK DK
+!! DK DK this first part handles the cases SIMULATION_TYPE == 1 and SIMULATION_TYPE == 2
+!! DK DK it also handles the cases NOISE_TOMOGRAPHY == 1 and NOISE_TOMOGRAPHY == 2
+!! DK DK
+
+ ! Newmark time scheme update
+
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
+ + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
+ + deltatover2*accel_crust_mantle(:,i)
+ accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ ! outer core
+ do i=1,NGLOB_OUTER_CORE
+ displ_outer_core(i) = displ_outer_core(i) &
+ + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
+ veloc_outer_core(i) = veloc_outer_core(i) &
+ + deltatover2*accel_outer_core(i)
+ accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ displ_inner_core(:,i) = displ_inner_core(:,i) &
+ + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) &
+ + deltatover2*accel_inner_core(:,i)
+ accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+
+ ! integral of strain for adjoint movie volume
+ if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) ) then
+! do *NOT* use array syntax for that loop, otherwise you will get a compiler error when MOVIE_VOLUME is off
+! because the shape of the arrays will not match (due to some arrays purposely declared with a dummy size of 1)
+ do ispec = 1,NSPEC_CRUST_MANTLE
+ call compute_element_strain_undo_att_noDev(ispec,nglob_crust_mantle,nspec_crust_mantle,&
+ displ_crust_mantle,hprime_xx,hprime_yy,hprime_zz,ibool_crust_mantle,&
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,&
+ epsilondev_loc_crust_mantle,eps_trace_over_3_loc_crust_mantle)
+ Iepsilondev_crust_mantle(:,:,:,:,ispec) = Iepsilondev_crust_mantle(:,:,:,:,ispec) &
+ + deltat*epsilondev_loc_crust_mantle(:,:,:,:)
+ Ieps_trace_over_3_crust_mantle(:,:,:,ispec) = Ieps_trace_over_3_crust_mantle(:,:,:,ispec) &
+ + deltat*eps_trace_over_3_loc_crust_mantle(:,:,:)
+ enddo
+ endif
+
+ ! compute the maximum of the norm of the displacement
+ ! in all the slices using an MPI reduction
+ ! and output timestamp file to check that simulation is running fine
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
+ call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
+ 1,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the fluid
+ ! ****************************************************
+
+ ! compute internal forces in the fluid region
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
+ else
+ time = (dble(it-1)*DT-t0)*scale_t_inv
+ endif
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
+ it,ibool_outer_core, &
+ veloc_outer_core,accel_outer_core, &
+ vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+ jacobian2D_bottom_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+ endif ! Stacey conditions
+
+
+ ! ****************************************************
+ ! ********** add matching with solid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the fluid
+
+ !---
+ !--- couple with mantle at the top of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ call compute_coupling_fluid_CMB(displ_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ NSPEC2D_TOP(IREGION_OUTER_CORE))
+ endif
+
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ call compute_coupling_fluid_ICB(displ_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ 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))
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+ ! outer core
+ iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
+ enddo
+
+ ! multiply by the inverse of the mass matrix and update velocity
+ do i=1,NGLOB_OUTER_CORE
+ accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
+ veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
+ enddo
+
+! ------------------- new non blocking implementation -------------------
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the solid
+ ! ****************************************************
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ iphase_CC = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,deltat,veloc_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,deltat,veloc_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,one_minus_sum_beta_inner_core,deltat,veloc_inner_core,&
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,one_minus_sum_beta_inner_core,deltat,veloc_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ call compute_stacey_crust_mantle_forward(ichunk, &
+ it,SAVE_FORWARD,ibool_crust_mantle, &
+ veloc_crust_mantle,accel_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+ wgllwgll_xz,wgllwgll_yz, &
+ 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, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+
+ endif ! Stacey conditions
+
+ ! add the sources
+ if (SIMULATION_TYPE == 1) &
+ call compute_add_sources(myrank,NSOURCES, &
+ accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ ! add adjoint sources only if adjoint simulation is performed for source inversion only
+!! DK DK UNDO_ATTENUATION this must remain here even when SIMULATION_TYPE == 3 because it applies to array
+!! DK DK UNDO_ATTENUATION accel_crust_mantle rather than b_accel_crust_mantle
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+ if( nadj_rec_local > 0 ) &
+ call compute_add_sources_adjoint(myrank,nrec, &
+ nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
+ accel_crust_mantle,adj_sourcearrays, &
+ nu,xi_receiver,eta_receiver,gamma_receiver, &
+ xigll,yigll,zigll,ibool_crust_mantle, &
+ islice_selected_rec,ispec_selected_rec, &
+ NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
+ it,it_begin,station_name,network_name,DT)
+ endif
+
+! ! add adjoint sources and add sources for backward/reconstructed wavefield
+! if (SIMULATION_TYPE == 3) &
+! call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+! b_accel_crust_mantle,sourcearrays, &
+! DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+! islice_selected_source,ispec_selected_source,it, &
+! hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ ! NOISE_TOMOGRAPHY
+ if ( NOISE_TOMOGRAPHY == 1 ) then
+ ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
+ ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
+ ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
+ ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
+ call add_source_master_rec_noise(myrank,nrec, &
+ NSTEP,accel_crust_mantle,noise_sourcearray, &
+ ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
+ it,irec_master_noise)
+ else if ( NOISE_TOMOGRAPHY == 2 ) then
+ ! second step of noise tomography, i.e., read the surface movie saved at every timestep
+ ! use the movie to drive the ensemble forward wavefield
+ call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
+ ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
+ ! note the ensemble forward sources are generally distributed on the surface of the earth
+ ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
+ ! therefore, we must add it here, before applying the inverse of mass matrix
+ endif
+
+ ! ****************************************************
+ ! ********** add matching with fluid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the solid
+
+ !---
+ !--- couple with outer core at the bottom of the mantle
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ call compute_coupling_CMB_fluid(displ_crust_mantle, &
+ accel_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ RHO_TOP_OC,minus_g_cmb, &
+ NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+ endif
+
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ call compute_coupling_ICB_fluid(displ_inner_core, &
+ accel_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ 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))
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+ iphase = 1 ! initialize the non blocking communication counter
+ iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,deltat,veloc_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,deltat,veloc_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,one_minus_sum_beta_inner_core,deltat,veloc_inner_core,&
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,one_minus_sum_beta_inner_core,deltat,veloc_inner_core,&
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+ enddo
+
+ !---
+ !--- use buffers to assemble forces with the central cube
+ !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),accel_inner_core,NDIM,iphase_CC)
+ enddo
+ endif ! end of assembling forces with the central cube
+
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ do i=1,NGLOB_CRUST_MANTLE
+ 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
+
+ else
+
+ do i=1,NGLOB_CRUST_MANTLE
+ 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
+
+! ------------------- new non blocking implementation -------------------
+
+ ! couples ocean with crust mantle
+ if(OCEANS_VAL) then
+ call compute_coupling_ocean(accel_crust_mantle, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+ rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load,NGLOB_XY, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ ABSORBING_CONDITIONS)
+ endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! Newmark time scheme - corrector for elastic parts
+
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
+ + two_omega_earth*veloc_inner_core(2,i)
+ accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
+ - two_omega_earth*veloc_inner_core(1,i)
+ accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
+
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
+ enddo
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+ if (SIMULATION_TYPE == 1) then
+ call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ else if (SIMULATION_TYPE == 2) then
+ call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
+ nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ hxir_store,hetar_store,hgammar_store, &
+ hpxir_store,hpetar_store,hpgammar_store, &
+ tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
+ 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, &
+ moment_der,sloc_der,stshift_der,shdur_der, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
+ ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
+ NSTEP,it,nit_written)
+
+ endif
+ endif ! nrec_local
+
+ ! write the current or final seismograms
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ else ! case of SIMULATION_TYPE == 2
+ 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_PATH)
+ nit_written = it
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! 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(displ_crust_mantle, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie,it)
+ endif
+
+ ! save movie on surface
+ if( MOVIE_SURFACE ) then
+ if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ ! save velocity here to avoid static offset on displacement for movies
+ call write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
+ scale_displ,displ_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_x_all,store_val_y_all,store_val_z_all, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ store_val_ux_all,store_val_uy_all,store_val_uz_all, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ NIT,it,OUTPUT_FILES,MOVIE_VOLUME_TYPE)
+ endif
+ endif
+
+
+ ! save movie in full 3D mesh
+ if(MOVIE_VOLUME ) then
+ if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
+ .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
+
+ if (MOVIE_VOLUME_TYPE == 1) then ! output strains
+ call write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie,&
+ NSPEC_CRUST_MANTLE,hprime_xx,hprime_yy,hprime_zz,ibool_crust_mantle,&
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle)
+
+ else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
+ ! output the Time Integral of Strain, or \mu*TIS
+ call write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,Ieps_trace_over_3_crust_mantle,Iepsilondev_crust_mantle, &
+ muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 4) then ! output divergence and curl in whole volume
+!!!!! for undo_att this type of MOVIE is not supported
+!!! call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
+!!! div_displ_outer_core, &
+!!! accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
+!!! eps_trace_over_3_inner_core, &
+!!! epsilondev_crust_mantle,epsilondev_inner_core, &
+!!! LOCAL_PATH, &
+!!! displ_crust_mantle,displ_inner_core,displ_outer_core, &
+!!! veloc_crust_mantle,veloc_inner_core,veloc_outer_core, &
+!!! accel_crust_mantle,accel_inner_core, &
+!!! ibool_crust_mantle,ibool_inner_core)
+
+ else if (MOVIE_VOLUME_TYPE == 5) then ! output displacement
+ scalingval = scale_displ
+ call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,displ_crust_mantle, &
+ scalingval,mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 6) then ! output velocity
+ scalingval = scale_veloc
+ call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,veloc_crust_mantle, &
+ scalingval,mask_3dmovie,nu_3dmovie)
+
+ else
+
+ call exit_MPI(myrank, 'MOVIE_VOLUME_TYPE has to be 1,2,3,4,5 or 6')
+
+ endif ! MOVIE_VOLUME_TYPE
+ endif
+ endif ! MOVIE_VOLUME
+
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/part1_undo_att.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/part1_undo_att.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/part1_undo_att.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -0,0 +1,989 @@
+
+!! DK DK
+!! DK DK this first part handles the cases SIMULATION_TYPE == 1 and SIMULATION_TYPE == 2
+!! DK DK it also handles the cases NOISE_TOMOGRAPHY == 1 and NOISE_TOMOGRAPHY == 2
+!! DK DK
+
+ ! Newmark time scheme update
+
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
+ + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
+ + deltatover2*accel_crust_mantle(:,i)
+ accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ ! outer core
+ do i=1,NGLOB_OUTER_CORE
+ displ_outer_core(i) = displ_outer_core(i) &
+ + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
+ veloc_outer_core(i) = veloc_outer_core(i) &
+ + deltatover2*accel_outer_core(i)
+ accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ displ_inner_core(:,i) = displ_inner_core(:,i) &
+ + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) &
+ + deltatover2*accel_inner_core(:,i)
+ accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+
+ ! integral of strain for adjoint movie volume
+ if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) ) then
+! do *NOT* use array syntax for that loop, otherwise you will get a compiler error when MOVIE_VOLUME is off
+! because the shape of the arrays will not match (due to some arrays purposely declared with a dummy size of 1)
+ do ispec = 1,NSPEC_CRUST_MANTLE
+ call compute_element_strain_undo_att_noDev(ispec,nglob_crust_mantle,nspec_crust_mantle,&
+ displ_crust_mantle,hprime_xx,hprime_yy,hprime_zz,ibool_crust_mantle,&
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,&
+ epsilondev_loc_crust_mantle,eps_trace_over_3_loc_crust_mantle)
+ Iepsilondev_crust_mantle(:,:,:,:,ispec) = Iepsilondev_crust_mantle(:,:,:,:,ispec) &
+ + deltat*epsilondev_loc_crust_mantle(:,:,:,:)
+ Ieps_trace_over_3_crust_mantle(:,:,:,ispec) = Ieps_trace_over_3_crust_mantle(:,:,:,ispec) &
+ + deltat*eps_trace_over_3_loc_crust_mantle(:,:,:)
+ enddo
+ endif
+
+ ! compute the maximum of the norm of the displacement
+ ! in all the slices using an MPI reduction
+ ! and output timestamp file to check that simulation is running fine
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
+ call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
+ 1,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the fluid
+ ! ****************************************************
+
+ ! compute internal forces in the fluid region
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
+ else
+ time = (dble(it-1)*DT-t0)*scale_t_inv
+ endif
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
+ it,ibool_outer_core, &
+ veloc_outer_core,accel_outer_core, &
+ vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+ jacobian2D_bottom_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+ endif ! Stacey conditions
+
+
+ ! ****************************************************
+ ! ********** add matching with solid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the fluid
+
+ !---
+ !--- couple with mantle at the top of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ call compute_coupling_fluid_CMB(displ_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ NSPEC2D_TOP(IREGION_OUTER_CORE))
+ endif
+
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ call compute_coupling_fluid_ICB(displ_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ 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))
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+ ! outer core
+ iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,deltat,two_omega_earth, &
+ A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
+ enddo
+
+ ! multiply by the inverse of the mass matrix and update velocity
+ do i=1,NGLOB_OUTER_CORE
+ accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
+ veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
+ enddo
+
+! ------------------- new non blocking implementation -------------------
+ ! ****************************************************
+ ! big loop over all spectral elements in the solid
+ ! ****************************************************
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ iphase = 0 ! do not start any non blocking communications at this stage
+ iphase_CC = 0 ! do not start any non blocking communications at this stage
+ icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,deltat,veloc_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,deltat,veloc_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,one_minus_sum_beta_inner_core,deltat,veloc_inner_core,&
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,one_minus_sum_beta_inner_core,deltat,veloc_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ call compute_stacey_crust_mantle_forward(ichunk, &
+ it,SAVE_FORWARD,ibool_crust_mantle, &
+ veloc_crust_mantle,accel_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+ wgllwgll_xz,wgllwgll_yz, &
+ 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, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+
+ endif ! Stacey conditions
+
+ ! add the sources
+ if (SIMULATION_TYPE == 1) &
+ call compute_add_sources(myrank,NSOURCES, &
+ accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+
+ ! add adjoint sources only if adjoint simulation is performed for source inversion only
+!! DK DK UNDO_ATTENUATION this must remain here even when SIMULATION_TYPE == 3 because it applies to array
+!! DK DK UNDO_ATTENUATION accel_crust_mantle rather than b_accel_crust_mantle
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+ if( nadj_rec_local > 0 ) &
+ call compute_add_sources_adjoint(myrank,nrec, &
+ nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
+ accel_crust_mantle,adj_sourcearrays, &
+ nu,xi_receiver,eta_receiver,gamma_receiver, &
+ xigll,yigll,zigll,ibool_crust_mantle, &
+ islice_selected_rec,ispec_selected_rec, &
+ NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
+ it,it_begin,station_name,network_name,DT)
+ endif
+
+
+ ! NOISE_TOMOGRAPHY
+ if ( NOISE_TOMOGRAPHY == 1 ) then
+ ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
+ ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
+ ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
+ ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
+ call add_source_master_rec_noise(myrank,nrec, &
+ NSTEP,accel_crust_mantle,noise_sourcearray, &
+ ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
+ it,irec_master_noise)
+ else if ( NOISE_TOMOGRAPHY == 2 ) then
+ ! second step of noise tomography, i.e., read the surface movie saved at every timestep
+ ! use the movie to drive the ensemble forward wavefield
+ call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ endif
+
+ ! ****************************************************
+ ! ********** add matching with fluid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the solid
+
+ !---
+ !--- couple with outer core at the bottom of the mantle
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ call compute_coupling_CMB_fluid(displ_crust_mantle, &
+ accel_crust_mantle, &
+ ibool_crust_mantle,ibelm_bottom_crust_mantle, &
+ accel_outer_core, &
+ normal_top_outer_core,jacobian2D_top_outer_core, &
+ wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
+ RHO_TOP_OC,minus_g_cmb, &
+ NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
+ endif
+
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ call compute_coupling_ICB_fluid(displ_inner_core, &
+ accel_inner_core, &
+ ibool_inner_core,ibelm_top_inner_core, &
+ 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))
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+ iphase = 1 ! initialize the non blocking communication counter
+ iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+
+ icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,deltat,veloc_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,icall, &
+ accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,deltat,veloc_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,one_minus_sum_beta_inner_core,deltat,veloc_inner_core,&
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ displ_inner_core,accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,icall, &
+ accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ R_memory_inner_core,one_minus_sum_beta_inner_core,deltat,veloc_inner_core,&
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
+ buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
+ enddo
+
+ !---
+ !--- use buffers to assemble forces with the central cube
+ !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),accel_inner_core,NDIM,iphase_CC)
+ enddo
+ endif ! end of assembling forces with the central cube
+
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ do i=1,NGLOB_CRUST_MANTLE
+ 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
+
+ else
+
+ do i=1,NGLOB_CRUST_MANTLE
+ 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
+
+! ------------------- new non blocking implementation -------------------
+ ! couples ocean with crust mantle
+ if(OCEANS_VAL) then
+ call compute_coupling_ocean(accel_crust_mantle, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+ rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load,NGLOB_XY, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ ABSORBING_CONDITIONS)
+ endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! Newmark time scheme - corrector for elastic parts
+
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
+ + two_omega_earth*veloc_inner_core(2,i)
+ accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
+ - two_omega_earth*veloc_inner_core(1,i)
+ accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
+
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
+ enddo
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+ if (SIMULATION_TYPE == 1) then
+ call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ else if (SIMULATION_TYPE == 2) then
+ call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
+ nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ hxir_store,hetar_store,hgammar_store, &
+ hpxir_store,hpetar_store,hpgammar_store, &
+ tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
+ 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, &
+ moment_der,sloc_der,stshift_der,shdur_der, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
+ ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
+ NSTEP,it,nit_written)
+ endif
+ endif ! nrec_local
+
+ ! write the current or final seismograms
+if(undo_att_sim_type_3)then
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ elseif(SIMULATION_TYPE == 2)then ! case of SIMULATION_TYPE == 2
+ 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_PATH)
+ nit_written = it
+ endif
+!!! seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+else
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ else ! case of SIMULATION_TYPE == 2
+ 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_PATH)
+ nit_written = it
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! 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(displ_crust_mantle, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie,it)
+ endif
+
+ ! save movie on surface
+ if( MOVIE_SURFACE ) then
+ if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ ! save velocity here to avoid static offset on displacement for movies
+ call write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
+ scale_displ,displ_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_x_all,store_val_y_all,store_val_z_all, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ store_val_ux_all,store_val_uy_all,store_val_uz_all, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ NIT,it,OUTPUT_FILES,MOVIE_VOLUME_TYPE)
+ endif
+ endif
+
+
+ ! save movie in full 3D mesh
+ if(MOVIE_VOLUME ) then
+ if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
+ .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
+
+ if (MOVIE_VOLUME_TYPE == 1) then ! output strains
+ call write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie,&
+ hprime_xx,hprime_yy,hprime_zz,ibool_crust_mantle,&
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle)
+
+ else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
+ ! output the Time Integral of Strain, or \mu*TIS
+ call write_movie_volume_strains(myrank,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
+ it,Ieps_trace_over_3_crust_mantle,Iepsilondev_crust_mantle, &
+ muvstore_crust_mantle_3dmovie, &
+ mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 4) then ! output divergence and curl in whole volume
+!!!!!! for undo_att this type of MOVIE is not supported
+!!! call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
+!!! div_displ_outer_core, &
+!!! accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
+!!! eps_trace_over_3_inner_core, &
+!!! epsilondev_crust_mantle,epsilondev_inner_core, &
+!!! LOCAL_PATH, &
+!!! displ_crust_mantle,displ_inner_core,displ_outer_core, &
+!!! veloc_crust_mantle,veloc_inner_core,veloc_outer_core, &
+!!! accel_crust_mantle,accel_inner_core, &
+!!! ibool_crust_mantle,ibool_inner_core)
+
+ else if (MOVIE_VOLUME_TYPE == 5) then ! output displacement
+ scalingval = scale_displ
+ call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,displ_crust_mantle, &
+ scalingval,mask_3dmovie,nu_3dmovie)
+
+ else if (MOVIE_VOLUME_TYPE == 6) then ! output velocity
+ scalingval = scale_veloc
+ call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
+ LOCAL_PATH,MOVIE_VOLUME_TYPE, &
+ MOVIE_COARSE,ibool_crust_mantle,veloc_crust_mantle, &
+ scalingval,mask_3dmovie,nu_3dmovie)
+
+ else
+
+ call exit_MPI(myrank, 'MOVIE_VOLUME_TYPE has to be 1,2,3,4,5 or 6')
+
+ endif ! MOVIE_VOLUME_TYPE
+ endif
+ endif ! MOVIE_VOLUME
+
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/part2_classical.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/part2_classical.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/part2_classical.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -0,0 +1,874 @@
+
+!! DK DK
+!! DK DK this first part handles the case SIMULATION_TYPE == 3
+!! DK DK it also handles the case NOISE_TOMOGRAPHY == 3
+!! DK DK
+
+ ! Newmark time scheme update
+
+ ! backward field
+ if (SIMULATION_TYPE == 3) then
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+ + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
+ + b_deltatover2*b_accel_crust_mantle(:,i)
+ b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ ! outer core
+ do i=1,NGLOB_OUTER_CORE
+ b_displ_outer_core(i) = b_displ_outer_core(i) &
+ + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+ + b_deltatover2*b_accel_outer_core(i)
+ b_accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
+ + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
+ + b_deltatover2*b_accel_inner_core(:,i)
+ b_accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+ endif ! SIMULATION_TYPE == 3
+
+ ! compute the maximum of the norm of the displacement
+ ! in all the slices using an MPI reduction
+ ! and output timestamp file to check that simulation is running fine
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
+ if (SIMULATION_TYPE == 3) then
+ call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
+ SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+ endif
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the fluid
+ ! ****************************************************
+
+ ! compute internal forces in the fluid region
+
+ if (SIMULATION_TYPE == 3) then
+ ! note on backward/reconstructed wavefields:
+ ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
+ ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
+ ! to a time (NSTEP - (it-1) - 1)*DT - t0
+ ! for reconstructing the rotational contributions
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
+
+ else
+ time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
+
+ endif
+
+ b_iphase = 0 ! do not start any non blocking communications at this stage
+ b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+ endif
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ if (SIMULATION_TYPE == 3) then
+ call compute_stacey_outer_core_backward(ichunk, &
+ NSTEP,it,ibool_outer_core, &
+ b_accel_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+ endif
+ endif ! Stacey conditions
+
+
+ ! ****************************************************
+ ! ********** add matching with solid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the fluid
+
+ !---
+ !--- couple with mantle at the top of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ if (SIMULATION_TYPE == 3) then
+ 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))
+ endif
+ endif
+
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ if (SIMULATION_TYPE == 3) then
+ 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))
+ endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! ------------------- new non blocking implementation -------------------
+
+ if (SIMULATION_TYPE == 3) then
+
+ ! outer core
+ b_iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+
+ b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+ enddo
+
+! ------------------- new non blocking implementation -------------------
+
+ ! Newmark time scheme - corrector for fluid parts
+ do i=1,NGLOB_OUTER_CORE
+ b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
+ enddo
+
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the solid
+ ! ****************************************************
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if (SIMULATION_TYPE == 3 ) then
+
+ b_iphase = 0 ! do not start any non blocking communications at this stage
+ b_iphase_CC = 0 ! do not start any non blocking communications at this stage
+ b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,b_deltat,b_veloc_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,b_deltat,b_displ_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+ endif
+
+ if (SIMULATION_TYPE == 3) then
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,one_minus_sum_beta_inner_core,b_deltat,b_veloc_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,one_minus_sum_beta_inner_core,b_deltat,b_veloc_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+ endif
+
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ if(SIMULATION_TYPE == 3) then
+
+ call compute_stacey_crust_mantle_backward(ichunk, &
+ NSTEP,it,ibool_crust_mantle, &
+ b_accel_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, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+ endif
+ endif ! Stacey conditions
+
+ ! add adjoint sources and add sources for backward/reconstructed wavefield
+ if (SIMULATION_TYPE == 3) then
+ call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+ b_accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source,it, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+ endif
+
+ if ( NOISE_TOMOGRAPHY == 3 ) then
+ ! 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(nmovie_points,b_accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ it,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ endif
+
+ ! ****************************************************
+ ! ********** add matching with fluid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the solid
+
+ !---
+ !--- couple with outer core at the bottom of the mantle
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ if(SIMULATION_TYPE == 3) then
+ 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))
+ endif
+ endif
+
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ if(SIMULATION_TYPE == 3) then
+ 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))
+ endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+! ------------------- new non blocking implementation -------------------
+
+ if (SIMULATION_TYPE == 3) then
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+ b_iphase = 1 ! initialize the non blocking communication counter
+ b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+
+ b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,b_deltat,b_veloc_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,b_deltat,b_displ_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,one_minus_sum_beta_inner_core,b_deltat,b_veloc_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,one_minus_sum_beta_inner_core,b_deltat,b_veloc_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+ enddo
+
+! !---
+! !--- use buffers to assemble forces with the central cube
+! !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
+ enddo
+ endif ! end of assembling forces with the central cube
+
+! ------------------- new non blocking implementation -------------------
+
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ do i=1,NGLOB_CRUST_MANTLE
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ else
+
+ do i=1,NGLOB_CRUST_MANTLE
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ endif
+
+ endif ! SIMULATION_TYPE == 3
+
+ ! couples ocean with crust mantle
+ if(OCEANS_VAL) then
+ if(SIMULATION_TYPE == 3) then
+ call compute_coupling_ocean(b_accel_crust_mantle, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+ rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load,NGLOB_XY, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ ABSORBING_CONDITIONS)
+ endif
+ endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! Newmark time scheme - corrector for elastic parts
+
+ if (SIMULATION_TYPE == 3) then
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
+ + b_two_omega_earth*b_veloc_inner_core(2,i)
+ b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
+ - b_two_omega_earth*b_veloc_inner_core(1,i)
+ b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
+ enddo
+ endif ! SIMULATION_TYPE == 3
+
+ ! restores last time snapshot saved for backward/reconstruction of wavefields
+ ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
+ ! and adjoint sources will become more complicated
+ ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
+ if(SIMULATION_TYPE == 3 .and. it == 1) then
+ call read_forward_arrays(myrank, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+ b_R_memory_crust_mantle,b_R_memory_inner_core, &
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+ endif
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+ if (SIMULATION_TYPE == 3) then
+ call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ endif
+ endif ! nrec_local
+
+ ! write the current or final seismograms
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/part2_undo_att.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/part2_undo_att.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/part2_undo_att.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -0,0 +1,960 @@
+
+!! DK DK
+!! DK DK this first part handles the case SIMULATION_TYPE == 3
+!! DK DK it also handles the case NOISE_TOMOGRAPHY == 3
+!! DK DK
+
+ ! Newmark time scheme update
+
+ ! backward field
+ if (SIMULATION_TYPE == 3) then
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
+ + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
+ + b_deltatover2*b_accel_crust_mantle(:,i)
+ b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
+ enddo
+ ! outer core
+ do i=1,NGLOB_OUTER_CORE
+ b_displ_outer_core(i) = b_displ_outer_core(i) &
+ + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+ + b_deltatover2*b_accel_outer_core(i)
+ b_accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
+ + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
+ + b_deltatover2*b_accel_inner_core(:,i)
+ b_accel_inner_core(:,i) = 0._CUSTOM_REAL
+ enddo
+ endif ! SIMULATION_TYPE == 3
+
+ ! compute the maximum of the norm of the displacement
+ ! in all the slices using an MPI reduction
+ ! and output timestamp file to check that simulation is running fine
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) then
+ if (SIMULATION_TYPE == 3) then
+ call check_simulation_stability(it,b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
+ SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
+ it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+ endif
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the fluid
+ ! ****************************************************
+
+ ! compute internal forces in the fluid region
+
+ if (SIMULATION_TYPE == 3) then
+ ! note on backward/reconstructed wavefields:
+ ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
+ ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
+ ! to a time (NSTEP - (it-1) - 1)*DT - t0
+ ! for reconstructing the rotational contributions
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
+if(UNDO_ATTENUATION)then
+ time = sngl((dble(NSTEP-(iteration_on_subset*NT_DUMP_ATTENUATION-it_of_this_subset+1))*DT-t0)*scale_t_inv)
+endif
+ else
+ time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
+if(UNDO_ATTENUATION)then
+ time = (dble(NSTEP-(iteration_on_subset*NT_DUMP_ATTENUATION-it_of_this_subset+1))*DT-t0)*scale_t_inv
+endif
+ endif
+
+ b_iphase = 0 ! do not start any non blocking communications at this stage
+ b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+ endif
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ if (SIMULATION_TYPE == 3) then
+if(UNDO_ATTENUATION)then
+ call compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
+ it,ibool_outer_core, &
+ b_veloc_outer_core,b_accel_outer_core, &
+ vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
+ jacobian2D_bottom_outer_core, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+else
+ call compute_stacey_outer_core_backward(ichunk, &
+ NSTEP,it,ibool_outer_core, &
+ b_accel_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+endif
+ endif
+ endif ! Stacey conditions
+
+
+ ! ****************************************************
+ ! ********** add matching with solid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the fluid
+
+ !---
+ !--- couple with mantle at the top of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ if (SIMULATION_TYPE == 3) then
+ 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))
+ endif
+ endif
+
+ !---
+ !--- couple with inner core at the bottom of the outer core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ if (SIMULATION_TYPE == 3) then
+ 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))
+ endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! ------------------- new non blocking implementation -------------------
+
+ if (SIMULATION_TYPE == 3) then
+
+ ! outer core
+ b_iphase = 1 ! start the non blocking communications
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+
+ b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ ! uses Deville et al. (2002) routine
+ call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ else
+ ! div_displ_outer_core is initialized to zero in the following subroutine.
+ call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
+ b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
+ minus_rho_g_over_kappa_fluid, &
+ b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ is_on_a_slice_edge_outer_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ ibool_outer_core,MOVIE_VOLUME)
+ endif
+
+ do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+ enddo
+
+! ------------------- new non blocking implementation -------------------
+
+ ! Newmark time scheme - corrector for fluid parts
+ do i=1,NGLOB_OUTER_CORE
+ b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
+ b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
+ enddo
+
+ endif
+
+ ! ****************************************************
+ ! big loop over all spectral elements in the solid
+ ! ****************************************************
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if (SIMULATION_TYPE == 3 ) then
+
+ b_iphase = 0 ! do not start any non blocking communications at this stage
+ b_iphase_CC = 0 ! do not start any non blocking communications at this stage
+ b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,b_deltat,b_veloc_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,b_deltat,b_displ_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+ endif
+
+ if (SIMULATION_TYPE == 3) then
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,one_minus_sum_beta_inner_core,b_deltat,b_veloc_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,one_minus_sum_beta_inner_core,b_deltat,b_veloc_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+ endif
+
+ ! Stacey
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ if(SIMULATION_TYPE == 3) then
+if(UNDO_ATTENUATION)then
+ call compute_stacey_crust_mantle_forward(ichunk, &
+ it,SAVE_FORWARD,ibool_crust_mantle, &
+ b_veloc_crust_mantle,b_accel_crust_mantle, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
+ wgllwgll_xz,wgllwgll_yz, &
+ 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, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+else
+ call compute_stacey_crust_mantle_backward(ichunk, &
+ NSTEP,it,ibool_crust_mantle, &
+ b_accel_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, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
+ absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
+endif
+ endif
+ endif ! Stacey conditions
+
+ ! add adjoint sources and add sources for backward/reconstructed wavefield
+ if (SIMULATION_TYPE == 3) then
+if(UNDO_ATTENUATION)then
+ call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+ b_accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source, &
+ iteration_on_subset*NT_DUMP_ATTENUATION-it_of_this_subset+1, &
+ hdur,xi_source,eta_source,gamma_source,nu_source)
+else
+ call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
+ b_accel_crust_mantle,sourcearrays, &
+ DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
+ islice_selected_source,ispec_selected_source, &
+ it,hdur,xi_source,eta_source,gamma_source,nu_source)
+endif
+ endif
+
+if(.not. UNDO_ATTENUATION)then
+ if ( NOISE_TOMOGRAPHY == 3 ) then
+ ! 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(nmovie_points,b_accel_crust_mantle, &
+ normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
+ ibelm_top_crust_mantle,ibool_crust_mantle, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ it,jacobian2D_top_crust_mantle,wgllwgll_xy)
+ endif
+endif
+
+ ! ****************************************************
+ ! ********** add matching with fluid part **********
+ ! ****************************************************
+
+ ! only for elements in first matching layer in the solid
+
+ !---
+ !--- couple with outer core at the bottom of the mantle
+ !---
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+ if(SIMULATION_TYPE == 3) then
+ 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))
+ endif
+ endif
+
+ !---
+ !--- couple with outer core at the top of the inner core
+ !---
+ if(ACTUALLY_COUPLE_FLUID_ICB) then
+ if(SIMULATION_TYPE == 3) then
+ 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))
+ endif
+ endif
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+! ------------------- new non blocking implementation -------------------
+
+ if (SIMULATION_TYPE == 3) then
+
+ ! assemble all the contributions between slices using MPI
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+
+ b_iphase = 1 ! initialize the non blocking communication counter
+ b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
+
+! start the non blocking communications
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+
+ b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+
+ ! compute internal forces in the solid regions
+
+ ! for anisotropy and gravity, x y and z contain r theta and phi
+
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT, &
+ hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,b_deltat,b_veloc_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_crust_mantle,b_accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ is_on_a_slice_edge_crust_mantle,b_icall, &
+ b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
+ c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
+ c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
+ c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ b_R_memory_crust_mantle,one_minus_sum_beta_crust_mantle,b_deltat,b_displ_crust_mantle, &
+ b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+ ! Deville routine
+ if( USE_DEVILLE_PRODUCTS_VAL ) then
+ call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,one_minus_sum_beta_inner_core,b_deltat,b_veloc_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ else
+ call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
+ b_displ_inner_core,b_accel_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ is_on_a_slice_edge_inner_core,b_icall, &
+ b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
+ myrank,iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
+ nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core, &
+ b_R_memory_inner_core,one_minus_sum_beta_inner_core,b_deltat,b_veloc_inner_core, &
+ b_alphaval,b_betaval,b_gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),PARTIAL_PHYS_DISPERSION_ONLY)
+ endif
+
+! assemble all the contributions between slices using MPI
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ do while (b_iphase <= 7) ! make sure the last communications are finished and processed
+ call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
+ b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
+ NUMMSGS_FACES,NCORNERSCHUNKS, &
+ NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+ enddo
+
+! !---
+! !--- use buffers to assemble forces with the central cube
+! !---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+ do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
+ receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
+ ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
+ enddo
+ endif ! end of assembling forces with the central cube
+
+! ------------------- new non blocking implementation -------------------
+
+ if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+
+ do i=1,NGLOB_CRUST_MANTLE
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ else
+
+ do i=1,NGLOB_CRUST_MANTLE
+ b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
+ + b_two_omega_earth*b_veloc_crust_mantle(2,i)
+ b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
+ - b_two_omega_earth*b_veloc_crust_mantle(1,i)
+ b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
+ enddo
+
+ endif
+
+ endif ! SIMULATION_TYPE == 3
+
+ ! couples ocean with crust mantle
+ if(OCEANS_VAL) then
+ if(SIMULATION_TYPE == 3) then
+ call compute_coupling_ocean(b_accel_crust_mantle, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
+ rmass_ocean_load,normal_top_crust_mantle, &
+ ibool_crust_mantle,ibelm_top_crust_mantle, &
+ updated_dof_ocean_load,NGLOB_XY, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
+ ABSORBING_CONDITIONS)
+ endif
+ endif
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+ ! Newmark time scheme - corrector for elastic parts
+
+ if (SIMULATION_TYPE == 3) then
+ ! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
+ enddo
+ ! inner core
+ do i=1,NGLOB_INNER_CORE
+ b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
+ + b_two_omega_earth*b_veloc_inner_core(2,i)
+ b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
+ - b_two_omega_earth*b_veloc_inner_core(1,i)
+ b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
+ b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
+ enddo
+ endif ! SIMULATION_TYPE == 3
+
+ ! restores last time snapshot saved for backward/reconstruction of wavefields
+ ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
+ ! and adjoint sources will become more complicated
+ ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
+if(.not. UNDO_ATTENUATION)then
+ if(SIMULATION_TYPE == 3 .and. it == 1) then
+ call read_forward_arrays(myrank, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+ b_R_memory_crust_mantle,b_R_memory_inner_core, &
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+ endif
+endif
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+ if (SIMULATION_TYPE == 3) then
+ call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
+ nu,hxir_store,hetar_store,hgammar_store, &
+ scale_displ,ibool_crust_mantle, &
+ ispec_selected_rec,number_receiver_global, &
+ seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismograms)
+
+ endif
+ endif ! nrec_local
+
+ ! write the current or final seismograms
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ 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,3
+ 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,3
+ 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
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,stbur, &
+ nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!
+
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/part3_kernel_computation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/part3_kernel_computation.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/part3_kernel_computation.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -0,0 +1,258 @@
+
+!! DK DK for kernel calculations
+
+! kernel calculations
+ if (SIMULATION_TYPE == 3) then
+ ! crust mantle
+ call compute_kernels_crust_mantle(ibool_crust_mantle, &
+ rho_kl_crust_mantle,beta_kl_crust_mantle, &
+ alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
+ accel_crust_mantle,b_displ_crust_mantle, &
+ deltat,displ_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)
+
+ ! outer core
+ call compute_kernels_outer_core(ibool_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ displ_outer_core,accel_outer_core, &
+ b_displ_outer_core,b_accel_outer_core, &
+ vector_accel_outer_core,vector_displ_outer_core, &
+ b_vector_displ_outer_core, &
+ div_displ_outer_core,b_div_displ_outer_core, &
+ rhostore_outer_core,kappavstore_outer_core, &
+ rho_kl_outer_core,alpha_kl_outer_core, &
+ deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
+ deltat)
+
+ ! inner core
+ call compute_kernels_inner_core(ibool_inner_core, &
+ rho_kl_inner_core,beta_kl_inner_core, &
+ alpha_kl_inner_core, &
+ accel_inner_core,b_displ_inner_core, &
+ deltat,displ_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)
+
+ ! NOISE TOMOGRAPHY --- source strength kernel
+ if (NOISE_TOMOGRAPHY == 3) &
+ call compute_kernels_strength_noise(nmovie_points,ibool_crust_mantle, &
+ Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
+ normal_x_noise,normal_y_noise,normal_z_noise, &
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
+ ibelm_top_crust_mantle)
+
+ ! --- boundary kernels ------
+ if (SAVE_BOUNDARY_MESH) then
+ fluid_solid_boundary = .false.
+ iregion_code = IREGION_CRUST_MANTLE
+
+ ! Moho
+ if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
+
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
+
+ moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
+ endif
+
+ ! d400
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
+
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
+
+ d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
+
+ ! d670
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
+
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
+
+ d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
+
+ ! CMB
+ fluid_solid_boundary = .true.
+ iregion_code = IREGION_CRUST_MANTLE
+ call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
+ b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
+ ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
+ c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
+ c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
+ c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
+ c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
+ c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
+ k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
+ cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
+
+ iregion_code = IREGION_OUTER_CORE
+ call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
+ b_vector_displ_outer_core,nspec_outer_core, &
+ iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core,&
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ k_bot,ibelm_top_outer_core,normal_top_outer_core, &
+ cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
+
+ cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
+
+ ! ICB
+ fluid_solid_boundary = .true.
+ call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
+ b_vector_displ_outer_core,nspec_outer_core, &
+ iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core,&
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_outer_core,kappavstore_outer_core,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
+ icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
+
+ iregion_code = IREGION_INNER_CORE
+ call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
+ b_displ_inner_core,nspec_inner_core,iregion_code, &
+ ystore_inner_core,zstore_inner_core,ibool_inner_core,ispec_is_tiso_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core,&
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
+ rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
+ dummy_array,dummy_array,dummy_array, &
+ c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array,dummy_array, &
+ c33store_inner_core,dummy_array,dummy_array, &
+ dummy_array,c44store_inner_core,dummy_array,dummy_array, &
+ dummy_array,dummy_array,dummy_array, &
+ k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
+ icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
+
+ icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
+ endif
+
+ ! approximate hessian
+ if( APPROXIMATE_HESS_KL ) then
+ call compute_kernels_hessian(ibool_crust_mantle, &
+ hess_kl_crust_mantle,&
+ accel_crust_mantle,b_accel_crust_mantle, &
+ deltat)
+ endif
+
+ endif ! end of if computing kernels
+
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_1D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_1D.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_1D.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -94,7 +94,6 @@
NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
nglob
-! computed in read_compute_parameters
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
@@ -111,6 +110,10 @@
integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
integer, dimension(NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_SPEC_THIS
integer, dimension(NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_SPEC_OTHER
+
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
+
! ************** PROGRAM STARTS HERE **************
print *
@@ -150,7 +153,7 @@
ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_2D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_2D.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_2D.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -84,7 +84,6 @@
ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,SAVE_REGULAR_KL
-! computed in read_compute_parameters
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
@@ -113,6 +112,9 @@
integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
+
! ************** PROGRAM STARTS HERE **************
print *
@@ -153,9 +155,8 @@
ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
-
! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_corners_chunks.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_corners_chunks.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_corners_chunks.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -93,7 +93,6 @@
character(len=150) filename,prname
-! computed in read_compute_parameters
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
@@ -103,6 +102,10 @@
logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
+
! ************** PROGRAM STARTS HERE **************
print *
@@ -140,9 +143,9 @@
ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
print *
print *,'There are ',NPROCTOT,' slices numbered from 0 to ',NPROCTOT-1
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_faces_chunks.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_faces_chunks.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/check_buffers_faces_chunks.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -97,7 +97,6 @@
character(len=150) filename,prname
-! computed in read_compute_parameters
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
@@ -108,6 +107,9 @@
integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
+
! ************** PROGRAM STARTS HERE **************
print *
@@ -143,7 +145,7 @@
ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/combine_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/combine_AVS_DX.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/combine_AVS_DX.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -170,18 +170,19 @@
integer proc_p1,proc_p2
-! computed in read_compute_parameters
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
+
! ************** PROGRAM STARTS HERE **************
print *
@@ -225,7 +226,7 @@
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,&
USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
if(.not. SAVE_MESH_FILES) stop 'AVS or DX files were not saved by the mesher'
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/create_movie_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/create_movie_AVS_DX.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/create_movie_AVS_DX.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -817,12 +817,14 @@
integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
+
print *
print *,'reading parameter file'
print *
! read the parameter file and compute additional parameters
-
call read_compute_parameters(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, &
@@ -851,7 +853,7 @@
ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
if(MOVIE_COARSE) stop 'create_movie_AVS_DX does not work with MOVIE_COARSE'
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/create_movie_GMT_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/create_movie_GMT_global.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/create_movie_GMT_global.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -159,6 +159,9 @@
real(kind=CUSTOM_REAL) :: xmesh,ymesh,zmesh
integer :: istamp1,istamp2
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
+
! ************** PROGRAM STARTS HERE **************
print *
@@ -200,7 +203,8 @@
CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE, &
- USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL)
+ USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL, &
+ PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
if(.not. MOVIE_SURFACE) stop 'movie frames were not saved by the solver'
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/Makefile
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/Makefile (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/Makefile 2013-06-28 17:42:14 UTC (rev 22443)
@@ -0,0 +1,56 @@
+#=====================================================================
+#
+# S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+# --------------------------------------------------
+#
+# Main authors: Dimitri Komatitsch and Jeroen Tromp
+# Princeton University, USA
+# and University of Pau / CNRS / INRIA, France
+# (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+# April 2011
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+#=====================================================================
+
+DIR = compute_optimized_dumping_undo_att
+
+# The rest of this file is generic
+#######################################
+
+####
+#### targets
+####
+
+default:
+ $(MAKE) -C ../.. $(DIR)
+
+all:
+ $(MAKE) -C ../.. all
+
+clean:
+ $(MAKE) -C ../.. CLEAN=$(DIR) clean
+
+cleanall:
+ $(MAKE) -C ../.. clean
+
+backup:
+ mkdir -p bak
+ cp *f90 *h Makefile bak
+
+bak: backup
+
+.PHONY: default all clean cleanall backup bak
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/compute_optimized_dumping_undo_att.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -0,0 +1,345 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and CNRS / INRIA / University of Pau, France
+! (c) Princeton University and CNRS / INRIA / University of Pau
+! April 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute the optimal interval at which to dump restart files to disk to undo attenuation in an exact way
+
+! Dimitri Komatitsch and Zhinan Xie, CNRS Marseille, France, June 2013.
+
+ program xcompute_optimized_dumping
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,RMOHO_FICTITIOUS_IN_MESHER
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION,CASE_3D, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,SAVE_REGULAR_KL
+
+ character(len=150) LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ nglob
+
+ double precision :: static_memory_size
+
+ integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
+
+ integer :: iregion
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
+ integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
+
+ integer :: NT_DUMP_ATTENUATION_optimal_to_use,number_of_dumpings_to_do
+ double precision :: gigabytes_avail_per_core,percentage_to_use_per_core,what_we_can_use_in_GB,size_to_store_at_each_time_step, &
+ disk_size_of_each_dumping
+
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
+
+! ************** PROGRAM STARTS HERE **************
+
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,&
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
+
+! optimal dumping interval calculation can only be done when SIMULATION_TYPE == 3 in the Par_file,
+! thus set it to that value here in this serial code even if it has a different value in the Par_file
+ SIMULATION_TYPE = 3
+
+! count the total number of sources in the CMTSOLUTION file
+ call count_number_of_sources(NSOURCES)
+
+ do iregion=1,MAX_NUM_REGIONS
+ NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
+ enddo
+
+ if (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA) then
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + &
+ maxval(DIFF_NSPEC1D_RADIAL(:,:))*(NGLLZ-1)
+ endif
+
+! evaluate the amount of static memory needed by the solver
+ call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+ ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+ ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+ NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+ NGLOB1D_RADIAL_TEMP(:) = &
+ (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
+
+ print *
+ print *,'number of processors = ',NPROCTOT
+ print *
+ print *,'maximum number of points per region = ',nglob(IREGION_CRUST_MANTLE)
+ print *
+ print *,'total elements per slice = ',sum(NSPEC)
+ print *,'total points per slice = ',sum(nglob)
+ print *
+ print *,'number of time steps = ',NSTEP
+ print *
+
+ print *,'approximate static memory needed by the solver:'
+ print *,'----------------------------------------------'
+ print *
+ print *,'(lower bound, usually the real amount used is 5% to 10% higher)'
+ print *
+ print *,'(you can get a more precise estimate of the size used per MPI process'
+ print *,' by typing "size -d bin/xspecfem3D"'
+ print *,' after compiling the code with the DATA/Par_file you plan to use)'
+ print *
+ print *,'size of static arrays per slice = ',static_memory_size/1.d6,' MB'
+ print *,' = ',static_memory_size/1048576.d0,' MiB'
+ print *,' = ',static_memory_size/1.d9,' GB'
+ print *,' = ',static_memory_size/1073741824.d0,' GiB'
+ print *
+
+ if(static_memory_size*dble(NPROCTOT)/1.d6 < 10000.d0) then
+ print *,'size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1.d6,' MB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1048576.d0,' MiB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1.d9,' GB'
+ else
+ print *,'size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1.d9,' GB'
+ endif
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GiB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1.d12,' TB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TiB'
+ print *
+
+ print *,'How much memory (in GB) is installed on your machine per CPU core?'
+ print *,' (or per GPU card or per INTEL MIC Phi board)?'
+ print *,' (beware, this value MUST be given per core, i.e. per MPI thread, i.e. per MPI rank, NOT per node)'
+ read(*,*) gigabytes_avail_per_core
+
+ if(gigabytes_avail_per_core < 0.1d0) stop 'less than 100 MB per core does not seem realistic; exiting...'
+ if(gigabytes_avail_per_core > 100.d0) stop 'more than 100 GB per core does not seem realistic; exiting...'
+
+ print *
+ print *,'What percentage of this total do you allow us to use, keeping in mind that you'
+ print *,'need to leave some memory available for the GNU/Linux system to run?'
+ print *,' (a typical value is 90%; 92% to 95% is probably OK too; 85% is very safe)'
+ read(*,*) percentage_to_use_per_core
+
+ if(percentage_to_use_per_core < 50.d0) stop 'less than 50% does not seem realistic; exiting...'
+ if(percentage_to_use_per_core > 96.d0) stop 'more than 96% is risky; exiting...'
+
+ what_we_can_use_in_GB = gigabytes_avail_per_core * percentage_to_use_per_core / 100.d0
+
+! convert static_memory_size to GB
+ static_memory_size = static_memory_size / 1.d9
+
+ print *
+ print *,'without undoing of attenuation you are using ',static_memory_size,' GB per core'
+ print *,' i.e. ',sngl(100.d0 * static_memory_size / gigabytes_avail_per_core),'% of the installed memory'
+
+ if(static_memory_size >= gigabytes_avail_per_core) &
+ stop 'you are using more memory than what you told us is installed!!! there is an error'
+
+ if(static_memory_size >= what_we_can_use_in_GB) &
+ stop 'you are using more memory than what you allowed us to use!!! there is an error'
+
+! compute the size to store in memory at each time step
+ size_to_store_at_each_time_step = 0
+
+! displ_crust_mantle
+ size_to_store_at_each_time_step = size_to_store_at_each_time_step + dble(NDIM)*NGLOB(IREGION_CRUST_MANTLE)*dble(CUSTOM_REAL)
+
+! displ_inner_core
+ size_to_store_at_each_time_step = size_to_store_at_each_time_step + dble(NDIM)*NGLOB(IREGION_INNER_CORE)*dble(CUSTOM_REAL)
+
+! displ_outer_core and accel_outer_core (both being scalar arrays)
+ size_to_store_at_each_time_step = size_to_store_at_each_time_step + 2.d0*NGLOB(IREGION_OUTER_CORE)*dble(CUSTOM_REAL)
+
+! convert to GB
+ size_to_store_at_each_time_step = size_to_store_at_each_time_step / 1.d9
+
+ print *
+ print *,'each time step to store in memory to undo attenuation requires storing ',size_to_store_at_each_time_step,' GB per core'
+
+ print *
+ print *,'*******************************************************************************'
+ print *,'the optimal value to put in DATA/Par_file is thus:'
+ NT_DUMP_ATTENUATION_optimal_to_use = int((what_we_can_use_in_GB - static_memory_size) / size_to_store_at_each_time_step)
+ print *
+ print *,'NT_DUMP_ATTENUATION = ',NT_DUMP_ATTENUATION_optimal_to_use
+ print *
+ print *,'(no need to then recompile the code, just edit the file and change the value)'
+ print *,'*******************************************************************************'
+
+! compute the size of files to dump to disk
+ disk_size_of_each_dumping = 0
+
+! displ_crust_mantle, veloc_crust_mantle, accel_crust_mantle
+ disk_size_of_each_dumping = disk_size_of_each_dumping + 3.d0*dble(NDIM)*NGLOB(IREGION_CRUST_MANTLE)*dble(CUSTOM_REAL)
+
+! displ_inner_core, veloc_inner_core, accel_inner_core
+ disk_size_of_each_dumping = disk_size_of_each_dumping + 3.d0*dble(NDIM)*NGLOB(IREGION_INNER_CORE)*dble(CUSTOM_REAL)
+
+! displ_outer_core, veloc_outer_core, accel_outer_core (all scalar arrays)
+ disk_size_of_each_dumping = disk_size_of_each_dumping + 3.d0*NGLOB(IREGION_OUTER_CORE)*dble(CUSTOM_REAL)
+
+! A_array_rotation,B_array_rotation
+ if (ROTATION) disk_size_of_each_dumping = disk_size_of_each_dumping + &
+ dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ROTATION*2.d0*dble(CUSTOM_REAL)
+
+ if (ATTENUATION) then
+! R_memory_crust_mantle
+ disk_size_of_each_dumping = disk_size_of_each_dumping + 5.d0*dble(N_SLS)*dble(NGLLX)* &
+ dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ATTENUAT*dble(CUSTOM_REAL)
+
+! R_memory_inner_core
+ disk_size_of_each_dumping = disk_size_of_each_dumping + 5.d0*dble(N_SLS)*dble(NGLLX)* &
+ dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ATTENUATION*dble(CUSTOM_REAL)
+ endif
+
+! convert to GB
+ disk_size_of_each_dumping = disk_size_of_each_dumping / 1.d9
+
+!! DK DK this formula could be made more precise here; currently in some cases it can probably be off by +1 or -1
+ number_of_dumpings_to_do = nint(NSTEP / dble(NT_DUMP_ATTENUATION_optimal_to_use))
+
+ print *
+ print *,'we will need to save a total of ',number_of_dumpings_to_do,' dumpings (restart files) to disk'
+
+ print *
+ print *,'each dumping on the disk to undo attenuation requires storing ',disk_size_of_each_dumping,' GB per core'
+
+ print *
+ print *,'each dumping on the disk requires storing ',disk_size_of_each_dumping*NPROCTOT, &
+ ' GB for all cores'
+
+ print *
+ print *,'ALL dumpings on the disk require storing ',disk_size_of_each_dumping*number_of_dumpings_to_do,' GB per core'
+
+ print *
+ print *,'*******************************************************************************'
+ print *,'ALL dumpings on the disk require storing ', &
+ disk_size_of_each_dumping*number_of_dumpings_to_do*NPROCTOT,' GB for all cores'
+ print *,' i.e. ',disk_size_of_each_dumping*number_of_dumpings_to_do*NPROCTOT/1000.d0,' TB'
+ print *,'*******************************************************************************'
+ print *
+
+ if(.not. UNDO_ATTENUATION) then
+ print *
+ print *,'*******************************************************************************'
+ print *,'BEWARE, UNDO_ATTENUATION is .false. and thus undoing is currently'
+ print *,'turned off, i.e. the above estimates are currently NOT USED.'
+ print *,'*******************************************************************************'
+ print *
+ endif
+
+ end program xcompute_optimized_dumping
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/rules.mk
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/rules.mk (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/compute_optimized_dumping_undo_att/rules.mk 2013-06-28 17:42:14 UTC (rev 22443)
@@ -0,0 +1,85 @@
+#=====================================================================
+#
+# S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+# --------------------------------------------------
+#
+# Main authors: Dimitri Komatitsch and Jeroen Tromp
+# Princeton University, USA
+# and University of Pau / CNRS / INRIA, France
+# (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+# April 2011
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+#=====================================================================
+
+#######################################
+
+compute_optimized_dumping_undo_att_TARGETS = \
+ $E/xcompute_optimized_dumping_undo_att \
+ $(EMPTY_MACRO)
+
+compute_optimized_dumping_undo_att_OBJECTS = \
+ $O/compute_optimized_dumping_undo_att.o \
+ $(EMPTY_MACRO)
+
+# These files come from the shared directory
+compute_optimized_dumping_undo_att_SHARED_OBJECTS = \
+ $O/auto_ner.o \
+ $O/count_number_of_sources.o \
+ $O/euler_angles.o \
+ $O/force_ftz.o \
+ $O/get_model_parameters.o \
+ $O/get_value_parameters.o \
+ $O/memory_eval.o \
+ $O/param_reader.o \
+ $O/read_compute_parameters.o \
+ $O/read_parameter_file.o \
+ $O/read_value_parameters.o \
+ $O/reduce.o \
+ $O/rthetaphi_xyz.o \
+ $O/save_header_file.o \
+ $(EMPTY_MACRO)
+
+#######################################
+
+####
+#### rules for executables
+####
+
+${E}/xcompute_optimized_dumping_undo_att: $(compute_optimized_dumping_undo_att_OBJECTS) $(compute_optimized_dumping_undo_att_SHARED_OBJECTS)
+ ${FCCOMPILE_CHECK} -o ${E}/xcompute_optimized_dumping_undo_att $(compute_optimized_dumping_undo_att_OBJECTS) $(compute_optimized_dumping_undo_att_SHARED_OBJECTS)
+
+## uses MPI compiler to link executable instead (usedful for cross-compilation)
+#${E}/xcompute_optimized_dumping_undo_att: $(compute_optimized_dumping_undo_att_OBJECTS) $(compute_optimized_dumping_undo_att_SHARED_OBJECTS)
+# ${MPIFCCOMPILE_CHECK} -o ${E}/xcompute_optimized_dumping_undo_att $(compute_optimized_dumping_undo_att_OBJECTS) $(compute_optimized_dumping_undo_att_SHARED_OBJECTS)
+
+#######################################
+
+## compilation directories
+S := ${S_TOP}/src/compute_optimized_dumping_undo_att
+$(compute_optimized_dumping_undo_att_OBJECTS): S := ${S_TOP}/src/compute_optimized_dumping_undo_att
+
+####
+#### rule for each .o file below
+####
+
+##
+## compute_optimized_dumping_undo_att objects
+##
+
+$O/compute_optimized_dumping_undo_att.o: $S/compute_optimized_dumping_undo_att.f90
+ ${FCCOMPILE_CHECK} -c -o $O/compute_optimized_dumping_undo_att.o ${FCFLAGS_f90} $S/compute_optimized_dumping_undo_att.f90
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_header_file/create_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_header_file/create_header_file.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/create_header_file/create_header_file.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -103,6 +103,9 @@
integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
+
! ************** PROGRAM STARTS HERE **************
call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
@@ -138,9 +141,8 @@
ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
-
! count the total number of sources in the CMTSOLUTION file
call count_number_of_sources(NSOURCES)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -381,7 +381,6 @@
NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
NGLOB
-! computed in read_compute_parameters
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
@@ -424,7 +423,11 @@
! this for non blocking MPI
logical, dimension(:), allocatable :: is_on_a_slice_edge
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
+
! ************** PROGRAM STARTS HERE **************
+
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
@@ -542,7 +545,8 @@
HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE, &
- USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL)
+ USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL, &
+ PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
endif
! distributes parameters from master to all processes
@@ -578,7 +582,7 @@
HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY, &
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
! check that the code is running with the requested number of processes
if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea1d.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea1d.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -101,9 +101,9 @@
double precision r,frac,scaleval
-!! DK DK UGLY implementation of model sea1d below and its radii in
-!! DK DK UGLY subroutine read_parameter_file.f90 has not been thoroughly
-!! DK DK UGLY checked yet
+!! DK DK implementation of model sea1d below and its radii in
+!! DK DK subroutine read_parameter_file.f90 has not been thoroughly
+!! DK DK checked yet
! compute real physical radius in meters
r = x * R_EARTH
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/broadcast_compute_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/broadcast_compute_parameters.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/broadcast_compute_parameters.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -57,7 +57,7 @@
HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY, &
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
implicit none
@@ -76,7 +76,7 @@
NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY,NT_DUMP_ATTENUATION
double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
@@ -90,7 +90,7 @@
SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT,&
OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE,&
- SAVE_REGULAR_KL
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
character(len=150) LOCAL_PATH,MODEL
@@ -127,8 +127,8 @@
! local parameters
double precision, dimension(31) :: bcast_double_precision
- integer, dimension(39) :: bcast_integer
- logical, dimension(36) :: bcast_logical
+ integer, dimension(40) :: bcast_integer
+ logical, dimension(38) :: bcast_logical
integer ier
! master process prepares broadcasting arrays
@@ -148,7 +148,7 @@
NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,&
SIMULATION_TYPE,REFERENCE_1D_MODEL,THREE_D_MODEL,NPROC,NPROCTOT, &
NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NSOURCES,NOISE_TOMOGRAPHY/)
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NSOURCES,NOISE_TOMOGRAPHY,NT_DUMP_ATTENUATION/)
bcast_logical = (/TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
@@ -160,7 +160,7 @@
HONOR_1D_SPHERICAL_MOHO,MOVIE_COARSE, &
OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE,&
- SAVE_REGULAR_KL/)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION/)
bcast_double_precision = (/DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
@@ -171,9 +171,9 @@
endif
! broadcasts the information read on the master to the nodes
- call MPI_BCAST(bcast_integer,39,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(bcast_integer,40,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(bcast_double_precision,31,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(bcast_logical,36,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(bcast_logical,38,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
! broadcasts non-single value parameters
call MPI_BCAST(LOCAL_PATH,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
@@ -246,6 +246,7 @@
MOVIE_STOP = bcast_integer(37)
NSOURCES = bcast_integer(38)
NOISE_TOMOGRAPHY = bcast_integer(39)
+ NT_DUMP_ATTENUATION = bcast_integer(40)
! logicals
TRANSVERSE_ISOTROPY = bcast_logical(1)
@@ -284,6 +285,8 @@
WRITE_SEISMOGRAMS_BY_MASTER= bcast_logical(34)
USE_BINARY_FOR_LARGE_FILE= bcast_logical(35)
SAVE_REGULAR_KL = bcast_logical(36)
+ PARTIAL_PHYS_DISPERSION_ONLY = bcast_logical(37)
+ UNDO_ATTENUATION = bcast_logical(38)
! double precisions
DT = bcast_double_precision(1)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/get_model_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/get_model_parameters.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/get_model_parameters.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -386,7 +386,7 @@
REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
THREE_D_MODEL = THREE_D_MODEL_GLL
TRANSVERSE_ISOTROPY = .true.
- ! note: after call to this routines read_compute_parameters() we will set
+ ! note: after call to this routine read_compute_parameters() we will set
! mgll_v%model_gll flag and reset
! THREE_D_MODEL = THREE_D_MODEL_S29EA
! (not done here because we will use mgll_v%model_gll flag to identify this
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/memory_eval.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/memory_eval.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/memory_eval.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -258,7 +258,7 @@
static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*dble(SIZE_INTEGER)
! idoubling_crust_mantle (not needed anymore..)
-! static_memory_size = static_memory_size + NSPEC(IREGION_CRUST_MANTLE)*dble(SIZE_INTEGER)
+! static_memory_size = static_memory_size + NSPEC(IREGION_CRUST_MANTLE)*dble(SIZE_INTEGER)
! idoubling_outer_core
static_memory_size = static_memory_size + NSPEC(IREGION_OUTER_CORE)*dble(SIZE_INTEGER)
! idoubling_inner_core
@@ -334,25 +334,28 @@
! add arrays used to save strain for attenuation or for adjoint runs
+!! ZN ZN this has now been suppressed to save as much memory as possible to undo attenuation
! epsilondev_crust_mantle
- static_memory_size = static_memory_size + 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
+! static_memory_size = static_memory_size + 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
! eps_trace_over_3_crust_mantle
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
+! static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
! epsilondev_inner_core
- static_memory_size = static_memory_size + 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
+! static_memory_size = static_memory_size + 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
! eps_trace_over_3_inner_core
- static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
+! static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
! add arrays used for adjoint runs only (LQY: not very accurate)
! b_R_memory_crust_mantle
-! b_epsilondev_crust_mantle
-! b_eps_trace_over_3_crust_mantle
+!! ZN ZN this has now been suppressed to save as much memory as possible to undo attenuation
+!!! b_epsilondev_crust_mantle
+!!! b_eps_trace_over_3_crust_mantle
! rho_kl_crust_mantle,beta_kl_crust_mantle, alpha_kl_crust_mantle
- static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 9.d0)* &
+! static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 9.d0)* &
+ static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 3.d0)* &
dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ADJOINT*dble(CUSTOM_REAL)
! b_div_displ_outer_core
@@ -360,10 +363,12 @@
static_memory_size = static_memory_size + 3.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ADJOINT*dble(CUSTOM_REAL)
! b_R_memory_inner_core
-! b_epsilondev_inner_core
-! b_eps_trace_over_3_inner_core
+!! ZN ZN this has now been suppressed to save as much memory as possible to undo attenuation
+!!! b_epsilondev_inner_core
+!!! b_eps_trace_over_3_inner_core
! rho_kl_inner_core,beta_kl_inner_core, alpha_kl_inner_core
- static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 9.d0)* &
+! static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 9.d0)* &
+ static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 3.d0)* &
dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ADJOINT*dble(CUSTOM_REAL)
! b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/read_compute_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/read_compute_parameters.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/read_compute_parameters.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -57,14 +57,12 @@
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,&
USE_BINARY_FOR_LARGE_FILE,EMULATE_ONLY,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
-
implicit none
include "constants.h"
-
! parameters read from parameter file
integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
@@ -148,6 +146,8 @@
integer :: tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,nglob_edge_v,to_remove
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
+ integer :: NT_DUMP_ATTENUATION
! reads in Par_file values
call read_parameter_file(OUTPUT_FILES,LOCAL_PATH,MODEL, &
@@ -167,7 +167,7 @@
OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
! converts values to radians
MOVIE_EAST = MOVIE_EAST_DEG * DEGREES_TO_RADIANS
@@ -227,6 +227,9 @@
! 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)
+!! 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 doing benchmark runs to measure scaling of the code for a limited number of time steps only
if (DO_BENCHMARK_RUN_ONLY) NSTEP = NSTEP_FOR_BENCHMARK
@@ -348,8 +351,6 @@
last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
-
-
end subroutine read_compute_parameters
!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/read_parameter_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/read_parameter_file.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/read_parameter_file.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -25,6 +25,14 @@
!
!=====================================================================
+!!!!!! VERY IMPORTANT
+!!!!!! VERY IMPORTANT
+!!!!!! VERY IMPORTANT if you add new parameters to DATA/Par_file, remember to also
+!!!!!! VERY IMPORTANT broadcast them with MPI_BCAST in src/shared/broadcast_compute_parameters.f90
+!!!!!! VERY IMPORTANT otherwise the code will *NOT* work
+!!!!!! VERY IMPORTANT
+!!!!!! VERY IMPORTANT
+
subroutine read_parameter_file(OUTPUT_FILES,LOCAL_PATH,MODEL, &
NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS, &
@@ -42,7 +50,7 @@
OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,NOISE_TOMOGRAPHY,&
- SAVE_REGULAR_KL)
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
implicit none
@@ -52,7 +60,7 @@
integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NTSTEP_BETWEEN_READ_ADJSRC,NTSTEP_BETWEEN_FRAMES, &
NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read,NOISE_TOMOGRAPHY
+ NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read,NOISE_TOMOGRAPHY,NT_DUMP_ATTENUATION
double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,&
@@ -67,7 +75,8 @@
ABSORBING_CONDITIONS,SAVE_FORWARD, &
OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,SAVE_REGULAR_KL
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,SAVE_REGULAR_KL, &
+ PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
@@ -126,8 +135,19 @@
! define the velocity model
call read_value_string(MODEL, 'model.MODEL', ierr)
if (ierr /= 0) stop 'an error occurred while reading the parameter file: MODEL'
+
call read_value_double_precision(RECORD_LENGTH_IN_MINUTES, 'solver.RECORD_LENGTH_IN_MINUTES', ierr)
- if (ierr /= 0) stop 'an error occurred while reading the parameter file: RECORD_LENGTH..'
+ if (ierr /= 0) stop 'an error occurred while reading the parameter file: RECORD_LENGTH_IN_MINUTES'
+
+ call read_value_logical(PARTIAL_PHYS_DISPERSION_ONLY, 'solver.PARTIAL_PHYS_DISPERSION_ONLY', ierr)
+ if (ierr /= 0) stop 'an error occurred while reading the parameter file: PARTIAL_PHYS_DISPERSION_ONLY'
+
+ call read_value_logical(UNDO_ATTENUATION, 'solver.UNDO_ATTENUATION', ierr)
+ if (ierr /= 0) stop 'an error occurred while reading the parameter file: UNDO_ATTENUATION'
+
+ call read_value_integer(NT_DUMP_ATTENUATION, 'solver.NT_DUMP_ATTENUATION', ierr)
+ if (ierr /= 0) stop 'an error occurred while reading the parameter file: NT_DUMP_ATTENUATION'
+
call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE', ierr)
if (ierr /= 0) stop 'an error occurred while reading the parameter file: MOVIE_SURFACE'
call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME', ierr)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/save_header_file.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/save_header_file.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -531,25 +531,6 @@
write(IOUT,*) 'logical, parameter :: USE_DEVILLE_PRODUCTS_VAL = .false.'
endif
- ! backward/reconstruction of forward wavefield:
- ! can only mimic attenuation effects on velocity at this point, since no full wavefield snapshots are stored
- if((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then
-
- ! attenuation mimic:
- ! mimicking average (not full) effect of attenuation on apparent velocities, not amplitudes. that is,
- ! phase shifts will be partially accounted for, but amplitudes will differ in adjoint simulations
- if( ATTENUATION ) then
- write(IOUT,*) 'logical, parameter :: PARTIAL_PHYS_DISPERSION_ONLY = .true.'
- else
- write(IOUT,*) 'logical, parameter :: PARTIAL_PHYS_DISPERSION_ONLY = .false.'
- endif
-
- else
-
- ! calculates full attenuation (phase & amplitude effects) if used
- write(IOUT,*) 'logical, parameter :: PARTIAL_PHYS_DISPERSION_ONLY = .false.'
- endif
-
! attenuation and/or adjoint simulations
if (ATTENUATION .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD &
.or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/check_simulation_stability.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/check_simulation_stability.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/check_simulation_stability.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -26,8 +26,6 @@
!=====================================================================
subroutine check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
- b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
@@ -46,15 +44,6 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ_inner_core
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: displ_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: b_displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_displ_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: b_displ_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
- eps_trace_over_3_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_crust_mantle
-
integer SIMULATION_TYPE
character(len=150) OUTPUT_FILES
@@ -63,8 +52,6 @@
! local parameters
! maximum of the norm of the displacement and of the potential in the fluid
real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all,Ufluidnorm,Ufluidnorm_all
- real(kind=CUSTOM_REAL) Strain_norm,Strain_norm_all,strain2_norm,strain2_norm_all
- real(kind=CUSTOM_REAL) b_Usolidnorm,b_Usolidnorm_all,b_Ufluidnorm,b_Ufluidnorm_all
! names of the data files for all the processors in MPI
character(len=150) outputname
! timer MPI
@@ -107,32 +94,6 @@
call MPI_REDUCE(Ufluidnorm,Ufluidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
MPI_COMM_WORLD,ier)
- if (SIMULATION_TYPE == 3) then
- b_Usolidnorm = max( &
- maxval(sqrt(b_displ_crust_mantle(1,:)**2 + &
- b_displ_crust_mantle(2,:)**2 + b_displ_crust_mantle(3,:)**2)), &
- maxval(sqrt(b_displ_inner_core(1,:)**2 &
- + b_displ_inner_core(2,:)**2 &
- + b_displ_inner_core(3,:)**2)))
-
- b_Ufluidnorm = maxval(abs(b_displ_outer_core))
-
- ! compute the maximum of the maxima for all the slices using an MPI reduction
- call MPI_REDUCE(b_Usolidnorm,b_Usolidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
- MPI_COMM_WORLD,ier)
- call MPI_REDUCE(b_Ufluidnorm,b_Ufluidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
- MPI_COMM_WORLD,ier)
- endif
-
- if (COMPUTE_AND_STORE_STRAIN) then
- Strain_norm = maxval(abs(eps_trace_over_3_crust_mantle))
- strain2_norm= maxval(abs(epsilondev_crust_mantle))
- call MPI_REDUCE(Strain_norm,Strain_norm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
- MPI_COMM_WORLD,ier)
- call MPI_REDUCE(Strain2_norm,Strain2_norm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
- MPI_COMM_WORLD,ier)
- endif
-
if(myrank == 0) then
write(IMAIN,*) 'Time step # ',it
@@ -140,19 +101,15 @@
! rescale maximum displacement to correct dimensions
Usolidnorm_all = Usolidnorm_all * sngl(scale_displ)
- write(IMAIN,*) 'Max norm displacement vector U in solid in all slices (m) = ',Usolidnorm_all
- write(IMAIN,*) 'Max non-dimensional potential Ufluid in fluid in all slices = ',Ufluidnorm_all
-
- if (SIMULATION_TYPE == 3) then
- b_Usolidnorm_all = b_Usolidnorm_all * sngl(scale_displ)
- write(IMAIN,*) 'Max norm displacement vector U in solid in all slices for back prop.(m) = ',b_Usolidnorm_all
- write(IMAIN,*) 'Max non-dimensional potential Ufluid in fluid in all slices for back prop.= ',b_Ufluidnorm_all
+ if (SIMULATION_TYPE == 1) then
+ write(IMAIN,*) 'Max norm displacement vector U in solid in all slices (m) = ',Usolidnorm_all
+ write(IMAIN,*) 'Max non-dimensional potential Ufluid in fluid in all slices = ',Ufluidnorm_all
+ else
+ write(IMAIN,*) 'Max norm displacement vector U in solid in all slices for back prop.(m) = ',Usolidnorm_all
+ write(IMAIN,*) 'Max non-dimensional potential Ufluid in fluid in all slices for back prop.= ',Ufluidnorm_all
endif
- if(COMPUTE_AND_STORE_STRAIN) then
- write(IMAIN,*) 'Max of strain, eps_trace_over_3_crust_mantle =',Strain_norm_all
- write(IMAIN,*) 'Max of strain, epsilondev_crust_mantle =',Strain2_norm_all
- endif
+!! DK DK UNDO_ATTENUATION
! information about the current run only
SHOW_SEPARATE_RUN_INFORMATION = NUMBER_OF_RUNS > 1 .and. NUMBER_OF_THIS_RUN < NUMBER_OF_RUNS
@@ -309,23 +266,28 @@
write(IMAIN,*)
! write time stamp file to give information about progression of simulation
- write(outputname,"('/timestamp',i6.6)") it
+!! DK DK UNDO_ATTENUATION
+ if(SIMULATION_TYPE == 1) then
+! write(outputname,"('/timestamp',i6.6)") it
+ write(outputname,"('/timestamp_forward',i6.6)") it
+ else
+ write(outputname,"('/timestamp_backward',i6.6)") it
+ endif
open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',action='write')
write(IOUT,*) 'Time step # ',it
write(IOUT,*) 'Time: ',sngl(((it-1)*DT-t0)/60.d0),' minutes'
write(IOUT,*)
- write(IOUT,*) 'Max norm displacement vector U in solid in all slices (m) = ',Usolidnorm_all
- write(IOUT,*) 'Max non-dimensional potential Ufluid in fluid in all slices = ',Ufluidnorm_all
+ if (SIMULATION_TYPE == 1) then
+ write(IOUT,*) 'Max norm displacement vector U in solid in all slices (m) = ',Usolidnorm_all
+ write(IOUT,*) 'Max non-dimensional potential Ufluid in fluid in all slices = ',Ufluidnorm_all
+ else
+ write(IOUT,*) 'Max norm displacement vector U in solid in all slices for back prop.(m) = ',Usolidnorm_all
+ write(IOUT,*) 'Max non-dimensional potential Ufluid in fluid in all slices for back prop.= ',Ufluidnorm_all
+ endif
write(IOUT,*)
- if (SIMULATION_TYPE == 3) then
- write(IOUT,*) 'Max norm displacement vector U in solid in all slices for back prop.(m) = ',b_Usolidnorm_all
- write(IOUT,*) 'Max non-dimensional potential Ufluid in fluid in all slices for back prop.= ',b_Ufluidnorm_all
- write(IOUT,*)
- endif
-
write(IOUT,*) 'Elapsed time in seconds = ',tCPU
write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it_run)
@@ -408,16 +370,20 @@
! check stability of the code, exit if unstable
! negative values can occur with some compilers when the unstable value is greater
! than the greatest possible floating-point number of the machine
- if(Usolidnorm_all > STABILITY_THRESHOLD .or. Usolidnorm_all < 0) &
- call exit_MPI(myrank,'forward simulation became unstable and blew up in the solid')
- if(Ufluidnorm_all > STABILITY_THRESHOLD .or. Ufluidnorm_all < 0) &
- call exit_MPI(myrank,'forward simulation became unstable and blew up in the fluid')
-
- if(SIMULATION_TYPE == 3) then
- if(b_Usolidnorm_all > STABILITY_THRESHOLD .or. b_Usolidnorm_all < 0) &
+ if(Usolidnorm_all > STABILITY_THRESHOLD .or. Usolidnorm_all < 0) then
+ if(SIMULATION_TYPE == 1) then
+ call exit_MPI(myrank,'forward simulation became unstable and blew up in the solid')
+ else
call exit_MPI(myrank,'backward simulation became unstable and blew up in the solid')
- if(b_Ufluidnorm_all > STABILITY_THRESHOLD .or. b_Ufluidnorm_all < 0) &
+ endif
+ endif
+
+ if(Ufluidnorm_all > STABILITY_THRESHOLD .or. Ufluidnorm_all < 0) then
+ if(SIMULATION_TYPE == 1) then
+ call exit_MPI(myrank,'forward simulation became unstable and blew up in the fluid')
+ else
call exit_MPI(myrank,'backward simulation became unstable and blew up in the fluid')
+ endif
endif
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_coupling.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_coupling.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_coupling.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -25,12 +25,12 @@
!
!=====================================================================
- subroutine compute_coupling_fluid_CMB(displ_crust_mantle,b_displ_crust_mantle, &
+ subroutine compute_coupling_fluid_CMB(displ_crust_mantle, &
ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
+ accel_outer_core, &
normal_top_outer_core,jacobian2D_top_outer_core, &
wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- SIMULATION_TYPE,nspec_top)
+ nspec_top)
implicit none
@@ -39,14 +39,11 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_displ_crust_mantle
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
@@ -55,7 +52,6 @@
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
- integer SIMULATION_TYPE
integer nspec_top
! local parameters
@@ -100,20 +96,6 @@
! update fluid acceleration/pressure
accel_outer_core(iglob_oc) = accel_outer_core(iglob_oc) + weight*displ_n
- if (SIMULATION_TYPE == 3) then
- ! get displacement in crust mantle
- iglob_cm = ibool_crust_mantle(i,j,k_corresp,ispec_selected)
- displ_x = b_displ_crust_mantle(1,iglob_cm)
- displ_y = b_displ_crust_mantle(2,iglob_cm)
- displ_z = b_displ_crust_mantle(3,iglob_cm)
-
- displ_n = displ_x*nx + displ_y*ny + displ_z*nz
-
- ! update fluid acceleration/pressure
- iglob_oc = ibool_outer_core(i,j,k,ispec)
- b_accel_outer_core(iglob_oc) = b_accel_outer_core(iglob_oc) + weight*displ_n
- endif
-
enddo
enddo
enddo
@@ -124,12 +106,12 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine compute_coupling_fluid_ICB(displ_inner_core,b_displ_inner_core, &
+ subroutine compute_coupling_fluid_ICB(displ_inner_core, &
ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
+ accel_outer_core, &
normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- SIMULATION_TYPE,nspec_bottom)
+ nspec_bottom)
implicit none
@@ -138,14 +120,11 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
displ_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
- b_displ_inner_core
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
@@ -154,7 +133,6 @@
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
- integer SIMULATION_TYPE
integer nspec_bottom
! local parameters
@@ -199,22 +177,6 @@
! update fluid acceleration/pressure
accel_outer_core(iglob_oc) = accel_outer_core(iglob_oc) - weight*displ_n
- if (SIMULATION_TYPE == 3) then
- ! get displacement in inner core
- iglob_ic = ibool_inner_core(i,j,k_corresp,ispec_selected)
- displ_x = b_displ_inner_core(1,iglob_ic)
- displ_y = b_displ_inner_core(2,iglob_ic)
- displ_z = b_displ_inner_core(3,iglob_ic)
-
- displ_n = displ_x*nx + displ_y*ny + displ_z*nz
-
-
- ! update fluid acceleration/pressure
- iglob_oc = ibool_outer_core(i,j,k,ispec)
- b_accel_outer_core(iglob_oc) = b_accel_outer_core(iglob_oc) - weight*displ_n
-
- endif
-
enddo
enddo
enddo
@@ -225,15 +187,14 @@
!-------------------------------------------------------------------------------------------------
!
-
- subroutine compute_coupling_CMB_fluid(displ_crust_mantle,b_displ_crust_mantle, &
- accel_crust_mantle,b_accel_crust_mantle, &
+ subroutine compute_coupling_CMB_fluid(displ_crust_mantle, &
+ accel_crust_mantle, &
ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
+ accel_outer_core, &
normal_top_outer_core,jacobian2D_top_outer_core, &
wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
RHO_TOP_OC,minus_g_cmb, &
- SIMULATION_TYPE,nspec_bottom)
+ nspec_bottom)
implicit none
@@ -242,14 +203,11 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
displ_crust_mantle,accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_displ_crust_mantle,b_accel_crust_mantle
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
@@ -261,7 +219,6 @@
double precision RHO_TOP_OC
real(kind=CUSTOM_REAL) minus_g_cmb
- integer SIMULATION_TYPE
integer nspec_bottom
! local parameters
@@ -309,19 +266,6 @@
accel_crust_mantle(2,iglob_mantle) = accel_crust_mantle(2,iglob_mantle) + weight*ny*pressure
accel_crust_mantle(3,iglob_mantle) = accel_crust_mantle(3,iglob_mantle) + weight*nz*pressure
- if (SIMULATION_TYPE == 3) then
- if(GRAVITY_VAL) then
- pressure = RHO_TOP_OC * (- b_accel_outer_core(iglob_oc) &
- + minus_g_cmb *(b_displ_crust_mantle(1,iglob_mantle)*nx &
- + b_displ_crust_mantle(2,iglob_mantle)*ny + b_displ_crust_mantle(3,iglob_mantle)*nz))
- else
- pressure = - RHO_TOP_OC * b_accel_outer_core(iglob_oc)
- endif
- b_accel_crust_mantle(1,iglob_mantle) = b_accel_crust_mantle(1,iglob_mantle) + weight*nx*pressure
- b_accel_crust_mantle(2,iglob_mantle) = b_accel_crust_mantle(2,iglob_mantle) + weight*ny*pressure
- b_accel_crust_mantle(3,iglob_mantle) = b_accel_crust_mantle(3,iglob_mantle) + weight*nz*pressure
- endif
-
enddo
enddo
enddo
@@ -333,14 +277,14 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine compute_coupling_ICB_fluid(displ_inner_core,b_displ_inner_core, &
- accel_inner_core,b_accel_inner_core, &
+ subroutine compute_coupling_ICB_fluid(displ_inner_core, &
+ accel_inner_core, &
ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
+ accel_outer_core, &
normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
RHO_BOTTOM_OC,minus_g_icb, &
- SIMULATION_TYPE,nspec_top)
+ nspec_top)
implicit none
@@ -349,14 +293,11 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
displ_inner_core,accel_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
- b_displ_inner_core,b_accel_inner_core
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: b_accel_outer_core
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
@@ -368,7 +309,6 @@
double precision RHO_BOTTOM_OC
real(kind=CUSTOM_REAL) minus_g_icb
- integer SIMULATION_TYPE
integer nspec_top
! local parameters
@@ -415,19 +355,6 @@
accel_inner_core(2,iglob_inner_core) = accel_inner_core(2,iglob_inner_core) - weight*ny*pressure
accel_inner_core(3,iglob_inner_core) = accel_inner_core(3,iglob_inner_core) - weight*nz*pressure
- if (SIMULATION_TYPE == 3) then
- if(GRAVITY_VAL) then
- pressure = RHO_BOTTOM_OC * (- b_accel_outer_core(iglob) &
- + minus_g_icb *(b_displ_inner_core(1,iglob_inner_core)*nx &
- + b_displ_inner_core(2,iglob_inner_core)*ny + b_displ_inner_core(3,iglob_inner_core)*nz))
- else
- pressure = - RHO_BOTTOM_OC * b_accel_outer_core(iglob)
- endif
- b_accel_inner_core(1,iglob_inner_core) = b_accel_inner_core(1,iglob_inner_core) - weight*nx*pressure
- b_accel_inner_core(2,iglob_inner_core) = b_accel_inner_core(2,iglob_inner_core) - weight*ny*pressure
- b_accel_inner_core(3,iglob_inner_core) = b_accel_inner_core(3,iglob_inner_core) - weight*nz*pressure
- endif
-
enddo
enddo
enddo
@@ -438,12 +365,12 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine compute_coupling_ocean(accel_crust_mantle,b_accel_crust_mantle, &
+ subroutine compute_coupling_ocean(accel_crust_mantle, &
rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
rmass_ocean_load,normal_top_crust_mantle, &
ibool_crust_mantle,ibelm_top_crust_mantle, &
updated_dof_ocean_load,NGLOB_XY, &
- SIMULATION_TYPE,nspec_top, &
+ nspec_top, &
ABSORBING_CONDITIONS)
implicit none
@@ -454,11 +381,10 @@
integer :: NGLOB_XY
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: b_accel_crust_mantle
! mass matrices
!
- ! in the case of stacey boundary conditions, add C*delta/2 contribution to the mass matrix
+ ! in the case of Stacey boundary conditions, add C*delta/2 contribution to the mass matrix
! on the Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
!
@@ -477,14 +403,12 @@
logical, dimension(NGLOB_CRUST_MANTLE_OCEANS) :: updated_dof_ocean_load
logical :: ABSORBING_CONDITIONS
- integer SIMULATION_TYPE
integer nspec_top
! local parameters
- real(kind=CUSTOM_REAL) :: force_normal_comp,b_force_normal_comp
+ real(kind=CUSTOM_REAL) :: force_normal_comp
real(kind=CUSTOM_REAL) :: additional_term_x,additional_term_y,additional_term_z
- real(kind=CUSTOM_REAL) :: b_additional_term_x,b_additional_term_y,b_additional_term_z
- real(kind=CUSTOM_REAL) :: additional_term,b_additional_term
+ real(kind=CUSTOM_REAL) :: additional_term
real(kind=CUSTOM_REAL) :: nx,ny,nz
integer :: i,j,k,ispec,ispec2D,iglob
@@ -531,20 +455,6 @@
accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + additional_term_y * ny
accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + additional_term_z * nz
- if (SIMULATION_TYPE == 3) then
- b_force_normal_comp = b_accel_crust_mantle(1,iglob)*nx / rmassx_crust_mantle(iglob) + &
- b_accel_crust_mantle(2,iglob)*ny / rmassy_crust_mantle(iglob) + &
- b_accel_crust_mantle(3,iglob)*nz / rmassz_crust_mantle(iglob)
-
- b_additional_term_x = (rmass_ocean_load(iglob) - rmassx_crust_mantle(iglob)) * b_force_normal_comp
- b_additional_term_y = (rmass_ocean_load(iglob) - rmassy_crust_mantle(iglob)) * b_force_normal_comp
- b_additional_term_z = (rmass_ocean_load(iglob) - rmassz_crust_mantle(iglob)) * b_force_normal_comp
-
- b_accel_crust_mantle(1,iglob) = b_accel_crust_mantle(1,iglob) + b_additional_term_x * nx
- b_accel_crust_mantle(2,iglob) = b_accel_crust_mantle(2,iglob) + b_additional_term_y * ny
- b_accel_crust_mantle(3,iglob) = b_accel_crust_mantle(3,iglob) + b_additional_term_z * nz
- endif
-
! done with this point
updated_dof_ocean_load(iglob) = .true.
@@ -591,18 +501,6 @@
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
- if (SIMULATION_TYPE == 3) then
- b_force_normal_comp = (b_accel_crust_mantle(1,iglob)*nx + &
- b_accel_crust_mantle(2,iglob)*ny + &
- b_accel_crust_mantle(3,iglob)*nz) / rmassz_crust_mantle(iglob)
-
- b_additional_term = (rmass_ocean_load(iglob) - rmassz_crust_mantle(iglob)) * b_force_normal_comp
-
- b_accel_crust_mantle(1,iglob) = b_accel_crust_mantle(1,iglob) + b_additional_term * nx
- b_accel_crust_mantle(2,iglob) = b_accel_crust_mantle(2,iglob) + b_additional_term * ny
- b_accel_crust_mantle(3,iglob) = b_accel_crust_mantle(3,iglob) + b_additional_term * nz
- endif
-
! done with this point
updated_dof_ocean_load(iglob) = .true.
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_element.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_element.F90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_element.F90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -32,10 +32,10 @@
wgll_cube, &
kappavstore,muvstore, &
ibool, &
- R_memory,epsilon_trace_over_3, &
+ R_memory, &
one_minus_sum_beta,vx,vy,vz,vnspec, &
tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
- dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H)
+ dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
@@ -66,13 +66,11 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
kappavstore,muvstore
-
! 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,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilon_trace_over_3
integer :: vx,vy,vz,vnspec
real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
@@ -110,11 +108,12 @@
double precision factor,sx_l,sy_l,sz_l,gxl,gyl,gzl
double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
- integer :: ispec_strain
integer :: i,j,k
integer :: int_radius
integer :: iglob1
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY
+
! isotropic element
do k=1,NGLLZ
@@ -159,15 +158,6 @@
! compute deviatoric strain
if (COMPUTE_AND_STORE_STRAIN) then
templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
- ispec_strain = 1
-!$OMP CRITICAL
- epsilon_trace_over_3(i,j,k,ispec_strain) = templ
-!$OMP END CRITICAL
- else
- ispec_strain = ispec
- epsilon_trace_over_3(i,j,k,ispec_strain) = templ
- endif
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
@@ -348,9 +338,6 @@
!--------------------------------------------------------------------------------------------------
!
-
-
-
subroutine compute_element_tiso(ispec, &
minus_gravity_table,density_table,minus_deriv_gravity_table, &
xstore,ystore,zstore, &
@@ -358,10 +345,10 @@
wgll_cube, &
kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
ibool, &
- R_memory,epsilon_trace_over_3, &
+ R_memory, &
one_minus_sum_beta,vx,vy,vz,vnspec, &
tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
- dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H)
+ dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
@@ -394,20 +381,17 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
kappavstore,muvstore
-
! 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,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilon_trace_over_3
integer vx,vy,vz,vnspec
! [alpha,beta,gamma]val reduced to N_SLS to N_SLS*NUM_NODES
real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
-
! gravity
double precision, dimension(NRAD_GRAVITY) :: minus_gravity_table,density_table,minus_deriv_gravity_table
@@ -418,7 +402,6 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
-
! local parameters
real(kind=CUSTOM_REAL) one_minus_sum_beta_use
! the 21 coefficients for an anisotropic medium in reduced notation
@@ -454,11 +437,12 @@
double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
- integer :: ispec_strain
integer :: i,j,k
integer :: int_radius
integer :: iglob1
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY
+
! transverse isotropic element
do k=1,NGLLZ
@@ -503,15 +487,6 @@
! compute deviatoric strain
if (COMPUTE_AND_STORE_STRAIN) then
templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
- ispec_strain = 1
-!$OMP CRITICAL
- epsilon_trace_over_3(i,j,k,ispec_strain) = templ
-!$OMP END CRITICAL
- else
- ispec_strain = ispec
- epsilon_trace_over_3(i,j,k,ispec_strain) = templ
- endif
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
@@ -885,7 +860,6 @@
!--------------------------------------------------------------------------------------------
!
-
subroutine compute_element_aniso(ispec, &
minus_gravity_table,density_table,minus_deriv_gravity_table, &
xstore,ystore,zstore, &
@@ -895,12 +869,11 @@
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
ibool, &
- R_memory,epsilon_trace_over_3, &
+ R_memory, &
one_minus_sum_beta,vx,vy,vz,vnspec, &
tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
- dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H)
+ dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
-
! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
implicit none
@@ -937,7 +910,6 @@
! 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,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilon_trace_over_3
integer vx,vy,vz,vnspec
@@ -978,11 +950,12 @@
double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
- integer :: ispec_strain
integer :: i,j,k
integer :: int_radius
integer :: iglob1
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY
+
! anisotropic elements
do k=1,NGLLZ
@@ -1027,15 +1000,6 @@
! compute deviatoric strain
if (COMPUTE_AND_STORE_STRAIN) then
templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
- ispec_strain = 1
-!$OMP CRITICAL
- epsilon_trace_over_3(i,j,k,ispec_strain) = templ
-!$OMP END CRITICAL
- else
- ispec_strain = ispec
- epsilon_trace_over_3(i,j,k,ispec_strain) = templ
- endif
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
@@ -1293,7 +1257,7 @@
vx,vy,vz,vnspec,factor_common, &
alphaval,betaval,gammaval, &
c44store,muvstore, &
- epsilondev,epsilondev_loc)
+ epsilondev_loc_nplus1,epsilondev_loc)
! crust mantle
! update memory variables based upon the Runge-Kutta scheme
@@ -1331,7 +1295,7 @@
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(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_nplus1
real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
! local parameters
@@ -1359,7 +1323,7 @@
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,:,:,:))
+ * (betaval(i_SLS) * epsilondev_loc(i_memory,:,:,:) + gammaval(i_SLS) * epsilondev_loc_nplus1(i_memory,:,:,:))
enddo
enddo ! i_SLS
@@ -1373,7 +1337,7 @@
vx,vy,vz,vnspec,factor_common, &
alphaval,betaval,gammaval, &
muvstore, &
- epsilondev,epsilondev_loc)
+ epsilondev_loc_nplus1,epsilondev_loc)
! inner core
! update memory variables based upon the Runge-Kutta scheme
@@ -1410,8 +1374,8 @@
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(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_nplus1
! local parameters
real(kind=CUSTOM_REAL), dimension(NGLLX, NGLLY, NGLLZ) :: factor_common_use
@@ -1431,9 +1395,660 @@
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,:,:,:))
+ (betaval(i_SLS) * epsilondev_loc_nplus1(i_memory,:,:,:) + gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
enddo
enddo
end subroutine compute_element_att_memory_ic
+
+!
+!--------------------------------------------------------------------------------------------
+!
+ 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,epsilondev_loc,eps_trace_over_3_loc)
+
+ implicit none
+ include "constants.h"
+
+ integer :: ispec,nglob,nspec
+ real(kind=CUSTOM_REAL), dimension(NDIM,nglob) :: displ
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT
+ 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
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: eps_trace_over_3_loc
+
+! local variable
+ integer :: i,j,k,iglob
+ 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
+ real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
+ equivalence(dummyx_loc,B1_m1_m2_5points)
+ equivalence(dummyy_loc,B2_m1_m2_5points)
+ equivalence(dummyz_loc,B3_m1_m2_5points)
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
+ equivalence(tempx1,C1_m1_m2_5points)
+ equivalence(tempy1,C2_m1_m2_5points)
+ equivalence(tempz1,C3_m1_m2_5points)
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
+ equivalence(tempx3,C1_mxm_m2_m1_5points)
+ equivalence(tempy3,C2_mxm_m2_m1_5points)
+ equivalence(tempz3,C3_mxm_m2_m1_5points)
+ real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: &
+ A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
+ equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
+ equivalence(dummyy_loc,A2_mxm_m2_m1_5points)
+ equivalence(dummyz_loc,A3_mxm_m2_m1_5points)
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duydyl,duzdzl,duxdyl,duydxl,duzdxl,duxdzl,duzdyl,duydzl,&
+ duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl,&
+ 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)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+ enddo
+ enddo
+ enddo
+
+ do j=1,m2
+ do i=1,m1
+ C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B1_m1_m2_5points(5,j)
+
+ C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B2_m1_m2_5points(5,j)
+
+ C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B3_m1_m2_5points(5,j)
+ enddo
+ enddo
+
+ do j=1,m1
+ do i=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyx_loc(i,5,k)*hprime_xxT(5,j)
+
+ tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyy_loc(i,5,k)*hprime_xxT(5,j)
+
+ tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ enddo
+ enddo
+ enddo
+
+ do j=1,m1
+ do i=1,m2
+ C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+
+ C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+
+ C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! 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*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
+ duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
+ duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
+
+ duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
+ duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
+ duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
+
+ duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
+ duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
+ duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
+
+ ! 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
+
+ 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)
+ 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
+
+ enddo
+ enddo
+ enddo
+
+
+ end subroutine compute_element_strain_undo_att_Dev
+
+!
+!--------------------------------------------------------------------------------------------
+!
+ subroutine compute_element_strain_att_Dev(ispec,nglob,nspec,displ,veloc,deltat,ibool,hprime_xx,hprime_xxT,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,epsilondev_loc_nplus1)
+
+ implicit none
+ include "constants.h"
+
+ 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
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT
+ 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
+
+! 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
+ real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
+ equivalence(dummyx_loc,B1_m1_m2_5points)
+ equivalence(dummyy_loc,B2_m1_m2_5points)
+ equivalence(dummyz_loc,B3_m1_m2_5points)
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
+ equivalence(tempx1,C1_m1_m2_5points)
+ equivalence(tempy1,C2_m1_m2_5points)
+ equivalence(tempz1,C3_m1_m2_5points)
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
+ equivalence(tempx3,C1_mxm_m2_m1_5points)
+ equivalence(tempy3,C2_mxm_m2_m1_5points)
+ equivalence(tempz3,C3_mxm_m2_m1_5points)
+ real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: &
+ A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
+ equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
+ equivalence(dummyy_loc,A2_mxm_m2_m1_5points)
+ equivalence(dummyz_loc,A3_mxm_m2_m1_5points)
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duydyl,duzdzl,duxdyl,duydxl,duzdxl,duxdzl,duzdyl,duydzl,&
+ duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl,&
+ 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 j=1,m2
+ do i=1,m1
+ C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B1_m1_m2_5points(5,j)
+
+ C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B2_m1_m2_5points(5,j)
+
+ C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B3_m1_m2_5points(5,j)
+ enddo
+ enddo
+
+ do j=1,m1
+ do i=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyx_loc(i,5,k)*hprime_xxT(5,j)
+
+ tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyy_loc(i,5,k)*hprime_xxT(5,j)
+
+ tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ enddo
+ enddo
+ enddo
+
+ do j=1,m1
+ do i=1,m2
+ C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+
+ C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+
+ C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! 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*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
+ duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
+ duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
+
+ duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
+ duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
+ duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
+
+ duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
+ duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
+ duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
+
+ ! 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)
+ 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 * duxdyl_plus_duydxl
+ epsilondev_loc_nplus1(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_loc_nplus1(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
+
+ enddo
+ enddo
+ enddo
+
+
+
+ end subroutine compute_element_strain_att_Dev
+!=====================================================================
+
+ subroutine compute_element_strain_undo_att_noDev(ispec,nglob,nspec,displ,hprime_xx,hprime_yy,hprime_zz,ibool,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,epsilondev_loc,eps_trace_over_3_loc)
+
+ implicit none
+
+ include "constants.h"
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer ispec,NSPEC,NGLOB
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: displ
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: eps_trace_over_3_loc
+
+!local parameters
+ integer iglob
+ integer i,j,k,l
+
+ 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) 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
+
+ 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)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + displ(1,iglob)*hp1
+ tempy1l = tempy1l + displ(2,iglob)*hp1
+ tempz1l = tempz1l + displ(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(1,iglob)*hp2
+ tempy2l = tempy2l + displ(2,iglob)*hp2
+ tempz2l = tempz2l + displ(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(1,iglob)*hp3
+ tempy3l = tempy3l + displ(2,iglob)*hp3
+ tempz3l = tempz3l + displ(3,iglob)*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
+
+! compute deviatoric strain
+
+ 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)
+ 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
+
+ enddo ! NGLLX
+ enddo ! NGLLY
+ enddo ! NGLLZ
+
+ end subroutine compute_element_strain_undo_att_noDev
+!=====================================================================
+
+ subroutine compute_element_strain_att_noDev(ispec,nglob,nspec,displ,veloc,deltat,hprime_xx,hprime_yy,hprime_zz,ibool,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,epsilondev_loc_nplus1)
+
+ implicit none
+
+ include "constants.h"
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer ispec,NSPEC,NGLOB
+ real(kind=CUSTOM_REAL) deltat
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: displ,veloc
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_nplus1
+
+!local parameters
+ integer iglob
+ integer i,j,k,l
+ 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) 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
+
+ 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)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + (displ(1,iglob) + deltat * veloc(1,iglob))*hp1
+ tempy1l = tempy1l + (displ(2,iglob) + deltat * veloc(2,iglob))*hp1
+ tempz1l = tempz1l + (displ(3,iglob) + deltat * veloc(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(1,iglob) + deltat * veloc(1,iglob))*hp2
+ tempy2l = tempy2l + (displ(2,iglob) + deltat * veloc(2,iglob))*hp2
+ tempz2l = tempz2l + (displ(3,iglob) + deltat * veloc(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(1,iglob) + deltat * veloc(1,iglob))*hp3
+ tempy3l = tempy3l + (displ(2,iglob) + deltat * veloc(2,iglob))*hp3
+ tempz3l = tempz3l + (displ(3,iglob) + deltat * veloc(3,iglob))*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
+
+! compute deviatoric strain
+
+ templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ 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 * duxdyl_plus_duydxl
+ epsilondev_loc_nplus1(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_loc_nplus1(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
+
+ enddo ! NGLLX
+ enddo ! NGLLY
+ enddo ! NGLLZ
+
+ end subroutine compute_element_strain_att_noDev
+
+
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -52,8 +52,8 @@
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
ibool,ispec_is_tiso, &
- R_memory,epsilondev,epsilon_trace_over_3,one_minus_sum_beta, &
- alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec)
+ R_memory,one_minus_sum_beta,deltat,veloc_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec,PARTIAL_PHYS_DISPERSION_ONLY)
! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
@@ -66,7 +66,8 @@
include "OUTPUT_FILES/values_from_mesher.h"
! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle,accel_crust_mantle
+ real(kind=CUSTOM_REAL) deltat
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle,accel_crust_mantle,veloc_crust_mantle
! arrays with mesh parameters per slice
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool
@@ -101,8 +102,7 @@
! 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,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilon_trace_over_3
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY
integer :: vx,vy,vz,vnspec
@@ -158,6 +158,7 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_nplus1
real(kind=CUSTOM_REAL) fac1,fac2,fac3
! for gravity
@@ -411,10 +412,10 @@
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
ibool, &
- R_memory,epsilon_trace_over_3, &
+ R_memory, &
one_minus_sum_beta,vx,vy,vz,vnspec, &
tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
- dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H)
+ dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
else
if( .not. ispec_is_tiso(ispec) ) then
! isotropic element
@@ -425,10 +426,10 @@
wgll_cube, &
kappavstore,muvstore, &
ibool, &
- R_memory,epsilon_trace_over_3, &
+ R_memory, &
one_minus_sum_beta,vx,vy,vz,vnspec, &
tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
- dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H)
+ dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
else
! transverse isotropic element
call compute_element_tiso(ispec, &
@@ -438,10 +439,10 @@
wgll_cube, &
kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
ibool, &
- R_memory,epsilon_trace_over_3, &
+ R_memory, &
one_minus_sum_beta,vx,vy,vz,vnspec, &
tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
- dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H)
+ dummyx_loc,dummyy_loc,dummyz_loc,epsilondev_loc,rho_s_H,PARTIAL_PHYS_DISPERSION_ONLY)
endif ! .not. ispec_is_tiso
endif
@@ -562,19 +563,18 @@
if(ATTENUATION_VAL .and. ( PARTIAL_PHYS_DISPERSION_ONLY .eqv. .false. ) ) then
+ call compute_element_strain_att_Dev(ispec,NGLOB_CRUST_MANTLE,NSPEC_CRUST_MANTLE,displ_crust_mantle,veloc_crust_mantle,&
+ deltat,ibool,hprime_xx,hprime_xxT,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,epsilondev_loc_nplus1)
! updates R_memory
call compute_element_att_memory_cr(ispec,R_memory, &
vx,vy,vz,vnspec,factor_common, &
alphaval,betaval,gammaval, &
c44store,muvstore, &
- epsilondev,epsilondev_loc)
+ epsilondev_loc_nplus1,epsilondev_loc)
endif
- ! save deviatoric strain for Runge-Kutta scheme
- if(COMPUTE_AND_STORE_STRAIN) then
- epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
- endif
! end ispec loop
enddo
!$OMP enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_noDev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_noDev.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_noDev.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -52,8 +52,8 @@
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
ibool,ispec_is_tiso, &
- R_memory,epsilondev,epsilon_trace_over_3,one_minus_sum_beta, &
- alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec)
+ R_memory,one_minus_sum_beta,deltat,veloc_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec,PARTIAL_PHYS_DISPERSION_ONLY)
implicit none
@@ -88,7 +88,7 @@
logical, dimension(NSPEC_CRUST_MANTLE) :: ispec_is_tiso
! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle,accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle,accel_crust_mantle,veloc_crust_mantle
! memory variables for attenuation
! memory variables R_ij are stored at the local rather than global level
@@ -97,13 +97,13 @@
! variable sized array variables for one_minus_sum_beta and factor_common
integer vx, vy, vz, vnspec
- real(kind=CUSTOM_REAL) one_minus_sum_beta_use,minus_sum_beta
+ real(kind=CUSTOM_REAL) one_minus_sum_beta_use,minus_sum_beta,deltat
real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
! for attenuation
real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY
! [alpha,beta,gamma]val reduced to N_SLS and factor_common to N_SLS*NUM_NODES
real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
@@ -111,7 +111,7 @@
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,NSPEC_CRUST_MANTLE) :: epsilon_trace_over_3
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_nplus1
! arrays with mesh parameters per slice
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool
@@ -147,6 +147,7 @@
integer ispec,iglob,ispec_strain
integer i,j,k,l
+ real(kind=CUSTOM_REAL) templ
! the 21 coefficients for an anisotropic medium in reduced notation
real(kind=CUSTOM_REAL) c11,c22,c33,c44,c55,c66,c12,c13,c23,c14,c24,c34,c15,c25,c35,c45,c16,c26,c36,c46,c56
@@ -380,9 +381,10 @@
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)
+
+ templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ 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
@@ -911,6 +913,10 @@
if(ATTENUATION_VAL .and. ( PARTIAL_PHYS_DISPERSION_ONLY .eqv. .false. )) then
+ call compute_element_strain_att_noDev(ispec,NGLOB_CRUST_MANTLE,NSPEC_CRUST_MANTLE,displ_crust_mantle,veloc_crust_mantle,&
+ deltat,hprime_xx,hprime_yy,hprime_zz,ibool,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,epsilondev_loc_nplus1)
+
! use Runge-Kutta scheme to march in time
do i_SLS = 1,N_SLS
do i_memory = 1,5
@@ -930,24 +936,26 @@
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,:,:,:))
+!ZN (betaval(i_SLS) * epsilondev(i_memory,:,:,:,ispec) + &
+!ZN gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
+ (betaval(i_SLS) * epsilondev_loc(i_memory,:,:,:) + &
+ gammaval(i_SLS) * epsilondev_loc_nplus1(i_memory,:,:,:))
enddo
enddo
endif
! save deviatoric strain for Runge-Kutta scheme
- if(COMPUTE_AND_STORE_STRAIN) then
- !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- epsilondev(:,i,j,k,ispec) = epsilondev_loc(:,i,j,k)
- enddo
- enddo
- enddo
- endif
+!ZN if(COMPUTE_AND_STORE_STRAIN) then
+!ZN !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
+!ZN do k=1,NGLLZ
+!ZN do j=1,NGLLY
+!ZN do i=1,NGLLX
+!ZN epsilondev(:,i,j,k,ispec) = epsilondev_loc(:,i,j,k)
+!ZN enddo
+!ZN enddo
+!ZN enddo
+!ZN endif
enddo ! spectral element loop NSPEC_CRUST_MANTLE
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -47,9 +47,9 @@
hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
kappavstore,muvstore,ibool,idoubling, &
- c11store,c33store,c12store,c13store,c44store,R_memory,epsilondev,epsilon_trace_over_3,&
- one_minus_sum_beta,alphaval,betaval,gammaval,factor_common, &
- vx,vy,vz,vnspec)
+ c11store,c33store,c12store,c13store,c44store,R_memory,one_minus_sum_beta,deltat,veloc_inner_core,&
+ alphaval,betaval,gammaval,factor_common, &
+ vx,vy,vz,vnspec,PARTIAL_PHYS_DISPERSION_ONLY)
! this routine is optimized for NGLLX = NGLLY = NGLLZ = 5 using the Deville et al. (2002) inlined matrix-matrix products
@@ -57,12 +57,14 @@
include "constants.h"
+ real(kind=CUSTOM_REAL) deltat
+
! include values created by the mesher
! done for performance only using static allocation to allow for loop unrolling
include "OUTPUT_FILES/values_from_mesher.h"
! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ_inner_core,accel_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ_inner_core,accel_inner_core,veloc_inner_core
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool
real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: xstore,ystore,zstore
@@ -82,8 +84,7 @@
real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilon_trace_over_3
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY
! array with derivatives of Lagrange polynomials and precalculated products
double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
@@ -143,6 +144,7 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_nplus1
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
@@ -152,7 +154,7 @@
real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
- real(kind=CUSTOM_REAL) fac1,fac2,fac3,templ
+ real(kind=CUSTOM_REAL) fac1,fac2,fac3
real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
real(kind=CUSTOM_REAL) kappal
@@ -170,7 +172,7 @@
real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
integer :: int_radius
- integer :: ispec,ispec_strain
+ integer :: ispec
integer :: i,j,k
integer :: iglob1
@@ -235,6 +237,8 @@
integer NSPEC2D_BOTTOM_INNER_CORE
integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
+ real(kind=CUSTOM_REAL) templ
+
! ****************************************************
! big loop over all spectral elements in the solid
! ****************************************************
@@ -404,15 +408,8 @@
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
- endif
templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- 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
@@ -747,18 +744,17 @@
! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
if(ATTENUATION_VAL .and. ( PARTIAL_PHYS_DISPERSION_ONLY .eqv. .false. ) ) then
+ call compute_element_strain_att_Dev(ispec,NGLOB_INNER_CORE,NSPEC_INNER_CORE,displ_inner_core,&
+ veloc_inner_core,deltat,ibool,hprime_xx,hprime_xxT,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,epsilondev_loc_nplus1)
! updates R_memory
call compute_element_att_memory_ic(ispec,R_memory, &
vx,vy,vz,vnspec,factor_common, &
alphaval,betaval,gammaval, &
muvstore, &
- epsilondev,epsilondev_loc)
+ epsilondev_loc_nplus1,epsilondev_loc)
- endif
- ! save deviatoric strain for Runge-Kutta scheme
- if(COMPUTE_AND_STORE_STRAIN) then
- epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
endif
endif ! end test to exclude fictitious elements in central cube
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_noDev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_noDev.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_noDev.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -48,9 +48,9 @@
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
kappavstore,muvstore,ibool,idoubling, &
- c11store,c33store,c12store,c13store,c44store,R_memory,epsilondev,epsilon_trace_over_3,&
- one_minus_sum_beta,alphaval,betaval,gammaval,factor_common, &
- vx,vy,vz,vnspec)
+ c11store,c33store,c12store,c13store,c44store,R_memory,one_minus_sum_beta,deltat,veloc_inner_core,&
+ alphaval,betaval,gammaval,factor_common, &
+ vx,vy,vz,vnspec,PARTIAL_PHYS_DISPERSION_ONLY)
implicit none
@@ -60,8 +60,10 @@
! done for performance only using static allocation to allow for loop unrolling
include "OUTPUT_FILES/values_from_mesher.h"
+ real(kind=CUSTOM_REAL) deltat
+
! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ_inner_core,accel_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ_inner_core,accel_inner_core,veloc_inner_core
! for attenuation
! memory variables R_ij are stored at the local rather than global level
@@ -79,9 +81,8 @@
real(kind=CUSTOM_REAL), dimension(NGLLX, NGLLY, NGLLZ) :: factor_common_use
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilon_trace_over_3
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc,epsilondev_loc_nplus1
+ logical :: PARTIAL_PHYS_DISPERSION_ONLY
! array with the local to global mapping per slice
integer, dimension(NSPEC_INNER_CORE) :: idoubling
@@ -207,6 +208,7 @@
! local to global mapping
integer NSPEC2D_BOTTOM_INNER_CORE
integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
+ real(kind=CUSTOM_REAL) templ
! ****************************************************
! big loop over all spectral elements in the solid
@@ -337,9 +339,9 @@
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)
+ templ = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ 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
@@ -644,6 +646,10 @@
if(ATTENUATION_VAL .and. ( PARTIAL_PHYS_DISPERSION_ONLY .eqv. .false. )) then
+ call compute_element_strain_att_noDev(ispec,NGLOB_INNER_CORE,NSPEC_INNER_CORE,displ_inner_core,&
+ veloc_inner_core,deltat,hprime_xx,hprime_yy,hprime_zz,ibool,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,epsilondev_loc_nplus1)
+
do i_SLS = 1,N_SLS
factor_common_use = factor_common(i_SLS,:,:,:,ispec)
do i_memory = 1,5
@@ -652,25 +658,12 @@
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,:,:,:))
+ epsilondev_loc_nplus1(i_memory,:,:,:) + gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
enddo
enddo
endif
- if (COMPUTE_AND_STORE_STRAIN) then
-! save deviatoric strain for Runge-Kutta scheme
- !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- epsilondev(:,i,j,k,ispec) = epsilondev_loc(:,i,j,k)
- enddo
- enddo
- enddo
-
- endif
-
endif ! end test to exclude fictitious elements in central cube
enddo ! spectral element loop
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_kernels.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_kernels.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -30,9 +30,8 @@
rho_kl_crust_mantle,beta_kl_crust_mantle, &
alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
accel_crust_mantle,b_displ_crust_mantle, &
- epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
- deltat)
+ deltat,displ_crust_mantle,hprime_xx,hprime_xxT,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
implicit none
@@ -49,30 +48,38 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- accel_crust_mantle
+ accel_crust_mantle,displ_crust_mantle
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
b_displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- b_epsilondev_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
- eps_trace_over_3_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- b_eps_trace_over_3_crust_mantle
-
real(kind=CUSTOM_REAL) deltat
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
! local parameters
real(kind=CUSTOM_REAL),dimension(21) :: prod !, cijkl_kl_local
real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_matrix,b_epsilondev_loc_matrix
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: eps_trace_over_3_loc_matrix,&
+ b_eps_trace_over_3_loc_matrix
integer :: i,j,k,ispec,iglob
! crust_mantle
do ispec = 1, NSPEC_CRUST_MANTLE
+
+ call compute_element_strain_undo_att_Dev(ispec,NGLOB_CRUST_MANTLE,NSPEC_CRUST_MANTLE,&
+ displ_CRUST_MANTLE,ibool_crust_mantle,hprime_xx,hprime_xxT,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,&
+ epsilondev_loc_matrix,eps_trace_over_3_loc_matrix)
+
+ call compute_element_strain_undo_att_Dev(ispec,NGLOB_CRUST_MANTLE,NSPEC_CRUST_MANTLE,&
+ b_displ_CRUST_MANTLE,ibool_crust_mantle,hprime_xx,hprime_xxT,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,&
+ b_epsilondev_loc_matrix,b_eps_trace_over_3_loc_matrix)
+
+
do k = 1, NGLLZ
do j = 1, NGLLY
do i = 1, NGLLX
@@ -95,14 +102,14 @@
+ accel_crust_mantle(2,iglob) * b_displ_crust_mantle(2,iglob) &
+ accel_crust_mantle(3,iglob) * b_displ_crust_mantle(3,iglob) )
- epsilondev_loc(:) = epsilondev_crust_mantle(:,i,j,k,ispec)
- b_epsilondev_loc(:) = b_epsilondev_crust_mantle(:,i,j,k,ispec)
+ epsilondev_loc(:) = epsilondev_loc_matrix(:,i,j,k)
+ b_epsilondev_loc(:) = b_epsilondev_loc_matrix(:,i,j,k)
! For anisotropic kernels
if (ANISOTROPIC_KL) then
- call compute_strain_product(prod,eps_trace_over_3_crust_mantle(i,j,k,ispec),epsilondev_loc, &
- b_eps_trace_over_3_crust_mantle(i,j,k,ispec),b_epsilondev_loc)
+ call compute_strain_product(prod,eps_trace_over_3_loc_matrix(i,j,k),epsilondev_loc, &
+ b_eps_trace_over_3_loc_matrix(i,j,k),b_epsilondev_loc)
cijkl_kl_crust_mantle(:,i,j,k,ispec) = cijkl_kl_crust_mantle(:,i,j,k,ispec) + deltat * prod(:)
else
@@ -119,8 +126,8 @@
! kernel for bulk modulus, see e.g. Tromp et al. (2005), equation (18)
! note: multiplication with kappa(x) will be done after the time loop
alpha_kl_crust_mantle(i,j,k,ispec) = alpha_kl_crust_mantle(i,j,k,ispec) &
- + deltat * (9 * eps_trace_over_3_crust_mantle(i,j,k,ispec) &
- * b_eps_trace_over_3_crust_mantle(i,j,k,ispec))
+ + deltat * (9 * eps_trace_over_3_loc_matrix(i,j,k) &
+ * b_eps_trace_over_3_loc_matrix(i,j,k))
endif
@@ -446,9 +453,8 @@
rho_kl_inner_core,beta_kl_inner_core, &
alpha_kl_inner_core, &
accel_inner_core,b_displ_inner_core, &
- epsilondev_inner_core,b_epsilondev_inner_core, &
- eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
- deltat)
+ deltat,displ_inner_core,hprime_xx,hprime_xxT,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
implicit none
@@ -462,31 +468,38 @@
rho_kl_inner_core, beta_kl_inner_core, alpha_kl_inner_core
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
- accel_inner_core
+ accel_inner_core,displ_inner_core
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
b_displ_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: &
- epsilondev_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- b_epsilondev_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STRAIN_ONLY) :: &
- eps_trace_over_3_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- b_eps_trace_over_3_inner_core
-
real(kind=CUSTOM_REAL) deltat
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
! local parameters
real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_matrix,b_epsilondev_loc_matrix
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: eps_trace_over_3_loc_matrix,&
+ b_eps_trace_over_3_loc_matrix
integer :: i,j,k,ispec,iglob
! inner_core
do ispec = 1, NSPEC_INNER_CORE
+
+ call compute_element_strain_undo_att_Dev(ispec,NGLOB_inner_core,NSPEC_inner_core,&
+ displ_inner_core,ibool_inner_core,hprime_xx,hprime_xxT,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,&
+ epsilondev_loc_matrix,eps_trace_over_3_loc_matrix)
+
+ call compute_element_strain_undo_att_Dev(ispec,NGLOB_inner_core,NSPEC_inner_core,&
+ b_displ_inner_core,ibool_inner_core,hprime_xx,hprime_xxT,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,&
+ b_epsilondev_loc_matrix,b_eps_trace_over_3_loc_matrix)
+
do k = 1, NGLLZ
do j = 1, NGLLY
do i = 1, NGLLX
@@ -497,8 +510,9 @@
+ accel_inner_core(2,iglob) * b_displ_inner_core(2,iglob) &
+ accel_inner_core(3,iglob) * b_displ_inner_core(3,iglob) )
- epsilondev_loc(:) = epsilondev_inner_core(:,i,j,k,ispec)
- b_epsilondev_loc(:) = b_epsilondev_inner_core(:,i,j,k,ispec)
+ epsilondev_loc(:) = epsilondev_loc_matrix(:,i,j,k)
+ b_epsilondev_loc(:) = b_epsilondev_loc_matrix(:,i,j,k)
+
beta_kl_inner_core(i,j,k,ispec) = beta_kl_inner_core(i,j,k,ispec) &
+ deltat * (epsilondev_loc(1)*b_epsilondev_loc(1) + epsilondev_loc(2)*b_epsilondev_loc(2) &
+ (epsilondev_loc(1)+epsilondev_loc(2)) * (b_epsilondev_loc(1)+b_epsilondev_loc(2)) &
@@ -506,7 +520,7 @@
+ epsilondev_loc(5)*b_epsilondev_loc(5)) )
alpha_kl_inner_core(i,j,k,ispec) = alpha_kl_inner_core(i,j,k,ispec) &
- + deltat * (9 * eps_trace_over_3_inner_core(i,j,k,ispec) * b_eps_trace_over_3_inner_core(i,j,k,ispec))
+ + deltat * (9 * eps_trace_over_3_loc_matrix(i,j,k) * b_eps_trace_over_3_loc_matrix(i,j,k))
enddo
enddo
enddo
@@ -1002,6 +1016,3 @@
end subroutine compute_kernels_hessian
-
-
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_seismograms.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_seismograms.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -191,7 +191,6 @@
!
subroutine compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
hxir_store,hetar_store,hgammar_store, &
hpxir_store,hpetar_store,hpgammar_store, &
@@ -213,10 +212,6 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
- eps_trace_over_3_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_crust_mantle
double precision, dimension(NDIM,NDIM,NSOURCES) :: nu_source
double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
@@ -266,6 +261,9 @@
double precision, external :: comp_source_time_function
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: eps_trace_over_3_loc_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_crust_mantle
+
do irec_local = 1,nrec_local
! get global number of that receiver
@@ -284,6 +282,13 @@
dxz = ZERO
dyz = ZERO
+ call compute_element_strain_undo_att_noDev(ispec_selected_source(irec),NGLOB_CRUST_MANTLE,NSPEC_CRUST_MANTLE,&
+ displ_crust_mantle,hprime_xx,hprime_yy,hprime_zz,ibool_crust_mantle,&
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,&
+ epsilondev_loc_crust_mantle,eps_trace_over_3_loc_crust_mantle)
+
do k = 1,NGLLZ
do j = 1,NGLLY
do i = 1,NGLLX
@@ -296,12 +301,12 @@
uyd = uyd + dble(displ_crust_mantle(2,iglob))*hlagrange
uzd = uzd + dble(displ_crust_mantle(3,iglob))*hlagrange
- eps_trace = eps_trace + dble(eps_trace_over_3_crust_mantle(i,j,k,ispec_selected_source(irec)))*hlagrange
- dxx = dxx + dble(epsilondev_crust_mantle(1,i,j,k,ispec_selected_source(irec)))*hlagrange
- dyy = dyy + dble(epsilondev_crust_mantle(2,i,j,k,ispec_selected_source(irec)))*hlagrange
- dxy = dxy + dble(epsilondev_crust_mantle(3,i,j,k,ispec_selected_source(irec)))*hlagrange
- dxz = dxz + dble(epsilondev_crust_mantle(4,i,j,k,ispec_selected_source(irec)))*hlagrange
- dyz = dyz + dble(epsilondev_crust_mantle(5,i,j,k,ispec_selected_source(irec)))*hlagrange
+ eps_trace = eps_trace + dble(eps_trace_over_3_loc_crust_mantle(i,j,k))*hlagrange
+ dxx = dxx + dble(epsilondev_loc_crust_mantle(1,i,j,k))*hlagrange
+ dyy = dyy + dble(epsilondev_loc_crust_mantle(2,i,j,k))*hlagrange
+ dxy = dxy + dble(epsilondev_loc_crust_mantle(3,i,j,k))*hlagrange
+ dxz = dxz + dble(epsilondev_loc_crust_mantle(4,i,j,k))*hlagrange
+ dyz = dyz + dble(epsilondev_loc_crust_mantle(5,i,j,k))*hlagrange
displ_s(:,i,j,k) = displ_crust_mantle(:,iglob)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_stacey_crust_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_stacey_crust_mantle.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_stacey_crust_mantle.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -25,9 +25,9 @@
!
!=====================================================================
- subroutine compute_stacey_crust_mantle(ichunk,SIMULATION_TYPE, &
- NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
- veloc_crust_mantle,accel_crust_mantle,b_accel_crust_mantle, &
+ subroutine compute_stacey_crust_mantle_forward(ichunk, &
+ it,SAVE_FORWARD,ibool_crust_mantle, &
+ veloc_crust_mantle,accel_crust_mantle, &
jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
wgllwgll_xz,wgllwgll_yz, &
@@ -47,21 +47,20 @@
absorb_xmin_crust_mantle,absorb_xmax_crust_mantle, &
absorb_ymin_crust_mantle,absorb_ymax_crust_mantle)
+
implicit none
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
- integer ichunk,SIMULATION_TYPE
- integer NSTEP,it
+ integer ichunk
+ integer it
logical SAVE_FORWARD
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
veloc_crust_mantle,accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
- b_accel_crust_mantle
real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
@@ -121,13 +120,6 @@
! if two chunks exclude this face for one of them
if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
- ! reads absorbing boundary values
- if (SIMULATION_TYPE == 3 .and. nspec2D_xmin_crust_mantle > 0) then
- ! note: backward/reconstructed wavefields are read in after the Newmark time scheme in the first time loop
- ! this leads to a corresponding boundary condition at time index NSTEP - (it-1) = NSTEP - it + 1
- call read_abs(0,absorb_xmin_crust_mantle,reclen_xmin_crust_mantle,NSTEP-it+1)
- endif
-
do ispec2D=1,nspec2D_xmin_crust_mantle
ispec=ibelm_xmin_crust_mantle(ispec2D)
@@ -160,32 +152,26 @@
accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
- if (SIMULATION_TYPE == 3) then
- b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_xmin_crust_mantle(:,j,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ if (SAVE_FORWARD) then
absorb_xmin_crust_mantle(1,j,k,ispec2D) = tx*weight
absorb_xmin_crust_mantle(2,j,k,ispec2D) = ty*weight
absorb_xmin_crust_mantle(3,j,k,ispec2D) = tz*weight
endif
+
enddo
enddo
enddo
! writes absorbing boundary values
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmin_crust_mantle > 0 ) then
+ if (SAVE_FORWARD .and. nspec2D_xmin_crust_mantle > 0 ) &
call write_abs(0,absorb_xmin_crust_mantle, reclen_xmin_crust_mantle,it)
- endif
+
endif
! xmax
! if two chunks exclude this face for one of them
if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB) then
- ! reads absorbing boundary values
- if (SIMULATION_TYPE == 3 .and. nspec2D_xmax_crust_mantle > 0) then
- call read_abs(1,absorb_xmax_crust_mantle,reclen_xmax_crust_mantle,NSTEP-it+1)
- endif
-
do ispec2D=1,nspec2D_xmax_crust_mantle
ispec=ibelm_xmax_crust_mantle(ispec2D)
@@ -218,9 +204,7 @@
accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
- if (SIMULATION_TYPE == 3) then
- b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_xmax_crust_mantle(:,j,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ if (SAVE_FORWARD) then
absorb_xmax_crust_mantle(1,j,k,ispec2D) = tx*weight
absorb_xmax_crust_mantle(2,j,k,ispec2D) = ty*weight
absorb_xmax_crust_mantle(3,j,k,ispec2D) = tz*weight
@@ -231,18 +215,13 @@
enddo
! writes absorbing boundary values
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmax_crust_mantle > 0 ) then
+ if (SAVE_FORWARD .and. nspec2D_xmax_crust_mantle > 0 ) &
call write_abs(1,absorb_xmax_crust_mantle,reclen_xmax_crust_mantle,it)
- endif
+
endif
! ymin
- ! reads absorbing boundary values
- if (SIMULATION_TYPE == 3 .and. nspec2D_ymin_crust_mantle > 0) then
- call read_abs(2,absorb_ymin_crust_mantle, reclen_ymin_crust_mantle,NSTEP-it+1)
- endif
-
do ispec2D=1,nspec2D_ymin_crust_mantle
ispec=ibelm_ymin_crust_mantle(ispec2D)
@@ -275,9 +254,7 @@
accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
- if (SIMULATION_TYPE == 3) then
- b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_ymin_crust_mantle(:,i,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ if (SAVE_FORWARD) then
absorb_ymin_crust_mantle(1,i,k,ispec2D) = tx*weight
absorb_ymin_crust_mantle(2,i,k,ispec2D) = ty*weight
absorb_ymin_crust_mantle(3,i,k,ispec2D) = tz*weight
@@ -288,19 +265,12 @@
enddo
! writes absorbing boundary values
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymin_crust_mantle > 0 ) then
+ if (SAVE_FORWARD .and. nspec2D_ymin_crust_mantle > 0 ) &
call write_abs(2,absorb_ymin_crust_mantle,reclen_ymin_crust_mantle,it)
- endif
-
! ymax
- ! reads absorbing boundary values
- if (SIMULATION_TYPE == 3 .and. nspec2D_ymax_crust_mantle > 0) then
- call read_abs(3,absorb_ymax_crust_mantle,reclen_ymax_crust_mantle,NSTEP-it+1)
- endif
-
do ispec2D=1,nspec2D_ymax_crust_mantle
ispec=ibelm_ymax_crust_mantle(ispec2D)
@@ -333,9 +303,7 @@
accel_crust_mantle(2,iglob)=accel_crust_mantle(2,iglob) - ty*weight
accel_crust_mantle(3,iglob)=accel_crust_mantle(3,iglob) - tz*weight
- if (SIMULATION_TYPE == 3) then
- b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_ymax_crust_mantle(:,i,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ if (SAVE_FORWARD) then
absorb_ymax_crust_mantle(1,i,k,ispec2D) = tx*weight
absorb_ymax_crust_mantle(2,i,k,ispec2D) = ty*weight
absorb_ymax_crust_mantle(3,i,k,ispec2D) = tz*weight
@@ -346,9 +314,180 @@
enddo
! writes absorbing boundary values
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymax_crust_mantle > 0 ) then
+ if (SAVE_FORWARD .and. nspec2D_ymax_crust_mantle > 0 ) &
call write_abs(3,absorb_ymax_crust_mantle,reclen_ymax_crust_mantle,it)
+
+ end subroutine compute_stacey_crust_mantle_forward
+
+!=====================================================================
+!=====================================================================
+
+ subroutine compute_stacey_crust_mantle_backward(ichunk, &
+ NSTEP,it,ibool_crust_mantle, &
+ b_accel_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, &
+ reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
+ nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
+ absorb_xmin_crust_mantle,absorb_xmax_crust_mantle, &
+ absorb_ymin_crust_mantle,absorb_ymax_crust_mantle)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer ichunk
+ integer NSTEP,it
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_accel_crust_mantle
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
+
+ integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_CM) :: &
+ nimin_crust_mantle,nimax_crust_mantle,nkmin_eta_crust_mantle
+ integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_CM) :: &
+ njmin_crust_mantle,njmax_crust_mantle,nkmin_xi_crust_mantle
+
+ integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
+
+ integer reclen_xmin_crust_mantle,reclen_xmax_crust_mantle,&
+ reclen_ymin_crust_mantle,reclen_ymax_crust_mantle
+
+ integer nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nabs_xmin_cm) :: absorb_xmin_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nabs_xmax_cm) :: absorb_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nabs_ymin_cm) :: absorb_ymin_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nabs_ymax_cm) :: absorb_ymax_crust_mantle
+
+
+ ! local parameters
+ 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)
+
+
+ ! crust & mantle
+
+ ! xmin
+ ! if two chunks, exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
+
+ ! reads absorbing boundary values
+ if (nspec2D_xmin_crust_mantle > 0) then
+ ! note: backward/reconstructed wavefields are read in after the Newmark time scheme in the first time loop
+ ! this leads to a corresponding boundary condition at time index NSTEP - (it-1) = NSTEP - it + 1
+ call read_abs(0,absorb_xmin_crust_mantle,reclen_xmin_crust_mantle,NSTEP-it+1)
+ endif
+
+ 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)
+ b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_xmin_crust_mantle(:,j,k,ispec2D)
+ enddo
+ enddo
+ enddo
+
endif
- end subroutine compute_stacey_crust_mantle
+ ! xmax
+ ! if two chunks, exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB) then
+ ! reads absorbing boundary values
+ if (nspec2D_xmax_crust_mantle > 0) then
+ call read_abs(1,absorb_xmax_crust_mantle,reclen_xmax_crust_mantle,NSTEP-it+1)
+ endif
+
+ 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)
+ b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_xmax_crust_mantle(:,j,k,ispec2D)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ ! ymin
+
+ ! reads absorbing boundary values
+ if (nspec2D_ymin_crust_mantle > 0) then
+ call read_abs(2,absorb_ymin_crust_mantle, reclen_ymin_crust_mantle,NSTEP-it+1)
+ endif
+
+ 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)
+ b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_ymin_crust_mantle(:,i,k,ispec2D)
+ enddo
+ enddo
+ enddo
+
+ ! ymax
+
+ ! reads absorbing boundary values
+ if (nspec2D_ymax_crust_mantle > 0) then
+ call read_abs(3,absorb_ymax_crust_mantle,reclen_ymax_crust_mantle,NSTEP-it+1)
+ endif
+
+ 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)
+ b_accel_crust_mantle(:,iglob)=b_accel_crust_mantle(:,iglob) - absorb_ymax_crust_mantle(:,i,k,ispec2D)
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_stacey_crust_mantle_backward
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_stacey_outer_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_stacey_outer_core.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_stacey_outer_core.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -25,10 +25,9 @@
!
!=====================================================================
-
- subroutine compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
- NSTEP,it,ibool_outer_core, &
- veloc_outer_core,accel_outer_core,b_accel_outer_core, &
+ subroutine compute_stacey_outer_core_forward(ichunk,SAVE_FORWARD, &
+ it,ibool_outer_core, &
+ veloc_outer_core,accel_outer_core, &
vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
jacobian2D_bottom_outer_core, &
jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
@@ -56,16 +55,14 @@
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
- integer ichunk,SIMULATION_TYPE
- integer NSTEP,it
+ integer ichunk
+ integer it
logical SAVE_FORWARD
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
veloc_outer_core,accel_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
- b_accel_outer_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_STACEY) :: vp_outer_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
@@ -79,7 +76,6 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: &
jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core
-
integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
@@ -120,20 +116,6 @@
! if two chunks exclude this face for one of them
if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
- ! reads absorbing boundary values
- if (SIMULATION_TYPE == 3 .and. nspec2D_xmin_outer_core > 0) then
- ! note: backward/reconstructed wavefields are read in after the Newmark time scheme in the first time loop
- ! this leads to a corresponding boundary condition at time index NSTEP - (it-1) = NSTEP - it + 1
-
- call read_abs(4,absorb_xmin_outer_core,reclen_xmin_outer_core,NSTEP-it+1)
-
-! read(61,rec=NSTEP-it+1) reclen1,absorb_xmin_outer_core,reclen2
-! if (reclen1 /= reclen_xmin_outer_core .or. reclen1 /= reclen2) &
-! call exit_MPI(myrank,'Error reading absorbing contribution absorb_xmin_outer_core')
-
-
- endif
-
do ispec2D=1,nspec2D_xmin_outer_core
ispec=ibelm_xmin_outer_core(ispec2D)
@@ -152,9 +134,7 @@
accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
- if (SIMULATION_TYPE == 3) then
- b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_xmin_outer_core(j,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ if (SAVE_FORWARD) then
absorb_xmin_outer_core(j,k,ispec2D) = weight*sn
endif
enddo
@@ -162,11 +142,8 @@
enddo
! writes absorbing boundary values
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmin_outer_core > 0 ) then
-
+ if (SAVE_FORWARD .and. nspec2D_xmin_outer_core > 0 ) then
call write_abs(4,absorb_xmin_outer_core,reclen_xmin_outer_core,it)
-
-! write(61,rec=it) reclen_xmin_outer_core,absorb_xmin_outer_core,reclen_xmin_outer_core
endif
endif
@@ -175,15 +152,6 @@
! if two chunks exclude this face for one of them
if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB) then
- if (SIMULATION_TYPE == 3 .and. nspec2D_xmax_outer_core > 0) then
-
- call read_abs(5,absorb_xmax_outer_core,reclen_xmax_outer_core,NSTEP-it+1)
-
-! read(62,rec=NSTEP-it+1) reclen1,absorb_xmax_outer_core,reclen2
-! if (reclen1 /= reclen_xmax_outer_core .or. reclen1 /= reclen2) &
-! call exit_MPI(myrank,'Error reading absorbing contribution absorb_xmax_outer_core')
- endif
-
do ispec2D=1,nspec2D_xmax_outer_core
ispec=ibelm_xmax_outer_core(ispec2D)
@@ -202,9 +170,7 @@
accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
- if (SIMULATION_TYPE == 3) then
- b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_xmax_outer_core(j,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ if (SAVE_FORWARD) then
absorb_xmax_outer_core(j,k,ispec2D) = weight*sn
endif
@@ -212,24 +178,14 @@
enddo
enddo
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_xmax_outer_core > 0 ) then
+ if (SAVE_FORWARD .and. nspec2D_xmax_outer_core > 0 ) then
call write_abs(5,absorb_xmax_outer_core,reclen_xmax_outer_core,it)
-
-! write(62,rec=it) reclen_xmax_outer_core,absorb_xmax_outer_core,reclen_xmax_outer_core
endif
endif
! ymin
- if (SIMULATION_TYPE == 3 .and. nspec2D_ymin_outer_core > 0) then
- call read_abs(6,absorb_ymin_outer_core,reclen_ymin_outer_core,NSTEP-it+1)
-
-! read(63,rec=NSTEP-it+1) reclen1,absorb_ymin_outer_core,reclen2
-! if (reclen1 /= reclen_ymin_outer_core .or. reclen1 /= reclen2) &
-! call exit_MPI(myrank,'Error reading absorbing contribution absorb_ymin_outer_core')
- endif
-
do ispec2D=1,nspec2D_ymin_outer_core
ispec=ibelm_ymin_outer_core(ispec2D)
@@ -248,9 +204,7 @@
accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
- if (SIMULATION_TYPE == 3) then
- b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_ymin_outer_core(i,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ if (SAVE_FORWARD) then
absorb_ymin_outer_core(i,k,ispec2D) = weight*sn
endif
@@ -258,21 +212,11 @@
enddo
enddo
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymin_outer_core > 0 ) then
+ if (SAVE_FORWARD .and. nspec2D_ymin_outer_core > 0 ) then
call write_abs(6,absorb_ymin_outer_core,reclen_ymin_outer_core,it)
-
-! write(63,rec=it) reclen_ymin_outer_core,absorb_ymin_outer_core,reclen_ymin_outer_core
endif
! ymax
- if (SIMULATION_TYPE == 3 .and. nspec2D_ymax_outer_core > 0) then
-
- call read_abs(7,absorb_ymax_outer_core,reclen_ymax_outer_core,NSTEP-it+1)
-
-! read(64,rec=NSTEP-it+1) reclen1,absorb_ymax_outer_core,reclen2
-! if (reclen1 /= reclen_ymax_outer_core .or. reclen1 /= reclen2) &
-! call exit_MPI(myrank,'Error reading absorbing contribution absorb_ymax_outer_core')
- endif
do ispec2D=1,nspec2D_ymax_outer_core
ispec=ibelm_ymax_outer_core(ispec2D)
@@ -291,9 +235,7 @@
accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
- if (SIMULATION_TYPE == 3) then
- b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_ymax_outer_core(i,k,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ if (SAVE_FORWARD) then
absorb_ymax_outer_core(i,k,ispec2D) = weight*sn
endif
@@ -301,22 +243,11 @@
enddo
enddo
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymax_outer_core > 0 ) then
+ if (SAVE_FORWARD .and. nspec2D_ymax_outer_core > 0 ) then
call write_abs(7,absorb_ymax_outer_core,reclen_ymax_outer_core,it)
-
-! write(64,rec=it) reclen_ymax_outer_core,absorb_ymax_outer_core,reclen_ymax_outer_core
endif
! for surface elements exactly on the ICB
- if (SIMULATION_TYPE == 3 .and. NSPEC2D_BOTTOM(IREGION_OUTER_CORE)> 0) then
-
- call read_abs(8,absorb_zmin_outer_core,reclen_zmin,NSTEP-it+1)
-
-! read(65,rec=NSTEP-it+1) reclen1,absorb_zmin_outer_core,reclen2
-! if (reclen1 /= reclen_zmin .or. reclen1 /= reclen2) &
-! call exit_MPI(myrank,'Error reading absorbing contribution absorb_zmin_outer_core')
- endif
-
do ispec2D = 1,NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
ispec = ibelm_bottom_outer_core(ispec2D)
@@ -332,9 +263,7 @@
accel_outer_core(iglob) = accel_outer_core(iglob) - weight*sn
- if (SIMULATION_TYPE == 3) then
- b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_zmin_outer_core(i,j,ispec2D)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ if (SAVE_FORWARD) then
absorb_zmin_outer_core(i,j,ispec2D) = weight*sn
endif
@@ -342,10 +271,198 @@
enddo
enddo
- if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 ) then
+ if (SAVE_FORWARD .and. NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 ) then
call write_abs(8,absorb_zmin_outer_core,reclen_zmin,it)
+ endif
-! write(65,rec=it) reclen_zmin,absorb_zmin_outer_core,reclen_zmin
+ end subroutine compute_stacey_outer_core_forward
+
+!=====================================================================
+!=====================================================================
+
+ subroutine compute_stacey_outer_core_backward(ichunk, &
+ NSTEP,it,ibool_outer_core, &
+ b_accel_outer_core, &
+ ibelm_bottom_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
+ ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ nimin_outer_core,nimax_outer_core, &
+ njmin_outer_core,njmax_outer_core, &
+ nkmin_xi_outer_core,nkmin_eta_outer_core, &
+ NSPEC2D_BOTTOM, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ reclen_zmin, &
+ reclen_xmin_outer_core,reclen_xmax_outer_core, &
+ reclen_ymin_outer_core,reclen_ymax_outer_core, &
+ nabs_zmin_oc, &
+ nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
+ absorb_zmin_outer_core, &
+ absorb_xmin_outer_core,absorb_xmax_outer_core, &
+ absorb_ymin_outer_core,absorb_ymax_outer_core)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer ichunk
+ integer NSTEP,it
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
+ b_accel_outer_core
+
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
+
+ integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_OC) :: &
+ nimin_outer_core,nimax_outer_core,nkmin_eta_outer_core
+ integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_OC) :: &
+ njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_BOTTOM
+ integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
+
+ integer reclen_zmin,reclen_xmin_outer_core,reclen_xmax_outer_core,&
+ reclen_ymin_outer_core,reclen_ymax_outer_core
+
+ integer nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc,nabs_zmin_oc
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nabs_xmin_oc) :: absorb_xmin_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nabs_xmax_oc) :: absorb_xmax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nabs_ymin_oc) :: absorb_ymin_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nabs_ymax_oc) :: absorb_ymax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,nabs_zmin_oc) :: absorb_zmin_outer_core
+
+ ! local parameters
+ !integer :: reclen1,reclen2
+ integer :: i,j,k,ispec2D,ispec,iglob
+
+ ! 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)
+
+ ! xmin
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
+
+ ! reads absorbing boundary values
+ if (nspec2D_xmin_outer_core > 0) then
+ ! note: backward/reconstructed wavefields are read in after the Newmark time scheme in the first time loop
+ ! this leads to a corresponding boundary condition at time index NSTEP - (it-1) = NSTEP - it + 1
+ call read_abs(4,absorb_xmin_outer_core,reclen_xmin_outer_core,NSTEP-it+1)
+ endif
+
+ 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)
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_xmin_outer_core(j,k,ispec2D)
+ enddo
+ enddo
+ enddo
+
endif
- end subroutine compute_stacey_outer_core
+ ! xmax
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AB) then
+
+ if (nspec2D_xmax_outer_core > 0) then
+ call read_abs(5,absorb_xmax_outer_core,reclen_xmax_outer_core,NSTEP-it+1)
+ endif
+
+ 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)
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_xmax_outer_core(j,k,ispec2D)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ ! ymin
+ if (nspec2D_ymin_outer_core > 0) then
+ call read_abs(6,absorb_ymin_outer_core,reclen_ymin_outer_core,NSTEP-it+1)
+ endif
+
+ 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)
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_ymin_outer_core(i,k,ispec2D)
+ enddo
+ enddo
+ enddo
+
+ ! ymax
+ if (nspec2D_ymax_outer_core > 0) then
+ call read_abs(7,absorb_ymax_outer_core,reclen_ymax_outer_core,NSTEP-it+1)
+ endif
+
+ 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)
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_ymax_outer_core(i,k,ispec2D)
+ enddo
+ enddo
+ enddo
+
+ ! for surface elements exactly on the ICB
+ if (NSPEC2D_BOTTOM(IREGION_OUTER_CORE)> 0) then
+ call read_abs(8,absorb_zmin_outer_core,reclen_zmin,NSTEP-it+1)
+ endif
+
+ do ispec2D = 1,NSPEC2D_BOTTOM(IREGION_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)
+ b_accel_outer_core(iglob) = b_accel_outer_core(iglob) - absorb_zmin_outer_core(i,j,ispec2D)
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_stacey_outer_core_backward
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/initialize_simulation.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/initialize_simulation.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -25,7 +25,6 @@
!
!=====================================================================
-
subroutine initialize_simulation(myrank,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, &
@@ -55,7 +54,8 @@
hprime_xx,hprime_yy,hprime_zz,hprime_xxT, &
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,hprimewgll_xxT, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- rec_filename,STATIONS,nrec,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL)
+ rec_filename,STATIONS,nrec,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL, &
+ PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
implicit none
@@ -73,19 +73,19 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY,NT_DUMP_ATTENUATION
double precision DT,ROCEAN,RMIDDLE_CRUST, &
RMOHO,R80,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
- logical MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ logical MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT,&
OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
- SAVE_REGULAR_KL
+ SAVE_REGULAR_KL,PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
character(len=150) LOCAL_PATH,OUTPUT_FILES
@@ -134,21 +134,29 @@
! local parameters
integer, dimension(MAX_NUM_REGIONS) :: NSPEC_computed,NGLOB_computed, &
NSPEC2D_XI,NSPEC2D_ETA,NSPEC1D_RADIAL
+
logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+
integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+
integer :: ratio_divide_central_cube
integer :: sizeprocs
integer :: ier,i,j,ios
integer :: NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,NPROC_XI,NPROC_ETA
+
double precision :: RMOHO_FICTITIOUS_IN_MESHER,R120,R_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,&
CENTER_LATITUDE_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,ANGULAR_WIDTH_XI_IN_DEGREES,&
GAMMA_ROTATION_AZIMUTH
+
integer :: REFERENCE_1D_MODEL,THREE_D_MODEL
+
logical :: TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS, &
ATTENUATION,ATTENUATION_3D,ROTATION,ELLIPTICITY,GRAVITY,CASE_3D,ISOTROPIC_3D_MANTLE, &
HETEROGEN_3D_MANTLE,CRUSTAL,INFLATE_CENTRAL_CUBE
+
character(len=150) :: MODEL,dummystring
+
! sizeprocs returns number of processes started (should be equal to NPROCTOT).
! myrank is the rank of each process, between 0 and sizeprocs-1.
! as usual in MPI, process 0 is in charge of coordinating everything
@@ -190,7 +198,8 @@
HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE, &
- USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL)
+ USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL, &
+ PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
endif
@@ -227,7 +236,8 @@
REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL)
+ ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL,&
+ PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
@@ -388,12 +398,17 @@
if (SIMULATION_TYPE /= 1 .and. NSOURCES > 999999) &
call exit_MPI(myrank, 'for adjoint simulations, NSOURCES <= 999999, if you need more change i6.6 in write_seismograms.f90')
+ if(UNDO_ATTENUATION .and. PARTIAL_PHYS_DISPERSION_ONLY) &
+ call exit_MPI(myrank,'cannot have both UNDO_ATTENUATION and PARTIAL_PHYS_DISPERSION_ONLY')
+
if((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then
if ( ATTENUATION_VAL) then
! checks mimic flag:
! attenuation for adjoint simulations must have PARTIAL_PHYS_DISPERSION_ONLY set by xcreate_header_file
- if( PARTIAL_PHYS_DISPERSION_ONLY .eqv. .false. ) &
- call exit_MPI(myrank,'error in compiled attenuation parameters, please recompile solver 17b')
+ if(.not. UNDO_ATTENUATION)then
+ if(.not. PARTIAL_PHYS_DISPERSION_ONLY) &
+ call exit_MPI(myrank,'ATTENUATION for adjoint runs or SAVE_FORWARD requires UNDO_ATTENUATION or PARTIAL_PHYS_DISPERSION_ONLY')
+ endif
! user output
if( myrank == 0 ) write(IMAIN,*) 'incorporates ATTENUATION for time-reversed simulation'
@@ -492,7 +507,5 @@
call MPI_BCAST(nrec,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
if(nrec < 1) call exit_MPI(myrank,trim(STATIONS)//': need at least one receiver')
-
end subroutine initialize_simulation
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_forward_arrays.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -32,13 +32,11 @@
displ_inner_core,veloc_inner_core,accel_inner_core, &
displ_outer_core,veloc_outer_core,accel_outer_core, &
R_memory_crust_mantle,R_memory_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
A_array_rotation,B_array_rotation, &
b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
! reads in saved wavefields
@@ -63,12 +61,8 @@
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: &
R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_crust_mantle
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: &
- epsilondev_inner_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
A_array_rotation,B_array_rotation
@@ -82,13 +76,9 @@
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: &
b_R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- b_epsilondev_crust_mantle
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: &
b_R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- b_epsilondev_inner_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
b_A_array_rotation,b_B_array_rotation
@@ -125,8 +115,6 @@
read(55) displ_outer_core
read(55) veloc_outer_core
read(55) accel_outer_core
- read(55) epsilondev_crust_mantle
- read(55) epsilondev_inner_core
read(55) A_array_rotation
read(55) B_array_rotation
read(55) R_memory_crust_mantle
@@ -145,8 +133,6 @@
b_displ_outer_core = 0._CUSTOM_REAL
b_veloc_outer_core = 0._CUSTOM_REAL
b_accel_outer_core = 0._CUSTOM_REAL
- b_epsilondev_crust_mantle = 0._CUSTOM_REAL
- b_epsilondev_inner_core = 0._CUSTOM_REAL
if (ROTATION_VAL) then
b_A_array_rotation = 0._CUSTOM_REAL
b_B_array_rotation = 0._CUSTOM_REAL
@@ -168,7 +154,6 @@
b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
! reads in saved wavefields
@@ -190,13 +175,9 @@
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: &
b_R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
- b_epsilondev_crust_mantle
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: &
b_R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
- b_epsilondev_inner_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
b_A_array_rotation,b_B_array_rotation
@@ -217,8 +198,6 @@
read(55) b_displ_outer_core
read(55) b_veloc_outer_core
read(55) b_accel_outer_core
- read(55) b_epsilondev_crust_mantle
- read(55) b_epsilondev_inner_core
if (ROTATION_VAL) then
read(55) b_A_array_rotation
read(55) b_B_array_rotation
@@ -230,3 +209,70 @@
close(55)
end subroutine read_forward_arrays
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_forward_arrays_undoatt(myrank, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+ b_R_memory_crust_mantle,b_R_memory_inner_core, &
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH,iteration_on_subset)
+
+! reads in saved wavefields
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ ! backward/reconstructed wavefields
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE_ADJOINT) :: &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: &
+ b_R_memory_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: &
+ b_R_memory_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
+ b_A_array_rotation,b_B_array_rotation
+
+ character(len=150) LOCAL_PATH
+
+ integer iteration_on_subset
+
+ !local parameters
+ character(len=150) outputname
+
+ write(outputname,'(a,i6.6,a,i6.6,a)') 'proc',myrank,'_save_frame_at',iteration_on_subset,'.bin'
+ open(unit=55,file=trim(LOCAL_PATH)//'/'//outputname,status='old',action='read',form='unformatted')
+ read(55) b_displ_crust_mantle
+ read(55) b_veloc_crust_mantle
+ read(55) b_accel_crust_mantle
+ read(55) b_displ_inner_core
+ read(55) b_veloc_inner_core
+ read(55) b_accel_inner_core
+ read(55) b_displ_outer_core
+ read(55) b_veloc_outer_core
+ read(55) b_accel_outer_core
+ if (ROTATION_VAL) then
+ read(55) b_A_array_rotation
+ read(55) b_B_array_rotation
+ endif
+ if (ATTENUATION_VAL) then
+ read(55) b_R_memory_crust_mantle
+ read(55) b_R_memory_inner_core
+ endif
+ close(55)
+
+ end subroutine read_forward_arrays_undoatt
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/save_forward_arrays.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -31,7 +31,6 @@
displ_inner_core,veloc_inner_core,accel_inner_core, &
displ_outer_core,veloc_outer_core,accel_outer_core, &
R_memory_crust_mantle,R_memory_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
A_array_rotation,B_array_rotation, &
LOCAL_PATH)
@@ -55,12 +54,8 @@
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: &
R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: &
- epsilondev_crust_mantle
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: &
- epsilondev_inner_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
A_array_rotation,B_array_rotation
@@ -84,8 +79,6 @@
write(55) displ_outer_core
write(55) veloc_outer_core
write(55) accel_outer_core
- write(55) epsilondev_crust_mantle
- write(55) epsilondev_inner_core
write(55) A_array_rotation
write(55) B_array_rotation
write(55) R_memory_crust_mantle
@@ -106,8 +99,6 @@
write(55) displ_outer_core
write(55) veloc_outer_core
write(55) accel_outer_core
- write(55) epsilondev_crust_mantle
- write(55) epsilondev_inner_core
if (ROTATION_VAL) then
write(55) A_array_rotation
write(55) B_array_rotation
@@ -120,3 +111,77 @@
endif
end subroutine save_forward_arrays
+!
+!=====================================================================
+
+ subroutine save_forward_arrays_undoatt(myrank,SIMULATION_TYPE,SAVE_FORWARD,NUMBER_OF_RUNS, &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
+ displ_inner_core,veloc_inner_core,accel_inner_core, &
+ displ_outer_core,veloc_outer_core,accel_outer_core, &
+ R_memory_crust_mantle,R_memory_inner_core, &
+ A_array_rotation,B_array_rotation, &
+ LOCAL_PATH,iteration_on_subset)
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ integer SIMULATION_TYPE
+ logical SAVE_FORWARD
+ integer NUMBER_OF_RUNS
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
+ displ_inner_core,veloc_inner_core,accel_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
+ displ_outer_core,veloc_outer_core,accel_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: &
+ R_memory_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: &
+ R_memory_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROTATION) :: &
+ A_array_rotation,B_array_rotation
+
+ character(len=150) LOCAL_PATH
+
+ integer iteration_on_subset
+
+ ! local parameters
+ 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'
+
+ ! 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=55,file=trim(LOCAL_PATH)//'/'//outputname,status='unknown',form='unformatted',action='write')
+ write(55) displ_crust_mantle
+ write(55) veloc_crust_mantle
+ write(55) accel_crust_mantle
+ write(55) displ_inner_core
+ write(55) veloc_inner_core
+ write(55) accel_inner_core
+ write(55) displ_outer_core
+ write(55) veloc_outer_core
+ write(55) accel_outer_core
+ if (ROTATION_VAL) then
+ write(55) A_array_rotation
+ write(55) B_array_rotation
+ endif
+ if (ATTENUATION_VAL) then
+ write(55) R_memory_crust_mantle
+ write(55) R_memory_inner_core
+ endif
+ close(55)
+ endif
+
+ end subroutine save_forward_arrays_undoatt
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -395,23 +395,17 @@
real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: epsilondev_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: eps_trace_over_3_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: eps_trace_over_3_loc_crust_mantle
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: epsilondev_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STRAIN_ONLY) :: eps_trace_over_3_inner_core
! ADJOINT
real(kind=CUSTOM_REAL), dimension(N_SLS) :: b_alphaval, b_betaval, b_gammaval
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_AND_ATT) :: b_R_memory_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: b_epsilondev_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: b_eps_trace_over_3_crust_mantle
real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_AND_ATT) :: b_R_memory_inner_core
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: b_epsilondev_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: b_eps_trace_over_3_inner_core
! for matching with central cube in inner core
integer, dimension(:), allocatable :: sender_from_slices_to_cube
@@ -865,7 +859,7 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS,&
NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY,NT_DUMP_ATTENUATION
double precision DT,ROCEAN,RMIDDLE_CRUST, &
RMOHO,R80,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
@@ -878,7 +872,8 @@
SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,SAVE_REGULAR_KL
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,SAVE_REGULAR_KL, &
+ PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION
character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
@@ -911,7 +906,6 @@
! dummy array that does not need to be actually read
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,1) :: dummy_array
-! computed in read_compute_parameters
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
@@ -948,6 +942,19 @@
integer msg_status(MPI_STATUS_SIZE)
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_displ_crust_mantle_store_buffer
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_displ_outer_core_store_buffer,&
+ b_accel_outer_core_store_buffer
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_displ_inner_core_store_buffer
+
+ integer :: iteration_on_subset,it_of_this_subset,j,irec_local,k
+ integer :: it_temp,seismo_current_temp
+ real(kind=CUSTOM_REAL), dimension(3) :: seismograms_temp
+ logical :: undo_att_sim_type_3
+
+ undo_att_sim_type_3 = .false.
+
+
! *************************************************
! ************** PROGRAM STARTS HERE **************
! *************************************************
@@ -1055,7 +1062,8 @@
hprime_xx,hprime_yy,hprime_zz,hprime_xxT, &
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,hprimewgll_xxT, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- rec_filename,STATIONS,nrec,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL)
+ rec_filename,STATIONS,nrec,NOISE_TOMOGRAPHY,SAVE_REGULAR_KL, &
+ PARTIAL_PHYS_DISPERSION_ONLY,UNDO_ATTENUATION,NT_DUMP_ATTENUATION)
!
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
@@ -1190,7 +1198,6 @@
allocate(b_buffer_send_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED), &
b_buffer_received_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED),stat=ier)
else
-! dummy allocation of unusued arrays
allocate(b_buffer_send_faces(1,1,1), &
b_buffer_received_faces(1,1,1),stat=ier)
endif
@@ -1708,12 +1715,12 @@
! allocate fictitious buffers for cube and slices with a dummy size
! just to be able to use them as arguments in subroutine calls
allocate(sender_from_slices_to_cube(1), &
- buffer_all_cube_from_slices(1,1,1), &
- b_buffer_all_cube_from_slices(1,1,1), &
- buffer_slices(1,1), &
- b_buffer_slices(1,1), &
- buffer_slices2(1,1), &
- ibool_central_cube(1,1),stat=ier)
+ buffer_all_cube_from_slices(1,1,1), &
+ b_buffer_all_cube_from_slices(1,1,1), &
+ buffer_slices(1,1), &
+ b_buffer_slices(1,1), &
+ buffer_slices2(1,1), &
+ ibool_central_cube(1,1),stat=ier)
if( ier /= 0 ) call exit_MPI(myrank,'error allocating dummy buffers')
endif
@@ -1884,6 +1891,13 @@
two_omega_earth,A_array_rotation,B_array_rotation, &
b_two_omega_earth, SIMULATION_TYPE)
+ if(UNDO_ATTENUATION) then
+ b_deltat = deltat
+ b_deltatover2 = deltatover2
+ b_deltatsqover2 = deltatsqover2
+ b_two_omega_earth = two_omega_earth
+ endif
+
! precomputes gravity factors
call prepare_timerun_gravity(myrank, &
minus_g_cmb,minus_g_icb, &
@@ -1908,8 +1922,15 @@
c33store_inner_core,c44store_inner_core, &
alphaval,betaval,gammaval,b_alphaval,b_betaval,b_gammaval, &
deltat,b_deltat,LOCAL_PATH)
+
+ if(UNDO_ATTENUATION) then
+ b_alphaval = alphaval
+ b_betaval = betaval
+ b_gammaval = gammaval
endif
+ endif
+
if(myrank == 0) then
write(IMAIN,*) 'for overlapping of communications with calculations:'
@@ -2005,18 +2026,6 @@
beta_kl_outer_core(:,:,:,:) = 0._CUSTOM_REAL
endif
- ! initialize to be on the save side for adjoint runs SIMULATION_TYPE==2
- eps_trace_over_3_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
- eps_trace_over_3_inner_core(:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
- if(FIX_UNDERFLOW_PROBLEM) then
- eps_trace_over_3_crust_mantle(:,:,:,:) = VERYSMALLVAL
- epsilondev_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
- eps_trace_over_3_inner_core(:,:,:,:) = VERYSMALLVAL
- epsilondev_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_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
@@ -2038,6 +2047,22 @@
! note: for SIMULATION_TYPE 3 simulations, the stored wavefields
! will be read in the time loop after the Newmark time scheme update.
! this makes indexing and timing easier to match with adjoint wavefields indexing.
+if(UNDO_ATTENUATION) then
+ if(NUMBER_OF_THIS_RUN > 1) stop 'we currently do not support NUMBER_OF_THIS_RUN > 1 in the case of UNDO_ATTENUATION'
+ ! define correct time steps if restart files
+ if(NUMBER_OF_RUNS < 1 .or. NUMBER_OF_RUNS > NSTEP) &
+ stop 'number of restart runs can not be less than 1 or greater than NSTEP'
+ if(NUMBER_OF_THIS_RUN < 1 .or. NUMBER_OF_THIS_RUN > NUMBER_OF_RUNS) stop 'incorrect run number'
+ if (SIMULATION_TYPE /= 1 .and. NUMBER_OF_RUNS /= 1) stop 'Only 1 run for SIMULATION_TYPE = 2/3'
+
+ it_begin = (NUMBER_OF_THIS_RUN - 1) * (NSTEP / NUMBER_OF_RUNS) + 1
+ if (NUMBER_OF_THIS_RUN < NUMBER_OF_RUNS) then
+ it_end = NUMBER_OF_THIS_RUN * (NSTEP / NUMBER_OF_RUNS)
+ else
+ ! Last run may be a bit larger
+ it_end = NSTEP
+ endif
+else
call read_forward_arrays_startrun(myrank,NSTEP, &
SIMULATION_TYPE,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
it_begin,it_end, &
@@ -2045,15 +2070,15 @@
displ_inner_core,veloc_inner_core,accel_inner_core, &
displ_outer_core,veloc_outer_core,accel_outer_core, &
R_memory_crust_mantle,R_memory_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
A_array_rotation,B_array_rotation, &
b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+endif
+
! NOISE TOMOGRAPHY
if ( NOISE_TOMOGRAPHY /= 0 ) then
allocate(noise_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NSTEP), &
@@ -2125,1889 +2150,171 @@
! ************* MAIN LOOP OVER THE TIME STEPS *************
! *********************************************************
+if(.not. UNDO_ATTENUATION) then
+
do it = it_begin,it_end
! update position in seismograms
seismo_current = seismo_current + 1
- ! Newark time scheme update
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
- + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
- + deltatover2*accel_crust_mantle(:,i)
- accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- displ_outer_core(i) = displ_outer_core(i) &
- + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) &
- + deltatover2*accel_outer_core(i)
- accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- displ_inner_core(:,i) = displ_inner_core(:,i) &
- + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
- veloc_inner_core(:,i) = veloc_inner_core(:,i) &
- + deltatover2*accel_inner_core(:,i)
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
+!! DK DK
+!! DK DK this first part handles the cases SIMULATION_TYPE == 1 and SIMULATION_TYPE == 2
+!! DK DK it also handles the cases NOISE_TOMOGRAPHY == 1 and NOISE_TOMOGRAPHY == 2
+!! DK DK
+ include "part1_classical.f90"
- ! backward field
- if (SIMULATION_TYPE == 3) then
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_displ_crust_mantle(:,i) = b_displ_crust_mantle(:,i) &
- + b_deltat*b_veloc_crust_mantle(:,i) + b_deltatsqover2*b_accel_crust_mantle(:,i)
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) &
- + b_deltatover2*b_accel_crust_mantle(:,i)
- b_accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
- ! outer core
- do i=1,NGLOB_OUTER_CORE
- b_displ_outer_core(i) = b_displ_outer_core(i) &
- + b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) &
- + b_deltatover2*b_accel_outer_core(i)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_displ_inner_core(:,i) = b_displ_inner_core(:,i) &
- + b_deltat*b_veloc_inner_core(:,i) + b_deltatsqover2*b_accel_inner_core(:,i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) &
- + b_deltatover2*b_accel_inner_core(:,i)
- b_accel_inner_core(:,i) = 0._CUSTOM_REAL
- enddo
- endif ! SIMULATION_TYPE == 3
+!! DK DK
+!! DK DK this first part handles the case SIMULATION_TYPE == 3
+!! DK DK it also handles the case NOISE_TOMOGRAPHY == 3
+!! DK DK
+ include "part2_classical.f90"
- ! integral of strain for adjoint movie volume
- if(MOVIE_VOLUME .and. (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) ) then
-! do *NOT* use array syntax for that loop, otherwise you will get a compiler error when MOVIE_VOLUME is off
-! because the shape of the arrays will not match (due to some arrays purposely declared with a dummy size of 1)
- do ispec = 1,NSPEC_CRUST_MANTLE
- Iepsilondev_crust_mantle(:,:,:,:,ispec) = Iepsilondev_crust_mantle(:,:,:,:,ispec) &
- + deltat*epsilondev_crust_mantle(:,:,:,:,ispec)
- Ieps_trace_over_3_crust_mantle(:,:,:,ispec) = Ieps_trace_over_3_crust_mantle(:,:,:,ispec) &
- + deltat*eps_trace_over_3_crust_mantle(:,:,:,ispec)
- enddo
- endif
+!! DK DK empty file for now
+ include "part3_kernel_computation.f90"
- ! compute the maximum of the norm of the displacement
- ! in all the slices using an MPI reduction
- ! and output timestamp file to check that simulation is running fine
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == it_begin+4 .or. it == it_end) &
- call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
- b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
- it_begin,it_end,NUMBER_OF_THIS_RUN,NUMBER_OF_RUNS,myrank)
+!
+!---- end of time iteration loop
+!
+ enddo ! end of main time loop
+else ! if UNDO_ATTENUATION
- ! ****************************************************
- ! big loop over all spectral elements in the fluid
- ! ****************************************************
+!! DK DK this should not be difficult to fix and test, but not done yet by lack of time
+ if(NUMBER_OF_RUNS /= 1) stop 'NUMBER_OF_RUNS should be == 1 for now when using UNDO_ATTENUATION'
- ! compute internal forces in the fluid region
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(it-1)*DT-t0)*scale_t_inv)
- else
- time = (dble(it-1)*DT-t0)*scale_t_inv
- endif
+!
+!-------------------------------------------------------------------------------
+!
- iphase = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- if (SIMULATION_TYPE == 3) then
- ! note on backward/reconstructed wavefields:
- ! time for b_displ( it=1 ) corresponds to (NSTEP - 1)*DT - t0 (after Newmark scheme...)
- ! as we start with saved wavefields b_displ( 1 ) <-> displ( NSTEP ) which correspond
- ! to a time (NSTEP - (it-1) - 1)*DT - t0
- ! for reconstructing the rotational contributions
- if(CUSTOM_REAL == SIZE_REAL) then
- time = sngl((dble(NSTEP-it)*DT-t0)*scale_t_inv)
- else
- time = (dble(NSTEP-it)*DT-t0)*scale_t_inv
+! New part of ZN
+ if(SIMULATION_TYPE == 1)then
+ it = 0
+ do iteration_on_subset = 1, NSTEP / NT_DUMP_ATTENUATION
+ if(SAVE_FORWARD)then
+ call save_forward_arrays_undoatt(myrank,SIMULATION_TYPE,SAVE_FORWARD,NUMBER_OF_RUNS, &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
+ displ_inner_core,veloc_inner_core,accel_inner_core, &
+ displ_outer_core,veloc_outer_core,accel_outer_core, &
+ R_memory_crust_mantle,R_memory_inner_core, &
+ A_array_rotation,B_array_rotation,LOCAL_PATH,iteration_on_subset)
endif
- b_iphase = 0 ! do not start any non blocking communications at this stage
- b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+ do it_of_this_subset = 1, NT_DUMP_ATTENUATION
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
- endif
+ it = it + 1
- ! Stacey absorbing boundaries
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- call compute_stacey_outer_core(ichunk,SIMULATION_TYPE,SAVE_FORWARD, &
- NSTEP,it,ibool_outer_core, &
- veloc_outer_core,accel_outer_core,b_accel_outer_core, &
- vp_outer_core,wgllwgll_xz,wgllwgll_yz,wgllwgll_xy, &
- jacobian2D_bottom_outer_core, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
- jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core, &
- ibelm_bottom_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core, &
- ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- nimin_outer_core,nimax_outer_core, &
- njmin_outer_core,njmax_outer_core, &
- nkmin_xi_outer_core,nkmin_eta_outer_core, &
- NSPEC2D_BOTTOM, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- reclen_zmin, &
- reclen_xmin_outer_core,reclen_xmax_outer_core, &
- reclen_ymin_outer_core,reclen_ymax_outer_core, &
- nabs_zmin_oc, &
- nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc, &
- absorb_zmin_outer_core, &
- absorb_xmin_outer_core,absorb_xmax_outer_core, &
- absorb_ymin_outer_core,absorb_ymax_outer_core)
- endif ! Stacey conditions
+ seismo_current = seismo_current + 1
+ include "part1_undo_att.f90"
- ! ****************************************************
- ! ********** add matching with solid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the fluid
-
- !---
- !--- couple with mantle at the top of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) &
- call compute_coupling_fluid_CMB(displ_crust_mantle,b_displ_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_OUTER_CORE))
-
- !---
- !--- couple with inner core at the bottom of the outer core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) &
- call compute_coupling_fluid_ICB(displ_inner_core,b_displ_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_OUTER_CORE))
-
-
- ! assemble all the contributions between slices using MPI
-
- ! outer core
- iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,deltat,two_omega_earth, &
- A_array_rotation,B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid,displ_outer_core,accel_outer_core,div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar,iphase,icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
-
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
enddo
-
- ! multiply by the inverse of the mass matrix and update velocity
- do i=1,NGLOB_OUTER_CORE
- accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
- veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
enddo
- if (SIMULATION_TYPE == 3) then
+ endif
-! ------------------- new non blocking implementation -------------------
+ if(SIMULATION_TYPE == 2)then
+ !!add this part
- ! outer core
- b_iphase = 1 ! start the non blocking communications
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
+ it = 0
+ do iteration_on_subset = 1, NSTEP / NT_DUMP_ATTENUATION
- b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
+ do it_of_this_subset = 1, NT_DUMP_ATTENUATION
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- ! uses Deville et al. (2002) routine
- call compute_forces_outer_core_Dev(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- else
- ! div_displ_outer_core is initialized to zero in the following subroutine.
- call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
- b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
- minus_rho_g_over_kappa_fluid, &
- b_displ_outer_core,b_accel_outer_core,b_div_displ_outer_core, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- is_on_a_slice_edge_outer_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar,b_iphase,b_icall, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core,MOVIE_VOLUME)
- endif
+ it = it + 1
- do while (b_iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_scalar,b_buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,b_iphase)
- enddo
+ seismo_current = seismo_current + 1
-! ------------------- new non blocking implementation -------------------
+ include "part1_undo_att.f90"
- ! Newmark time scheme - corrector for fluid parts
- do i=1,NGLOB_OUTER_CORE
- b_accel_outer_core(i) = b_accel_outer_core(i)*rmass_outer_core(i)
- b_veloc_outer_core(i) = b_veloc_outer_core(i) + b_deltatover2*b_accel_outer_core(i)
enddo
+ enddo
+ endif
- endif
+ if(SIMULATION_TYPE == 3)then
- ! ****************************************************
- ! big loop over all spectral elements in the solid
- ! ****************************************************
+ undo_att_sim_type_3 = .true.
- ! compute internal forces in the solid regions
+ allocate(b_displ_crust_mantle_store_buffer(NDIM,NGLOB_CRUST_MANTLE,NT_DUMP_ATTENUATION),stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_displ_crust_mantle_store_buffer')
+ allocate(b_displ_outer_core_store_buffer(NGLOB_OUTER_CORE,NT_DUMP_ATTENUATION),stat=ier)
+ 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,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,NT_DUMP_ATTENUATION),stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating b_displ_inner_core_store_buffer')
- ! for anisotropy and gravity, x y and z contain r theta and phi
+ it = 0
- iphase = 0 ! do not start any non blocking communications at this stage
- iphase_CC = 0 ! do not start any non blocking communications at this stage
- icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+ do iteration_on_subset = 1, NSTEP / NT_DUMP_ATTENUATION
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
+ call read_forward_arrays_undoatt(myrank, &
+ b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
+ b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
+ b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
+ b_R_memory_crust_mantle,b_R_memory_inner_core, &
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH, NSTEP/NT_DUMP_ATTENUATION-iteration_on_subset+1)
- if (SIMULATION_TYPE == 3 ) then
+ it_temp = it
+ seismo_current_temp = seismo_current
- b_iphase = 0 ! do not start any non blocking communications at this stage
- b_iphase_CC = 0 ! do not start any non blocking communications at this stage
- b_icall = 1 ! compute all the outer elements first in the case of non blocking MPI
+ do it_of_this_subset = 1, NT_DUMP_ATTENUATION
- ! for anisotropy and gravity, x y and z contain r theta and phi
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
+ it = it + 1
+ seismo_current = seismo_current + 1
+ include "part2_undo_att.f90"
- endif
- endif
+ 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(:,:)
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
- if (SIMULATION_TYPE == 3) then
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
- endif
-
- ! Stacey
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
- call compute_stacey_crust_mantle(ichunk,SIMULATION_TYPE, &
- NSTEP,it,SAVE_FORWARD,ibool_crust_mantle, &
- veloc_crust_mantle,accel_crust_mantle,b_accel_crust_mantle, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle, &
- wgllwgll_xz,wgllwgll_yz, &
- 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, &
- reclen_xmin_crust_mantle,reclen_xmax_crust_mantle, &
- reclen_ymin_crust_mantle,reclen_ymax_crust_mantle, &
- nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
- absorb_xmin_crust_mantle5,absorb_xmax_crust_mantle5, &
- absorb_ymin_crust_mantle5,absorb_ymax_crust_mantle5)
- endif ! Stacey conditions
-
- ! add the sources
- if (SIMULATION_TYPE == 1) &
- call compute_add_sources(myrank,NSOURCES, &
- accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
- ! add adjoint sources
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- if( nadj_rec_local > 0 ) &
- call compute_add_sources_adjoint(myrank,nrec, &
- nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
- accel_crust_mantle,adj_sourcearrays, &
- nu,xi_receiver,eta_receiver,gamma_receiver, &
- xigll,yigll,zigll,ibool_crust_mantle, &
- islice_selected_rec,ispec_selected_rec, &
- NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
- it,it_begin,station_name,network_name,DT)
- endif
-
- ! add sources for backward/reconstructed wavefield
- if (SIMULATION_TYPE == 3) &
- call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
- b_accel_crust_mantle,sourcearrays, &
- DT,t0,tshift_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it, &
- hdur,xi_source,eta_source,gamma_source,nu_source)
-
- ! NOISE_TOMOGRAPHY
- if ( NOISE_TOMOGRAPHY == 1 ) then
- ! the first step of noise tomography is to use |S(\omega)|^2 as a point force source at one of the receivers.
- ! hence, instead of a moment tensor 'sourcearrays', a 'noise_sourcearray' for a point force is needed.
- ! furthermore, the CMTSOLUTION needs to be zero, i.e., no earthquakes.
- ! now this must be manually set in DATA/CMTSOLUTION, by USERS.
- call add_source_master_rec_noise(myrank,nrec, &
- NSTEP,accel_crust_mantle,noise_sourcearray, &
- ibool_crust_mantle,islice_selected_rec,ispec_selected_rec, &
- it,irec_master_noise)
- else if ( NOISE_TOMOGRAPHY == 2 ) then
- ! second step of noise tomography, i.e., read the surface movie saved at every timestep
- ! use the movie to drive the ensemble forward wavefield
- call noise_read_add_surface_movie(nmovie_points,accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- NSTEP-it+1,jacobian2D_top_crust_mantle,wgllwgll_xy)
- ! be careful, since ensemble forward sources are reversals of generating wavefield "eta"
- ! hence the "NSTEP-it+1", i.e., start reading from the last timestep
- ! note the ensemble forward sources are generally distributed on the surface of the earth
- ! that's to say, the ensemble forward source is kind of a surface force density, not a body force density
- ! therefore, we must add it here, before applying the inverse of mass matrix
- else if ( NOISE_TOMOGRAPHY == 3 ) then
- ! 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(nmovie_points,b_accel_crust_mantle, &
- normal_x_noise,normal_y_noise,normal_z_noise,mask_noise, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- it,jacobian2D_top_crust_mantle,wgllwgll_xy)
- endif
-
- ! ****************************************************
- ! ********** add matching with fluid part **********
- ! ****************************************************
-
- ! only for elements in first matching layer in the solid
-
- !---
- !--- couple with outer core at the bottom of the mantle
- !---
- if(ACTUALLY_COUPLE_FLUID_CMB) &
- call compute_coupling_CMB_fluid(displ_crust_mantle,b_displ_crust_mantle, &
- accel_crust_mantle,b_accel_crust_mantle, &
- ibool_crust_mantle,ibelm_bottom_crust_mantle, &
- accel_outer_core,b_accel_outer_core, &
- normal_top_outer_core,jacobian2D_top_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- RHO_TOP_OC,minus_g_cmb, &
- SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
-
- !---
- !--- couple with outer core at the top of the inner core
- !---
- if(ACTUALLY_COUPLE_FLUID_ICB) &
- call compute_coupling_ICB_fluid(displ_inner_core,b_displ_inner_core, &
- accel_inner_core,b_accel_inner_core, &
- ibool_inner_core,ibelm_top_inner_core, &
- accel_outer_core,b_accel_outer_core, &
- normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
- wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
- RHO_BOTTOM_OC,minus_g_icb, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_INNER_CORE))
-
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
- iphase = 1 ! initialize the non blocking communication counter
- iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
-
- icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_crust_mantle,accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,icall, &
- accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- R_memory_crust_mantle,epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- alphaval,betaval,gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- displ_inner_core,accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,icall, &
- accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector,iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- R_memory_inner_core,epsilondev_inner_core, eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- alphaval,betaval,gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,accel_crust_mantle,accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,iphase)
enddo
- !---
- !--- use buffers to assemble forces with the central cube
- !---
+ it = it_temp
+ seismo_current = seismo_current_temp
- if(INCLUDE_CENTRAL_CUBE) then
- do while (iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,buffer_all_cube_from_slices,buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),accel_inner_core,NDIM,iphase_CC)
+ do it_of_this_subset = 1, NT_DUMP_ATTENUATION
+ 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
- endif ! end of assembling forces with the central cube
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
-
- do i=1,NGLOB_CRUST_MANTLE
- 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
-
- else
-
- do i=1,NGLOB_CRUST_MANTLE
- 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
-
- if (SIMULATION_TYPE == 3) then
-
-! ------------------- new non blocking implementation -------------------
-
- ! assemble all the contributions between slices using MPI
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
-
- b_iphase = 1 ! initialize the non blocking communication counter
- b_iphase_CC = 1 ! initialize the non blocking communication counter for the central cube
-
-! start the non blocking communications
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
-
- b_icall = 2 ! now compute all the inner elements in the case of non blocking MPI
-
- ! compute internal forces in the solid regions
-
- ! for anisotropy and gravity, x y and z contain r theta and phi
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_crust_mantle_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- else
- call compute_forces_crust_mantle(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_crust_mantle,b_accel_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- is_on_a_slice_edge_crust_mantle,b_icall, &
- b_accel_inner_core,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
- c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle, &
- c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
- c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- b_R_memory_crust_mantle,b_epsilondev_crust_mantle, &
- b_eps_trace_over_3_crust_mantle,one_minus_sum_beta_crust_mantle, &
- b_alphaval,b_betaval,b_gammaval,factor_common_crust_mantle, &
- size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
- size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5) )
- endif
-
- ! Deville routine
- if( USE_DEVILLE_PRODUCTS_VAL ) then
- call compute_forces_inner_core_Dev(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- else
- call compute_forces_inner_core(minus_gravity_table,density_table,minus_deriv_gravity_table, &
- b_displ_inner_core,b_accel_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- is_on_a_slice_edge_inner_core,b_icall, &
- b_accel_crust_mantle,ibool_inner_core,idoubling_inner_core, &
- myrank,iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector,b_iphase, &
- nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibelm_bottom_inner_core,NSPEC2D_BOTTOM_IC,INCLUDE_CENTRAL_CUBE,b_iphase_CC, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core, &
- b_R_memory_inner_core,b_epsilondev_inner_core, b_eps_trace_over_3_inner_core,&
- one_minus_sum_beta_inner_core, &
- b_alphaval,b_betaval,b_gammaval, &
- factor_common_inner_core, &
- size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
- size(factor_common_inner_core,4), size(factor_common_inner_core,5) )
- endif
-
-! assemble all the contributions between slices using MPI
-! crust/mantle and inner core handled in the same call
-! in order to reduce the number of MPI messages by 2
- do while (b_iphase <= 7) ! make sure the last communications are finished and processed
- call assemble_MPI_vector(myrank,b_accel_crust_mantle,b_accel_inner_core, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- b_buffer_send_faces,b_buffer_received_faces,npoin2D_max_all_CM_IC, &
- b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
- NUMMSGS_FACES,NCORNERSCHUNKS, &
- NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS_VAL,b_iphase)
+ 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
- !---
- !--- use buffers to assemble forces with the central cube
- !---
-
- if(INCLUDE_CENTRAL_CUBE) then
- do while (b_iphase_CC <= 4) ! make sure the last communications are finished and processed
- call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube,sender_from_slices_to_cube, &
- npoin2D_cube_from_slices,b_buffer_all_cube_from_slices,b_buffer_slices,ibool_central_cube, &
- receiver_cube_from_slices,ibool_inner_core,idoubling_inner_core, &
- ibelm_bottom_inner_core,NSPEC2D_BOTTOM(IREGION_INNER_CORE),b_accel_inner_core,NDIM,b_iphase_CC)
+ 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
- endif ! end of assembling forces with the central cube
+ enddo
-! ------------------- new non blocking implementation -------------------
+ it = it + 1
- if(NCHUNKS_VAL /= 6 .and. ABSORBING_CONDITIONS) then
+ seismo_current = seismo_current + 1
- do i=1,NGLOB_CRUST_MANTLE
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassx_crust_mantle(i) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassy_crust_mantle(i) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
+ include "part1_undo_att.f90"
- else
+ include "part3_kernel_computation.f90"
- do i=1,NGLOB_CRUST_MANTLE
- b_accel_crust_mantle(1,i) = b_accel_crust_mantle(1,i)*rmassz_crust_mantle(i) &
- + b_two_omega_earth*b_veloc_crust_mantle(2,i)
- b_accel_crust_mantle(2,i) = b_accel_crust_mantle(2,i)*rmassz_crust_mantle(i) &
- - b_two_omega_earth*b_veloc_crust_mantle(1,i)
- b_accel_crust_mantle(3,i) = b_accel_crust_mantle(3,i)*rmassz_crust_mantle(i)
- enddo
-
- endif
-
- endif ! SIMULATION_TYPE == 3
-
- ! couples ocean with crust mantle
- if(OCEANS_VAL) &
- call compute_coupling_ocean(accel_crust_mantle,b_accel_crust_mantle, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle, &
- rmass_ocean_load,normal_top_crust_mantle, &
- ibool_crust_mantle,ibelm_top_crust_mantle, &
- updated_dof_ocean_load,NGLOB_XY, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- ABSORBING_CONDITIONS)
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
- ! Newmark time scheme - corrector for elastic parts
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i) &
- + two_omega_earth*veloc_inner_core(2,i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i) &
- - two_omega_earth*veloc_inner_core(1,i)
- accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
-
- veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
- enddo
-
- if (SIMULATION_TYPE == 3) then
- ! mantle
- do i=1,NGLOB_CRUST_MANTLE
- b_veloc_crust_mantle(:,i) = b_veloc_crust_mantle(:,i) + b_deltatover2*b_accel_crust_mantle(:,i)
enddo
- ! inner core
- do i=1,NGLOB_INNER_CORE
- b_accel_inner_core(1,i) = b_accel_inner_core(1,i)*rmass_inner_core(i) &
- + b_two_omega_earth*b_veloc_inner_core(2,i)
- b_accel_inner_core(2,i) = b_accel_inner_core(2,i)*rmass_inner_core(i) &
- - b_two_omega_earth*b_veloc_inner_core(1,i)
- b_accel_inner_core(3,i) = b_accel_inner_core(3,i)*rmass_inner_core(i)
- b_veloc_inner_core(:,i) = b_veloc_inner_core(:,i) + b_deltatover2*b_accel_inner_core(:,i)
- enddo
-
- endif ! SIMULATION_TYPE == 3
-
- ! restores last time snapshot saved for backward/reconstruction of wavefields
- ! note: this is done here after the Newmark time scheme, otherwise the indexing for sources
- ! and adjoint sources will become more complicated
- ! that is, index it for adjoint sources will match index NSTEP - 1 for backward/reconstructed wavefields
- if( SIMULATION_TYPE == 3 .and. it == 1 ) then
- call read_forward_arrays(myrank, &
- b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle, &
- b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core, &
- b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
- b_R_memory_crust_mantle,b_R_memory_inner_core, &
- b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
- b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
- endif
-
-! write the seismograms with time shift
-
-! store the seismograms only if there is at least one receiver located in this slice
- if (nrec_local > 0) then
- if (SIMULATION_TYPE == 1) then
- call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- else if (SIMULATION_TYPE == 2) then
- call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
- eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- hxir_store,hetar_store,hgammar_store, &
- hpxir_store,hpetar_store,hpgammar_store, &
- tshift_cmt,hdur_gaussian,DT,t0,scale_displ, &
- 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, &
- moment_der,sloc_der,stshift_der,shdur_der, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
- ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
- NSTEP,it,nit_written)
-
- else if (SIMULATION_TYPE == 3) then
- call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
- nu,hxir_store,hetar_store,hgammar_store, &
- scale_displ,ibool_crust_mantle, &
- ispec_selected_rec,number_receiver_global, &
- seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
- endif
- endif ! nrec_local
-
- ! write the current or final seismograms
- if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
- call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,stbur, &
- nrec,nrec_local,ANGULAR_WIDTH_XI_IN_DEGREES,NEX_XI,DT,t0,it_end, &
- yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC,t_shift_SAC, &
- elat_SAC,elon_SAC,depth_SAC,event_name_SAC,cmt_lat_SAC,cmt_lon_SAC,&
- cmt_depth_SAC,cmt_hdur_SAC,NPROCTOT_VAL, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,MODEL)
- if(myrank==0) then
- write(IMAIN,*)
- write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
- write(IMAIN,*)
- endif
- else
- 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_PATH)
- nit_written = it
- endif
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
+ enddo ! end of main time loop
endif
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
+endif
-! kernel calculations
- if (SIMULATION_TYPE == 3) then
- ! crust mantle
- call compute_kernels_crust_mantle(ibool_crust_mantle, &
- rho_kl_crust_mantle,beta_kl_crust_mantle, &
- alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
- accel_crust_mantle,b_displ_crust_mantle, &
- epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
- eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
- deltat)
-
- ! outer core
- call compute_kernels_outer_core(ibool_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
- hprime_xx,hprime_yy,hprime_zz, &
- displ_outer_core,accel_outer_core, &
- b_displ_outer_core,b_accel_outer_core, &
- vector_accel_outer_core,vector_displ_outer_core, &
- b_vector_displ_outer_core, &
- div_displ_outer_core,b_div_displ_outer_core, &
- rhostore_outer_core,kappavstore_outer_core, &
- rho_kl_outer_core,alpha_kl_outer_core, &
- deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
- deltat)
-
- ! inner core
- call compute_kernels_inner_core(ibool_inner_core, &
- rho_kl_inner_core,beta_kl_inner_core, &
- alpha_kl_inner_core, &
- accel_inner_core,b_displ_inner_core, &
- epsilondev_inner_core,b_epsilondev_inner_core, &
- eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
- deltat)
-
- ! NOISE TOMOGRAPHY --- source strength kernel
- if (NOISE_TOMOGRAPHY == 3) &
- call compute_kernels_strength_noise(nmovie_points,ibool_crust_mantle, &
- Sigma_kl_crust_mantle,displ_crust_mantle,deltat,it, &
- normal_x_noise,normal_y_noise,normal_z_noise, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie, &
- ibelm_top_crust_mantle)
-
- ! --- boundary kernels ------
- if (SAVE_BOUNDARY_MESH) then
- fluid_solid_boundary = .false.
- iregion_code = IREGION_CRUST_MANTLE
-
- ! Moho
- if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_moho_top,normal_moho,moho_kl_top,fluid_solid_boundary,NSPEC2D_MOHO)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_moho_bot,normal_moho,moho_kl_bot,fluid_solid_boundary,NSPEC2D_MOHO)
-
- moho_kl = moho_kl + (moho_kl_top - moho_kl_bot) * deltat
- endif
-
- ! 400
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_400_top,normal_400,d400_kl_top,fluid_solid_boundary,NSPEC2D_400)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_400_bot,normal_400,d400_kl_bot,fluid_solid_boundary,NSPEC2D_400)
-
- d400_kl = d400_kl + (d400_kl_top - d400_kl_bot) * deltat
-
- ! 670
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_670_top,normal_670,d670_kl_top,fluid_solid_boundary,NSPEC2D_670)
-
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_bot,ibelm_670_bot,normal_670,d670_kl_bot,fluid_solid_boundary,NSPEC2D_670)
-
- d670_kl = d670_kl + (d670_kl_top - d670_kl_bot) * deltat
-
- ! CMB
- fluid_solid_boundary = .true.
- iregion_code = IREGION_CRUST_MANTLE
- call compute_boundary_kernel(displ_crust_mantle,accel_crust_mantle, &
- b_displ_crust_mantle,nspec_crust_mantle,iregion_code, &
- ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle,ispec_is_tiso_crust_mantle, &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_crust_mantle,kappavstore_crust_mantle, muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,c14store_crust_mantle, &
- c15store_crust_mantle,c16store_crust_mantle,c22store_crust_mantle, &
- c23store_crust_mantle,c24store_crust_mantle,c25store_crust_mantle,c26store_crust_mantle, &
- c33store_crust_mantle,c34store_crust_mantle,c35store_crust_mantle, &
- c36store_crust_mantle,c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
- c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- k_top,ibelm_bottom_crust_mantle,normal_top_outer_core, &
- cmb_kl_top,fluid_solid_boundary,NSPEC2D_CMB)
-
- iregion_code = IREGION_OUTER_CORE
- call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
- b_vector_displ_outer_core,nspec_outer_core, &
- iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core,&
- gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_outer_core,kappavstore_outer_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_bot,ibelm_top_outer_core,normal_top_outer_core, &
- cmb_kl_bot,fluid_solid_boundary,NSPEC2D_CMB)
-
- cmb_kl = cmb_kl + (cmb_kl_top - cmb_kl_bot) * deltat
-
- ! ICB
- fluid_solid_boundary = .true.
- call compute_boundary_kernel(vector_displ_outer_core,vector_accel_outer_core, &
- b_vector_displ_outer_core,nspec_outer_core, &
- iregion_code,ystore_outer_core,zstore_outer_core,ibool_outer_core,ispec_is_tiso_outer_core, &
- xix_outer_core,xiy_outer_core,xiz_outer_core, &
- etax_outer_core,etay_outer_core,etaz_outer_core,&
- gammax_outer_core,gammay_outer_core,gammaz_outer_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_outer_core,kappavstore_outer_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_top,ibelm_bottom_outer_core,normal_bottom_outer_core, &
- icb_kl_top,fluid_solid_boundary,NSPEC2D_ICB)
-
- iregion_code = IREGION_INNER_CORE
- call compute_boundary_kernel(displ_inner_core,accel_inner_core, &
- b_displ_inner_core,nspec_inner_core,iregion_code, &
- ystore_inner_core,zstore_inner_core,ibool_inner_core,ispec_is_tiso_inner_core, &
- xix_inner_core,xiy_inner_core,xiz_inner_core, &
- etax_inner_core,etay_inner_core,etaz_inner_core,&
- gammax_inner_core,gammay_inner_core,gammaz_inner_core,hprime_xx,hprime_yy,hprime_zz, &
- rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
- dummy_array,dummy_array,dummy_array, &
- c11store_inner_core,c12store_inner_core,c13store_inner_core,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array,dummy_array, &
- c33store_inner_core,dummy_array,dummy_array, &
- dummy_array,c44store_inner_core,dummy_array,dummy_array, &
- dummy_array,dummy_array,dummy_array, &
- k_bot,ibelm_top_inner_core,normal_bottom_outer_core, &
- icb_kl_bot,fluid_solid_boundary,NSPEC2D_ICB)
-
- icb_kl = icb_kl + (icb_kl_top - icb_kl_bot) * deltat
- endif
-
- ! approximate hessian
- if( APPROXIMATE_HESS_KL ) then
- call compute_kernels_hessian(ibool_crust_mantle, &
- hess_kl_crust_mantle,&
- accel_crust_mantle,b_accel_crust_mantle, &
- deltat)
- endif
-
- endif ! end computing kernels
-
-!
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
-!
- ! 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(displ_crust_mantle, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE),noise_surface_movie,it)
- endif
+ !ZN need to be removed for undoing att
- ! save movie on surface
- if( MOVIE_SURFACE ) then
- if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- ! save velocity here to avoid static offset on displacement for movies
- call write_movie_surface(myrank,nmovie_points,scale_veloc,veloc_crust_mantle, &
- scale_displ,displ_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- store_val_x,store_val_y,store_val_z, &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux,store_val_uy,store_val_uz, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all, &
- ibelm_top_crust_mantle,ibool_crust_mantle, &
- NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- NIT,it,OUTPUT_FILES,MOVIE_VOLUME_TYPE)
- endif
- endif
-
-
- ! save movie in full 3D mesh
- if(MOVIE_VOLUME ) then
- if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
- .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
-
- if (MOVIE_VOLUME_TYPE == 1) then ! output strains
-
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
- ! output the Time Integral of Strain, or \mu*TIS
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,Ieps_trace_over_3_crust_mantle,Iepsilondev_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 4) then ! output divergence and curl in whole volume
-
- call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
- div_displ_outer_core, &
- accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
- eps_trace_over_3_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
- LOCAL_PATH, &
- displ_crust_mantle,displ_inner_core,displ_outer_core, &
- veloc_crust_mantle,veloc_inner_core,veloc_outer_core, &
- accel_crust_mantle,accel_inner_core, &
- ibool_crust_mantle,ibool_inner_core)
-
- else if (MOVIE_VOLUME_TYPE == 5) then ! output displacement
- scalingval = scale_displ
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,displ_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- else if (MOVIE_VOLUME_TYPE == 6) then ! output velocity
- scalingval = scale_veloc
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_PATH,MOVIE_VOLUME_TYPE, &
- MOVIE_COARSE,ibool_crust_mantle,veloc_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- else
-
- call exit_MPI(myrank, 'MOVIE_VOLUME_TYPE has to be 1,2,3,4,5 or 6')
-
- endif ! MOVIE_VOLUME_TYPE
- endif
- endif ! MOVIE_VOLUME
-
-!
-!---- end of time iteration loop
-!
- enddo ! end of main time loop
-
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!
-
! synchronize all processes, waits until all processes have written their seismograms
call MPI_BARRIER(MPI_COMM_WORLD,ier)
if( ier /= 0 ) call exit_mpi(myrank,'error synchronize after time loop')
@@ -4084,13 +2391,13 @@
if( ier /= 0 ) call exit_mpi(myrank,'error synchronize closing snapshots')
! save files to local disk or tape system if restart file
- call save_forward_arrays(myrank,SIMULATION_TYPE,SAVE_FORWARD, &
+ if(.not. UNDO_ATTENUATION) call save_forward_arrays(myrank,SIMULATION_TYPE,SAVE_FORWARD, &
NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
displ_inner_core,veloc_inner_core,accel_inner_core, &
displ_outer_core,veloc_outer_core,accel_outer_core, &
R_memory_crust_mantle,R_memory_inner_core, &
- epsilondev_crust_mantle,epsilondev_inner_core, &
+!ZN epsilondev_crust_mantle,epsilondev_inner_core, &
A_array_rotation,B_array_rotation,LOCAL_PATH)
! synchronize all processes
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_volume.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_volume.f90 2013-06-28 16:17:37 UTC (rev 22442)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_volume.f90 2013-06-28 17:42:14 UTC (rev 22443)
@@ -254,10 +254,12 @@
end subroutine write_movie_volume_mesh
! ---------------------------------------------
-
subroutine write_movie_volume_strains(myrank,npoints_3dmovie,LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,eps_trace_over_3_crust_mantle,epsilondev_crust_mantle,muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
+ it,muvstore_crust_mantle_3dmovie,mask_3dmovie,nu_3dmovie,&
+ hprime_xx,hprime_yy,hprime_zz,ibool_crust_mantle,&
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,displ_crust_mantle)
implicit none
@@ -267,14 +269,27 @@
! input
integer :: myrank,npoints_3dmovie,MOVIE_VOLUME_TYPE,it
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: eps_trace_over_3_crust_mantle
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: eps_trace_over_3_loc_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_3DMOVIE) :: muvstore_crust_mantle_3dmovie
logical, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: mask_3dmovie
logical :: MOVIE_COARSE
real(kind=CUSTOM_REAL), dimension(3,3,npoints_3dmovie) :: nu_3dmovie
character(len=150) LOCAL_PATH,outputname
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle
+
! variables
character(len=150) prname
integer :: ipoints_3dmovie,i,j,k,ispec,NIT
@@ -310,19 +325,28 @@
write(prname,"('proc',i6.6)") myrank
ipoints_3dmovie=0
do ispec=1,NSPEC_CRUST_MANTLE
+ call compute_element_strain_undo_att_noDev(ispec,nglob_crust_mantle,NSPEC_CRUST_MANTLE,&
+ displ_crust_mantle,hprime_xx,hprime_yy,hprime_zz,ibool_crust_mantle,&
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,&
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle,&
+ epsilondev_loc_crust_mantle,eps_trace_over_3_loc_crust_mantle)
+
do k=1,NGLLZ,NIT
do j=1,NGLLY,NIT
do i=1,NGLLX,NIT
if(mask_3dmovie(i,j,k,ispec)) then
ipoints_3dmovie=ipoints_3dmovie+1
muv_3dmovie=muvstore_crust_mantle_3dmovie(i,j,k,ispec)
- eps_loc(1,1)=eps_trace_over_3_crust_mantle(i,j,k,ispec) + epsilondev_crust_mantle(1,i,j,k,ispec)
- eps_loc(2,2)=eps_trace_over_3_crust_mantle(i,j,k,ispec) + epsilondev_crust_mantle(2,i,j,k,ispec)
- eps_loc(3,3)=eps_trace_over_3_crust_mantle(i,j,k,ispec)- &
- epsilondev_crust_mantle(1,i,j,k,ispec) - epsilondev_crust_mantle(2,i,j,k,ispec)
- eps_loc(1,2)=epsilondev_crust_mantle(3,i,j,k,ispec)
- eps_loc(1,3)=epsilondev_crust_mantle(4,i,j,k,ispec)
- eps_loc(2,3)=epsilondev_crust_mantle(5,i,j,k,ispec)
+
+ eps_loc(1,1)=eps_trace_over_3_loc_crust_mantle(i,j,k) + epsilondev_loc_crust_mantle(1,i,j,k)
+ eps_loc(2,2)=eps_trace_over_3_loc_crust_mantle(i,j,k) + epsilondev_loc_crust_mantle(2,i,j,k)
+ eps_loc(3,3)=eps_trace_over_3_loc_crust_mantle(i,j,k)- &
+ epsilondev_loc_crust_mantle(1,i,j,k) - epsilondev_loc_crust_mantle(2,i,j,k)
+ eps_loc(1,2)=epsilondev_loc_crust_mantle(3,i,j,k)
+ eps_loc(1,3)=epsilondev_loc_crust_mantle(4,i,j,k)
+ eps_loc(2,3)=epsilondev_loc_crust_mantle(5,i,j,k)
+
eps_loc(2,1)=eps_loc(1,2)
eps_loc(3,1)=eps_loc(1,3)
eps_loc(3,2)=eps_loc(2,3)
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/yyyy_will_need_to_add_UNDO_ATT_NT_DUMP_to_all_EXAMPLE_Par_files
===================================================================
More information about the CIG-COMMITS
mailing list