[cig-commits] r12616 - in seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta: . src
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Tue Aug 12 14:42:28 PDT 2008
Author: dkomati1
Date: 2008-08-12 14:42:28 -0700 (Tue, 12 Aug 2008)
New Revision: 12616
Added:
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_central_cube.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_scalar.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_vector.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/attenuation_model.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_central_cube_buffers.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_chunk_buffers.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_receivers.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_sources.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/main_program.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.F90
Removed:
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_before.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_scalar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_vector.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/attenuation_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_meshfem1.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_meshfem2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_specfem1.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_specfem2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_central_cube_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_chunk_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declarations_main.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declarations_mesher.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/main_program.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.f90
Modified:
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.bgl
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_mantle_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/auto_ner.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_element_properties.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sea99_s_model.f90
Log:
committed the serial version to test stability on one mesh slice without MPI;
fixed and improved several small things in the MPI version as well;
updated the Makefile and the compiler options for both versions;
also removed some useless white spaces
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile 2008-08-12 21:42:28 UTC (rev 12616)
@@ -36,35 +36,44 @@
#
FC = ifort
MPIFC = mpif90
-FLAGS_NO_CHECK = -O1 -vec-report0 -e03 -std03 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check all -align sequence -assume byterecl -fpe0 -ftz -traceback -ftrapuv
-#FLAGS_NO_CHECK = -O3 -xP -vec-report0 -e03 -std03 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check nobounds -align sequence -assume byterecl -fpe3 -ftz
+MPIFLAGS = -DUSE_MPI # -lmpi
+#FLAGS_NO_CHECK = -O1 -vec-report0 -e03 -std03 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check nobounds -align sequence -assume byterecl -fpe0 -ftz -traceback -ftrapuv
+FLAGS_NO_CHECK = -O3 -xP -vec-report0 -e03 -std03 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check nobounds -align sequence -assume byterecl -fpe3 -ftz
#
# GNU gfortran
#
#FC = gfortran
#MPIFC = /opt/mpich2_gfortran/bin/mpif90
-#FLAGS_NO_CHECK = -std=f2003 -fimplicit-none -frange-check -O3 -fmax-errors=10 -pedantic -pedantic-errors -Waliasing -Wampersand -Wcharacter-truncation -Wline-truncation -Wsurprising -Wno-tabs -Wunderflow -fno-trapping-math -fbounds-check
+#MPIFLAGS = -DUSE_MPI
+#FLAGS_NO_CHECK = -std=f2003 -fimplicit-none -frange-check -O3 -fmax-errors=10 -pedantic -pedantic-errors -Waliasing -Wampersand -Wcharacter-truncation -Wline-truncation -Wsurprising -Wno-tabs -Wunderflow -fno-trapping-math # -fbounds-check
#
# Portland pgf90
#
#FC = pgf90
#MPIFC = mpif90
-#FLAGS_NO_CHECK = -fast -Mnobounds -Minline -Mneginfo -Mdclchk -Knoieee -Minform=warn -Mstandard -fastsse -tp amd64e
+#MPIFLAGS = -DUSE_MPI
+#FLAGS_NO_CHECK = -fast -Mnobounds -Minline -Mdclchk -Knoieee -fastsse -tp amd64e -Minform=warn
#
# IBM xlf
#
#FC = xlf_r
#MPIFC = mpxlf90
-#FLAGS_NO_CHECK = -O3 -qnosave -qstrict -q64 -qtune=auto -qarch=auto -qcache=auto -qfree=f90 -Q -qsuffix=f=f90 -qhalt=w -qlanglvl=2003pure -qnoflttrap
+#MPIFLAGS = -WF,-DUSE_MPI
+#FLAGS_NO_CHECK = -O3 -qstrict -q64 -qnosave -qtune=auto -qarch=auto -qcache=auto -qfree=f90 -Q -qsuffix=f=f90 -qhalt=w
+#
# One can also use -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap -qinitauto=7FBFFFFF to trap errors
# on MareNostrum at the Barcelona SuperComputing Center (Spain) use
-# -qtune=ppc970 -qarch=ppc64v -qsave -qstrict instead of -qnosave -qstrict -qtune=auto -qarch=auto
+# -qsave -qtune=ppc970 -qarch=ppc64v instead of -qnosave -qtune=auto -qarch=auto
# otherwise the IBM compiler allocates the arrays in the stack and the code crashes
# if the stack size is too small (it is limited to 1GB on MareNostrum)
+#######
+####### no need to change anything below this
+#######
+
FLAGS_CHECK = $(FLAGS_NO_CHECK)
FCFLAGS_f90 =
MPILIBS =
@@ -72,12 +81,13 @@
SPECINC = setup/
OUTPUT_FILES_INC = OUTPUT_FILES/
+CURRENT_INC = src/
BIN = bin
-FCCOMPILE_CHECK = ${FC} ${FCFLAGS} $(FLAGS_CHECK) -I$(SPECINC) -I$(OUTPUT_FILES_INC)
-FCCOMPILE_NO_CHECK = ${FC} ${FCFLAGS} $(FLAGS_NO_CHECK) -I$(SPECINC) -I$(OUTPUT_FILES_INC)
-MPIFCCOMPILE_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_CHECK) -I$(SPECINC) -I$(OUTPUT_FILES_INC)
-MPIFCCOMPILE_NO_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK) -I$(SPECINC) -I$(OUTPUT_FILES_INC)
+FCCOMPILE_CHECK = ${FC} ${FCFLAGS} $(FLAGS_CHECK) -I$(CURRENT_INC) -I$(SPECINC) -I$(OUTPUT_FILES_INC)
+FCCOMPILE_NO_CHECK = ${FC} ${FCFLAGS} $(FLAGS_NO_CHECK) -I$(CURRENT_INC) -I$(SPECINC) -I$(OUTPUT_FILES_INC)
+MPIFCCOMPILE_CHECK = ${MPIFC} ${FCFLAGS} $(MPIFLAGS) $(FLAGS_CHECK) -I$(CURRENT_INC) -I$(SPECINC) -I$(OUTPUT_FILES_INC)
+MPIFCCOMPILE_NO_CHECK = ${MPIFC} ${FCFLAGS} $(MPIFLAGS) $(FLAGS_NO_CHECK) -I$(CURRENT_INC) -I$(SPECINC) -I$(OUTPUT_FILES_INC)
CC = gcc
CFLAGS = -g -O2
@@ -102,6 +112,8 @@
$O/assemble_MPI_vector.o \
$O/attenuation_model.o \
$O/calc_jacobian.o \
+ $O/convert_time.o \
+ $O/calendar.o \
$O/comp_source_spectrum.o \
$O/comp_source_time_function.o \
$O/compute_arrays_source.o \
@@ -240,8 +252,8 @@
### optimized flags and dependence on values from mesher here
###
-$O/specfem3D.o: $(SPECINC)/constants.h $(OUTPUT_FILES_INC)/values_from_mesher.h $S/specfem3D.f90
- ${MPIFCCOMPILE_NO_CHECK} -c -o $O/specfem3D.o ${FCFLAGS_f90} $S/specfem3D.f90
+$O/specfem3D.o: $(SPECINC)/constants.h $(OUTPUT_FILES_INC)/values_from_mesher.h $S/specfem3D.F90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/specfem3D.o ${FCFLAGS_f90} $S/specfem3D.F90
$O/compute_forces_crust_mantle.o: $(SPECINC)/constants.h $(OUTPUT_FILES_INC)/values_from_mesher.h $S/compute_forces_crust_mantle.f90
${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_crust_mantle.o ${FCFLAGS_f90} $S/compute_forces_crust_mantle.f90
@@ -253,15 +265,15 @@
${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_inner_core.o ${FCFLAGS_f90} $S/compute_forces_inner_core.f90
### use MPI here
-$O/assemble_MPI_vector.o: $(SPECINC)/constants.h $S/assemble_MPI_vector.f90
- ${MPIFCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_vector.o ${FCFLAGS_f90} $S/assemble_MPI_vector.f90
+$O/assemble_MPI_vector.o: $(SPECINC)/constants.h $S/assemble_MPI_vector.F90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_vector.o ${FCFLAGS_f90} $S/assemble_MPI_vector.F90
### use MPI here
-$O/assemble_MPI_scalar.o: $(SPECINC)/constants.h $S/assemble_MPI_scalar.f90
- ${MPIFCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_scalar.o ${FCFLAGS_f90} $S/assemble_MPI_scalar.f90
+$O/assemble_MPI_scalar.o: $(SPECINC)/constants.h $S/assemble_MPI_scalar.F90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_scalar.o ${FCFLAGS_f90} $S/assemble_MPI_scalar.F90
-$O/assemble_MPI_central_cube.o: $(SPECINC)/constants.h $(OUTPUT_FILES_INC)/values_from_mesher.h $S/assemble_MPI_central_cube.f90
- ${MPIFCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_central_cube.o ${FCFLAGS_f90} $S/assemble_MPI_central_cube.f90
+$O/assemble_MPI_central_cube.o: $(SPECINC)/constants.h $(OUTPUT_FILES_INC)/values_from_mesher.h $S/assemble_MPI_central_cube.F90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_central_cube.o ${FCFLAGS_f90} $S/assemble_MPI_central_cube.F90
###
### regular compilation options here
@@ -277,23 +289,23 @@
${FCCOMPILE_CHECK} -c -o $O/comp_source_time_function.o ${FCFLAGS_f90} $S/comp_source_time_function.f90
## use MPI here
-$O/create_chunk_buffers.o: $(SPECINC)/constants.h $S/create_chunk_buffers.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/create_chunk_buffers.o ${FCFLAGS_f90} $S/create_chunk_buffers.f90
+$O/create_chunk_buffers.o: $(SPECINC)/constants.h $S/create_chunk_buffers.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/create_chunk_buffers.o ${FCFLAGS_f90} $S/create_chunk_buffers.F90
$O/sort_array_coordinates.o: $(SPECINC)/constants.h $S/sort_array_coordinates.f90
${FCCOMPILE_CHECK} -c -o $O/sort_array_coordinates.o ${FCFLAGS_f90} $S/sort_array_coordinates.f90
### use MPI here
-$O/locate_sources.o: $(SPECINC)/constants.h $S/locate_sources.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/locate_sources.o ${FCFLAGS_f90} $S/locate_sources.f90
+$O/locate_sources.o: $(SPECINC)/constants.h $S/locate_sources.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/locate_sources.o ${FCFLAGS_f90} $S/locate_sources.F90
### use MPI here
-$O/locate_receivers.o: $(SPECINC)/constants.h $S/locate_receivers.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/locate_receivers.o ${FCFLAGS_f90} $S/locate_receivers.f90
+$O/locate_receivers.o: $(SPECINC)/constants.h $S/locate_receivers.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/locate_receivers.o ${FCFLAGS_f90} $S/locate_receivers.F90
## use MPI here
-$O/exit_mpi.o: $(SPECINC)/constants.h $S/exit_mpi.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/exit_mpi.o ${FCFLAGS_f90} $S/exit_mpi.f90
+$O/exit_mpi.o: $(SPECINC)/constants.h $S/exit_mpi.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/exit_mpi.o ${FCFLAGS_f90} $S/exit_mpi.F90
$O/count_number_of_sources.o: $(SPECINC)/constants.h $S/count_number_of_sources.f90
${FCCOMPILE_CHECK} -c -o $O/count_number_of_sources.o ${FCFLAGS_f90} $S/count_number_of_sources.f90
@@ -310,6 +322,12 @@
$O/calc_jacobian.o: $(SPECINC)/constants.h $S/calc_jacobian.f90
${FCCOMPILE_CHECK} -c -o $O/calc_jacobian.o ${FCFLAGS_f90} $S/calc_jacobian.f90
+$O/convert_time.o: $(SPECINC)/constants.h $S/convert_time.f90
+ ${FCCOMPILE_CHECK} -c -o $O/convert_time.o ${FCFLAGS_f90} $S/convert_time.f90
+
+$O/calendar.o: $(SPECINC)/constants.h $S/calendar.f90
+ ${FCCOMPILE_CHECK} -c -o $O/calendar.o ${FCFLAGS_f90} $S/calendar.f90
+
$O/crustal_model.o: $(SPECINC)/constants.h $S/crustal_model.f90
${FCCOMPILE_CHECK} -c -o $O/crustal_model.o ${FCFLAGS_f90} $S/crustal_model.f90
@@ -331,8 +349,8 @@
$O/get_cmt.o: $(SPECINC)/constants.h $S/get_cmt.f90
${FCCOMPILE_CHECK} -c -o $O/get_cmt.o ${FCFLAGS_f90} $S/get_cmt.f90
-$O/get_event_info.o: $(SPECINC)/constants.h $S/get_event_info.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/get_event_info.o ${FCFLAGS_f90} $S/get_event_info.f90
+$O/get_event_info.o: $(SPECINC)/constants.h $S/get_event_info.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/get_event_info.o ${FCFLAGS_f90} $S/get_event_info.F90
$O/get_ellipticity.o: $(SPECINC)/constants.h $S/get_ellipticity.f90
${FCCOMPILE_CHECK} -c -o $O/get_ellipticity.o ${FCFLAGS_f90} $S/get_ellipticity.f90
@@ -374,12 +392,12 @@
${FCCOMPILE_CHECK} -c -o $O/euler_angles.o ${FCFLAGS_f90} $S/euler_angles.f90
## use MPI here
-$O/main_program.o: $(SPECINC)/constants.h $S/main_program.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/main_program.o ${FCFLAGS_f90} $S/main_program.f90
+$O/main_program.o: $(SPECINC)/constants.h $S/main_program.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/main_program.o ${FCFLAGS_f90} $S/main_program.F90
## use MPI here
-$O/meshfem3D.o: $(SPECINC)/constants.h $S/meshfem3D.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/meshfem3D.o ${FCFLAGS_f90} $S/meshfem3D.f90
+$O/meshfem3D.o: $(SPECINC)/constants.h $S/meshfem3D.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/meshfem3D.o ${FCFLAGS_f90} $S/meshfem3D.F90
$O/spline_routines.o: $(SPECINC)/constants.h $S/spline_routines.f90
${FCCOMPILE_CHECK} -c -o $O/spline_routines.o ${FCFLAGS_f90} $S/spline_routines.f90
@@ -444,8 +462,8 @@
$O/add_topography_icb.o: $(SPECINC)/constants.h $S/add_topography_icb.f90
${FCCOMPILE_CHECK} -c -o $O/add_topography_icb.o ${FCFLAGS_f90} $S/add_topography_icb.f90
-$O/write_seismograms.o: $(SPECINC)/constants.h $S/write_seismograms.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/write_seismograms.o ${FCFLAGS_f90} $S/write_seismograms.f90
+$O/write_seismograms.o: $(SPECINC)/constants.h $S/write_seismograms.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/write_seismograms.o ${FCFLAGS_f90} $S/write_seismograms.F90
$O/lagrange_poly.o: $(SPECINC)/constants.h $S/lagrange_poly.f90
${FCCOMPILE_CHECK} -c -o $O/lagrange_poly.o ${FCFLAGS_f90} $S/lagrange_poly.f90
@@ -453,8 +471,8 @@
$O/recompute_jacobian.o: $(SPECINC)/constants.h $S/recompute_jacobian.f90
${FCCOMPILE_CHECK} -c -o $O/recompute_jacobian.o ${FCFLAGS_f90} $S/recompute_jacobian.f90
-$O/create_regions_mesh.o: $(SPECINC)/constants.h $S/create_regions_mesh.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/create_regions_mesh.o ${FCFLAGS_f90} $S/create_regions_mesh.f90
+$O/create_regions_mesh.o: $(SPECINC)/constants.h $S/create_regions_mesh.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/create_regions_mesh.o ${FCFLAGS_f90} $S/create_regions_mesh.F90
$O/define_derivation_matrices.o: $(SPECINC)/constants.h $S/define_derivation_matrices.f90
${FCCOMPILE_CHECK} -c -o $O/define_derivation_matrices.o ${FCFLAGS_f90} $S/define_derivation_matrices.f90
@@ -462,11 +480,11 @@
$O/compute_arrays_source.o: $(SPECINC)/constants.h $S/compute_arrays_source.f90
${FCCOMPILE_CHECK} -c -o $O/compute_arrays_source.o ${FCFLAGS_f90} $S/compute_arrays_source.f90
-$O/create_central_cube_buffers.o: $(SPECINC)/constants.h $S/create_central_cube_buffers.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/create_central_cube_buffers.o ${FCFLAGS_f90} $S/create_central_cube_buffers.f90
+$O/create_central_cube_buffers.o: $(SPECINC)/constants.h $S/create_central_cube_buffers.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/create_central_cube_buffers.o ${FCFLAGS_f90} $S/create_central_cube_buffers.F90
-$O/attenuation_model.o: $(SPECINC)/constants.h $S/attenuation_model.f90 $O/model_ak135.o $O/model_1066a.o $O/model_ref.o
- ${MPIFCCOMPILE_CHECK} -c -o $O/attenuation_model.o ${FCFLAGS_f90} $S/attenuation_model.f90
+$O/attenuation_model.o: $(SPECINC)/constants.h $S/attenuation_model.F90 $O/model_ak135.o $O/model_1066a.o $O/model_ref.o
+ ${MPIFCCOMPILE_CHECK} -c -o $O/attenuation_model.o ${FCFLAGS_f90} $S/attenuation_model.F90
$O/gll_library.o: $(SPECINC)/constants.h $S/gll_library.f90
${FCCOMPILE_CHECK} -c -o $O/gll_library.o ${FCFLAGS_f90} $S/gll_library.f90
@@ -486,8 +504,8 @@
$O/stretching_function.o: $(SPECINC)/constants.h $S/stretching_function.f90
${FCCOMPILE_CHECK} -c -o $O/stretching_function.o ${FCFLAGS_f90} $S/stretching_function.f90
-$O/read_compute_parameters.o: $(SPECINC)/constants.h $S/read_compute_parameters.f90
- ${FCCOMPILE_CHECK} -c -o $O/read_compute_parameters.o ${FCFLAGS_f90} $S/read_compute_parameters.f90
+$O/read_compute_parameters.o: $(SPECINC)/constants.h $S/read_compute_parameters.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/read_compute_parameters.o ${FCFLAGS_f90} $S/read_compute_parameters.F90
$O/auto_ner.o: $(SPECINC)/constants.h $S/auto_ner.f90
${FCCOMPILE_CHECK} -c -o $O/auto_ner.o ${FCFLAGS_f90} $S/auto_ner.f90
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.bgl
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.bgl 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile.bgl 2008-08-12 21:42:28 UTC (rev 12616)
@@ -31,8 +31,8 @@
FCFLAGS = #-g
MPIFC = mpxlf90 -qmaxmem=-1 -qxflag=stacksize
MPILIBS =
-FLAGS_NO_CHECK = -O3 -qarch=440 -qtune=440 -qfree=f90 -Q -qsuffix=f=f90
-FLAGS_CHECK = $(FLAGS_NO_CHECK)
+FLAGS_NO_CHECK = -O3 -qstrict -qarch=440 -qtune=440 -qfree=f90 -Q -qsuffix=f=f90
+FLAGS_CHECK = $(FLAGS_NO_CHECK)
FCFLAGS_f90 =
CC = mpcc -I$(SPECINC)
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_before.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_before.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/allocate_before.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,23 +0,0 @@
-
-!! DK DK added this for merged version
- allocate(xelm_store_crust_mantle(NGNOD,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) stop 'error memory allocation merged version'
- allocate(yelm_store_crust_mantle(NGNOD,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) stop 'error memory allocation merged version'
- allocate(zelm_store_crust_mantle(NGNOD,NSPEC_CRUST_MANTLE),stat=ier)
- if(ier /= 0) stop 'error memory allocation merged version'
-
- allocate(xelm_store_outer_core(NGNOD,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) stop 'error memory allocation merged version'
- allocate(yelm_store_outer_core(NGNOD,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) stop 'error memory allocation merged version'
- allocate(zelm_store_outer_core(NGNOD,NSPEC_OUTER_CORE),stat=ier)
- if(ier /= 0) stop 'error memory allocation merged version'
-
- allocate(xelm_store_inner_core(NGNOD,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) stop 'error memory allocation merged version'
- allocate(yelm_store_inner_core(NGNOD,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) stop 'error memory allocation merged version'
- allocate(zelm_store_inner_core(NGNOD,NSPEC_INNER_CORE),stat=ier)
- if(ier /= 0) stop 'error memory allocation merged version'
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_mantle_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_mantle_model.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/anisotropic_mantle_model.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -74,7 +74,7 @@
colat = theta / DEGREES_TO_RADIANS
! uncomment this line to suppress the anisotropic mantle model
-! call exit_MPI_without_rank('please provide an anisotropic mantle model for subroutine aniso_mantle_model')
+! call exit_mpi_without_rank('please provide an anisotropic mantle model for subroutine aniso_mantle_model')
! assign the local (d_ij) or global (c_ij) anisotropic parameters.
! The c_ij are the coefficients in the global
@@ -128,7 +128,7 @@
! dimensionalize
depth = R_EARTH_KM*(R_UNIT_SPHERE - r)
- if(depth <= pro(nz0) .or. depth >= pro(1)) call exit_MPI_without_rank('r out of range in build_cij')
+ if(depth <= pro(nz0) .or. depth >= pro(1)) call exit_mpi_without_rank('r out of range in build_cij')
itheta = int(theta + pxy0)/pxy0
ilon = int(phi + pxy0)/pxy0
tet = theta
@@ -153,12 +153,12 @@
icz1 = icz0 + 1
! check that parameters make sense
- if(ict0 < 1 .or. ict0 > nx0) call exit_MPI_without_rank('ict0 out of range')
- if(ict1 < 1 .or. ict1 > nx0) call exit_MPI_without_rank('ict1 out of range')
- if(icp0 < 1 .or. icp0 > ny0) call exit_MPI_without_rank('icp0 out of range')
- if(icp1 < 1 .or. icp1 > ny0) call exit_MPI_without_rank('icp1 out of range')
- if(icz0 < 1 .or. icz0 > nz0) call exit_MPI_without_rank('icz0 out of range')
- if(icz1 < 1 .or. icz1 > nz0) call exit_MPI_without_rank('icz1 out of range')
+ if(ict0 < 1 .or. ict0 > nx0) call exit_mpi_without_rank('ict0 out of range')
+ if(ict1 < 1 .or. ict1 > nx0) call exit_mpi_without_rank('ict1 out of range')
+ if(icp0 < 1 .or. icp0 > ny0) call exit_mpi_without_rank('icp0 out of range')
+ if(icp1 < 1 .or. icp1 > ny0) call exit_mpi_without_rank('icp1 out of range')
+ if(icz0 < 1 .or. icz0 > nz0) call exit_mpi_without_rank('icz0 out of range')
+ if(icz1 < 1 .or. icz1 > nz0) call exit_mpi_without_rank('icz1 out of range')
do ipar = 1,14
anispara(ipar,1,1) = beta(ipar,icz0,ict0,icp0)
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_central_cube.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_central_cube.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_central_cube.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_central_cube.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,276 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine 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, buffer_slices2, ibool_central_cube, &
+ receiver_cube_from_slices, ibool_inner_core, idoubling_inner_core, NSPEC_INNER_CORE, &
+ ibelm_bottom_inner_core, NSPEC2D_BOTTOM_INNER_CORE,NGLOB_INNER_CORE,vector_assemble,ndim_assemble)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+ include 'constants.h'
+
+! for matching with central cube in inner core
+ integer ichunk, nb_msgs_theor_in_cube, npoin2D_cube_from_slices
+ integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
+ double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices,buffer_slices2
+ double precision, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM) :: buffer_all_cube_from_slices
+ integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
+ integer receiver_cube_from_slices
+
+! local to global mapping
+ integer NSPEC_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE, NGLOB_INNER_CORE
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
+
+! vector
+ integer ndim_assemble
+ real(kind=CUSTOM_REAL), dimension(ndim_assemble,NGLOB_INNER_CORE) :: vector_assemble
+
+ integer ipoin,idimension, ispec2D, ispec
+ integer i,j,k
+ integer sender,receiver,imsg
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: array_central_cube
+
+! MPI status of messages to be received
+#ifdef USE_MPI
+ integer, dimension(MPI_STATUS_SIZE) :: msg_status
+ integer :: ier
+#endif
+
+! mask
+ logical, dimension(NGLOB_INNER_CORE) :: mask
+
+!---
+!--- now use buffers to assemble mass matrix with central cube once and for all
+!---
+
+! on chunks AB and AB_ANTIPODE, receive all the messages from slices
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ do imsg = 1,nb_msgs_theor_in_cube-1
+
+! receive buffers from slices
+ sender = sender_from_slices_to_cube(imsg)
+#ifdef USE_MPI
+ call MPI_RECV(buffer_slices, &
+ ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! copy buffer in 2D array for each slice
+ buffer_all_cube_from_slices(imsg,:,1:ndim_assemble) = buffer_slices(:,1:ndim_assemble)
+
+ enddo
+ endif
+
+! send info to central cube from all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
+ if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
+
+! for bottom elements in contact with central cube from the slices side
+ ipoin = 0
+ do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
+
+ ispec = ibelm_bottom_inner_core(ispec2D)
+
+! only for DOFs exactly on surface of central cube (bottom of these elements)
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ buffer_slices(ipoin,1:ndim_assemble) = dble(vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)))
+ enddo
+ enddo
+ enddo
+
+! send buffer to central cube
+ receiver = receiver_cube_from_slices
+#ifdef USE_MPI
+ call MPI_SEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
+ MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+
+ endif ! end sending info to central cube
+
+
+! exchange of their bottom faces between chunks AB and AB_ANTIPODE
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ ipoin = 0
+ do ispec = NSPEC_INNER_CORE, 1, -1
+ if (idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE) then
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ buffer_slices(ipoin,1:ndim_assemble) = dble(vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)))
+ enddo
+ enddo
+ endif
+ enddo
+
+ sender = sender_from_slices_to_cube(nb_msgs_theor_in_cube)
+
+#ifdef USE_MPI
+ call MPI_SENDRECV(buffer_slices,ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,receiver_cube_from_slices, &
+ itag,buffer_slices2,ndim_assemble*npoin2D_cube_from_slices,&
+ MPI_DOUBLE_PRECISION,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+ buffer_all_cube_from_slices(nb_msgs_theor_in_cube,:,1:ndim_assemble) = buffer_slices2(:,1:ndim_assemble)
+
+ endif
+
+!--- now we need to assemble the contributions
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ do idimension = 1,ndim_assemble
+! erase contributions to central cube array
+ array_central_cube(:) = 0._CUSTOM_REAL
+
+! use indirect addressing to store contributions only once
+! distinguish between single and double precision for reals
+ do imsg = 1,nb_msgs_theor_in_cube-1
+ do ipoin = 1,npoin2D_cube_from_slices
+ if(CUSTOM_REAL == SIZE_REAL) then
+ array_central_cube(ibool_central_cube(imsg,ipoin)) = sngl(buffer_all_cube_from_slices(imsg,ipoin,idimension))
+ else
+ array_central_cube(ibool_central_cube(imsg,ipoin)) = buffer_all_cube_from_slices(imsg,ipoin,idimension)
+ endif
+ enddo
+ enddo
+! add the constribution of AB or AB_ANTIPODE to sum with the external slices on the edges
+! use a mask to avoid taking the same point into account several times.
+ mask(:) = .false.
+ do ipoin = 1,npoin2D_cube_from_slices
+ if (.not. mask(ibool_central_cube(nb_msgs_theor_in_cube,ipoin))) then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = &
+ array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) + &
+ sngl(buffer_all_cube_from_slices(nb_msgs_theor_in_cube,ipoin,idimension))
+ else
+ array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = &
+ array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) + &
+ buffer_all_cube_from_slices(nb_msgs_theor_in_cube,ipoin,idimension)
+ endif
+ mask(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = .true.
+ endif
+ enddo
+
+! suppress degrees of freedom already assembled at top of cube on edges
+ do ispec = 1,NSPEC_INNER_CORE
+ if(idoubling_inner_core(ispec) == IFLAG_TOP_CENTRAL_CUBE) then
+ k = NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ array_central_cube(ibool_inner_core(i,j,k,ispec)) = 0._CUSTOM_REAL
+ enddo
+ enddo
+ endif
+ enddo
+
+! assemble contributions
+ vector_assemble(idimension,:) = vector_assemble(idimension,:) + array_central_cube(:)
+
+! copy sum back
+ do imsg = 1,nb_msgs_theor_in_cube-1
+ do ipoin = 1,npoin2D_cube_from_slices
+ buffer_all_cube_from_slices(imsg,ipoin,idimension) = vector_assemble(idimension,ibool_central_cube(imsg,ipoin))
+ enddo
+ enddo
+
+ enddo
+
+ endif
+
+!----------
+
+! receive info from central cube on all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
+ if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
+
+! receive buffers from slices
+ sender = receiver_cube_from_slices
+#ifdef USE_MPI
+ call MPI_RECV(buffer_slices, &
+ ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! for bottom elements in contact with central cube from the slices side
+ ipoin = 0
+ do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
+
+ ispec = ibelm_bottom_inner_core(ispec2D)
+
+! only for DOFs exactly on surface of central cube (bottom of these elements)
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)) = sngl(buffer_slices(ipoin,1:ndim_assemble))
+ else
+ vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)) = buffer_slices(ipoin,1:ndim_assemble)
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ endif ! end receiving info from central cube
+
+!------- send info back from central cube to slices
+
+! on chunk AB & CHUNK_AB_ANTIPODE, send all the messages to slices
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ do imsg = 1,nb_msgs_theor_in_cube-1
+
+! copy buffer in 2D array for each slice
+ buffer_slices(:,1:ndim_assemble) = buffer_all_cube_from_slices(imsg,:,1:ndim_assemble)
+
+! send buffers to slices
+ receiver = sender_from_slices_to_cube(imsg)
+#ifdef USE_MPI
+ call MPI_SEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
+ MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+
+ enddo
+ endif
+
+end subroutine assemble_MPI_central_cube
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_central_cube.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_central_cube.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_central_cube.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,261 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-subroutine 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, buffer_slices2, ibool_central_cube, &
- receiver_cube_from_slices, ibool_inner_core, idoubling_inner_core, NSPEC_INNER_CORE, &
- ibelm_bottom_inner_core, NSPEC2D_BOTTOM_INNER_CORE,NGLOB_INNER_CORE,vector_assemble,ndim_assemble)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
- include 'constants.h'
-
-! for matching with central cube in inner core
- integer ichunk, nb_msgs_theor_in_cube, npoin2D_cube_from_slices
- integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
- double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices,buffer_slices2
- double precision, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM) :: buffer_all_cube_from_slices
- integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
- integer receiver_cube_from_slices
-
-! local to global mapping
- integer NSPEC_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE, NGLOB_INNER_CORE
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
-
-! vector
- integer ndim_assemble
- real(kind=CUSTOM_REAL), dimension(ndim_assemble,NGLOB_INNER_CORE) :: vector_assemble
-
- integer ipoin,idimension, ispec2D, ispec
- integer i,j,k
- integer sender,receiver,imsg
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: array_central_cube
-
-! MPI status of messages to be received
- integer msg_status(MPI_STATUS_SIZE), ier
-
-! mask
- logical, dimension(NGLOB_INNER_CORE) :: mask
-
-!---
-!--- now use buffers to assemble mass matrix with central cube once and for all
-!---
-
-! on chunks AB and AB_ANTIPODE, receive all the messages from slices
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do imsg = 1,nb_msgs_theor_in_cube-1
-
-! receive buffers from slices
- sender = sender_from_slices_to_cube(imsg)
- call MPI_RECV(buffer_slices, &
- ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! copy buffer in 2D array for each slice
- buffer_all_cube_from_slices(imsg,:,1:ndim_assemble) = buffer_slices(:,1:ndim_assemble)
-
- enddo
- endif
-
-! send info to central cube from all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
-
-! for bottom elements in contact with central cube from the slices side
- ipoin = 0
- do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
-
- ispec = ibelm_bottom_inner_core(ispec2D)
-
-! only for DOFs exactly on surface of central cube (bottom of these elements)
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- buffer_slices(ipoin,1:ndim_assemble) = dble(vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)))
- enddo
- enddo
- enddo
-
-! send buffer to central cube
- receiver = receiver_cube_from_slices
- call MPI_SEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
- MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
-
- endif ! end sending info to central cube
-
-
-! exchange of their bottom faces between chunks AB and AB_ANTIPODE
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- ipoin = 0
- do ispec = NSPEC_INNER_CORE, 1, -1
- if (idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE) then
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- buffer_slices(ipoin,1:ndim_assemble) = dble(vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)))
- enddo
- enddo
- endif
- enddo
-
- sender = sender_from_slices_to_cube(nb_msgs_theor_in_cube)
-
- call MPI_SENDRECV(buffer_slices,ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,receiver_cube_from_slices, &
- itag,buffer_slices2,ndim_assemble*npoin2D_cube_from_slices,&
- MPI_DOUBLE_PRECISION,sender,itag,MPI_COMM_WORLD,msg_status,ier)
-
- buffer_all_cube_from_slices(nb_msgs_theor_in_cube,:,1:ndim_assemble) = buffer_slices2(:,1:ndim_assemble)
-
- endif
-
-!--- now we need to assemble the contributions
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do idimension = 1,ndim_assemble
-! erase contributions to central cube array
- array_central_cube(:) = 0._CUSTOM_REAL
-
-! use indirect addressing to store contributions only once
-! distinguish between single and double precision for reals
- do imsg = 1,nb_msgs_theor_in_cube-1
- do ipoin = 1,npoin2D_cube_from_slices
- if(CUSTOM_REAL == SIZE_REAL) then
- array_central_cube(ibool_central_cube(imsg,ipoin)) = sngl(buffer_all_cube_from_slices(imsg,ipoin,idimension))
- else
- array_central_cube(ibool_central_cube(imsg,ipoin)) = buffer_all_cube_from_slices(imsg,ipoin,idimension)
- endif
- enddo
- enddo
-! add the constribution of AB or AB_ANTIPODE to sum with the external slices on the edges
-! use a mask to avoid taking the same point into account several times.
- mask(:) = .false.
- do ipoin = 1,npoin2D_cube_from_slices
- if (.not. mask(ibool_central_cube(nb_msgs_theor_in_cube,ipoin))) then
- if(CUSTOM_REAL == SIZE_REAL) then
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = &
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) + &
- sngl(buffer_all_cube_from_slices(nb_msgs_theor_in_cube,ipoin,idimension))
- else
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = &
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) + &
- buffer_all_cube_from_slices(nb_msgs_theor_in_cube,ipoin,idimension)
- endif
- mask(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = .true.
- endif
- enddo
-
-! suppress degrees of freedom already assembled at top of cube on edges
- do ispec = 1,NSPEC_INNER_CORE
- if(idoubling_inner_core(ispec) == IFLAG_TOP_CENTRAL_CUBE) then
- k = NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- array_central_cube(ibool_inner_core(i,j,k,ispec)) = 0._CUSTOM_REAL
- enddo
- enddo
- endif
- enddo
-
-! assemble contributions
- vector_assemble(idimension,:) = vector_assemble(idimension,:) + array_central_cube(:)
-
-! copy sum back
- do imsg = 1,nb_msgs_theor_in_cube-1
- do ipoin = 1,npoin2D_cube_from_slices
- buffer_all_cube_from_slices(imsg,ipoin,idimension) = vector_assemble(idimension,ibool_central_cube(imsg,ipoin))
- enddo
- enddo
-
- enddo
-
- endif
-
-!----------
-
-! receive info from central cube on all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
-
-! receive buffers from slices
- sender = receiver_cube_from_slices
- call MPI_RECV(buffer_slices, &
- ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! for bottom elements in contact with central cube from the slices side
- ipoin = 0
- do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
-
- ispec = ibelm_bottom_inner_core(ispec2D)
-
-! only for DOFs exactly on surface of central cube (bottom of these elements)
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)) = sngl(buffer_slices(ipoin,1:ndim_assemble))
- else
- vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)) = buffer_slices(ipoin,1:ndim_assemble)
- endif
-
- enddo
- enddo
- enddo
-
- endif ! end receiving info from central cube
-
-!------- send info back from central cube to slices
-
-! on chunk AB & CHUNK_AB_ANTIPODE, send all the messages to slices
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do imsg = 1,nb_msgs_theor_in_cube-1
-
-! copy buffer in 2D array for each slice
- buffer_slices(:,1:ndim_assemble) = buffer_all_cube_from_slices(imsg,:,1:ndim_assemble)
-
-! send buffers to slices
- receiver = sender_from_slices_to_cube(imsg)
- call MPI_SEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
- MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
-
- enddo
- endif
-
-end subroutine assemble_MPI_central_cube
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_scalar.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_scalar.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_scalar.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_scalar.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,491 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! 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.
+!
+!=====================================================================
+
+!----
+!---- assemble the contributions between slices and chunks using MPI
+!----
+
+ subroutine assemble_MPI_scalar(myrank,array_val,nglob, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
+ npoin2D_faces,npoin2D_xi,npoin2D_eta, &
+ iboolfaces,iboolcorner, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces_scalar,buffer_received_faces_scalar,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NCHUNKS)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "precision.h"
+#endif
+
+ integer myrank,nglob,NCHUNKS
+
+! array to assemble
+ real(kind=CUSTOM_REAL), dimension(nglob) :: array_val
+
+ integer iproc_xi,iproc_eta,ichunk
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
+ integer npoin2D_faces(NUMFACES_SHARED)
+
+ integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY
+ integer NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL
+ integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS
+
+! for addressing of the slices
+ integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
+
+! 2-D addressing and buffers for summation between slices
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+
+! indirect addressing for each corner of the chunks
+ integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
+ integer icount_corners
+
+ integer :: npoin2D_max_all
+ integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
+ real(kind=CUSTOM_REAL), dimension(npoin2D_max_all) :: buffer_send_faces_scalar,buffer_received_faces_scalar
+
+! buffers for send and receive between corners of the chunks
+ real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL) :: buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar
+
+! ---- arrays to assemble between chunks
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+! MPI status of messages to be received
+#ifdef USE_MPI
+ integer, dimension(MPI_STATUS_SIZE) :: msg_status
+#endif
+
+ integer :: ipoin,ipoin2D,ipoin1D
+ integer :: sender,receiver
+ integer :: imsg,imsg_loop
+ integer :: icount_faces,npoin2D_chunks
+
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! check flag to see if we need to assemble (might be turned off when debugging)
+ if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) return
+
+! here we have to assemble all the contributions between slices using MPI
+
+!----
+!---- assemble the contributions between slices using MPI
+!----
+
+!----
+!---- first assemble along xi using the 2-D topology
+!----
+
+! assemble along xi only if more than one slice
+ if(NPROC_XI > 1) then
+
+! slices copy the right face into the buffer
+ do ipoin=1,npoin2D_xi(2)
+ buffer_send_faces_scalar(ipoin) = array_val(iboolright_xi(ipoin))
+ enddo
+
+! send messages forward along each row
+ if(iproc_xi == 0) then
+#ifdef USE_MPI
+ sender = MPI_PROC_NULL
+#endif
+ else
+ sender = addressing(ichunk,iproc_xi - 1,iproc_eta)
+ endif
+ if(iproc_xi == NPROC_XI-1) then
+#ifdef USE_MPI
+ receiver = MPI_PROC_NULL
+#endif
+ else
+ receiver = addressing(ichunk,iproc_xi + 1,iproc_eta)
+ endif
+#ifdef USE_MPI
+ call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! all slices add the buffer received to the contributions on the left face
+ if(iproc_xi > 0) then
+ do ipoin=1,npoin2D_xi(1)
+ array_val(iboolleft_xi(ipoin)) = array_val(iboolleft_xi(ipoin)) + &
+ buffer_received_faces_scalar(ipoin)
+ enddo
+ endif
+
+! the contributions are correctly assembled on the left side of each slice
+! now we have to send the result back to the sender
+! all slices copy the left face into the buffer
+ do ipoin=1,npoin2D_xi(1)
+ buffer_send_faces_scalar(ipoin) = array_val(iboolleft_xi(ipoin))
+ enddo
+
+! send messages backward along each row
+ if(iproc_xi == NPROC_XI-1) then
+#ifdef USE_MPI
+ sender = MPI_PROC_NULL
+#endif
+ else
+ sender = addressing(ichunk,iproc_xi + 1,iproc_eta)
+ endif
+ if(iproc_xi == 0) then
+#ifdef USE_MPI
+ receiver = MPI_PROC_NULL
+#endif
+ else
+ receiver = addressing(ichunk,iproc_xi - 1,iproc_eta)
+ endif
+#ifdef USE_MPI
+ call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! all slices copy the buffer received to the contributions on the right face
+ if(iproc_xi < NPROC_XI-1) then
+ do ipoin=1,npoin2D_xi(2)
+ array_val(iboolright_xi(ipoin)) = buffer_received_faces_scalar(ipoin)
+ enddo
+ endif
+
+ endif
+
+!----
+!---- then assemble along eta using the 2-D topology
+!----
+
+! assemble along eta only if more than one slice
+ if(NPROC_ETA > 1) then
+
+! slices copy the right face into the buffer
+ do ipoin=1,npoin2D_eta(2)
+ buffer_send_faces_scalar(ipoin) = array_val(iboolright_eta(ipoin))
+ enddo
+
+! send messages forward along each row
+ if(iproc_eta == 0) then
+#ifdef USE_MPI
+ sender = MPI_PROC_NULL
+#endif
+ else
+ sender = addressing(ichunk,iproc_xi,iproc_eta - 1)
+ endif
+ if(iproc_eta == NPROC_ETA-1) then
+#ifdef USE_MPI
+ receiver = MPI_PROC_NULL
+#endif
+ else
+ receiver = addressing(ichunk,iproc_xi,iproc_eta + 1)
+ endif
+#ifdef USE_MPI
+ call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! all slices add the buffer received to the contributions on the left face
+ if(iproc_eta > 0) then
+ do ipoin=1,npoin2D_eta(1)
+ array_val(iboolleft_eta(ipoin)) = array_val(iboolleft_eta(ipoin)) + &
+ buffer_received_faces_scalar(ipoin)
+ enddo
+ endif
+
+! the contributions are correctly assembled on the left side of each slice
+! now we have to send the result back to the sender
+! all slices copy the left face into the buffer
+ do ipoin=1,npoin2D_eta(1)
+ buffer_send_faces_scalar(ipoin) = array_val(iboolleft_eta(ipoin))
+ enddo
+
+! send messages backward along each row
+ if(iproc_eta == NPROC_ETA-1) then
+#ifdef USE_MPI
+ sender = MPI_PROC_NULL
+#endif
+ else
+ sender = addressing(ichunk,iproc_xi,iproc_eta + 1)
+ endif
+ if(iproc_eta == 0) then
+#ifdef USE_MPI
+ receiver = MPI_PROC_NULL
+#endif
+ else
+ receiver = addressing(ichunk,iproc_xi,iproc_eta - 1)
+ endif
+#ifdef USE_MPI
+ call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! all slices copy the buffer received to the contributions on the right face
+ if(iproc_eta < NPROC_ETA-1) then
+ do ipoin=1,npoin2D_eta(2)
+ array_val(iboolright_eta(ipoin)) = buffer_received_faces_scalar(ipoin)
+ enddo
+ endif
+
+ endif
+
+!----
+!---- start MPI assembling phase between chunks
+!----
+
+! check flag to see if we need to assemble (might be turned off when debugging)
+! and do not assemble if only one chunk
+ if (.not. ACTUALLY_ASSEMBLE_MPI_CHUNKS .or. NCHUNKS == 1) return
+
+! ***************************************************************
+! transmit messages in forward direction (iprocfrom -> iprocto)
+! ***************************************************************
+
+!---- put slices in receive mode
+!---- a given slice can belong to at most two faces
+
+! use three step scheme that can never deadlock
+! scheme for faces cannot deadlock even if NPROC_XI = NPROC_ETA = 1
+ do imsg_loop = 1,NUM_MSG_TYPES
+
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ sender = iprocfrom_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+#ifdef USE_MPI
+ call MPI_RECV(buffer_received_faces_scalar, &
+ npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+ do ipoin2D=1,npoin2D_chunks
+ array_val(iboolfaces(ipoin2D,icount_faces)) = &
+ array_val(iboolfaces(ipoin2D,icount_faces)) + buffer_received_faces_scalar(ipoin2D)
+ enddo
+ endif
+ enddo
+
+!---- put slices in send mode
+!---- a given slice can belong to at most two faces
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ receiver = iprocto_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+ do ipoin2D=1,npoin2D_chunks
+ buffer_send_faces_scalar(ipoin2D) = array_val(iboolfaces(ipoin2D,icount_faces))
+ enddo
+#ifdef USE_MPI
+ call MPI_SEND(buffer_send_faces_scalar,npoin2D_chunks, &
+ CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+ endif
+ enddo
+
+! *********************************************************************
+! transmit messages back in opposite direction (iprocto -> iprocfrom)
+! *********************************************************************
+
+!---- put slices in receive mode
+!---- a given slice can belong to at most two faces
+
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ sender = iprocto_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+#ifdef USE_MPI
+ call MPI_RECV(buffer_received_faces_scalar, &
+ npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+ do ipoin2D=1,npoin2D_chunks
+ array_val(iboolfaces(ipoin2D,icount_faces)) = buffer_received_faces_scalar(ipoin2D)
+ enddo
+ endif
+ enddo
+
+!---- put slices in send mode
+!---- a given slice can belong to at most two faces
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ receiver = iprocfrom_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+ do ipoin2D=1,npoin2D_chunks
+ buffer_send_faces_scalar(ipoin2D) = array_val(iboolfaces(ipoin2D,icount_faces))
+ enddo
+#ifdef USE_MPI
+ call MPI_SEND(buffer_send_faces_scalar,npoin2D_chunks, &
+ CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+ endif
+ enddo
+
+! end of anti-deadlocking loop
+ enddo
+
+!----
+!---- start MPI assembling corners
+!----
+
+! scheme for corners cannot deadlock even if NPROC_XI = NPROC_ETA = 1
+
+! ***************************************************************
+! transmit messages in forward direction (two workers -> master)
+! ***************************************************************
+
+ icount_corners = 0
+
+ do imsg = 1,NCORNERSCHUNKS
+
+ if(myrank == iproc_master_corners(imsg) .or. &
+ myrank == iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) icount_corners = icount_corners + 1
+
+!---- receive messages from the two workers on the master
+ if(myrank==iproc_master_corners(imsg)) then
+
+! receive from worker #1 and add to local array
+ sender = iproc_worker1_corners(imsg)
+#ifdef USE_MPI
+ call MPI_RECV(buffer_recv_chunkcorners_scalar,NGLOB1D_RADIAL, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+ do ipoin1D=1,NGLOB1D_RADIAL
+ array_val(iboolcorner(ipoin1D,icount_corners)) = array_val(iboolcorner(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_scalar(ipoin1D)
+ enddo
+
+! receive from worker #2 and add to local array
+ if(NCHUNKS /= 2) then
+ sender = iproc_worker2_corners(imsg)
+#ifdef USE_MPI
+ call MPI_RECV(buffer_recv_chunkcorners_scalar,NGLOB1D_RADIAL, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+ do ipoin1D=1,NGLOB1D_RADIAL
+ array_val(iboolcorner(ipoin1D,icount_corners)) = array_val(iboolcorner(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_scalar(ipoin1D)
+ enddo
+ endif
+
+ endif
+
+!---- send messages from the two workers to the master
+ if(myrank==iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
+
+ receiver = iproc_master_corners(imsg)
+ do ipoin1D=1,NGLOB1D_RADIAL
+ buffer_send_chunkcorners_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
+ enddo
+#ifdef USE_MPI
+ call MPI_SEND(buffer_send_chunkcorners_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
+ receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+
+ endif
+
+! *********************************************************************
+! transmit messages back in opposite direction (master -> two workers)
+! *********************************************************************
+
+!---- receive messages from the master on the two workers
+ if(myrank==iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
+
+! receive from master and copy to local array
+ sender = iproc_master_corners(imsg)
+#ifdef USE_MPI
+ call MPI_RECV(buffer_recv_chunkcorners_scalar,NGLOB1D_RADIAL, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+ do ipoin1D=1,NGLOB1D_RADIAL
+ array_val(iboolcorner(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_scalar(ipoin1D)
+ enddo
+
+ endif
+
+!---- send messages from the master to the two workers
+ if(myrank==iproc_master_corners(imsg)) then
+
+ do ipoin1D=1,NGLOB1D_RADIAL
+ buffer_send_chunkcorners_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
+ enddo
+
+! send to worker #1
+ receiver = iproc_worker1_corners(imsg)
+#ifdef USE_MPI
+ call MPI_SEND(buffer_send_chunkcorners_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
+ receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+
+! send to worker #2
+ if(NCHUNKS /= 2) then
+ receiver = iproc_worker2_corners(imsg)
+#ifdef USE_MPI
+ call MPI_SEND(buffer_send_chunkcorners_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
+ receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+ endif
+
+ endif
+
+ enddo
+
+ end subroutine assemble_MPI_scalar
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_scalar.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_scalar.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_scalar.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,437 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! 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.
-!
-!=====================================================================
-
-!----
-!---- assemble the contributions between slices and chunks using MPI
-!----
-
- subroutine assemble_MPI_scalar(myrank,array_val,nglob, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
- npoin2D_faces,npoin2D_xi,npoin2D_eta, &
- iboolfaces,iboolcorner, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces_scalar,buffer_received_faces_scalar,npoin2D_max_all, &
- buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NCHUNKS)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
- integer myrank,nglob,NCHUNKS
-
-! array to assemble
- real(kind=CUSTOM_REAL), dimension(nglob) :: array_val
-
- integer iproc_xi,iproc_eta,ichunk
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
- integer npoin2D_faces(NUMFACES_SHARED)
-
- integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY
- integer NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL
- integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS
-
-! for addressing of the slices
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
-
-! 2-D addressing and buffers for summation between slices
- integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
- integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
-
-! indirect addressing for each corner of the chunks
- integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
- integer icount_corners
-
- integer :: npoin2D_max_all
- integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
- real(kind=CUSTOM_REAL), dimension(npoin2D_max_all) :: buffer_send_faces_scalar,buffer_received_faces_scalar
-
-! buffers for send and receive between corners of the chunks
- real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL) :: buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar
-
-! ---- arrays to assemble between chunks
-
-! communication pattern for faces between chunks
- integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
-
-! communication pattern for corners between chunks
- integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
-! MPI status of messages to be received
- integer msg_status(MPI_STATUS_SIZE)
-
- integer ipoin,ipoin2D,ipoin1D
- integer sender,receiver,ier
- integer imsg,imsg_loop
- integer icount_faces,npoin2D_chunks
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! check flag to see if we need to assemble (might be turned off when debugging)
- if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) return
-
-! here we have to assemble all the contributions between slices using MPI
-
-!----
-!---- assemble the contributions between slices using MPI
-!----
-
-!----
-!---- first assemble along xi using the 2-D topology
-!----
-
-! assemble along xi only if more than one slice
- if(NPROC_XI > 1) then
-
-! slices copy the right face into the buffer
- do ipoin=1,npoin2D_xi(2)
- buffer_send_faces_scalar(ipoin) = array_val(iboolright_xi(ipoin))
- enddo
-
-! send messages forward along each row
- if(iproc_xi == 0) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi - 1,iproc_eta)
- endif
- if(iproc_xi == NPROC_XI-1) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi + 1,iproc_eta)
- endif
- call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! all slices add the buffer received to the contributions on the left face
- if(iproc_xi > 0) then
- do ipoin=1,npoin2D_xi(1)
- array_val(iboolleft_xi(ipoin)) = array_val(iboolleft_xi(ipoin)) + &
- buffer_received_faces_scalar(ipoin)
- enddo
- endif
-
-! the contributions are correctly assembled on the left side of each slice
-! now we have to send the result back to the sender
-! all slices copy the left face into the buffer
- do ipoin=1,npoin2D_xi(1)
- buffer_send_faces_scalar(ipoin) = array_val(iboolleft_xi(ipoin))
- enddo
-
-! send messages backward along each row
- if(iproc_xi == NPROC_XI-1) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi + 1,iproc_eta)
- endif
- if(iproc_xi == 0) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi - 1,iproc_eta)
- endif
- call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! all slices copy the buffer received to the contributions on the right face
- if(iproc_xi < NPROC_XI-1) then
- do ipoin=1,npoin2D_xi(2)
- array_val(iboolright_xi(ipoin)) = buffer_received_faces_scalar(ipoin)
- enddo
- endif
-
- endif
-
-!----
-!---- then assemble along eta using the 2-D topology
-!----
-
-! assemble along eta only if more than one slice
- if(NPROC_ETA > 1) then
-
-! slices copy the right face into the buffer
- do ipoin=1,npoin2D_eta(2)
- buffer_send_faces_scalar(ipoin) = array_val(iboolright_eta(ipoin))
- enddo
-
-! send messages forward along each row
- if(iproc_eta == 0) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi,iproc_eta - 1)
- endif
- if(iproc_eta == NPROC_ETA-1) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi,iproc_eta + 1)
- endif
- call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! all slices add the buffer received to the contributions on the left face
- if(iproc_eta > 0) then
- do ipoin=1,npoin2D_eta(1)
- array_val(iboolleft_eta(ipoin)) = array_val(iboolleft_eta(ipoin)) + &
- buffer_received_faces_scalar(ipoin)
- enddo
- endif
-
-! the contributions are correctly assembled on the left side of each slice
-! now we have to send the result back to the sender
-! all slices copy the left face into the buffer
- do ipoin=1,npoin2D_eta(1)
- buffer_send_faces_scalar(ipoin) = array_val(iboolleft_eta(ipoin))
- enddo
-
-! send messages backward along each row
- if(iproc_eta == NPROC_ETA-1) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi,iproc_eta + 1)
- endif
- if(iproc_eta == 0) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi,iproc_eta - 1)
- endif
- call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! all slices copy the buffer received to the contributions on the right face
- if(iproc_eta < NPROC_ETA-1) then
- do ipoin=1,npoin2D_eta(2)
- array_val(iboolright_eta(ipoin)) = buffer_received_faces_scalar(ipoin)
- enddo
- endif
-
- endif
-
-!----
-!---- start MPI assembling phase between chunks
-!----
-
-! check flag to see if we need to assemble (might be turned off when debugging)
-! and do not assemble if only one chunk
- if (.not. ACTUALLY_ASSEMBLE_MPI_CHUNKS .or. NCHUNKS == 1) return
-
-! ***************************************************************
-! transmit messages in forward direction (iprocfrom -> iprocto)
-! ***************************************************************
-
-!---- put slices in receive mode
-!---- a given slice can belong to at most two faces
-
-! use three step scheme that can never deadlock
-! scheme for faces cannot deadlock even if NPROC_XI = NPROC_ETA = 1
- do imsg_loop = 1,NUM_MSG_TYPES
-
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- sender = iprocfrom_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- call MPI_RECV(buffer_received_faces_scalar, &
- npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
- do ipoin2D=1,npoin2D_chunks
- array_val(iboolfaces(ipoin2D,icount_faces)) = &
- array_val(iboolfaces(ipoin2D,icount_faces)) + buffer_received_faces_scalar(ipoin2D)
- enddo
- endif
- enddo
-
-!---- put slices in send mode
-!---- a given slice can belong to at most two faces
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- receiver = iprocto_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- do ipoin2D=1,npoin2D_chunks
- buffer_send_faces_scalar(ipoin2D) = array_val(iboolfaces(ipoin2D,icount_faces))
- enddo
- call MPI_SEND(buffer_send_faces_scalar,npoin2D_chunks, &
- CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
- endif
- enddo
-
-! *********************************************************************
-! transmit messages back in opposite direction (iprocto -> iprocfrom)
-! *********************************************************************
-
-!---- put slices in receive mode
-!---- a given slice can belong to at most two faces
-
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- sender = iprocto_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- call MPI_RECV(buffer_received_faces_scalar, &
- npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
- do ipoin2D=1,npoin2D_chunks
- array_val(iboolfaces(ipoin2D,icount_faces)) = buffer_received_faces_scalar(ipoin2D)
- enddo
- endif
- enddo
-
-!---- put slices in send mode
-!---- a given slice can belong to at most two faces
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- receiver = iprocfrom_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- do ipoin2D=1,npoin2D_chunks
- buffer_send_faces_scalar(ipoin2D) = array_val(iboolfaces(ipoin2D,icount_faces))
- enddo
- call MPI_SEND(buffer_send_faces_scalar,npoin2D_chunks, &
- CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
- endif
- enddo
-
-! end of anti-deadlocking loop
- enddo
-
-!----
-!---- start MPI assembling corners
-!----
-
-! scheme for corners cannot deadlock even if NPROC_XI = NPROC_ETA = 1
-
-! ***************************************************************
-! transmit messages in forward direction (two workers -> master)
-! ***************************************************************
-
- icount_corners = 0
-
- do imsg = 1,NCORNERSCHUNKS
-
- if(myrank == iproc_master_corners(imsg) .or. &
- myrank == iproc_worker1_corners(imsg) .or. &
- (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) icount_corners = icount_corners + 1
-
-!---- receive messages from the two workers on the master
- if(myrank==iproc_master_corners(imsg)) then
-
-! receive from worker #1 and add to local array
- sender = iproc_worker1_corners(imsg)
- call MPI_RECV(buffer_recv_chunkcorners_scalar,NGLOB1D_RADIAL, &
- CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- do ipoin1D=1,NGLOB1D_RADIAL
- array_val(iboolcorner(ipoin1D,icount_corners)) = array_val(iboolcorner(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_scalar(ipoin1D)
- enddo
-
-! receive from worker #2 and add to local array
- if(NCHUNKS /= 2) then
- sender = iproc_worker2_corners(imsg)
- call MPI_RECV(buffer_recv_chunkcorners_scalar,NGLOB1D_RADIAL, &
- CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- do ipoin1D=1,NGLOB1D_RADIAL
- array_val(iboolcorner(ipoin1D,icount_corners)) = array_val(iboolcorner(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_scalar(ipoin1D)
- enddo
- endif
-
- endif
-
-!---- send messages from the two workers to the master
- if(myrank==iproc_worker1_corners(imsg) .or. &
- (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
-
- receiver = iproc_master_corners(imsg)
- do ipoin1D=1,NGLOB1D_RADIAL
- buffer_send_chunkcorners_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
- enddo
- call MPI_SEND(buffer_send_chunkcorners_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
- receiver,itag,MPI_COMM_WORLD,ier)
-
- endif
-
-! *********************************************************************
-! transmit messages back in opposite direction (master -> two workers)
-! *********************************************************************
-
-!---- receive messages from the master on the two workers
- if(myrank==iproc_worker1_corners(imsg) .or. &
- (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
-
-! receive from master and copy to local array
- sender = iproc_master_corners(imsg)
- call MPI_RECV(buffer_recv_chunkcorners_scalar,NGLOB1D_RADIAL, &
- CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- do ipoin1D=1,NGLOB1D_RADIAL
- array_val(iboolcorner(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_scalar(ipoin1D)
- enddo
-
- endif
-
-!---- send messages from the master to the two workers
- if(myrank==iproc_master_corners(imsg)) then
-
- do ipoin1D=1,NGLOB1D_RADIAL
- buffer_send_chunkcorners_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
- enddo
-
-! send to worker #1
- receiver = iproc_worker1_corners(imsg)
- call MPI_SEND(buffer_send_chunkcorners_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
- receiver,itag,MPI_COMM_WORLD,ier)
-
-! send to worker #2
- if(NCHUNKS /= 2) then
- receiver = iproc_worker2_corners(imsg)
- call MPI_SEND(buffer_send_chunkcorners_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
- receiver,itag,MPI_COMM_WORLD,ier)
- endif
-
- endif
-
- enddo
-
- end subroutine assemble_MPI_scalar
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_vector.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_vector.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_vector.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_vector.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,796 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! 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.
+!
+!=====================================================================
+
+!----
+!---- assemble the contributions between slices and chunks using MPI
+!---- we handle two regions (crust/mantle and inner core) in the same MPI call
+!---- to reduce the total number of MPI calls
+!----
+
+ subroutine 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,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces_vector,buffer_received_faces_vector,npoin2D_max_all, &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL_crust_mantle, &
+ NGLOB1D_RADIAL_inner_core,NCHUNKS,NDIM_smaller_buffers)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "precision.h"
+#endif
+
+! include values created by the mesher
+ include "values_from_mesher.h"
+
+ integer myrank,NCHUNKS
+
+! the two arrays to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: accel_inner_core
+
+ integer iproc_xi,iproc_eta,ichunk
+ integer npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
+ integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer npoin2D_xi_inner_core,npoin2D_eta_inner_core
+ integer npoin2D_faces_inner_core(NUMFACES_SHARED)
+
+ integer NGLOB1D_RADIAL_crust_mantle,NGLOB1D_RADIAL_inner_core,NPROC_XI,NPROC_ETA
+ integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS,NDIM_smaller_buffers
+
+! for addressing of the slices
+ integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
+
+! 2-D addressing and buffers for summation between slices
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
+
+! indirect addressing for each corner of the chunks
+ integer, dimension(NGLOB1D_RADIAL_crust_mantle,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_inner_core,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+ integer icount_corners
+
+ integer :: npoin2D_max_all
+ integer, dimension(NGLOB2DMAX_XY_VAL_CM,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_VAL_IC,NUMFACES_SHARED) :: iboolfaces_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM_smaller_buffers,npoin2D_max_all) :: buffer_send_faces_vector,buffer_received_faces_vector
+
+! buffers for send and receive between corners of the chunks
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB1D_RADIAL_crust_mantle + NGLOB1D_RADIAL_inner_core) :: &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector
+
+! ---- arrays to assemble between chunks
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+! MPI status of messages to be received
+#ifdef USE_MPI
+ integer, dimension(MPI_STATUS_SIZE) :: msg_status
+#endif
+
+ integer :: ipoin,ipoin2D,ipoin1D
+ integer :: sender,receiver
+ integer :: imsg,imsg_loop,iloop
+ integer :: icount_faces,npoin2D_chunks_all
+
+ integer :: npoin2D_xi_all,npoin2D_eta_all,NGLOB1D_RADIAL_all,ioffset
+
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! check flag to see if we need to assemble (might be turned off when debugging)
+ if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) return
+
+! here we have to assemble all the contributions between slices using MPI
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_xi_all = npoin2D_xi_crust_mantle + npoin2D_xi_inner_core
+ npoin2D_eta_all = npoin2D_eta_crust_mantle + npoin2D_eta_inner_core
+
+!----
+!---- assemble the contributions between slices using MPI
+!----
+
+! loop three times if using smaller buffers, and only once if using larger buffers
+ do iloop = 1,NDIM + 1 - NDIM_smaller_buffers
+
+!----
+!---- first assemble along xi using the 2-D topology
+!----
+
+! assemble along xi only if more than one slice
+ if(NPROC_XI > 1) then
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_xi_crust_mantle
+
+! slices copy the right face into the buffer
+ do ipoin = 1,npoin2D_xi_crust_mantle
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(iloop,iboolright_xi_crust_mantle(ipoin))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolright_xi_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolright_xi_crust_mantle(ipoin))
+ endif
+ enddo
+
+ do ipoin = 1,npoin2D_xi_inner_core
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(iloop,iboolright_xi_inner_core(ipoin))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolright_xi_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolright_xi_inner_core(ipoin))
+ endif
+ enddo
+
+! send messages forward along each row
+ if(iproc_xi == 0) then
+#ifdef USE_MPI
+ sender = MPI_PROC_NULL
+#endif
+ else
+ sender = addressing(ichunk,iproc_xi - 1,iproc_eta)
+ endif
+ if(iproc_xi == NPROC_XI-1) then
+#ifdef USE_MPI
+ receiver = MPI_PROC_NULL
+#endif
+ else
+ receiver = addressing(ichunk,iproc_xi + 1,iproc_eta)
+ endif
+#ifdef USE_MPI
+ call MPI_SENDRECV(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_xi_all,CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_xi_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! all slices add the buffer received to the contributions on the left face
+ if(iproc_xi > 0) then
+
+ do ipoin = 1,npoin2D_xi_crust_mantle
+ accel_crust_mantle(iloop,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(iloop,iboolleft_xi_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(1,ipoin)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(2,ipoin)
+ accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(3,ipoin)
+ endif
+ enddo
+
+ do ipoin = 1,npoin2D_xi_inner_core
+ accel_inner_core(iloop,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(iloop,iboolleft_xi_inner_core(ipoin)) + &
+ buffer_received_faces_vector(1,ioffset + ipoin)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_inner_core(2,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(2,iboolleft_xi_inner_core(ipoin)) + &
+ buffer_received_faces_vector(2,ioffset + ipoin)
+ accel_inner_core(3,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(3,iboolleft_xi_inner_core(ipoin)) + &
+ buffer_received_faces_vector(3,ioffset + ipoin)
+ endif
+ enddo
+
+ endif
+
+! the contributions are correctly assembled on the left side of each slice
+! now we have to send the result back to the sender
+! all slices copy the left face into the buffer
+ do ipoin = 1,npoin2D_xi_crust_mantle
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(iloop,iboolleft_xi_crust_mantle(ipoin))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin))
+ endif
+ enddo
+
+ do ipoin = 1,npoin2D_xi_inner_core
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(iloop,iboolleft_xi_inner_core(ipoin))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolleft_xi_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolleft_xi_inner_core(ipoin))
+ endif
+ enddo
+
+! send messages backward along each row
+ if(iproc_xi == NPROC_XI-1) then
+#ifdef USE_MPI
+ sender = MPI_PROC_NULL
+#endif
+ else
+ sender = addressing(ichunk,iproc_xi + 1,iproc_eta)
+ endif
+ if(iproc_xi == 0) then
+#ifdef USE_MPI
+ receiver = MPI_PROC_NULL
+#endif
+ else
+ receiver = addressing(ichunk,iproc_xi - 1,iproc_eta)
+ endif
+#ifdef USE_MPI
+ call MPI_SENDRECV(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_xi_all,CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_xi_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! all slices copy the buffer received to the contributions on the right face
+ if(iproc_xi < NPROC_XI-1) then
+
+ do ipoin = 1,npoin2D_xi_crust_mantle
+ accel_crust_mantle(iloop,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_crust_mantle(2,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(2,ipoin)
+ accel_crust_mantle(3,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(3,ipoin)
+ endif
+ enddo
+
+ do ipoin = 1,npoin2D_xi_inner_core
+ accel_inner_core(iloop,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_inner_core(2,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(2,ioffset + ipoin)
+ accel_inner_core(3,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(3,ioffset + ipoin)
+ endif
+ enddo
+
+ endif
+
+ endif
+
+!----
+!---- then assemble along eta using the 2-D topology
+!----
+
+! assemble along eta only if more than one slice
+ if(NPROC_ETA > 1) then
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_eta_crust_mantle
+
+! slices copy the right face into the buffer
+ do ipoin = 1,npoin2D_eta_crust_mantle
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(iloop,iboolright_eta_crust_mantle(ipoin))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolright_eta_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolright_eta_crust_mantle(ipoin))
+ endif
+ enddo
+
+ do ipoin = 1,npoin2D_eta_inner_core
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(iloop,iboolright_eta_inner_core(ipoin))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolright_eta_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolright_eta_inner_core(ipoin))
+ endif
+ enddo
+
+! send messages forward along each row
+ if(iproc_eta == 0) then
+#ifdef USE_MPI
+ sender = MPI_PROC_NULL
+#endif
+ else
+ sender = addressing(ichunk,iproc_xi,iproc_eta - 1)
+ endif
+ if(iproc_eta == NPROC_ETA-1) then
+#ifdef USE_MPI
+ receiver = MPI_PROC_NULL
+#endif
+ else
+ receiver = addressing(ichunk,iproc_xi,iproc_eta + 1)
+ endif
+#ifdef USE_MPI
+ call MPI_SENDRECV(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_eta_all,CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_eta_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! all slices add the buffer received to the contributions on the left face
+ if(iproc_eta > 0) then
+
+ do ipoin = 1,npoin2D_eta_crust_mantle
+ accel_crust_mantle(iloop,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(iloop,iboolleft_eta_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(1,ipoin)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(2,ipoin)
+ accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(3,ipoin)
+ endif
+ enddo
+
+ do ipoin = 1,npoin2D_eta_inner_core
+ accel_inner_core(iloop,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(iloop,iboolleft_eta_inner_core(ipoin)) + &
+ buffer_received_faces_vector(1,ioffset + ipoin)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_inner_core(2,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(2,iboolleft_eta_inner_core(ipoin)) + &
+ buffer_received_faces_vector(2,ioffset + ipoin)
+ accel_inner_core(3,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(3,iboolleft_eta_inner_core(ipoin)) + &
+ buffer_received_faces_vector(3,ioffset + ipoin)
+ endif
+ enddo
+
+ endif
+
+! the contributions are correctly assembled on the left side of each slice
+! now we have to send the result back to the sender
+! all slices copy the left face into the buffer
+ do ipoin = 1,npoin2D_eta_crust_mantle
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(iloop,iboolleft_eta_crust_mantle(ipoin))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin))
+ endif
+ enddo
+
+ do ipoin = 1,npoin2D_eta_inner_core
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(iloop,iboolleft_eta_inner_core(ipoin))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolleft_eta_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolleft_eta_inner_core(ipoin))
+ endif
+ enddo
+
+! send messages backward along each row
+ if(iproc_eta == NPROC_ETA-1) then
+#ifdef USE_MPI
+ sender = MPI_PROC_NULL
+#endif
+ else
+ sender = addressing(ichunk,iproc_xi,iproc_eta + 1)
+ endif
+ if(iproc_eta == 0) then
+#ifdef USE_MPI
+ receiver = MPI_PROC_NULL
+#endif
+ else
+ receiver = addressing(ichunk,iproc_xi,iproc_eta - 1)
+ endif
+#ifdef USE_MPI
+ call MPI_SENDRECV(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_eta_all,CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_eta_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! all slices copy the buffer received to the contributions on the right face
+ if(iproc_eta < NPROC_ETA-1) then
+
+ do ipoin = 1,npoin2D_eta_crust_mantle
+ accel_crust_mantle(iloop,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_crust_mantle(2,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(2,ipoin)
+ accel_crust_mantle(3,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(3,ipoin)
+ endif
+ enddo
+
+ do ipoin = 1,npoin2D_eta_inner_core
+ accel_inner_core(iloop,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_inner_core(2,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(2,ioffset + ipoin)
+ accel_inner_core(3,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(3,ioffset + ipoin)
+ endif
+ enddo
+
+ endif
+
+ endif
+
+!----
+!---- start MPI assembling phase between chunks
+!----
+
+! check flag to see if we need to assemble (might be turned off when debugging)
+! and do not assemble if only one chunk
+ if (.not. ACTUALLY_ASSEMBLE_MPI_CHUNKS .or. NCHUNKS == 1) return
+
+! ***************************************************************
+! transmit messages in forward direction (iprocfrom -> iprocto)
+! ***************************************************************
+
+!---- put slices in receive mode
+!---- a given slice can belong to at most two faces
+
+! use three step scheme that can never deadlock
+! scheme for faces cannot deadlock even if NPROC_XI = NPROC_ETA = 1
+ do imsg_loop = 1,NUM_MSG_TYPES
+
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ sender = iprocfrom_faces(imsg)
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_faces_crust_mantle(icount_faces)
+
+#ifdef USE_MPI
+ call MPI_RECV(buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_chunks_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ accel_crust_mantle(iloop,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
+ accel_crust_mantle(iloop,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ipoin2D)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
+ accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(2,ipoin2D)
+ accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
+ accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(3,ipoin2D)
+ endif
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ accel_inner_core(iloop,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ accel_inner_core(iloop,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ioffset + ipoin2D)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(2,ioffset + ipoin2D)
+ accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(3,ioffset + ipoin2D)
+ endif
+ enddo
+
+ endif
+ enddo
+
+!---- put slices in send mode
+!---- a given slice can belong to at most two faces
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ receiver = iprocto_faces(imsg)
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_faces_crust_mantle(icount_faces)
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ buffer_send_faces_vector(1,ipoin2D) = accel_crust_mantle(iloop,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ipoin2D) = accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ipoin2D) = accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ endif
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ buffer_send_faces_vector(1,ioffset + ipoin2D) = accel_inner_core(iloop,iboolfaces_inner_core(ipoin2D,icount_faces))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ioffset + ipoin2D) = accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ioffset + ipoin2D) = accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces))
+ endif
+ enddo
+
+#ifdef USE_MPI
+ call MPI_SEND(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_chunks_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+
+ endif
+ enddo
+
+
+! *********************************************************************
+! transmit messages back in opposite direction (iprocto -> iprocfrom)
+! *********************************************************************
+
+!---- put slices in receive mode
+!---- a given slice can belong to at most two faces
+
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ sender = iprocto_faces(imsg)
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_faces_crust_mantle(icount_faces)
+
+#ifdef USE_MPI
+ call MPI_RECV(buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_chunks_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ accel_crust_mantle(iloop,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ipoin2D)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(2,ipoin2D)
+ accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(3,ipoin2D)
+ endif
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ accel_inner_core(iloop,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ioffset + ipoin2D)
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(2,ioffset + ipoin2D)
+ accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(3,ioffset + ipoin2D)
+ endif
+ enddo
+
+ endif
+ enddo
+
+!---- put slices in send mode
+!---- a given slice can belong to at most two faces
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ receiver = iprocfrom_faces(imsg)
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_faces_crust_mantle(icount_faces)
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ buffer_send_faces_vector(1,ipoin2D) = accel_crust_mantle(iloop,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ipoin2D) = accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ipoin2D) = accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ endif
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ buffer_send_faces_vector(1,ioffset + ipoin2D) = accel_inner_core(iloop,iboolfaces_inner_core(ipoin2D,icount_faces))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ buffer_send_faces_vector(2,ioffset + ipoin2D) = accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ioffset + ipoin2D) = accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces))
+ endif
+ enddo
+
+#ifdef USE_MPI
+ call MPI_SEND(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_chunks_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+
+ endif
+ enddo
+
+! end of anti-deadlocking loop
+ enddo
+
+ enddo ! of loop on iloop depending on NDIM_smaller_buffers
+
+!----
+!---- start MPI assembling corners
+!----
+
+! scheme for corners cannot deadlock even if NPROC_XI = NPROC_ETA = 1
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ NGLOB1D_RADIAL_all = NGLOB1D_RADIAL_crust_mantle + NGLOB1D_RADIAL_inner_core
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = NGLOB1D_RADIAL_crust_mantle
+
+! ***************************************************************
+! transmit messages in forward direction (two workers -> master)
+! ***************************************************************
+
+ icount_corners = 0
+
+ do imsg = 1,NCORNERSCHUNKS
+
+ if(myrank == iproc_master_corners(imsg) .or. &
+ myrank == iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) icount_corners = icount_corners + 1
+
+!---- receive messages from the two workers on the master
+ if(myrank==iproc_master_corners(imsg)) then
+
+! receive from worker #1 and add to local array
+ sender = iproc_worker1_corners(imsg)
+
+#ifdef USE_MPI
+ call MPI_RECV(buffer_recv_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
+ accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(1,ipoin1D)
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(2,ipoin1D)
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(3,ipoin1D)
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(1,ioffset + ipoin1D)
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(2,ioffset + ipoin1D)
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(3,ioffset + ipoin1D)
+ enddo
+
+! receive from worker #2 and add to local array
+ if(NCHUNKS /= 2) then
+
+ sender = iproc_worker2_corners(imsg)
+
+#ifdef USE_MPI
+ call MPI_RECV(buffer_recv_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
+ accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(1,ipoin1D)
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(2,ipoin1D)
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(3,ipoin1D)
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(1,ioffset + ipoin1D)
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(2,ioffset + ipoin1D)
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(3,ioffset + ipoin1D)
+ enddo
+
+ endif
+
+ endif
+
+!---- send messages from the two workers to the master
+ if(myrank==iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
+
+ receiver = iproc_master_corners(imsg)
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
+ buffer_send_chunkcorners_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ buffer_send_chunkcorners_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(3,ioffset + ipoin1D) = accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners))
+ enddo
+
+#ifdef USE_MPI
+ call MPI_SEND(buffer_send_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+
+ endif
+
+! *********************************************************************
+! transmit messages back in opposite direction (master -> two workers)
+! *********************************************************************
+
+!---- receive messages from the master on the two workers
+ if(myrank==iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
+
+! receive from master and copy to local array
+ sender = iproc_master_corners(imsg)
+
+#ifdef USE_MPI
+ call MPI_RECV(buffer_recv_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
+ accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(1,ipoin1D)
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(2,ipoin1D)
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(3,ipoin1D)
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(1,ioffset + ipoin1D)
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(2,ioffset + ipoin1D)
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(3,ioffset + ipoin1D)
+ enddo
+
+ endif
+
+!---- send messages from the master to the two workers
+ if(myrank==iproc_master_corners(imsg)) then
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
+ buffer_send_chunkcorners_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ buffer_send_chunkcorners_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(3,ioffset + ipoin1D) = accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners))
+ enddo
+
+! send to worker #1
+ receiver = iproc_worker1_corners(imsg)
+#ifdef USE_MPI
+ call MPI_SEND(buffer_send_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+
+! send to worker #2
+ if(NCHUNKS /= 2) then
+ receiver = iproc_worker2_corners(imsg)
+#ifdef USE_MPI
+ call MPI_SEND(buffer_send_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+
+ endif
+
+ endif
+
+ enddo
+
+ end subroutine assemble_MPI_vector
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_vector.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/assemble_MPI_vector.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,742 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! 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.
-!
-!=====================================================================
-
-!----
-!---- assemble the contributions between slices and chunks using MPI
-!---- we handle two regions (crust/mantle and inner core) in the same MPI call
-!---- to reduce the total number of MPI calls
-!----
-
- subroutine 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,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces_vector,buffer_received_faces_vector,npoin2D_max_all, &
- buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL_crust_mantle, &
- NGLOB1D_RADIAL_inner_core,NCHUNKS,NDIM_smaller_buffers)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
-! include values created by the mesher
- include "values_from_mesher.h"
-
- integer myrank,NCHUNKS
-
-! the two arrays to assemble
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: accel_inner_core
-
- integer iproc_xi,iproc_eta,ichunk
- integer npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
- integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
- integer npoin2D_xi_inner_core,npoin2D_eta_inner_core
- integer npoin2D_faces_inner_core(NUMFACES_SHARED)
-
- integer NGLOB1D_RADIAL_crust_mantle,NGLOB1D_RADIAL_inner_core,NPROC_XI,NPROC_ETA
- integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS,NDIM_smaller_buffers
-
-! for addressing of the slices
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
-
-! 2-D addressing and buffers for summation between slices
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
-
-! indirect addressing for each corner of the chunks
- integer, dimension(NGLOB1D_RADIAL_crust_mantle,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
- integer, dimension(NGLOB1D_RADIAL_inner_core,NUMCORNERS_SHARED) :: iboolcorner_inner_core
- integer icount_corners
-
- integer :: npoin2D_max_all
- integer, dimension(NGLOB2DMAX_XY_VAL_CM,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL_IC,NUMFACES_SHARED) :: iboolfaces_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM_smaller_buffers,npoin2D_max_all) :: buffer_send_faces_vector,buffer_received_faces_vector
-
-! buffers for send and receive between corners of the chunks
-! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB1D_RADIAL_crust_mantle + NGLOB1D_RADIAL_inner_core) :: &
- buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector
-
-! ---- arrays to assemble between chunks
-
-! communication pattern for faces between chunks
- integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
-
-! communication pattern for corners between chunks
- integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
-! MPI status of messages to be received
- integer msg_status(MPI_STATUS_SIZE)
-
- integer ipoin,ipoin2D,ipoin1D
- integer sender,receiver,ier
- integer imsg,imsg_loop,iloop
- integer icount_faces,npoin2D_chunks_all
-
- integer :: npoin2D_xi_all,npoin2D_eta_all,NGLOB1D_RADIAL_all,ioffset
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! check flag to see if we need to assemble (might be turned off when debugging)
- if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) return
-
-! here we have to assemble all the contributions between slices using MPI
-
-! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- npoin2D_xi_all = npoin2D_xi_crust_mantle + npoin2D_xi_inner_core
- npoin2D_eta_all = npoin2D_eta_crust_mantle + npoin2D_eta_inner_core
-
-!----
-!---- assemble the contributions between slices using MPI
-!----
-
-! loop three times if using smaller buffers, and only once if using larger buffers
- do iloop = 1,NDIM + 1 - NDIM_smaller_buffers
-
-!----
-!---- first assemble along xi using the 2-D topology
-!----
-
-! assemble along xi only if more than one slice
- if(NPROC_XI > 1) then
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_xi_crust_mantle
-
-! slices copy the right face into the buffer
- do ipoin = 1,npoin2D_xi_crust_mantle
- buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(iloop,iboolright_xi_crust_mantle(ipoin))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolright_xi_crust_mantle(ipoin))
- buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolright_xi_crust_mantle(ipoin))
- endif
- enddo
-
- do ipoin = 1,npoin2D_xi_inner_core
- buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(iloop,iboolright_xi_inner_core(ipoin))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolright_xi_inner_core(ipoin))
- buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolright_xi_inner_core(ipoin))
- endif
- enddo
-
-! send messages forward along each row
- if(iproc_xi == 0) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi - 1,iproc_eta)
- endif
- if(iproc_xi == NPROC_XI-1) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi + 1,iproc_eta)
- endif
- call MPI_SENDRECV(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_xi_all,CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_xi_all,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! all slices add the buffer received to the contributions on the left face
- if(iproc_xi > 0) then
-
- do ipoin = 1,npoin2D_xi_crust_mantle
- accel_crust_mantle(iloop,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(iloop,iboolleft_xi_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(1,ipoin)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(2,ipoin)
- accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(3,ipoin)
- endif
- enddo
-
- do ipoin = 1,npoin2D_xi_inner_core
- accel_inner_core(iloop,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(iloop,iboolleft_xi_inner_core(ipoin)) + &
- buffer_received_faces_vector(1,ioffset + ipoin)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_inner_core(2,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(2,iboolleft_xi_inner_core(ipoin)) + &
- buffer_received_faces_vector(2,ioffset + ipoin)
- accel_inner_core(3,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(3,iboolleft_xi_inner_core(ipoin)) + &
- buffer_received_faces_vector(3,ioffset + ipoin)
- endif
- enddo
-
- endif
-
-! the contributions are correctly assembled on the left side of each slice
-! now we have to send the result back to the sender
-! all slices copy the left face into the buffer
- do ipoin = 1,npoin2D_xi_crust_mantle
- buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(iloop,iboolleft_xi_crust_mantle(ipoin))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin))
- buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin))
- endif
- enddo
-
- do ipoin = 1,npoin2D_xi_inner_core
- buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(iloop,iboolleft_xi_inner_core(ipoin))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolleft_xi_inner_core(ipoin))
- buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolleft_xi_inner_core(ipoin))
- endif
- enddo
-
-! send messages backward along each row
- if(iproc_xi == NPROC_XI-1) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi + 1,iproc_eta)
- endif
- if(iproc_xi == 0) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi - 1,iproc_eta)
- endif
- call MPI_SENDRECV(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_xi_all,CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_xi_all,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! all slices copy the buffer received to the contributions on the right face
- if(iproc_xi < NPROC_XI-1) then
-
- do ipoin = 1,npoin2D_xi_crust_mantle
- accel_crust_mantle(iloop,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_crust_mantle(2,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(2,ipoin)
- accel_crust_mantle(3,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(3,ipoin)
- endif
- enddo
-
- do ipoin = 1,npoin2D_xi_inner_core
- accel_inner_core(iloop,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_inner_core(2,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(2,ioffset + ipoin)
- accel_inner_core(3,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(3,ioffset + ipoin)
- endif
- enddo
-
- endif
-
- endif
-
-!----
-!---- then assemble along eta using the 2-D topology
-!----
-
-! assemble along eta only if more than one slice
- if(NPROC_ETA > 1) then
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_eta_crust_mantle
-
-! slices copy the right face into the buffer
- do ipoin = 1,npoin2D_eta_crust_mantle
- buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(iloop,iboolright_eta_crust_mantle(ipoin))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolright_eta_crust_mantle(ipoin))
- buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolright_eta_crust_mantle(ipoin))
- endif
- enddo
-
- do ipoin = 1,npoin2D_eta_inner_core
- buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(iloop,iboolright_eta_inner_core(ipoin))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolright_eta_inner_core(ipoin))
- buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolright_eta_inner_core(ipoin))
- endif
- enddo
-
-! send messages forward along each row
- if(iproc_eta == 0) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi,iproc_eta - 1)
- endif
- if(iproc_eta == NPROC_ETA-1) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi,iproc_eta + 1)
- endif
- call MPI_SENDRECV(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_eta_all,CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_eta_all,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! all slices add the buffer received to the contributions on the left face
- if(iproc_eta > 0) then
-
- do ipoin = 1,npoin2D_eta_crust_mantle
- accel_crust_mantle(iloop,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(iloop,iboolleft_eta_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(1,ipoin)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(2,ipoin)
- accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin)) + &
- buffer_received_faces_vector(3,ipoin)
- endif
- enddo
-
- do ipoin = 1,npoin2D_eta_inner_core
- accel_inner_core(iloop,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(iloop,iboolleft_eta_inner_core(ipoin)) + &
- buffer_received_faces_vector(1,ioffset + ipoin)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_inner_core(2,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(2,iboolleft_eta_inner_core(ipoin)) + &
- buffer_received_faces_vector(2,ioffset + ipoin)
- accel_inner_core(3,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(3,iboolleft_eta_inner_core(ipoin)) + &
- buffer_received_faces_vector(3,ioffset + ipoin)
- endif
- enddo
-
- endif
-
-! the contributions are correctly assembled on the left side of each slice
-! now we have to send the result back to the sender
-! all slices copy the left face into the buffer
- do ipoin = 1,npoin2D_eta_crust_mantle
- buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(iloop,iboolleft_eta_crust_mantle(ipoin))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin))
- buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin))
- endif
- enddo
-
- do ipoin = 1,npoin2D_eta_inner_core
- buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(iloop,iboolleft_eta_inner_core(ipoin))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolleft_eta_inner_core(ipoin))
- buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolleft_eta_inner_core(ipoin))
- endif
- enddo
-
-! send messages backward along each row
- if(iproc_eta == NPROC_ETA-1) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi,iproc_eta + 1)
- endif
- if(iproc_eta == 0) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi,iproc_eta - 1)
- endif
- call MPI_SENDRECV(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_eta_all,CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_eta_all,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! all slices copy the buffer received to the contributions on the right face
- if(iproc_eta < NPROC_ETA-1) then
-
- do ipoin = 1,npoin2D_eta_crust_mantle
- accel_crust_mantle(iloop,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_crust_mantle(2,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(2,ipoin)
- accel_crust_mantle(3,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(3,ipoin)
- endif
- enddo
-
- do ipoin = 1,npoin2D_eta_inner_core
- accel_inner_core(iloop,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_inner_core(2,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(2,ioffset + ipoin)
- accel_inner_core(3,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(3,ioffset + ipoin)
- endif
- enddo
-
- endif
-
- endif
-
-!----
-!---- start MPI assembling phase between chunks
-!----
-
-! check flag to see if we need to assemble (might be turned off when debugging)
-! and do not assemble if only one chunk
- if (.not. ACTUALLY_ASSEMBLE_MPI_CHUNKS .or. NCHUNKS == 1) return
-
-! ***************************************************************
-! transmit messages in forward direction (iprocfrom -> iprocto)
-! ***************************************************************
-
-!---- put slices in receive mode
-!---- a given slice can belong to at most two faces
-
-! use three step scheme that can never deadlock
-! scheme for faces cannot deadlock even if NPROC_XI = NPROC_ETA = 1
- do imsg_loop = 1,NUM_MSG_TYPES
-
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- sender = iprocfrom_faces(imsg)
-
-! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_faces_crust_mantle(icount_faces)
-
- call MPI_RECV(buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_chunks_all,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
- accel_crust_mantle(iloop,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
- accel_crust_mantle(iloop,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ipoin2D)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
- accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(2,ipoin2D)
- accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
- accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(3,ipoin2D)
- endif
- enddo
-
- do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
- accel_inner_core(iloop,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
- accel_inner_core(iloop,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ioffset + ipoin2D)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
- accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(2,ioffset + ipoin2D)
- accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
- accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(3,ioffset + ipoin2D)
- endif
- enddo
-
- endif
- enddo
-
-!---- put slices in send mode
-!---- a given slice can belong to at most two faces
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- receiver = iprocto_faces(imsg)
-
-! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_faces_crust_mantle(icount_faces)
-
- do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
- buffer_send_faces_vector(1,ipoin2D) = accel_crust_mantle(iloop,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ipoin2D) = accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- buffer_send_faces_vector(3,ipoin2D) = accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- endif
- enddo
-
- do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
- buffer_send_faces_vector(1,ioffset + ipoin2D) = accel_inner_core(iloop,iboolfaces_inner_core(ipoin2D,icount_faces))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ioffset + ipoin2D) = accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces))
- buffer_send_faces_vector(3,ioffset + ipoin2D) = accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces))
- endif
- enddo
-
- call MPI_SEND(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_chunks_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
-
- endif
- enddo
-
-
-! *********************************************************************
-! transmit messages back in opposite direction (iprocto -> iprocfrom)
-! *********************************************************************
-
-!---- put slices in receive mode
-!---- a given slice can belong to at most two faces
-
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- sender = iprocto_faces(imsg)
-
-! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_faces_crust_mantle(icount_faces)
-
- call MPI_RECV(buffer_received_faces_vector,NDIM_smaller_buffers*npoin2D_chunks_all,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
- accel_crust_mantle(iloop,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ipoin2D)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(2,ipoin2D)
- accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(3,ipoin2D)
- endif
- enddo
-
- do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
- accel_inner_core(iloop,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ioffset + ipoin2D)
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(2,ioffset + ipoin2D)
- accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(3,ioffset + ipoin2D)
- endif
- enddo
-
- endif
- enddo
-
-!---- put slices in send mode
-!---- a given slice can belong to at most two faces
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- receiver = iprocfrom_faces(imsg)
-
-! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = npoin2D_faces_crust_mantle(icount_faces)
-
- do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
- buffer_send_faces_vector(1,ipoin2D) = accel_crust_mantle(iloop,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ipoin2D) = accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- buffer_send_faces_vector(3,ipoin2D) = accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces))
- endif
- enddo
-
- do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
- buffer_send_faces_vector(1,ioffset + ipoin2D) = accel_inner_core(iloop,iboolfaces_inner_core(ipoin2D,icount_faces))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- buffer_send_faces_vector(2,ioffset + ipoin2D) = accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces))
- buffer_send_faces_vector(3,ioffset + ipoin2D) = accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces))
- endif
- enddo
-
- call MPI_SEND(buffer_send_faces_vector,NDIM_smaller_buffers*npoin2D_chunks_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
-
- endif
- enddo
-
-! end of anti-deadlocking loop
- enddo
-
- enddo ! of loop on iloop depending on NDIM_smaller_buffers
-
-!----
-!---- start MPI assembling corners
-!----
-
-! scheme for corners cannot deadlock even if NPROC_XI = NPROC_ETA = 1
-
-! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- NGLOB1D_RADIAL_all = NGLOB1D_RADIAL_crust_mantle + NGLOB1D_RADIAL_inner_core
-
-! the buffer for the inner core starts right after the buffer for the crust and mantle
- ioffset = NGLOB1D_RADIAL_crust_mantle
-
-! ***************************************************************
-! transmit messages in forward direction (two workers -> master)
-! ***************************************************************
-
- icount_corners = 0
-
- do imsg = 1,NCORNERSCHUNKS
-
- if(myrank == iproc_master_corners(imsg) .or. &
- myrank == iproc_worker1_corners(imsg) .or. &
- (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) icount_corners = icount_corners + 1
-
-!---- receive messages from the two workers on the master
- if(myrank==iproc_master_corners(imsg)) then
-
-! receive from worker #1 and add to local array
- sender = iproc_worker1_corners(imsg)
-
- call MPI_RECV(buffer_recv_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all, &
- CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
-
- do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
- accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
- accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(1,ipoin1D)
- accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
- accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(2,ipoin1D)
- accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
- accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(3,ipoin1D)
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
- accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(1,ioffset + ipoin1D)
- accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
- accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(2,ioffset + ipoin1D)
- accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
- accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(3,ioffset + ipoin1D)
- enddo
-
-! receive from worker #2 and add to local array
- if(NCHUNKS /= 2) then
-
- sender = iproc_worker2_corners(imsg)
-
- call MPI_RECV(buffer_recv_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all, &
- CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
-
- do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
- accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
- accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(1,ipoin1D)
- accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
- accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(2,ipoin1D)
- accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
- accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(3,ipoin1D)
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
- accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(1,ioffset + ipoin1D)
- accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
- accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(2,ioffset + ipoin1D)
- accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
- accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorners_vector(3,ioffset + ipoin1D)
- enddo
-
- endif
-
- endif
-
-!---- send messages from the two workers to the master
- if(myrank==iproc_worker1_corners(imsg) .or. &
- (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
-
- receiver = iproc_master_corners(imsg)
-
- do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
- buffer_send_chunkcorners_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorners_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorners_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- buffer_send_chunkcorners_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorners_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorners_vector(3,ioffset + ipoin1D) = accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners))
- enddo
-
- call MPI_SEND(buffer_send_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
-
- endif
-
-! *********************************************************************
-! transmit messages back in opposite direction (master -> two workers)
-! *********************************************************************
-
-!---- receive messages from the master on the two workers
- if(myrank==iproc_worker1_corners(imsg) .or. &
- (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
-
-! receive from master and copy to local array
- sender = iproc_master_corners(imsg)
-
- call MPI_RECV(buffer_recv_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all, &
- CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
-
- do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
- accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(1,ipoin1D)
- accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(2,ipoin1D)
- accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(3,ipoin1D)
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(1,ioffset + ipoin1D)
- accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(2,ioffset + ipoin1D)
- accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(3,ioffset + ipoin1D)
- enddo
-
- endif
-
-!---- send messages from the master to the two workers
- if(myrank==iproc_master_corners(imsg)) then
-
- do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
- buffer_send_chunkcorners_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorners_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- buffer_send_chunkcorners_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
- enddo
-
- do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
- buffer_send_chunkcorners_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorners_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
- buffer_send_chunkcorners_vector(3,ioffset + ipoin1D) = accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners))
- enddo
-
-! send to worker #1
- receiver = iproc_worker1_corners(imsg)
- call MPI_SEND(buffer_send_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
-
-! send to worker #2
- if(NCHUNKS /= 2) then
- receiver = iproc_worker2_corners(imsg)
- call MPI_SEND(buffer_send_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
-
- endif
-
- endif
-
- enddo
-
- end subroutine assemble_MPI_vector
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/attenuation_model.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/attenuation_model.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/attenuation_model.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/attenuation_model.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,1936 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! 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.
+!
+!=====================================================================
+
+! This portion of the SPECFEM3D Code was written by:
+! Brian Savage while at
+! California Institute of Technology
+! Department of Terrestrial Magnetism / Carnegie Institute of Washington
+! Univeristy of Rhode Island
+! <savage at uri.edu>.
+!
+! It is based upon formulation in the following references:
+!
+! Dahlen and Tromp, 1998
+! Theoretical Global Seismology
+!
+! Liu et al. 1976
+! Velocity dispersion due to anelasticity: implications for seismology and mantle composition
+! Geophys, J. R. asts. Soc, Vol 47, pp. 41-58
+!
+! The methodology can be found in Savage and Tromp, 2006, unpublished
+!
+
+subroutine attenuation_lookup_value(i, r)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer i
+ double precision r
+
+ r = dble(i) / TABLE_ATTENUATION
+
+end subroutine attenuation_lookup_value
+
+! This Subroutine is Hackish. It could probably all be moved to an input attenuation file.
+! Actually all the velocities, densities and attenuations could be moved to seperate input
+! files rather than be defined within the CODE
+!
+! All this subroutine does is define the Attenuation vs Radius and then Compute the Attenuation
+! Variables (tau_sigma and tau_epslion ( or tau_mu) )
+subroutine attenuation_model_setup(REFERENCE_1D_MODEL,RICB,RCMB,R670,R220,R80,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,AM_S,AS_V)
+
+ implicit none
+
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ integer myrank
+ integer REFERENCE_1D_MODEL
+ double precision RICB, RCMB, R670, R220, R80
+ double precision tau_e(N_SLS)
+
+ integer i
+#ifdef USE_MPI
+ integer :: ier
+#endif
+ double precision Qb
+ double precision R120
+
+ Qb = 57287.0d0
+ R120 = 6251.d3
+
+#ifdef USE_MPI
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+#else
+ myrank = 0
+#endif
+
+ if(myrank > 0) return
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ AM_V%Qn = 12
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+ AM_V%Qn = 12
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ call define_model_ak135(.FALSE.,Mak135_V)
+ AM_V%Qn = NR_AK135
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ call define_model_1066a(.FALSE., M1066a_V)
+ AM_V%Qn = NR_1066A
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call define_model_ref(Mref_V)
+ AM_V%Qn = NR_REF
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+ AM_V%Qn = 12
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ call define_model_sea1d(.FALSE., SEA1DM_V)
+ AM_V%Qn = NR_SEA1D
+ else
+ call exit_MPI(myrank, 'Reference 1D Model Not recognized')
+ endif
+
+!! DK DK could allocate these automatic arrays here and in the rest of this file
+!! DK DK in the memory stack to avoid memory fragmentation with "allocate()"
+ allocate(AM_V%Qr(AM_V%Qn))
+ allocate(AM_V%Qmu(AM_V%Qn))
+ allocate(AM_V%interval_Q(AM_V%Qn))
+ allocate(AM_V%Qtau_e(N_SLS,AM_V%Qn))
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ AM_V%Qr(:) = (/ 0.0d0, RICB, RICB, RCMB, RCMB, R670, R670, R220, R220, R80, R80, R_EARTH /)
+ AM_V%Qmu(:) = (/ 84.6d0, 84.6d0, 0.0d0, 0.0d0, 312.0d0, 312.0d0, 143.0d0, 143.0d0, 80.0d0, 80.0d0, 600.0d0, 600.0d0 /)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+ AM_V%Qr(:) = (/ 0.0d0, RICB, RICB, RCMB, RCMB, R670, R670, R220, R220, R120, R120, R_EARTH /)
+ AM_V%Qmu(:) = (/ 84.6d0, 84.6d0, 0.0d0, 0.0d0, 312.0d0, 312.0d0, 143.0d0, 143.0d0, 80.0d0, 80.0d0, 600.0d0, 600.0d0 /)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ AM_V%Qr(:) = Mak135_V%radius_ak135(:)
+ AM_V%Qmu(:) = Mak135_V%Qmu_ak135(:)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ AM_V%Qr(:) = M1066a_V%radius_1066a(:)
+ AM_V%Qmu(:) = M1066a_V%Qmu_1066a(:)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_ref) then
+ AM_V%Qr(:) = Mref_V%radius_ref(:)
+ AM_V%Qmu(:) = Mref_V%Qmu_ref(:)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+ AM_V%Qr(:) = (/ 0.0d0, RICB, RICB, RCMB, RCMB, R670, R670, R220, R220, R120, R120, R_EARTH /)
+ AM_V%Qmu(:) = (/ 84.6d0, 84.6d0, 0.0d0, 0.0d0, 312.0d0, 312.0d0, 143.0d0, 143.0d0, 80.0d0, 80.0d0, 600.0d0, 600.0d0 /)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ AM_V%Qr(:) = SEA1DM_V%radius_sea1d(:)
+ AM_V%Qmu(:) = SEA1DM_V%Qmu_sea1d(:)
+ endif
+
+ do i = 1, AM_V%Qn
+ call attenuation_conversion(AM_V%Qmu(i), AM_V%QT_c_source, AM_V%Qtau_s, tau_e, AM_V, AM_S,AS_V)
+ AM_V%Qtau_e(:,i) = tau_e(:)
+ enddo
+
+end subroutine attenuation_model_setup
+
+subroutine attenuation_save_arrays(iregion_code, AM_V)
+
+ implicit none
+
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+ integer iregion_code
+#ifdef USE_MPI
+ integer :: ier
+#endif
+ integer myrank
+
+!! DK DK we should remove this "save" statement at some point
+ integer, save :: first_time_called = 1
+
+#ifdef USE_MPI
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+#else
+ myrank = 0
+#endif
+
+ if(myrank == 0 .AND. iregion_code == IREGION_CRUST_MANTLE .AND. first_time_called == 1) then
+ first_time_called = 0
+
+ print *,'DK DK we should do this in MPI instead of writing to a local file and using a "save" statement'
+
+ open(unit=27,file='OUTPUT_FILES/1D_Q.bin',status='unknown',form='unformatted',action='write')
+ write(27) AM_V%QT_c_source
+ write(27) AM_V%Qtau_s
+ write(27) AM_V%Qn
+ write(27) AM_V%Qr
+ write(27) AM_V%Qmu
+ write(27) AM_V%Qtau_e
+ close(27)
+ endif
+
+end subroutine attenuation_save_arrays
+
+subroutine attenuation_storage(Qmu, tau_e, rw, AM_S)
+
+ implicit none
+
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+ include 'constants.h'
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+ integer myrank
+#ifdef USE_MPI
+ integer :: ier
+#endif
+ double precision Qmu, Qmu_new
+ double precision, dimension(N_SLS) :: tau_e
+ integer rw
+
+ integer Qtmp
+
+!! DK DK we should remove this "save" statement at some point
+ integer, save :: first_time_called = 1
+
+ if(first_time_called == 1) then
+ first_time_called = 0
+ AM_S%Q_resolution = 10**ATTENUATION_COMP_RESOLUTION
+ AM_S%Q_max = ATTENUATION_COMP_MAXIMUM
+ Qtmp = AM_S%Q_resolution * AM_S%Q_max
+ allocate(AM_S%tau_e_storage(N_SLS, Qtmp))
+ allocate(AM_S%Qmu_storage(Qtmp))
+ AM_S%Qmu_storage(:) = -1
+ endif
+
+ if(Qmu < 0.0d0 .OR. Qmu >= AM_S%Q_max) then
+ write(IMAIN,*) 'Error'
+ write(IMAIN,*) 'attenuation_conversion/storage()'
+ write(IMAIN,*) 'Attenuation Value out of Range: ', Qmu
+ write(IMAIN,*) 'Attenuation Value out of Range: Min, Max ', 0, AM_S%Q_max
+#ifdef USE_MPI
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+#else
+ myrank = 0
+#endif
+ call exit_MPI(myrank, 'Attenuation Value out of Range')
+ endif
+
+ if(rw > 0 .AND. Qmu == 0.0d0) then
+ Qmu = 0.0d0;
+ tau_e(:) = 0.0d0;
+ return
+ endif
+ ! Generate index for Storage Array
+ ! and Recast Qmu using this index
+ ! Accroding to Brian, use float
+ !Qtmp = Qmu * Q_resolution
+ !Qmu = Qtmp / Q_resolution;
+
+ !
+ Qtmp = Qmu * dble(AM_S%Q_resolution)
+ Qmu_new = dble(Qtmp) / dble(AM_S%Q_resolution)
+
+ if(rw > 0) then
+ ! READ
+ if(AM_S%Qmu_storage(Qtmp) > 0) then
+ ! READ SUCCESSFUL
+ tau_e(:) = AM_S%tau_e_storage(:, Qtmp)
+ Qmu = AM_S%Qmu_storage(Qtmp)
+ rw = 1
+ else
+ ! READ NOT SUCCESSFUL
+ rw = -1
+ endif
+ else
+ ! WRITE SUCCESSFUL
+ AM_S%tau_e_storage(:,Qtmp) = tau_e(:)
+ AM_S%Qmu_storage(Qtmp) = Qmu
+ rw = 1
+ endif
+
+end subroutine attenuation_storage
+
+subroutine attenuation_conversion(Qmu_in, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
+! includes min_period, max_period, and N_SLS
+
+ implicit none
+
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ double precision Qmu_in, T_c_source
+ double precision, dimension(N_SLS) :: tau_s, tau_e
+
+ integer rw
+
+ ! READ
+ rw = 1
+ call attenuation_storage(Qmu_in, tau_e, rw, AM_S)
+ if(rw > 0) return
+
+ call attenuation_invert_by_simplex(AM_V%min_period, AM_V%max_period, N_SLS, Qmu_in, T_c_source, tau_s, tau_e, AS_V)
+
+ ! WRITE
+ rw = -1
+ call attenuation_storage(Qmu_in, tau_e, rw, AM_S)
+
+end subroutine attenuation_conversion
+
+subroutine read_attenuation_model(min, max, AM_V)
+
+ implicit none
+
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+ integer min, max
+
+ AM_V%min_period = min * 1.0d0
+ AM_V%max_period = max * 1.0d0
+
+ call attenuation_tau_sigma(AM_V%Qtau_s, N_SLS, AM_V%min_period, AM_V%max_period)
+ call attenuation_source_frequency(AM_V%QT_c_source, AM_V%min_period, AM_V%max_period)
+
+end subroutine read_attenuation_model
+
+subroutine attenuation_memory_values(tau_s, deltat, alphaval,betaval,gammaval)
+
+ implicit none
+
+ include 'constants.h'
+
+ double precision, dimension(N_SLS) :: tau_s, alphaval, betaval,gammaval
+ real(kind=CUSTOM_REAL) deltat
+
+ double precision, dimension(N_SLS) :: tauinv
+
+ tauinv(:) = - 1.0 / tau_s(:)
+
+ alphaval(:) = 1 + deltat*tauinv(:) + deltat**2*tauinv(:)**2 / 2. + &
+ deltat**3*tauinv(:)**3 / 6. + deltat**4*tauinv(:)**4 / 24.
+ betaval(:) = deltat / 2. + deltat**2*tauinv(:) / 3. + deltat**3*tauinv(:)**2 / 8. + deltat**4*tauinv(:)**3 / 24.
+ gammaval(:) = deltat / 2. + deltat**2*tauinv(:) / 6. + deltat**3*tauinv(:)**2 / 24.0
+
+end subroutine attenuation_memory_values
+
+subroutine attenuation_scale_factor(myrank, T_c_source, tau_mu, tau_sigma, Q_mu, scale_factor)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer myrank
+ double precision scale_factor, Q_mu, T_c_source
+ double precision, dimension(N_SLS) :: tau_mu, tau_sigma
+
+ double precision scale_t
+ double precision f_c_source, w_c_source, f_0_prem
+ double precision factor_scale_mu0, factor_scale_mu
+ double precision a_val, b_val
+ double precision big_omega
+ integer i
+
+ scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
+
+!--- compute central angular frequency of source (non dimensionalized)
+ f_c_source = ONE / T_c_source
+ w_c_source = TWO_PI * f_c_source
+
+!--- non dimensionalize PREM reference of 1 second
+ f_0_prem = ONE / ( ONE / scale_t)
+
+!--- quantity by which to scale mu_0 to get mu
+! this formula can be found for instance in
+! Liu, H. P., Anderson, D. L. and Kanamori, H., Velocity dispersion due to
+! anelasticity: implications for seismology and mantle composition,
+! Geophys. J. R. Astron. Soc., vol. 47, pp. 41-58 (1976)
+! and in Aki, K. and Richards, P. G., Quantitative seismology, theory and methods,
+! W. H. Freeman, (1980), second edition, sections 5.5 and 5.5.2, eq. (5.81) p. 170
+ factor_scale_mu0 = ONE + TWO * log(f_c_source / f_0_prem) / (PI * Q_mu)
+
+!--- compute a, b and Omega parameters, also compute one minus sum of betas
+ a_val = ONE
+ b_val = ZERO
+
+ do i = 1,N_SLS
+ a_val = a_val - w_c_source * w_c_source * tau_mu(i) * &
+ (tau_mu(i) - tau_sigma(i)) / (1.d0 + w_c_source * w_c_source * tau_mu(i) * tau_mu(i))
+ b_val = b_val + w_c_source * (tau_mu(i) - tau_sigma(i)) / &
+ (1.d0 + w_c_source * w_c_source * tau_mu(i) * tau_mu(i))
+ enddo
+
+ big_omega = a_val*(sqrt(1.d0 + b_val*b_val/(a_val*a_val))-1.d0)
+
+!--- quantity by which to scale mu to get mu_relaxed
+ factor_scale_mu = b_val * b_val / (TWO * big_omega)
+
+!--- total factor by which to scale mu0
+ scale_factor = factor_scale_mu * factor_scale_mu0
+
+!--- check that the correction factor is close to one
+ if(scale_factor < 0.9 .or. scale_factor > 1.1) then
+ write(*,*)'scale factor: ', scale_factor
+ call exit_MPI(myrank,'incorrect correction factor in attenuation model')
+ endif
+
+end subroutine attenuation_scale_factor
+
+!----
+
+subroutine attenuation_property_values(tau_s, tau_e, factor_common, one_minus_sum_beta)
+
+ implicit none
+
+ include 'constants.h'
+
+ double precision, dimension(N_SLS) :: tau_s, tau_e, beta, factor_common
+ double precision one_minus_sum_beta
+
+ double precision, dimension(N_SLS) :: tauinv
+ integer i
+
+ tauinv(:) = -1.0d0 / tau_s(:)
+
+ beta(:) = 1.0d0 - tau_e(:) / tau_s(:)
+ one_minus_sum_beta = 1.0d0
+
+ do i = 1,N_SLS
+ one_minus_sum_beta = one_minus_sum_beta - beta(i)
+ enddo
+
+ factor_common(:) = 2.0d0 * beta(:) * tauinv(:)
+
+end subroutine attenuation_property_values
+
+!---
+!---
+!---
+
+subroutine get_attenuation_model_1D(myrank, iregion_code, tau_s, one_minus_sum_beta, &
+ factor_common, scale_factor, vn,vx,vy,vz, AM_V)
+
+ implicit none
+
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+ integer myrank, iregion_code
+ integer vn, vx,vy,vz
+ double precision, dimension(N_SLS) :: tau_s
+ double precision, dimension(vx,vy,vz,vn) :: scale_factor, one_minus_sum_beta
+ double precision, dimension(N_SLS, vx,vy,vz,vn) :: factor_common
+
+ integer i,j,rmax
+#ifdef USE_MPI
+ integer :: ier
+#endif
+ double precision scale_t
+ double precision Qp1, Qpn, radius, fctmp
+ double precision, dimension(:), allocatable :: Qfctmp, Qfc2tmp
+
+!! DK DK we should remove this "save" statement at some point
+ integer, save :: first_time_called = 1
+
+ if(myrank == 0 .AND. iregion_code == IREGION_CRUST_MANTLE .AND. first_time_called == 1) then
+ first_time_called = 0
+
+ print *,'DK DK we should do this in MPI instead of reading from a local file and using a "save" statement'
+
+ open(unit=27, file='OUTPUT_FILES/1D_Q.bin', status='unknown', form='unformatted',action='read')
+ read(27) AM_V%QT_c_source
+ read(27) tau_s
+ read(27) AM_V%Qn
+
+ allocate(AM_V%Qr(AM_V%Qn))
+ allocate(AM_V%Qmu(AM_V%Qn))
+ allocate(AM_V%Qtau_e(N_SLS,AM_V%Qn))
+
+ read(27) AM_V%Qr
+ read(27) AM_V%Qmu
+ read(27) AM_V%Qtau_e
+ close(27)
+ endif
+
+ ! Synch up after the Read
+#ifdef USE_MPI
+ call MPI_BCAST(AM_V%QT_c_source,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(tau_s,N_SLS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AM_V%Qn,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+#endif
+
+ if(myrank /= 0) then
+ allocate(AM_V%Qr(AM_V%Qn))
+ allocate(AM_V%Qmu(AM_V%Qn))
+ allocate(AM_V%Qtau_e(N_SLS,AM_V%Qn))
+ endif
+
+#ifdef USE_MPI
+ call MPI_BCAST(AM_V%Qr,AM_V%Qn,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AM_V%Qmu,AM_V%Qn,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AM_V%Qtau_e,AM_V%Qn*N_SLS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+
+ scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
+
+ ! Scale the Attenuation Values
+ tau_s(:) = tau_s(:) / scale_t
+ AM_V%Qtau_e(:,:) = AM_V%Qtau_e(:,:) / scale_t
+ AM_V%QT_c_source = 1000.0d0 / AM_V%QT_c_source / scale_t
+ AM_V%Qr(:) = AM_V%Qr(:) / R_EARTH
+
+ allocate(AM_V%Qsf(AM_V%Qn))
+ allocate(AM_V%Qomsb(AM_V%Qn))
+ allocate(AM_V%Qfc(N_SLS,AM_V%Qn))
+
+ allocate(AM_V%Qsf2(AM_V%Qn))
+ allocate(AM_V%Qomsb2(AM_V%Qn))
+ allocate(AM_V%Qfc2(N_SLS,AM_V%Qn))
+
+ allocate(AM_V%interval_Q(AM_V%Qn))
+
+ allocate(Qfctmp(AM_V%Qn))
+ allocate(Qfc2tmp(AM_V%Qn))
+
+ do i = 1,AM_V%Qn
+ if(AM_V%Qmu(i) == 0.0d0) then
+ AM_V%Qomsb(i) = 0.0d0
+ AM_V%Qfc(:,i) = 0.0d0
+ AM_V%Qsf(i) = 0.0d0
+ else
+ call attenuation_property_values(tau_s, AM_V%Qtau_e(:,i), AM_V%Qfc(:,i), AM_V%Qomsb(i))
+ call attenuation_scale_factor(myrank, AM_V%QT_c_source, AM_V%Qtau_e(:,i), tau_s, AM_V%Qmu(i), AM_V%Qsf(i))
+ endif
+ enddo
+
+ ! Determine the Spline Coefficients or Second Derivatives
+ call pspline_construction(AM_V%Qr, AM_V%Qsf, AM_V%Qn, Qp1, Qpn, AM_V%Qsf2, AM_V%interval_Q)
+ call pspline_construction(AM_V%Qr, AM_V%Qomsb, AM_V%Qn, Qp1, Qpn, AM_V%Qomsb2, AM_V%interval_Q)
+ do i = 1,N_SLS
+! copy the sub-arrays to temporary arrays to avoid a warning by some compilers
+! about temporary arrays being created automatically when using this expression
+! directly in the call to the subroutine
+ Qfctmp(:) = AM_V%Qfc(i,:)
+ Qfc2tmp(:) = AM_V%Qfc2(i,:)
+ call pspline_construction(AM_V%Qr, Qfctmp, AM_V%Qn, Qp1, Qpn, Qfc2tmp, AM_V%interval_Q)
+! copy the arrays back to the sub-arrays, since these sub-arrays are used
+! as input and output
+ AM_V%Qfc(i,:) = Qfctmp(:)
+ AM_V%Qfc2(i,:) = Qfc2tmp(:)
+ enddo
+
+ radius = 0.0d0
+ rmax = nint(TABLE_ATTENUATION)
+ do i = 1,rmax
+ call attenuation_lookup_value(i, radius)
+ call pspline_evaluation(AM_V%Qr, AM_V%Qsf, AM_V%Qsf2, AM_V%Qn, radius, scale_factor(1,1,1,i), AM_V%interval_Q)
+ call pspline_evaluation(AM_V%Qr, AM_V%Qomsb, AM_V%Qomsb2, AM_V%Qn, radius, one_minus_sum_beta(1,1,1,i), AM_V%interval_Q)
+ do j = 1,N_SLS
+ Qfctmp = AM_V%Qfc(j,:)
+ Qfc2tmp = AM_V%Qfc2(j,:)
+ call pspline_evaluation(AM_V%Qr, Qfctmp, Qfc2tmp, AM_V%Qn, radius, fctmp, AM_V%interval_Q)
+ factor_common(j,1,1,1,i) = fctmp
+ enddo
+ enddo
+ do i = rmax+1,NRAD_ATTENUATION
+ scale_factor(1,1,1,i) = scale_factor(1,1,1,rmax)
+ one_minus_sum_beta(1,1,1,i) = one_minus_sum_beta(1,1,1,rmax)
+ factor_common(1,1,1,1,i) = factor_common(1,1,1,1,rmax)
+ factor_common(2,1,1,1,i) = factor_common(2,1,1,1,rmax)
+ factor_common(3,1,1,1,i) = factor_common(3,1,1,1,rmax)
+ enddo
+
+ deallocate(AM_V%Qfc2)
+ deallocate(AM_V%Qsf2)
+ deallocate(AM_V%Qomsb2)
+ deallocate(AM_V%Qfc)
+ deallocate(AM_V%Qsf)
+ deallocate(AM_V%Qomsb)
+ deallocate(AM_V%Qtau_e)
+ deallocate(Qfctmp)
+ deallocate(Qfc2tmp)
+
+end subroutine get_attenuation_model_1D
+
+subroutine set_attenuation_regions_1D(RICB, RCMB, R670, R220, R80, AM_V)
+
+ implicit none
+
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+ double precision RICB, RCMB, R670, R220, R80
+ integer i
+
+ allocate(AM_V%Qrmin(6))
+ allocate(AM_V%Qrmax(6))
+ allocate(AM_V%QrDisc(5))
+
+ AM_V%QrDisc(1) = RICB
+ AM_V%QrDisc(2) = RCMB
+ AM_V%QrDisc(3) = R670
+ AM_V%QrDisc(4) = R220
+ AM_V%QrDisc(5) = R80
+
+ ! INNER CORE
+ AM_V%Qrmin(IREGION_ATTENUATION_INNER_CORE) = 1 ! Center of the Earth
+ i = nint(RICB / 100.d0) ! === BOUNDARY === INNER CORE / OUTER CORE
+ AM_V%Qrmax(IREGION_ATTENUATION_INNER_CORE) = i - 1 ! Inner Core Boundary (Inner)
+
+ ! OUTER_CORE
+ AM_V%Qrmin(6) = i ! Inner Core Boundary (Outer)
+ i = nint(RCMB / 100.d0) ! === BOUNDARY === INNER CORE / OUTER CORE
+ AM_V%Qrmax(6) = i - 1
+
+ ! LOWER MANTLE
+ AM_V%Qrmin(IREGION_ATTENUATION_CMB_670) = i
+ i = nint(R670 / 100.d0) ! === BOUNDARY === 670 km
+ AM_V%Qrmax(IREGION_ATTENUATION_CMB_670) = i - 1
+
+ ! UPPER MANTLE
+ AM_V%Qrmin(IREGION_ATTENUATION_670_220) = i
+ i = nint(R220 / 100.d0) ! === BOUNDARY === 220 km
+ AM_V%Qrmax(IREGION_ATTENUATION_670_220) = i - 1
+
+ ! MANTLE ISH LITHOSPHERE
+ AM_V%Qrmin(IREGION_ATTENUATION_220_80) = i
+ i = nint(R80 / 100.d0) ! === BOUNDARY === 80 km
+ AM_V%Qrmax(IREGION_ATTENUATION_220_80) = i - 1
+
+ ! CRUST ISH LITHOSPHERE
+ AM_V%Qrmin(IREGION_ATTENUATION_80_SURFACE) = i
+ AM_V%Qrmax(IREGION_ATTENUATION_80_SURFACE) = NRAD_ATTENUATION
+
+end subroutine set_attenuation_regions_1D
+
+subroutine get_attenuation_index(iflag, radius, index, inner_core, AM_V)
+
+ implicit none
+
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+ integer iflag, iregion, index
+ double precision radius
+
+ ! Inner Core or not
+ logical inner_core
+
+ index = nint(radius * TABLE_ATTENUATION)
+
+!! DK DK this seems incorrect and is difficult to read anyway
+!! DK DK therefore let me rewrite it better
+! if(inner_core) then
+! if(iflag >= IFLAG_INNER_CORE_NORMAL) then
+! iregion = IREGION_ATTENUATION_INNER_CORE
+! else if(iflag >= IFLAG_OUTER_CORE_NORMAL) then
+! iregion = 6
+! endif
+! else
+! if(iflag >= IFLAG_MANTLE_NORMAL) then
+! iregion = IREGION_ATTENUATION_CMB_670
+! else if(iflag == IFLAG_670_220) then
+! iregion = IREGION_ATTENUATION_670_220
+! else if(iflag <= IFLAG_220_80) then
+! iregion = IREGION_ATTENUATION_220_80
+! else
+! iregion = IREGION_ATTENUATION_80_SURFACE
+! endif
+! endif
+ if(inner_core) then
+
+ if(iflag == IFLAG_INNER_CORE_NORMAL .or. iflag == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ iflag == IFLAG_BOTTOM_CENTRAL_CUBE .or. iflag == IFLAG_TOP_CENTRAL_CUBE .or. &
+ iflag == IFLAG_IN_FICTITIOUS_CUBE) then
+ iregion = IREGION_ATTENUATION_INNER_CORE
+ else
+! this is fictitious for the outer core, which has no Qmu attenuation since it is fluid
+! iregion = IREGION_ATTENUATION_80_SURFACE + 1
+ iregion = IREGION_ATTENUATION_UNDEFINED
+ endif
+
+ else
+
+ if(iflag == IFLAG_MANTLE_NORMAL) then
+ iregion = IREGION_ATTENUATION_CMB_670
+ else if(iflag == IFLAG_670_220) then
+ iregion = IREGION_ATTENUATION_670_220
+ else if(iflag == IFLAG_220_80) then
+ iregion = IREGION_ATTENUATION_220_80
+ else if(iflag == IFLAG_CRUST .or. iflag == IFLAG_80_MOHO) then
+ iregion = IREGION_ATTENUATION_80_SURFACE
+ else
+! this is fictitious for the outer core, which has no Qmu attenuation since it is fluid
+! iregion = IREGION_ATTENUATION_80_SURFACE + 1
+ iregion = IREGION_ATTENUATION_UNDEFINED
+ endif
+
+ endif
+
+! Clamp regions
+ if(index < AM_V%Qrmin(iregion)) index = AM_V%Qrmin(iregion)
+ if(index > AM_V%Qrmax(iregion)) index = AM_V%Qrmax(iregion)
+
+end subroutine get_attenuation_index
+
+subroutine get_attenuation_model_3D(myrank, one_minus_sum_beta, factor_common, scale_factor, tau_s, vnspec)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer myrank, vnspec
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,vnspec) :: one_minus_sum_beta, scale_factor
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,vnspec) :: factor_common
+ double precision, dimension(N_SLS) :: tau_s
+
+ integer i,j,k,ispec
+
+ double precision, dimension(N_SLS) :: tau_e, fc
+ double precision omsb, Q_mu, sf, T_c_source, scale_t
+
+ ! All of the following reads use the output parameters as their temporary arrays
+ ! use the filename to determine the actual contents of the read
+
+ print *,'DK DK we should do this in MPI instead of reading from a local file'
+
+ stop 'DK DK code to create OUTPUT_FILES/attenuation3D.bin not included yet in this merged version'
+
+ open(unit=27, file='OUTPUT_FILES/attenuation3D.bin',status='old',action='read',form='unformatted')
+ read(27) tau_s
+ read(27) factor_common
+ read(27) scale_factor
+ read(27) T_c_source
+ close(27)
+
+ scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
+
+ factor_common(:,:,:,:,:) = factor_common(:,:,:,:,:) / scale_t ! This is really tau_e, not factor_common
+ tau_s(:) = tau_s(:) / scale_t
+ T_c_source = 1000.0d0 / T_c_source
+ T_c_source = T_c_source / scale_t
+
+ do ispec = 1, vnspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ tau_e(:) = factor_common(:,i,j,k,ispec)
+ Q_mu = scale_factor(i,j,k,ispec)
+
+ ! Determine the factor_common and one_minus_sum_beta from tau_s and tau_e
+ call attenuation_property_values(tau_s, tau_e, fc, omsb)
+
+ factor_common(:,i,j,k,ispec) = fc(:)
+ one_minus_sum_beta(i,j,k,ispec) = omsb
+
+ ! Determine the "scale_factor" from tau_s, tau_e, central source frequency, and Q
+ call attenuation_scale_factor(myrank, T_c_source, tau_e, tau_s, Q_mu, sf)
+ scale_factor(i,j,k,ispec) = sf
+ enddo
+ enddo
+ enddo
+ enddo
+end subroutine get_attenuation_model_3D
+
+subroutine attenuation_source_frequency(omega_not, min_period, max_period)
+ ! Determine the Source Frequency
+
+ implicit none
+
+ double precision omega_not
+ double precision f1, f2
+ double precision min_period, max_period
+
+ f1 = 1.0d0 / max_period
+ f2 = 1.0d0 / min_period
+
+ omega_not = 1.0e+03 * 10.0d0**(0.5 * (log10(f1) + log10(f2)))
+
+end subroutine attenuation_source_frequency
+
+subroutine attenuation_tau_sigma(tau_s, n, min_period, max_period)
+ ! Set the Tau_sigma (tau_s) to be equally spaced in log10 frequency
+
+ implicit none
+
+ integer n
+ double precision tau_s(n)
+ double precision min_period, max_period
+ double precision f1, f2
+ double precision exp1, exp2
+ double precision dexp
+ integer i
+ double precision, parameter :: PI = 3.14159265358979d0
+
+ f1 = 1.0d0 / max_period
+ f2 = 1.0d0 / min_period
+
+ exp1 = log10(f1)
+ exp2 = log10(f2)
+
+ dexp = (exp2-exp1) / ((n*1.0d0) - 1)
+ do i = 1,n
+ tau_s(i) = 1.0 / (PI * 2.0d0 * 10**(exp1 + (i - 1)* 1.0d0 *dexp))
+ enddo
+
+end subroutine attenuation_tau_sigma
+
+subroutine attenuation_invert_by_simplex(t2, t1, n, Q_real, omega_not, tau_s, tau_e, AS_V)
+
+ implicit none
+
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ ! Input / Output
+ integer myrank
+#ifdef USE_MPI
+ integer :: ier
+#endif
+ double precision t1, t2
+ double precision Q_real
+ double precision omega_not
+ integer n
+ double precision, dimension(n) :: tau_s, tau_e
+
+ ! Internal
+ integer i, iterations, err,prnt
+ double precision f1, f2, exp1,exp2,dexp, min_value
+ double precision, allocatable, dimension(:) :: f
+ double precision, parameter :: PI = 3.14159265358979d0
+ integer, parameter :: nf = 100
+ double precision, external :: attenuation_eval
+
+ ! Values to be passed into the simplex minimization routine
+ iterations = -1
+ min_value = -1.0e-4
+ err = 0
+ prnt = 0
+
+ allocate(f(nf))
+ ! Determine the min and max frequencies
+ f1 = 1.0d0 / t1
+ f2 = 1.0d0 / t2
+
+ ! Determine the exponents of the frequencies
+ exp1 = log10(f1)
+ exp2 = log10(f2)
+
+ if(f2 < f1 .OR. Q_real < 0.0d0 .OR. n < 1) then
+#ifdef USE_MPI
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+#else
+ myrank = 0
+#endif
+ call exit_MPI(myrank, 'frequencies flipped or Q less than zero or N_SLS < 0')
+ endif
+
+ ! Determine the Source frequency
+ omega_not = 1.0e+03 * 10.0d0**(0.5 * (log10(f1) + log10(f2)))
+
+ ! Determine the Frequencies at which to compare solutions
+ ! The frequencies should be equally spaced in log10 frequency
+ do i = 1,nf
+ f(i) = exp1 + ((i-1)*1.0d0 * (exp2-exp1) / ((nf-1)*1.0d0))
+ enddo
+
+ ! Set the Tau_sigma (tau_s) to be equally spaced in log10 frequency
+ dexp = (exp2-exp1) / ((n*1.0d0) - 1)
+ do i = 1,n
+ tau_s(i) = 1.0 / (PI * 2.0d0 * 10**(exp1 + (i - 1)* 1.0d0 *dexp))
+ enddo
+
+ ! Shove the paramters into the module
+ call attenuation_simplex_setup(nf,n,f,Q_real,tau_s,AS_V)
+
+ ! Set the Tau_epsilon (tau_e) to an initial value at omega*tau = 1
+ ! tan_delta = 1/Q = (tau_e - tau_s)/(2 * sqrt(tau e*tau_s))
+ ! if we assume tau_e =~ tau_s
+ ! we get the equation below
+ do i = 1,n
+ tau_e(i) = tau_s(i) + (tau_s(i) * 2.0d0/Q_real)
+ enddo
+
+ ! Run a simplex search to determine the optimum values of tau_e
+ call fminsearch(attenuation_eval, tau_e, n, iterations, min_value, err,AS_V)
+ if(err > 0) then
+ write(*,*)'Search did not converge for an attenuation of ', Q_real
+ write(*,*)' Iterations: ', iterations
+ write(*,*)' Min Value: ', min_value
+ write(*,*)' Aborting program'
+#ifdef USE_MPI
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+#else
+ myrank = 0
+#endif
+ call exit_MPI(myrank,'attenuation_simplex: Search for Strain relaxation times did not converge')
+ endif
+ deallocate(f)
+
+ call attenuation_simplex_finish(AS_V)
+
+end subroutine attenuation_invert_by_simplex
+
+subroutine attenuation_simplex_finish(AS_V)
+
+ implicit none
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ deallocate(AS_V%f)
+ deallocate(AS_V%tau_s)
+
+end subroutine attenuation_simplex_finish
+
+! - Inserts necessary parameters into the module attenuation_simplex_variables
+! - See module for explaination
+subroutine attenuation_simplex_setup(nf_in,nsls_in,f_in,Q_in,tau_s_in,AS_V)
+
+ implicit none
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ integer nf_in, nsls_in
+ double precision Q_in
+ double precision, dimension(nf_in) :: f_in
+ double precision, dimension(nsls_in) :: tau_s_in
+
+ allocate(AS_V%f(nf_in))
+ allocate(AS_V%tau_s(nsls_in))
+
+ AS_V%nf = nf_in
+ AS_V%nsls = nsls_in
+ AS_V%f = f_in
+ AS_V%Q = Q_in
+ AS_V%iQ = 1.0d0/AS_V%Q
+ AS_V%tau_s = tau_s_in
+
+end subroutine attenuation_simplex_setup
+
+! - Computes the Moduli (Maxwell Solid) for a series of
+! Standard Linear Solids
+! - Computes M1 and M2 parameters after Dahlen and Tromp pp.203
+! here called B and A after Liu et al. 1976
+! - Another formulation uses Kelvin-Voigt Solids and computes
+! Compliences J1 and J2 after Dahlen and Tromp pp.203
+!
+! Input
+! nf = Number of Frequencies
+! nsls = Number of Standard Linear Solids
+! f = Frequencies (in log10 of frequencies)
+! dimension(nf)
+! tau_s = Tau_sigma Stress relaxation time (see References)
+! dimension(nsls)
+! tau_e = Tau_epislon Strain relaxation time (see References)
+! dimension(nsls)!
+! Output
+! B = Real Moduli ( M2 Dahlen and Tromp pp.203 )
+! dimension(nf)
+! A = Imaginary Moduli ( M1 Dahlen and Tromp pp.203 )
+! dimension(nf)
+!
+! Dahlen and Tromp, 1998
+! Theoretical Global Seismology
+!
+! Liu et al. 1976
+! Velocity dispersion due to anelasticity: implications for seismology and mantle composition
+! Geophys, J. R. asts. Soc, Vol 47, pp. 41-58
+subroutine attenuation_maxwell(nf,nsls,f,tau_s,tau_e,B,A)
+
+ implicit none
+
+ ! Input
+ integer nf, nsls
+ double precision, dimension(nf) :: f
+ double precision, dimension(nsls) :: tau_s, tau_e
+ ! Output
+ double precision, dimension(nf) :: A,B
+
+ integer i,j
+ double precision w, pi, demon
+
+ PI = 3.14159265358979d0
+
+ A(:) = 1.0d0 - nsls*1.0d0
+ B(:) = 0.0d0
+ do i = 1,nf
+ w = 2.0d0 * PI * 10**f(i)
+ do j = 1,nsls
+ demon = 1.0d0 + w**2 * tau_s(j)**2
+ A(i) = A(i) + ((1.0d0 + (w**2 * tau_e(j) * tau_s(j)))/ demon)
+ B(i) = B(i) + ((w * (tau_e(j) - tau_s(j))) / demon)
+ enddo
+ enddo
+
+end subroutine attenuation_maxwell
+
+! - Computes the misfit from a set of relaxation paramters
+! given a set of frequencies and target attenuation
+! - Evaluates only at the given frequencies
+! - Evaluation is done with an L2 norm
+!
+! Input
+! Xin = Tau_epsilon, Strain Relaxation Time
+! Note: Tau_sigma the Stress Relaxation Time is loaded
+! with attenuation_simplex_setup and stored in
+! attenuation_simplex_variables
+!
+! Xi = Sum_i^N sqrt [ (1/Qc_i - 1/Qt_i)^2 / 1/Qt_i^2 ]
+!
+! where Qc_i is the computed attenuation at a specific frequency
+! Qt_i is the desired attenuaiton at that frequency
+!
+! Uses attenuation_simplex_variables to store constant values
+!
+! See atteunation_simplex_setup
+!
+double precision function attenuation_eval(Xin,AS_V)
+
+ implicit none
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ ! Input
+ double precision, dimension(AS_V%nsls) :: Xin
+ double precision, dimension(AS_V%nsls) :: tau_e
+
+ double precision, dimension(AS_V%nf) :: A, B, tan_delta
+
+ integer i
+ double precision xi, iQ2
+
+ tau_e = Xin
+
+ call attenuation_maxwell(AS_V%nf,AS_V%nsls,AS_V%f,AS_V%tau_s,tau_e,B,A)
+
+ tan_delta = B / A
+
+ attenuation_eval = 0.0d0
+ iQ2 = AS_V%iQ**2
+ do i = 1,AS_V%nf
+ xi = sqrt(( ( (tan_delta(i) - AS_V%iQ) ** 2 ) / iQ2 ))
+ attenuation_eval = attenuation_eval + xi
+ enddo
+
+end function attenuation_eval
+
+! subroutine fminsearch
+! - Computes the minimization of funk(x(n)) using the simplex method
+! - This subroutine is similar to Matlab's fminsearch.m
+! and modified to suit our needs
+! Input
+! funk = double precision function with one input parameter
+! double precision function the_funk(x)
+! x = Input/Output
+! variables to be minimized
+! dimension(n)
+! Input: Initial Value
+! Output: Mimimized Value
+! n = number of variables
+! itercount = Input/Output
+! Input: maximum number of iterations
+! if < 0 default is used (200 * n)
+! Output: total number of iterations on output
+! tolf = Input/Output
+! Input: minimium tolerance of the function funk(x)
+! Output: minimium value of funk(x)(i.e. "a" solution)
+! err = Output
+! 0 => Normal exeecution, converged within desired range
+! 1 => Function Evaluation exceeded limit
+! 2 => Iterations exceeded limit
+!
+subroutine fminsearch(funk, x, n, itercount, tolf, err, AS_V)
+
+ implicit none
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ ! Input
+ double precision, external :: funk
+
+ integer n
+ double precision x(n) ! Also Output
+ integer itercount, err
+ double precision tolf
+
+ !Internal
+ integer i,j, how
+ integer, parameter :: none = 0
+ integer, parameter :: initial = 1
+ integer, parameter :: expand = 2
+ integer, parameter :: reflect = 3
+ integer, parameter :: contract_outside = 4
+ integer, parameter :: contract_inside = 5
+ integer, parameter :: shrink = 6
+
+ integer maxiter, maxfun
+ integer func_evals
+ double precision tolx
+
+ double precision rho, chi, psi, sigma
+ double precision xin(n), y(n), v(n,n+1), fv(n+1)
+ double precision vtmp(n,n+1)
+ double precision usual_delta, zero_term_delta
+ double precision xbar(n), xr(n), fxr, xe(n), fxe, xc(n), fxc, fxcc, xcc(n)
+ integer place(n+1)
+
+ double precision max_size_simplex, max_value
+
+ rho = 1.0d0
+ chi = 2.0d0
+ psi = 0.5d0
+ sigma = 0.5d0
+
+
+ if(itercount > 0) then
+ maxiter = itercount
+ else
+ maxiter = 200 * n
+ endif
+ itercount = 0
+ maxfun = 200 * n
+
+ if(tolf > 0.0d0) then
+ tolx = 1.0e-4
+ else
+ tolx = 1.0e-4
+ tolf = 1.0e-4
+ endif
+
+ err = 0
+
+ xin = x
+ v(:,:) = 0.0d0
+ fv(:) = 0.0d0
+
+ v(:,1) = xin
+ x = xin
+
+ fv(1) = funk(xin,AS_V)
+
+ usual_delta = 0.05
+ zero_term_delta = 0.00025
+
+ do j = 1,n
+ y = xin
+ if(y(j) /= 0.0d0) then
+ y(j) = (1.0d0 + usual_delta) * y(j)
+ else
+ y(j) = zero_term_delta
+ endif
+ v(:,j+1) = y
+ x(:) = y
+ fv(j+1) = funk(x,AS_V)
+ enddo
+
+ call qsort(fv,n+1,place)
+
+ do i = 1,n+1
+ vtmp(:,i) = v(:,place(i))
+ enddo
+ v = vtmp
+
+ how = initial
+ itercount = 1
+ func_evals = n+1
+
+ do while (func_evals < maxfun .AND. itercount < maxiter)
+
+ if(max_size_simplex(v,n) <= tolx .AND. &
+ max_value(fv,n+1) <= tolf) then
+ goto 888
+ endif
+ how = none
+
+ ! xbar = average of the n (NOT n+1) best points
+ ! xbar = sum(v(:,1:n), 2)/n
+ xbar(:) = 0.0d0
+ do i = 1,n
+ do j = 1,n
+ xbar(i) = xbar(i) + v(i,j)
+ enddo
+ xbar(i) = xbar(i) / (n*1.0d0)
+ enddo
+ xr = (1 + rho)*xbar - rho*v(:,n+1)
+ x(:) = xr
+ fxr = funk(x,AS_V)
+ func_evals = func_evals + 1
+ if (fxr < fv(1)) then
+ ! Calculate the expansion point
+ xe = (1 + rho*chi)*xbar - rho*chi*v(:,n+1)
+ x = xe
+ fxe = funk(x,AS_V)
+ func_evals = func_evals+1
+ if (fxe < fxr) then
+ v(:,n+1) = xe
+ fv(n+1) = fxe
+ how = expand
+ else
+ v(:,n+1) = xr
+ fv(n+1) = fxr
+ how = reflect
+ endif
+ else ! fv(:,1) <= fxr
+ if (fxr < fv(n)) then
+ v(:,n+1) = xr
+ fv(n+1) = fxr
+ how = reflect
+ else ! fxr >= fv(:,n)
+ ! Perform contraction
+ if (fxr < fv(n+1)) then
+ ! Perform an outside contraction
+ xc = (1 + psi*rho)*xbar - psi*rho*v(:,n+1)
+ x(:) = xc
+ fxc = funk(x,AS_V)
+ func_evals = func_evals+1
+
+ if (fxc <= fxr) then
+ v(:,n+1) = xc
+ fv(n+1) = fxc
+ how = contract_outside
+ else
+ ! perform a shrink
+ how = shrink
+ endif
+ else
+ ! Perform an inside contraction
+ xcc = (1-psi)*xbar + psi*v(:,n+1)
+ x(:) = xcc
+ fxcc = funk(x,AS_V)
+ func_evals = func_evals+1
+
+ if (fxcc < fv(n+1)) then
+ v(:,n+1) = xcc
+ fv(n+1) = fxcc
+ how = contract_inside
+ else
+ ! perform a shrink
+ how = shrink
+ endif
+ endif
+ if (how == shrink) then
+ do j=2,n+1
+ v(:,j)=v(:,1)+sigma*(v(:,j) - v(:,1))
+ x(:) = v(:,j)
+ fv(j) = funk(x,AS_V)
+ enddo
+ func_evals = func_evals + n
+ endif
+ endif
+ endif
+
+ call qsort(fv,n+1,place)
+ do i = 1,n+1
+ vtmp(:,i) = v(:,place(i))
+ enddo
+ v = vtmp
+
+ itercount = itercount + 1
+ enddo
+
+ if(func_evals > maxfun) then
+ write(*,*)'function evaluations exceeded prescribed limit', maxfun
+ stop 'err = 1'
+ endif
+ if(itercount > maxiter) then
+ write(*,*)'iterations exceeded prescribed limit', maxiter
+ stop 'err = 2'
+ endif
+
+888 continue
+ x = v(:,1)
+ tolf = fv(1)
+
+end subroutine fminsearch
+
+! - Finds the maximim value of the difference of between the first
+! value and the remaining values of a vector
+! Input
+! fv = Input
+! Vector
+! dimension(n)
+! n = Input
+! Length of fv
+!
+! Returns:
+! Xi = max( || fv(1)- fv(i) || ) for i=2:n
+!
+double precision function max_value(fv,n)
+ implicit none
+ integer n
+ double precision fv(n)
+
+ integer i
+ double precision m, z
+
+ m = 0.0d0
+ do i = 2,n
+ z = abs(fv(1) - fv(i))
+ if(z > m) then
+ m = z
+ endif
+ enddo
+
+ max_value = m
+
+end function max_value
+
+! - Determines the maximum distance between two point in a simplex
+! Input
+! v = Input
+! Simplex Verticies
+! dimension(n, n+1)
+! n = Pseudo Length of n
+!
+! Returns:
+! Xi = max( max( || v(:,1) - v(:,i) || ) ) for i=2:n+1
+!
+double precision function max_size_simplex(v,n)
+ implicit none
+ integer n
+ double precision v(n,n+1)
+
+ integer i,j
+ double precision m, z
+
+ m = 0.0d0
+ do i = 1,n
+ do j = 2,n+1
+ z = abs(v(i,j) - v(i,1))
+ if(z > m) then
+ m = z
+ endif
+ enddo
+ enddo
+
+ max_size_simplex = m
+
+end function max_size_simplex
+
+! - Implementation of a Bubble Sort Routine
+! Input
+! X = Input/Output
+! Vector to be sorted
+! dimension(n)
+! n = Input
+! Length of X
+! I = Output
+! Sorted Indicies of vecotr X
+!
+! Example:
+! X = [ 4 3 1 2 ] on Input
+! I = [ 1 2 3 4 ] Computed Internally (in order)
+!
+! X = [ 1 2 3 4 ] on Output
+! I = [ 3 4 2 1 ] on Output
+!
+subroutine qsort(X,n,I)
+
+ implicit none
+
+ integer n
+ double precision X(n)
+ integer I(n)
+
+ integer j,k
+ double precision rtmp
+ integer itmp
+
+ do j = 1,n
+ I(j) = j
+ enddo
+
+ do j = 1,n
+ do k = 1,n-j
+ if(X(k+1) < X(k)) then
+ rtmp = X(k)
+ X(k) = X(k+1)
+ X(k+1) = rtmp
+
+ itmp = I(k)
+ I(k) = I(k+1)
+ I(k+1) = itmp
+ endif
+ enddo
+ enddo
+
+end subroutine qsort
+
+! Piecewise Continuous Splines
+! - Added Steps which describes the discontinuities
+! - Steps must be repeats in the dependent variable, X
+! - Derivates at the steps are computed using the point
+! at the derivate and the closest point within that piece
+! - A point lying directly on the discontinuity will recieve the
+! value of the first or smallest piece in terms of X
+! - Beginning and Ending points of the Function become beginning
+! and ending points of the first and last splines
+! - A Step with a value of zero is undefined
+! - Works with functions with steps or no steps
+! See the comment below about the ScS bug
+subroutine pspline_evaluation(xa, ya, y2a, n, x, y, steps)
+
+ implicit none
+
+ integer n
+ double precision xa(n),ya(n),y2a(n)
+ integer steps(n)
+ double precision x, y
+
+ integer i, l, n1, n2
+
+ do i = 1,n-1,1
+ if(steps(i+1) == 0) return
+ if(x >= xa(steps(i)) .and. x <= xa(steps(i+1))) then
+ call pspline_piece(i,n1,n2,l,n,steps)
+ call spline_evaluation(xa(n1), ya(n1), y2a(n1), l, x, y)
+! return <-- Commented out to fix ScS bug
+ endif
+ enddo
+
+end subroutine pspline_evaluation
+
+subroutine pspline_piece(i,n1,n2,l,n,s)
+
+ implicit none
+
+ integer i, n1, n2, l, n, s(n)
+ n1 = s(i)+1
+ if(i == 1) n1 = s(i)
+ n2 = s(i+1)
+ l = n2 - n1 + 1
+
+end subroutine pspline_piece
+
+subroutine pspline_construction(x, y, n, yp1, ypn, y2, steps)
+
+ implicit none
+
+ integer n
+ double precision x(n),y(n),y2(n)
+ double precision yp1, ypn
+ integer steps(n)
+
+ integer i,r, l, n1,n2
+
+ steps(:) = 0
+
+ ! Find steps in x, defining pieces
+ steps(1) = 1
+ r = 2
+ do i = 2,n
+ if(x(i) == x(i-1)) then
+ steps(r) = i-1
+ r = r + 1
+ endif
+ enddo
+ steps(r) = n
+
+ ! Run spline for each piece
+ do i = 1,r-1
+ call pspline_piece(i,n1,n2,l,n,steps)
+ ! Determine the First Derivates at Begin/End Points
+ yp1 = ( y(n1+1) - y(n1) ) / ( x(n1+1) - x(n1))
+ ypn = ( y(n2) - y(n2-1) ) / ( x(n2) - x(n2-1))
+ call spline_construction(x(n1),y(n1),l,yp1,ypn,y2(n1))
+ enddo
+
+end subroutine pspline_construction
+
+subroutine attenuation_model_1D_PREM(x, Qmu, iflag)
+
+! x in the radius from 0 to 1 where 0 is the center and 1 is the surface
+! This version is for 1D PREM.
+
+ implicit none
+
+ include 'constants.h'
+
+ integer iflag
+ double precision r, x, Qmu,RICB,RCMB, &
+ RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R80, ROCEAN, RMOHO, RMIDDLE_CRUST
+ double precision Qkappa
+
+ r = x * R_EARTH
+
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R220 = 6151000.d0
+ R400 = 5971000.d0
+ R600 = 5771000.d0
+ R670 = 5701000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3480000.d0
+ RICB = 1221000.d0
+
+! PREM
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r <= RICB) then
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if(r > RICB .and. r <= RCMB) then
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+ if(RCMB - r < r - RICB) then
+ Qmu = 312.0d0 ! CMB
+ else
+ Qmu = 84.6d0 ! ICB
+ endif
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= R600) then
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R600 .and. r <= R400) then
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R400 .and. r <= R220) then
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R220 .and. r <= R80) then
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+ else if(r > R80) then
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+ ! We determine the attenuation value here dependent on the doubling flag and
+ ! which region we are sitting in. The radius reported is not accurate for
+ ! determination of which region we are actually in, whereas the idoubling flag is
+ if(iflag == IFLAG_INNER_CORE_NORMAL .or. iflag == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ iflag == IFLAG_BOTTOM_CENTRAL_CUBE .or. iflag == IFLAG_TOP_CENTRAL_CUBE .or. &
+ iflag == IFLAG_IN_FICTITIOUS_CUBE) then
+ Qmu = 84.6d0
+ Qkappa = 1327.7d0
+ else if(iflag == IFLAG_OUTER_CORE_NORMAL) then
+ Qmu = 0.0d0
+ Qkappa = 57827.0d0
+ else if(iflag == IFLAG_MANTLE_NORMAL) then ! D'' to 670 km
+ Qmu = 312.0d0
+ Qkappa = 57827.0d0
+ else if(iflag == IFLAG_670_220) then
+ Qmu=143.0d0
+ Qkappa = 57827.0d0
+ else if(iflag == IFLAG_220_80) then
+ Qmu=80.0d0
+ Qkappa = 57827.0d0
+ else if(iflag == IFLAG_80_MOHO) then
+ Qmu=600.0d0
+ Qkappa = 57827.0d0
+ else if(iflag == IFLAG_CRUST) then
+ Qmu=600.0d0
+ Qkappa = 57827.0d0
+ else
+ call exit_mpi_without_rank('Invalid idoubling flag in attenuation_model_1D_prem from get_model()')
+ endif
+
+end subroutine attenuation_model_1D_PREM
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/attenuation_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/attenuation_model.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/attenuation_model.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,1876 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! 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.
-!
-!=====================================================================
-
-! This portion of the SPECFEM3D Code was written by:
-! Brian Savage while at
-! California Institute of Technology
-! Department of Terrestrial Magnetism / Carnegie Institute of Washington
-! Univeristy of Rhode Island
-! <savage at uri.edu>.
-!
-! It is based upon formulation in the following references:
-!
-! Dahlen and Tromp, 1998
-! Theoretical Global Seismology
-!
-! Liu et al. 1976
-! Velocity dispersion due to anelasticity: implications for seismology and mantle composition
-! Geophys, J. R. asts. Soc, Vol 47, pp. 41-58
-!
-! The methodology can be found in Savage and Tromp, 2006, unpublished
-!
-
-subroutine attenuation_lookup_value(i, r)
-
- implicit none
-
- include 'constants.h'
-
- integer i
- double precision r
-
- r = dble(i) / TABLE_ATTENUATION
-
-end subroutine attenuation_lookup_value
-
-! This Subroutine is Hackish. It could probably all be moved to an input attenuation file.
-! Actually all the velocities, densities and attenuations could be moved to seperate input
-! files rather than be defined within the CODE
-!
-! All this subroutine does is define the Attenuation vs Radius and then Compute the Attenuation
-! Variables (tau_sigma and tau_epslion ( or tau_mu) )
-subroutine attenuation_model_setup(REFERENCE_1D_MODEL,RICB,RCMB,R670,R220,R80,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,AM_S,AS_V)
-
- implicit none
-
- include 'mpif.h'
- include 'constants.h'
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: interval_Q ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
-! model_1066a_variables
- type model_1066a_variables
- sequence
- double precision, dimension(NR_1066A) :: radius_1066a
- double precision, dimension(NR_1066A) :: density_1066a
- double precision, dimension(NR_1066A) :: vp_1066a
- double precision, dimension(NR_1066A) :: vs_1066a
- double precision, dimension(NR_1066A) :: Qkappa_1066a
- double precision, dimension(NR_1066A) :: Qmu_1066a
- end type model_1066a_variables
-
- type (model_1066a_variables) M1066a_V
-! model_1066a_variables
-
-! model_ak135_variables
- type model_ak135_variables
- sequence
- double precision, dimension(NR_AK135) :: radius_ak135
- double precision, dimension(NR_AK135) :: density_ak135
- double precision, dimension(NR_AK135) :: vp_ak135
- double precision, dimension(NR_AK135) :: vs_ak135
- double precision, dimension(NR_AK135) :: Qkappa_ak135
- double precision, dimension(NR_AK135) :: Qmu_ak135
- end type model_ak135_variables
-
- type (model_ak135_variables) Mak135_V
-! model_ak135_variables
-
-! model_ref_variables
- type model_ref_variables
- sequence
- double precision, dimension(NR_REF) :: radius_ref
- double precision, dimension(NR_REF) :: density_ref
- double precision, dimension(NR_REF) :: vpv_ref
- double precision, dimension(NR_REF) :: vph_ref
- double precision, dimension(NR_REF) :: vsv_ref
- double precision, dimension(NR_REF) :: vsh_ref
- double precision, dimension(NR_REF) :: eta_ref
- double precision, dimension(NR_REF) :: Qkappa_ref
- double precision, dimension(NR_REF) :: Qmu_ref
- end type model_ref_variables
-
- type (model_ref_variables) Mref_V
-! model_ref_variables
-
-! sea1d_model_variables
- type sea1d_model_variables
- sequence
- double precision, dimension(NR_SEA1D) :: radius_sea1d
- double precision, dimension(NR_SEA1D) :: density_sea1d
- double precision, dimension(NR_SEA1D) :: vp_sea1d
- double precision, dimension(NR_SEA1D) :: vs_sea1d
- double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
- double precision, dimension(NR_SEA1D) :: Qmu_sea1d
- end type sea1d_model_variables
-
- type (sea1d_model_variables) SEA1DM_V
-! sea1d_model_variables
-
-! attenuation_model_storage
- type attenuation_model_storage
- sequence
- integer Q_resolution
- integer Q_max
- double precision, dimension(:,:), pointer :: tau_e_storage
- double precision, dimension(:), pointer :: Qmu_storage
- end type attenuation_model_storage
-
- type (attenuation_model_storage) AM_S
-! attenuation_model_storage
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- double precision Q ! Q = Desired Value of Attenuation or Q
- double precision iQ ! iQ = 1/Q
- double precision, dimension(:), pointer :: f
- ! f = Frequencies at which to evaluate the solution
- double precision, dimension(:), pointer :: tau_s
- ! tau_s = Tau_sigma defined by the frequency range and
- ! number of standard linear solids
- end type attenuation_simplex_variables
-
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
- integer myrank
- integer REFERENCE_1D_MODEL
- double precision RICB, RCMB, R670, R220, R80
- double precision tau_e(N_SLS)
-
- integer i,ier
- double precision Qb
- double precision R120
-
- Qb = 57287.0d0
- R120 = 6251.d3
-
- call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
- if(myrank > 0) return
-
- if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
- AM_V%Qn = 12
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
- AM_V%Qn = 12
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
- call define_model_ak135(.FALSE.,Mak135_V)
- AM_V%Qn = NR_AK135
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
- call define_model_1066a(.FALSE., M1066a_V)
- AM_V%Qn = NR_1066A
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
- call define_model_ref(Mref_V)
- AM_V%Qn = NR_REF
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
- AM_V%Qn = 12
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
- call define_model_sea1d(.FALSE., SEA1DM_V)
- AM_V%Qn = NR_SEA1D
- else
- call exit_MPI(myrank, 'Reference 1D Model Not recognized')
- endif
-
-!! DK DK could allocate these automatic arrays here and in the rest of this file
-!! DK DK in the memory stack to avoid memory fragmentation with "allocate()"
- allocate(AM_V%Qr(AM_V%Qn))
- allocate(AM_V%Qmu(AM_V%Qn))
- allocate(AM_V%interval_Q(AM_V%Qn))
- allocate(AM_V%Qtau_e(N_SLS,AM_V%Qn))
-
- if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
- AM_V%Qr(:) = (/ 0.0d0, RICB, RICB, RCMB, RCMB, R670, R670, R220, R220, R80, R80, R_EARTH /)
- AM_V%Qmu(:) = (/ 84.6d0, 84.6d0, 0.0d0, 0.0d0, 312.0d0, 312.0d0, 143.0d0, 143.0d0, 80.0d0, 80.0d0, 600.0d0, 600.0d0 /)
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
- AM_V%Qr(:) = (/ 0.0d0, RICB, RICB, RCMB, RCMB, R670, R670, R220, R220, R120, R120, R_EARTH /)
- AM_V%Qmu(:) = (/ 84.6d0, 84.6d0, 0.0d0, 0.0d0, 312.0d0, 312.0d0, 143.0d0, 143.0d0, 80.0d0, 80.0d0, 600.0d0, 600.0d0 /)
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
- AM_V%Qr(:) = Mak135_V%radius_ak135(:)
- AM_V%Qmu(:) = Mak135_V%Qmu_ak135(:)
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
- AM_V%Qr(:) = M1066a_V%radius_1066a(:)
- AM_V%Qmu(:) = M1066a_V%Qmu_1066a(:)
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_ref) then
- AM_V%Qr(:) = Mref_V%radius_ref(:)
- AM_V%Qmu(:) = Mref_V%Qmu_ref(:)
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
- AM_V%Qr(:) = (/ 0.0d0, RICB, RICB, RCMB, RCMB, R670, R670, R220, R220, R120, R120, R_EARTH /)
- AM_V%Qmu(:) = (/ 84.6d0, 84.6d0, 0.0d0, 0.0d0, 312.0d0, 312.0d0, 143.0d0, 143.0d0, 80.0d0, 80.0d0, 600.0d0, 600.0d0 /)
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
- AM_V%Qr(:) = SEA1DM_V%radius_sea1d(:)
- AM_V%Qmu(:) = SEA1DM_V%Qmu_sea1d(:)
- endif
-
- do i = 1, AM_V%Qn
- call attenuation_conversion(AM_V%Qmu(i), AM_V%QT_c_source, AM_V%Qtau_s, tau_e, AM_V, AM_S,AS_V)
- AM_V%Qtau_e(:,i) = tau_e(:)
- enddo
-
-end subroutine attenuation_model_setup
-
-subroutine attenuation_save_arrays(iregion_code, AM_V)
-
- implicit none
-
- include 'mpif.h'
- include 'constants.h'
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: interval_Q ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
- integer iregion_code
- integer ier
- integer myrank
- integer, save :: first_time_called = 1
-
- print *,'DK DK we should do this in MPI instead of writing to a local file'
-
- call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
- if(myrank == 0 .AND. iregion_code == IREGION_CRUST_MANTLE .AND. first_time_called == 1) then
- first_time_called = 0
- open(unit=27,file='OUTPUT_FILES/1D_Q.bin',status='unknown',form='unformatted',action='write')
- write(27) AM_V%QT_c_source
- write(27) AM_V%Qtau_s
- write(27) AM_V%Qn
- write(27) AM_V%Qr
- write(27) AM_V%Qmu
- write(27) AM_V%Qtau_e
- close(27)
- endif
-
-end subroutine attenuation_save_arrays
-
-subroutine attenuation_storage(Qmu, tau_e, rw, AM_S)
-
- implicit none
- include 'mpif.h'
- include 'constants.h'
-
-! attenuation_model_storage
- type attenuation_model_storage
- sequence
- integer Q_resolution
- integer Q_max
- double precision, dimension(:,:), pointer :: tau_e_storage
- double precision, dimension(:), pointer :: Qmu_storage
- end type attenuation_model_storage
-
- type (attenuation_model_storage) AM_S
-! attenuation_model_storage
-
- integer myrank, ier
- double precision Qmu, Qmu_new
- double precision, dimension(N_SLS) :: tau_e
- integer rw
-
- integer Qtmp
- integer, save :: first_time_called = 1
-
- if(first_time_called == 1) then
- first_time_called = 0
- AM_S%Q_resolution = 10**ATTENUATION_COMP_RESOLUTION
- AM_S%Q_max = ATTENUATION_COMP_MAXIMUM
- Qtmp = AM_S%Q_resolution * AM_S%Q_max
- allocate(AM_S%tau_e_storage(N_SLS, Qtmp))
- allocate(AM_S%Qmu_storage(Qtmp))
- AM_S%Qmu_storage(:) = -1
- endif
-
- if(Qmu < 0.0d0 .OR. Qmu >= AM_S%Q_max) then
- write(IMAIN,*) 'Error'
- write(IMAIN,*) 'attenuation_conversion/storage()'
- write(IMAIN,*) 'Attenuation Value out of Range: ', Qmu
- write(IMAIN,*) 'Attenuation Value out of Range: Min, Max ', 0, AM_S%Q_max
- call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
- call exit_MPI(myrank, 'Attenuation Value out of Range')
- endif
-
- if(rw > 0 .AND. Qmu == 0.0d0) then
- Qmu = 0.0d0;
- tau_e(:) = 0.0d0;
- return
- endif
- ! Generate index for Storage Array
- ! and Recast Qmu using this index
- ! Accroding to Brian, use float
- !Qtmp = Qmu * Q_resolution
- !Qmu = Qtmp / Q_resolution;
-
- !
- Qtmp = Qmu * dble(AM_S%Q_resolution)
- Qmu_new = dble(Qtmp) / dble(AM_S%Q_resolution)
-
- if(rw > 0) then
- ! READ
- if(AM_S%Qmu_storage(Qtmp) > 0) then
- ! READ SUCCESSFUL
- tau_e(:) = AM_S%tau_e_storage(:, Qtmp)
- Qmu = AM_S%Qmu_storage(Qtmp)
- rw = 1
- else
- ! READ NOT SUCCESSFUL
- rw = -1
- endif
- else
- ! WRITE SUCCESSFUL
- AM_S%tau_e_storage(:,Qtmp) = tau_e(:)
- AM_S%Qmu_storage(Qtmp) = Qmu
- rw = 1
- endif
-
-end subroutine attenuation_storage
-
-subroutine attenuation_conversion(Qmu_in, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
-! includes min_period, max_period, and N_SLS
-
- implicit none
-
- include 'constants.h'
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: interval_Q ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
-! attenuation_model_storage
- type attenuation_model_storage
- sequence
- integer Q_resolution
- integer Q_max
- double precision, dimension(:,:), pointer :: tau_e_storage
- double precision, dimension(:), pointer :: Qmu_storage
- end type attenuation_model_storage
-
- type (attenuation_model_storage) AM_S
-! attenuation_model_storage
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- double precision Q ! Q = Desired Value of Attenuation or Q
- double precision iQ ! iQ = 1/Q
- double precision, dimension(:), pointer :: f
- ! f = Frequencies at which to evaluate the solution
- double precision, dimension(:), pointer :: tau_s
- ! tau_s = Tau_sigma defined by the frequency range and
- ! number of standard linear solids
- end type attenuation_simplex_variables
-
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
- double precision Qmu_in, T_c_source
- double precision, dimension(N_SLS) :: tau_s, tau_e
-
- integer rw
-
- ! READ
- rw = 1
- call attenuation_storage(Qmu_in, tau_e, rw, AM_S)
- if(rw > 0) return
-
- call attenuation_invert_by_simplex(AM_V%min_period, AM_V%max_period, N_SLS, Qmu_in, T_c_source, tau_s, tau_e, AS_V)
-
- ! WRITE
- rw = -1
- call attenuation_storage(Qmu_in, tau_e, rw, AM_S)
-
-end subroutine attenuation_conversion
-
-subroutine read_attenuation_model(min, max, AM_V)
-
- implicit none
-
- include 'constants.h'
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: interval_Q ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
- integer min, max
-
- AM_V%min_period = min * 1.0d0
- AM_V%max_period = max * 1.0d0
-
- call attenuation_tau_sigma(AM_V%Qtau_s, N_SLS, AM_V%min_period, AM_V%max_period)
- call attenuation_source_frequency(AM_V%QT_c_source, AM_V%min_period, AM_V%max_period)
-
-end subroutine read_attenuation_model
-
-subroutine attenuation_memory_values(tau_s, deltat, alphaval,betaval,gammaval)
-
- implicit none
-
- include 'constants.h'
-
- double precision, dimension(N_SLS) :: tau_s, alphaval, betaval,gammaval
- real(kind=CUSTOM_REAL) deltat
-
- double precision, dimension(N_SLS) :: tauinv
-
- tauinv(:) = - 1.0 / tau_s(:)
-
- alphaval(:) = 1 + deltat*tauinv(:) + deltat**2*tauinv(:)**2 / 2. + &
- deltat**3*tauinv(:)**3 / 6. + deltat**4*tauinv(:)**4 / 24.
- betaval(:) = deltat / 2. + deltat**2*tauinv(:) / 3. + deltat**3*tauinv(:)**2 / 8. + deltat**4*tauinv(:)**3 / 24.
- gammaval(:) = deltat / 2. + deltat**2*tauinv(:) / 6. + deltat**3*tauinv(:)**2 / 24.0
-
-end subroutine attenuation_memory_values
-
-subroutine attenuation_scale_factor(myrank, T_c_source, tau_mu, tau_sigma, Q_mu, scale_factor)
-
- implicit none
-
- include 'constants.h'
-
- integer myrank
- double precision scale_factor, Q_mu, T_c_source
- double precision, dimension(N_SLS) :: tau_mu, tau_sigma
-
- double precision scale_t
- double precision f_c_source, w_c_source, f_0_prem
- double precision factor_scale_mu0, factor_scale_mu
- double precision a_val, b_val
- double precision big_omega
- integer i
-
- scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
-
-!--- compute central angular frequency of source (non dimensionalized)
- f_c_source = ONE / T_c_source
- w_c_source = TWO_PI * f_c_source
-
-!--- non dimensionalize PREM reference of 1 second
- f_0_prem = ONE / ( ONE / scale_t)
-
-!--- quantity by which to scale mu_0 to get mu
-! this formula can be found for instance in
-! Liu, H. P., Anderson, D. L. and Kanamori, H., Velocity dispersion due to
-! anelasticity: implications for seismology and mantle composition,
-! Geophys. J. R. Astron. Soc., vol. 47, pp. 41-58 (1976)
-! and in Aki, K. and Richards, P. G., Quantitative seismology, theory and methods,
-! W. H. Freeman, (1980), second edition, sections 5.5 and 5.5.2, eq. (5.81) p. 170
- factor_scale_mu0 = ONE + TWO * log(f_c_source / f_0_prem) / (PI * Q_mu)
-
-!--- compute a, b and Omega parameters, also compute one minus sum of betas
- a_val = ONE
- b_val = ZERO
-
- do i = 1,N_SLS
- a_val = a_val - w_c_source * w_c_source * tau_mu(i) * &
- (tau_mu(i) - tau_sigma(i)) / (1.d0 + w_c_source * w_c_source * tau_mu(i) * tau_mu(i))
- b_val = b_val + w_c_source * (tau_mu(i) - tau_sigma(i)) / &
- (1.d0 + w_c_source * w_c_source * tau_mu(i) * tau_mu(i))
- enddo
-
- big_omega = a_val*(sqrt(1.d0 + b_val*b_val/(a_val*a_val))-1.d0)
-
-!--- quantity by which to scale mu to get mu_relaxed
- factor_scale_mu = b_val * b_val / (TWO * big_omega)
-
-!--- total factor by which to scale mu0
- scale_factor = factor_scale_mu * factor_scale_mu0
-
-!--- check that the correction factor is close to one
- if(scale_factor < 0.9 .or. scale_factor > 1.1) then
- write(*,*)'scale factor: ', scale_factor
- call exit_MPI(myrank,'incorrect correction factor in attenuation model')
- endif
-
-end subroutine attenuation_scale_factor
-
-!----
-
-subroutine attenuation_property_values(tau_s, tau_e, factor_common, one_minus_sum_beta)
-
- implicit none
-
- include 'constants.h'
-
- double precision, dimension(N_SLS) :: tau_s, tau_e, beta, factor_common
- double precision one_minus_sum_beta
-
- double precision, dimension(N_SLS) :: tauinv
- integer i
-
- tauinv(:) = -1.0d0 / tau_s(:)
-
- beta(:) = 1.0d0 - tau_e(:) / tau_s(:)
- one_minus_sum_beta = 1.0d0
-
- do i = 1,N_SLS
- one_minus_sum_beta = one_minus_sum_beta - beta(i)
- enddo
-
- factor_common(:) = 2.0d0 * beta(:) * tauinv(:)
-
-end subroutine attenuation_property_values
-
-!---
-!---
-!---
-
-subroutine get_attenuation_model_1D(myrank, iregion_code, tau_s, one_minus_sum_beta, &
- factor_common, scale_factor, vn,vx,vy,vz, AM_V)
-
- implicit none
-
- include 'mpif.h'
- include 'constants.h'
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: interval_Q ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
- integer myrank, iregion_code
- integer vn, vx,vy,vz
- double precision, dimension(N_SLS) :: tau_s
- double precision, dimension(vx,vy,vz,vn) :: scale_factor, one_minus_sum_beta
- double precision, dimension(N_SLS, vx,vy,vz,vn) :: factor_common
-
- integer i,j,ier,rmax
- double precision scale_t
- double precision Qp1, Qpn, radius, fctmp
- double precision, dimension(:), allocatable :: Qfctmp, Qfc2tmp
-
- integer, save :: first_time_called = 1
-
- print *,'DK DK we should do this in MPI instead of writing to a local file'
-
- if(myrank == 0 .AND. iregion_code == IREGION_CRUST_MANTLE .AND. first_time_called == 1) then
- first_time_called = 0
- open(unit=27, file='OUTPUT_FILES/1D_Q.bin', status='unknown', form='unformatted',action='read')
- read(27) AM_V%QT_c_source
- read(27) tau_s
- read(27) AM_V%Qn
-
- allocate(AM_V%Qr(AM_V%Qn))
- allocate(AM_V%Qmu(AM_V%Qn))
- allocate(AM_V%Qtau_e(N_SLS,AM_V%Qn))
-
- read(27) AM_V%Qr
- read(27) AM_V%Qmu
- read(27) AM_V%Qtau_e
- close(27)
- endif
-
- ! Synch up after the Read
- call MPI_BCAST(AM_V%QT_c_source,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(tau_s,N_SLS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(AM_V%Qn,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- if(myrank /= 0) then
- allocate(AM_V%Qr(AM_V%Qn))
- allocate(AM_V%Qmu(AM_V%Qn))
- allocate(AM_V%Qtau_e(N_SLS,AM_V%Qn))
- endif
-
- call MPI_BCAST(AM_V%Qr,AM_V%Qn,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(AM_V%Qmu,AM_V%Qn,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(AM_V%Qtau_e,AM_V%Qn*N_SLS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
-
- ! Scale the Attenuation Values
- tau_s(:) = tau_s(:) / scale_t
- AM_V%Qtau_e(:,:) = AM_V%Qtau_e(:,:) / scale_t
- AM_V%QT_c_source = 1000.0d0 / AM_V%QT_c_source / scale_t
- AM_V%Qr(:) = AM_V%Qr(:) / R_EARTH
-
- allocate(AM_V%Qsf(AM_V%Qn))
- allocate(AM_V%Qomsb(AM_V%Qn))
- allocate(AM_V%Qfc(N_SLS,AM_V%Qn))
-
- allocate(AM_V%Qsf2(AM_V%Qn))
- allocate(AM_V%Qomsb2(AM_V%Qn))
- allocate(AM_V%Qfc2(N_SLS,AM_V%Qn))
-
- allocate(AM_V%interval_Q(AM_V%Qn))
-
- allocate(Qfctmp(AM_V%Qn))
- allocate(Qfc2tmp(AM_V%Qn))
-
- do i = 1,AM_V%Qn
- if(AM_V%Qmu(i) == 0.0d0) then
- AM_V%Qomsb(i) = 0.0d0
- AM_V%Qfc(:,i) = 0.0d0
- AM_V%Qsf(i) = 0.0d0
- else
- call attenuation_property_values(tau_s, AM_V%Qtau_e(:,i), AM_V%Qfc(:,i), AM_V%Qomsb(i))
- call attenuation_scale_factor(myrank, AM_V%QT_c_source, AM_V%Qtau_e(:,i), tau_s, AM_V%Qmu(i), AM_V%Qsf(i))
- endif
- enddo
-
- ! Determine the Spline Coefficients or Second Derivatives
- call pspline_construction(AM_V%Qr, AM_V%Qsf, AM_V%Qn, Qp1, Qpn, AM_V%Qsf2, AM_V%interval_Q)
- call pspline_construction(AM_V%Qr, AM_V%Qomsb, AM_V%Qn, Qp1, Qpn, AM_V%Qomsb2, AM_V%interval_Q)
- do i = 1,N_SLS
-! copy the sub-arrays to temporary arrays to avoid a warning by some compilers
-! about temporary arrays being created automatically when using this expression
-! directly in the call to the subroutine
- Qfctmp(:) = AM_V%Qfc(i,:)
- Qfc2tmp(:) = AM_V%Qfc2(i,:)
- call pspline_construction(AM_V%Qr, Qfctmp, AM_V%Qn, Qp1, Qpn, Qfc2tmp, AM_V%interval_Q)
-! copy the arrays back to the sub-arrays, since these sub-arrays are used
-! as input and output
- AM_V%Qfc(i,:) = Qfctmp(:)
- AM_V%Qfc2(i,:) = Qfc2tmp(:)
- enddo
-
- radius = 0.0d0
- rmax = nint(TABLE_ATTENUATION)
- do i = 1,rmax
- call attenuation_lookup_value(i, radius)
- call pspline_evaluation(AM_V%Qr, AM_V%Qsf, AM_V%Qsf2, AM_V%Qn, radius, scale_factor(1,1,1,i), AM_V%interval_Q)
- call pspline_evaluation(AM_V%Qr, AM_V%Qomsb, AM_V%Qomsb2, AM_V%Qn, radius, one_minus_sum_beta(1,1,1,i), AM_V%interval_Q)
- do j = 1,N_SLS
- Qfctmp = AM_V%Qfc(j,:)
- Qfc2tmp = AM_V%Qfc2(j,:)
- call pspline_evaluation(AM_V%Qr, Qfctmp, Qfc2tmp, AM_V%Qn, radius, fctmp, AM_V%interval_Q)
- factor_common(j,1,1,1,i) = fctmp
- enddo
- enddo
- do i = rmax+1,NRAD_ATTENUATION
- scale_factor(1,1,1,i) = scale_factor(1,1,1,rmax)
- one_minus_sum_beta(1,1,1,i) = one_minus_sum_beta(1,1,1,rmax)
- factor_common(1,1,1,1,i) = factor_common(1,1,1,1,rmax)
- factor_common(2,1,1,1,i) = factor_common(2,1,1,1,rmax)
- factor_common(3,1,1,1,i) = factor_common(3,1,1,1,rmax)
- enddo
-
- deallocate(AM_V%Qfc2)
- deallocate(AM_V%Qsf2)
- deallocate(AM_V%Qomsb2)
- deallocate(AM_V%Qfc)
- deallocate(AM_V%Qsf)
- deallocate(AM_V%Qomsb)
- deallocate(AM_V%Qtau_e)
- deallocate(Qfctmp)
- deallocate(Qfc2tmp)
-
-end subroutine get_attenuation_model_1D
-
-subroutine set_attenuation_regions_1D(RICB, RCMB, R670, R220, R80, AM_V)
-
- implicit none
-
- include 'constants.h'
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: interval_Q ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
- double precision RICB, RCMB, R670, R220, R80
- integer i
-
- allocate(AM_V%Qrmin(6))
- allocate(AM_V%Qrmax(6))
- allocate(AM_V%QrDisc(5))
-
- AM_V%QrDisc(1) = RICB
- AM_V%QrDisc(2) = RCMB
- AM_V%QrDisc(3) = R670
- AM_V%QrDisc(4) = R220
- AM_V%QrDisc(5) = R80
-
- ! INNER CORE
- AM_V%Qrmin(IREGION_ATTENUATION_INNER_CORE) = 1 ! Center of the Earth
- i = nint(RICB / 100.d0) ! === BOUNDARY === INNER CORE / OUTER CORE
- AM_V%Qrmax(IREGION_ATTENUATION_INNER_CORE) = i - 1 ! Inner Core Boundary (Inner)
-
- ! OUTER_CORE
- AM_V%Qrmin(6) = i ! Inner Core Boundary (Outer)
- i = nint(RCMB / 100.d0) ! === BOUNDARY === INNER CORE / OUTER CORE
- AM_V%Qrmax(6) = i - 1
-
- ! LOWER MANTLE
- AM_V%Qrmin(IREGION_ATTENUATION_CMB_670) = i
- i = nint(R670 / 100.d0) ! === BOUNDARY === 670 km
- AM_V%Qrmax(IREGION_ATTENUATION_CMB_670) = i - 1
-
- ! UPPER MANTLE
- AM_V%Qrmin(IREGION_ATTENUATION_670_220) = i
- i = nint(R220 / 100.d0) ! === BOUNDARY === 220 km
- AM_V%Qrmax(IREGION_ATTENUATION_670_220) = i - 1
-
- ! MANTLE ISH LITHOSPHERE
- AM_V%Qrmin(IREGION_ATTENUATION_220_80) = i
- i = nint(R80 / 100.d0) ! === BOUNDARY === 80 km
- AM_V%Qrmax(IREGION_ATTENUATION_220_80) = i - 1
-
- ! CRUST ISH LITHOSPHERE
- AM_V%Qrmin(IREGION_ATTENUATION_80_SURFACE) = i
- AM_V%Qrmax(IREGION_ATTENUATION_80_SURFACE) = NRAD_ATTENUATION
-
-end subroutine set_attenuation_regions_1D
-
-subroutine get_attenuation_index(iflag, radius, index, inner_core, AM_V)
-
- implicit none
-
- include 'constants.h'
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: interval_Q ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
- integer iflag, iregion, index
- double precision radius
-
- ! Inner Core or not
- logical inner_core
-
- index = nint(radius * TABLE_ATTENUATION)
-
-!! DK DK this seems incorrect and is difficult to read anyway
-!! DK DK therefore let me rewrite it better
-! if(inner_core) then
-! if(iflag >= IFLAG_INNER_CORE_NORMAL) then
-! iregion = IREGION_ATTENUATION_INNER_CORE
-! else if(iflag >= IFLAG_OUTER_CORE_NORMAL) then
-! iregion = 6
-! endif
-! else
-! if(iflag >= IFLAG_MANTLE_NORMAL) then
-! iregion = IREGION_ATTENUATION_CMB_670
-! else if(iflag == IFLAG_670_220) then
-! iregion = IREGION_ATTENUATION_670_220
-! else if(iflag <= IFLAG_220_80) then
-! iregion = IREGION_ATTENUATION_220_80
-! else
-! iregion = IREGION_ATTENUATION_80_SURFACE
-! endif
-! endif
- if(inner_core) then
-
- if(iflag == IFLAG_INNER_CORE_NORMAL .or. iflag == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- iflag == IFLAG_BOTTOM_CENTRAL_CUBE .or. iflag == IFLAG_TOP_CENTRAL_CUBE .or. &
- iflag == IFLAG_IN_FICTITIOUS_CUBE) then
- iregion = IREGION_ATTENUATION_INNER_CORE
- else
-! this is fictitious for the outer core, which has no Qmu attenuation since it is fluid
-! iregion = IREGION_ATTENUATION_80_SURFACE + 1
- iregion = IREGION_ATTENUATION_UNDEFINED
- endif
-
- else
-
- if(iflag == IFLAG_MANTLE_NORMAL) then
- iregion = IREGION_ATTENUATION_CMB_670
- else if(iflag == IFLAG_670_220) then
- iregion = IREGION_ATTENUATION_670_220
- else if(iflag == IFLAG_220_80) then
- iregion = IREGION_ATTENUATION_220_80
- else if(iflag == IFLAG_CRUST .or. iflag == IFLAG_80_MOHO) then
- iregion = IREGION_ATTENUATION_80_SURFACE
- else
-! this is fictitious for the outer core, which has no Qmu attenuation since it is fluid
-! iregion = IREGION_ATTENUATION_80_SURFACE + 1
- iregion = IREGION_ATTENUATION_UNDEFINED
- endif
-
- endif
-
-! Clamp regions
- if(index < AM_V%Qrmin(iregion)) index = AM_V%Qrmin(iregion)
- if(index > AM_V%Qrmax(iregion)) index = AM_V%Qrmax(iregion)
-
-end subroutine get_attenuation_index
-
-subroutine get_attenuation_model_3D(myrank, one_minus_sum_beta, factor_common, scale_factor, tau_s, vnspec)
-
- implicit none
-
- include 'constants.h'
-
- integer myrank, vnspec
- double precision, dimension(NGLLX,NGLLY,NGLLZ,vnspec) :: one_minus_sum_beta, scale_factor
- double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,vnspec) :: factor_common
- double precision, dimension(N_SLS) :: tau_s
-
- integer i,j,k,ispec
-
- double precision, dimension(N_SLS) :: tau_e, fc
- double precision omsb, Q_mu, sf, T_c_source, scale_t
-
- ! All of the following reads use the output parameters as their temporary arrays
- ! use the filename to determine the actual contents of the read
-
- print *,'DK DK we should do this in MPI instead of writing to a local file'
-
- open(unit=27, file='OUTPUT_FILES/attenuation3D.bin',status='old',action='read',form='unformatted')
- read(27) tau_s
- read(27) factor_common
- read(27) scale_factor
- read(27) T_c_source
- close(27)
-
- scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
-
- factor_common(:,:,:,:,:) = factor_common(:,:,:,:,:) / scale_t ! This is really tau_e, not factor_common
- tau_s(:) = tau_s(:) / scale_t
- T_c_source = 1000.0d0 / T_c_source
- T_c_source = T_c_source / scale_t
-
- do ispec = 1, vnspec
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- tau_e(:) = factor_common(:,i,j,k,ispec)
- Q_mu = scale_factor(i,j,k,ispec)
-
- ! Determine the factor_common and one_minus_sum_beta from tau_s and tau_e
- call attenuation_property_values(tau_s, tau_e, fc, omsb)
-
- factor_common(:,i,j,k,ispec) = fc(:)
- one_minus_sum_beta(i,j,k,ispec) = omsb
-
- ! Determine the "scale_factor" from tau_s, tau_e, central source frequency, and Q
- call attenuation_scale_factor(myrank, T_c_source, tau_e, tau_s, Q_mu, sf)
- scale_factor(i,j,k,ispec) = sf
- enddo
- enddo
- enddo
- enddo
-end subroutine get_attenuation_model_3D
-
-subroutine attenuation_source_frequency(omega_not, min_period, max_period)
- ! Determine the Source Frequency
-
- implicit none
-
- double precision omega_not
- double precision f1, f2
- double precision min_period, max_period
-
- f1 = 1.0d0 / max_period
- f2 = 1.0d0 / min_period
-
- omega_not = 1.0e+03 * 10.0d0**(0.5 * (log10(f1) + log10(f2)))
-
-end subroutine attenuation_source_frequency
-
-subroutine attenuation_tau_sigma(tau_s, n, min_period, max_period)
- ! Set the Tau_sigma (tau_s) to be equally spaced in log10 frequency
-
- implicit none
-
- integer n
- double precision tau_s(n)
- double precision min_period, max_period
- double precision f1, f2
- double precision exp1, exp2
- double precision dexp
- integer i
- double precision, parameter :: PI = 3.14159265358979d0
-
- f1 = 1.0d0 / max_period
- f2 = 1.0d0 / min_period
-
- exp1 = log10(f1)
- exp2 = log10(f2)
-
- dexp = (exp2-exp1) / ((n*1.0d0) - 1)
- do i = 1,n
- tau_s(i) = 1.0 / (PI * 2.0d0 * 10**(exp1 + (i - 1)* 1.0d0 *dexp))
- enddo
-
-end subroutine attenuation_tau_sigma
-
-subroutine attenuation_invert_by_simplex(t2, t1, n, Q_real, omega_not, tau_s, tau_e, AS_V)
-
- implicit none
-
- include 'mpif.h'
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- double precision Q ! Q = Desired Value of Attenuation or Q
- double precision iQ ! iQ = 1/Q
- double precision, dimension(:), pointer :: f
- ! f = Frequencies at which to evaluate the solution
- double precision, dimension(:), pointer :: tau_s
- ! tau_s = Tau_sigma defined by the frequency range and
- ! number of standard linear solids
- end type attenuation_simplex_variables
-
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
- ! Input / Output
- integer myrank, ier
- double precision t1, t2
- double precision Q_real
- double precision omega_not
- integer n
- double precision, dimension(n) :: tau_s, tau_e
-
- ! Internal
- integer i, iterations, err,prnt
- double precision f1, f2, exp1,exp2,dexp, min_value
- double precision, allocatable, dimension(:) :: f
- double precision, parameter :: PI = 3.14159265358979d0
- integer, parameter :: nf = 100
- double precision, external :: attenuation_eval
-
- ! Values to be passed into the simplex minimization routine
- iterations = -1
- min_value = -1.0e-4
- err = 0
- prnt = 0
-
- allocate(f(nf))
- ! Determine the min and max frequencies
- f1 = 1.0d0 / t1
- f2 = 1.0d0 / t2
-
- ! Determine the exponents of the frequencies
- exp1 = log10(f1)
- exp2 = log10(f2)
-
- if(f2 < f1 .OR. Q_real < 0.0d0 .OR. n < 1) then
- call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
- call exit_MPI(myrank, 'frequencies flipped or Q less than zero or N_SLS < 0')
- endif
-
- ! Determine the Source frequency
- omega_not = 1.0e+03 * 10.0d0**(0.5 * (log10(f1) + log10(f2)))
-
- ! Determine the Frequencies at which to compare solutions
- ! The frequencies should be equally spaced in log10 frequency
- do i = 1,nf
- f(i) = exp1 + ((i-1)*1.0d0 * (exp2-exp1) / ((nf-1)*1.0d0))
- enddo
-
- ! Set the Tau_sigma (tau_s) to be equally spaced in log10 frequency
- dexp = (exp2-exp1) / ((n*1.0d0) - 1)
- do i = 1,n
- tau_s(i) = 1.0 / (PI * 2.0d0 * 10**(exp1 + (i - 1)* 1.0d0 *dexp))
- enddo
-
- ! Shove the paramters into the module
- call attenuation_simplex_setup(nf,n,f,Q_real,tau_s,AS_V)
-
- ! Set the Tau_epsilon (tau_e) to an initial value at omega*tau = 1
- ! tan_delta = 1/Q = (tau_e - tau_s)/(2 * sqrt(tau e*tau_s))
- ! if we assume tau_e =~ tau_s
- ! we get the equation below
- do i = 1,n
- tau_e(i) = tau_s(i) + (tau_s(i) * 2.0d0/Q_real)
- enddo
-
- ! Run a simplex search to determine the optimum values of tau_e
- call fminsearch(attenuation_eval, tau_e, n, iterations, min_value, err,AS_V)
- if(err > 0) then
- write(*,*)'Search did not converge for an attenuation of ', Q_real
- write(*,*)' Iterations: ', iterations
- write(*,*)' Min Value: ', min_value
- write(*,*)' Aborting program'
- call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
- call exit_MPI(myrank,'attenuation_simplex: Search for Strain relaxation times did not converge')
- endif
- deallocate(f)
-
- call attenuation_simplex_finish(AS_V)
-
-end subroutine attenuation_invert_by_simplex
-
-subroutine attenuation_simplex_finish(AS_V)
-
- implicit none
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- double precision Q ! Q = Desired Value of Attenuation or Q
- double precision iQ ! iQ = 1/Q
- double precision, dimension(:), pointer :: f
- ! f = Frequencies at which to evaluate the solution
- double precision, dimension(:), pointer :: tau_s
- ! tau_s = Tau_sigma defined by the frequency range and
- ! number of standard linear solids
- end type attenuation_simplex_variables
-
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
- deallocate(AS_V%f)
- deallocate(AS_V%tau_s)
-
-end subroutine attenuation_simplex_finish
-
-! - Inserts necessary parameters into the module attenuation_simplex_variables
-! - See module for explaination
-subroutine attenuation_simplex_setup(nf_in,nsls_in,f_in,Q_in,tau_s_in,AS_V)
-
- implicit none
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- double precision Q ! Q = Desired Value of Attenuation or Q
- double precision iQ ! iQ = 1/Q
- double precision, dimension(:), pointer :: f
- ! f = Frequencies at which to evaluate the solution
- double precision, dimension(:), pointer :: tau_s
- ! tau_s = Tau_sigma defined by the frequency range and
- ! number of standard linear solids
- end type attenuation_simplex_variables
-
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
- integer nf_in, nsls_in
- double precision Q_in
- double precision, dimension(nf_in) :: f_in
- double precision, dimension(nsls_in) :: tau_s_in
-
- allocate(AS_V%f(nf_in))
- allocate(AS_V%tau_s(nsls_in))
-
- AS_V%nf = nf_in
- AS_V%nsls = nsls_in
- AS_V%f = f_in
- AS_V%Q = Q_in
- AS_V%iQ = 1.0d0/AS_V%Q
- AS_V%tau_s = tau_s_in
-
-end subroutine attenuation_simplex_setup
-
-! - Computes the Moduli (Maxwell Solid) for a series of
-! Standard Linear Solids
-! - Computes M1 and M2 parameters after Dahlen and Tromp pp.203
-! here called B and A after Liu et al. 1976
-! - Another formulation uses Kelvin-Voigt Solids and computes
-! Compliences J1 and J2 after Dahlen and Tromp pp.203
-!
-! Input
-! nf = Number of Frequencies
-! nsls = Number of Standard Linear Solids
-! f = Frequencies (in log10 of frequencies)
-! dimension(nf)
-! tau_s = Tau_sigma Stress relaxation time (see References)
-! dimension(nsls)
-! tau_e = Tau_epislon Strain relaxation time (see References)
-! dimension(nsls)!
-! Output
-! B = Real Moduli ( M2 Dahlen and Tromp pp.203 )
-! dimension(nf)
-! A = Imaginary Moduli ( M1 Dahlen and Tromp pp.203 )
-! dimension(nf)
-!
-! Dahlen and Tromp, 1998
-! Theoretical Global Seismology
-!
-! Liu et al. 1976
-! Velocity dispersion due to anelasticity: implications for seismology and mantle composition
-! Geophys, J. R. asts. Soc, Vol 47, pp. 41-58
-subroutine attenuation_maxwell(nf,nsls,f,tau_s,tau_e,B,A)
-
- implicit none
-
- ! Input
- integer nf, nsls
- double precision, dimension(nf) :: f
- double precision, dimension(nsls) :: tau_s, tau_e
- ! Output
- double precision, dimension(nf) :: A,B
-
- integer i,j
- double precision w, pi, demon
-
- PI = 3.14159265358979d0
-
- A(:) = 1.0d0 - nsls*1.0d0
- B(:) = 0.0d0
- do i = 1,nf
- w = 2.0d0 * PI * 10**f(i)
- do j = 1,nsls
- demon = 1.0d0 + w**2 * tau_s(j)**2
- A(i) = A(i) + ((1.0d0 + (w**2 * tau_e(j) * tau_s(j)))/ demon)
- B(i) = B(i) + ((w * (tau_e(j) - tau_s(j))) / demon)
- enddo
- enddo
-
-end subroutine attenuation_maxwell
-
-! - Computes the misfit from a set of relaxation paramters
-! given a set of frequencies and target attenuation
-! - Evaluates only at the given frequencies
-! - Evaluation is done with an L2 norm
-!
-! Input
-! Xin = Tau_epsilon, Strain Relaxation Time
-! Note: Tau_sigma the Stress Relaxation Time is loaded
-! with attenuation_simplex_setup and stored in
-! attenuation_simplex_variables
-!
-! Xi = Sum_i^N sqrt [ (1/Qc_i - 1/Qt_i)^2 / 1/Qt_i^2 ]
-!
-! where Qc_i is the computed attenuation at a specific frequency
-! Qt_i is the desired attenuaiton at that frequency
-!
-! Uses attenuation_simplex_variables to store constant values
-!
-! See atteunation_simplex_setup
-!
-double precision function attenuation_eval(Xin,AS_V)
-
- implicit none
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- double precision Q ! Q = Desired Value of Attenuation or Q
- double precision iQ ! iQ = 1/Q
- double precision, dimension(:), pointer :: f
- ! f = Frequencies at which to evaluate the solution
- double precision, dimension(:), pointer :: tau_s
- ! tau_s = Tau_sigma defined by the frequency range and
- ! number of standard linear solids
- end type attenuation_simplex_variables
-
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
- ! Input
- double precision, dimension(AS_V%nsls) :: Xin
- double precision, dimension(AS_V%nsls) :: tau_e
-
- double precision, dimension(AS_V%nf) :: A, B, tan_delta
-
- integer i
- double precision xi, iQ2
-
- tau_e = Xin
-
- call attenuation_maxwell(AS_V%nf,AS_V%nsls,AS_V%f,AS_V%tau_s,tau_e,B,A)
-
- tan_delta = B / A
-
- attenuation_eval = 0.0d0
- iQ2 = AS_V%iQ**2
- do i = 1,AS_V%nf
- xi = sqrt(( ( (tan_delta(i) - AS_V%iQ) ** 2 ) / iQ2 ))
- attenuation_eval = attenuation_eval + xi
- enddo
-
-end function attenuation_eval
-
-! subroutine fminsearch
-! - Computes the minimization of funk(x(n)) using the simplex method
-! - This subroutine is similar to Matlab's fminsearch.m
-! and modified to suit our needs
-! Input
-! funk = double precision function with one input parameter
-! double precision function the_funk(x)
-! x = Input/Output
-! variables to be minimized
-! dimension(n)
-! Input: Initial Value
-! Output: Mimimized Value
-! n = number of variables
-! itercount = Input/Output
-! Input: maximum number of iterations
-! if < 0 default is used (200 * n)
-! Output: total number of iterations on output
-! tolf = Input/Output
-! Input: minimium tolerance of the function funk(x)
-! Output: minimium value of funk(x)(i.e. "a" solution)
-! err = Output
-! 0 => Normal exeecution, converged within desired range
-! 1 => Function Evaluation exceeded limit
-! 2 => Iterations exceeded limit
-!
-subroutine fminsearch(funk, x, n, itercount, tolf, err, AS_V)
-
- implicit none
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- double precision Q ! Q = Desired Value of Attenuation or Q
- double precision iQ ! iQ = 1/Q
- double precision, dimension(:), pointer :: f
- ! f = Frequencies at which to evaluate the solution
- double precision, dimension(:), pointer :: tau_s
- ! tau_s = Tau_sigma defined by the frequency range and
- ! number of standard linear solids
- end type attenuation_simplex_variables
-
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
- ! Input
- double precision, external :: funk
-
- integer n
- double precision x(n) ! Also Output
- integer itercount, err
- double precision tolf
-
- !Internal
- integer i,j, how
- integer, parameter :: none = 0
- integer, parameter :: initial = 1
- integer, parameter :: expand = 2
- integer, parameter :: reflect = 3
- integer, parameter :: contract_outside = 4
- integer, parameter :: contract_inside = 5
- integer, parameter :: shrink = 6
-
- integer maxiter, maxfun
- integer func_evals
- double precision tolx
-
- double precision rho, chi, psi, sigma
- double precision xin(n), y(n), v(n,n+1), fv(n+1)
- double precision vtmp(n,n+1)
- double precision usual_delta, zero_term_delta
- double precision xbar(n), xr(n), fxr, xe(n), fxe, xc(n), fxc, fxcc, xcc(n)
- integer place(n+1)
-
- double precision max_size_simplex, max_value
-
- rho = 1.0d0
- chi = 2.0d0
- psi = 0.5d0
- sigma = 0.5d0
-
-
- if(itercount > 0) then
- maxiter = itercount
- else
- maxiter = 200 * n
- endif
- itercount = 0
- maxfun = 200 * n
-
- if(tolf > 0.0d0) then
- tolx = 1.0e-4
- else
- tolx = 1.0e-4
- tolf = 1.0e-4
- endif
-
- err = 0
-
- xin = x
- v(:,:) = 0.0d0
- fv(:) = 0.0d0
-
- v(:,1) = xin
- x = xin
-
- fv(1) = funk(xin,AS_V)
-
- usual_delta = 0.05
- zero_term_delta = 0.00025
-
- do j = 1,n
- y = xin
- if(y(j) /= 0.0d0) then
- y(j) = (1.0d0 + usual_delta) * y(j)
- else
- y(j) = zero_term_delta
- endif
- v(:,j+1) = y
- x(:) = y
- fv(j+1) = funk(x,AS_V)
- enddo
-
- call qsort(fv,n+1,place)
-
- do i = 1,n+1
- vtmp(:,i) = v(:,place(i))
- enddo
- v = vtmp
-
- how = initial
- itercount = 1
- func_evals = n+1
-
- do while (func_evals < maxfun .AND. itercount < maxiter)
-
- if(max_size_simplex(v,n) <= tolx .AND. &
- max_value(fv,n+1) <= tolf) then
- goto 888
- endif
- how = none
-
- ! xbar = average of the n (NOT n+1) best points
- ! xbar = sum(v(:,1:n), 2)/n
- xbar(:) = 0.0d0
- do i = 1,n
- do j = 1,n
- xbar(i) = xbar(i) + v(i,j)
- enddo
- xbar(i) = xbar(i) / (n*1.0d0)
- enddo
- xr = (1 + rho)*xbar - rho*v(:,n+1)
- x(:) = xr
- fxr = funk(x,AS_V)
- func_evals = func_evals + 1
- if (fxr < fv(1)) then
- ! Calculate the expansion point
- xe = (1 + rho*chi)*xbar - rho*chi*v(:,n+1)
- x = xe
- fxe = funk(x,AS_V)
- func_evals = func_evals+1
- if (fxe < fxr) then
- v(:,n+1) = xe
- fv(n+1) = fxe
- how = expand
- else
- v(:,n+1) = xr
- fv(n+1) = fxr
- how = reflect
- endif
- else ! fv(:,1) <= fxr
- if (fxr < fv(n)) then
- v(:,n+1) = xr
- fv(n+1) = fxr
- how = reflect
- else ! fxr >= fv(:,n)
- ! Perform contraction
- if (fxr < fv(n+1)) then
- ! Perform an outside contraction
- xc = (1 + psi*rho)*xbar - psi*rho*v(:,n+1)
- x(:) = xc
- fxc = funk(x,AS_V)
- func_evals = func_evals+1
-
- if (fxc <= fxr) then
- v(:,n+1) = xc
- fv(n+1) = fxc
- how = contract_outside
- else
- ! perform a shrink
- how = shrink
- endif
- else
- ! Perform an inside contraction
- xcc = (1-psi)*xbar + psi*v(:,n+1)
- x(:) = xcc
- fxcc = funk(x,AS_V)
- func_evals = func_evals+1
-
- if (fxcc < fv(n+1)) then
- v(:,n+1) = xcc
- fv(n+1) = fxcc
- how = contract_inside
- else
- ! perform a shrink
- how = shrink
- endif
- endif
- if (how == shrink) then
- do j=2,n+1
- v(:,j)=v(:,1)+sigma*(v(:,j) - v(:,1))
- x(:) = v(:,j)
- fv(j) = funk(x,AS_V)
- enddo
- func_evals = func_evals + n
- endif
- endif
- endif
-
- call qsort(fv,n+1,place)
- do i = 1,n+1
- vtmp(:,i) = v(:,place(i))
- enddo
- v = vtmp
-
- itercount = itercount + 1
- enddo
-
- if(func_evals > maxfun) then
- write(*,*)'function evaluations exceeded prescribed limit', maxfun
- stop 'err = 1'
- endif
- if(itercount > maxiter) then
- write(*,*)'iterations exceeded prescribed limit', maxiter
- stop 'err = 2'
- endif
-
-888 continue
- x = v(:,1)
- tolf = fv(1)
-
-end subroutine fminsearch
-
-! - Finds the maximim value of the difference of between the first
-! value and the remaining values of a vector
-! Input
-! fv = Input
-! Vector
-! dimension(n)
-! n = Input
-! Length of fv
-!
-! Returns:
-! Xi = max( || fv(1)- fv(i) || ) for i=2:n
-!
-double precision function max_value(fv,n)
- implicit none
- integer n
- double precision fv(n)
-
- integer i
- double precision m, z
-
- m = 0.0d0
- do i = 2,n
- z = abs(fv(1) - fv(i))
- if(z > m) then
- m = z
- endif
- enddo
-
- max_value = m
-
-end function max_value
-
-! - Determines the maximum distance between two point in a simplex
-! Input
-! v = Input
-! Simplex Verticies
-! dimension(n, n+1)
-! n = Pseudo Length of n
-!
-! Returns:
-! Xi = max( max( || v(:,1) - v(:,i) || ) ) for i=2:n+1
-!
-double precision function max_size_simplex(v,n)
- implicit none
- integer n
- double precision v(n,n+1)
-
- integer i,j
- double precision m, z
-
- m = 0.0d0
- do i = 1,n
- do j = 2,n+1
- z = abs(v(i,j) - v(i,1))
- if(z > m) then
- m = z
- endif
- enddo
- enddo
-
- max_size_simplex = m
-
-end function max_size_simplex
-
-! - Implementation of a Bubble Sort Routine
-! Input
-! X = Input/Output
-! Vector to be sorted
-! dimension(n)
-! n = Input
-! Length of X
-! I = Output
-! Sorted Indicies of vecotr X
-!
-! Example:
-! X = [ 4 3 1 2 ] on Input
-! I = [ 1 2 3 4 ] Computed Internally (in order)
-!
-! X = [ 1 2 3 4 ] on Output
-! I = [ 3 4 2 1 ] on Output
-!
-subroutine qsort(X,n,I)
-
- implicit none
-
- integer n
- double precision X(n)
- integer I(n)
-
- integer j,k
- double precision rtmp
- integer itmp
-
- do j = 1,n
- I(j) = j
- enddo
-
- do j = 1,n
- do k = 1,n-j
- if(X(k+1) < X(k)) then
- rtmp = X(k)
- X(k) = X(k+1)
- X(k+1) = rtmp
-
- itmp = I(k)
- I(k) = I(k+1)
- I(k+1) = itmp
- endif
- enddo
- enddo
-
-end subroutine qsort
-
-! Piecewise Continuous Splines
-! - Added Steps which describes the discontinuities
-! - Steps must be repeats in the dependent variable, X
-! - Derivates at the steps are computed using the point
-! at the derivate and the closest point within that piece
-! - A point lying directly on the discontinuity will recieve the
-! value of the first or smallest piece in terms of X
-! - Beginning and Ending points of the Function become beginning
-! and ending points of the first and last splines
-! - A Step with a value of zero is undefined
-! - Works with functions with steps or no steps
-! See the comment below about the ScS bug
-subroutine pspline_evaluation(xa, ya, y2a, n, x, y, steps)
-
- implicit none
-
- integer n
- double precision xa(n),ya(n),y2a(n)
- integer steps(n)
- double precision x, y
-
- integer i, l, n1, n2
-
- do i = 1,n-1,1
- if(steps(i+1) == 0) return
- if(x >= xa(steps(i)) .and. x <= xa(steps(i+1))) then
- call pspline_piece(i,n1,n2,l,n,steps)
- call spline_evaluation(xa(n1), ya(n1), y2a(n1), l, x, y)
-! return <-- Commented out to fix ScS bug
- endif
- enddo
-
-end subroutine pspline_evaluation
-
-subroutine pspline_piece(i,n1,n2,l,n,s)
-
- implicit none
-
- integer i, n1, n2, l, n, s(n)
- n1 = s(i)+1
- if(i == 1) n1 = s(i)
- n2 = s(i+1)
- l = n2 - n1 + 1
-
-end subroutine pspline_piece
-
-subroutine pspline_construction(x, y, n, yp1, ypn, y2, steps)
-
- implicit none
-
- integer n
- double precision x(n),y(n),y2(n)
- double precision yp1, ypn
- integer steps(n)
-
- integer i,r, l, n1,n2
-
- steps(:) = 0
-
- ! Find steps in x, defining pieces
- steps(1) = 1
- r = 2
- do i = 2,n
- if(x(i) == x(i-1)) then
- steps(r) = i-1
- r = r + 1
- endif
- enddo
- steps(r) = n
-
- ! Run spline for each piece
- do i = 1,r-1
- call pspline_piece(i,n1,n2,l,n,steps)
- ! Determine the First Derivates at Begin/End Points
- yp1 = ( y(n1+1) - y(n1) ) / ( x(n1+1) - x(n1))
- ypn = ( y(n2) - y(n2-1) ) / ( x(n2) - x(n2-1))
- call spline_construction(x(n1),y(n1),l,yp1,ypn,y2(n1))
- enddo
-
-end subroutine pspline_construction
-
-subroutine attenuation_model_1D_PREM(x, Qmu, iflag)
-
-! x in the radius from 0 to 1 where 0 is the center and 1 is the surface
-! This version is for 1D PREM.
-
- implicit none
-
- include 'constants.h'
-
- integer iflag
- double precision r, x, Qmu,RICB,RCMB, &
- RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R80, ROCEAN, RMOHO, RMIDDLE_CRUST
- double precision Qkappa
-
- r = x * R_EARTH
-
- ROCEAN = 6368000.d0
- RMIDDLE_CRUST = 6356000.d0
- RMOHO = 6346600.d0
- R80 = 6291000.d0
- R220 = 6151000.d0
- R400 = 5971000.d0
- R600 = 5771000.d0
- R670 = 5701000.d0
- R771 = 5600000.d0
- RTOPDDOUBLEPRIME = 3630000.d0
- RCMB = 3480000.d0
- RICB = 1221000.d0
-
-! PREM
-!
-!--- inner core
-!
- if(r >= 0.d0 .and. r <= RICB) then
- Qmu=84.6d0
- Qkappa=1327.7d0
-!
-!--- outer core
-!
- else if(r > RICB .and. r <= RCMB) then
- Qmu=0.0d0
- Qkappa=57827.0d0
- if(RCMB - r < r - RICB) then
- Qmu = 312.0d0 ! CMB
- else
- Qmu = 84.6d0 ! ICB
- endif
-!
-!--- D" at the base of the mantle
-!
- else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
- Qmu=312.0d0
- Qkappa=57827.0d0
-!
-!--- mantle: from top of D" to d670
-!
- else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
- Qmu=312.0d0
- Qkappa=57827.0d0
- else if(r > R771 .and. r <= R670) then
- Qmu=312.0d0
- Qkappa=57827.0d0
-!
-!--- mantle: above d670
-!
- else if(r > R670 .and. r <= R600) then
- Qmu=143.0d0
- Qkappa=57827.0d0
- else if(r > R600 .and. r <= R400) then
- Qmu=143.0d0
- Qkappa=57827.0d0
- else if(r > R400 .and. r <= R220) then
- Qmu=143.0d0
- Qkappa=57827.0d0
- else if(r > R220 .and. r <= R80) then
- Qmu=80.0d0
- Qkappa=57827.0d0
- else if(r > R80) then
- Qmu=600.0d0
- Qkappa=57827.0d0
- endif
-
- ! We determine the attenuation value here dependent on the doubling flag and
- ! which region we are sitting in. The radius reported is not accurate for
- ! determination of which region we are actually in, whereas the idoubling flag is
- if(iflag == IFLAG_INNER_CORE_NORMAL .or. iflag == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- iflag == IFLAG_BOTTOM_CENTRAL_CUBE .or. iflag == IFLAG_TOP_CENTRAL_CUBE .or. &
- iflag == IFLAG_IN_FICTITIOUS_CUBE) then
- Qmu = 84.6d0
- Qkappa = 1327.7d0
- else if(iflag == IFLAG_OUTER_CORE_NORMAL) then
- Qmu = 0.0d0
- Qkappa = 57827.0d0
- else if(iflag == IFLAG_MANTLE_NORMAL) then ! D'' to 670 km
- Qmu = 312.0d0
- Qkappa = 57827.0d0
- else if(iflag == IFLAG_670_220) then
- Qmu=143.0d0
- Qkappa = 57827.0d0
- else if(iflag == IFLAG_220_80) then
- Qmu=80.0d0
- Qkappa = 57827.0d0
- else if(iflag == IFLAG_80_MOHO) then
- Qmu=600.0d0
- Qkappa = 57827.0d0
- else if(iflag == IFLAG_CRUST) then
- Qmu=600.0d0
- Qkappa = 57827.0d0
- else
- call exit_MPI_without_rank('Invalid idoubling flag in attenuation_model_1D_prem from get_model()')
- endif
-
-end subroutine attenuation_model_1D_PREM
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/auto_ner.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/auto_ner.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/auto_ner.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -112,7 +112,7 @@
MIN_ATTENUATION_PERIOD = TMP
if(N_SLS < 2 .OR. N_SLS > 5) then
- call exit_MPI_without_rank('N_SLS must be greater than 1 or less than 6')
+ call exit_mpi_without_rank('N_SLS must be greater than 1 or less than 6')
endif
! Compute Max Attenuation Period
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_meshfem1.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_meshfem1.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_meshfem1.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,24 +0,0 @@
-
-!! DK DK created this for merged version
-
- call meshfem3D( &
- myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo,NSOURCES, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,ibool_crust_mantle,ibool_outer_core,ibool_inner_core, &
- idoubling_crust_mantle,idoubling_inner_core,ibelm_bottom_crust_mantle, ibelm_bottom_outer_core, ibelm_top_outer_core, &
-ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
-ibelm_top_inner_core,iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, iboolleft_eta_crust_mantle, &
-iboolright_eta_crust_mantle,iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core, iboolleft_eta_inner_core,iboolright_eta_inner_core,&
- jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
- normal_bottom_outer_core, normal_top_outer_core,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle,kappavstore_inner_core,muvstore_inner_core, &
- rmass_crust_mantle, rmass_outer_core, rmass_inner_core, &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
-iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core, &
- iboolcorner_crust_mantle,iboolcorner_outer_core,iboolcorner_inner_core, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core,rmass_ocean_load, &
- normal_top_crust_mantle,ibelm_top_crust_mantle,AM_V)
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_meshfem2.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_meshfem2.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_meshfem2.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,24 +0,0 @@
-
-!! DK DK created this for merged version
-
- subroutine meshfem3D( &
- myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo,NSOURCES, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,ibool_crust_mantle,ibool_outer_core,ibool_inner_core, &
- idoubling_crust_mantle,idoubling_inner_core,ibelm_bottom_crust_mantle, ibelm_bottom_outer_core, ibelm_top_outer_core, &
-ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
-ibelm_top_inner_core,iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, iboolleft_eta_crust_mantle, &
-iboolright_eta_crust_mantle,iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core, iboolleft_eta_inner_core,iboolright_eta_inner_core,&
- jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
- normal_bottom_outer_core, normal_top_outer_core,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle,kappavstore_inner_core,muvstore_inner_core, &
- rmass_crust_mantle, rmass_outer_core, rmass_inner_core, &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
-iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core, &
- iboolcorner_crust_mantle,iboolcorner_outer_core,iboolcorner_inner_core, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core,rmass_ocean_load, &
- normal_top_crust_mantle,ibelm_top_crust_mantle,AM_V)
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_specfem1.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_specfem1.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_specfem1.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,24 +0,0 @@
-
-!! DK DK created this for merged version
-
- call specfem3D( &
- myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo,NSOURCES,npoin2D_max_all, &
- NDIM_smaller_buffers,nrec,NTSTEP_BETWEEN_OUTPUT_SEISMOS,ibool_crust_mantle,ibool_outer_core,ibool_inner_core, &
- idoubling_crust_mantle,idoubling_inner_core,ibelm_bottom_crust_mantle, ibelm_bottom_outer_core, ibelm_top_outer_core, &
-ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
-ibelm_top_inner_core,iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, iboolleft_eta_crust_mantle, &
-iboolright_eta_crust_mantle,iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core, iboolleft_eta_inner_core,iboolright_eta_inner_core,&
- jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
- normal_bottom_outer_core, normal_top_outer_core,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle,kappavstore_inner_core,muvstore_inner_core, &
- rmass_crust_mantle, rmass_outer_core, rmass_inner_core, &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
-iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core, &
- iboolcorner_crust_mantle,iboolcorner_outer_core,iboolcorner_inner_core, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core,rmass_ocean_load, &
- normal_top_crust_mantle,ibelm_top_crust_mantle,AM_V)
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_specfem2.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_specfem2.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/call_specfem2.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,24 +0,0 @@
-
-!! DK DK created this for merged version
-
- subroutine specfem3D( &
- myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo,NSOURCES,npoin2D_max_all, &
- NDIM_smaller_buffers,nrec,NTSTEP_BETWEEN_OUTPUT_SEISMOS,ibool_crust_mantle,ibool_outer_core,ibool_inner_core, &
- idoubling_crust_mantle,idoubling_inner_core,ibelm_bottom_crust_mantle, ibelm_bottom_outer_core, ibelm_top_outer_core, &
-ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
-ibelm_top_inner_core,iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, iboolleft_eta_crust_mantle, &
-iboolright_eta_crust_mantle,iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core, iboolleft_eta_inner_core,iboolright_eta_inner_core,&
- jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
- normal_bottom_outer_core, normal_top_outer_core,kappavstore_crust_mantle,muvstore_crust_mantle, &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle,kappavstore_inner_core,muvstore_inner_core, &
- rmass_crust_mantle, rmass_outer_core, rmass_inner_core, &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
-iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core, &
- iboolcorner_crust_mantle,iboolcorner_outer_core,iboolcorner_inner_core, &
- npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core,rmass_ocean_load, &
- normal_top_crust_mantle,ibelm_top_crust_mantle,AM_V)
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_element_properties.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_element_properties.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/compute_element_properties.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -229,9 +229,6 @@
! sea99_s_model_variables
type sea99_s_model_variables
sequence
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
double precision :: sea99_ddeg
double precision :: alatmin
double precision :: alatmax
@@ -239,6 +236,9 @@
double precision :: alonmax
double precision :: sea99_vs(100,100,100)
double precision :: sea99_depth(100)
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
end type sea99_s_model_variables
type (sea99_s_model_variables) SEA99M_V
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_central_cube_buffers.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_central_cube_buffers.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_central_cube_buffers.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_central_cube_buffers.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,557 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!
+!--- create buffers to assemble with central cube
+!
+
+ subroutine create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
+ NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
+ NSPEC2DMAX_XMIN_XMAX_INNER_CORE,NSPEC2DMAX_YMIN_YMAX_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE, &
+ addressing,ibool_inner_core,idoubling_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
+ nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices, &
+ receiver_cube_from_slices,sender_from_slices_to_cube,ibool_central_cube, &
+ buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+
+ integer, intent(in) :: myrank,iproc_xi,iproc_eta,ichunk, &
+ NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
+ NSPEC2DMAX_XMIN_XMAX_INNER_CORE,NSPEC2DMAX_YMIN_YMAX_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE
+
+! for addressing of the slices
+ integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1), intent(in) :: addressing
+
+! mesh parameters
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE), intent(in) :: ibool_inner_core
+
+! local to global mapping
+ integer, dimension(NSPEC_INNER_CORE), intent(in) :: idoubling_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE), intent(in) :: xstore_inner_core,ystore_inner_core,zstore_inner_core
+
+! boundary parameters locator
+ integer, intent(in) :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_INNER_CORE), intent(in) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_INNER_CORE), intent(in) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_INNER_CORE), intent(in) :: ibelm_bottom_inner_core
+
+ integer, intent(in) :: nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices
+
+! for matching with central cube in inner core
+ integer, intent(out) :: receiver_cube_from_slices
+
+ integer, dimension(non_zero_nb_msgs_theor_in_cube), intent(out) :: sender_from_slices_to_cube
+ integer, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices), intent(out) :: ibool_central_cube
+ double precision, dimension(npoin2D_cube_from_slices,NDIM), intent(out) :: buffer_slices,buffer_slices2
+ double precision, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM), intent(out) :: &
+ buffer_all_cube_from_slices
+
+! local variables below
+ integer i,j,k,ispec,ispec2D,iglob
+#ifdef USE_MPI
+ integer :: ier
+#endif
+ integer sender,receiver,imsg,ipoin,iproc_xi_loop
+
+ double precision x_target,y_target,z_target
+ double precision x_current,y_current,z_current
+
+! MPI status of messages to be received
+#ifdef USE_MPI
+ integer, dimension(MPI_STATUS_SIZE) :: msg_status
+#endif
+
+!--- processor to send information to in cube from slices
+
+! four vertical sides first
+ if(ichunk == CHUNK_AC) then
+ if (iproc_xi < floor(NPROC_XI/2.d0)) then
+ receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1,iproc_eta)
+ else
+ receiver_cube_from_slices = addressing(CHUNK_AB,0,iproc_eta)
+ endif
+ else if(ichunk == CHUNK_BC) then
+ if (iproc_xi < floor(NPROC_XI/2.d0)) then
+ receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_eta,NPROC_ETA-1)
+ else
+ receiver_cube_from_slices = addressing(CHUNK_AB,iproc_eta,NPROC_ETA-1)
+ endif
+ else if(ichunk == CHUNK_AC_ANTIPODE) then
+ if (iproc_xi <= ceiling((NPROC_XI/2.d0)-1)) then
+ receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1,iproc_eta)
+ else
+ receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,0,iproc_eta)
+ endif
+ else if(ichunk == CHUNK_BC_ANTIPODE) then
+ if (iproc_xi < floor(NPROC_XI/2.d0)) then
+ receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,iproc_eta,0)
+ else
+ receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1-iproc_eta,0)
+ endif
+! bottom of cube, direct correspondance but with inverted xi axis
+ else if(ichunk == CHUNK_AB_ANTIPODE) then
+ receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1-iproc_xi,iproc_eta)
+ else if(ichunk == CHUNK_AB) then
+ receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_xi,iproc_eta)
+ endif
+
+
+!--- list of processors to receive information from in cube
+
+! only for slices in central cube
+ if(ichunk == CHUNK_AB) then
+
+! initialize index of sender
+ imsg = 0
+
+! define sender for xi = xi_min edge
+ if(iproc_xi == 0) then
+ do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,iproc_xi_loop,iproc_eta)
+ enddo
+ endif
+
+! define sender for xi = xi_max edge
+ if(iproc_xi == NPROC_XI-1) then
+ do iproc_xi_loop = 0, floor((NPROC_XI-1)/2.d0)
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,iproc_xi_loop,iproc_eta)
+ enddo
+ endif
+
+! define sender for eta = eta_min edge
+ if(iproc_eta == 0) then
+ do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,iproc_xi_loop,NPROC_ETA-1-iproc_xi)
+ enddo
+ endif
+
+! define sender for eta = eta_max edge
+ if(iproc_eta == NPROC_ETA-1) then
+ do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,iproc_xi_loop,iproc_xi)
+ enddo
+ endif
+
+! define sender for bottom edge
+! bottom of cube, direct correspondence but with inverted xi axis
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_xi,iproc_eta)
+
+! check that total number of faces found is correct
+ if(imsg /= nb_msgs_theor_in_cube) call exit_MPI(myrank,'wrong number of faces found for central cube')
+
+ else if(ichunk == CHUNK_AB_ANTIPODE) then
+
+! initialize index of sender
+ imsg = 0
+
+! define sender for xi = xi_min edge
+ if(iproc_xi == 0) then
+ do iproc_xi_loop = ceiling(NPROC_XI/2.d0),NPROC_XI-1
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,iproc_xi_loop,iproc_eta)
+ enddo
+ endif
+
+! define sender for xi = xi_max edge
+ if(iproc_xi == NPROC_XI-1) then
+ do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,iproc_xi_loop,iproc_eta)
+ enddo
+ endif
+
+! define sender for eta = eta_min edge
+ if(iproc_eta == 0) then
+ do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,iproc_xi_loop,iproc_xi)
+ enddo
+ endif
+
+! define sender for eta = eta_max edge
+ if(iproc_eta == NPROC_ETA-1) then
+ do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,iproc_xi_loop,NPROC_ETA-1-iproc_xi)
+ enddo
+ endif
+
+! define sender for bottom edge
+! bottom of cube, direct correspondence but with inverted xi axis
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AB,NPROC_XI-1-iproc_xi,iproc_eta)
+
+! check that total number of faces found is correct
+ if(imsg /= nb_msgs_theor_in_cube) call exit_MPI(myrank,'wrong number of faces found for central cube')
+
+ else
+
+! dummy value in slices
+ sender_from_slices_to_cube(1) = -1
+
+ endif
+
+
+! on chunk AB & AB ANTIPODE, receive all (except bottom) the messages from slices
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ do imsg = 1,nb_msgs_theor_in_cube-1
+
+! receive buffers from slices
+ sender = sender_from_slices_to_cube(imsg)
+#ifdef USE_MPI
+ call MPI_RECV(buffer_slices, &
+ NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+
+! copy buffer in 2D array for each slice
+ buffer_all_cube_from_slices(imsg,:,:) = buffer_slices(:,:)
+
+ enddo
+ endif
+
+! send info to central cube from all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
+ if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE ) then
+
+! for bottom elements in contact with central cube from the slices side
+ ipoin = 0
+ do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
+
+ ispec = ibelm_bottom_inner_core(ispec2D)
+
+! only for DOFs exactly on surface of central cube (bottom of these elements)
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ iglob = ibool_inner_core(i,j,k,ispec)
+ buffer_slices(ipoin,1) = dble(xstore_inner_core(iglob))
+ buffer_slices(ipoin,2) = dble(ystore_inner_core(iglob))
+ buffer_slices(ipoin,3) = dble(zstore_inner_core(iglob))
+ enddo
+ enddo
+ enddo
+
+! send buffer to central cube
+ receiver = receiver_cube_from_slices
+#ifdef USE_MPI
+ call MPI_SEND(buffer_slices,NDIM*npoin2D_cube_from_slices, &
+ MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+
+ endif ! end sending info to central cube
+
+
+! exchange of their bottom faces between chunks AB and AB_ANTIPODE
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+ ipoin = 0
+ do ispec = NSPEC_INNER_CORE, 1, -1
+ if (idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE) then
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ iglob = ibool_inner_core(i,j,k,ispec)
+ buffer_slices(ipoin,1) = dble(xstore_inner_core(iglob))
+ buffer_slices(ipoin,2) = dble(ystore_inner_core(iglob))
+ buffer_slices(ipoin,3) = dble(zstore_inner_core(iglob))
+ enddo
+ enddo
+ endif
+ enddo
+ if (ipoin /= npoin2D_cube_from_slices) call exit_MPI(myrank,'wrong number of points found for bottom CC AB or !AB')
+
+ sender = sender_from_slices_to_cube(nb_msgs_theor_in_cube)
+
+#ifdef USE_MPI
+ call MPI_SENDRECV(buffer_slices,NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,receiver_cube_from_slices, &
+ itag,buffer_slices2,NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+#else
+!! DK DK dummy statement to avoid a warning in the serial case
+ buffer_slices2 = 0
+#endif
+
+ buffer_all_cube_from_slices(nb_msgs_theor_in_cube,:,:) = buffer_slices2(:,:)
+
+ endif
+
+!--- now we need to find the points received and create indirect addressing
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ do imsg = 1,nb_msgs_theor_in_cube
+
+ do ipoin = 1,npoin2D_cube_from_slices
+
+ x_target = buffer_all_cube_from_slices(imsg,ipoin,1)
+ y_target = buffer_all_cube_from_slices(imsg,ipoin,2)
+ z_target = buffer_all_cube_from_slices(imsg,ipoin,3)
+
+! x = x_min
+ do ispec2D = 1,nspec2D_xmin_inner_core
+
+ ispec = ibelm_xmin_inner_core(ispec2D)
+
+! do not loop on elements outside of the central cube
+ if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
+
+ i = 1
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+
+ iglob = ibool_inner_core(i,j,k,ispec)
+ x_current = dble(xstore_inner_core(iglob))
+ y_current = dble(ystore_inner_core(iglob))
+ z_current = dble(zstore_inner_core(iglob))
+
+! look for matching point
+ if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
+ ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
+ goto 100
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! x = x_max
+ do ispec2D = 1,nspec2D_xmax_inner_core
+
+ ispec = ibelm_xmax_inner_core(ispec2D)
+
+! do not loop on elements outside of the central cube
+ if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
+
+ i = NGLLX
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+
+ iglob = ibool_inner_core(i,j,k,ispec)
+ x_current = dble(xstore_inner_core(iglob))
+ y_current = dble(ystore_inner_core(iglob))
+ z_current = dble(zstore_inner_core(iglob))
+
+! look for matching point
+ if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
+ ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
+ goto 100
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! y = y_min
+ do ispec2D = 1,nspec2D_ymin_inner_core
+
+ ispec = ibelm_ymin_inner_core(ispec2D)
+
+! do not loop on elements outside of the central cube
+ if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
+
+ j = 1
+ do k = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool_inner_core(i,j,k,ispec)
+ x_current = dble(xstore_inner_core(iglob))
+ y_current = dble(ystore_inner_core(iglob))
+ z_current = dble(zstore_inner_core(iglob))
+
+! look for matching point
+ if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
+ ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
+ goto 100
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! y = y_max
+ do ispec2D = 1,nspec2D_ymax_inner_core
+
+ ispec = ibelm_ymax_inner_core(ispec2D)
+
+! do not loop on elements outside of the central cube
+ if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
+
+ j = NGLLY
+ do k = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool_inner_core(i,j,k,ispec)
+ x_current = dble(xstore_inner_core(iglob))
+ y_current = dble(ystore_inner_core(iglob))
+ z_current = dble(zstore_inner_core(iglob))
+
+! look for matching point
+ if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
+ ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
+ goto 100
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! bottom of cube
+ do ispec = 1,NSPEC_INNER_CORE
+
+! loop on elements at the bottom of the cube only
+ if(idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE) cycle
+
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ iglob = ibool_inner_core(i,j,k,ispec)
+ x_current = dble(xstore_inner_core(iglob))
+ y_current = dble(ystore_inner_core(iglob))
+ z_current = dble(zstore_inner_core(iglob))
+
+! look for matching point
+ if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
+ ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
+ goto 100
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! check that a matching point is found in all cases
+ call exit_MPI(myrank,'point never found in central cube')
+
+ 100 continue
+
+ enddo
+ enddo
+ endif
+
+ end subroutine create_central_cube_buffers
+
+!
+!----------------------------------
+!
+
+ subroutine comp_central_cube_buffer_size(iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM_INNER_CORE, &
+ nb_msgs_theor_in_cube,npoin2D_cube_from_slices)
+
+!--- compute number of messages to expect in cube as well as their size
+!--- take into account vertical sides and bottom side
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM_INNER_CORE
+
+ integer, intent(out) :: nb_msgs_theor_in_cube,npoin2D_cube_from_slices
+
+! only for slices in central cube
+ if(ichunk == CHUNK_AB) then
+ if(NPROC_XI == 1) then
+! five sides if only one processor in cube
+ nb_msgs_theor_in_cube = 5
+ else
+! case of a corner
+ if((iproc_xi == 0 .or. iproc_xi == NPROC_XI-1).and. &
+ (iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1)) then
+! slices on both "vertical" faces plus one slice at the bottom
+ nb_msgs_theor_in_cube = 2*(ceiling(NPROC_XI/2.d0)) + 1
+! case of an edge
+ else if(iproc_xi == 0 .or. iproc_xi == NPROC_XI-1 .or. &
+ iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1) then
+! slices on the "vertical" face plus one slice at the bottom
+ nb_msgs_theor_in_cube = ceiling(NPROC_XI/2.d0) + 1
+ else
+! bottom element only
+ nb_msgs_theor_in_cube = 1
+ endif
+ endif
+ else if(ichunk == CHUNK_AB_ANTIPODE) then
+ if(NPROC_XI == 1) then
+! five sides if only one processor in cube
+ nb_msgs_theor_in_cube = 5
+ else
+! case of a corner
+ if((iproc_xi == 0 .or. iproc_xi == NPROC_XI-1).and. &
+ (iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1)) then
+! slices on both "vertical" faces plus one slice at the bottom
+ nb_msgs_theor_in_cube = 2*(floor(NPROC_XI/2.d0)) + 1
+! case of an edge
+ else if(iproc_xi == 0 .or. iproc_xi == NPROC_XI-1 .or. &
+ iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1) then
+! slices on the "vertical" face plus one slice at the bottom
+ nb_msgs_theor_in_cube = floor(NPROC_XI/2.d0) + 1
+ else
+! bottom element only
+ nb_msgs_theor_in_cube = 1
+ endif
+ endif
+ else
+! not in chunk AB
+ nb_msgs_theor_in_cube = 0
+ endif
+
+! number of points to send or receive (bottom of slices)
+ npoin2D_cube_from_slices = NSPEC2D_BOTTOM_INNER_CORE * NGLLX * NGLLY
+
+ end subroutine comp_central_cube_buffer_size
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_central_cube_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_central_cube_buffers.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_central_cube_buffers.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,541 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!
-!--- create buffers to assemble with central cube
-!
-
- subroutine create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
- NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- NSPEC2DMAX_XMIN_XMAX_INNER_CORE,NSPEC2DMAX_YMIN_YMAX_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE, &
- addressing,ibool_inner_core,idoubling_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
- ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
- nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices, &
- receiver_cube_from_slices,sender_from_slices_to_cube,ibool_central_cube, &
- buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
-
- integer, intent(in) :: myrank,iproc_xi,iproc_eta,ichunk, &
- NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- NSPEC2DMAX_XMIN_XMAX_INNER_CORE,NSPEC2DMAX_YMIN_YMAX_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE
-
-! for addressing of the slices
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1), intent(in) :: addressing
-
-! mesh parameters
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE), intent(in) :: ibool_inner_core
-
-! local to global mapping
- integer, dimension(NSPEC_INNER_CORE), intent(in) :: idoubling_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE), intent(in) :: xstore_inner_core,ystore_inner_core,zstore_inner_core
-
-! boundary parameters locator
- integer, intent(in) :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_INNER_CORE), intent(in) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_INNER_CORE), intent(in) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE), intent(in) :: ibelm_bottom_inner_core
-
- integer, intent(in) :: nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices
-
-! for matching with central cube in inner core
- integer, intent(out) :: receiver_cube_from_slices
-
- integer, dimension(non_zero_nb_msgs_theor_in_cube), intent(out) :: sender_from_slices_to_cube
- integer, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices), intent(out) :: ibool_central_cube
- double precision, dimension(npoin2D_cube_from_slices,NDIM), intent(out) :: buffer_slices,buffer_slices2
- double precision, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM), intent(out) :: &
- buffer_all_cube_from_slices
-
-! local variables below
- integer i,j,k,ispec,ispec2D,iglob,ier
- integer sender,receiver,imsg,ipoin,iproc_xi_loop
-
- double precision x_target,y_target,z_target
- double precision x_current,y_current,z_current
-
-! MPI status of messages to be received
- integer msg_status(MPI_STATUS_SIZE)
-
-!--- processor to send information to in cube from slices
-
-! four vertical sides first
- if(ichunk == CHUNK_AC) then
- if (iproc_xi < floor(NPROC_XI/2.d0)) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1,iproc_eta)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB,0,iproc_eta)
- endif
- else if(ichunk == CHUNK_BC) then
- if (iproc_xi < floor(NPROC_XI/2.d0)) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_eta,NPROC_ETA-1)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB,iproc_eta,NPROC_ETA-1)
- endif
- else if(ichunk == CHUNK_AC_ANTIPODE) then
- if (iproc_xi <= ceiling((NPROC_XI/2.d0)-1)) then
- receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1,iproc_eta)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,0,iproc_eta)
- endif
- else if(ichunk == CHUNK_BC_ANTIPODE) then
- if (iproc_xi < floor(NPROC_XI/2.d0)) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,iproc_eta,0)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1-iproc_eta,0)
- endif
-! bottom of cube, direct correspondance but with inverted xi axis
- else if(ichunk == CHUNK_AB_ANTIPODE) then
- receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1-iproc_xi,iproc_eta)
- else if(ichunk == CHUNK_AB) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_xi,iproc_eta)
- endif
-
-
-!--- list of processors to receive information from in cube
-
-! only for slices in central cube
- if(ichunk == CHUNK_AB) then
-
-! initialize index of sender
- imsg = 0
-
-! define sender for xi = xi_min edge
- if(iproc_xi == 0) then
- do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
-! define sender for xi = xi_max edge
- if(iproc_xi == NPROC_XI-1) then
- do iproc_xi_loop = 0, floor((NPROC_XI-1)/2.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
-! define sender for eta = eta_min edge
- if(iproc_eta == 0) then
- do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,iproc_xi_loop,NPROC_ETA-1-iproc_xi)
- enddo
- endif
-
-! define sender for eta = eta_max edge
- if(iproc_eta == NPROC_ETA-1) then
- do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,iproc_xi_loop,iproc_xi)
- enddo
- endif
-
-! define sender for bottom edge
-! bottom of cube, direct correspondence but with inverted xi axis
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_xi,iproc_eta)
-
-! check that total number of faces found is correct
- if(imsg /= nb_msgs_theor_in_cube) call exit_MPI(myrank,'wrong number of faces found for central cube')
-
- else if(ichunk == CHUNK_AB_ANTIPODE) then
-
-! initialize index of sender
- imsg = 0
-
-! define sender for xi = xi_min edge
- if(iproc_xi == 0) then
- do iproc_xi_loop = ceiling(NPROC_XI/2.d0),NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
-! define sender for xi = xi_max edge
- if(iproc_xi == NPROC_XI-1) then
- do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
-! define sender for eta = eta_min edge
- if(iproc_eta == 0) then
- do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,iproc_xi_loop,iproc_xi)
- enddo
- endif
-
-! define sender for eta = eta_max edge
- if(iproc_eta == NPROC_ETA-1) then
- do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,iproc_xi_loop,NPROC_ETA-1-iproc_xi)
- enddo
- endif
-
-! define sender for bottom edge
-! bottom of cube, direct correspondence but with inverted xi axis
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AB,NPROC_XI-1-iproc_xi,iproc_eta)
-
-! check that total number of faces found is correct
- if(imsg /= nb_msgs_theor_in_cube) call exit_MPI(myrank,'wrong number of faces found for central cube')
-
- else
-
-! dummy value in slices
- sender_from_slices_to_cube(1) = -1
-
- endif
-
-
-! on chunk AB & AB ANTIPODE, receive all (except bottom) the messages from slices
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do imsg = 1,nb_msgs_theor_in_cube-1
-
-! receive buffers from slices
- sender = sender_from_slices_to_cube(imsg)
- call MPI_RECV(buffer_slices, &
- NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
-! copy buffer in 2D array for each slice
- buffer_all_cube_from_slices(imsg,:,:) = buffer_slices(:,:)
-
- enddo
- endif
-
-! send info to central cube from all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE ) then
-
-! for bottom elements in contact with central cube from the slices side
- ipoin = 0
- do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
-
- ispec = ibelm_bottom_inner_core(ispec2D)
-
-! only for DOFs exactly on surface of central cube (bottom of these elements)
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool_inner_core(i,j,k,ispec)
- buffer_slices(ipoin,1) = dble(xstore_inner_core(iglob))
- buffer_slices(ipoin,2) = dble(ystore_inner_core(iglob))
- buffer_slices(ipoin,3) = dble(zstore_inner_core(iglob))
- enddo
- enddo
- enddo
-
-! send buffer to central cube
- receiver = receiver_cube_from_slices
- call MPI_SEND(buffer_slices,NDIM*npoin2D_cube_from_slices, &
- MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
-
- endif ! end sending info to central cube
-
-
-! exchange of their bottom faces between chunks AB and AB_ANTIPODE
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
- ipoin = 0
- do ispec = NSPEC_INNER_CORE, 1, -1
- if (idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE) then
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool_inner_core(i,j,k,ispec)
- buffer_slices(ipoin,1) = dble(xstore_inner_core(iglob))
- buffer_slices(ipoin,2) = dble(ystore_inner_core(iglob))
- buffer_slices(ipoin,3) = dble(zstore_inner_core(iglob))
- enddo
- enddo
- endif
- enddo
- if (ipoin /= npoin2D_cube_from_slices) call exit_MPI(myrank,'wrong number of points found for bottom CC AB or !AB')
-
- sender = sender_from_slices_to_cube(nb_msgs_theor_in_cube)
-
- call MPI_SENDRECV(buffer_slices,NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,receiver_cube_from_slices, &
- itag,buffer_slices2,NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- buffer_all_cube_from_slices(nb_msgs_theor_in_cube,:,:) = buffer_slices2(:,:)
-
- endif
-
-!--- now we need to find the points received and create indirect addressing
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do imsg = 1,nb_msgs_theor_in_cube
-
- do ipoin = 1,npoin2D_cube_from_slices
-
- x_target = buffer_all_cube_from_slices(imsg,ipoin,1)
- y_target = buffer_all_cube_from_slices(imsg,ipoin,2)
- z_target = buffer_all_cube_from_slices(imsg,ipoin,3)
-
-! x = x_min
- do ispec2D = 1,nspec2D_xmin_inner_core
-
- ispec = ibelm_xmin_inner_core(ispec2D)
-
-! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
-
- i = 1
- do k = 1,NGLLZ
- do j = 1,NGLLY
-
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
-
-! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
-
- enddo
- enddo
-
- enddo
-
-! x = x_max
- do ispec2D = 1,nspec2D_xmax_inner_core
-
- ispec = ibelm_xmax_inner_core(ispec2D)
-
-! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
-
- i = NGLLX
- do k = 1,NGLLZ
- do j = 1,NGLLY
-
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
-
-! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
-
- enddo
- enddo
-
- enddo
-
-! y = y_min
- do ispec2D = 1,nspec2D_ymin_inner_core
-
- ispec = ibelm_ymin_inner_core(ispec2D)
-
-! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
-
- j = 1
- do k = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
-
-! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
-
- enddo
- enddo
-
- enddo
-
-! y = y_max
- do ispec2D = 1,nspec2D_ymax_inner_core
-
- ispec = ibelm_ymax_inner_core(ispec2D)
-
-! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
-
- j = NGLLY
- do k = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
-
-! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
-
- enddo
- enddo
-
- enddo
-
-! bottom of cube
- do ispec = 1,NSPEC_INNER_CORE
-
-! loop on elements at the bottom of the cube only
- if(idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE) cycle
-
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
-
-! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
-
- enddo
- enddo
-
- enddo
-
-! check that a matching point is found in all cases
- call exit_MPI(myrank,'point never found in central cube')
-
- 100 continue
-
- enddo
- enddo
- endif
-
- end subroutine create_central_cube_buffers
-
-!
-!----------------------------------
-!
-
- subroutine comp_central_cube_buffer_size(iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM_INNER_CORE, &
- nb_msgs_theor_in_cube,npoin2D_cube_from_slices)
-
-!--- compute number of messages to expect in cube as well as their size
-!--- take into account vertical sides and bottom side
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM_INNER_CORE
-
- integer, intent(out) :: nb_msgs_theor_in_cube,npoin2D_cube_from_slices
-
-! only for slices in central cube
- if(ichunk == CHUNK_AB) then
- if(NPROC_XI == 1) then
-! five sides if only one processor in cube
- nb_msgs_theor_in_cube = 5
- else
-! case of a corner
- if((iproc_xi == 0 .or. iproc_xi == NPROC_XI-1).and. &
- (iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1)) then
-! slices on both "vertical" faces plus one slice at the bottom
- nb_msgs_theor_in_cube = 2*(ceiling(NPROC_XI/2.d0)) + 1
-! case of an edge
- else if(iproc_xi == 0 .or. iproc_xi == NPROC_XI-1 .or. &
- iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1) then
-! slices on the "vertical" face plus one slice at the bottom
- nb_msgs_theor_in_cube = ceiling(NPROC_XI/2.d0) + 1
- else
-! bottom element only
- nb_msgs_theor_in_cube = 1
- endif
- endif
- else if(ichunk == CHUNK_AB_ANTIPODE) then
- if(NPROC_XI == 1) then
-! five sides if only one processor in cube
- nb_msgs_theor_in_cube = 5
- else
-! case of a corner
- if((iproc_xi == 0 .or. iproc_xi == NPROC_XI-1).and. &
- (iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1)) then
-! slices on both "vertical" faces plus one slice at the bottom
- nb_msgs_theor_in_cube = 2*(floor(NPROC_XI/2.d0)) + 1
-! case of an edge
- else if(iproc_xi == 0 .or. iproc_xi == NPROC_XI-1 .or. &
- iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1) then
-! slices on the "vertical" face plus one slice at the bottom
- nb_msgs_theor_in_cube = floor(NPROC_XI/2.d0) + 1
- else
-! bottom element only
- nb_msgs_theor_in_cube = 1
- endif
- endif
- else
-! not in chunk AB
- nb_msgs_theor_in_cube = 0
- endif
-
-! number of points to send or receive (bottom of slices)
- npoin2D_cube_from_slices = NSPEC2D_BOTTOM_INNER_CORE * NGLLX * NGLLY
-
- end subroutine comp_central_cube_buffer_size
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_chunk_buffers.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_chunk_buffers.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_chunk_buffers.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_chunk_buffers.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,1005 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! subroutine to create MPI buffers to assemble between chunks
+
+ subroutine create_chunk_buffers(iregion_code,nspec,ibool,idoubling,xstore,ystore,zstore, &
+ nglob_ori, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,NGLOB1D_RADIAL_MAX, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ myrank, &
+ addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces,npoin2D_faces,iboolcorner,NGLOB1D_RADIAL,NGLOB2DMAX_XY)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "precision.h"
+#endif
+
+!! DK DK for the merged version
+! include values created by the mesher
+ include "values_from_mesher.h"
+
+!! DK DK added this for the merged version
+ integer :: NGLOB1D_RADIAL
+ integer :: imsg2,icount_faces,icount_corners
+ integer, dimension(NUMFACES_SHARED) :: npoin2D_faces
+ integer :: NGLOB2DMAX_XY
+ integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
+ integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
+
+!! DK DK added this for the merged version
+!---- arrays to assemble between chunks
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES_VAL) :: imsg_type,iprocfrom_faces,iprocto_faces
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
+
+ integer nglob,nglob_ori
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
+ integer NPROC,NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_MAX,NGLOB1D_RADIAL_my_corner
+ integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+ integer nspec
+ integer myrank,NCHUNKS
+
+! arrays with the mesh
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ character(len=150) ERR_MSG
+
+! array with the local to global mapping per slice
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+
+! mask for ibool to mark points already found
+ logical, dimension(nglob_ori) :: mask_ibool
+
+! array to store points selected for the chunk face buffer
+ integer, dimension(NGLOB2DMAX_XY) :: ibool_selected
+
+ double precision, dimension(NGLOB2DMAX_XY) :: xstore_selected,ystore_selected,zstore_selected
+
+! arrays for sorting routine
+ integer, dimension(NGLOB2DMAX_XY) :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(NGLOB2DMAX_XY) :: ifseg
+ double precision, dimension(NGLOB2DMAX_XY) :: work
+
+! pairs generated theoretically
+! four sides for each of the three types of messages
+ integer, dimension(NUMMSGS_FACES_VAL) :: npoin2D_send,npoin2D_receive
+
+! 1D buffers to remove points belonging to corners
+ integer ibool1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_leftxi_righteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_rightxi_righteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D(NGLOB1D_RADIAL_MAX)
+ integer ipoin1D
+
+!! DK DK changed this for merged version
+ double precision, dimension(NGLOB1D_RADIAL_MAX) :: &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta
+
+ double precision, dimension(NGLOB1D_RADIAL_MAX) :: xread1D,yread1D,zread1D
+
+! arrays to assemble the corners (3 processors for each corner)
+ integer, dimension(3,NCORNERSCHUNKS_VAL) :: iprocscorners,itypecorner
+
+ integer ichunk_send,iproc_xi_send,iproc_eta_send
+ integer ichunk_receive,iproc_xi_receive,iproc_eta_receive
+ integer iproc_loop,iproc_xi_loop,iproc_eta_loop
+ integer iproc_xi_loop_inv,iproc_eta_loop_inv
+ integer imember_corner
+
+ integer iregion_code
+
+ integer iproc_edge_send,iproc_edge_receive
+ integer imsg_type_loop,iside,imode_comm,iedge
+
+! boundary parameters per slice
+ integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
+ integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
+ integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
+
+ integer npoin2D,npoin2D_send_local,npoin2D_receive_local
+
+ integer i,j,k,ispec,ispec2D,ipoin2D
+
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+! current message number
+ integer imsg
+
+! for addressing of the slices
+ integer ichunk,iproc_xi,iproc_eta,iproc
+ integer addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1)
+ integer ichunk_slice(0:NPROCTOT-1)
+ integer iproc_xi_slice(0:NPROCTOT-1)
+
+ integer iproc_eta_slice(0:NPROCTOT-1)
+
+! this to avoid problem at compile time if less than six chunks
+ integer addressing_big(NCHUNKS_MAX,0:NPROC_XI-1,0:NPROC_ETA-1)
+
+! number of faces between chunks
+ integer NUM_FACES,NUMMSGS_FACES
+
+! number of corners between chunks
+ integer NCORNERSCHUNKS
+
+! number of message types
+ integer NUM_MSG_TYPES
+
+ integer NPROC_ONE_DIRECTION
+
+! ************** subroutine starts here **************
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '----- creating chunk buffers -----'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
+ write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
+ write(IMAIN,*) 'There are ',NCHUNKS,' chunks'
+ write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in all the chunks'
+ write(IMAIN,*)
+ endif
+
+! number of corners and faces shared between chunks and number of message types
+ if(NCHUNKS == 1 .or. NCHUNKS == 2) then
+ NCORNERSCHUNKS = 1
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 1
+ else if(NCHUNKS == 3) then
+ NCORNERSCHUNKS = 1
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 3
+ else if(NCHUNKS == 6) then
+ NCORNERSCHUNKS = 8
+ NUM_FACES = 4
+ NUM_MSG_TYPES = 3
+ else
+ call exit_MPI(myrank,'number of chunks must be either 1, 2, 3 or 6')
+ endif
+
+! if more than one chunk then same number of processors in each direction
+ NPROC_ONE_DIRECTION = NPROC_XI
+
+! total number of messages corresponding to these common faces
+ NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
+
+! check that there is more than one chunk, otherwise nothing to do
+ if(NCHUNKS == 1) return
+
+! same number of GLL points in each direction for several chunks
+ if(NGLLY /= NGLLX) call exit_MPI(myrank,'must have NGLLY = NGLLX for several chunks')
+
+! clear arrays
+ iprocfrom_faces(:) = 0
+ iprocto_faces(:) = 0
+ npoin2D_send(:) = 0
+ npoin2D_receive(:) = 0
+ iprocscorners(:,:) = 0
+ itypecorner(:,:) = 0
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'There is a total of ',NUMMSGS_FACES,' messages to assemble faces between chunks'
+ write(IMAIN,*)
+ endif
+
+ imsg = 0
+
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+
+! create theoretical communication pattern
+ do imsg_type_loop = 1,NUM_MSG_TYPES
+ do iside = 1,NUM_FACES
+ do iproc_loop = 0,NPROC_ONE_DIRECTION-1
+
+! create a new message
+! we know there can be no deadlock with this scheme
+! because the three types of messages are independent
+ imsg = imsg + 1
+
+! check that current message number is correct
+ if(imsg > NUMMSGS_FACES) call exit_MPI(myrank,'incorrect message number')
+
+ if(myrank == 0) write(IMAIN,*) 'Generating message ',imsg,' for faces out of ',NUMMSGS_FACES
+
+! we know there is the same number of slices in both directions
+ iproc_xi_loop = iproc_loop
+ iproc_eta_loop = iproc_loop
+
+! take care of local frame inversions between chunks
+ iproc_xi_loop_inv = NPROC_ONE_DIRECTION - iproc_loop - 1
+ iproc_eta_loop_inv = NPROC_ONE_DIRECTION - iproc_loop - 1
+
+
+! define the 12 different messages
+
+! message type M1
+ if(imsg_type_loop == 1) then
+
+ if(iside == 1) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AC
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MAX
+ endif
+
+ if(iside == 2) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = NPROC_XI-1
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MAX
+ ichunk_receive = CHUNK_AC_ANTIPODE
+ iproc_xi_receive = 0
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MIN
+ endif
+
+ if(iside == 3) then
+ ichunk_send = CHUNK_AC_ANTIPODE
+ iproc_xi_send = NPROC_XI-1
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MAX
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = 0
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MIN
+ endif
+
+ if(iside == 4) then
+ ichunk_send = CHUNK_AC
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MAX
+ endif
+
+ endif
+
+! message type M2
+ if(imsg_type_loop == 2) then
+
+ if(iside == 1) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = NPROC_ETA-1
+ iproc_edge_send = ETA_MAX
+ ichunk_receive = CHUNK_BC
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MAX
+ endif
+
+ if(iside == 2) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = 0
+ iproc_edge_send = ETA_MIN
+ ichunk_receive = CHUNK_BC_ANTIPODE
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop_inv
+ iproc_edge_receive = XI_MAX
+ endif
+
+ if(iside == 3) then
+ ichunk_send = CHUNK_BC
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop_inv
+ iproc_eta_receive = NPROC_ETA-1
+ iproc_edge_receive = ETA_MAX
+ endif
+
+ if(iside == 4) then
+ ichunk_send = CHUNK_BC_ANTIPODE
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop
+ iproc_eta_receive = 0
+ iproc_edge_receive = ETA_MIN
+ endif
+
+ endif
+
+! message type M3
+ if(imsg_type_loop == 3) then
+
+ if(iside == 1) then
+ ichunk_send = CHUNK_AC
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = NPROC_ETA-1
+ iproc_edge_send = ETA_MAX
+ ichunk_receive = CHUNK_BC
+ iproc_xi_receive = iproc_xi_loop
+ iproc_eta_receive = 0
+ iproc_edge_receive = ETA_MIN
+ endif
+
+ if(iside == 2) then
+ ichunk_send = CHUNK_BC
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = NPROC_ETA-1
+ iproc_edge_send = ETA_MAX
+ ichunk_receive = CHUNK_AC_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop_inv
+ iproc_eta_receive = NPROC_ETA-1
+ iproc_edge_receive = ETA_MAX
+ endif
+
+ if(iside == 3) then
+ ichunk_send = CHUNK_AC_ANTIPODE
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = 0
+ iproc_edge_send = ETA_MIN
+ ichunk_receive = CHUNK_BC_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop_inv
+ iproc_eta_receive = 0
+ iproc_edge_receive = ETA_MIN
+ endif
+
+ if(iside == 4) then
+ ichunk_send = CHUNK_AC
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = 0
+ iproc_edge_send = ETA_MIN
+ ichunk_receive = CHUNK_BC_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop
+ iproc_eta_receive = NPROC_ETA-1
+ iproc_edge_receive = ETA_MAX
+ endif
+
+ endif
+
+
+! store addressing generated
+ iprocfrom_faces(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
+ iprocto_faces(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
+ imsg_type(imsg) = imsg_type_loop
+
+! check that sender/receiver pair is ordered
+ if(iprocfrom_faces(imsg) > iprocto_faces(imsg)) call exit_MPI(myrank,'incorrect order in sender/receiver pair')
+
+! save message type and pair of processors in list of messages
+!!! DK DK for merged if(myrank == 0) write(IOUT,*) imsg_type(imsg),iprocfrom_faces(imsg),iprocto_faces(imsg)
+
+! loop on sender/receiver (1=sender 2=receiver)
+ do imode_comm=1,2
+
+ if(imode_comm == 1) then
+ iproc = iprocfrom_faces(imsg)
+ iedge = iproc_edge_send
+!! DK DK commented this out for the merged version
+! write(filename_out,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
+
+ else if(imode_comm == 2) then
+ iproc = iprocto_faces(imsg)
+ iedge = iproc_edge_receive
+!! DK DK commented this out for the merged version
+! write(filename_out,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
+
+ else
+ call exit_MPI(myrank,'incorrect communication mode')
+ endif
+
+! only do this if current processor is the right one for MPI version
+ if(iproc == myrank) then
+
+!---------------------------------------------------------------------
+
+!! DK DK added this for the merged version, modified from the old read_arrays_buffers_solver.f90
+!! DK DK the goal here is to determine the right value of icount_faces
+
+!---- read indirect addressing for each message for faces of the chunks
+!---- a given slice can belong to at most two faces
+! check that we have found the right correspondance
+ if(imode_comm == 1 .and. myrank /= iprocfrom_faces(imsg)) call exit_MPI(myrank,'this message should be for a sender')
+ if(imode_comm == 2 .and. myrank /= iprocto_faces(imsg)) call exit_MPI(myrank,'this message should be for a receiver')
+ icount_faces = 0
+ do imsg2 = 1,imsg
+ if(myrank == iprocfrom_faces(imsg2) .or. myrank == iprocto_faces(imsg2)) then
+ icount_faces = icount_faces + 1
+ if(icount_faces>NUMFACES_SHARED) call exit_MPI(myrank,'more than NUMFACES_SHARED faces for this slice')
+ if(icount_faces>2 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) call exit_MPI(myrank,'more than two faces for this slice')
+ endif
+ enddo
+
+!---------------------------------------------------------------------
+
+! determine chunk number and local slice coordinates using addressing
+ ichunk = ichunk_slice(iproc)
+ iproc_xi = iproc_xi_slice(iproc)
+ iproc_eta = iproc_eta_slice(iproc)
+
+! problem if not on edges
+ if(iproc_xi /= 0 .and. iproc_xi /= NPROC_XI-1 .and. &
+ iproc_eta /= 0 .and. iproc_eta /= NPROC_ETA-1) call exit_MPI(myrank,'slice not on any edge')
+
+ nglob=nglob_ori
+! check that iboolmax=nglob
+
+ if(minval(ibool(:,:,:,1:nspec)) /= 1 .or. maxval(ibool(:,:,:,1:nspec)) /= nglob) &
+ call exit_MPI(myrank,ERR_MSG)
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! erase logical mask
+ mask_ibool(:) = .false.
+
+ npoin2D = 0
+
+! create all the points on each face (no duplicates, but not sorted)
+
+! xmin
+ if(iedge == XI_MIN) then
+
+! mark corner points to remove them if needed
+ if(iproc_eta == 0) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ mask_ibool(ibool1D_leftxi_lefteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ if(iproc_eta == NPROC_ETA-1) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ mask_ibool(ibool1D_leftxi_righteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ do ispec2D=1,nspec2D_xmin
+ ispec=ibelm_xmin(ispec2D)
+
+! remove central cube for chunk buffers
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+
+ i=1
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ if(.not. mask_ibool(ibool(i,j,k,ispec))) then
+! mask and store points found
+ mask_ibool(ibool(i,j,k,ispec)) = .true.
+ npoin2D = npoin2D + 1
+ if(npoin2D > NGLOB2DMAX_XMIN_XMAX) call exit_MPI(myrank,'incorrect 2D point number in xmin')
+ ibool_selected(npoin2D) = ibool(i,j,k,ispec)
+
+ xstore_selected(npoin2D) = xstore(i,j,k,ispec)
+ ystore_selected(npoin2D) = ystore(i,j,k,ispec)
+ zstore_selected(npoin2D) = zstore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+
+! xmax
+ else if(iedge == XI_MAX) then
+
+! mark corner points to remove them if needed
+
+ if(iproc_eta == 0) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ mask_ibool(ibool1D_rightxi_lefteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ if(iproc_eta == NPROC_ETA-1) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ mask_ibool(ibool1D_rightxi_righteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ do ispec2D=1,nspec2D_xmax
+ ispec=ibelm_xmax(ispec2D)
+
+! remove central cube for chunk buffers
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+
+ i=NGLLX
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ if(.not. mask_ibool(ibool(i,j,k,ispec))) then
+! mask and store points found
+ mask_ibool(ibool(i,j,k,ispec)) = .true.
+ npoin2D = npoin2D + 1
+ if(npoin2D > NGLOB2DMAX_XMIN_XMAX) call exit_MPI(myrank,'incorrect 2D point number in xmax')
+ ibool_selected(npoin2D) = ibool(i,j,k,ispec)
+
+ xstore_selected(npoin2D) = xstore(i,j,k,ispec)
+ ystore_selected(npoin2D) = ystore(i,j,k,ispec)
+ zstore_selected(npoin2D) = zstore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+
+! ymin
+ else if(iedge == ETA_MIN) then
+
+! mark corner points to remove them if needed
+
+ if(iproc_xi == 0) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ mask_ibool(ibool1D_leftxi_lefteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ if(iproc_xi == NPROC_XI-1) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ mask_ibool(ibool1D_rightxi_lefteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ do ispec2D=1,nspec2D_ymin
+ ispec=ibelm_ymin(ispec2D)
+
+! remove central cube for chunk buffers
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+
+ j=1
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ if(.not. mask_ibool(ibool(i,j,k,ispec))) then
+! mask and store points found
+ mask_ibool(ibool(i,j,k,ispec)) = .true.
+ npoin2D = npoin2D + 1
+ if(npoin2D > NGLOB2DMAX_YMIN_YMAX) call exit_MPI(myrank,'incorrect 2D point number in ymin')
+ ibool_selected(npoin2D) = ibool(i,j,k,ispec)
+
+ xstore_selected(npoin2D) = xstore(i,j,k,ispec)
+ ystore_selected(npoin2D) = ystore(i,j,k,ispec)
+ zstore_selected(npoin2D) = zstore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+
+! ymax
+ else if(iedge == ETA_MAX) then
+
+! mark corner points to remove them if needed
+
+ if(iproc_xi == 0) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ mask_ibool(ibool1D_leftxi_righteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ if(iproc_xi == NPROC_XI-1) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ mask_ibool(ibool1D_rightxi_righteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ do ispec2D=1,nspec2D_ymax
+ ispec=ibelm_ymax(ispec2D)
+
+! remove central cube for chunk buffers
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+
+ j=NGLLY
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ if(.not. mask_ibool(ibool(i,j,k,ispec))) then
+! mask and store points found
+ mask_ibool(ibool(i,j,k,ispec)) = .true.
+ npoin2D = npoin2D + 1
+ if(npoin2D > NGLOB2DMAX_YMIN_YMAX) call exit_MPI(myrank,'incorrect 2D point number in ymax')
+ ibool_selected(npoin2D) = ibool(i,j,k,ispec)
+
+ xstore_selected(npoin2D) = xstore(i,j,k,ispec)
+ ystore_selected(npoin2D) = ystore(i,j,k,ispec)
+ zstore_selected(npoin2D) = zstore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+
+ else
+
+ call exit_MPI(myrank,'incorrect edge code')
+ endif
+
+! sort buffer obtained to be conforming with neighbor in other chunk
+! sort on x, y and z, the other arrays will be swapped as well
+ call sort_array_coordinates(npoin2D,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+! check that no duplicate has been detected
+ if(nglob /= npoin2D) call exit_MPI(myrank,'duplicates detected in buffer')
+
+! write list of selected points to output buffer
+!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) npoin2D
+
+!! DK DK added this for the merged version
+ npoin2D_faces(icount_faces) = npoin2D
+
+!! DK DK suppressed in the merged version do ipoin2D = 1,npoin2D
+ do ipoin2D = 1,npoin2D
+!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) ibool_selected(ipoin2D), &
+!! DK DK suppressed in the merged version
+! xstore_selected(ipoin2D),ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+
+!! DK DK added this for the merged version
+ iboolfaces(ipoin2D,icount_faces) = ibool_selected(ipoin2D)
+
+ enddo
+!! DK DK suppressed in the merged version enddo
+
+!! DK DK suppressed in the merged version close(IOUT_BUFFERS)
+
+! store result to compare number of points for sender and for receiver
+ if(imode_comm == 1) then
+ npoin2D_send(imsg) = npoin2D
+ else
+ npoin2D_receive(imsg) = npoin2D
+ endif
+
+! end of section done only if right processor for MPI
+ endif
+
+! end of loop on sender/receiver
+ enddo
+
+! end of loops on all the messages
+ enddo
+ enddo
+ enddo
+
+!!! DK DK for merged if(myrank == 0) close(IOUT)
+
+! check that total number of messages is correct
+ if(imsg /= NUMMSGS_FACES) call exit_MPI(myrank,'incorrect total number of messages')
+
+!
+!---- check that number of points detected is the same for sender and receiver
+!
+
+! gather information about all the messages on all processes
+ do imsg = 1,NUMMSGS_FACES
+
+! gather number of points for sender
+ npoin2D_send_local = npoin2D_send(imsg)
+#ifdef USE_MPI
+ call MPI_BCAST(npoin2D_send_local,1,MPI_INTEGER,iprocfrom_faces(imsg),MPI_COMM_WORLD,ier)
+#endif
+ if(myrank /= iprocfrom_faces(imsg)) npoin2D_send(imsg) = npoin2D_send_local
+
+! gather number of points for receiver
+ npoin2D_receive_local = npoin2D_receive(imsg)
+#ifdef USE_MPI
+ call MPI_BCAST(npoin2D_receive_local,1,MPI_INTEGER,iprocto_faces(imsg),MPI_COMM_WORLD,ier)
+#endif
+ if(myrank /= iprocto_faces(imsg)) npoin2D_receive(imsg) = npoin2D_receive_local
+
+ enddo
+
+! check the number of points
+ do imsg = 1,NUMMSGS_FACES
+ if(npoin2D_send(imsg) /= npoin2D_receive(imsg)) &
+ call exit_MPI(myrank,'incorrect number of points for sender/receiver pair detected')
+ enddo
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'all the messages for chunk faces have the right size'
+ write(IMAIN,*)
+ endif
+
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+
+!
+!---- generate the 8 message patterns sharing a corner of valence 3
+!
+
+! to avoid problem at compile time, use bigger array with fixed dimension
+ addressing_big(:,:,:) = 0
+ addressing_big(1:NCHUNKS,:,:) = addressing(1:NCHUNKS,:,:)
+
+ ichunk = 1
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,0,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC,NPROC_XI-1,NPROC_ETA-1)
+! this line is ok even for NCHUNKS = 2
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_BC,NPROC_XI-1,0)
+
+ itypecorner(1,ichunk) = ILOWERUPPER
+ itypecorner(2,ichunk) = IUPPERUPPER
+ itypecorner(3,ichunk) = IUPPERLOWER
+
+!! DK DK UGLY in the future, should also assemble second corner when NCHUNKS = 2
+!! DK DK UGLY for now we only assemble one corner for simplicity
+!! DK DK UGLY formally this is incorrect and should be changed in the future
+!! DK DK UGLY in practice this trick works fine
+
+! this only if more than 3 chunks
+ if(NCHUNKS > 3) then
+
+ ichunk = 2
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,NPROC_XI-1,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,0,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,NPROC_XI-1,0)
+
+ itypecorner(1,ichunk) = IUPPERLOWER
+ itypecorner(2,ichunk) = ILOWERLOWER
+ itypecorner(3,ichunk) = IUPPERLOWER
+
+ ichunk = 3
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,0,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC,NPROC_XI-1,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = ILOWERLOWER
+ itypecorner(2,ichunk) = IUPPERLOWER
+ itypecorner(3,ichunk) = IUPPERUPPER
+
+ ichunk = 4
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,NPROC_XI-1,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC,NPROC_XI-1,NPROC_ETA-1)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,0,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = IUPPERUPPER
+ itypecorner(2,ichunk) = IUPPERUPPER
+ itypecorner(3,ichunk) = ILOWERUPPER
+
+ ichunk = 5
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AC,0,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,0,NPROC_ETA-1)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,NPROC_XI-1,0)
+
+ itypecorner(1,ichunk) = ILOWERLOWER
+ itypecorner(2,ichunk) = ILOWERUPPER
+ itypecorner(3,ichunk) = IUPPERLOWER
+
+ ichunk = 6
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,NPROC_XI-1,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,0,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,0,0)
+
+ itypecorner(1,ichunk) = IUPPERLOWER
+ itypecorner(2,ichunk) = ILOWERLOWER
+ itypecorner(3,ichunk) = ILOWERLOWER
+
+ ichunk = 7
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AC,0,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC,0,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = ILOWERUPPER
+ itypecorner(2,ichunk) = ILOWERLOWER
+ itypecorner(3,ichunk) = IUPPERUPPER
+
+ ichunk = 8
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_BC,0,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,0,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = ILOWERUPPER
+ itypecorner(2,ichunk) = IUPPERUPPER
+ itypecorner(3,ichunk) = ILOWERUPPER
+
+ endif
+
+! loop over all the messages to create the addressing
+ do imsg = 1,NCORNERSCHUNKS
+
+ if(myrank == 0) write(IMAIN,*) 'Generating message ',imsg,' for corners out of ',NCORNERSCHUNKS
+
+! save triplet of processors in list of messages
+!!! DK DK for merged if(myrank == 0) write(IOUT,*) iprocscorners(1,imsg),iprocscorners(2,imsg),iprocscorners(3,imsg)
+
+! loop on the three processors of a given corner
+ do imember_corner = 1,3
+
+! if(imember_corner == 1) then
+! write(filename_out,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
+! else if(imember_corner == 2) then
+! write(filename_out,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
+! else
+! write(filename_out,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
+! endif
+
+! only do this if current processor is the right one for MPI version
+! this line is ok even for NCHUNKS = 2
+ if(iprocscorners(imember_corner,imsg) == myrank) then
+
+!---------------------------------------------------------------------
+
+!! DK DK added this for the merged version, modified from the old read_arrays_buffers_solver.f90
+!! DK DK the goal here is to determine the right value of icount_corners
+
+!---- read indirect addressing for each message for corners of the chunks
+!---- a given slice can belong to at most one corner
+! check that we have found the right correspondance
+ if(imember_corner == 1 .and. myrank /= iprocscorners(1,imsg)) call exit_MPI(myrank,'this message should be for a master')
+ if(imember_corner == 2 .and. myrank /= iprocscorners(2,imsg)) call exit_MPI(myrank,'this message should be for a worker1')
+ if(imember_corner == 3 .and. myrank /= iprocscorners(3,imsg)) call exit_MPI(myrank,'this message should be for a worker2')
+ icount_corners = 0
+ do imsg2 = 1,imsg
+ if(myrank == iprocscorners(1,imsg2) .or. &
+ myrank == iprocscorners(2,imsg2) .or. &
+ myrank == iprocscorners(3,imsg2)) then
+ icount_corners = icount_corners + 1
+ if(icount_corners>1 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) &
+ call exit_MPI(myrank,'more than one corner for this slice')
+ if(icount_corners>4) call exit_MPI(myrank,'more than four corners for this slice')
+ endif
+ enddo
+
+!---- read indirect addressing for each message for faces of the chunks
+!---- a given slice can belong to at most two faces
+ if(imode_comm == 1 .and. myrank /= iprocfrom_faces(imsg)) call exit_MPI(myrank,'this message should be for a sender')
+ if(imode_comm == 2 .and. myrank /= iprocto_faces(imsg)) call exit_MPI(myrank,'this message should be for a receiver')
+
+!---------------------------------------------------------------------
+
+! pick the correct 1D buffer
+! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
+ if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ else
+ call exit_MPI(myrank,'incorrect corner coordinates')
+ endif
+
+! 1D buffer for corner
+ do ipoin1D = 1,NGLOB1D_RADIAL_my_corner
+
+!! DK DK added this for merged
+! pick the correct 1D buffer
+! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
+ if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
+ ibool1D(ipoin1D) = ibool1D_leftxi_lefteta(ipoin1D)
+ xread1D(ipoin1D) = xread1D_leftxi_lefteta(ipoin1D)
+ yread1D(ipoin1D) = yread1D_leftxi_lefteta(ipoin1D)
+ zread1D(ipoin1D) = zread1D_leftxi_lefteta(ipoin1D)
+ else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
+ ibool1D(ipoin1D) = ibool1D_leftxi_righteta(ipoin1D)
+ xread1D(ipoin1D) = xread1D_leftxi_righteta(ipoin1D)
+ yread1D(ipoin1D) = yread1D_leftxi_righteta(ipoin1D)
+ zread1D(ipoin1D) = zread1D_leftxi_righteta(ipoin1D)
+ else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
+ ibool1D(ipoin1D) = ibool1D_rightxi_lefteta(ipoin1D)
+ xread1D(ipoin1D) = xread1D_rightxi_lefteta(ipoin1D)
+ yread1D(ipoin1D) = yread1D_rightxi_lefteta(ipoin1D)
+ zread1D(ipoin1D) = zread1D_rightxi_lefteta(ipoin1D)
+ else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
+ ibool1D(ipoin1D) = ibool1D_rightxi_righteta(ipoin1D)
+ xread1D(ipoin1D) = xread1D_rightxi_righteta(ipoin1D)
+ yread1D(ipoin1D) = yread1D_rightxi_righteta(ipoin1D)
+ zread1D(ipoin1D) = zread1D_rightxi_righteta(ipoin1D)
+ else
+ call exit_MPI(myrank,'incorrect corner coordinates')
+ endif
+
+ enddo
+!! DK DK suppressed in the merged version close(IIN)
+
+! sort array read based upon the coordinates of the points
+! to ensure conforming matching with other buffers from neighbors
+ call sort_array_coordinates(NGLOB1D_RADIAL_my_corner,xread1D,yread1D,zread1D, &
+ ibool1D,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+! check that no duplicates have been found
+ if(nglob /= NGLOB1D_RADIAL_my_corner) call exit_MPI(myrank,'duplicates found for corners')
+
+! 1D buffer for corner
+ do ipoin1D = 1,NGLOB1D_RADIAL_my_corner
+!! DK DK added this for merged version
+ iboolcorner(ipoin1D,icount_corners) = ibool1D(ipoin1D)
+ enddo
+
+! end of section done only if right processor for MPI
+ endif
+
+ enddo
+
+ enddo
+
+! save arrays in a slightly different format for historical reasons
+ iproc_master_corners(:) = iprocscorners(1,:)
+ iproc_worker1_corners(:) = iprocscorners(2,:)
+ iproc_worker2_corners(:) = iprocscorners(3,:)
+
+ end subroutine create_chunk_buffers
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_chunk_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_chunk_buffers.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_chunk_buffers.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,993 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-! subroutine to create MPI buffers to assemble between chunks
-
- subroutine create_chunk_buffers(iregion_code,nspec,ibool,idoubling,xstore,ystore,zstore, &
- nglob_ori, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,NGLOB1D_RADIAL_MAX, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- myrank, &
- addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
- ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax, &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
- iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces,npoin2D_faces,iboolcorner,NGLOB1D_RADIAL,NGLOB2DMAX_XY)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
-!! DK DK for the merged version
-! include values created by the mesher
- include "values_from_mesher.h"
-
-!! DK DK added this for the merged version
- integer :: NGLOB1D_RADIAL
- integer :: imsg2,icount_faces,icount_corners
- integer, dimension(NUMFACES_SHARED) :: npoin2D_faces
- integer :: NGLOB2DMAX_XY
- integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
- integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
-
-!! DK DK added this for the merged version
-!---- arrays to assemble between chunks
-
-! communication pattern for faces between chunks
- integer, dimension(NUMMSGS_FACES_VAL) :: imsg_type,iprocfrom_faces,iprocto_faces
-
-! communication pattern for corners between chunks
- integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
-
- integer nglob,nglob_ori
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
- integer NPROC,NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_MAX,NGLOB1D_RADIAL_my_corner
- integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
- integer nspec
- integer myrank,NCHUNKS
-
-! arrays with the mesh
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- character(len=150) ERR_MSG
-
-! array with the local to global mapping per slice
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer idoubling(nspec)
-
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
-
-! mask for ibool to mark points already found
- logical, dimension(nglob_ori) :: mask_ibool
-
-! array to store points selected for the chunk face buffer
- integer, dimension(NGLOB2DMAX_XY) :: ibool_selected
-
- double precision, dimension(NGLOB2DMAX_XY) :: xstore_selected,ystore_selected,zstore_selected
-
-! arrays for sorting routine
- integer, dimension(NGLOB2DMAX_XY) :: ind,ninseg,iglob,locval,iwork
- logical, dimension(NGLOB2DMAX_XY) :: ifseg
- double precision, dimension(NGLOB2DMAX_XY) :: work
-
-! pairs generated theoretically
-! four sides for each of the three types of messages
- integer, dimension(NUMMSGS_FACES_VAL) :: npoin2D_send,npoin2D_receive
-
-! 1D buffers to remove points belonging to corners
- integer ibool1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D_leftxi_righteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D_rightxi_righteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D(NGLOB1D_RADIAL_MAX)
- integer ipoin1D
-
-!! DK DK changed this for merged version
- double precision, dimension(NGLOB1D_RADIAL_MAX) :: &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta
-
- double precision, dimension(NGLOB1D_RADIAL_MAX) :: xread1D,yread1D,zread1D
-
-! arrays to assemble the corners (3 processors for each corner)
- integer, dimension(3,NCORNERSCHUNKS_VAL) :: iprocscorners,itypecorner
-
- integer ichunk_send,iproc_xi_send,iproc_eta_send
- integer ichunk_receive,iproc_xi_receive,iproc_eta_receive
- integer iproc_loop,iproc_xi_loop,iproc_eta_loop
- integer iproc_xi_loop_inv,iproc_eta_loop_inv
- integer imember_corner
-
- integer iregion_code
-
- integer iproc_edge_send,iproc_edge_receive
- integer imsg_type_loop,iside,imode_comm,iedge
-
-! boundary parameters per slice
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
- integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
- integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
-
- integer npoin2D,npoin2D_send_local,npoin2D_receive_local
-
- integer i,j,k,ispec,ispec2D,ipoin2D,ier
-
-! current message number
- integer imsg
-
-! for addressing of the slices
- integer ichunk,iproc_xi,iproc_eta,iproc
- integer addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1)
- integer ichunk_slice(0:NPROCTOT-1)
- integer iproc_xi_slice(0:NPROCTOT-1)
-
- integer iproc_eta_slice(0:NPROCTOT-1)
-
-! this to avoid problem at compile time if less than six chunks
- integer addressing_big(NCHUNKS_MAX,0:NPROC_XI-1,0:NPROC_ETA-1)
-
-! number of faces between chunks
- integer NUM_FACES,NUMMSGS_FACES
-
-! number of corners between chunks
- integer NCORNERSCHUNKS
-
-! number of message types
- integer NUM_MSG_TYPES
-
- integer NPROC_ONE_DIRECTION
-
-! ************** subroutine starts here **************
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '----- creating chunk buffers -----'
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
- write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
- write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
- write(IMAIN,*) 'There are ',NCHUNKS,' chunks'
- write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in all the chunks'
- write(IMAIN,*)
- endif
-
-! number of corners and faces shared between chunks and number of message types
- if(NCHUNKS == 1 .or. NCHUNKS == 2) then
- NCORNERSCHUNKS = 1
- NUM_FACES = 1
- NUM_MSG_TYPES = 1
- else if(NCHUNKS == 3) then
- NCORNERSCHUNKS = 1
- NUM_FACES = 1
- NUM_MSG_TYPES = 3
- else if(NCHUNKS == 6) then
- NCORNERSCHUNKS = 8
- NUM_FACES = 4
- NUM_MSG_TYPES = 3
- else
- call exit_MPI(myrank,'number of chunks must be either 1, 2, 3 or 6')
- endif
-
-! if more than one chunk then same number of processors in each direction
- NPROC_ONE_DIRECTION = NPROC_XI
-
-! total number of messages corresponding to these common faces
- NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
-
-! check that there is more than one chunk, otherwise nothing to do
- if(NCHUNKS == 1) return
-
-! same number of GLL points in each direction for several chunks
- if(NGLLY /= NGLLX) call exit_MPI(myrank,'must have NGLLY = NGLLX for several chunks')
-
-! clear arrays
- iprocfrom_faces(:) = 0
- iprocto_faces(:) = 0
- npoin2D_send(:) = 0
- npoin2D_receive(:) = 0
- iprocscorners(:,:) = 0
- itypecorner(:,:) = 0
-
- if(myrank == 0) then
- write(IMAIN,*) 'There is a total of ',NUMMSGS_FACES,' messages to assemble faces between chunks'
- write(IMAIN,*)
- endif
-
- imsg = 0
-
-!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
-!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
-!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
-!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
-!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
-!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
-!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
-
-! create theoretical communication pattern
- do imsg_type_loop = 1,NUM_MSG_TYPES
- do iside = 1,NUM_FACES
- do iproc_loop = 0,NPROC_ONE_DIRECTION-1
-
-! create a new message
-! we know there can be no deadlock with this scheme
-! because the three types of messages are independent
- imsg = imsg + 1
-
-! check that current message number is correct
- if(imsg > NUMMSGS_FACES) call exit_MPI(myrank,'incorrect message number')
-
- if(myrank == 0) write(IMAIN,*) 'Generating message ',imsg,' for faces out of ',NUMMSGS_FACES
-
-! we know there is the same number of slices in both directions
- iproc_xi_loop = iproc_loop
- iproc_eta_loop = iproc_loop
-
-! take care of local frame inversions between chunks
- iproc_xi_loop_inv = NPROC_ONE_DIRECTION - iproc_loop - 1
- iproc_eta_loop_inv = NPROC_ONE_DIRECTION - iproc_loop - 1
-
-
-! define the 12 different messages
-
-! message type M1
- if(imsg_type_loop == 1) then
-
- if(iside == 1) then
- ichunk_send = CHUNK_AB
- iproc_xi_send = 0
- iproc_eta_send = iproc_eta_loop
- iproc_edge_send = XI_MIN
- ichunk_receive = CHUNK_AC
- iproc_xi_receive = NPROC_XI-1
- iproc_eta_receive = iproc_eta_loop
- iproc_edge_receive = XI_MAX
- endif
-
- if(iside == 2) then
- ichunk_send = CHUNK_AB
- iproc_xi_send = NPROC_XI-1
- iproc_eta_send = iproc_eta_loop
- iproc_edge_send = XI_MAX
- ichunk_receive = CHUNK_AC_ANTIPODE
- iproc_xi_receive = 0
- iproc_eta_receive = iproc_eta_loop
- iproc_edge_receive = XI_MIN
- endif
-
- if(iside == 3) then
- ichunk_send = CHUNK_AC_ANTIPODE
- iproc_xi_send = NPROC_XI-1
- iproc_eta_send = iproc_eta_loop
- iproc_edge_send = XI_MAX
- ichunk_receive = CHUNK_AB_ANTIPODE
- iproc_xi_receive = 0
- iproc_eta_receive = iproc_eta_loop
- iproc_edge_receive = XI_MIN
- endif
-
- if(iside == 4) then
- ichunk_send = CHUNK_AC
- iproc_xi_send = 0
- iproc_eta_send = iproc_eta_loop
- iproc_edge_send = XI_MIN
- ichunk_receive = CHUNK_AB_ANTIPODE
- iproc_xi_receive = NPROC_XI-1
- iproc_eta_receive = iproc_eta_loop
- iproc_edge_receive = XI_MAX
- endif
-
- endif
-
-! message type M2
- if(imsg_type_loop == 2) then
-
- if(iside == 1) then
- ichunk_send = CHUNK_AB
- iproc_xi_send = iproc_xi_loop
- iproc_eta_send = NPROC_ETA-1
- iproc_edge_send = ETA_MAX
- ichunk_receive = CHUNK_BC
- iproc_xi_receive = NPROC_XI-1
- iproc_eta_receive = iproc_eta_loop
- iproc_edge_receive = XI_MAX
- endif
-
- if(iside == 2) then
- ichunk_send = CHUNK_AB
- iproc_xi_send = iproc_xi_loop
- iproc_eta_send = 0
- iproc_edge_send = ETA_MIN
- ichunk_receive = CHUNK_BC_ANTIPODE
- iproc_xi_receive = NPROC_XI-1
- iproc_eta_receive = iproc_eta_loop_inv
- iproc_edge_receive = XI_MAX
- endif
-
- if(iside == 3) then
- ichunk_send = CHUNK_BC
- iproc_xi_send = 0
- iproc_eta_send = iproc_eta_loop
- iproc_edge_send = XI_MIN
- ichunk_receive = CHUNK_AB_ANTIPODE
- iproc_xi_receive = iproc_xi_loop_inv
- iproc_eta_receive = NPROC_ETA-1
- iproc_edge_receive = ETA_MAX
- endif
-
- if(iside == 4) then
- ichunk_send = CHUNK_BC_ANTIPODE
- iproc_xi_send = 0
- iproc_eta_send = iproc_eta_loop
- iproc_edge_send = XI_MIN
- ichunk_receive = CHUNK_AB_ANTIPODE
- iproc_xi_receive = iproc_xi_loop
- iproc_eta_receive = 0
- iproc_edge_receive = ETA_MIN
- endif
-
- endif
-
-! message type M3
- if(imsg_type_loop == 3) then
-
- if(iside == 1) then
- ichunk_send = CHUNK_AC
- iproc_xi_send = iproc_xi_loop
- iproc_eta_send = NPROC_ETA-1
- iproc_edge_send = ETA_MAX
- ichunk_receive = CHUNK_BC
- iproc_xi_receive = iproc_xi_loop
- iproc_eta_receive = 0
- iproc_edge_receive = ETA_MIN
- endif
-
- if(iside == 2) then
- ichunk_send = CHUNK_BC
- iproc_xi_send = iproc_xi_loop
- iproc_eta_send = NPROC_ETA-1
- iproc_edge_send = ETA_MAX
- ichunk_receive = CHUNK_AC_ANTIPODE
- iproc_xi_receive = iproc_xi_loop_inv
- iproc_eta_receive = NPROC_ETA-1
- iproc_edge_receive = ETA_MAX
- endif
-
- if(iside == 3) then
- ichunk_send = CHUNK_AC_ANTIPODE
- iproc_xi_send = iproc_xi_loop
- iproc_eta_send = 0
- iproc_edge_send = ETA_MIN
- ichunk_receive = CHUNK_BC_ANTIPODE
- iproc_xi_receive = iproc_xi_loop_inv
- iproc_eta_receive = 0
- iproc_edge_receive = ETA_MIN
- endif
-
- if(iside == 4) then
- ichunk_send = CHUNK_AC
- iproc_xi_send = iproc_xi_loop
- iproc_eta_send = 0
- iproc_edge_send = ETA_MIN
- ichunk_receive = CHUNK_BC_ANTIPODE
- iproc_xi_receive = iproc_xi_loop
- iproc_eta_receive = NPROC_ETA-1
- iproc_edge_receive = ETA_MAX
- endif
-
- endif
-
-
-! store addressing generated
- iprocfrom_faces(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
- iprocto_faces(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
- imsg_type(imsg) = imsg_type_loop
-
-! check that sender/receiver pair is ordered
- if(iprocfrom_faces(imsg) > iprocto_faces(imsg)) call exit_MPI(myrank,'incorrect order in sender/receiver pair')
-
-! save message type and pair of processors in list of messages
-!!! DK DK for merged if(myrank == 0) write(IOUT,*) imsg_type(imsg),iprocfrom_faces(imsg),iprocto_faces(imsg)
-
-! loop on sender/receiver (1=sender 2=receiver)
- do imode_comm=1,2
-
- if(imode_comm == 1) then
- iproc = iprocfrom_faces(imsg)
- iedge = iproc_edge_send
-!! DK DK commented this out for the merged version
-! write(filename_out,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
-
- else if(imode_comm == 2) then
- iproc = iprocto_faces(imsg)
- iedge = iproc_edge_receive
-!! DK DK commented this out for the merged version
-! write(filename_out,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
-
- else
- call exit_MPI(myrank,'incorrect communication mode')
- endif
-
-! only do this if current processor is the right one for MPI version
- if(iproc == myrank) then
-
-!---------------------------------------------------------------------
-
-!! DK DK added this for the merged version, modified from the old read_arrays_buffers_solver.f90
-!! DK DK the goal here is to determine the right value of icount_faces
-
-!---- read indirect addressing for each message for faces of the chunks
-!---- a given slice can belong to at most two faces
-! check that we have found the right correspondance
- if(imode_comm == 1 .and. myrank /= iprocfrom_faces(imsg)) call exit_MPI(myrank,'this message should be for a sender')
- if(imode_comm == 2 .and. myrank /= iprocto_faces(imsg)) call exit_MPI(myrank,'this message should be for a receiver')
- icount_faces = 0
- do imsg2 = 1,imsg
- if(myrank == iprocfrom_faces(imsg2) .or. myrank == iprocto_faces(imsg2)) then
- icount_faces = icount_faces + 1
- if(icount_faces>NUMFACES_SHARED) call exit_MPI(myrank,'more than NUMFACES_SHARED faces for this slice')
- if(icount_faces>2 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) call exit_MPI(myrank,'more than two faces for this slice')
- endif
- enddo
-
-!---------------------------------------------------------------------
-
-! determine chunk number and local slice coordinates using addressing
- ichunk = ichunk_slice(iproc)
- iproc_xi = iproc_xi_slice(iproc)
- iproc_eta = iproc_eta_slice(iproc)
-
-! problem if not on edges
- if(iproc_xi /= 0 .and. iproc_xi /= NPROC_XI-1 .and. &
- iproc_eta /= 0 .and. iproc_eta /= NPROC_ETA-1) call exit_MPI(myrank,'slice not on any edge')
-
- nglob=nglob_ori
-! check that iboolmax=nglob
-
- if(minval(ibool(:,:,:,1:nspec)) /= 1 .or. maxval(ibool(:,:,:,1:nspec)) /= nglob) &
- call exit_MPI(myrank,ERR_MSG)
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! erase logical mask
- mask_ibool(:) = .false.
-
- npoin2D = 0
-
-! create all the points on each face (no duplicates, but not sorted)
-
-! xmin
- if(iedge == XI_MIN) then
-
-! mark corner points to remove them if needed
- if(iproc_eta == 0) then
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
- mask_ibool(ibool1D_leftxi_lefteta(ipoin1D)) = .true.
- enddo
- endif
-
- if(iproc_eta == NPROC_ETA-1) then
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
- mask_ibool(ibool1D_leftxi_righteta(ipoin1D)) = .true.
- enddo
- endif
-
- do ispec2D=1,nspec2D_xmin
- ispec=ibelm_xmin(ispec2D)
-
-! remove central cube for chunk buffers
- if(iregion_code == IREGION_INNER_CORE) then
- if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
- endif
-
- i=1
- do k=1,NGLLZ
- do j=1,NGLLY
- if(.not. mask_ibool(ibool(i,j,k,ispec))) then
-! mask and store points found
- mask_ibool(ibool(i,j,k,ispec)) = .true.
- npoin2D = npoin2D + 1
- if(npoin2D > NGLOB2DMAX_XMIN_XMAX) call exit_MPI(myrank,'incorrect 2D point number in xmin')
- ibool_selected(npoin2D) = ibool(i,j,k,ispec)
-
- xstore_selected(npoin2D) = xstore(i,j,k,ispec)
- ystore_selected(npoin2D) = ystore(i,j,k,ispec)
- zstore_selected(npoin2D) = zstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
-
-! xmax
- else if(iedge == XI_MAX) then
-
-! mark corner points to remove them if needed
-
- if(iproc_eta == 0) then
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
- mask_ibool(ibool1D_rightxi_lefteta(ipoin1D)) = .true.
- enddo
- endif
-
- if(iproc_eta == NPROC_ETA-1) then
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
- mask_ibool(ibool1D_rightxi_righteta(ipoin1D)) = .true.
- enddo
- endif
-
- do ispec2D=1,nspec2D_xmax
- ispec=ibelm_xmax(ispec2D)
-
-! remove central cube for chunk buffers
- if(iregion_code == IREGION_INNER_CORE) then
- if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
- endif
-
- i=NGLLX
- do k=1,NGLLZ
- do j=1,NGLLY
- if(.not. mask_ibool(ibool(i,j,k,ispec))) then
-! mask and store points found
- mask_ibool(ibool(i,j,k,ispec)) = .true.
- npoin2D = npoin2D + 1
- if(npoin2D > NGLOB2DMAX_XMIN_XMAX) call exit_MPI(myrank,'incorrect 2D point number in xmax')
- ibool_selected(npoin2D) = ibool(i,j,k,ispec)
-
- xstore_selected(npoin2D) = xstore(i,j,k,ispec)
- ystore_selected(npoin2D) = ystore(i,j,k,ispec)
- zstore_selected(npoin2D) = zstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
-
-! ymin
- else if(iedge == ETA_MIN) then
-
-! mark corner points to remove them if needed
-
- if(iproc_xi == 0) then
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
- mask_ibool(ibool1D_leftxi_lefteta(ipoin1D)) = .true.
- enddo
- endif
-
- if(iproc_xi == NPROC_XI-1) then
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
- mask_ibool(ibool1D_rightxi_lefteta(ipoin1D)) = .true.
- enddo
- endif
-
- do ispec2D=1,nspec2D_ymin
- ispec=ibelm_ymin(ispec2D)
-
-! remove central cube for chunk buffers
- if(iregion_code == IREGION_INNER_CORE) then
- if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
- endif
-
- j=1
- do k=1,NGLLZ
- do i=1,NGLLX
- if(.not. mask_ibool(ibool(i,j,k,ispec))) then
-! mask and store points found
- mask_ibool(ibool(i,j,k,ispec)) = .true.
- npoin2D = npoin2D + 1
- if(npoin2D > NGLOB2DMAX_YMIN_YMAX) call exit_MPI(myrank,'incorrect 2D point number in ymin')
- ibool_selected(npoin2D) = ibool(i,j,k,ispec)
-
- xstore_selected(npoin2D) = xstore(i,j,k,ispec)
- ystore_selected(npoin2D) = ystore(i,j,k,ispec)
- zstore_selected(npoin2D) = zstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
-
-! ymax
- else if(iedge == ETA_MAX) then
-
-! mark corner points to remove them if needed
-
- if(iproc_xi == 0) then
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
- mask_ibool(ibool1D_leftxi_righteta(ipoin1D)) = .true.
- enddo
- endif
-
- if(iproc_xi == NPROC_XI-1) then
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
- mask_ibool(ibool1D_rightxi_righteta(ipoin1D)) = .true.
- enddo
- endif
-
- do ispec2D=1,nspec2D_ymax
- ispec=ibelm_ymax(ispec2D)
-
-! remove central cube for chunk buffers
- if(iregion_code == IREGION_INNER_CORE) then
- if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
- endif
-
- j=NGLLY
- do k=1,NGLLZ
- do i=1,NGLLX
- if(.not. mask_ibool(ibool(i,j,k,ispec))) then
-! mask and store points found
- mask_ibool(ibool(i,j,k,ispec)) = .true.
- npoin2D = npoin2D + 1
- if(npoin2D > NGLOB2DMAX_YMIN_YMAX) call exit_MPI(myrank,'incorrect 2D point number in ymax')
- ibool_selected(npoin2D) = ibool(i,j,k,ispec)
-
- xstore_selected(npoin2D) = xstore(i,j,k,ispec)
- ystore_selected(npoin2D) = ystore(i,j,k,ispec)
- zstore_selected(npoin2D) = zstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
-
- else
-
- call exit_MPI(myrank,'incorrect edge code')
- endif
-
-! sort buffer obtained to be conforming with neighbor in other chunk
-! sort on x, y and z, the other arrays will be swapped as well
- call sort_array_coordinates(npoin2D,xstore_selected,ystore_selected,zstore_selected, &
- ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-! check that no duplicate has been detected
- if(nglob /= npoin2D) call exit_MPI(myrank,'duplicates detected in buffer')
-
-! write list of selected points to output buffer
-!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) npoin2D
-
-!! DK DK added this for the merged version
- npoin2D_faces(icount_faces) = npoin2D
-
-!! DK DK suppressed in the merged version do ipoin2D = 1,npoin2D
- do ipoin2D = 1,npoin2D
-!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) ibool_selected(ipoin2D), &
-!! DK DK suppressed in the merged version
-! xstore_selected(ipoin2D),ystore_selected(ipoin2D),zstore_selected(ipoin2D)
-
-!! DK DK added this for the merged version
- iboolfaces(ipoin2D,icount_faces) = ibool_selected(ipoin2D)
-
- enddo
-!! DK DK suppressed in the merged version enddo
-
-!! DK DK suppressed in the merged version close(IOUT_BUFFERS)
-
-! store result to compare number of points for sender and for receiver
- if(imode_comm == 1) then
- npoin2D_send(imsg) = npoin2D
- else
- npoin2D_receive(imsg) = npoin2D
- endif
-
-! end of section done only if right processor for MPI
- endif
-
-! end of loop on sender/receiver
- enddo
-
-! end of loops on all the messages
- enddo
- enddo
- enddo
-
-!!! DK DK for merged if(myrank == 0) close(IOUT)
-
-! check that total number of messages is correct
- if(imsg /= NUMMSGS_FACES) call exit_MPI(myrank,'incorrect total number of messages')
-
-!
-!---- check that number of points detected is the same for sender and receiver
-!
-
-! gather information about all the messages on all processes
- do imsg = 1,NUMMSGS_FACES
-
-! gather number of points for sender
- npoin2D_send_local = npoin2D_send(imsg)
- call MPI_BCAST(npoin2D_send_local,1,MPI_INTEGER,iprocfrom_faces(imsg),MPI_COMM_WORLD,ier)
- if(myrank /= iprocfrom_faces(imsg)) npoin2D_send(imsg) = npoin2D_send_local
-
-! gather number of points for receiver
- npoin2D_receive_local = npoin2D_receive(imsg)
- call MPI_BCAST(npoin2D_receive_local,1,MPI_INTEGER,iprocto_faces(imsg),MPI_COMM_WORLD,ier)
- if(myrank /= iprocto_faces(imsg)) npoin2D_receive(imsg) = npoin2D_receive_local
-
- enddo
-
-! check the number of points
- do imsg = 1,NUMMSGS_FACES
- if(npoin2D_send(imsg) /= npoin2D_receive(imsg)) &
- call exit_MPI(myrank,'incorrect number of points for sender/receiver pair detected')
- enddo
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'all the messages for chunk faces have the right size'
- write(IMAIN,*)
- endif
-
-!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
-!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
-!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
-!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
-!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
-!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
-!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
-
-!
-!---- generate the 8 message patterns sharing a corner of valence 3
-!
-
-! to avoid problem at compile time, use bigger array with fixed dimension
- addressing_big(:,:,:) = 0
- addressing_big(1:NCHUNKS,:,:) = addressing(1:NCHUNKS,:,:)
-
- ichunk = 1
- iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,0,NPROC_ETA-1)
- iprocscorners(2,ichunk) = addressing_big(CHUNK_AC,NPROC_XI-1,NPROC_ETA-1)
-! this line is ok even for NCHUNKS = 2
- iprocscorners(3,ichunk) = addressing_big(CHUNK_BC,NPROC_XI-1,0)
-
- itypecorner(1,ichunk) = ILOWERUPPER
- itypecorner(2,ichunk) = IUPPERUPPER
- itypecorner(3,ichunk) = IUPPERLOWER
-
-!! DK DK UGLY in the future, should also assemble second corner when NCHUNKS = 2
-!! DK DK UGLY for now we only assemble one corner for simplicity
-!! DK DK UGLY formally this is incorrect and should be changed in the future
-!! DK DK UGLY in practice this trick works fine
-
-! this only if more than 3 chunks
- if(NCHUNKS > 3) then
-
- ichunk = 2
- iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,NPROC_XI-1,0)
- iprocscorners(2,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,0,0)
- iprocscorners(3,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,NPROC_XI-1,0)
-
- itypecorner(1,ichunk) = IUPPERLOWER
- itypecorner(2,ichunk) = ILOWERLOWER
- itypecorner(3,ichunk) = IUPPERLOWER
-
- ichunk = 3
- iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,0,0)
- iprocscorners(2,ichunk) = addressing_big(CHUNK_AC,NPROC_XI-1,0)
- iprocscorners(3,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
-
- itypecorner(1,ichunk) = ILOWERLOWER
- itypecorner(2,ichunk) = IUPPERLOWER
- itypecorner(3,ichunk) = IUPPERUPPER
-
- ichunk = 4
- iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,NPROC_XI-1,NPROC_ETA-1)
- iprocscorners(2,ichunk) = addressing_big(CHUNK_BC,NPROC_XI-1,NPROC_ETA-1)
- iprocscorners(3,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,0,NPROC_ETA-1)
-
- itypecorner(1,ichunk) = IUPPERUPPER
- itypecorner(2,ichunk) = IUPPERUPPER
- itypecorner(3,ichunk) = ILOWERUPPER
-
- ichunk = 5
- iprocscorners(1,ichunk) = addressing_big(CHUNK_AC,0,0)
- iprocscorners(2,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,0,NPROC_ETA-1)
- iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,NPROC_XI-1,0)
-
- itypecorner(1,ichunk) = ILOWERLOWER
- itypecorner(2,ichunk) = ILOWERUPPER
- itypecorner(3,ichunk) = IUPPERLOWER
-
- ichunk = 6
- iprocscorners(1,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,NPROC_XI-1,0)
- iprocscorners(2,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,0,0)
- iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,0,0)
-
- itypecorner(1,ichunk) = IUPPERLOWER
- itypecorner(2,ichunk) = ILOWERLOWER
- itypecorner(3,ichunk) = ILOWERLOWER
-
- ichunk = 7
- iprocscorners(1,ichunk) = addressing_big(CHUNK_AC,0,NPROC_ETA-1)
- iprocscorners(2,ichunk) = addressing_big(CHUNK_BC,0,0)
- iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
-
- itypecorner(1,ichunk) = ILOWERUPPER
- itypecorner(2,ichunk) = ILOWERLOWER
- itypecorner(3,ichunk) = IUPPERUPPER
-
- ichunk = 8
- iprocscorners(1,ichunk) = addressing_big(CHUNK_BC,0,NPROC_ETA-1)
- iprocscorners(2,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
- iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,0,NPROC_ETA-1)
-
- itypecorner(1,ichunk) = ILOWERUPPER
- itypecorner(2,ichunk) = IUPPERUPPER
- itypecorner(3,ichunk) = ILOWERUPPER
-
- endif
-
-! loop over all the messages to create the addressing
- do imsg = 1,NCORNERSCHUNKS
-
- if(myrank == 0) write(IMAIN,*) 'Generating message ',imsg,' for corners out of ',NCORNERSCHUNKS
-
-! save triplet of processors in list of messages
-!!! DK DK for merged if(myrank == 0) write(IOUT,*) iprocscorners(1,imsg),iprocscorners(2,imsg),iprocscorners(3,imsg)
-
-! loop on the three processors of a given corner
- do imember_corner = 1,3
-
-! if(imember_corner == 1) then
-! write(filename_out,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
-! else if(imember_corner == 2) then
-! write(filename_out,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
-! else
-! write(filename_out,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
-! endif
-
-! only do this if current processor is the right one for MPI version
-! this line is ok even for NCHUNKS = 2
- if(iprocscorners(imember_corner,imsg) == myrank) then
-
-!---------------------------------------------------------------------
-
-!! DK DK added this for the merged version, modified from the old read_arrays_buffers_solver.f90
-!! DK DK the goal here is to determine the right value of icount_corners
-
-!---- read indirect addressing for each message for corners of the chunks
-!---- a given slice can belong to at most one corner
-! check that we have found the right correspondance
- if(imember_corner == 1 .and. myrank /= iprocscorners(1,imsg)) call exit_MPI(myrank,'this message should be for a master')
- if(imember_corner == 2 .and. myrank /= iprocscorners(2,imsg)) call exit_MPI(myrank,'this message should be for a worker1')
- if(imember_corner == 3 .and. myrank /= iprocscorners(3,imsg)) call exit_MPI(myrank,'this message should be for a worker2')
- icount_corners = 0
- do imsg2 = 1,imsg
- if(myrank == iprocscorners(1,imsg2) .or. &
- myrank == iprocscorners(2,imsg2) .or. &
- myrank == iprocscorners(3,imsg2)) then
- icount_corners = icount_corners + 1
- if(icount_corners>1 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) &
- call exit_MPI(myrank,'more than one corner for this slice')
- if(icount_corners>4) call exit_MPI(myrank,'more than four corners for this slice')
- endif
- enddo
-
-!---- read indirect addressing for each message for faces of the chunks
-!---- a given slice can belong to at most two faces
- if(imode_comm == 1 .and. myrank /= iprocfrom_faces(imsg)) call exit_MPI(myrank,'this message should be for a sender')
- if(imode_comm == 2 .and. myrank /= iprocto_faces(imsg)) call exit_MPI(myrank,'this message should be for a receiver')
-
-!---------------------------------------------------------------------
-
-! pick the correct 1D buffer
-! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
- if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,1)
- else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,4)
- else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,2)
- else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
- NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,3)
- else
- call exit_MPI(myrank,'incorrect corner coordinates')
- endif
-
-! 1D buffer for corner
- do ipoin1D = 1,NGLOB1D_RADIAL_my_corner
-
-!! DK DK added this for merged
-! pick the correct 1D buffer
-! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
- if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
- ibool1D(ipoin1D) = ibool1D_leftxi_lefteta(ipoin1D)
- xread1D(ipoin1D) = xread1D_leftxi_lefteta(ipoin1D)
- yread1D(ipoin1D) = yread1D_leftxi_lefteta(ipoin1D)
- zread1D(ipoin1D) = zread1D_leftxi_lefteta(ipoin1D)
- else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
- ibool1D(ipoin1D) = ibool1D_leftxi_righteta(ipoin1D)
- xread1D(ipoin1D) = xread1D_leftxi_righteta(ipoin1D)
- yread1D(ipoin1D) = yread1D_leftxi_righteta(ipoin1D)
- zread1D(ipoin1D) = zread1D_leftxi_righteta(ipoin1D)
- else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
- ibool1D(ipoin1D) = ibool1D_rightxi_lefteta(ipoin1D)
- xread1D(ipoin1D) = xread1D_rightxi_lefteta(ipoin1D)
- yread1D(ipoin1D) = yread1D_rightxi_lefteta(ipoin1D)
- zread1D(ipoin1D) = zread1D_rightxi_lefteta(ipoin1D)
- else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
- ibool1D(ipoin1D) = ibool1D_rightxi_righteta(ipoin1D)
- xread1D(ipoin1D) = xread1D_rightxi_righteta(ipoin1D)
- yread1D(ipoin1D) = yread1D_rightxi_righteta(ipoin1D)
- zread1D(ipoin1D) = zread1D_rightxi_righteta(ipoin1D)
- else
- call exit_MPI(myrank,'incorrect corner coordinates')
- endif
-
- enddo
-!! DK DK suppressed in the merged version close(IIN)
-
-! sort array read based upon the coordinates of the points
-! to ensure conforming matching with other buffers from neighbors
- call sort_array_coordinates(NGLOB1D_RADIAL_my_corner,xread1D,yread1D,zread1D, &
- ibool1D,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-
-! check that no duplicates have been found
- if(nglob /= NGLOB1D_RADIAL_my_corner) call exit_MPI(myrank,'duplicates found for corners')
-
-! 1D buffer for corner
- do ipoin1D = 1,NGLOB1D_RADIAL_my_corner
-!! DK DK added this for merged version
- iboolcorner(ipoin1D,icount_corners) = ibool1D(ipoin1D)
- enddo
-
-! end of section done only if right processor for MPI
- endif
-
- enddo
-
- enddo
-
-! save arrays in a slightly different format for historical reasons
- iproc_master_corners(:) = iprocscorners(1,:)
- iproc_worker1_corners(:) = iprocscorners(2,:)
- iproc_worker2_corners(:) = iprocscorners(3,:)
-
- end subroutine create_chunk_buffers
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,1499 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_regions_mesh(iregion_code,ibool,idoubling,xstore,ystore,zstore,rmins,rmaxs,iproc_xi,iproc_eta,ichunk,nspec, &
+ nspec_tiso,volume_local,area_local_bottom,area_local_top,nspl,rspl,espl,espl2,nglob_theor,npointot,NEX_XI,NEX_PER_PROC_XI, &
+ NEX_PER_PROC_ETA,NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP,ELLIPTICITY,TOPOGRAPHY, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST,NPROC_XI,NPROC_ETA, &
+ myrank,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,ATTENUATION,ATTENUATION_3D,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL,R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,ner,ratio_sampling_array,doubling_index,r_bottom,r_top, &
+ this_layer_has_a_doubling,CASE_3D,AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ offset_proc_xi,offset_proc_eta,nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,ibelm_xmin,ibelm_xmax,ibelm_ymin, &
+ ibelm_ymax,ibelm_bottom,ibelm_top,jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom, &
+ jacobian2D_top,normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top,kappavstore,kappahstore,muvstore, &
+ muhstore,eta_anisostore,rmass,xelm_store,yelm_store,zelm_store,xigll,wxgll,yigll,wygll,zigll,wzgll,shape3D,dershape3D, &
+ shape2D_x,shape2D_y,shape2D_bottom,shape2D_top,dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top,rhostore_local, &
+ kappavstore_local,c11store,c12store,c13store,c14store,c15store,c16store,c22store,c23store,c24store,c25store,c26store, &
+ c33store,c34store,c35store,c36store,c44store,c45store,c46store,c55store,c56store,c66store,iboun,locval,ifseg,xp,yp,zp, &
+ rmass_ocean_load,mask_ibool,copy_ibool_ori,iMPIcut_xi,iMPIcut_eta, &
+#ifdef USE_MPI
+ NGLOB1D_RADIAL_MAX,NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,NGLOB2DMAX_XMIN_XMAX, &
+ NGLOB2DMAX_YMIN_YMAX,npoin2D_xi,npoin2D_eta,iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta,ibool1D_leftxi_lefteta, &
+ ibool1D_rightxi_lefteta,ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,xread1D_leftxi_lefteta,xread1D_rightxi_lefteta, &
+ xread1D_leftxi_righteta,xread1D_rightxi_righteta,yread1D_leftxi_lefteta,yread1D_rightxi_lefteta,yread1D_leftxi_righteta, &
+ yread1D_rightxi_righteta,zread1D_leftxi_lefteta,zread1D_rightxi_lefteta,zread1D_leftxi_righteta,zread1D_rightxi_righteta, &
+#endif
+ rho_vp,rho_vs,Qmu_store,tau_e_store,ifirst_layer_aniso,ilast_layer_aniso)
+
+! create the different regions of the mesh
+
+ implicit none
+
+#ifdef USE_MPI
+ include "mpif.h"
+#endif
+ include "constants.h"
+
+!! DK DK for the merged version
+! include values created by the mesher
+ include "values_from_mesher.h"
+
+!! DK DK added this for merged version
+#ifdef USE_MPI
+ integer :: npoin2D_xi,npoin2D_eta
+#endif
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(nglob_theor) :: rmass
+
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
+
+! the jacobian
+ real(kind=CUSTOM_REAL) jacobianl
+
+!! DK DK changed this for merged version: made it local
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+!! DK DK added this for merged version
+ logical :: add_contrib_this_element
+
+#ifdef USE_MPI
+!! DK DK for merged version
+ integer :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+
+!! DK DK added this for merged version
+ integer :: NGLOB1D_RADIAL_MAX
+ double precision, dimension(NGLOB1D_RADIAL_MAX) :: &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta
+
+ integer ibool1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_leftxi_righteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_rightxi_righteta(NGLOB1D_RADIAL_MAX)
+
+! this to cut the doubling brick
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
+#endif
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer :: step_mult,offset_proc_xi,offset_proc_eta
+ integer :: case_xi,case_eta,subblock_num
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_layer_has_a_doubling
+
+ integer :: ignod,ner_without_doubling,ispec_superbrick,ilayer,ilayer_loop,ix_elem,iy_elem,iz_elem, &
+ ifirst_layer,ilast_layer,ratio_divide_central_cube
+
+! allocate this automatic array in the memory stack to avoid memory fragmentation with "allocate()"
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: permutation_layer
+
+! mesh doubling superbrick
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+! correct number of spectral elements in each block depending on chunk type
+ integer nspec,nspec_tiso,nspec_stacey
+
+ integer NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
+
+ integer NPROC_XI,NPROC_ETA
+
+ integer npointot
+
+ logical ELLIPTICITY,TOPOGRAPHY
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST,OCEANS
+
+ logical ATTENUATION,ATTENUATION_3D,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
+
+ double precision R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+ character(len=150) errmsg
+
+! use integer array to store values
+ integer ibathy_topo(NX_BATHY,NY_BATHY)
+
+! arrays with the mesh in double precision
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! meshing parameters
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! to define the central cube in the inner core
+ integer nx_central_cube,ny_central_cube,nz_central_cube
+ double precision radius_cube
+ double precision :: xgrid_central_cube,ygrid_central_cube,zgrid_central_cube
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+! auxiliary variables to generate the mesh
+ integer ix,iy,iz
+
+! topology of the elements
+ integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
+
+! code for the four regions of the mesh
+ integer iregion_code
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll,wxgll
+ double precision, dimension(NGLLY) :: yigll,wygll
+ double precision, dimension(NGLLZ) :: zigll,wzgll
+
+! 3D shape functions and their derivatives
+ double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
+ double precision, dimension(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ) :: dershape3D
+
+! 2D shape functions and their derivatives
+ double precision shape2D_x(NGNOD2D,NGLLY,NGLLZ)
+ double precision shape2D_y(NGNOD2D,NGLLX,NGLLZ)
+ double precision shape2D_bottom(NGNOD2D,NGLLX,NGLLY)
+ double precision shape2D_top(NGNOD2D,NGLLX,NGLLY)
+
+ double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ)
+ double precision dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
+ double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+ double precision dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+!! DK DK added this for merged version
+!! DK DK stored in single precision for merged version, check if it precise enough (probably yes)
+ real(kind=CUSTOM_REAL), dimension(NGNOD,nspec) :: xelm_store,yelm_store,zelm_store
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm,offset_x,offset_y,offset_z
+
+ integer idoubling(nspec)
+
+! parameters needed to store the radii of the grid points in the spherically symmetric Earth
+ double precision :: rmin,rmax
+
+! for model density and anisotropy
+ integer nspec_ani
+
+!! DK DK changed this for the merged version
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: rhostore_local,kappavstore_local
+
+!! DK DK added this for merged version
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store
+
+! boundary locator
+ logical, dimension(6,nspec) :: iboun
+
+! proc numbers for MPI
+ integer myrank
+
+! check area and volume of the final mesh
+ double precision weight
+ double precision area_local_bottom,area_local_top
+ double precision volume_local
+
+! variables for creating array ibool (some arrays also used for AVS or DX files)
+ integer, dimension(npointot) :: locval
+ logical, dimension(npointot) :: ifseg
+ double precision, dimension(npointot) :: xp,yp,zp
+
+ integer :: nglob,nglob_theor,ieoff,ilocnum,ier
+#ifdef USE_MPI
+ integer :: errorcode
+#endif
+
+! mass matrix and bathymetry for ocean load
+ integer ix_oceans,iy_oceans,iz_oceans,ispec_oceans
+ integer ispec2D_top_crust
+ integer nglob_oceans
+ double precision xval,yval,zval,rval,thetaval,phival
+ double precision lat,lon,colat
+ double precision elevation,height_oceans
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
+
+! mask to sort ibool
+ integer :: inumber
+ integer, dimension(nglob_theor) :: mask_ibool
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: copy_ibool_ori
+
+! boundary parameters locator
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX) :: ibelm_xmin,ibelm_xmax
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX) :: ibelm_ymin,ibelm_ymax
+ integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
+ integer, dimension(NSPEC2D_TOP) :: ibelm_top
+
+! MPI cut-planes parameters along xi and along eta
+ logical, dimension(2,nspec) :: iMPIcut_xi,iMPIcut_eta
+
+! Stacey indices for Clayton-Engquist absorbing conditions
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: rho_vp,rho_vs
+
+! number of elements on the boundaries
+ integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
+
+ integer i,j,k,ia,ispec,iglobnum
+ integer iproc_xi,iproc_eta,ichunk
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+! attenuation
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: Qmu_store
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: tau_e_store
+ double precision, dimension(N_SLS) :: tau_s
+ double precision T_c_source
+
+! **************
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
+ logical :: USE_ONE_LAYER_SB,CASE_3D
+ integer :: nspec_sb
+
+ integer NUMBER_OF_MESH_LAYERS,layer_shift,ifirst_layer_aniso,ilast_layer_aniso
+ double precision, dimension(:,:), allocatable :: stretch_tab
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=40) varstr(maxker)
+
+! to perform two passes of the whole routine to be able to save memory
+ integer :: ipass
+
+! the height at which the central cube is cut
+ integer :: nz_inf_limit
+
+!! DK DK added this for the merged version
+! 2-D jacobians and normals
+ real(kind=CUSTOM_REAL) :: jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) :: jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) :: jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) :: jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) :: jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM)
+ real(kind=CUSTOM_REAL) :: jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
+
+ real(kind=CUSTOM_REAL) :: normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) :: normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) :: normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) :: normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) :: normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM)
+ real(kind=CUSTOM_REAL) :: normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
+
+! perform two passes of the whole routine to be able to save memory
+ do ipass = 1,2
+
+! attenuation
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ T_c_source = AM_V%QT_c_source
+ tau_s(:) = AM_V%Qtau_s(:)
+ else
+ Qmu_store(1,1,1,1) = 0.0d0
+ tau_e_store(:,1,1,1,1) = 0.0d0
+ endif
+
+! Stacey
+ if(NCHUNKS /= 6) then
+ nspec_stacey = nspec
+ else
+ nspec_stacey = 1
+ endif
+
+! anisotropy
+ nspec_ani = 1
+ if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
+ (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) nspec_ani = nspec
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly zero
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! get the 3-D shape functions
+ call get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
+
+! get the 2-D shape functions
+ call get_shape2D(myrank,shape2D_x,dershape2D_x,yigll,zigll,NGLLY,NGLLZ)
+ call get_shape2D(myrank,shape2D_y,dershape2D_y,xigll,zigll,NGLLX,NGLLZ)
+ call get_shape2D(myrank,shape2D_bottom,dershape2D_bottom,xigll,yigll,NGLLX,NGLLY)
+ call get_shape2D(myrank,shape2D_top,dershape2D_top,xigll,yigll,NGLLX,NGLLY)
+
+! define models 1066a and ak135 and ref
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ call define_model_1066a(CRUSTAL, M1066a_V)
+ elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ call define_model_ak135(CRUSTAL, Mak135_V)
+ elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call define_model_ref(Mref_V)
+ elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ call define_model_sea1d(CRUSTAL, SEA1DM_V)
+ endif
+
+!------------------------------------------------------------------------
+
+! create the shape of the corner nodes of a regular mesh element
+ call hex_nodes(iaddx,iaddy,iaddz)
+
+! reference element has size one here, not two
+ iaddx(:) = iaddx(:) / 2
+ iaddy(:) = iaddy(:) / 2
+ iaddz(:) = iaddz(:) / 2
+
+ if (ONE_CRUST) then
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS - 1
+ layer_shift = 0
+ else
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS
+ layer_shift = 1
+ endif
+
+ if (.not. ADD_4TH_DOUBLING) NUMBER_OF_MESH_LAYERS = NUMBER_OF_MESH_LAYERS - 1
+
+! define the first and last layers that define this region
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ ifirst_layer = 1
+ ilast_layer = 10 + layer_shift
+
+ else if(iregion_code == IREGION_OUTER_CORE) then
+ ifirst_layer = 11 + layer_shift
+ ilast_layer = NUMBER_OF_MESH_LAYERS - 1
+
+ else if(iregion_code == IREGION_INNER_CORE) then
+ ifirst_layer = NUMBER_OF_MESH_LAYERS
+ ilast_layer = NUMBER_OF_MESH_LAYERS
+
+ else
+ call exit_MPI(myrank,'incorrect region code detected')
+
+ endif
+
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+
+! create anisotropic (transversely isotropic) layers first to save memory when
+! storing the anisotropic arrays
+ ilayer = 0
+ do ilayer_loop = ifirst_layer_aniso,ilast_layer_aniso
+ ilayer = ilayer + 1
+ permutation_layer(ilayer) = ilayer_loop
+ enddo
+
+! and then create all the isotropic layers
+ do ilayer_loop = ifirst_layer,ilast_layer
+ if(ilayer_loop < ifirst_layer_aniso .or. ilayer_loop > ilast_layer_aniso) then
+ ilayer = ilayer + 1
+ permutation_layer(ilayer) = ilayer_loop
+ endif
+ enddo
+
+ else
+
+! use identity permutation for regions that do not have transversely isotropic layer
+ do ilayer_loop = ifirst_layer,ilast_layer
+ permutation_layer(ilayer_loop) = ilayer_loop
+ enddo
+
+ endif
+
+! initialize mesh arrays
+!! DK DK merged version: we exclude the outer core because the doubling array is useless there and therefore not allocated
+ if(iregion_code /= IREGION_OUTER_CORE) idoubling(:) = 0
+
+ xstore(:,:,:,:) = 0.d0
+ ystore(:,:,:,:) = 0.d0
+ zstore(:,:,:,:) = 0.d0
+
+ if(ipass == 1) ibool(:,:,:,:) = 0
+
+! initialize boundary arrays
+ iboun(:,:) = .false.
+ iMPIcut_xi(:,:) = .false.
+ iMPIcut_eta(:,:) = .false.
+
+!! DK DK added this for merged version
+! creating mass matrix in this slice (will be fully assembled in the solver)
+ if(ipass == 2) rmass(:) = 0._CUSTOM_REAL
+
+ if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
+ allocate(stretch_tab(2,ner(1)),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+#ifdef USE_MPI
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+#else
+ stop 'fatal error'
+#endif
+ endif
+
+ call stretching_function(r_top(1),r_bottom(1),ner(1),stretch_tab)
+ endif
+
+! generate and count all the elements in this region of the mesh
+ ispec = 0
+
+! loop on all the layers in this region of the mesh
+ do ilayer_loop = ifirst_layer,ilast_layer
+
+ ilayer = permutation_layer(ilayer_loop)
+
+! determine the radii that define the shell
+ rmin = rmins(ilayer)
+ rmax = rmaxs(ilayer)
+
+ ner_without_doubling = ner(ilayer)
+
+! if there is a doubling at the top of this region, we implement it in the last two layers of elements
+! and therefore we suppress two layers of regular elements here
+ USE_ONE_LAYER_SB = .false.
+ if(this_layer_has_a_doubling(ilayer)) then
+ if (ner(ilayer) == 1) then
+ ner_without_doubling = ner_without_doubling - 1
+ USE_ONE_LAYER_SB = .true.
+ else
+ ner_without_doubling = ner_without_doubling - 2
+ USE_ONE_LAYER_SB = .false.
+ endif
+ endif
+
+!----
+!---- regular mesh elements
+!----
+
+! loop on all the elements
+ do ix_elem = 1,NEX_PER_PROC_XI,ratio_sampling_array(ilayer)
+ do iy_elem = 1,NEX_PER_PROC_ETA,ratio_sampling_array(ilayer)
+ do iz_elem = 1,ner_without_doubling
+! loop on all the corner nodes of this element
+ do ignod = 1,NGNOD_EIGHT_CORNERS
+! define topological coordinates of this mesh point
+ offset_x(ignod) = (ix_elem - 1) + iaddx(ignod) * ratio_sampling_array(ilayer)
+ offset_y(ignod) = (iy_elem - 1) + iaddy(ignod) * ratio_sampling_array(ilayer)
+ if (ilayer == 1 .and. CASE_3D) then
+ offset_z(ignod) = iaddz(ignod)
+ else
+ offset_z(ignod) = (iz_elem - 1) + iaddz(ignod)
+ endif
+ enddo
+ call add_missing_nodes(offset_x,offset_y,offset_z)
+
+! compute the actual position of all the grid points of that element
+ if (ilayer == 1 .and. CASE_3D .and. .not. SUPPRESS_CRUSTAL_MESH) then
+! crustal elements are stretched to be thinner in the upper crust than in lower crust in the 3D case
+! max ratio between size of upper crust elements and lower crust elements is given by the param MAX_RATIO_STRETCHING
+! to avoid stretching, set MAX_RATIO_STRETCHING = 1.0d in constants.h
+ call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ stretch_tab(1,ner_without_doubling-iz_elem+1),&
+ stretch_tab(2,ner_without_doubling-iz_elem+1),1,ilayer,ichunk,rotation_matrix, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+ else
+ call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ r_top(ilayer),r_bottom(ilayer),ner(ilayer),ilayer,ichunk,rotation_matrix, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+ endif
+! add one spectral element to the list
+ ispec = ispec + 1
+ if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation')
+
+! new get_flag_boundaries
+! xmin & xmax
+ if (ix_elem == 1) then
+ iMPIcut_xi(1,ispec) = .true.
+ if (iproc_xi == 0) iboun(1,ispec)= .true.
+ endif
+ if (ix_elem == (NEX_PER_PROC_XI-ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_xi(2,ispec) = .true.
+ if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= .true.
+ endif
+! ymin & ymax
+ if (iy_elem == 1) then
+ iMPIcut_eta(1,ispec) = .true.
+ if (iproc_eta == 0) iboun(3,ispec)= .true.
+ endif
+ if (iy_elem == (NEX_PER_PROC_ETA-ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_eta(2,ispec) = .true.
+ if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= .true.
+ endif
+! zmin & zmax
+ if (iz_elem == ner(ilayer) .and. ilayer == ifirst_layer) then
+ iboun(6,ispec)= .true.
+ endif
+ if (iz_elem == 1 .and. ilayer == ilast_layer) then ! defined if no doubling in this layer
+ iboun(5,ispec)= .true.
+ endif
+
+! define the doubling flag of this element
+ if(iregion_code /= IREGION_OUTER_CORE) idoubling(ispec) = doubling_index(ilayer)
+
+! compute several rheological and geometrical properties for this spectral element
+ call compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore_local,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,tau_s,T_c_source,rho_vp,rho_vs,&
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+!! DK DK added this for merged version
+ include "comp_mass_matrix_one_element.f90"
+ include "store_xelm_yelm_zelm.f90"
+
+! end of loop on all the regular elements
+ enddo
+ enddo
+ enddo
+
+!----
+!---- mesh doubling elements
+!----
+
+! If there is a doubling at the top of this region, let us add these elements.
+! The superbrick implements a symmetric four-to-two doubling and therefore replaces
+! a basic regular block of 2 x 2 = 4 elements.
+! We have imposed that NEX be a multiple of 16 therefore we know that we can always create
+! these 2 x 2 blocks because NEX_PER_PROC_XI / ratio_sampling_array(ilayer) and
+! NEX_PER_PROC_ETA / ratio_sampling_array(ilayer) are always divisible by 2.
+ if(this_layer_has_a_doubling(ilayer)) then
+ if (USE_ONE_LAYER_SB) then
+ call define_superbrick_one_layer(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
+ nspec_sb = NSPEC_SUPERBRICK_1L
+ iz_elem = ner(ilayer)
+ step_mult = 2
+ else
+ if(iregion_code==IREGION_OUTER_CORE .and. ilayer==ilast_layer .and. (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
+ nspec_sb = NSPEC_DOUBLING_BASICBRICK
+ step_mult = 1
+ else
+ call define_superbrick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
+ nspec_sb = NSPEC_DOUBLING_SUPERBRICK
+ step_mult = 2
+ endif
+! the doubling is implemented in the last two radial elements
+! therefore we start one element before the last one
+ iz_elem = ner(ilayer) - 1
+ endif
+
+! loop on all the elements in the 2 x 2 blocks
+ do ix_elem = 1,NEX_PER_PROC_XI,step_mult*ratio_sampling_array(ilayer)
+ do iy_elem = 1,NEX_PER_PROC_ETA,step_mult*ratio_sampling_array(ilayer)
+
+ if (step_mult == 1) then
+! for xi direction
+ if (.not. CUT_SUPERBRICK_XI) then
+ if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_xi = 1
+ else
+ case_xi = 2
+ endif
+ else
+ if (offset_proc_xi == 0) then
+ if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_xi = 1
+ else
+ case_xi = 2
+ endif
+ else
+ if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))/=0) then
+ case_xi = 1
+ else
+ case_xi = 2
+ endif
+ endif
+ endif
+! for eta direction
+ if (.not. CUT_SUPERBRICK_ETA) then
+ if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_eta = 1
+ else
+ case_eta = 2
+ endif
+ else
+ if (offset_proc_eta == 0) then
+ if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_eta = 1
+ else
+ case_eta = 2
+ endif
+ else
+ if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))/=0) then
+ case_eta = 1
+ else
+ case_eta = 2
+ endif
+ endif
+ endif
+! determine the current sub-block
+ if (case_xi == 1) then
+ if (case_eta == 1) then
+ subblock_num = 1
+ else
+ subblock_num = 2
+ endif
+ else
+ if (case_eta == 1) then
+ subblock_num = 3
+ else
+ subblock_num = 4
+ endif
+ endif
+! then define the geometry for this sub-block
+ call define_basic_doubling_brick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb,subblock_num)
+ endif
+! loop on all the elements in the mesh doubling superbrick
+ do ispec_superbrick = 1,nspec_sb
+! loop on all the corner nodes of this element
+ do ignod = 1,NGNOD_EIGHT_CORNERS
+
+! define topological coordinates of this mesh point
+ offset_x(ignod) = (ix_elem - 1) + &
+ x_superbrick(ibool_superbrick(ignod,ispec_superbrick)) * ratio_sampling_array(ilayer)
+ offset_y(ignod) = (iy_elem - 1) + &
+ y_superbrick(ibool_superbrick(ignod,ispec_superbrick)) * ratio_sampling_array(ilayer)
+ offset_z(ignod) = (iz_elem - 1) + &
+ z_superbrick(ibool_superbrick(ignod,ispec_superbrick))
+
+ enddo
+! the rest of the 27 nodes are missing, therefore add them
+ call add_missing_nodes(offset_x,offset_y,offset_z)
+
+! compute the actual position of all the grid points of that element
+ call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ r_top(ilayer),r_bottom(ilayer),ner(ilayer),ilayer,ichunk,rotation_matrix, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+
+! add one spectral element to the list
+ ispec = ispec + 1
+ if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation')
+
+! new get_flag_boundaries
+
+! xmin and xmax
+ if (ix_elem == 1) then
+ iMPIcut_xi(1,ispec) = iboun_sb(ispec_superbrick,1)
+ if (iproc_xi == 0) iboun(1,ispec)= iboun_sb(ispec_superbrick,1)
+ endif
+ if (ix_elem == (NEX_PER_PROC_XI-step_mult*ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_xi(2,ispec) = iboun_sb(ispec_superbrick,2)
+ if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= iboun_sb(ispec_superbrick,2)
+ endif
+
+! ymin and ymax
+ if (iy_elem == 1) then
+ iMPIcut_eta(1,ispec) = iboun_sb(ispec_superbrick,3)
+ if (iproc_eta == 0) iboun(3,ispec)= iboun_sb(ispec_superbrick,3)
+ endif
+ if (iy_elem == (NEX_PER_PROC_ETA-step_mult*ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_eta(2,ispec) = iboun_sb(ispec_superbrick,4)
+ if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= iboun_sb(ispec_superbrick,4)
+ endif
+
+! zmax only
+ if (ilayer==ifirst_layer) iboun(6,ispec)= iboun_sb(ispec_superbrick,6)
+ if (ilayer==ilast_layer .and. iz_elem==1) iboun(5,ispec)= iboun_sb(ispec_superbrick,5)
+
+! define the doubling flag of this element
+ if(iregion_code /= IREGION_OUTER_CORE) idoubling(ispec) = doubling_index(ilayer)
+
+! compute several rheological and geometrical properties for this spectral element
+ call compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore_local,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,tau_s,T_c_source,rho_vp,rho_vs,&
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+!! DK DK added this for merged version
+ include "comp_mass_matrix_one_element.f90"
+ include "store_xelm_yelm_zelm.f90"
+
+! end of loops on the mesh doubling elements
+ enddo
+ enddo
+ enddo
+ endif
+
+! end of loop on all the layers of the mesh
+ enddo
+
+ if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
+ deallocate(stretch_tab,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate stretch_tab in create_regions_mesh ier=",ier
+ stop 'error in deallocate'
+ endif
+ endif
+
+!---
+
+! define central cube in inner core
+
+ if(INCLUDE_CENTRAL_CUBE .and. iregion_code == IREGION_INNER_CORE) then
+
+! create the shape of a regular mesh element in the inner core
+ call hex_nodes(iaddx,iaddy,iaddz)
+
+! define vertical slice in central cube on current processor
+! we can assume that NEX_XI = NEX_ETA, otherwise central cube cannot be defined
+ nx_central_cube = NEX_PER_PROC_XI / ratio_divide_central_cube
+ ny_central_cube = NEX_PER_PROC_ETA / ratio_divide_central_cube
+ nz_central_cube = NEX_XI / ratio_divide_central_cube
+
+! size of the cube along cartesian axes before rotation
+ radius_cube = (R_CENTRAL_CUBE / R_EARTH) / sqrt(3.d0)
+
+! define spectral elements in central cube
+ do iz = 0,2*nz_central_cube-2,2
+ do iy = 0,2*ny_central_cube-2,2
+ do ix = 0,2*nx_central_cube-2,2
+
+! radii that define the shell, we know that we are in the central cube
+ rmin = 0.d0
+ rmax = R_CENTRAL_CUBE / R_EARTH
+
+! loop over the NGNOD nodes
+ do ia=1,NGNOD
+
+! flat cubed sphere with correct mapping
+ call compute_coord_central_cube(ix+iaddx(ia),iy+iaddy(ia),iz+iaddz(ia), &
+ xgrid_central_cube,ygrid_central_cube,zgrid_central_cube, &
+ iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,nx_central_cube,ny_central_cube,nz_central_cube,radius_cube)
+
+ if(ichunk == CHUNK_AB) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = + xgrid_central_cube
+ zelm(ia) = + zgrid_central_cube
+
+ else if(ichunk == CHUNK_AB_ANTIPODE) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = - xgrid_central_cube
+ zelm(ia) = - zgrid_central_cube
+
+ else if(ichunk == CHUNK_AC) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = - zgrid_central_cube
+ zelm(ia) = + xgrid_central_cube
+
+ else if(ichunk == CHUNK_AC_ANTIPODE) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = + zgrid_central_cube
+ zelm(ia) = - xgrid_central_cube
+
+ else if(ichunk == CHUNK_BC) then
+ xelm(ia) = - zgrid_central_cube
+ yelm(ia) = + ygrid_central_cube
+ zelm(ia) = + xgrid_central_cube
+
+ else if(ichunk == CHUNK_BC_ANTIPODE) then
+ xelm(ia) = + zgrid_central_cube
+ yelm(ia) = - ygrid_central_cube
+ zelm(ia) = + xgrid_central_cube
+
+ else
+ call exit_MPI(myrank,'wrong chunk number in flat cubed sphere definition')
+ endif
+
+ enddo
+
+! add one spectral element to the list
+ ispec = ispec + 1
+ if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in central cube creation')
+
+! new get_flag_boundaries
+! xmin & xmax
+ if (ix == 0) then
+ iMPIcut_xi(1,ispec) = .true.
+ if (iproc_xi == 0) iboun(1,ispec)= .true.
+ endif
+ if (ix == 2*nx_central_cube-2) then
+ iMPIcut_xi(2,ispec) = .true.
+ if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= .true.
+ endif
+! ymin & ymax
+ if (iy == 0) then
+ iMPIcut_eta(1,ispec) = .true.
+ if (iproc_eta == 0) iboun(3,ispec)= .true.
+ endif
+ if (iy == 2*ny_central_cube-2) then
+ iMPIcut_eta(2,ispec) = .true.
+ if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= .true.
+ endif
+
+! define the doubling flag of this element
+! only two active central cubes, the four others are fictitious
+
+! determine where we cut the central cube to share it between CHUNK_AB & CHUNK_AB_ANTIPODE
+! in the case of mod(NPROC_XI,2)/=0, the cut is asymetric and the bigger part is for CHUNK_AB
+ if (mod(NPROC_XI,2)/=0) then
+ if (ichunk == CHUNK_AB) then
+ nz_inf_limit = ((nz_central_cube*2)/NPROC_XI)*floor(NPROC_XI/2.d0)
+ elseif (ichunk == CHUNK_AB_ANTIPODE) then
+ nz_inf_limit = ((nz_central_cube*2)/NPROC_XI)*ceiling(NPROC_XI/2.d0)
+ endif
+ else
+ nz_inf_limit = nz_central_cube
+ endif
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+ if(iz == nz_inf_limit) then
+ idoubling(ispec) = IFLAG_BOTTOM_CENTRAL_CUBE
+ else if(iz == 2*nz_central_cube-2) then
+ idoubling(ispec) = IFLAG_TOP_CENTRAL_CUBE
+ else if (iz > nz_inf_limit .and. iz < 2*nz_central_cube-2) then
+ idoubling(ispec) = IFLAG_MIDDLE_CENTRAL_CUBE
+ else
+ idoubling(ispec) = IFLAG_IN_FICTITIOUS_CUBE
+ endif
+ else
+ idoubling(ispec) = IFLAG_IN_FICTITIOUS_CUBE
+ endif
+
+
+! compute several rheological and geometrical properties for this spectral element
+ call compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore_local,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,tau_s,T_c_source,rho_vp,rho_vs,&
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+!! DK DK added this for merged version
+ include "comp_mass_matrix_one_element.f90"
+ include "store_xelm_yelm_zelm.f90"
+
+ enddo
+ enddo
+ enddo
+
+ endif ! end of definition of central cube in inner core
+
+!---
+
+! check total number of spectral elements created
+ if(ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec')
+
+! only create global addressing and the MPI buffers in the first pass
+ if(ipass == 1) then
+
+ locval = 0
+ ifseg = .false.
+ xp = 0.d0
+ yp = 0.d0
+ zp = 0.d0
+
+ ! we need to create a copy of the x, y and z arrays because sorting in get_global will swap
+ ! these arrays and therefore destroy them
+ do ispec=1,nspec
+ ieoff = NGLLX * NGLLY * NGLLZ * (ispec-1)
+ ilocnum = 0
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ilocnum = ilocnum + 1
+ xp(ilocnum+ieoff) = xstore(i,j,k,ispec)
+ yp(ilocnum+ieoff) = ystore(i,j,k,ispec)
+ zp(ilocnum+ieoff) = zstore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ call get_global(nspec,xp,yp,zp,ibool,locval,ifseg,nglob,npointot)
+
+ ! check that number of points found equals theoretical value
+ if(nglob /= nglob_theor) then
+ write(errmsg,*) 'incorrect total number of points found: myrank,nglob,nglob_theor,ipass,iregion_code = ',&
+ myrank,nglob,nglob_theor,ipass,iregion_code
+ call exit_MPI(myrank,errmsg)
+ endif
+
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering')
+
+! create a new indirect addressing to reduce cache misses in memory access in the solver
+! this is *critical* to improve performance in the solver
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:)
+
+ inumber = 0
+ do ispec=1,nspec
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if(mask_ibool(copy_ibool_ori(i,j,k,ispec)) == -1) then
+ ! create a new point
+ inumber = inumber + 1
+ ibool(i,j,k,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,k,ispec)) = inumber
+ else
+ ! use an existing point created previously
+ ibool(i,j,k,ispec) = mask_ibool(copy_ibool_ori(i,j,k,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering after sorting')
+
+! create MPI buffers
+! arrays locval(npointot) and ifseg(npointot) used to save memory
+#ifdef USE_MPI
+ call get_MPI_cutplanes_xi(myrank,nspec,iMPIcut_xi,ibool, &
+ ifseg,npointot, &
+ NSPEC2D_ETA_FACE,iregion_code,nglob,iboolleft_xi,iboolright_xi,NGLOB2DMAX_XMIN_XMAX,npoin2D_xi)
+
+ call get_MPI_cutplanes_eta(myrank,nspec,iMPIcut_eta,ibool, &
+ ifseg,npointot, &
+ NSPEC2D_XI_FACE,iregion_code,nglob,iboolleft_eta,iboolright_eta,NGLOB2DMAX_YMIN_YMAX,npoin2D_eta)
+
+ call get_MPI_1D_buffers(myrank,nspec,iMPIcut_xi,iMPIcut_eta,ibool,idoubling, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion_code,nglob, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,NGLOB1D_RADIAL_MAX, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iregion_code)
+#endif
+
+! only create mass matrix and save all the final arrays in the second pass
+ else if(ipass == 2) then
+
+! copy the theoretical number of points for the second pass
+ nglob = nglob_theor
+
+! count number of anisotropic elements in current region
+! should be zero in all the regions except in the mantle
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ nspec_tiso = count(idoubling(1:nspec) == IFLAG_220_80) + count(idoubling(1:nspec) == IFLAG_80_MOHO)
+ else
+ nspec_tiso = 0
+ endif
+
+ call get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ jacobian2D_xmin,jacobian2D_xmax, &
+ jacobian2D_ymin,jacobian2D_ymax, &
+ jacobian2D_bottom,jacobian2D_top, &
+ normal_xmin,normal_xmax, &
+ normal_ymin,normal_ymax, &
+ normal_bottom,normal_top, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
+
+! save the binary files
+! save ocean load mass matrix as well if oceans
+ if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
+
+! adding ocean load mass matrix at the top of the crust for oceans
+ nglob_oceans = nglob
+
+! create ocean load mass matrix for degrees of freedom at ocean bottom
+ rmass_ocean_load(:) = 0._CUSTOM_REAL
+
+! add contribution of the oceans
+! for surface elements exactly at the top of the crust (ocean bottom)
+ do ispec2D_top_crust = 1,NSPEC2D_TOP
+
+ ispec_oceans = ibelm_top(ispec2D_top_crust)
+
+ iz_oceans = NGLLZ
+
+ do ix_oceans = 1,NGLLX
+ do iy_oceans = 1,NGLLY
+
+ iglobnum=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+
+! if 3D Earth, compute local height of oceans
+ if(CASE_3D) then
+
+! get coordinates of current point
+ xval = xstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+ yval = ystore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+ zval = zstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+
+! map to latitude and longitude for bathymetry routine
+ call xyz_2_rthetaphi_dble(xval,yval,zval,rval,thetaval,phival)
+ call reduce(thetaval,phival)
+
+! convert the geocentric colatitude to a geographic colatitude
+ colat = PI/2.0d0 - datan(1.006760466d0*dcos(thetaval)/dmax1(TINYVAL,dsin(thetaval)))
+
+! get geographic latitude and longitude in degrees
+ lat = 90.0d0 - colat*180.0d0/PI
+ lon = phival*180.0d0/PI
+ elevation = 0.d0
+
+! compute elevation at current point
+ call get_topo_bathy(lat,lon,elevation,ibathy_topo)
+
+! non-dimensionalize the elevation, which is in meters
+! and suppress positive elevation, which means no oceans
+ if(elevation >= - MINIMUM_THICKNESS_3D_OCEANS) then
+ height_oceans = 0.d0
+ else
+ height_oceans = dabs(elevation) / R_EARTH
+ endif
+
+ else
+! if 1D Earth, use oceans of constant thickness everywhere
+ height_oceans = THICKNESS_OCEANS_PREM
+ endif
+
+! take into account inertia of water column
+ weight = wxgll(ix_oceans)*wygll(iy_oceans)*dble(jacobian2D_top(ix_oceans,iy_oceans,ispec2D_top_crust)) &
+ * dble(RHO_OCEANS) * height_oceans
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + sngl(weight)
+ else
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + weight
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! add regular mass matrix to ocean load contribution
+ rmass_ocean_load(:) = rmass_ocean_load(:) + rmass(:)
+
+ else
+
+! allocate dummy array if no oceans
+ nglob_oceans = 1
+
+ endif
+
+!! DK DK save Brian's attenuation files to a shared disk
+!! DK DK obviously we should do this with MPI or with subroutine arguments
+!! DK DK shared by the mesher and the solver subroutines at some point
+ call attenuation_save_arrays(iregion_code, AM_V)
+
+! compute volume, bottom and top area of that part of the slice
+ volume_local = ZERO
+ area_local_bottom = ZERO
+ area_local_top = ZERO
+
+ do ispec = 1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+
+! compute the jacobian
+!! DK DK in merged version the jacobian is not stored anymore and therefore not valid anymore
+ goto 777
+ xixl = xixstore(i,j,k)
+ xiyl = xiystore(i,j,k)
+ xizl = xizstore(i,j,k)
+ etaxl = etaxstore(i,j,k)
+ etayl = etaystore(i,j,k)
+ etazl = etazstore(i,j,k)
+ gammaxl = gammaxstore(i,j,k)
+ gammayl = gammaystore(i,j,k)
+ gammazl = gammazstore(i,j,k)
+
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ volume_local = volume_local + dble(jacobianl)*weight
+!! DK DK in merged version the jacobian is not stored anymore and therefore not valid anymore
+ 777 continue
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do ispec = 1,NSPEC2D_BOTTOM
+ do i=1,NGLLX
+ do j=1,NGLLY
+ weight=wxgll(i)*wygll(j)
+ area_local_bottom = area_local_bottom + dble(jacobian2D_bottom(i,j,ispec))*weight
+ enddo
+ enddo
+ enddo
+
+ do ispec = 1,NSPEC2D_TOP
+ do i=1,NGLLX
+ do j=1,NGLLY
+ weight=wxgll(i)*wygll(j)
+ area_local_top = area_local_top + dble(jacobian2D_top(i,j,ispec))*weight
+ enddo
+ enddo
+ enddo
+
+ else
+ stop 'there cannot be more than two passes in mesh creation'
+
+ endif ! end of test if first or second pass
+
+ enddo ! of loop on ipass = 1,2
+
+ end subroutine create_regions_mesh
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/create_regions_mesh.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,1498 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine create_regions_mesh(iregion_code,ibool,idoubling, &
- xstore,ystore,zstore,rmins,rmaxs,iproc_xi,iproc_eta,ichunk,nspec,nspec_tiso, &
- volume_local,area_local_bottom,area_local_top, &
- nspl,rspl,espl,espl2,nglob_theor,npointot, &
- NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
- NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
- myrank,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,&
- ATTENUATION,ATTENUATION_3D, &
- NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- ner,ratio_sampling_array,doubling_index,r_bottom,r_top,this_layer_has_a_doubling,CASE_3D, &
- AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, AM_S, AS_V, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ratio_divide_central_cube, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta, &
- iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,NGLOB1D_RADIAL_MAX, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
- jacobian2D_xmin,jacobian2D_xmax, &
- jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom,jacobian2D_top, &
- normal_xmin,normal_xmax,normal_ymin, &
- normal_ymax,normal_bottom,normal_top, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,rmass,xelm_store,yelm_store,zelm_store, &
- npoin2D_xi,npoin2D_eta, &
- xigll,wxgll, yigll,wygll, zigll,wzgll, shape3D, dershape3D, shape2D_x, shape2D_y, shape2D_bottom, shape2D_top, &
- dershape2D_x, dershape2D_y, dershape2D_bottom, dershape2D_top, rhostore_local,kappavstore_local, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- iboun, locval, ifseg, xp,yp,zp, rmass_ocean_load, mask_ibool, copy_ibool_ori, iMPIcut_xi,iMPIcut_eta, &
- rho_vp,rho_vs, Qmu_store, tau_e_store,ifirst_layer_aniso,ilast_layer_aniso)
-
-! create the different regions of the mesh
-
- implicit none
-
- include "mpif.h"
- include "constants.h"
-
-!! DK DK for the merged version
-! include values created by the mesher
- include "values_from_mesher.h"
-
-!! DK DK added this for merged version
- integer :: npoin2D_xi,npoin2D_eta
-
-! mass matrix
- real(kind=CUSTOM_REAL), dimension(nglob_theor) :: rmass
-
- real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
-
-! the jacobian
- real(kind=CUSTOM_REAL) jacobianl
-
-!! DK DK changed this for merged version: made it local
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
-!! DK DK added this for merged version
- logical :: add_contrib_this_element
-
-!! DK DK for merged version
- integer :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
- integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
- integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
-
-!! DK DK added this for merged version
- double precision, dimension(NGLOB1D_RADIAL_MAX) :: &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta
-
- integer :: NGLOB1D_RADIAL_MAX
- integer ibool1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D_leftxi_righteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D_rightxi_righteta(NGLOB1D_RADIAL_MAX)
-
-! this to cut the doubling brick
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer :: step_mult,offset_proc_xi,offset_proc_eta
- integer :: case_xi,case_eta,subblock_num
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_layer_has_a_doubling
-
- integer :: ignod,ner_without_doubling,ispec_superbrick,ilayer,ilayer_loop,ix_elem,iy_elem,iz_elem, &
- ifirst_layer,ilast_layer,ratio_divide_central_cube
-
-! allocate this automatic array in the memory stack to avoid memory fragmentation with "allocate()"
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: permutation_layer
-
-! mesh doubling superbrick
- integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
-
- double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
-
-! aniso_mantle_model_variables
- type aniso_mantle_model_variables
- sequence
- double precision beta(14,34,37,73)
- double precision pro(47)
- integer npar1
- end type aniso_mantle_model_variables
-
- type (aniso_mantle_model_variables) AMM_V
-! aniso_mantle_model_variables
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: interval_Q ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
-! model_1066a_variables
- type model_1066a_variables
- sequence
- double precision, dimension(NR_1066A) :: radius_1066a
- double precision, dimension(NR_1066A) :: density_1066a
- double precision, dimension(NR_1066A) :: vp_1066a
- double precision, dimension(NR_1066A) :: vs_1066a
- double precision, dimension(NR_1066A) :: Qkappa_1066a
- double precision, dimension(NR_1066A) :: Qmu_1066a
- end type model_1066a_variables
-
- type (model_1066a_variables) M1066a_V
-! model_1066a_variables
-
-! model_ak135_variables
- type model_ak135_variables
- sequence
- double precision, dimension(NR_AK135) :: radius_ak135
- double precision, dimension(NR_AK135) :: density_ak135
- double precision, dimension(NR_AK135) :: vp_ak135
- double precision, dimension(NR_AK135) :: vs_ak135
- double precision, dimension(NR_AK135) :: Qkappa_ak135
- double precision, dimension(NR_AK135) :: Qmu_ak135
- end type model_ak135_variables
-
- type (model_ak135_variables) Mak135_V
-! model_ak135_variables
-
-! model_ref_variables
- type model_ref_variables
- sequence
- double precision, dimension(NR_REF) :: radius_ref
- double precision, dimension(NR_REF) :: density_ref
- double precision, dimension(NR_REF) :: vpv_ref
- double precision, dimension(NR_REF) :: vph_ref
- double precision, dimension(NR_REF) :: vsv_ref
- double precision, dimension(NR_REF) :: vsh_ref
- double precision, dimension(NR_REF) :: eta_ref
- double precision, dimension(NR_REF) :: Qkappa_ref
- double precision, dimension(NR_REF) :: Qmu_ref
- end type model_ref_variables
-
- type (model_ref_variables) Mref_V
-! model_ref_variables
-
-! sea1d_model_variables
- type sea1d_model_variables
- sequence
- double precision, dimension(NR_SEA1D) :: radius_sea1d
- double precision, dimension(NR_SEA1D) :: density_sea1d
- double precision, dimension(NR_SEA1D) :: vp_sea1d
- double precision, dimension(NR_SEA1D) :: vs_sea1d
- double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
- double precision, dimension(NR_SEA1D) :: Qmu_sea1d
- end type sea1d_model_variables
-
- type (sea1d_model_variables) SEA1DM_V
-! sea1d_model_variables
-
-! three_d_mantle_model_variables
- type three_d_mantle_model_variables
- sequence
- double precision dvs_a(0:NK,0:NS,0:NS)
- double precision dvs_b(0:NK,0:NS,0:NS)
- double precision dvp_a(0:NK,0:NS,0:NS)
- double precision dvp_b(0:NK,0:NS,0:NS)
- double precision spknt(NK+1)
- double precision qq0(NK+1,NK+1)
- double precision qq(3,NK+1,NK+1)
- end type three_d_mantle_model_variables
-
- type (three_d_mantle_model_variables) D3MM_V
-! three_d_mantle_model_variables
-
-! jp3d_model_variables
- type jp3d_model_variables
- sequence
-! vmod3d
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
-! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
-! locate
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
-! weight
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- double precision :: WV(8)
-! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
-! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- end type jp3d_model_variables
-
- type (jp3d_model_variables) JP3DM_V
-! jp3d_model_variables
-
-! sea99_s_model_variables
- type sea99_s_model_variables
- sequence
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
- double precision :: sea99_ddeg
- double precision :: alatmin
- double precision :: alatmax
- double precision :: alonmin
- double precision :: alonmax
- double precision :: sea99_vs(100,100,100)
- double precision :: sea99_depth(100)
- end type sea99_s_model_variables
-
- type (sea99_s_model_variables) SEA99M_V
-! sea99_s_model_variables
-
-! crustal_model_variables
- type crustal_model_variables
- sequence
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
- character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
- character(len=2) code(NKEYS_CRUST)
- end type crustal_model_variables
-
- type (crustal_model_variables) CM_V
-! crustal_model_variables
-
-! attenuation_model_storage
- type attenuation_model_storage
- sequence
- integer Q_resolution
- integer Q_max
- double precision, dimension(:,:), pointer :: tau_e_storage
- double precision, dimension(:), pointer :: Qmu_storage
- end type attenuation_model_storage
-
- type (attenuation_model_storage) AM_S
-! attenuation_model_storage
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- double precision Q ! Q = Desired Value of Attenuation or Q
- double precision iQ ! iQ = 1/Q
- double precision, dimension(:), pointer :: f
- ! f = Frequencies at which to evaluate the solution
- double precision, dimension(:), pointer :: tau_s
- ! tau_s = Tau_sigma defined by the frequency range and
- ! number of standard linear solids
- end type attenuation_simplex_variables
-
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
-! correct number of spectral elements in each block depending on chunk type
- integer nspec,nspec_tiso,nspec_stacey
-
- integer NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,REFERENCE_1D_MODEL,THREE_D_MODEL
-
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
-
- integer NPROC_XI,NPROC_ETA
-
- integer npointot
-
- logical ELLIPTICITY,TOPOGRAPHY
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST,OCEANS
-
- logical ATTENUATION,ATTENUATION_3D,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
-
- double precision R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO, &
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
-
- character(len=150) errmsg
-
-! use integer array to store values
- integer ibathy_topo(NX_BATHY,NY_BATHY)
-
-! arrays with the mesh in double precision
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
-! meshing parameters
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-! to define the central cube in the inner core
- integer nx_central_cube,ny_central_cube,nz_central_cube
- double precision radius_cube
- double precision :: xgrid_central_cube,ygrid_central_cube,zgrid_central_cube
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
-! auxiliary variables to generate the mesh
- integer ix,iy,iz
-
-! topology of the elements
- integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
-
-! code for the four regions of the mesh
- integer iregion_code
-
-! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll,wxgll
- double precision, dimension(NGLLY) :: yigll,wygll
- double precision, dimension(NGLLZ) :: zigll,wzgll
-
-! 3D shape functions and their derivatives
- double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
- double precision, dimension(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ) :: dershape3D
-
-! 2D shape functions and their derivatives
- double precision shape2D_x(NGNOD2D,NGLLY,NGLLZ)
- double precision shape2D_y(NGNOD2D,NGLLX,NGLLZ)
- double precision shape2D_bottom(NGNOD2D,NGLLX,NGLLY)
- double precision shape2D_top(NGNOD2D,NGLLX,NGLLY)
-
- double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ)
- double precision dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
- double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
- double precision dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
-!! DK DK added this for merged version
-!! DK DK stored in single precision for merged version, check if it precise enough (probably yes)
- real(kind=CUSTOM_REAL), dimension(NGNOD,nspec) :: xelm_store,yelm_store,zelm_store
-
- double precision, dimension(NGNOD) :: xelm,yelm,zelm,offset_x,offset_y,offset_z
-
- integer idoubling(nspec)
-
-! parameters needed to store the radii of the grid points in the spherically symmetric Earth
- double precision :: rmin,rmax
-
-! for model density and anisotropy
- integer nspec_ani
-
-!! DK DK changed this for the merged version
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: rhostore_local,kappavstore_local
-
-!! DK DK added this for merged version
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
-
-! the 21 coefficients for an anisotropic medium in reduced notation
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store
-
-! boundary locator
- logical, dimension(6,nspec) :: iboun
-
-! proc numbers for MPI
- integer myrank
-
-! check area and volume of the final mesh
- double precision weight
- double precision area_local_bottom,area_local_top
- double precision volume_local
-
-! variables for creating array ibool (some arrays also used for AVS or DX files)
- integer, dimension(npointot) :: locval
- logical, dimension(npointot) :: ifseg
- double precision, dimension(npointot) :: xp,yp,zp
-
- integer nglob,nglob_theor,ieoff,ilocnum,ier,errorcode
-
-! mass matrix and bathymetry for ocean load
- integer ix_oceans,iy_oceans,iz_oceans,ispec_oceans
- integer ispec2D_top_crust
- integer nglob_oceans
- double precision xval,yval,zval,rval,thetaval,phival
- double precision lat,lon,colat
- double precision elevation,height_oceans
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
-
-! mask to sort ibool
- integer :: inumber
- integer, dimension(nglob_theor) :: mask_ibool
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: copy_ibool_ori
-
-! boundary parameters locator
- integer, dimension(NSPEC2DMAX_XMIN_XMAX) :: ibelm_xmin,ibelm_xmax
- integer, dimension(NSPEC2DMAX_YMIN_YMAX) :: ibelm_ymin,ibelm_ymax
- integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
- integer, dimension(NSPEC2D_TOP) :: ibelm_top
-
-! MPI cut-planes parameters along xi and along eta
- logical, dimension(2,nspec) :: iMPIcut_xi,iMPIcut_eta
-
-! Stacey indices for Clayton-Engquist absorbing conditions
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: rho_vp,rho_vs
-
-! number of elements on the boundaries
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
-
- integer i,j,k,ia,ispec,iglobnum
- integer iproc_xi,iproc_eta,ichunk
-
- double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
-
-! rotation matrix from Euler angles
- double precision, dimension(NDIM,NDIM) :: rotation_matrix
-
-! attenuation
- double precision, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: Qmu_store
- double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: tau_e_store
- double precision, dimension(N_SLS) :: tau_s
- double precision T_c_source
-
-! **************
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
- logical :: USE_ONE_LAYER_SB,CASE_3D
- integer :: nspec_sb
-
- integer NUMBER_OF_MESH_LAYERS,layer_shift,ifirst_layer_aniso,ilast_layer_aniso
- double precision, dimension(:,:), allocatable :: stretch_tab
-
- integer, parameter :: maxker=200
- integer, parameter :: maxl=72
- integer, parameter :: maxcoe=2000
- integer, parameter :: maxver=1000
- integer, parameter :: maxhpa=2
-
- integer numker
- integer numhpa,numcof
- integer ihpa,lmax,nylm
- integer lmxhpa(maxhpa)
- integer itypehpa(maxhpa)
- integer ihpakern(maxker)
- integer numcoe(maxhpa)
- integer ivarkern(maxker)
-
- integer nconpt(maxhpa),iver
- integer iconpt(maxver,maxhpa)
- real(kind=4) conpt(maxver,maxhpa)
-
- real(kind=4) xlaspl(maxcoe,maxhpa)
- real(kind=4) xlospl(maxcoe,maxhpa)
- real(kind=4) radspl(maxcoe,maxhpa)
- real(kind=4) coe(maxcoe,maxker)
- real(kind=4) vercof(maxker)
- real(kind=4) vercofd(maxker)
-
- real(kind=4) ylmcof((maxl+1)**2,maxhpa)
- real(kind=4) wk1(maxl+1)
- real(kind=4) wk2(maxl+1)
- real(kind=4) wk3(maxl+1)
-
- character(len=80) kerstr
- character(len=40) varstr(maxker)
-
-! to perform two passes of the whole routine to be able to save memory
- integer :: ipass
-
-! the height at which the central cube is cut
- integer :: nz_inf_limit
-
-!! DK DK added this for the merged version
-! 2-D jacobians and normals
- real(kind=CUSTOM_REAL) :: jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) :: jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) :: jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) :: jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) :: jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM)
- real(kind=CUSTOM_REAL) :: jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
-
- real(kind=CUSTOM_REAL) :: normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) :: normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) :: normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) :: normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) :: normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM)
- real(kind=CUSTOM_REAL) :: normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
-
-! perform two passes of the whole routine to be able to save memory
- do ipass = 1,2
-
-! attenuation
- if(ATTENUATION .and. ATTENUATION_3D) then
- T_c_source = AM_V%QT_c_source
- tau_s(:) = AM_V%Qtau_s(:)
- else
- Qmu_store(1,1,1,1) = 0.0d0
- tau_e_store(:,1,1,1,1) = 0.0d0
- endif
-
-! Stacey
- if(NCHUNKS /= 6) then
- nspec_stacey = nspec
- else
- nspec_stacey = 1
- endif
-
-! anisotropy
- nspec_ani = 1
- if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
- (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) nspec_ani = nspec
-
-! set up coordinates of the Gauss-Lobatto-Legendre points
- call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
- call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
- call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
-
-! if number of points is odd, the middle abscissa is exactly zero
- if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
- if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
- if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
-
-! get the 3-D shape functions
- call get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
-
-! get the 2-D shape functions
- call get_shape2D(myrank,shape2D_x,dershape2D_x,yigll,zigll,NGLLY,NGLLZ)
- call get_shape2D(myrank,shape2D_y,dershape2D_y,xigll,zigll,NGLLX,NGLLZ)
- call get_shape2D(myrank,shape2D_bottom,dershape2D_bottom,xigll,yigll,NGLLX,NGLLY)
- call get_shape2D(myrank,shape2D_top,dershape2D_top,xigll,yigll,NGLLX,NGLLY)
-
-! define models 1066a and ak135 and ref
- if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
- call define_model_1066a(CRUSTAL, M1066a_V)
- elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
- call define_model_ak135(CRUSTAL, Mak135_V)
- elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
- call define_model_ref(Mref_V)
- elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
- call define_model_sea1d(CRUSTAL, SEA1DM_V)
- endif
-
-!------------------------------------------------------------------------
-
-! create the shape of the corner nodes of a regular mesh element
- call hex_nodes(iaddx,iaddy,iaddz)
-
-! reference element has size one here, not two
- iaddx(:) = iaddx(:) / 2
- iaddy(:) = iaddy(:) / 2
- iaddz(:) = iaddz(:) / 2
-
- if (ONE_CRUST) then
- NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS - 1
- layer_shift = 0
- else
- NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS
- layer_shift = 1
- endif
-
- if (.not. ADD_4TH_DOUBLING) NUMBER_OF_MESH_LAYERS = NUMBER_OF_MESH_LAYERS - 1
-
-! define the first and last layers that define this region
- if(iregion_code == IREGION_CRUST_MANTLE) then
- ifirst_layer = 1
- ilast_layer = 10 + layer_shift
-
- else if(iregion_code == IREGION_OUTER_CORE) then
- ifirst_layer = 11 + layer_shift
- ilast_layer = NUMBER_OF_MESH_LAYERS - 1
-
- else if(iregion_code == IREGION_INNER_CORE) then
- ifirst_layer = NUMBER_OF_MESH_LAYERS
- ilast_layer = NUMBER_OF_MESH_LAYERS
-
- else
- call exit_MPI(myrank,'incorrect region code detected')
-
- endif
-
- if(iregion_code == IREGION_CRUST_MANTLE) then
-
-! create anisotropic (transversely isotropic) layers first to save memory when
-! storing the anisotropic arrays
- ilayer = 0
- do ilayer_loop = ifirst_layer_aniso,ilast_layer_aniso
- ilayer = ilayer + 1
- permutation_layer(ilayer) = ilayer_loop
- enddo
-
-! and then create all the isotropic layers
- do ilayer_loop = ifirst_layer,ilast_layer
- if(ilayer_loop < ifirst_layer_aniso .or. ilayer_loop > ilast_layer_aniso) then
- ilayer = ilayer + 1
- permutation_layer(ilayer) = ilayer_loop
- endif
- enddo
-
- else
-
-! use identity permutation for regions that do not have transversely isotropic layer
- do ilayer_loop = ifirst_layer,ilast_layer
- permutation_layer(ilayer_loop) = ilayer_loop
- enddo
-
- endif
-
-! initialize mesh arrays
-!! DK DK merged version: we exclude the outer core because the doubling array is useless there and therefore not allocated
- if(iregion_code /= IREGION_OUTER_CORE) idoubling(:) = 0
-
- xstore(:,:,:,:) = 0.d0
- ystore(:,:,:,:) = 0.d0
- zstore(:,:,:,:) = 0.d0
-
- if(ipass == 1) ibool(:,:,:,:) = 0
-
-! initialize boundary arrays
- iboun(:,:) = .false.
- iMPIcut_xi(:,:) = .false.
- iMPIcut_eta(:,:) = .false.
-
-!! DK DK added this for merged version
-! creating mass matrix in this slice (will be fully assembled in the solver)
- if(ipass == 2) rmass(:) = 0._CUSTOM_REAL
-
- if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
- allocate(stretch_tab(2,ner(1)),STAT=ier )
- if (ier /= 0) then
- print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- call stretching_function(r_top(1),r_bottom(1),ner(1),stretch_tab)
- endif
-
-! generate and count all the elements in this region of the mesh
- ispec = 0
-
-! loop on all the layers in this region of the mesh
- do ilayer_loop = ifirst_layer,ilast_layer
-
- ilayer = permutation_layer(ilayer_loop)
-
-! determine the radii that define the shell
- rmin = rmins(ilayer)
- rmax = rmaxs(ilayer)
-
- ner_without_doubling = ner(ilayer)
-
-! if there is a doubling at the top of this region, we implement it in the last two layers of elements
-! and therefore we suppress two layers of regular elements here
- USE_ONE_LAYER_SB = .false.
- if(this_layer_has_a_doubling(ilayer)) then
- if (ner(ilayer) == 1) then
- ner_without_doubling = ner_without_doubling - 1
- USE_ONE_LAYER_SB = .true.
- else
- ner_without_doubling = ner_without_doubling - 2
- USE_ONE_LAYER_SB = .false.
- endif
- endif
-
-!----
-!---- regular mesh elements
-!----
-
-! loop on all the elements
- do ix_elem = 1,NEX_PER_PROC_XI,ratio_sampling_array(ilayer)
- do iy_elem = 1,NEX_PER_PROC_ETA,ratio_sampling_array(ilayer)
- do iz_elem = 1,ner_without_doubling
-! loop on all the corner nodes of this element
- do ignod = 1,NGNOD_EIGHT_CORNERS
-! define topological coordinates of this mesh point
- offset_x(ignod) = (ix_elem - 1) + iaddx(ignod) * ratio_sampling_array(ilayer)
- offset_y(ignod) = (iy_elem - 1) + iaddy(ignod) * ratio_sampling_array(ilayer)
- if (ilayer == 1 .and. CASE_3D) then
- offset_z(ignod) = iaddz(ignod)
- else
- offset_z(ignod) = (iz_elem - 1) + iaddz(ignod)
- endif
- enddo
- call add_missing_nodes(offset_x,offset_y,offset_z)
-
-! compute the actual position of all the grid points of that element
- if (ilayer == 1 .and. CASE_3D .and. .not. SUPPRESS_CRUSTAL_MESH) then
-! crustal elements are stretched to be thinner in the upper crust than in lower crust in the 3D case
-! max ratio between size of upper crust elements and lower crust elements is given by the param MAX_RATIO_STRETCHING
-! to avoid stretching, set MAX_RATIO_STRETCHING = 1.0d in constants.h
- call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
- ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
- NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- stretch_tab(1,ner_without_doubling-iz_elem+1),&
- stretch_tab(2,ner_without_doubling-iz_elem+1),1,ilayer,ichunk,rotation_matrix, &
- NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
- else
- call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
- ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
- NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- r_top(ilayer),r_bottom(ilayer),ner(ilayer),ilayer,ichunk,rotation_matrix, &
- NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
- endif
-! add one spectral element to the list
- ispec = ispec + 1
- if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation')
-
-! new get_flag_boundaries
-! xmin & xmax
- if (ix_elem == 1) then
- iMPIcut_xi(1,ispec) = .true.
- if (iproc_xi == 0) iboun(1,ispec)= .true.
- endif
- if (ix_elem == (NEX_PER_PROC_XI-ratio_sampling_array(ilayer)+1)) then
- iMPIcut_xi(2,ispec) = .true.
- if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= .true.
- endif
-! ymin & ymax
- if (iy_elem == 1) then
- iMPIcut_eta(1,ispec) = .true.
- if (iproc_eta == 0) iboun(3,ispec)= .true.
- endif
- if (iy_elem == (NEX_PER_PROC_ETA-ratio_sampling_array(ilayer)+1)) then
- iMPIcut_eta(2,ispec) = .true.
- if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= .true.
- endif
-! zmin & zmax
- if (iz_elem == ner(ilayer) .and. ilayer == ifirst_layer) then
- iboun(6,ispec)= .true.
- endif
- if (iz_elem == 1 .and. ilayer == ilast_layer) then ! defined if no doubling in this layer
- iboun(5,ispec)= .true.
- endif
-
-! define the doubling flag of this element
- if(iregion_code /= IREGION_OUTER_CORE) idoubling(ispec) = doubling_index(ilayer)
-
-! compute several rheological and geometrical properties for this spectral element
- call compute_element_properties(ispec,iregion_code,idoubling, &
- xstore,ystore,zstore,nspec, &
- nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
- ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
- myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
- ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore_local,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
-!! DK DK added this for the merged version
- kappavstore_local, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- nspec_ani,nspec_stacey,Qmu_store,tau_e_store,tau_s,T_c_source,rho_vp,rho_vs,&
- AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
-
-!! DK DK added this for merged version
- include "comp_mass_matrix_one_element.f90"
- include "store_xelm_yelm_zelm.f90"
-
-! end of loop on all the regular elements
- enddo
- enddo
- enddo
-
-!----
-!---- mesh doubling elements
-!----
-
-! If there is a doubling at the top of this region, let us add these elements.
-! The superbrick implements a symmetric four-to-two doubling and therefore replaces
-! a basic regular block of 2 x 2 = 4 elements.
-! We have imposed that NEX be a multiple of 16 therefore we know that we can always create
-! these 2 x 2 blocks because NEX_PER_PROC_XI / ratio_sampling_array(ilayer) and
-! NEX_PER_PROC_ETA / ratio_sampling_array(ilayer) are always divisible by 2.
- if(this_layer_has_a_doubling(ilayer)) then
- if (USE_ONE_LAYER_SB) then
- call define_superbrick_one_layer(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
- nspec_sb = NSPEC_SUPERBRICK_1L
- iz_elem = ner(ilayer)
- step_mult = 2
- else
- if(iregion_code==IREGION_OUTER_CORE .and. ilayer==ilast_layer .and. (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
- nspec_sb = NSPEC_DOUBLING_BASICBRICK
- step_mult = 1
- else
- call define_superbrick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
- nspec_sb = NSPEC_DOUBLING_SUPERBRICK
- step_mult = 2
- endif
-! the doubling is implemented in the last two radial elements
-! therefore we start one element before the last one
- iz_elem = ner(ilayer) - 1
- endif
-
-! loop on all the elements in the 2 x 2 blocks
- do ix_elem = 1,NEX_PER_PROC_XI,step_mult*ratio_sampling_array(ilayer)
- do iy_elem = 1,NEX_PER_PROC_ETA,step_mult*ratio_sampling_array(ilayer)
-
- if (step_mult == 1) then
-! for xi direction
- if (.not. CUT_SUPERBRICK_XI) then
- if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
- case_xi = 1
- else
- case_xi = 2
- endif
- else
- if (offset_proc_xi == 0) then
- if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
- case_xi = 1
- else
- case_xi = 2
- endif
- else
- if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))/=0) then
- case_xi = 1
- else
- case_xi = 2
- endif
- endif
- endif
-! for eta direction
- if (.not. CUT_SUPERBRICK_ETA) then
- if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
- case_eta = 1
- else
- case_eta = 2
- endif
- else
- if (offset_proc_eta == 0) then
- if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
- case_eta = 1
- else
- case_eta = 2
- endif
- else
- if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))/=0) then
- case_eta = 1
- else
- case_eta = 2
- endif
- endif
- endif
-! determine the current sub-block
- if (case_xi == 1) then
- if (case_eta == 1) then
- subblock_num = 1
- else
- subblock_num = 2
- endif
- else
- if (case_eta == 1) then
- subblock_num = 3
- else
- subblock_num = 4
- endif
- endif
-! then define the geometry for this sub-block
- call define_basic_doubling_brick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb,subblock_num)
- endif
-! loop on all the elements in the mesh doubling superbrick
- do ispec_superbrick = 1,nspec_sb
-! loop on all the corner nodes of this element
- do ignod = 1,NGNOD_EIGHT_CORNERS
-
-! define topological coordinates of this mesh point
- offset_x(ignod) = (ix_elem - 1) + &
- x_superbrick(ibool_superbrick(ignod,ispec_superbrick)) * ratio_sampling_array(ilayer)
- offset_y(ignod) = (iy_elem - 1) + &
- y_superbrick(ibool_superbrick(ignod,ispec_superbrick)) * ratio_sampling_array(ilayer)
- offset_z(ignod) = (iz_elem - 1) + &
- z_superbrick(ibool_superbrick(ignod,ispec_superbrick))
-
- enddo
-! the rest of the 27 nodes are missing, therefore add them
- call add_missing_nodes(offset_x,offset_y,offset_z)
-
-! compute the actual position of all the grid points of that element
- call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
- ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
- NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- r_top(ilayer),r_bottom(ilayer),ner(ilayer),ilayer,ichunk,rotation_matrix, &
- NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
-
-! add one spectral element to the list
- ispec = ispec + 1
- if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation')
-
-! new get_flag_boundaries
-
-! xmin and xmax
- if (ix_elem == 1) then
- iMPIcut_xi(1,ispec) = iboun_sb(ispec_superbrick,1)
- if (iproc_xi == 0) iboun(1,ispec)= iboun_sb(ispec_superbrick,1)
- endif
- if (ix_elem == (NEX_PER_PROC_XI-step_mult*ratio_sampling_array(ilayer)+1)) then
- iMPIcut_xi(2,ispec) = iboun_sb(ispec_superbrick,2)
- if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= iboun_sb(ispec_superbrick,2)
- endif
-
-! ymin and ymax
- if (iy_elem == 1) then
- iMPIcut_eta(1,ispec) = iboun_sb(ispec_superbrick,3)
- if (iproc_eta == 0) iboun(3,ispec)= iboun_sb(ispec_superbrick,3)
- endif
- if (iy_elem == (NEX_PER_PROC_ETA-step_mult*ratio_sampling_array(ilayer)+1)) then
- iMPIcut_eta(2,ispec) = iboun_sb(ispec_superbrick,4)
- if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= iboun_sb(ispec_superbrick,4)
- endif
-
-! zmax only
- if (ilayer==ifirst_layer) iboun(6,ispec)= iboun_sb(ispec_superbrick,6)
- if (ilayer==ilast_layer .and. iz_elem==1) iboun(5,ispec)= iboun_sb(ispec_superbrick,5)
-
-! define the doubling flag of this element
- if(iregion_code /= IREGION_OUTER_CORE) idoubling(ispec) = doubling_index(ilayer)
-
-! compute several rheological and geometrical properties for this spectral element
- call compute_element_properties(ispec,iregion_code,idoubling, &
- xstore,ystore,zstore,nspec, &
- nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
- ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
- myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
- ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore_local,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
-!! DK DK added this for the merged version
- kappavstore_local, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- nspec_ani,nspec_stacey,Qmu_store,tau_e_store,tau_s,T_c_source,rho_vp,rho_vs,&
- AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
-
-!! DK DK added this for merged version
- include "comp_mass_matrix_one_element.f90"
- include "store_xelm_yelm_zelm.f90"
-
-! end of loops on the mesh doubling elements
- enddo
- enddo
- enddo
- endif
-
-! end of loop on all the layers of the mesh
- enddo
-
- if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
- deallocate(stretch_tab,STAT=ier )
- if (ier /= 0) then
- print *,"ERROR can not deallocate stretch_tab in create_regions_mesh ier=",ier
- stop 'error in deallocate'
- endif
- endif
-
-!---
-
-! define central cube in inner core
-
- if(INCLUDE_CENTRAL_CUBE .and. iregion_code == IREGION_INNER_CORE) then
-
-! create the shape of a regular mesh element in the inner core
- call hex_nodes(iaddx,iaddy,iaddz)
-
-! define vertical slice in central cube on current processor
-! we can assume that NEX_XI = NEX_ETA, otherwise central cube cannot be defined
- nx_central_cube = NEX_PER_PROC_XI / ratio_divide_central_cube
- ny_central_cube = NEX_PER_PROC_ETA / ratio_divide_central_cube
- nz_central_cube = NEX_XI / ratio_divide_central_cube
-
-! size of the cube along cartesian axes before rotation
- radius_cube = (R_CENTRAL_CUBE / R_EARTH) / sqrt(3.d0)
-
-! define spectral elements in central cube
- do iz = 0,2*nz_central_cube-2,2
- do iy = 0,2*ny_central_cube-2,2
- do ix = 0,2*nx_central_cube-2,2
-
-! radii that define the shell, we know that we are in the central cube
- rmin = 0.d0
- rmax = R_CENTRAL_CUBE / R_EARTH
-
-! loop over the NGNOD nodes
- do ia=1,NGNOD
-
-! flat cubed sphere with correct mapping
- call compute_coord_central_cube(ix+iaddx(ia),iy+iaddy(ia),iz+iaddz(ia), &
- xgrid_central_cube,ygrid_central_cube,zgrid_central_cube, &
- iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,nx_central_cube,ny_central_cube,nz_central_cube,radius_cube)
-
- if(ichunk == CHUNK_AB) then
- xelm(ia) = - ygrid_central_cube
- yelm(ia) = + xgrid_central_cube
- zelm(ia) = + zgrid_central_cube
-
- else if(ichunk == CHUNK_AB_ANTIPODE) then
- xelm(ia) = - ygrid_central_cube
- yelm(ia) = - xgrid_central_cube
- zelm(ia) = - zgrid_central_cube
-
- else if(ichunk == CHUNK_AC) then
- xelm(ia) = - ygrid_central_cube
- yelm(ia) = - zgrid_central_cube
- zelm(ia) = + xgrid_central_cube
-
- else if(ichunk == CHUNK_AC_ANTIPODE) then
- xelm(ia) = - ygrid_central_cube
- yelm(ia) = + zgrid_central_cube
- zelm(ia) = - xgrid_central_cube
-
- else if(ichunk == CHUNK_BC) then
- xelm(ia) = - zgrid_central_cube
- yelm(ia) = + ygrid_central_cube
- zelm(ia) = + xgrid_central_cube
-
- else if(ichunk == CHUNK_BC_ANTIPODE) then
- xelm(ia) = + zgrid_central_cube
- yelm(ia) = - ygrid_central_cube
- zelm(ia) = + xgrid_central_cube
-
- else
- call exit_MPI(myrank,'wrong chunk number in flat cubed sphere definition')
- endif
-
- enddo
-
-! add one spectral element to the list
- ispec = ispec + 1
- if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in central cube creation')
-
-! new get_flag_boundaries
-! xmin & xmax
- if (ix == 0) then
- iMPIcut_xi(1,ispec) = .true.
- if (iproc_xi == 0) iboun(1,ispec)= .true.
- endif
- if (ix == 2*nx_central_cube-2) then
- iMPIcut_xi(2,ispec) = .true.
- if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= .true.
- endif
-! ymin & ymax
- if (iy == 0) then
- iMPIcut_eta(1,ispec) = .true.
- if (iproc_eta == 0) iboun(3,ispec)= .true.
- endif
- if (iy == 2*ny_central_cube-2) then
- iMPIcut_eta(2,ispec) = .true.
- if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= .true.
- endif
-
-! define the doubling flag of this element
-! only two active central cubes, the four others are fictitious
-
-! determine where we cut the central cube to share it between CHUNK_AB & CHUNK_AB_ANTIPODE
-! in the case of mod(NPROC_XI,2)/=0, the cut is asymetric and the bigger part is for CHUNK_AB
- if (mod(NPROC_XI,2)/=0) then
- if (ichunk == CHUNK_AB) then
- nz_inf_limit = ((nz_central_cube*2)/NPROC_XI)*floor(NPROC_XI/2.d0)
- elseif (ichunk == CHUNK_AB_ANTIPODE) then
- nz_inf_limit = ((nz_central_cube*2)/NPROC_XI)*ceiling(NPROC_XI/2.d0)
- endif
- else
- nz_inf_limit = nz_central_cube
- endif
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
- if(iz == nz_inf_limit) then
- idoubling(ispec) = IFLAG_BOTTOM_CENTRAL_CUBE
- else if(iz == 2*nz_central_cube-2) then
- idoubling(ispec) = IFLAG_TOP_CENTRAL_CUBE
- else if (iz > nz_inf_limit .and. iz < 2*nz_central_cube-2) then
- idoubling(ispec) = IFLAG_MIDDLE_CENTRAL_CUBE
- else
- idoubling(ispec) = IFLAG_IN_FICTITIOUS_CUBE
- endif
- else
- idoubling(ispec) = IFLAG_IN_FICTITIOUS_CUBE
- endif
-
-
-! compute several rheological and geometrical properties for this spectral element
- call compute_element_properties(ispec,iregion_code,idoubling, &
- xstore,ystore,zstore,nspec, &
- nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
- ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
- myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
- ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore_local,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
-!! DK DK added this for the merged version
- kappavstore_local, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- nspec_ani,nspec_stacey,Qmu_store,tau_e_store,tau_s,T_c_source,rho_vp,rho_vs,&
- AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
-
-!! DK DK added this for merged version
- include "comp_mass_matrix_one_element.f90"
- include "store_xelm_yelm_zelm.f90"
-
- enddo
- enddo
- enddo
-
- endif ! end of definition of central cube in inner core
-
-!---
-
-! check total number of spectral elements created
- if(ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec')
-
-! only create global addressing and the MPI buffers in the first pass
- if(ipass == 1) then
-
- locval = 0
- ifseg = .false.
- xp = 0.d0
- yp = 0.d0
- zp = 0.d0
-
- ! we need to create a copy of the x, y and z arrays because sorting in get_global will swap
- ! these arrays and therefore destroy them
- do ispec=1,nspec
- ieoff = NGLLX * NGLLY * NGLLZ * (ispec-1)
- ilocnum = 0
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- ilocnum = ilocnum + 1
- xp(ilocnum+ieoff) = xstore(i,j,k,ispec)
- yp(ilocnum+ieoff) = ystore(i,j,k,ispec)
- zp(ilocnum+ieoff) = zstore(i,j,k,ispec)
- enddo
- enddo
- enddo
- enddo
-
- call get_global(nspec,xp,yp,zp,ibool,locval,ifseg,nglob,npointot)
-
- ! check that number of points found equals theoretical value
- if(nglob /= nglob_theor) then
- write(errmsg,*) 'incorrect total number of points found: myrank,nglob,nglob_theor,ipass,iregion_code = ',&
- myrank,nglob,nglob_theor,ipass,iregion_code
- call exit_MPI(myrank,errmsg)
- endif
-
- if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering')
-
-! create a new indirect addressing to reduce cache misses in memory access in the solver
-! this is *critical* to improve performance in the solver
- mask_ibool(:) = -1
- copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:)
-
- inumber = 0
- do ispec=1,nspec
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- if(mask_ibool(copy_ibool_ori(i,j,k,ispec)) == -1) then
- ! create a new point
- inumber = inumber + 1
- ibool(i,j,k,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,k,ispec)) = inumber
- else
- ! use an existing point created previously
- ibool(i,j,k,ispec) = mask_ibool(copy_ibool_ori(i,j,k,ispec))
- endif
- enddo
- enddo
- enddo
- enddo
-
- if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering after sorting')
-
- ! create MPI buffers
- ! arrays locval(npointot) and ifseg(npointot) used to save memory
- call get_MPI_cutplanes_xi(myrank,nspec,iMPIcut_xi,ibool, &
- ifseg,npointot, &
- NSPEC2D_ETA_FACE,iregion_code,nglob,iboolleft_xi,iboolright_xi,NGLOB2DMAX_XMIN_XMAX,npoin2D_xi)
- call get_MPI_cutplanes_eta(myrank,nspec,iMPIcut_eta,ibool, &
- ifseg,npointot, &
- NSPEC2D_XI_FACE,iregion_code,nglob,iboolleft_eta,iboolright_eta,NGLOB2DMAX_YMIN_YMAX,npoin2D_eta)
- call get_MPI_1D_buffers(myrank,nspec,iMPIcut_xi,iMPIcut_eta,ibool,idoubling, &
- xstore,ystore,zstore,ifseg,npointot, &
- NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion_code,nglob, &
- ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,NGLOB1D_RADIAL_MAX, &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
- iregion_code)
-
-! only create mass matrix and save all the final arrays in the second pass
- else if(ipass == 2) then
-
-! copy the theoretical number of points for the second pass
- nglob = nglob_theor
-
-! count number of anisotropic elements in current region
-! should be zero in all the regions except in the mantle
- if(iregion_code == IREGION_CRUST_MANTLE) then
- nspec_tiso = count(idoubling(1:nspec) == IFLAG_220_80) + count(idoubling(1:nspec) == IFLAG_80_MOHO)
- else
- nspec_tiso = 0
- endif
-
- call get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- jacobian2D_xmin,jacobian2D_xmax, &
- jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top, &
- normal_xmin,normal_xmax, &
- normal_ymin,normal_ymax, &
- normal_bottom,normal_top, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
-
-! save the binary files
-! save ocean load mass matrix as well if oceans
- if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
-
-! adding ocean load mass matrix at the top of the crust for oceans
- nglob_oceans = nglob
-
-! create ocean load mass matrix for degrees of freedom at ocean bottom
- rmass_ocean_load(:) = 0._CUSTOM_REAL
-
-! add contribution of the oceans
-! for surface elements exactly at the top of the crust (ocean bottom)
- do ispec2D_top_crust = 1,NSPEC2D_TOP
-
- ispec_oceans = ibelm_top(ispec2D_top_crust)
-
- iz_oceans = NGLLZ
-
- do ix_oceans = 1,NGLLX
- do iy_oceans = 1,NGLLY
-
- iglobnum=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
-
-! if 3D Earth, compute local height of oceans
- if(CASE_3D) then
-
-! get coordinates of current point
- xval = xstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
- yval = ystore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
- zval = zstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
-
-! map to latitude and longitude for bathymetry routine
- call xyz_2_rthetaphi_dble(xval,yval,zval,rval,thetaval,phival)
- call reduce(thetaval,phival)
-
-! convert the geocentric colatitude to a geographic colatitude
- colat = PI/2.0d0 - datan(1.006760466d0*dcos(thetaval)/dmax1(TINYVAL,dsin(thetaval)))
-
-! get geographic latitude and longitude in degrees
- lat = 90.0d0 - colat*180.0d0/PI
- lon = phival*180.0d0/PI
- elevation = 0.d0
-
-! compute elevation at current point
- call get_topo_bathy(lat,lon,elevation,ibathy_topo)
-
-! non-dimensionalize the elevation, which is in meters
-! and suppress positive elevation, which means no oceans
- if(elevation >= - MINIMUM_THICKNESS_3D_OCEANS) then
- height_oceans = 0.d0
- else
- height_oceans = dabs(elevation) / R_EARTH
- endif
-
- else
-! if 1D Earth, use oceans of constant thickness everywhere
- height_oceans = THICKNESS_OCEANS_PREM
- endif
-
-! take into account inertia of water column
- weight = wxgll(ix_oceans)*wygll(iy_oceans)*dble(jacobian2D_top(ix_oceans,iy_oceans,ispec2D_top_crust)) &
- * dble(RHO_OCEANS) * height_oceans
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + sngl(weight)
- else
- rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + weight
- endif
-
- enddo
- enddo
-
- enddo
-
-! add regular mass matrix to ocean load contribution
- rmass_ocean_load(:) = rmass_ocean_load(:) + rmass(:)
-
- else
-
-! allocate dummy array if no oceans
- nglob_oceans = 1
-
- endif
-
-!! DK DK save Brian's attenuation files to a shared disk
-!! DK DK obviously we should do this with MPI or with subroutine arguments
-!! DK DK shared by the mesher and the solver subroutines at some point
- call attenuation_save_arrays(iregion_code, AM_V)
-
-! compute volume, bottom and top area of that part of the slice
- volume_local = ZERO
- area_local_bottom = ZERO
- area_local_top = ZERO
-
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- weight = wxgll(i)*wygll(j)*wzgll(k)
-
-! compute the jacobian
-!! DK DK in merged version the jacobian is not stored anymore and therefore not valid anymore
- goto 777
- xixl = xixstore(i,j,k)
- xiyl = xiystore(i,j,k)
- xizl = xizstore(i,j,k)
- etaxl = etaxstore(i,j,k)
- etayl = etaystore(i,j,k)
- etazl = etazstore(i,j,k)
- gammaxl = gammaxstore(i,j,k)
- gammayl = gammaystore(i,j,k)
- gammazl = gammazstore(i,j,k)
-
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- volume_local = volume_local + dble(jacobianl)*weight
-!! DK DK in merged version the jacobian is not stored anymore and therefore not valid anymore
- 777 continue
-
- enddo
- enddo
- enddo
- enddo
-
- do ispec = 1,NSPEC2D_BOTTOM
- do i=1,NGLLX
- do j=1,NGLLY
- weight=wxgll(i)*wygll(j)
- area_local_bottom = area_local_bottom + dble(jacobian2D_bottom(i,j,ispec))*weight
- enddo
- enddo
- enddo
-
- do ispec = 1,NSPEC2D_TOP
- do i=1,NGLLX
- do j=1,NGLLY
- weight=wxgll(i)*wygll(j)
- area_local_top = area_local_top + dble(jacobian2D_top(i,j,ispec))*weight
- enddo
- enddo
- enddo
-
- else
- stop 'there cannot be more than two passes in mesh creation'
-
- endif ! end of test if first or second pass
-
- enddo ! of loop on ipass = 1,2
-
- end subroutine create_regions_mesh
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declarations_main.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declarations_main.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declarations_main.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,107 +0,0 @@
-
-!! DK DK for merged version, all the arrays below are allocated statically instead
-
- integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
- integer npoin2D_faces_outer_core(NUMFACES_SHARED)
- integer npoin2D_faces_inner_core(NUMFACES_SHARED)
-
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
-
-! number of elements on the boundaries
- integer :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: kappavstore_crust_mantle,muvstore_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: kappavstore_inner_core,muvstore_inner_core
-
-! 2-D jacobians and normals
- integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
-
- integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
- integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
-
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
- integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
- integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
-
- integer, dimension(NGLOB2DMAX_XY_VAL_CM,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL_OC,NUMFACES_SHARED) :: iboolfaces_outer_core
- integer, dimension(NGLOB2DMAX_XY_VAL_IC,NUMFACES_SHARED) :: iboolfaces_inner_core
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
-
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
-
- integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
- integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
- integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
-
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
-
- integer :: npoin2D_max_all,NDIM_smaller_buffers
-
-! receiver information
- integer :: nrec,ios
- character(len=150) :: STATIONS,rec_filename,dummystring
-
-!---- arrays to assemble between chunks
-
-! communication pattern for faces between chunks
- integer, dimension(NUMMSGS_FACES_VAL) :: imsg_type,iprocfrom_faces,iprocto_faces
-
-! communication pattern for corners between chunks
- integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: Qs ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declarations_mesher.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declarations_mesher.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/declarations_mesher.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,172 +0,0 @@
-
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
-
-! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll,wxgll
- double precision, dimension(NGLLY) :: yigll,wygll
- double precision, dimension(NGLLZ) :: zigll,wzgll
-
-! 3D shape functions and their derivatives
- double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
- double precision, dimension(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ) :: dershape3D
-
-! 2D shape functions and their derivatives
- double precision shape2D_x(NGNOD2D,NGLLY,NGLLZ)
- double precision shape2D_y(NGNOD2D,NGLLX,NGLLZ)
- double precision shape2D_bottom(NGNOD2D,NGLLX,NGLLY)
- double precision shape2D_top(NGNOD2D,NGLLX,NGLLY)
-
- double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ)
- double precision dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
- double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
- double precision dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: rhostore_local,kappavstore_local
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store
-
- logical, dimension(6,NSPEC_CRUST_MANTLE) :: iboun
-
-! very large arrays used for the sorting routine
- integer, dimension(NSPEC_CRUST_MANTLE * NGLLX * NGLLY * NGLLZ) :: locval
- logical, dimension(NSPEC_CRUST_MANTLE * NGLLX * NGLLY * NGLLZ) :: ifseg
- double precision, dimension(NSPEC_CRUST_MANTLE * NGLLX * NGLLY * NGLLZ) :: xp,yp,zp
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
-
- integer, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: copy_ibool_ori
-
- logical, dimension(2,NSPEC_CRUST_MANTLE) :: iMPIcut_xi,iMPIcut_eta
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: rho_vp,rho_vs
-
- double precision, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: Qmu_store
- double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: tau_e_store
-
-!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
-!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
-!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
-!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
-!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
-!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
-!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
-
- integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
- integer npoin2D_faces_outer_core(NUMFACES_SHARED)
- integer npoin2D_faces_inner_core(NUMFACES_SHARED)
-
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core
-
-! number of elements on the boundaries
- integer :: nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle,nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
- integer :: nspec2D_xmin_outer_core,nspec2D_xmax_outer_core,nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
- integer :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: kappavstore_crust_mantle,muvstore_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: kappavstore_inner_core,muvstore_inner_core
-
-!! DK DK added this for the merged version
-!! DK DK these arrays are useless in the solver and will therefore be allocated with a dummy size of 1
- real(kind=CUSTOM_REAL), dimension(1,1,1,1) :: kappahstore_inner_core,muhstore_inner_core,eta_anisostore_inner_core
- real(kind=CUSTOM_REAL), dimension(1,1,1,1) :: kappavstore_outer_core,muvstore_outer_core
- real(kind=CUSTOM_REAL), dimension(1,1,1,1) :: kappahstore_outer_core,muhstore_outer_core,eta_anisostore_outer_core
-
-! 2-D jacobians and normals
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_IC) :: jacobian2D_xmin_inner_core,jacobian2D_xmax_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_IC) :: jacobian2D_ymin_inner_core,jacobian2D_ymax_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_IC) :: jacobian2D_bottom_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_IC) :: jacobian2D_top_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_IC) :: normal_xmin_inner_core,normal_xmax_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_IC) :: normal_ymin_inner_core,normal_ymax_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_IC) :: normal_bottom_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_IC) :: normal_top_inner_core
-
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
- integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_CM) :: &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: jacobian2D_bottom_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: jacobian2D_top_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: normal_xmin_crust_mantle,normal_xmax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2DMAX_YMIN_YMAX_CM) :: normal_ymin_crust_mantle,normal_ymax_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: normal_bottom_crust_mantle
-
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
- integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
- integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: normal_xmin_outer_core,normal_xmax_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: normal_ymin_outer_core,normal_ymax_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
-
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
- integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
- integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
-
- integer, dimension(NGLOB2DMAX_XY_VAL_CM,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL_OC,NUMFACES_SHARED) :: iboolfaces_outer_core
- integer, dimension(NGLOB2DMAX_XY_VAL_IC,NUMFACES_SHARED) :: iboolfaces_inner_core
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
-
-!! DK DK this array is useless in the solver and is therefore allocated with a dummy size of 1
- integer, dimension(1) :: idoubling_outer_core
-
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
-
- integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
- integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
- integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
-
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
-
-!! DK DK added this for the merged version
-!---- arrays to assemble between chunks
-
-! communication pattern for faces between chunks
- integer, dimension(NUMMSGS_FACES_VAL) :: imsg_type,iprocfrom_faces,iprocto_faces
-
-! communication pattern for corners between chunks
- integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,110 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! 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.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+#ifdef USE_MPI
+ integer ier
+#endif
+ character(len=80) outputname
+ character(len=150) OUTPUT_FILES
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+ write(outputname,"('/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(OUTPUT_FILES)//outputname,status='unknown',action='write')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+! close output file
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN)
+
+! stop all the MPI processes, and exit
+#ifdef USE_MPI
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+#endif
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
+
+! version without rank number printed in the error message
+ subroutine exit_mpi_without_rank(error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+
+ character(len=*) error_msg
+
+#ifdef USE_MPI
+ integer ier
+#endif
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI...'
+
+! stop all the MPI processes, and exit
+#ifdef USE_MPI
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+#endif
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_mpi_without_rank
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/exit_mpi.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,98 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! 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.
-!
-!=====================================================================
-
-! end the simulation and exit MPI
-
-! version with rank number printed in the error message
- subroutine exit_MPI(myrank,error_msg)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
-
-! identifier for error message file
- integer, parameter :: IERROR = 30
-
- integer myrank
- character(len=*) error_msg
-
- integer ier
- character(len=80) outputname
- character(len=150) OUTPUT_FILES
-
-! write error message to screen
- write(*,*) error_msg(1:len(error_msg))
- write(*,*) 'Error detected, aborting MPI... proc ',myrank
-
-! write error message to file
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
- write(outputname,"('/error_message',i6.6,'.txt')") myrank
- open(unit=IERROR,file=trim(OUTPUT_FILES)//outputname,status='unknown',action='write')
- write(IERROR,*) error_msg(1:len(error_msg))
- write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
- close(IERROR)
-
-! close output file
- if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN)
-
-! stop all the MPI processes, and exit
- call MPI_ABORT(MPI_COMM_WORLD,30,ier)
- stop 'error, program ended in exit_MPI'
-
- end subroutine exit_MPI
-
-!
-!----
-!
-
-! version without rank number printed in the error message
- subroutine exit_MPI_without_rank(error_msg)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
-
- character(len=*) error_msg
-
- integer ier
-
-! write error message to screen
- write(*,*) error_msg(1:len(error_msg))
- write(*,*) 'Error detected, aborting MPI...'
-
-! stop all the MPI processes, and exit
- call MPI_ABORT(MPI_COMM_WORLD,30,ier)
- stop 'error, program ended in exit_MPI'
-
- end subroutine exit_MPI_without_rank
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,201 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! 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.
+!
+!=====================================================================
+
+! get information about event name and location for SAC seismograms: MPI version by Dimitri Komatitsch
+
+ subroutine get_event_info_parallel(myrank,yr,jda,ho,mi,sec,t_cmt, &
+ elat,elon,depth,mb,ename,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+
+!--- input or output arguments of the subroutine below
+
+ integer, intent(in) :: myrank
+
+ integer, intent(out) :: NSOURCES,yr,jda,ho,mi
+ real, intent(out) :: mb
+ double precision, intent(out) :: t_cmt,elat,elon,depth,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,sec
+ character(len=12), intent(out) :: ename
+
+!--- local variables below
+
+ integer :: i
+
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+ integer, parameter :: LENGTH_REGION_NAME = 150
+ character(len=LENGTH_REGION_NAME) region
+
+! get event information for SAC header on the master
+ if(myrank == 0) then
+
+ call get_event_info_serial(yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,region, &
+ cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES,LENGTH_REGION_NAME)
+
+! create the event name
+ write(ename(1:12),'(a12)') region(1:12)
+
+! replace white spaces with underscores in event name
+ do i=1,len_trim(ename)
+ if (ename(i:i) == ' ') ename(i:i) = '_'
+ enddo
+
+ endif
+
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(yr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(jda,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ho,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(mi,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(sec,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(t_cmt,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(elat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(elon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(depth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(cmt_lat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(cmt_lon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(cmt_depth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(cmt_hdur,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(ename,12,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+#endif
+
+ end subroutine get_event_info_parallel
+
+!=====================================================================
+
+! get information about event name and location for SAC seismograms: MPI version by Bernhard Schuberth
+! This subroutine reads the first line of the DATA/CMTSOLUTION file
+! and extracts event information needed for SAC or PITSA headers
+
+ subroutine get_event_info_serial(yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,region,&
+ cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES,LENGTH_REGION_NAME)
+
+ implicit none
+
+ include "constants.h"
+
+!--- arguments of the subroutine below
+
+ integer, intent(out) :: NSOURCES,yr,jda,ho,mi
+
+ real, intent(out) :: mb
+
+ double precision, intent(out) :: sec,t_cmt,elat,elon,depth,cmt_lat,cmt_lon,cmt_depth,cmt_hdur
+
+ integer, intent(in) :: LENGTH_REGION_NAME
+ character(len=LENGTH_REGION_NAME), intent(out) :: region ! event name for SAC header
+
+!--- local variables here
+
+ integer ios,icounter,mo,da,julian_day
+
+ real ms
+
+ character(len=5) datasource
+ character(len=150) string,dummystring,CMTSOLUTION
+
+!
+!---- read hypocenter info
+!
+ call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION','DATA/CMTSOLUTION')
+
+ open(unit=821,file=CMTSOLUTION,iostat=ios,status='old',action='read')
+ if(ios /= 0) stop 'error opening CMTSOLUTION file (in get_event_info_serial)'
+
+ icounter = 0
+ do while(ios == 0)
+ read(821,"(a)",iostat=ios) dummystring
+ if(ios == 0) icounter = icounter + 1
+ enddo
+ close(821)
+ if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) &
+ stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
+ NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE
+ if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
+
+ open(unit=821,file=CMTSOLUTION,status='old',action='read')
+
+ ! example header line of CMTSOLUTION file
+ !PDE 2003 09 25 19 50 08.93 41.78 144.08 18.0 7.9 8.0 Hokkaido, Japan
+ !event_id, date,origin time,latitude,longitude,depth, mb, MS, region
+
+ ! read header with event information
+ read(821,*) datasource,yr,mo,da,ho,mi,sec,elat,elon,depth,mb,ms,region
+
+ jda=julian_day(yr,mo,da)
+
+ ! ignore line with event name
+ read(821,"(a)") string
+
+ ! read time shift
+ read(821,"(a)") string
+ read(string(12:len_trim(string)),*) t_cmt
+
+ if (NSOURCES == 1) then
+
+ ! read half duration
+ read(821,"(a)") string
+ read(string(15:len_trim(string)),*) cmt_hdur
+
+ ! read latitude
+ read(821,"(a)") string
+ read(string(10:len_trim(string)),*) cmt_lat
+
+ ! read longitude
+ read(821,"(a)") string
+ read(string(11:len_trim(string)),*) cmt_lon
+
+ ! read depth
+ read(821,"(a)") string
+ read(string(7:len_trim(string)),*) cmt_depth
+
+ else
+
+ cmt_hdur=-1e8
+ cmt_lat=-1e8
+ cmt_lon=-1e8
+ cmt_depth=-1e8
+
+ endif
+
+ close(821)
+
+ end subroutine get_event_info_serial
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_event_info.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,193 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! 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.
-!
-!=====================================================================
-
-! get information about event name and location for SAC seismograms: MPI version by Dimitri Komatitsch
-
- subroutine get_event_info_parallel(myrank,yr,jda,ho,mi,sec,t_cmt, &
- elat,elon,depth,mb,ename,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
-
-!--- input or output arguments of the subroutine below
-
- integer, intent(in) :: myrank
-
- integer, intent(out) :: NSOURCES,yr,jda,ho,mi
- real, intent(out) :: mb
- double precision, intent(out) :: t_cmt,elat,elon,depth,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,sec
- character(len=12), intent(out) :: ename
-
-!--- local variables below
-
- integer i,ier
-
- integer, parameter :: LENGTH_REGION_NAME = 150
- character(len=LENGTH_REGION_NAME) region
-
-! get event information for SAC header on the master
- if(myrank == 0) then
-
- call get_event_info_serial(yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,region, &
- cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES,LENGTH_REGION_NAME)
-
-! create the event name
- write(ename(1:12),'(a12)') region(1:12)
-
-! replace white spaces with underscores in event name
- do i=1,len_trim(ename)
- if (ename(i:i) == ' ') ename(i:i) = '_'
- enddo
-
- endif
-
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(yr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(jda,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ho,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(mi,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(sec,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(t_cmt,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(elat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(elon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(depth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(cmt_lat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(cmt_lon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(cmt_depth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(cmt_hdur,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(ename,12,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
-
- end subroutine get_event_info_parallel
-
-!=====================================================================
-
-! get information about event name and location for SAC seismograms: MPI version by Bernhard Schuberth
-! This subroutine reads the first line of the DATA/CMTSOLUTION file
-! and extracts event information needed for SAC or PITSA headers
-
- subroutine get_event_info_serial(yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,region,&
- cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES,LENGTH_REGION_NAME)
-
- implicit none
-
- include "constants.h"
-
-!--- arguments of the subroutine below
-
- integer, intent(out) :: NSOURCES,yr,jda,ho,mi
-
- real, intent(out) :: mb
-
- double precision, intent(out) :: sec,t_cmt,elat,elon,depth,cmt_lat,cmt_lon,cmt_depth,cmt_hdur
-
- integer, intent(in) :: LENGTH_REGION_NAME
- character(len=LENGTH_REGION_NAME), intent(out) :: region ! event name for SAC header
-
-!--- local variables here
-
- integer ios,icounter,mo,da,julian_day
-
- real ms
-
- character(len=5) datasource
- character(len=150) string,dummystring,CMTSOLUTION
-
-!
-!---- read hypocenter info
-!
- call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION','DATA/CMTSOLUTION')
-
- open(unit=821,file=CMTSOLUTION,iostat=ios,status='old',action='read')
- if(ios /= 0) stop 'error opening CMTSOLUTION file (in get_event_info_serial)'
-
- icounter = 0
- do while(ios == 0)
- read(821,"(a)",iostat=ios) dummystring
- if(ios == 0) icounter = icounter + 1
- enddo
- close(821)
- if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) &
- stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
- NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE
- if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
-
- open(unit=821,file=CMTSOLUTION,status='old',action='read')
-
- ! example header line of CMTSOLUTION file
- !PDE 2003 09 25 19 50 08.93 41.78 144.08 18.0 7.9 8.0 Hokkaido, Japan
- !event_id, date,origin time,latitude,longitude,depth, mb, MS, region
-
- ! read header with event information
- read(821,*) datasource,yr,mo,da,ho,mi,sec,elat,elon,depth,mb,ms,region
-
- jda=julian_day(yr,mo,da)
-
- ! ignore line with event name
- read(821,"(a)") string
-
- ! read time shift
- read(821,"(a)") string
- read(string(12:len_trim(string)),*) t_cmt
-
- if (NSOURCES == 1) then
-
- ! read half duration
- read(821,"(a)") string
- read(string(15:len_trim(string)),*) cmt_hdur
-
- ! read latitude
- read(821,"(a)") string
- read(string(10:len_trim(string)),*) cmt_lat
-
- ! read longitude
- read(821,"(a)") string
- read(string(11:len_trim(string)),*) cmt_lon
-
- ! read depth
- read(821,"(a)") string
- read(string(7:len_trim(string)),*) cmt_depth
-
- else
-
- cmt_hdur=-1e8
- cmt_lat=-1e8
- cmt_lon=-1e8
- cmt_depth=-1e8
-
- endif
-
- close(821)
-
- end subroutine get_event_info_serial
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_model.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/get_model.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -234,9 +234,6 @@
! sea99_s_model_variables
type sea99_s_model_variables
sequence
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
double precision :: sea99_ddeg
double precision :: alatmin
double precision :: alatmax
@@ -244,6 +241,9 @@
double precision :: alonmax
double precision :: sea99_vs(100,100,100)
double precision :: sea99_depth(100)
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
end type sea99_s_model_variables
type (sea99_s_model_variables) SEA99M_V
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_receivers.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_receivers.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_receivers.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_receivers.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,656 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! 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.
+!
+!=====================================================================
+
+!----
+!---- locate_receivers finds the correct position of the receivers
+!----
+
+ subroutine locate_receivers(myrank,DT,NSTEP,nspec,nglob,ibool, &
+ xstore,ystore,zstore,xigll,yigll,zigll,rec_filename, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ xi_receiver,eta_receiver,gamma_receiver,station_name,network_name,stlat,stlon,stele,nu, &
+ yr,jda,ho,mi,sec,NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
+ theta_source,phi_source, &
+ rspl,espl,espl2,nspl,ibathy_topo,RECEIVERS_CAN_BE_BURIED,NCHUNKS)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "precision.h"
+#endif
+
+ integer NPROCTOT,NCHUNKS
+
+ logical ELLIPTICITY,TOPOGRAPHY,RECEIVERS_CAN_BE_BURIED
+
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ integer nspec,nglob,nrec,myrank,nrec_found
+
+ integer yr,jda,ho,mi
+ double precision sec
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer NSTEP
+ double precision DT
+
+! arrays containing coordinates of the points
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
+
+ character(len=*) rec_filename
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ integer iorientation
+ integer iprocloop
+ double precision stazi,stdip
+
+ integer irec
+ integer i,j,k,ispec,iglob
+
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+ double precision ell
+ double precision elevation
+ double precision n(3)
+ double precision thetan,phin
+ double precision sint,cost,sinp,cosp
+ double precision r0,p20
+ double precision theta,phi
+ double precision theta_source,phi_source
+ double precision dist
+ double precision xi,eta,gamma,dx,dy,dz,dxi,deta,dgamma
+
+! topology of the control points of the surface element
+ integer iax,iay,iaz
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddr(NGNOD)
+
+! coordinates of the control points of the surface element
+ double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
+
+ integer iter_loop,ispec_iterate
+
+ integer ia
+ double precision x,y,z
+ double precision xix,xiy,xiz
+ double precision etax,etay,etaz
+ double precision gammax,gammay,gammaz
+
+! timer MPI
+ double precision time_start,tCPU
+
+ double precision distmin,final_distance_max
+
+! receiver information
+! timing information for the stations
+! station information for writing the seismograms
+ integer nsamp
+ integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+ double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
+ double precision, dimension(3,3,nrec) :: nu
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ integer, dimension(nrec) :: islice_selected_rec_found,ispec_selected_rec_found
+ double precision, dimension(nrec) :: xi_receiver_found,eta_receiver_found,gamma_receiver_found
+ double precision, dimension(3,3,nrec) :: nu_found
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name_found
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name_found
+ double precision, dimension(nrec) :: stlat_found,stlon_found,stele_found, epidist_found
+ character(len=150) STATIONS
+
+ double precision, dimension(nrec) :: stlat,stlon,stele
+
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+ integer, dimension(nrec) :: ix_initial_guess,iy_initial_guess,iz_initial_guess
+
+ double precision, dimension(nrec) :: x_target,y_target,z_target
+ double precision, dimension(nrec) :: epidist
+ double precision, dimension(nrec) :: x_found,y_found,z_found
+ double precision, dimension(nrec,0:NPROCTOT-1) :: x_found_all,y_found_all,z_found_all
+
+ double precision, dimension(nrec) :: final_distance
+ double precision, dimension(nrec,0:NPROCTOT-1) :: final_distance_all
+
+ integer, dimension(nrec,0:NPROCTOT-1) :: ispec_selected_rec_all
+ double precision, dimension(nrec) :: stbur
+ double precision, dimension(nrec,0:NPROCTOT-1) :: xi_receiver_all,eta_receiver_all,gamma_receiver_all
+
+ character(len=150) OUTPUT_FILES
+
+! **************
+
+! make sure we clean the array before the gather
+ ispec_selected_rec(:) = 0
+
+! get MPI starting time
+#ifdef USE_MPI
+ time_start = MPI_WTIME()
+#else
+ time_start = 0
+#endif
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '********************'
+ write(IMAIN,*) ' locating receivers'
+ write(IMAIN,*) '********************'
+ write(IMAIN,*)
+ endif
+
+! define topology of the control element
+ call hex_nodes(iaddx,iaddy,iaddr)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*) 'reading receiver information'
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*)
+ endif
+
+! read that STATIONS file on the master
+ if(myrank == 0) then
+ call get_value_string(STATIONS, 'solver.STATIONS', rec_filename)
+ open(unit=1,file=STATIONS,status='old',action='read')
+! loop on all the stations to read station information
+ do irec = 1,nrec
+ read(1,*) station_name(irec),network_name(irec),stlat(irec),stlon(irec),stele(irec),stbur(irec)
+ enddo
+! close receiver file
+ close(1)
+ endif
+
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(station_name,nrec*MAX_LENGTH_STATION_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(network_name,nrec*MAX_LENGTH_NETWORK_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(stlat,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(stlon,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(stele,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(stbur,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+
+! loop on all the stations to locate them in the mesh
+ do irec=1,nrec
+
+! set distance to huge initial value
+ distmin=HUGEVAL
+
+! convert geographic latitude stlat (degrees)
+! to geocentric colatitude theta (radians)
+ theta=PI/2.0d0-atan(0.99329534d0*dtan(stlat(irec)*PI/180.0d0))
+ phi=stlon(irec)*PI/180.0d0
+ call reduce(theta,phi)
+
+! compute epicentral distance
+ epidist(irec) = acos(cos(theta)*cos(theta_source) + &
+ sin(theta)*sin(theta_source)*cos(phi-phi_source))*180.0d0/PI
+
+! print some information about stations
+ if(myrank == 0) &
+ write(IMAIN,*) 'Station #',irec,': ',station_name(irec)(1:len_trim(station_name(irec))), &
+ '.',network_name(irec)(1:len_trim(network_name(irec))), &
+ ' epicentral distance: ',sngl(epidist(irec)),' degrees'
+
+! record three components for each station
+ do iorientation = 1,3
+
+! North
+ if(iorientation == 1) then
+ stazi = 0.d0
+ stdip = 0.d0
+! East
+ else if(iorientation == 2) then
+ stazi = 90.d0
+ stdip = 0.d0
+! Vertical
+ else if(iorientation == 3) then
+ stazi = 0.d0
+ stdip = - 90.d0
+ else
+ call exit_MPI(myrank,'incorrect orientation')
+ endif
+
+! get the orientation of the seismometer
+ thetan=(90.0d0+stdip)*PI/180.0d0
+ phin=stazi*PI/180.0d0
+
+! we use the same convention as in Harvard normal modes for the orientation
+
+! vertical component
+ n(1) = cos(thetan)
+! N-S component
+ n(2) = - sin(thetan)*cos(phin)
+! E-W component
+ n(3) = sin(thetan)*sin(phin)
+
+! get the Cartesian components of n in the model: nu
+ sint = sin(theta)
+ cost = cos(theta)
+ sinp = sin(phi)
+ cosp = cos(phi)
+ nu(iorientation,1,irec) = n(1)*sint*cosp+n(2)*cost*cosp-n(3)*sinp
+ nu(iorientation,2,irec) = n(1)*sint*sinp+n(2)*cost*sinp+n(3)*cosp
+ nu(iorientation,3,irec) = n(1)*cost-n(2)*sint
+
+ enddo
+
+! ellipticity
+ r0=1.0d0
+ if(ELLIPTICITY) then
+ if(TOPOGRAPHY) then
+ call get_topo_bathy(stlat(irec),stlon(irec),elevation,ibathy_topo)
+ r0 = r0 + elevation/R_EARTH
+ endif
+ cost=cos(theta)
+ p20=0.5d0*(3.0d0*cost*cost-1.0d0)
+ call spline_evaluation(rspl,espl,espl2,nspl,r0,ell)
+ r0=r0*(1.0d0-(2.0d0/3.0d0)*ell*p20)
+ endif
+
+! subtract station burial depth (in meters)
+ r0 = r0 - stbur(irec)/R_EARTH
+
+! compute the Cartesian position of the receiver
+ x_target(irec) = r0*sin(theta)*cos(phi)
+ y_target(irec) = r0*sin(theta)*sin(phi)
+ z_target(irec) = r0*cos(theta)
+
+! examine top of the elements only (receivers always at the surface)
+! k = NGLLZ
+
+ do ispec=1,nspec
+
+! loop only on points inside the element
+! exclude edges to ensure this point is not shared with other elements
+ do k=2,NGLLZ-1
+ do j=2,NGLLY-1
+ do i=2,NGLLX-1
+
+ iglob = ibool(i,j,k,ispec)
+ dist = dsqrt((x_target(irec)-dble(xstore(iglob)))**2 &
+ +(y_target(irec)-dble(ystore(iglob)))**2 &
+ +(z_target(irec)-dble(zstore(iglob)))**2)
+
+! keep this point if it is closer to the receiver
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_rec(irec) = ispec
+ ix_initial_guess(irec) = i
+ iy_initial_guess(irec) = j
+ iz_initial_guess(irec) = k
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! end of loop on all the spectral elements in current slice
+ enddo
+
+! end of loop on all the stations
+ enddo
+
+! create RECORDHEADER file with usual format for normal-mode codes
+ if(myrank == 0) then
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! create file for QmX Harvard
+! Harvard format does not support the network name
+! therefore only the station name is included below
+! compute total number of samples for normal modes with 1 sample per second
+ open(unit=1,file=trim(OUTPUT_FILES)//'/RECORDHEADERS',status='unknown',action='write')
+ nsamp = nint(dble(NSTEP-1)*DT)
+ do irec = 1,nrec
+
+ if(stele(irec) >= -999.9999) then
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHN',stlat(irec),stlon(irec),stele(irec),stbur(irec), &
+ 0.,0.,1.,nsamp,yr,jda,ho,mi,sec
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHE',stlat(irec),stlon(irec),stele(irec),stbur(irec), &
+ 90.,0.,1.,nsamp,yr,jda,ho,mi,sec
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHZ',stlat(irec),stlon(irec),stele(irec),stbur(irec), &
+ 0.,-90.,1.,nsamp,yr,jda,ho,mi,sec
+ else
+! very deep ocean-bottom stations such as H2O are not compatible
+! with the standard RECORDHEADERS format because of the f6.1 format
+! therefore suppress decimals for depth in that case
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,i6,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHN',stlat(irec),stlon(irec),nint(stele(irec)),stbur(irec), &
+ 0.,0.,1.,nsamp,yr,jda,ho,mi,sec
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,i6,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHE',stlat(irec),stlon(irec),nint(stele(irec)),stbur(irec), &
+ 90.,0.,1.,nsamp,yr,jda,ho,mi,sec
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,i6,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHZ',stlat(irec),stlon(irec),nint(stele(irec)),stbur(irec), &
+ 0.,-90.,1.,nsamp,yr,jda,ho,mi,sec
+ endif
+ enddo
+ close(1)
+
+ endif
+
+! ****************************************
+! find the best (xi,eta) for each receiver
+! ****************************************
+
+! loop on all the receivers to iterate in that slice
+ do irec = 1,nrec
+
+ ispec_iterate = ispec_selected_rec(irec)
+
+! use initial guess in xi and eta
+ xi = xigll(ix_initial_guess(irec))
+ eta = yigll(iy_initial_guess(irec))
+ gamma = zigll(iz_initial_guess(irec))
+
+! define coordinates of the control points of the element
+
+ do ia=1,NGNOD
+
+ if(iaddx(ia) == 0) then
+ iax = 1
+ else if(iaddx(ia) == 1) then
+ iax = (NGLLX+1)/2
+ else if(iaddx(ia) == 2) then
+ iax = NGLLX
+ else
+ call exit_MPI(myrank,'incorrect value of iaddx')
+ endif
+
+ if(iaddy(ia) == 0) then
+ iay = 1
+ else if(iaddy(ia) == 1) then
+ iay = (NGLLY+1)/2
+ else if(iaddy(ia) == 2) then
+ iay = NGLLY
+ else
+ call exit_MPI(myrank,'incorrect value of iaddy')
+ endif
+
+ if(iaddr(ia) == 0) then
+ iaz = 1
+ else if(iaddr(ia) == 1) then
+ iaz = (NGLLZ+1)/2
+ else if(iaddr(ia) == 2) then
+ iaz = NGLLZ
+ else
+ call exit_MPI(myrank,'incorrect value of iaddr')
+ endif
+
+ iglob = ibool(iax,iay,iaz,ispec_iterate)
+ xelm(ia) = dble(xstore(iglob))
+ yelm(ia) = dble(ystore(iglob))
+ zelm(ia) = dble(zstore(iglob))
+
+ enddo
+
+! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+! impose receiver exactly at the surface
+ if(.not. RECEIVERS_CAN_BE_BURIED) gamma = 1.d0
+
+! recompute jacobian for the new point
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+! compute distance to target location
+ dx = - (x - x_target(irec))
+ dy = - (y - y_target(irec))
+ dz = - (z - z_target(irec))
+
+! compute increments
+! gamma does not change since we know the receiver is exactly on the surface
+ dxi = xix*dx + xiy*dy + xiz*dz
+ deta = etax*dx + etay*dy + etaz*dz
+ if(RECEIVERS_CAN_BE_BURIED) dgamma = gammax*dx + gammay*dy + gammaz*dz
+
+! update values
+ xi = xi + dxi
+ eta = eta + deta
+ if(RECEIVERS_CAN_BE_BURIED) gamma = gamma + dgamma
+
+! impose that we stay in that element
+! (useful if user gives a receiver outside the mesh for instance)
+! we can go slightly outside the [1,1] segment since with finite elements
+! the polynomial solution is defined everywhere
+! can be useful for convergence of iterative scheme with distorted elements
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (eta > 1.10d0) eta = 1.10d0
+ if (eta < -1.10d0) eta = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
+
+! end of non linear iterations
+ enddo
+
+! impose receiver exactly at the surface after final iteration
+ if(.not. RECEIVERS_CAN_BE_BURIED) gamma = 1.d0
+
+! compute final coordinates of point found
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+! store xi,eta and x,y,z of point found
+ xi_receiver(irec) = xi
+ eta_receiver(irec) = eta
+ gamma_receiver(irec) = gamma
+ x_found(irec) = x
+ y_found(irec) = y
+ z_found(irec) = z
+
+! compute final distance between asked and found (converted to km)
+ final_distance(irec) = dsqrt((x_target(irec)-x_found(irec))**2 + &
+ (y_target(irec)-y_found(irec))**2 + (z_target(irec)-z_found(irec))**2)*R_EARTH/1000.d0
+
+ enddo
+
+! for MPI version, gather information from all the nodes
+ ispec_selected_rec_all(:,:) = -1
+#ifdef USE_MPI
+ call MPI_GATHER(ispec_selected_rec,nrec,MPI_INTEGER,ispec_selected_rec_all,nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_GATHER(xi_receiver,nrec,MPI_DOUBLE_PRECISION,xi_receiver_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(eta_receiver,nrec,MPI_DOUBLE_PRECISION,eta_receiver_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(gamma_receiver,nrec,MPI_DOUBLE_PRECISION,gamma_receiver_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(final_distance,nrec,MPI_DOUBLE_PRECISION,final_distance_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(x_found,nrec,MPI_DOUBLE_PRECISION,x_found_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(y_found,nrec,MPI_DOUBLE_PRECISION,y_found_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(z_found,nrec,MPI_DOUBLE_PRECISION,z_found_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+
+! this is executed by main process only
+ if(myrank == 0) then
+
+! check that the gather operation went well
+ if(any(ispec_selected_rec_all(:,:) == -1)) call exit_MPI(myrank,'gather operation failed for receivers')
+
+! MPI loop on all the results to determine the best slice
+ islice_selected_rec(:) = -1
+ do irec = 1,nrec
+ distmin = HUGEVAL
+ do iprocloop = 0,NPROCTOT-1
+ if(final_distance_all(irec,iprocloop) < distmin) then
+ distmin = final_distance_all(irec,iprocloop)
+ islice_selected_rec(irec) = iprocloop
+ ispec_selected_rec(irec) = ispec_selected_rec_all(irec,iprocloop)
+ xi_receiver(irec) = xi_receiver_all(irec,iprocloop)
+ eta_receiver(irec) = eta_receiver_all(irec,iprocloop)
+ gamma_receiver(irec) = gamma_receiver_all(irec,iprocloop)
+ x_found(irec) = x_found_all(irec,iprocloop)
+ y_found(irec) = y_found_all(irec,iprocloop)
+ z_found(irec) = z_found_all(irec,iprocloop)
+ endif
+ enddo
+ final_distance(irec) = distmin
+ enddo
+
+ nrec_found = 0
+ do irec=1,nrec
+
+ if(final_distance(irec) == HUGEVAL) call exit_MPI(myrank,'error locating receiver')
+
+ if(DISPLAY_DETAILS_STATIONS) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec)
+ write(IMAIN,*) ' original latitude: ',sngl(stlat(irec))
+ write(IMAIN,*) ' original longitude: ',sngl(stlon(irec))
+ write(IMAIN,*) ' epicentral distance: ',sngl(epidist(irec))
+ write(IMAIN,*) 'closest estimate found: ',sngl(final_distance(irec)),' km away'
+ write(IMAIN,*) ' in slice ',islice_selected_rec(irec),' in element ',ispec_selected_rec(irec)
+ write(IMAIN,*) ' at xi,eta,gamma coordinates = ',xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec)
+ endif
+
+! add warning if estimate is poor
+! (usually means receiver outside the mesh given by the user)
+ if(final_distance(irec) > THRESHOLD_EXCLUDE_STATION) then
+ write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec)
+ write(IMAIN,*) '*****************************************************************'
+ if(NCHUNKS == 6) then
+ write(IMAIN,*) '***** WARNING: receiver location estimate is poor, therefore receiver excluded *****'
+ else
+ write(IMAIN,*) '***** WARNING: receiver is located outside the mesh, therefore excluded *****'
+ endif
+ write(IMAIN,*) '*****************************************************************'
+ else
+ nrec_found = nrec_found + 1
+ islice_selected_rec_found(nrec_found) = islice_selected_rec(irec)
+ ispec_selected_rec_found(nrec_found) = ispec_selected_rec(irec)
+ xi_receiver_found(nrec_found) = xi_receiver(irec)
+ eta_receiver_found(nrec_found) = eta_receiver(irec)
+ gamma_receiver_found(nrec_found) = gamma_receiver(irec)
+ station_name_found(nrec_found) = station_name(irec)
+ network_name_found(nrec_found) = network_name(irec)
+ stlat_found(nrec_found) = stlat(irec)
+ stlon_found(nrec_found) = stlon(irec)
+ stele_found(nrec_found) = stele(irec)
+ nu_found(:,:,nrec_found) = nu(:,:,irec)
+ epidist_found(nrec_found) = epidist(irec)
+ endif
+
+ enddo
+
+! compute maximal distance for all the receivers
+ final_distance_max = maxval(final_distance(:))
+
+! display maximum error for all the receivers
+ write(IMAIN,*)
+ write(IMAIN,*) 'maximum error in location of all the receivers: ',sngl(final_distance_max),' km'
+
+! add warning if estimate is poor
+! (usually means receiver outside the mesh given by the user)
+ if(final_distance_max > THRESHOLD_EXCLUDE_STATION) then
+ write(IMAIN,*)
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '***** WARNING: at least one receiver was excluded from the station list *****'
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '************************************************************'
+ endif
+
+ nrec = nrec_found
+ islice_selected_rec(1:nrec) = islice_selected_rec_found(1:nrec)
+ ispec_selected_rec(1:nrec) = ispec_selected_rec_found(1:nrec)
+ xi_receiver(1:nrec) = xi_receiver_found(1:nrec)
+ eta_receiver(1:nrec) = eta_receiver_found(1:nrec)
+ gamma_receiver(1:nrec) = gamma_receiver_found(1:nrec)
+ station_name(1:nrec) = station_name_found(1:nrec)
+ network_name(1:nrec) = network_name_found(1:nrec)
+ stlat(1:nrec) = stlat_found(1:nrec)
+ stlon(1:nrec) = stlon_found(1:nrec)
+ stele(1:nrec) = stele_found(1:nrec)
+ nu(:,:,1:nrec) = nu_found(:,:,1:nrec)
+ epidist(1:nrec) = epidist_found(1:nrec)
+
+! write the list of stations and associated epicentral distance
+ open(unit=27,file=trim(OUTPUT_FILES)//'/output_list_stations.txt',status='unknown',action='write')
+ write(27,*)
+ write(27,*) 'total number of stations: ',nrec
+ write(27,*)
+ do irec=1,nrec
+ write(27,*) station_name(irec)(1:len_trim(station_name(irec))), &
+ '.',network_name(irec)(1:len_trim(network_name(irec))), &
+ ' epicentral distance ',sngl(epidist(irec)),' deg'
+ enddo
+ close(27)
+
+! elapsed time since beginning of mesh generation
+#ifdef USE_MPI
+ tCPU = MPI_WTIME() - time_start
+#else
+ tCPU = 0
+#endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for receiver detection in seconds = ',tCPU
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of receiver detection - done'
+ write(IMAIN,*)
+
+ endif ! end of section executed by main process only
+
+! main process broadcasts the results to all the slices
+#ifdef USE_MPI
+ call MPI_BCAST(nrec,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(islice_selected_rec,nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ispec_selected_rec,nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(xi_receiver,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eta_receiver,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(gamma_receiver,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(station_name,nrec*MAX_LENGTH_STATION_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(network_name,nrec*MAX_LENGTH_NETWORK_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(stlat,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(stlon,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(stele,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(nu,nrec*3*3,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+
+ end subroutine locate_receivers
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_receivers.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_receivers.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,635 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! 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.
-!
-!=====================================================================
-
-!----
-!---- locate_receivers finds the correct position of the receivers
-!----
-
- subroutine locate_receivers(myrank,DT,NSTEP,nspec,nglob,ibool, &
- xstore,ystore,zstore,xigll,yigll,zigll,rec_filename, &
- nrec,islice_selected_rec,ispec_selected_rec, &
- xi_receiver,eta_receiver,gamma_receiver,station_name,network_name,stlat,stlon,stele,nu, &
- yr,jda,ho,mi,sec,NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
- theta_source,phi_source, &
- rspl,espl,espl2,nspl,ibathy_topo,RECEIVERS_CAN_BE_BURIED,NCHUNKS)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
- integer NPROCTOT,NCHUNKS
-
- logical ELLIPTICITY,TOPOGRAPHY,RECEIVERS_CAN_BE_BURIED
-
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
- integer nspec,nglob,nrec,myrank,nrec_found
-
- integer yr,jda,ho,mi
- double precision sec
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
- integer NSTEP
- double precision DT
-
-! arrays containing coordinates of the points
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
-
-! Gauss-Lobatto-Legendre points of integration
- double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
-
- character(len=*) rec_filename
-
-! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
- integer iorientation
- integer iprocloop
- double precision stazi,stdip
-
- integer irec
- integer i,j,k,ispec,iglob
- integer ier
-
- double precision ell
- double precision elevation
- double precision n(3)
- double precision thetan,phin
- double precision sint,cost,sinp,cosp
- double precision r0,p20
- double precision theta,phi
- double precision theta_source,phi_source
- double precision dist
- double precision xi,eta,gamma,dx,dy,dz,dxi,deta,dgamma
-
-! topology of the control points of the surface element
- integer iax,iay,iaz
- integer iaddx(NGNOD),iaddy(NGNOD),iaddr(NGNOD)
-
-! coordinates of the control points of the surface element
- double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
-
- integer iter_loop,ispec_iterate
-
- integer ia
- double precision x,y,z
- double precision xix,xiy,xiz
- double precision etax,etay,etaz
- double precision gammax,gammay,gammaz
-
-! timer MPI
- double precision time_start,tCPU
-
- double precision distmin,final_distance_max
-
-! receiver information
-! timing information for the stations
-! station information for writing the seismograms
- integer nsamp
- integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
- double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
- double precision, dimension(3,3,nrec) :: nu
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- integer, dimension(nrec) :: islice_selected_rec_found,ispec_selected_rec_found
- double precision, dimension(nrec) :: xi_receiver_found,eta_receiver_found,gamma_receiver_found
- double precision, dimension(3,3,nrec) :: nu_found
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name_found
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name_found
- double precision, dimension(nrec) :: stlat_found,stlon_found,stele_found, epidist_found
- character(len=150) STATIONS
-
- double precision, dimension(nrec) :: stlat,stlon,stele
-
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
- integer, dimension(nrec) :: ix_initial_guess,iy_initial_guess,iz_initial_guess
-
- double precision, dimension(nrec) :: x_target,y_target,z_target
- double precision, dimension(nrec) :: epidist
- double precision, dimension(nrec) :: x_found,y_found,z_found
- double precision, dimension(nrec,0:NPROCTOT-1) :: x_found_all,y_found_all,z_found_all
-
- double precision, dimension(nrec) :: final_distance
- double precision, dimension(nrec,0:NPROCTOT-1) :: final_distance_all
-
- integer, dimension(nrec,0:NPROCTOT-1) :: ispec_selected_rec_all
- double precision, dimension(nrec) :: stbur
- double precision, dimension(nrec,0:NPROCTOT-1) :: xi_receiver_all,eta_receiver_all,gamma_receiver_all
-
- character(len=150) OUTPUT_FILES
-
-! **************
-
-! make sure we clean the array before the gather
- ispec_selected_rec(:) = 0
-
-! get MPI starting time
- time_start = MPI_WTIME()
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '********************'
- write(IMAIN,*) ' locating receivers'
- write(IMAIN,*) '********************'
- write(IMAIN,*)
- endif
-
-! define topology of the control element
- call hex_nodes(iaddx,iaddy,iaddr)
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '****************************'
- write(IMAIN,*) 'reading receiver information'
- write(IMAIN,*) '****************************'
- write(IMAIN,*)
- endif
-
-! read that STATIONS file on the master
- if(myrank == 0) then
- call get_value_string(STATIONS, 'solver.STATIONS', rec_filename)
- open(unit=1,file=STATIONS,status='old',action='read')
-! loop on all the stations to read station information
- do irec = 1,nrec
- read(1,*) station_name(irec),network_name(irec),stlat(irec),stlon(irec),stele(irec),stbur(irec)
- enddo
-! close receiver file
- close(1)
- endif
-
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(station_name,nrec*MAX_LENGTH_STATION_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(network_name,nrec*MAX_LENGTH_NETWORK_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(stlat,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(stlon,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(stele,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(stbur,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
-! loop on all the stations to locate them in the mesh
- do irec=1,nrec
-
-! set distance to huge initial value
- distmin=HUGEVAL
-
-! convert geographic latitude stlat (degrees)
-! to geocentric colatitude theta (radians)
- theta=PI/2.0d0-atan(0.99329534d0*dtan(stlat(irec)*PI/180.0d0))
- phi=stlon(irec)*PI/180.0d0
- call reduce(theta,phi)
-
-! compute epicentral distance
- epidist(irec) = acos(cos(theta)*cos(theta_source) + &
- sin(theta)*sin(theta_source)*cos(phi-phi_source))*180.0d0/PI
-
-! print some information about stations
- if(myrank == 0) &
- write(IMAIN,*) 'Station #',irec,': ',station_name(irec)(1:len_trim(station_name(irec))), &
- '.',network_name(irec)(1:len_trim(network_name(irec))), &
- ' epicentral distance: ',sngl(epidist(irec)),' degrees'
-
-! record three components for each station
- do iorientation = 1,3
-
-! North
- if(iorientation == 1) then
- stazi = 0.d0
- stdip = 0.d0
-! East
- else if(iorientation == 2) then
- stazi = 90.d0
- stdip = 0.d0
-! Vertical
- else if(iorientation == 3) then
- stazi = 0.d0
- stdip = - 90.d0
- else
- call exit_MPI(myrank,'incorrect orientation')
- endif
-
-! get the orientation of the seismometer
- thetan=(90.0d0+stdip)*PI/180.0d0
- phin=stazi*PI/180.0d0
-
-! we use the same convention as in Harvard normal modes for the orientation
-
-! vertical component
- n(1) = cos(thetan)
-! N-S component
- n(2) = - sin(thetan)*cos(phin)
-! E-W component
- n(3) = sin(thetan)*sin(phin)
-
-! get the Cartesian components of n in the model: nu
- sint = sin(theta)
- cost = cos(theta)
- sinp = sin(phi)
- cosp = cos(phi)
- nu(iorientation,1,irec) = n(1)*sint*cosp+n(2)*cost*cosp-n(3)*sinp
- nu(iorientation,2,irec) = n(1)*sint*sinp+n(2)*cost*sinp+n(3)*cosp
- nu(iorientation,3,irec) = n(1)*cost-n(2)*sint
-
- enddo
-
-! ellipticity
- r0=1.0d0
- if(ELLIPTICITY) then
- if(TOPOGRAPHY) then
- call get_topo_bathy(stlat(irec),stlon(irec),elevation,ibathy_topo)
- r0 = r0 + elevation/R_EARTH
- endif
- cost=cos(theta)
- p20=0.5d0*(3.0d0*cost*cost-1.0d0)
- call spline_evaluation(rspl,espl,espl2,nspl,r0,ell)
- r0=r0*(1.0d0-(2.0d0/3.0d0)*ell*p20)
- endif
-
-! subtract station burial depth (in meters)
- r0 = r0 - stbur(irec)/R_EARTH
-
-! compute the Cartesian position of the receiver
- x_target(irec) = r0*sin(theta)*cos(phi)
- y_target(irec) = r0*sin(theta)*sin(phi)
- z_target(irec) = r0*cos(theta)
-
-! examine top of the elements only (receivers always at the surface)
-! k = NGLLZ
-
- do ispec=1,nspec
-
-! loop only on points inside the element
-! exclude edges to ensure this point is not shared with other elements
- do k=2,NGLLZ-1
- do j=2,NGLLY-1
- do i=2,NGLLX-1
-
- iglob = ibool(i,j,k,ispec)
- dist = dsqrt((x_target(irec)-dble(xstore(iglob)))**2 &
- +(y_target(irec)-dble(ystore(iglob)))**2 &
- +(z_target(irec)-dble(zstore(iglob)))**2)
-
-! keep this point if it is closer to the receiver
- if(dist < distmin) then
- distmin = dist
- ispec_selected_rec(irec) = ispec
- ix_initial_guess(irec) = i
- iy_initial_guess(irec) = j
- iz_initial_guess(irec) = k
- endif
-
- enddo
- enddo
- enddo
-
-! end of loop on all the spectral elements in current slice
- enddo
-
-! end of loop on all the stations
- enddo
-
-! create RECORDHEADER file with usual format for normal-mode codes
- if(myrank == 0) then
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! create file for QmX Harvard
-! Harvard format does not support the network name
-! therefore only the station name is included below
-! compute total number of samples for normal modes with 1 sample per second
- open(unit=1,file=trim(OUTPUT_FILES)//'/RECORDHEADERS',status='unknown',action='write')
- nsamp = nint(dble(NSTEP-1)*DT)
- do irec = 1,nrec
-
- if(stele(irec) >= -999.9999) then
- write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
- station_name(irec),'LHN',stlat(irec),stlon(irec),stele(irec),stbur(irec), &
- 0.,0.,1.,nsamp,yr,jda,ho,mi,sec
- write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
- station_name(irec),'LHE',stlat(irec),stlon(irec),stele(irec),stbur(irec), &
- 90.,0.,1.,nsamp,yr,jda,ho,mi,sec
- write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
- station_name(irec),'LHZ',stlat(irec),stlon(irec),stele(irec),stbur(irec), &
- 0.,-90.,1.,nsamp,yr,jda,ho,mi,sec
- else
-! very deep ocean-bottom stations such as H2O are not compatible
-! with the standard RECORDHEADERS format because of the f6.1 format
-! therefore suppress decimals for depth in that case
- write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,i6,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
- station_name(irec),'LHN',stlat(irec),stlon(irec),nint(stele(irec)),stbur(irec), &
- 0.,0.,1.,nsamp,yr,jda,ho,mi,sec
- write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,i6,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
- station_name(irec),'LHE',stlat(irec),stlon(irec),nint(stele(irec)),stbur(irec), &
- 90.,0.,1.,nsamp,yr,jda,ho,mi,sec
- write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,i6,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
- station_name(irec),'LHZ',stlat(irec),stlon(irec),nint(stele(irec)),stbur(irec), &
- 0.,-90.,1.,nsamp,yr,jda,ho,mi,sec
- endif
- enddo
- close(1)
-
- endif
-
-! ****************************************
-! find the best (xi,eta) for each receiver
-! ****************************************
-
-! loop on all the receivers to iterate in that slice
- do irec = 1,nrec
-
- ispec_iterate = ispec_selected_rec(irec)
-
-! use initial guess in xi and eta
- xi = xigll(ix_initial_guess(irec))
- eta = yigll(iy_initial_guess(irec))
- gamma = zigll(iz_initial_guess(irec))
-
-! define coordinates of the control points of the element
-
- do ia=1,NGNOD
-
- if(iaddx(ia) == 0) then
- iax = 1
- else if(iaddx(ia) == 1) then
- iax = (NGLLX+1)/2
- else if(iaddx(ia) == 2) then
- iax = NGLLX
- else
- call exit_MPI(myrank,'incorrect value of iaddx')
- endif
-
- if(iaddy(ia) == 0) then
- iay = 1
- else if(iaddy(ia) == 1) then
- iay = (NGLLY+1)/2
- else if(iaddy(ia) == 2) then
- iay = NGLLY
- else
- call exit_MPI(myrank,'incorrect value of iaddy')
- endif
-
- if(iaddr(ia) == 0) then
- iaz = 1
- else if(iaddr(ia) == 1) then
- iaz = (NGLLZ+1)/2
- else if(iaddr(ia) == 2) then
- iaz = NGLLZ
- else
- call exit_MPI(myrank,'incorrect value of iaddr')
- endif
-
- iglob = ibool(iax,iay,iaz,ispec_iterate)
- xelm(ia) = dble(xstore(iglob))
- yelm(ia) = dble(ystore(iglob))
- zelm(ia) = dble(zstore(iglob))
-
- enddo
-
-! iterate to solve the non linear system
- do iter_loop = 1,NUM_ITER
-
-! impose receiver exactly at the surface
- if(.not. RECEIVERS_CAN_BE_BURIED) gamma = 1.d0
-
-! recompute jacobian for the new point
- call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
-
-! compute distance to target location
- dx = - (x - x_target(irec))
- dy = - (y - y_target(irec))
- dz = - (z - z_target(irec))
-
-! compute increments
-! gamma does not change since we know the receiver is exactly on the surface
- dxi = xix*dx + xiy*dy + xiz*dz
- deta = etax*dx + etay*dy + etaz*dz
- if(RECEIVERS_CAN_BE_BURIED) dgamma = gammax*dx + gammay*dy + gammaz*dz
-
-! update values
- xi = xi + dxi
- eta = eta + deta
- if(RECEIVERS_CAN_BE_BURIED) gamma = gamma + dgamma
-
-! impose that we stay in that element
-! (useful if user gives a receiver outside the mesh for instance)
-! we can go slightly outside the [1,1] segment since with finite elements
-! the polynomial solution is defined everywhere
-! can be useful for convergence of iterative scheme with distorted elements
- if (xi > 1.10d0) xi = 1.10d0
- if (xi < -1.10d0) xi = -1.10d0
- if (eta > 1.10d0) eta = 1.10d0
- if (eta < -1.10d0) eta = -1.10d0
- if (gamma > 1.10d0) gamma = 1.10d0
- if (gamma < -1.10d0) gamma = -1.10d0
-
-! end of non linear iterations
- enddo
-
-! impose receiver exactly at the surface after final iteration
- if(.not. RECEIVERS_CAN_BE_BURIED) gamma = 1.d0
-
-! compute final coordinates of point found
- call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
-
-! store xi,eta and x,y,z of point found
- xi_receiver(irec) = xi
- eta_receiver(irec) = eta
- gamma_receiver(irec) = gamma
- x_found(irec) = x
- y_found(irec) = y
- z_found(irec) = z
-
-! compute final distance between asked and found (converted to km)
- final_distance(irec) = dsqrt((x_target(irec)-x_found(irec))**2 + &
- (y_target(irec)-y_found(irec))**2 + (z_target(irec)-z_found(irec))**2)*R_EARTH/1000.d0
-
- enddo
-
-! for MPI version, gather information from all the nodes
- ispec_selected_rec_all(:,:) = -1
- call MPI_GATHER(ispec_selected_rec,nrec,MPI_INTEGER,ispec_selected_rec_all,nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_GATHER(xi_receiver,nrec,MPI_DOUBLE_PRECISION,xi_receiver_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(eta_receiver,nrec,MPI_DOUBLE_PRECISION,eta_receiver_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(gamma_receiver,nrec,MPI_DOUBLE_PRECISION,gamma_receiver_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(final_distance,nrec,MPI_DOUBLE_PRECISION,final_distance_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(x_found,nrec,MPI_DOUBLE_PRECISION,x_found_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(y_found,nrec,MPI_DOUBLE_PRECISION,y_found_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(z_found,nrec,MPI_DOUBLE_PRECISION,z_found_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
-! this is executed by main process only
- if(myrank == 0) then
-
-! check that the gather operation went well
- if(any(ispec_selected_rec_all(:,:) == -1)) call exit_MPI(myrank,'gather operation failed for receivers')
-
-! MPI loop on all the results to determine the best slice
- islice_selected_rec(:) = -1
- do irec = 1,nrec
- distmin = HUGEVAL
- do iprocloop = 0,NPROCTOT-1
- if(final_distance_all(irec,iprocloop) < distmin) then
- distmin = final_distance_all(irec,iprocloop)
- islice_selected_rec(irec) = iprocloop
- ispec_selected_rec(irec) = ispec_selected_rec_all(irec,iprocloop)
- xi_receiver(irec) = xi_receiver_all(irec,iprocloop)
- eta_receiver(irec) = eta_receiver_all(irec,iprocloop)
- gamma_receiver(irec) = gamma_receiver_all(irec,iprocloop)
- x_found(irec) = x_found_all(irec,iprocloop)
- y_found(irec) = y_found_all(irec,iprocloop)
- z_found(irec) = z_found_all(irec,iprocloop)
- endif
- enddo
- final_distance(irec) = distmin
- enddo
-
- nrec_found = 0
- do irec=1,nrec
-
- if(final_distance(irec) == HUGEVAL) call exit_MPI(myrank,'error locating receiver')
-
- if(DISPLAY_DETAILS_STATIONS) then
- write(IMAIN,*)
- write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec)
- write(IMAIN,*) ' original latitude: ',sngl(stlat(irec))
- write(IMAIN,*) ' original longitude: ',sngl(stlon(irec))
- write(IMAIN,*) ' epicentral distance: ',sngl(epidist(irec))
- write(IMAIN,*) 'closest estimate found: ',sngl(final_distance(irec)),' km away'
- write(IMAIN,*) ' in slice ',islice_selected_rec(irec),' in element ',ispec_selected_rec(irec)
- write(IMAIN,*) ' at xi,eta,gamma coordinates = ',xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec)
- endif
-
-! add warning if estimate is poor
-! (usually means receiver outside the mesh given by the user)
- if(final_distance(irec) > THRESHOLD_EXCLUDE_STATION) then
- write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec)
- write(IMAIN,*) '*****************************************************************'
- if(NCHUNKS == 6) then
- write(IMAIN,*) '***** WARNING: receiver location estimate is poor, therefore receiver excluded *****'
- else
- write(IMAIN,*) '***** WARNING: receiver is located outside the mesh, therefore excluded *****'
- endif
- write(IMAIN,*) '*****************************************************************'
- else
- nrec_found = nrec_found + 1
- islice_selected_rec_found(nrec_found) = islice_selected_rec(irec)
- ispec_selected_rec_found(nrec_found) = ispec_selected_rec(irec)
- xi_receiver_found(nrec_found) = xi_receiver(irec)
- eta_receiver_found(nrec_found) = eta_receiver(irec)
- gamma_receiver_found(nrec_found) = gamma_receiver(irec)
- station_name_found(nrec_found) = station_name(irec)
- network_name_found(nrec_found) = network_name(irec)
- stlat_found(nrec_found) = stlat(irec)
- stlon_found(nrec_found) = stlon(irec)
- stele_found(nrec_found) = stele(irec)
- nu_found(:,:,nrec_found) = nu(:,:,irec)
- epidist_found(nrec_found) = epidist(irec)
- endif
-
- enddo
-
-! compute maximal distance for all the receivers
- final_distance_max = maxval(final_distance(:))
-
-! display maximum error for all the receivers
- write(IMAIN,*)
- write(IMAIN,*) 'maximum error in location of all the receivers: ',sngl(final_distance_max),' km'
-
-! add warning if estimate is poor
-! (usually means receiver outside the mesh given by the user)
- if(final_distance_max > THRESHOLD_EXCLUDE_STATION) then
- write(IMAIN,*)
- write(IMAIN,*) '************************************************************'
- write(IMAIN,*) '************************************************************'
- write(IMAIN,*) '***** WARNING: at least one receiver was excluded from the station list *****'
- write(IMAIN,*) '************************************************************'
- write(IMAIN,*) '************************************************************'
- endif
-
- nrec = nrec_found
- islice_selected_rec(1:nrec) = islice_selected_rec_found(1:nrec)
- ispec_selected_rec(1:nrec) = ispec_selected_rec_found(1:nrec)
- xi_receiver(1:nrec) = xi_receiver_found(1:nrec)
- eta_receiver(1:nrec) = eta_receiver_found(1:nrec)
- gamma_receiver(1:nrec) = gamma_receiver_found(1:nrec)
- station_name(1:nrec) = station_name_found(1:nrec)
- network_name(1:nrec) = network_name_found(1:nrec)
- stlat(1:nrec) = stlat_found(1:nrec)
- stlon(1:nrec) = stlon_found(1:nrec)
- stele(1:nrec) = stele_found(1:nrec)
- nu(:,:,1:nrec) = nu_found(:,:,1:nrec)
- epidist(1:nrec) = epidist_found(1:nrec)
-
-! write the list of stations and associated epicentral distance
- open(unit=27,file=trim(OUTPUT_FILES)//'/output_list_stations.txt',status='unknown',action='write')
- write(27,*)
- write(27,*) 'total number of stations: ',nrec
- write(27,*)
- do irec=1,nrec
- write(27,*) station_name(irec)(1:len_trim(station_name(irec))), &
- '.',network_name(irec)(1:len_trim(network_name(irec))), &
- ' epicentral distance ',sngl(epidist(irec)),' deg'
- enddo
- close(27)
-
-! elapsed time since beginning of mesh generation
- tCPU = MPI_WTIME() - time_start
- write(IMAIN,*)
- write(IMAIN,*) 'Elapsed time for receiver detection in seconds = ',tCPU
- write(IMAIN,*)
- write(IMAIN,*) 'End of receiver detection - done'
- write(IMAIN,*)
-
- endif ! end of section executed by main process only
-
-! main process broadcasts the results to all the slices
- call MPI_BCAST(nrec,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(islice_selected_rec,nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ispec_selected_rec,nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(xi_receiver,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(eta_receiver,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(gamma_receiver,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(station_name,nrec*MAX_LENGTH_STATION_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(network_name,nrec*MAX_LENGTH_NETWORK_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(stlat,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(stlon,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(stele,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(nu,nrec*3*3,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- end subroutine locate_receivers
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_sources.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_sources.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_sources.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_sources.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,701 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! 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.
+!
+!=====================================================================
+
+!----
+!---- locate_sources finds the correct position of the sources
+!----
+
+ subroutine locate_sources(NSOURCES,myrank,nspec,nglob,ibool,&
+ xstore,ystore,zstore,xigll,yigll,zigll, &
+ NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
+ sec,t_cmt,yr,jda,ho,mi,theta_source,phi_source, &
+ NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source, nu_source, &
+ rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "precision.h"
+#endif
+
+ integer NPROCTOT
+ integer NSTEP,NSOURCES,NEX_XI
+
+ logical ELLIPTICITY,TOPOGRAPHY,PRINT_SOURCE_TIME_FUNCTION
+
+ double precision DT
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ integer nspec,nglob,myrank,isource
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+! arrays containing coordinates of the points
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
+
+ double precision nu_source(NDIM,NDIM,NSOURCES)
+
+ integer yr,jda,ho,mi
+
+ double precision sec
+ double precision t_cmt(NSOURCES)
+ double precision t0, hdur_gaussian(NSOURCES)
+
+ integer iprocloop
+
+ integer i,j,k,ispec,iglob
+
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+ double precision ell
+ double precision elevation
+ double precision r0,dcost,p20
+ double precision theta,phi
+ double precision, dimension(NSOURCES) :: theta_source,phi_source
+ double precision dist,typical_size
+ double precision xi,eta,gamma,dx,dy,dz,dxi,deta
+
+! topology of the control points of the surface element
+ integer iax,iay,iaz
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddr(NGNOD)
+
+! coordinates of the control points of the surface element
+ double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
+
+ integer iter_loop
+
+ integer ia
+ double precision x,y,z
+ double precision xix,xiy,xiz
+ double precision etax,etay,etaz
+ double precision gammax,gammay,gammaz
+ double precision dgamma
+
+ double precision final_distance_source(NSOURCES)
+
+ double precision x_target_source,y_target_source,z_target_source
+ double precision r_target_source
+
+ integer islice_selected_source(NSOURCES)
+
+! timer MPI
+ double precision time_start,tCPU
+
+ integer isources_already_done,isource_in_this_subset
+ integer ispec_selected_source(NSOURCES)
+
+ double precision hdur(NSOURCES)
+
+ double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+
+ double precision, dimension(NSOURCES) :: lat,long,depth
+ double precision scalar_moment
+ double precision moment_tensor(6,NSOURCES)
+ double precision radius
+
+ character(len=150) OUTPUT_FILES,plot_file
+
+ double precision r_found_source
+ double precision st,ct,sp,cp
+ double precision Mrr,Mtt,Mpp,Mrt,Mrp,Mtp
+ double precision colat_source
+ double precision distmin
+
+ integer :: ix_initial_guess_source,iy_initial_guess_source,iz_initial_guess_source,NSOURCES_SUBSET_current_size
+
+ logical located_target
+
+! for calculation of source time function and spectrum
+ integer it,iom
+ double precision time_source,om
+ double precision, external :: comp_source_time_function,comp_source_spectrum
+
+! number of points to plot the source time function and spectrum
+ integer, parameter :: NSAMP_PLOT_SOURCE = 1000
+
+ integer iorientation
+ double precision stazi,stdip,thetan,phin,n(3)
+
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+ double precision, dimension(NSOURCES_SUBSET_MAX) :: final_distance_source_subset
+
+ integer, dimension(NSOURCES_SUBSET_MAX) :: ispec_selected_source_subset
+
+ integer, dimension(0:NPROCTOT-1,NSOURCES_SUBSET_MAX) :: ispec_selected_source_all
+
+ double precision, dimension(0:NPROCTOT-1,NSOURCES_SUBSET_MAX) :: xi_source_all,eta_source_all,gamma_source_all, &
+ final_distance_source_all,x_found_source_all,y_found_source_all,z_found_source_all
+
+ double precision, dimension(NSOURCES_SUBSET_MAX) :: xi_source_subset,eta_source_subset,gamma_source_subset
+
+ double precision, dimension(NSOURCES_SUBSET_MAX) :: x_found_source,y_found_source,z_found_source
+
+! **************
+
+! make sure we clean the future final array
+ ispec_selected_source(:) = 0
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! read all the sources
+ if(myrank == 0) call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,NSOURCES)
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(yr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(jda,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ho,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(mi,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(sec,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(t_cmt,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(hdur,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(lat,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(long,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(depth,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(moment_tensor,6*NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+
+! define topology of the control element
+ call hex_nodes(iaddx,iaddy,iaddr)
+
+! get MPI starting time for all sources
+#ifdef USE_MPI
+ time_start = MPI_WTIME()
+#else
+ time_start = 0
+#endif
+
+! convert the half duration for triangle STF to the one for gaussian STF
+ hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
+
+! define t0 as the earliest start time
+ t0 = - 1.5d0*minval(t_cmt-hdur)
+
+! loop on all the sources
+! gather source information in subsets to reduce memory requirements
+
+! loop over subsets of sources
+ do isources_already_done = 0, NSOURCES, NSOURCES_SUBSET_MAX
+
+! the size of the subset can be the maximum size, or less (if we are in the last subset,
+! or if there are fewer sources than the maximum size of a subset)
+ NSOURCES_SUBSET_current_size = min(NSOURCES_SUBSET_MAX, NSOURCES - isources_already_done)
+
+! make sure we clean the subset array before the gather
+ ispec_selected_source_subset(:) = 0
+
+! loop over sources within this subset
+ do isource_in_this_subset = 1,NSOURCES_SUBSET_current_size
+
+! mapping from source number in current subset to real source number in all the subsets
+ isource = isource_in_this_subset + isources_already_done
+
+! convert geographic latitude lat (degrees)
+! to geocentric colatitude theta (radians)
+ theta=PI/2.0d0-atan(0.99329534d0*dtan(lat(isource)*PI/180.0d0))
+ phi=long(isource)*PI/180.0d0
+ call reduce(theta,phi)
+
+! get the moment tensor
+ Mrr = moment_tensor(1,isource)
+ Mtt = moment_tensor(2,isource)
+ Mpp = moment_tensor(3,isource)
+ Mrt = moment_tensor(4,isource)
+ Mrp = moment_tensor(5,isource)
+ Mtp = moment_tensor(6,isource)
+
+! convert from a spherical to a Cartesian representation of the moment tensor
+ st=dsin(theta)
+ ct=dcos(theta)
+ sp=dsin(phi)
+ cp=dcos(phi)
+
+ Mxx(isource)=st*st*cp*cp*Mrr+ct*ct*cp*cp*Mtt+sp*sp*Mpp &
+ +2.0d0*st*ct*cp*cp*Mrt-2.0d0*st*sp*cp*Mrp-2.0d0*ct*sp*cp*Mtp
+ Myy(isource)=st*st*sp*sp*Mrr+ct*ct*sp*sp*Mtt+cp*cp*Mpp &
+ +2.0d0*st*ct*sp*sp*Mrt+2.0d0*st*sp*cp*Mrp+2.0d0*ct*sp*cp*Mtp
+ Mzz(isource)=ct*ct*Mrr+st*st*Mtt-2.0d0*st*ct*Mrt
+ Mxy(isource)=st*st*sp*cp*Mrr+ct*ct*sp*cp*Mtt-sp*cp*Mpp &
+ +2.0d0*st*ct*sp*cp*Mrt+st*(cp*cp-sp*sp)*Mrp+ct*(cp*cp-sp*sp)*Mtp
+ Mxz(isource)=st*ct*cp*Mrr-st*ct*cp*Mtt &
+ +(ct*ct-st*st)*cp*Mrt-ct*sp*Mrp+st*sp*Mtp
+ Myz(isource)=st*ct*sp*Mrr-st*ct*sp*Mtt &
+ +(ct*ct-st*st)*sp*Mrt+ct*cp*Mrp-st*cp*Mtp
+
+! record three components for each station
+ do iorientation = 1,3
+
+! North
+ if(iorientation == 1) then
+ stazi = 0.d0
+ stdip = 0.d0
+! East
+ else if(iorientation == 2) then
+ stazi = 90.d0
+ stdip = 0.d0
+! Vertical
+ else if(iorientation == 3) then
+ stazi = 0.d0
+ stdip = - 90.d0
+ else
+ call exit_MPI(myrank,'incorrect orientation')
+ endif
+
+! get the orientation of the seismometer
+ thetan=(90.0d0+stdip)*PI/180.0d0
+ phin=stazi*PI/180.0d0
+
+! we use the same convention as in Harvard normal modes for the orientation
+
+! vertical component
+ n(1) = dcos(thetan)
+! N-S component
+ n(2) = - dsin(thetan)*dcos(phin)
+! E-W component
+ n(3) = dsin(thetan)*dsin(phin)
+
+! get the Cartesian components of n in the model: nu
+ nu_source(iorientation,1,isource) = n(1)*st*cp+n(2)*ct*cp-n(3)*sp
+ nu_source(iorientation,2,isource) = n(1)*st*sp+n(2)*ct*sp+n(3)*cp
+ nu_source(iorientation,3,isource) = n(1)*ct-n(2)*st
+
+ enddo
+
+! normalized source radius
+ r0 = R_UNIT_SPHERE
+
+ if(ELLIPTICITY) then
+ if(TOPOGRAPHY) then
+ call get_topo_bathy(lat(isource),long(isource),elevation,ibathy_topo)
+ r0 = r0 + elevation/R_EARTH
+ endif
+ dcost = dcos(theta)
+ p20 = 0.5d0*(3.0d0*dcost*dcost-1.0d0)
+ radius = r0 - depth(isource)*1000.0d0/R_EARTH
+ call spline_evaluation(rspl,espl,espl2,nspl,radius,ell)
+ r0 = r0*(1.0d0-(2.0d0/3.0d0)*ell*p20)
+ endif
+
+! compute the Cartesian position of the source
+ r_target_source = r0 - depth(isource)*1000.0d0/R_EARTH
+ x_target_source = r_target_source*dsin(theta)*dcos(phi)
+ y_target_source = r_target_source*dsin(theta)*dsin(phi)
+ z_target_source = r_target_source*dcos(theta)
+
+! set distance to huge initial value
+ distmin = HUGEVAL
+
+! compute typical size of elements at the surface
+ typical_size = TWO_PI * R_UNIT_SPHERE / (4.*NEX_XI)
+
+! use 10 times the distance as a criterion for source detection
+ typical_size = 10. * typical_size
+
+! flag to check that we located at least one target element
+ located_target = .false.
+
+ do ispec = 1,nspec
+
+! exclude elements that are too far from target
+ iglob = ibool(1,1,1,ispec)
+ dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
+ + (y_target_source - dble(ystore(iglob)))**2 &
+ + (z_target_source - dble(zstore(iglob)))**2)
+ if(USE_DISTANCE_CRITERION .and. dist > typical_size) cycle
+
+ located_target = .true.
+
+! loop only on points inside the element
+! exclude edges to ensure this point is not shared with other elements
+ do k = 2,NGLLZ-1
+ do j = 2,NGLLY-1
+ do i = 2,NGLLX-1
+
+! keep this point if it is closer to the receiver
+ iglob = ibool(i,j,k,ispec)
+ dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
+ +(y_target_source - dble(ystore(iglob)))**2 &
+ +(z_target_source - dble(zstore(iglob)))**2)
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_source_subset(isource_in_this_subset) = ispec
+ ix_initial_guess_source = i
+ iy_initial_guess_source = j
+ iz_initial_guess_source = k
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! end of loop on all the elements in current slice
+ enddo
+
+! *******************************************
+! find the best (xi,eta,gamma) for the source
+! *******************************************
+
+! if we have not located a target element, the source is not in this slice
+! therefore use first element only for fictitious iterative search
+ if(.not. located_target) then
+ ispec_selected_source_subset(isource_in_this_subset)=1
+ ix_initial_guess_source = 2
+ iy_initial_guess_source = 2
+ iz_initial_guess_source = 2
+ endif
+
+! use initial guess in xi, eta and gamma
+ xi = xigll(ix_initial_guess_source)
+ eta = yigll(iy_initial_guess_source)
+ gamma = zigll(iz_initial_guess_source)
+
+! define coordinates of the control points of the element
+
+ do ia=1,NGNOD
+
+ if(iaddx(ia) == 0) then
+ iax = 1
+ else if(iaddx(ia) == 1) then
+ iax = (NGLLX+1)/2
+ else if(iaddx(ia) == 2) then
+ iax = NGLLX
+ else
+ call exit_MPI(myrank,'incorrect value of iaddx')
+ endif
+
+ if(iaddy(ia) == 0) then
+ iay = 1
+ else if(iaddy(ia) == 1) then
+ iay = (NGLLY+1)/2
+ else if(iaddy(ia) == 2) then
+ iay = NGLLY
+ else
+ call exit_MPI(myrank,'incorrect value of iaddy')
+ endif
+
+ if(iaddr(ia) == 0) then
+ iaz = 1
+ else if(iaddr(ia) == 1) then
+ iaz = (NGLLZ+1)/2
+ else if(iaddr(ia) == 2) then
+ iaz = NGLLZ
+ else
+ call exit_MPI(myrank,'incorrect value of iaddr')
+ endif
+
+ iglob = ibool(iax,iay,iaz,ispec_selected_source_subset(isource_in_this_subset))
+ xelm(ia) = dble(xstore(iglob))
+ yelm(ia) = dble(ystore(iglob))
+ zelm(ia) = dble(zstore(iglob))
+
+ enddo
+
+! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+! recompute jacobian for the new point
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+! compute distance to target location
+ dx = - (x - x_target_source)
+ dy = - (y - y_target_source)
+ dz = - (z - z_target_source)
+
+! compute increments
+ dxi = xix*dx + xiy*dy + xiz*dz
+ deta = etax*dx + etay*dy + etaz*dz
+ dgamma = gammax*dx + gammay*dy + gammaz*dz
+
+! update values
+ xi = xi + dxi
+ eta = eta + deta
+ gamma = gamma + dgamma
+
+! impose that we stay in that element
+! (useful if user gives a source outside the mesh for instance)
+ if (xi > 1.d0) xi = 1.d0
+ if (xi < -1.d0) xi = -1.d0
+ if (eta > 1.d0) eta = 1.d0
+ if (eta < -1.d0) eta = -1.d0
+ if (gamma > 1.d0) gamma = 1.d0
+ if (gamma < -1.d0) gamma = -1.d0
+
+ enddo
+
+! compute final coordinates of point found
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+! store xi,eta,gamma and x,y,z of point found
+ xi_source_subset(isource_in_this_subset) = xi
+ eta_source_subset(isource_in_this_subset) = eta
+ gamma_source_subset(isource_in_this_subset) = gamma
+ x_found_source(isource_in_this_subset) = x
+ y_found_source(isource_in_this_subset) = y
+ z_found_source(isource_in_this_subset) = z
+
+! compute final distance between asked and found (converted to km)
+ final_distance_source_subset(isource_in_this_subset) = dsqrt((x_target_source-x_found_source(isource_in_this_subset))**2 + &
+ (y_target_source-y_found_source(isource_in_this_subset))**2 + &
+ (z_target_source-z_found_source(isource_in_this_subset))**2)*R_EARTH/1000.d0
+
+! end of loop on all the sources
+ enddo
+
+! now gather information from all the nodes
+! use -1 as a flag to detect if gather fails for some reason
+ ispec_selected_source_all(:,:) = 0
+ ispec_selected_source_all(:,1:NSOURCES_SUBSET_current_size) = -1
+
+#ifdef USE_MPI
+ call MPI_GATHER(ispec_selected_source_subset,NSOURCES_SUBSET_current_size,MPI_INTEGER, &
+ ispec_selected_source_all,NSOURCES_SUBSET_current_size,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(xi_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ xi_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(eta_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ eta_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(gamma_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ gamma_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(final_distance_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ final_distance_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(x_found_source,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ x_found_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(y_found_source,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ y_found_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(z_found_source,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ z_found_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+
+! this is executed by main process only
+ if(myrank == 0) then
+
+! check that the gather operation went well
+ if(minval(ispec_selected_source_all) < 0) call exit_MPI(myrank,'gather operation failed for source')
+
+! loop on all the sources within subsets
+ do isource_in_this_subset = 1,NSOURCES_SUBSET_current_size
+
+! mapping from source number in current subset to real source number in all the subsets
+ isource = isources_already_done + isource_in_this_subset
+
+! loop on all the results to determine the best slice
+ distmin = HUGEVAL
+ do iprocloop = 0,NPROCTOT-1
+ if(final_distance_source_all(iprocloop,isource_in_this_subset) < distmin) then
+ distmin = final_distance_source_all(iprocloop,isource_in_this_subset)
+ islice_selected_source(isource) = iprocloop
+ ispec_selected_source(isource) = ispec_selected_source_all(iprocloop,isource_in_this_subset)
+ xi_source(isource) = xi_source_all(iprocloop,isource_in_this_subset)
+ eta_source(isource) = eta_source_all(iprocloop,isource_in_this_subset)
+ gamma_source(isource) = gamma_source_all(iprocloop,isource_in_this_subset)
+ x_found_source(isource_in_this_subset) = x_found_source_all(iprocloop,isource_in_this_subset)
+ y_found_source(isource_in_this_subset) = y_found_source_all(iprocloop,isource_in_this_subset)
+ z_found_source(isource_in_this_subset) = z_found_source_all(iprocloop,isource_in_this_subset)
+ endif
+ enddo
+ final_distance_source(isource) = distmin
+
+ write(IMAIN,*)
+ write(IMAIN,*) '*************************************'
+ write(IMAIN,*) ' locating source ',isource
+ write(IMAIN,*) '*************************************'
+ write(IMAIN,*)
+ write(IMAIN,*) 'source located in slice ',islice_selected_source(isource_in_this_subset)
+ write(IMAIN,*) ' in element ',ispec_selected_source(isource_in_this_subset)
+ write(IMAIN,*)
+ write(IMAIN,*) ' xi coordinate of source in that element: ',xi_source(isource)
+ write(IMAIN,*) ' eta coordinate of source in that element: ',eta_source(isource)
+ write(IMAIN,*) 'gamma coordinate of source in that element: ',gamma_source(isource)
+
+! add message if source is a Heaviside
+ if(hdur(isource) < 5.*DT) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Source time function is a Heaviside, convolve later'
+ write(IMAIN,*)
+ endif
+
+ write(IMAIN,*)
+ write(IMAIN,*) ' half duration: ',hdur(isource),' seconds'
+ write(IMAIN,*) ' time shift: ',t_cmt(isource),' seconds'
+
+! get latitude, longitude and depth of the source that will be used
+ call xyz_2_rthetaphi_dble(x_found_source(isource_in_this_subset),y_found_source(isource_in_this_subset), &
+ z_found_source(isource_in_this_subset),r_found_source,theta_source(isource),phi_source(isource))
+ call reduce(theta_source(isource),phi_source(isource))
+
+! convert geocentric to geographic colatitude
+ colat_source = PI/2.0d0-datan(1.006760466d0*dcos(theta_source(isource))/dmax1(TINYVAL,dsin(theta_source(isource))))
+ if(phi_source(isource)>PI) phi_source(isource)=phi_source(isource)-TWO_PI
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'original (requested) position of the source:'
+ write(IMAIN,*)
+ write(IMAIN,*) ' latitude: ',lat(isource)
+ write(IMAIN,*) ' longitude: ',long(isource)
+ write(IMAIN,*) ' depth: ',depth(isource),' km'
+ write(IMAIN,*)
+
+! compute real position of the source
+ write(IMAIN,*) 'position of the source that will be used:'
+ write(IMAIN,*)
+ write(IMAIN,*) ' latitude: ',(PI/2.0d0-colat_source)*180.0d0/PI
+ write(IMAIN,*) ' longitude: ',phi_source(isource)*180.0d0/PI
+ write(IMAIN,*) ' depth: ',(r0-r_found_source)*R_EARTH/1000.0d0,' km'
+ write(IMAIN,*)
+
+! display error in location estimate
+ write(IMAIN,*) 'error in location of the source: ',sngl(final_distance_source(isource)),' km'
+
+! add warning if estimate is poor
+! (usually means source outside the mesh given by the user)
+ if(final_distance_source(isource) > 50.d0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '***** WARNING: source location estimate is poor *****'
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '*****************************************************'
+ endif
+
+! print source time function and spectrum
+ if(PRINT_SOURCE_TIME_FUNCTION) then
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'printing the source-time function'
+
+ scalar_moment = 0.
+ do i = 1,6
+ scalar_moment = scalar_moment + moment_tensor(i,isource)**2
+ enddo
+ scalar_moment = dsqrt(scalar_moment/2.)
+
+! print the source-time function
+ if(NSOURCES == 1) then
+ plot_file = '/plot_source_time_function.txt'
+ else
+ if(isource < 10) then
+ write(plot_file,"('/plot_source_time_function',i1,'.txt')") isource
+ elseif(isource < 100) then
+ write(plot_file,"('/plot_source_time_function',i2,'.txt')") isource
+ else
+ write(plot_file,"('/plot_source_time_function',i3,'.txt')") isource
+ endif
+ endif
+
+ open(unit=27,file=trim(OUTPUT_FILES)//plot_file,status='unknown',action='write')
+ do it=1,NSTEP
+ time_source = dble(it-1)*DT-t0-t_cmt(isource)
+ write(27,*) sngl(dble(it-1)*DT-t0),sngl(scalar_moment*comp_source_time_function(time_source,hdur_gaussian(isource)))
+ enddo
+ close(27)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'printing the source spectrum'
+
+! print the spectrum of the derivative of the source from 0 to 1/8 Hz
+ if(NSOURCES == 1) then
+ plot_file = '/plot_source_spectrum.txt'
+ else
+ if(isource < 10) then
+ write(plot_file,"('/plot_source_spectrum',i1,'.txt')") isource
+ elseif(isource < 100) then
+ write(plot_file,"('/plot_source_spectrum',i2,'.txt')") isource
+ else
+ write(plot_file,"('/plot_source_spectrum',i3,'.txt')") isource
+ endif
+ endif
+
+ open(unit=27,file=trim(OUTPUT_FILES)//plot_file,status='unknown',action='write')
+ do iom=1,NSAMP_PLOT_SOURCE
+ om=TWO_PI*(1.0d0/8.0d0)*(iom-1)/dble(NSAMP_PLOT_SOURCE-1)
+ write(27,*) sngl(om/TWO_PI),sngl(scalar_moment*om*comp_source_spectrum(om,hdur(isource)))
+ enddo
+ close(27)
+
+ endif
+
+ enddo ! end of loop on all the sources within current source subset
+
+ endif ! end of section executed by main process only
+
+ enddo ! end of loop over all source subsets
+
+! display maximum error in location estimate
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'maximum error in location of the sources: ',sngl(maxval(final_distance_source)),' km'
+ write(IMAIN,*)
+ endif
+
+
+! main process broadcasts the results to all the slices
+#ifdef USE_MPI
+ call MPI_BCAST(islice_selected_source,NSOURCES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ispec_selected_source,NSOURCES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(xi_source,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eta_source,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(gamma_source,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+
+! elapsed time since beginning of source detection
+ if(myrank == 0) then
+#ifdef USE_MPI
+ tCPU = MPI_WTIME() - time_start
+#else
+ tCPU = 0
+#endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for detection of sources in seconds = ',tCPU
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of source detection - done'
+ write(IMAIN,*)
+ endif
+
+ end subroutine locate_sources
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_sources.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/locate_sources.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,680 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! 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.
-!
-!=====================================================================
-
-!----
-!---- locate_sources finds the correct position of the sources
-!----
-
- subroutine locate_sources(NSOURCES,myrank,nspec,nglob,ibool,&
- xstore,ystore,zstore,xigll,yigll,zigll, &
- NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
- sec,t_cmt,yr,jda,ho,mi,theta_source,phi_source, &
- NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- islice_selected_source,ispec_selected_source, &
- xi_source,eta_source,gamma_source, nu_source, &
- rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
- integer NPROCTOT
- integer NSTEP,NSOURCES,NEX_XI
-
- logical ELLIPTICITY,TOPOGRAPHY,PRINT_SOURCE_TIME_FUNCTION
-
- double precision DT
-
-! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
- integer nspec,nglob,myrank,isource
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
-! arrays containing coordinates of the points
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
-
-! Gauss-Lobatto-Legendre points of integration
- double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
-
- double precision nu_source(NDIM,NDIM,NSOURCES)
-
- integer yr,jda,ho,mi
-
- double precision sec
- double precision t_cmt(NSOURCES)
- double precision t0, hdur_gaussian(NSOURCES)
-
- integer iprocloop
-
- integer i,j,k,ispec,iglob
- integer ier
-
- double precision ell
- double precision elevation
- double precision r0,dcost,p20
- double precision theta,phi
- double precision, dimension(NSOURCES) :: theta_source,phi_source
- double precision dist,typical_size
- double precision xi,eta,gamma,dx,dy,dz,dxi,deta
-
-! topology of the control points of the surface element
- integer iax,iay,iaz
- integer iaddx(NGNOD),iaddy(NGNOD),iaddr(NGNOD)
-
-! coordinates of the control points of the surface element
- double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
-
- integer iter_loop
-
- integer ia
- double precision x,y,z
- double precision xix,xiy,xiz
- double precision etax,etay,etaz
- double precision gammax,gammay,gammaz
- double precision dgamma
-
- double precision final_distance_source(NSOURCES)
-
- double precision x_target_source,y_target_source,z_target_source
- double precision r_target_source
-
- integer islice_selected_source(NSOURCES)
-
-! timer MPI
- double precision time_start,tCPU
-
- integer isources_already_done,isource_in_this_subset
- integer ispec_selected_source(NSOURCES)
-
- double precision hdur(NSOURCES)
-
- double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
-
- double precision, dimension(NSOURCES) :: lat,long,depth
- double precision scalar_moment
- double precision moment_tensor(6,NSOURCES)
- double precision radius
-
- character(len=150) OUTPUT_FILES,plot_file
-
- double precision r_found_source
- double precision st,ct,sp,cp
- double precision Mrr,Mtt,Mpp,Mrt,Mrp,Mtp
- double precision colat_source
- double precision distmin
-
- integer :: ix_initial_guess_source,iy_initial_guess_source,iz_initial_guess_source,NSOURCES_SUBSET_current_size
-
- logical located_target
-
-! for calculation of source time function and spectrum
- integer it,iom
- double precision time_source,om
- double precision, external :: comp_source_time_function,comp_source_spectrum
-
-! number of points to plot the source time function and spectrum
- integer, parameter :: NSAMP_PLOT_SOURCE = 1000
-
- integer iorientation
- double precision stazi,stdip,thetan,phin,n(3)
-
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
- double precision, dimension(NSOURCES_SUBSET_MAX) :: final_distance_source_subset
-
- integer, dimension(NSOURCES_SUBSET_MAX) :: ispec_selected_source_subset
-
- integer, dimension(0:NPROCTOT-1,NSOURCES_SUBSET_MAX) :: ispec_selected_source_all
-
- double precision, dimension(0:NPROCTOT-1,NSOURCES_SUBSET_MAX) :: xi_source_all,eta_source_all,gamma_source_all, &
- final_distance_source_all,x_found_source_all,y_found_source_all,z_found_source_all
-
- double precision, dimension(NSOURCES_SUBSET_MAX) :: xi_source_subset,eta_source_subset,gamma_source_subset
-
- double precision, dimension(NSOURCES_SUBSET_MAX) :: x_found_source,y_found_source,z_found_source
-
-! **************
-
-! make sure we clean the future final array
- ispec_selected_source(:) = 0
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! read all the sources
- if(myrank == 0) call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,NSOURCES)
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(yr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(jda,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ho,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(mi,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(sec,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(t_cmt,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(hdur,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(lat,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(long,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(depth,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(moment_tensor,6*NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
-! define topology of the control element
- call hex_nodes(iaddx,iaddy,iaddr)
-
-! get MPI starting time for all sources
- time_start = MPI_WTIME()
-
-! convert the half duration for triangle STF to the one for gaussian STF
- hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
-
-! define t0 as the earliest start time
- t0 = - 1.5d0*minval(t_cmt-hdur)
-
-! loop on all the sources
-! gather source information in subsets to reduce memory requirements
-
-! loop over subsets of sources
- do isources_already_done = 0, NSOURCES, NSOURCES_SUBSET_MAX
-
-! the size of the subset can be the maximum size, or less (if we are in the last subset,
-! or if there are fewer sources than the maximum size of a subset)
- NSOURCES_SUBSET_current_size = min(NSOURCES_SUBSET_MAX, NSOURCES - isources_already_done)
-
-! make sure we clean the subset array before the gather
- ispec_selected_source_subset(:) = 0
-
-! loop over sources within this subset
- do isource_in_this_subset = 1,NSOURCES_SUBSET_current_size
-
-! mapping from source number in current subset to real source number in all the subsets
- isource = isource_in_this_subset + isources_already_done
-
-! convert geographic latitude lat (degrees)
-! to geocentric colatitude theta (radians)
- theta=PI/2.0d0-atan(0.99329534d0*dtan(lat(isource)*PI/180.0d0))
- phi=long(isource)*PI/180.0d0
- call reduce(theta,phi)
-
-! get the moment tensor
- Mrr = moment_tensor(1,isource)
- Mtt = moment_tensor(2,isource)
- Mpp = moment_tensor(3,isource)
- Mrt = moment_tensor(4,isource)
- Mrp = moment_tensor(5,isource)
- Mtp = moment_tensor(6,isource)
-
-! convert from a spherical to a Cartesian representation of the moment tensor
- st=dsin(theta)
- ct=dcos(theta)
- sp=dsin(phi)
- cp=dcos(phi)
-
- Mxx(isource)=st*st*cp*cp*Mrr+ct*ct*cp*cp*Mtt+sp*sp*Mpp &
- +2.0d0*st*ct*cp*cp*Mrt-2.0d0*st*sp*cp*Mrp-2.0d0*ct*sp*cp*Mtp
- Myy(isource)=st*st*sp*sp*Mrr+ct*ct*sp*sp*Mtt+cp*cp*Mpp &
- +2.0d0*st*ct*sp*sp*Mrt+2.0d0*st*sp*cp*Mrp+2.0d0*ct*sp*cp*Mtp
- Mzz(isource)=ct*ct*Mrr+st*st*Mtt-2.0d0*st*ct*Mrt
- Mxy(isource)=st*st*sp*cp*Mrr+ct*ct*sp*cp*Mtt-sp*cp*Mpp &
- +2.0d0*st*ct*sp*cp*Mrt+st*(cp*cp-sp*sp)*Mrp+ct*(cp*cp-sp*sp)*Mtp
- Mxz(isource)=st*ct*cp*Mrr-st*ct*cp*Mtt &
- +(ct*ct-st*st)*cp*Mrt-ct*sp*Mrp+st*sp*Mtp
- Myz(isource)=st*ct*sp*Mrr-st*ct*sp*Mtt &
- +(ct*ct-st*st)*sp*Mrt+ct*cp*Mrp-st*cp*Mtp
-
-! record three components for each station
- do iorientation = 1,3
-
-! North
- if(iorientation == 1) then
- stazi = 0.d0
- stdip = 0.d0
-! East
- else if(iorientation == 2) then
- stazi = 90.d0
- stdip = 0.d0
-! Vertical
- else if(iorientation == 3) then
- stazi = 0.d0
- stdip = - 90.d0
- else
- call exit_MPI(myrank,'incorrect orientation')
- endif
-
-! get the orientation of the seismometer
- thetan=(90.0d0+stdip)*PI/180.0d0
- phin=stazi*PI/180.0d0
-
-! we use the same convention as in Harvard normal modes for the orientation
-
-! vertical component
- n(1) = dcos(thetan)
-! N-S component
- n(2) = - dsin(thetan)*dcos(phin)
-! E-W component
- n(3) = dsin(thetan)*dsin(phin)
-
-! get the Cartesian components of n in the model: nu
- nu_source(iorientation,1,isource) = n(1)*st*cp+n(2)*ct*cp-n(3)*sp
- nu_source(iorientation,2,isource) = n(1)*st*sp+n(2)*ct*sp+n(3)*cp
- nu_source(iorientation,3,isource) = n(1)*ct-n(2)*st
-
- enddo
-
-! normalized source radius
- r0 = R_UNIT_SPHERE
-
- if(ELLIPTICITY) then
- if(TOPOGRAPHY) then
- call get_topo_bathy(lat(isource),long(isource),elevation,ibathy_topo)
- r0 = r0 + elevation/R_EARTH
- endif
- dcost = dcos(theta)
- p20 = 0.5d0*(3.0d0*dcost*dcost-1.0d0)
- radius = r0 - depth(isource)*1000.0d0/R_EARTH
- call spline_evaluation(rspl,espl,espl2,nspl,radius,ell)
- r0 = r0*(1.0d0-(2.0d0/3.0d0)*ell*p20)
- endif
-
-! compute the Cartesian position of the source
- r_target_source = r0 - depth(isource)*1000.0d0/R_EARTH
- x_target_source = r_target_source*dsin(theta)*dcos(phi)
- y_target_source = r_target_source*dsin(theta)*dsin(phi)
- z_target_source = r_target_source*dcos(theta)
-
-! set distance to huge initial value
- distmin = HUGEVAL
-
-! compute typical size of elements at the surface
- typical_size = TWO_PI * R_UNIT_SPHERE / (4.*NEX_XI)
-
-! use 10 times the distance as a criterion for source detection
- typical_size = 10. * typical_size
-
-! flag to check that we located at least one target element
- located_target = .false.
-
- do ispec = 1,nspec
-
-! exclude elements that are too far from target
- iglob = ibool(1,1,1,ispec)
- dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
- + (y_target_source - dble(ystore(iglob)))**2 &
- + (z_target_source - dble(zstore(iglob)))**2)
- if(USE_DISTANCE_CRITERION .and. dist > typical_size) cycle
-
- located_target = .true.
-
-! loop only on points inside the element
-! exclude edges to ensure this point is not shared with other elements
- do k = 2,NGLLZ-1
- do j = 2,NGLLY-1
- do i = 2,NGLLX-1
-
-! keep this point if it is closer to the receiver
- iglob = ibool(i,j,k,ispec)
- dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
- +(y_target_source - dble(ystore(iglob)))**2 &
- +(z_target_source - dble(zstore(iglob)))**2)
- if(dist < distmin) then
- distmin = dist
- ispec_selected_source_subset(isource_in_this_subset) = ispec
- ix_initial_guess_source = i
- iy_initial_guess_source = j
- iz_initial_guess_source = k
- endif
-
- enddo
- enddo
- enddo
-
-! end of loop on all the elements in current slice
- enddo
-
-! *******************************************
-! find the best (xi,eta,gamma) for the source
-! *******************************************
-
-! if we have not located a target element, the source is not in this slice
-! therefore use first element only for fictitious iterative search
- if(.not. located_target) then
- ispec_selected_source_subset(isource_in_this_subset)=1
- ix_initial_guess_source = 2
- iy_initial_guess_source = 2
- iz_initial_guess_source = 2
- endif
-
-! use initial guess in xi, eta and gamma
- xi = xigll(ix_initial_guess_source)
- eta = yigll(iy_initial_guess_source)
- gamma = zigll(iz_initial_guess_source)
-
-! define coordinates of the control points of the element
-
- do ia=1,NGNOD
-
- if(iaddx(ia) == 0) then
- iax = 1
- else if(iaddx(ia) == 1) then
- iax = (NGLLX+1)/2
- else if(iaddx(ia) == 2) then
- iax = NGLLX
- else
- call exit_MPI(myrank,'incorrect value of iaddx')
- endif
-
- if(iaddy(ia) == 0) then
- iay = 1
- else if(iaddy(ia) == 1) then
- iay = (NGLLY+1)/2
- else if(iaddy(ia) == 2) then
- iay = NGLLY
- else
- call exit_MPI(myrank,'incorrect value of iaddy')
- endif
-
- if(iaddr(ia) == 0) then
- iaz = 1
- else if(iaddr(ia) == 1) then
- iaz = (NGLLZ+1)/2
- else if(iaddr(ia) == 2) then
- iaz = NGLLZ
- else
- call exit_MPI(myrank,'incorrect value of iaddr')
- endif
-
- iglob = ibool(iax,iay,iaz,ispec_selected_source_subset(isource_in_this_subset))
- xelm(ia) = dble(xstore(iglob))
- yelm(ia) = dble(ystore(iglob))
- zelm(ia) = dble(zstore(iglob))
-
- enddo
-
-! iterate to solve the non linear system
- do iter_loop = 1,NUM_ITER
-
-! recompute jacobian for the new point
- call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
-
-! compute distance to target location
- dx = - (x - x_target_source)
- dy = - (y - y_target_source)
- dz = - (z - z_target_source)
-
-! compute increments
- dxi = xix*dx + xiy*dy + xiz*dz
- deta = etax*dx + etay*dy + etaz*dz
- dgamma = gammax*dx + gammay*dy + gammaz*dz
-
-! update values
- xi = xi + dxi
- eta = eta + deta
- gamma = gamma + dgamma
-
-! impose that we stay in that element
-! (useful if user gives a source outside the mesh for instance)
- if (xi > 1.d0) xi = 1.d0
- if (xi < -1.d0) xi = -1.d0
- if (eta > 1.d0) eta = 1.d0
- if (eta < -1.d0) eta = -1.d0
- if (gamma > 1.d0) gamma = 1.d0
- if (gamma < -1.d0) gamma = -1.d0
-
- enddo
-
-! compute final coordinates of point found
- call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
-
-! store xi,eta,gamma and x,y,z of point found
- xi_source_subset(isource_in_this_subset) = xi
- eta_source_subset(isource_in_this_subset) = eta
- gamma_source_subset(isource_in_this_subset) = gamma
- x_found_source(isource_in_this_subset) = x
- y_found_source(isource_in_this_subset) = y
- z_found_source(isource_in_this_subset) = z
-
-! compute final distance between asked and found (converted to km)
- final_distance_source_subset(isource_in_this_subset) = dsqrt((x_target_source-x_found_source(isource_in_this_subset))**2 + &
- (y_target_source-y_found_source(isource_in_this_subset))**2 + &
- (z_target_source-z_found_source(isource_in_this_subset))**2)*R_EARTH/1000.d0
-
-! end of loop on all the sources
- enddo
-
-! now gather information from all the nodes
-! use -1 as a flag to detect if gather fails for some reason
- ispec_selected_source_all(:,:) = 0
- ispec_selected_source_all(:,1:NSOURCES_SUBSET_current_size) = -1
-
- call MPI_GATHER(ispec_selected_source_subset,NSOURCES_SUBSET_current_size,MPI_INTEGER, &
- ispec_selected_source_all,NSOURCES_SUBSET_current_size,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(xi_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
- xi_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(eta_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
- eta_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(gamma_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
- gamma_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(final_distance_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
- final_distance_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(x_found_source,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
- x_found_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(y_found_source,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
- y_found_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(z_found_source,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
- z_found_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
-! this is executed by main process only
- if(myrank == 0) then
-
-! check that the gather operation went well
- if(minval(ispec_selected_source_all) < 0) call exit_MPI(myrank,'gather operation failed for source')
-
-! loop on all the sources within subsets
- do isource_in_this_subset = 1,NSOURCES_SUBSET_current_size
-
-! mapping from source number in current subset to real source number in all the subsets
- isource = isources_already_done + isource_in_this_subset
-
-! loop on all the results to determine the best slice
- distmin = HUGEVAL
- do iprocloop = 0,NPROCTOT-1
- if(final_distance_source_all(iprocloop,isource_in_this_subset) < distmin) then
- distmin = final_distance_source_all(iprocloop,isource_in_this_subset)
- islice_selected_source(isource) = iprocloop
- ispec_selected_source(isource) = ispec_selected_source_all(iprocloop,isource_in_this_subset)
- xi_source(isource) = xi_source_all(iprocloop,isource_in_this_subset)
- eta_source(isource) = eta_source_all(iprocloop,isource_in_this_subset)
- gamma_source(isource) = gamma_source_all(iprocloop,isource_in_this_subset)
- x_found_source(isource_in_this_subset) = x_found_source_all(iprocloop,isource_in_this_subset)
- y_found_source(isource_in_this_subset) = y_found_source_all(iprocloop,isource_in_this_subset)
- z_found_source(isource_in_this_subset) = z_found_source_all(iprocloop,isource_in_this_subset)
- endif
- enddo
- final_distance_source(isource) = distmin
-
- write(IMAIN,*)
- write(IMAIN,*) '*************************************'
- write(IMAIN,*) ' locating source ',isource
- write(IMAIN,*) '*************************************'
- write(IMAIN,*)
- write(IMAIN,*) 'source located in slice ',islice_selected_source(isource_in_this_subset)
- write(IMAIN,*) ' in element ',ispec_selected_source(isource_in_this_subset)
- write(IMAIN,*)
- write(IMAIN,*) ' xi coordinate of source in that element: ',xi_source(isource)
- write(IMAIN,*) ' eta coordinate of source in that element: ',eta_source(isource)
- write(IMAIN,*) 'gamma coordinate of source in that element: ',gamma_source(isource)
-
-! add message if source is a Heaviside
- if(hdur(isource) < 5.*DT) then
- write(IMAIN,*)
- write(IMAIN,*) 'Source time function is a Heaviside, convolve later'
- write(IMAIN,*)
- endif
-
- write(IMAIN,*)
- write(IMAIN,*) ' half duration: ',hdur(isource),' seconds'
- write(IMAIN,*) ' time shift: ',t_cmt(isource),' seconds'
-
-! get latitude, longitude and depth of the source that will be used
- call xyz_2_rthetaphi_dble(x_found_source(isource_in_this_subset),y_found_source(isource_in_this_subset), &
- z_found_source(isource_in_this_subset),r_found_source,theta_source(isource),phi_source(isource))
- call reduce(theta_source(isource),phi_source(isource))
-
-! convert geocentric to geographic colatitude
- colat_source = PI/2.0d0-datan(1.006760466d0*dcos(theta_source(isource))/dmax1(TINYVAL,dsin(theta_source(isource))))
- if(phi_source(isource)>PI) phi_source(isource)=phi_source(isource)-TWO_PI
-
- write(IMAIN,*)
- write(IMAIN,*) 'original (requested) position of the source:'
- write(IMAIN,*)
- write(IMAIN,*) ' latitude: ',lat(isource)
- write(IMAIN,*) ' longitude: ',long(isource)
- write(IMAIN,*) ' depth: ',depth(isource),' km'
- write(IMAIN,*)
-
-! compute real position of the source
- write(IMAIN,*) 'position of the source that will be used:'
- write(IMAIN,*)
- write(IMAIN,*) ' latitude: ',(PI/2.0d0-colat_source)*180.0d0/PI
- write(IMAIN,*) ' longitude: ',phi_source(isource)*180.0d0/PI
- write(IMAIN,*) ' depth: ',(r0-r_found_source)*R_EARTH/1000.0d0,' km'
- write(IMAIN,*)
-
-! display error in location estimate
- write(IMAIN,*) 'error in location of the source: ',sngl(final_distance_source(isource)),' km'
-
-! add warning if estimate is poor
-! (usually means source outside the mesh given by the user)
- if(final_distance_source(isource) > 50.d0) then
- write(IMAIN,*)
- write(IMAIN,*) '*****************************************************'
- write(IMAIN,*) '*****************************************************'
- write(IMAIN,*) '***** WARNING: source location estimate is poor *****'
- write(IMAIN,*) '*****************************************************'
- write(IMAIN,*) '*****************************************************'
- endif
-
-! print source time function and spectrum
- if(PRINT_SOURCE_TIME_FUNCTION) then
-
- write(IMAIN,*)
- write(IMAIN,*) 'printing the source-time function'
-
- scalar_moment = 0.
- do i = 1,6
- scalar_moment = scalar_moment + moment_tensor(i,isource)**2
- enddo
- scalar_moment = dsqrt(scalar_moment/2.)
-
-! print the source-time function
- if(NSOURCES == 1) then
- plot_file = '/plot_source_time_function.txt'
- else
- if(isource < 10) then
- write(plot_file,"('/plot_source_time_function',i1,'.txt')") isource
- elseif(isource < 100) then
- write(plot_file,"('/plot_source_time_function',i2,'.txt')") isource
- else
- write(plot_file,"('/plot_source_time_function',i3,'.txt')") isource
- endif
- endif
-
- open(unit=27,file=trim(OUTPUT_FILES)//plot_file,status='unknown',action='write')
- do it=1,NSTEP
- time_source = dble(it-1)*DT-t0-t_cmt(isource)
- write(27,*) sngl(dble(it-1)*DT-t0),sngl(scalar_moment*comp_source_time_function(time_source,hdur_gaussian(isource)))
- enddo
- close(27)
-
- write(IMAIN,*)
- write(IMAIN,*) 'printing the source spectrum'
-
-! print the spectrum of the derivative of the source from 0 to 1/8 Hz
- if(NSOURCES == 1) then
- plot_file = '/plot_source_spectrum.txt'
- else
- if(isource < 10) then
- write(plot_file,"('/plot_source_spectrum',i1,'.txt')") isource
- elseif(isource < 100) then
- write(plot_file,"('/plot_source_spectrum',i2,'.txt')") isource
- else
- write(plot_file,"('/plot_source_spectrum',i3,'.txt')") isource
- endif
- endif
-
- open(unit=27,file=trim(OUTPUT_FILES)//plot_file,status='unknown',action='write')
- do iom=1,NSAMP_PLOT_SOURCE
- om=TWO_PI*(1.0d0/8.0d0)*(iom-1)/dble(NSAMP_PLOT_SOURCE-1)
- write(27,*) sngl(om/TWO_PI),sngl(scalar_moment*om*comp_source_spectrum(om,hdur(isource)))
- enddo
- close(27)
-
- endif
-
- enddo ! end of loop on all the sources within current source subset
-
- endif ! end of section executed by main process only
-
- enddo ! end of loop over all source subsets
-
-! display maximum error in location estimate
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'maximum error in location of the sources: ',sngl(maxval(final_distance_source)),' km'
- write(IMAIN,*)
- endif
-
-
-! main process broadcasts the results to all the slices
- call MPI_BCAST(islice_selected_source,NSOURCES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ispec_selected_source,NSOURCES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(xi_source,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(eta_source,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(gamma_source,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
-! elapsed time since beginning of source detection
- if(myrank == 0) then
- tCPU = MPI_WTIME() - time_start
- write(IMAIN,*)
- write(IMAIN,*) 'Elapsed time for detection of sources in seconds = ',tCPU
- write(IMAIN,*)
- write(IMAIN,*) 'End of source detection - done'
- write(IMAIN,*)
- endif
-
- end subroutine locate_sources
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/main_program.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/main_program.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/main_program.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/main_program.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,494 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+!===================================================================!
+! !
+! Specfem3D is a 3-D spectral-element solver for the Earth. !
+! It uses a mesh generated by meshfem3D, !
+! which produces a spectral element grid for the Earth. !
+! This is accomplished based upon a mapping of the face of a cube !
+! to a portion of the sphere (Ronchi et al., The Cubed Sphere). !
+! Grid density is decreased by a factor of two !
+! three times in the radial direction. !
+! !
+!===================================================================!
+!
+! If you use this code for your own research, please cite some of these articles:
+!
+! @ARTICLE{KoRiTr02,
+! author={D. Komatitsch and J. Ritsema and J. Tromp},
+! year=2002,
+! title={The Spectral-Element Method, {B}eowulf Computing, and Global Seismology},
+! journal={Science},
+! volume=298,
+! number=5599,
+! pages={1737-1742},
+! doi={10.1126/science.1076024}}
+!
+! @ARTICLE{KoTr02a,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-I. V}alidation},
+! journal={Geophys. J. Int.},
+! volume=149,
+! number=2,
+! pages={390-412},
+! doi={10.1046/j.1365-246X.2002.01653.x}}
+!
+! @ARTICLE{KoTr02b,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-II. 3-D} Models, Oceans, Rotation, and Self-Gravitation},
+! journal={Geophys. J. Int.},
+! volume=150,
+! pages={303-318},
+! number=1,
+! doi={10.1046/j.1365-246X.2002.01716.x}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! If you use the kernel capabilities of the code, please cite
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! If you use 3-D model S20RTS, please cite
+!
+! @ARTICLE{RiVa00,
+! author={J. Ritsema and H. J. {Van Heijst}},
+! year=2000,
+! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
+! journal={Science Progress},
+! volume=83,
+! pages={243-259}}
+!
+! Reference frame - convention:
+! ----------------------------
+!
+! The code uses the following convention for the reference frame:
+!
+! - X axis is East
+! - Y axis is North
+! - Z axis is up
+!
+! Note that this convention is different from both the Aki-Richards convention
+! and the Harvard CMT convention.
+!
+! Let us recall that the Aki-Richards convention is:
+!
+! - X axis is North
+! - Y axis is East
+! - Z axis is down
+!
+! and that the Harvard CMT convention is:
+!
+! - X axis is South
+! - Y axis is East
+! - Z axis is up
+!
+! To report bugs or suggest improvements to the code, please send an email
+! to Jeroen Tromp <jtromp AT princeton.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+! Evolution of the code:
+! ---------------------
+!
+! v. 4.1_beta Dimitri Komatitsch, University of Pau, France, August 2008:
+! merged the mesher and the solver, support for diskless supercomputers,
+! converted many arrays from memory heap to stack (using automatic arrays instead of allocatable)
+! to avoid memory fragmentation in the case of very large models
+!
+! v. 4.0 David Michea and Dimitri Komatitsch, University of Pau, France, February 2008:
+! new doubling brick in the mesh, new perfectly load-balanced mesh,
+! more flexible routines for mesh design, new inflated central cube
+! with optimized shape, far fewer mesh files saved by the mesher,
+! global arrays sorted to speed up the simulation, seismograms can be
+! written by the master
+!
+! v. 3.6 Many people, many affiliations, September 2006:
+! adjoint and kernel calculations (by Qinya Liu), fixed IASP91 model,
+! added AK135 and 1066a, fixed topography/bathymetry routine,
+! new attenuation routines, faster and better I/Os on very large
+! systems, many small improvements and bug fixes, new "configure"
+! script, new Pyre version, new user's manual etc.
+!
+! v. 3.5 Dimitri Komatitsch, Brian Savage and Jeroen Tromp, Caltech, July 2004:
+! any size of chunk, 3D attenuation, case of two chunks,
+! more precise topography/bathymetry model, new Par_file structure
+!
+! v. 3.4 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2003:
+! merged global and regional codes, no iterations in fluid, better movies
+!
+! v. 3.3 Dimitri Komatitsch, Caltech, September 2002:
+! flexible mesh doubling in outer core, inlined code, OpenDX support for mesh files
+!
+! v. 3.2 Jeroen Tromp, Caltech, July 2002:
+! multiple sources and flexible PREM reading
+!
+! v. 3.1 Dimitri Komatitsch, Caltech, June 2002:
+! vectorized loops in solver and merged central cube
+!
+! v. 3.0 Dimitri Komatitsch and Jeroen Tromp, Caltech, May 2002:
+! ported to SGI and Compaq DEC Alpha, double precision solver, more general anisotropy
+!
+! v. 2.3 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2001:
+! gravity, rotation, oceans and 3-D models
+!
+! v. 2.2 Dimitri Komatitsch and Jeroen Tromp, Caltech, March 2001:
+! final MPI package
+!
+! v. 2.0 Dimitri Komatitsch, Harvard, January 2000:
+! MPI code for the globe
+!
+! v. 1.0 Dimitri Komatitsch, Mexico, June 1999:
+! first MPI code for a chunk
+!
+! Jeroen Tromp, Harvard, July 1998:
+! first chunk solver using OpenMP on Sun
+!
+! Dimitri Komatitsch, IPG Paris, December 1996:
+! first 3-D solver for the Connection Machine CM-5 (by Thinking Machines)
+!
+
+!! DK DK added this for merged version
+!! DK DK stored in single precision for merged version, check if it precise enough (probably yes)
+!! DK DK now defined as pointers, in order to be able to deallocate them
+!! DK DK see for instance http://www.pcc.qub.ac.uk/tec/courses/f77tof90/stu-notes/f90studentMIF_6.html
+!! DK DK Section 5.6 about this
+ module dyn_array
+!---------------------------------------------------------------------
+! Module containing definitions needed to dynamically allocate the values of an array
+!---------------------------------------------------------------------
+ include "constants.h"
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ xelm_store_crust_mantle,yelm_store_crust_mantle,zelm_store_crust_mantle, &
+ xelm_store_outer_core,yelm_store_outer_core,zelm_store_outer_core, &
+ xelm_store_inner_core,yelm_store_inner_core,zelm_store_inner_core
+ end module dyn_array
+
+ program main_program
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "precision.h"
+#endif
+
+!! DK DK for the merged version
+! include values created by the mesher
+ include "values_from_mesher.h"
+
+! proc numbers for MPI
+ integer myrank,sizeprocs,ier
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! addressing for all the slices
+ integer, dimension(0:NPROCTOT_VAL-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+
+ integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSOURCES
+
+ integer, external :: err_occurred
+
+!!!! DK DK for merged version, all the arrays below are allocated statically instead
+
+#ifdef USE_MPI
+ integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer npoin2D_faces_outer_core(NUMFACES_SHARED)
+ integer npoin2D_faces_inner_core(NUMFACES_SHARED)
+#endif
+
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ npoin2D_xi_inner_core,npoin2D_eta_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+
+! number of elements on the boundaries
+ integer :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: kappavstore_crust_mantle,muvstore_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: kappavstore_inner_core,muvstore_inner_core
+
+! 2-D jacobians and normals
+
+ integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
+
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+ integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
+ integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
+
+#ifdef USE_MPI
+ integer, dimension(NGLOB2DMAX_XY_VAL_CM,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_VAL_OC,NUMFACES_SHARED) :: iboolfaces_outer_core
+ integer, dimension(NGLOB2DMAX_XY_VAL_IC,NUMFACES_SHARED) :: iboolfaces_inner_core
+#endif
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+
+#ifdef USE_MPI
+ integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
+ integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
+#endif
+
+ integer :: npoin2D_max_all,NDIM_smaller_buffers
+
+! receiver information
+ integer :: nrec,ios
+ character(len=150) :: STATIONS,rec_filename,dummystring
+
+!---- arrays to assemble between chunks
+
+#ifdef USE_MPI
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES_VAL) :: imsg_type,iprocfrom_faces,iprocto_faces
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+#endif
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: Qs ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! ************** PROGRAM STARTS HERE **************
+
+! initialize the MPI communicator and start the NPROCTOT MPI processes.
+#ifdef USE_MPI
+ call MPI_INIT(ier)
+#else
+ ier = 0
+#endif
+ if(ier /= 0) stop 'error: cannot start MPI!!!'
+
+! sizeprocs returns number of processes started (should be equal to NPROCTOT).
+! myrank is the rank of each process, between 0 and NPROCTOT-1.
+! as usual in MPI, process 0 is in charge of coordinating everything
+! and also takes care of the main output
+! do not create anything for the inner core here, will be done in solver
+#ifdef USE_MPI
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+#else
+ myrank = 0
+ sizeprocs = NPROCTOT_VAL
+#endif
+
+! YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY
+
+!! DK DK for the merged version, mesher inserted here
+ call meshfem3D(myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo,NSOURCES, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,ibool_crust_mantle,ibool_outer_core,ibool_inner_core, &
+ idoubling_crust_mantle,idoubling_inner_core,ibelm_bottom_crust_mantle, ibelm_bottom_outer_core, ibelm_top_outer_core, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
+ ibelm_top_inner_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
+ normal_bottom_outer_core, normal_top_outer_core,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle,kappavstore_inner_core,muvstore_inner_core, &
+ rmass_crust_mantle, rmass_outer_core, rmass_inner_core, &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+#ifdef USE_MPI
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core, iboolleft_eta_inner_core,iboolright_eta_inner_core,&
+ iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core, &
+ iboolcorner_crust_mantle,iboolcorner_outer_core,iboolcorner_inner_core, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+#endif
+ rmass_ocean_load,normal_top_crust_mantle,ibelm_top_crust_mantle,AM_V)
+
+! synchronize all the processes to make sure everybody has finished creating the mesh
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+#endif
+
+! YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY
+
+!! DK DK for merged version, temporary patch for David's code to cut the superbrick
+!! DK DK which I have not fully ported to the merged version yet: I do not
+!! DK DK yet distinguish the two values of each array, therefore let me set them
+!! DK DK equal here
+ npoin2D_xi_crust_mantle(2) = npoin2D_xi_crust_mantle(1)
+ npoin2D_eta_crust_mantle(2) = npoin2D_eta_crust_mantle(1)
+
+ npoin2D_xi_outer_core(2) = npoin2D_xi_outer_core(1)
+ npoin2D_eta_outer_core(2) = npoin2D_eta_outer_core(1)
+
+ npoin2D_xi_inner_core(2) = npoin2D_xi_inner_core(1)
+ npoin2D_eta_inner_core(2) = npoin2D_eta_inner_core(1)
+
+!! DK DK added this to reduce the size of the buffers
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_max_all = max(maxval(npoin2D_xi_crust_mantle(:) + npoin2D_xi_inner_core(:)), &
+ maxval(npoin2D_eta_crust_mantle(:) + npoin2D_eta_inner_core(:)))
+ if(FEWER_MESSAGES_LARGER_BUFFERS) then
+ NDIM_smaller_buffers = NDIM
+ else
+ NDIM_smaller_buffers = 1
+ endif
+
+! read the number of receivers
+ rec_filename = 'DATA/STATIONS'
+ call get_value_string(STATIONS, 'solver.STATIONS', rec_filename)
+! get total number of receivers
+ if(myrank == 0) then
+ open(unit=IIN,file=STATIONS,iostat=ios,status='old',action='read')
+ nrec = 0
+ do while(ios == 0)
+ read(IIN,"(a)",iostat=ios) dummystring
+ if(ios == 0) nrec = nrec + 1
+ enddo
+ close(IIN)
+ endif
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(nrec,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+#endif
+
+!! DK DK for the merged version, solver inserted here
+ call specfem3D(myrank,sizeprocs,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NSOURCES, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,ibool_crust_mantle,ibool_outer_core,ibool_inner_core, &
+ idoubling_crust_mantle,idoubling_inner_core,ibelm_bottom_crust_mantle, ibelm_bottom_outer_core, ibelm_top_outer_core, &
+ibelm_top_inner_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
+ normal_bottom_outer_core, normal_top_outer_core,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle,kappavstore_inner_core,muvstore_inner_core, &
+ rmass_crust_mantle,rmass_outer_core,rmass_inner_core,rmass_ocean_load, &
+#ifdef USE_MPI
+ NDIM_smaller_buffers,npoin2D_max_all,nrec,addressing,ibathy_topo, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
+iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core, iboolleft_eta_inner_core,iboolright_eta_inner_core,&
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core, &
+ iboolcorner_crust_mantle,iboolcorner_outer_core,iboolcorner_inner_core, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ normal_top_crust_mantle,ibelm_top_crust_mantle, &
+#endif
+ AM_V)
+
+#ifdef USE_MPI
+! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! stop all the MPI processes, and exit
+ call MPI_FINALIZE(ier)
+#endif
+
+ end program main_program
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/main_program.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/main_program.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/main_program.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,329 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-!
-! United States and French Government Sponsorship Acknowledged.
-
-!===================================================================!
-! !
-! Specfem3D is a 3-D spectral-element solver for the Earth. !
-! It uses a mesh generated by meshfem3D, !
-! which produces a spectral element grid for the Earth. !
-! This is accomplished based upon a mapping of the face of a cube !
-! to a portion of the sphere (Ronchi et al., The Cubed Sphere). !
-! Grid density is decreased by a factor of two !
-! three times in the radial direction. !
-! !
-!===================================================================!
-!
-! If you use this code for your own research, please cite some of these articles:
-!
-! @ARTICLE{KoRiTr02,
-! author={D. Komatitsch and J. Ritsema and J. Tromp},
-! year=2002,
-! title={The Spectral-Element Method, {B}eowulf Computing, and Global Seismology},
-! journal={Science},
-! volume=298,
-! number=5599,
-! pages={1737-1742},
-! doi={10.1126/science.1076024}}
-!
-! @ARTICLE{KoTr02a,
-! author={D. Komatitsch and J. Tromp},
-! year=2002,
-! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-I. V}alidation},
-! journal={Geophys. J. Int.},
-! volume=149,
-! number=2,
-! pages={390-412},
-! doi={10.1046/j.1365-246X.2002.01653.x}}
-!
-! @ARTICLE{KoTr02b,
-! author={D. Komatitsch and J. Tromp},
-! year=2002,
-! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-II. 3-D} Models, Oceans, Rotation, and Self-Gravitation},
-! journal={Geophys. J. Int.},
-! volume=150,
-! pages={303-318},
-! number=1,
-! doi={10.1046/j.1365-246X.2002.01716.x}}
-!
-! @ARTICLE{KoTr99,
-! author={D. Komatitsch and J. Tromp},
-! year=1999,
-! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
-! journal={Geophys. J. Int.},
-! volume=139,
-! number=3,
-! pages={806-822},
-! doi={10.1046/j.1365-246x.1999.00967.x}}
-!
-! @ARTICLE{KoVi98,
-! author={D. Komatitsch and J. P. Vilotte},
-! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
-! journal={Bull. Seismol. Soc. Am.},
-! year=1998,
-! volume=88,
-! number=2,
-! pages={368-392}}
-!
-! If you use the kernel capabilities of the code, please cite
-!
-! @ARTICLE{LiTr06,
-! author={Qinya Liu and Jeroen Tromp},
-! title={Finite-frequency kernels based on adjoint methods},
-! journal={Bull. Seismol. Soc. Am.},
-! year=2006,
-! volume=96,
-! number=6,
-! pages={2383-2397},
-! doi={10.1785/0120060041}}
-!
-! If you use 3-D model S20RTS, please cite
-!
-! @ARTICLE{RiVa00,
-! author={J. Ritsema and H. J. {Van Heijst}},
-! year=2000,
-! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
-! journal={Science Progress},
-! volume=83,
-! pages={243-259}}
-!
-! Reference frame - convention:
-! ----------------------------
-!
-! The code uses the following convention for the reference frame:
-!
-! - X axis is East
-! - Y axis is North
-! - Z axis is up
-!
-! Note that this convention is different from both the Aki-Richards convention
-! and the Harvard CMT convention.
-!
-! Let us recall that the Aki-Richards convention is:
-!
-! - X axis is North
-! - Y axis is East
-! - Z axis is down
-!
-! and that the Harvard CMT convention is:
-!
-! - X axis is South
-! - Y axis is East
-! - Z axis is up
-!
-! To report bugs or suggest improvements to the code, please send an email
-! to Jeroen Tromp <jtromp AT princeton.edu> and/or use our online
-! bug tracking system at http://www.geodynamics.org/roundup .
-!
-! Evolution of the code:
-! ---------------------
-!
-! v. 4.1_beta Dimitri Komatitsch, University of Pau, France, August 2008:
-! merged the mesher and the solver, support for diskless supercomputers,
-! converted many arrays from memory heap to stack (using automatic arrays instead of allocatable)
-! to avoid memory fragmentation in the case of very large models
-!
-! v. 4.0 David Michea and Dimitri Komatitsch, University of Pau, France, February 2008:
-! new doubling brick in the mesh, new perfectly load-balanced mesh,
-! more flexible routines for mesh design, new inflated central cube
-! with optimized shape, far fewer mesh files saved by the mesher,
-! global arrays sorted to speed up the simulation, seismograms can be
-! written by the master
-!
-! v. 3.6 Many people, many affiliations, September 2006:
-! adjoint and kernel calculations (by Qinya Liu), fixed IASP91 model,
-! added AK135 and 1066a, fixed topography/bathymetry routine,
-! new attenuation routines, faster and better I/Os on very large
-! systems, many small improvements and bug fixes, new "configure"
-! script, new Pyre version, new user's manual etc.
-!
-! v. 3.5 Dimitri Komatitsch, Brian Savage and Jeroen Tromp, Caltech, July 2004:
-! any size of chunk, 3D attenuation, case of two chunks,
-! more precise topography/bathymetry model, new Par_file structure
-!
-! v. 3.4 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2003:
-! merged global and regional codes, no iterations in fluid, better movies
-!
-! v. 3.3 Dimitri Komatitsch, Caltech, September 2002:
-! flexible mesh doubling in outer core, inlined code, OpenDX support for mesh files
-!
-! v. 3.2 Jeroen Tromp, Caltech, July 2002:
-! multiple sources and flexible PREM reading
-!
-! v. 3.1 Dimitri Komatitsch, Caltech, June 2002:
-! vectorized loops in solver and merged central cube
-!
-! v. 3.0 Dimitri Komatitsch and Jeroen Tromp, Caltech, May 2002:
-! ported to SGI and Compaq DEC Alpha, double precision solver, more general anisotropy
-!
-! v. 2.3 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2001:
-! gravity, rotation, oceans and 3-D models
-!
-! v. 2.2 Dimitri Komatitsch and Jeroen Tromp, Caltech, March 2001:
-! final MPI package
-!
-! v. 2.0 Dimitri Komatitsch, Harvard, January 2000:
-! MPI code for the globe
-!
-! v. 1.0 Dimitri Komatitsch, Mexico, June 1999:
-! first MPI code for a chunk
-!
-! Jeroen Tromp, Harvard, July 1998:
-! first chunk solver using OpenMP on Sun
-!
-! Dimitri Komatitsch, IPG Paris, December 1996:
-! first 3-D solver for the Connection Machine CM-5 (by Thinking Machines)
-!
-
-!! DK DK added this for merged version
-!! DK DK stored in single precision for merged version, check if it precise enough (probably yes)
-!! DK DK now defined as pointers, in order to be able to deallocate them
-!! DK DK see for instance http://www.pcc.qub.ac.uk/tec/courses/f77tof90/stu-notes/f90studentMIF_6.html
-!! DK DK Section 5.6 about this
- module dyn_array
-!---------------------------------------------------------------------
-! Module containing definitions needed to dynamically allocate the values of an array
-!---------------------------------------------------------------------
- include "constants.h"
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- xelm_store_crust_mantle,yelm_store_crust_mantle,zelm_store_crust_mantle, &
- xelm_store_outer_core,yelm_store_outer_core,zelm_store_outer_core, &
- xelm_store_inner_core,yelm_store_inner_core,zelm_store_inner_core
- end module dyn_array
-
- program main_program
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
-!! DK DK for the merged version
-! include values created by the mesher
- include "values_from_mesher.h"
-
-! proc numbers for MPI
- integer myrank,sizeprocs,ier
-
-! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
-! addressing for all the slices
- integer, dimension(0:NPROCTOT_VAL-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
-
- integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSOURCES
-
- integer, external :: err_occurred
-
-!! DK DK for the merged version
- include 'declarations_main.f90'
-
-! ************** PROGRAM STARTS HERE **************
-
-! initialize the MPI communicator and start the NPROCTOT MPI processes.
- call MPI_INIT(ier)
- if(ier /= 0) stop 'error: cannot start MPI!!!'
-
-! sizeprocs returns number of processes started (should be equal to NPROCTOT).
-! myrank is the rank of each process, between 0 and NPROCTOT-1.
-! as usual in MPI, process 0 is in charge of coordinating everything
-! and also takes care of the main output
-! do not create anything for the inner core here, will be done in solver
- call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
-
-! YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY
-
-!! DK DK for the merged version
-!!!!!!!! DK DK mesher inserted here
-!!!!!!!! DK DK mesher inserted here
-!!!!!!!! DK DK mesher inserted here
- include 'call_meshfem1.f90'
-
-! synchronize all the processes to make sure everybody has finished
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-! YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY
-
-!! DK DK for merged version, temporary patch for David's code to cut the superbrick
-!! DK DK which I have not fully ported to the merged version yet: I do not
-!! DK DK yet distinguish the two values of each array, therefore let me set them
-!! DK DK equal here
- npoin2D_xi_crust_mantle(2) = npoin2D_xi_crust_mantle(1)
- npoin2D_eta_crust_mantle(2) = npoin2D_eta_crust_mantle(1)
-
- npoin2D_xi_outer_core(2) = npoin2D_xi_outer_core(1)
- npoin2D_eta_outer_core(2) = npoin2D_eta_outer_core(1)
-
- npoin2D_xi_inner_core(2) = npoin2D_xi_inner_core(1)
- npoin2D_eta_inner_core(2) = npoin2D_eta_inner_core(1)
-
-!! DK DK added this to reduce the size of the buffers
-! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- npoin2D_max_all = max(maxval(npoin2D_xi_crust_mantle(:) + npoin2D_xi_inner_core(:)), &
- maxval(npoin2D_eta_crust_mantle(:) + npoin2D_eta_inner_core(:)))
- if(FEWER_MESSAGES_LARGER_BUFFERS) then
- NDIM_smaller_buffers = NDIM
- else
- NDIM_smaller_buffers = 1
- endif
-
-! read the number of receivers
- rec_filename = 'DATA/STATIONS'
- call get_value_string(STATIONS, 'solver.STATIONS', rec_filename)
-! get total number of receivers
- if(myrank == 0) then
- open(unit=IIN,file=STATIONS,iostat=ios,status='old',action='read')
- nrec = 0
- do while(ios == 0)
- read(IIN,"(a)",iostat=ios) dummystring
- if(ios == 0) nrec = nrec + 1
- enddo
- close(IIN)
- endif
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(nrec,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
-!! DK DK for the merged version
-!!!!!!!! DK DK solver inserted here
-!!!!!!!! DK DK solver inserted here
-!!!!!!!! DK DK solver inserted here
- include 'call_specfem1.f90'
-
-! synchronize all the processes to make sure everybody has finished
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-! stop all the MPI processes, and exit
- call MPI_FINALIZE(ier)
-
- end program main_program
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,1769 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! 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.
+!
+!=====================================================================
+
+!=====================================================================!
+! meshfem3D produces a spectral element grid for the Earth. !
+! This is accomplished based upon a mapping of the face of a cube !
+! to a portion of the sphere (Ronchi et al., The Cubed Sphere). !
+! Grid density is decreased by a factor of two !
+! three times in the radial direction. !
+!=====================================================================!
+
+!! DK DK for the merged version
+ subroutine meshfem3D(myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo,NSOURCES, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,ibool_crust_mantle,ibool_outer_core,ibool_inner_core, &
+ idoubling_crust_mantle,idoubling_inner_core,ibelm_bottom_crust_mantle, ibelm_bottom_outer_core, ibelm_top_outer_core, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
+ ibelm_top_inner_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
+ normal_bottom_outer_core, normal_top_outer_core,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle,kappavstore_inner_core,muvstore_inner_core, &
+ rmass_crust_mantle, rmass_outer_core, rmass_inner_core, &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+#ifdef USE_MPI
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core, iboolleft_eta_inner_core,iboolright_eta_inner_core,&
+ iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core, &
+ iboolcorner_crust_mantle,iboolcorner_outer_core,iboolcorner_inner_core, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+#endif
+ rmass_ocean_load,normal_top_crust_mantle,ibelm_top_crust_mantle,AM_V)
+
+ use dyn_array
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+
+!!!!!!!!!!! DK DK now in module dyn_array include "constants.h"
+ include "precision.h"
+#endif
+
+!! DK DK for the merged version
+! include values created by the mesher
+ include "values_from_mesher.h"
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: Qs ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+! correct number of spectral elements in each block depending on chunk type
+
+ integer nspec_tiso,npointot
+
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+! use the size of the largest region (crust_mantle) and therefore largest possible array
+! arrays with the mesh in double precision
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: xstore,ystore,zstore
+
+! proc numbers for MPI
+ integer myrank,sizeprocs,ier
+
+! check area and volume of the final mesh
+ double precision area_local_bottom,area_total_bottom
+ double precision area_local_top,area_total_top
+ double precision volume_local,volume_total,volume_total_region
+
+ integer iprocnum
+
+! for loop on all the slices
+ integer iregion_code,iregion
+ integer iproc_xi,iproc_eta,ichunk
+
+!! DK DK for the merged version
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+! use the size of the largest region (crust_mantle) and therefore largest possible array
+
+#ifdef USE_MPI
+ integer, dimension(NGLOB1D_RADIAL_CM) :: ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta
+
+ double precision, dimension(NGLOB1D_RADIAL_CM) :: &
+ xread1D_leftxi_lefteta,xread1D_rightxi_lefteta, &
+ xread1D_leftxi_righteta,xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta,yread1D_rightxi_lefteta, &
+ yread1D_leftxi_righteta,yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta,zread1D_rightxi_lefteta, &
+ zread1D_leftxi_righteta,zread1D_rightxi_righteta
+#endif
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+! for some statistics for the mesh
+ integer numelem_crust_mantle,numelem_outer_core,numelem_inner_core
+ integer numelem_total
+
+! timer MPI
+ double precision time_start,tCPU
+
+! addressing for all the slices
+ integer, dimension(0:NPROCTOT_VAL-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+
+! 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,RMOHO_FICTITIOUS_IN_MESHER, &
+ 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, &
+ ifirst_layer_aniso,ilast_layer_aniso
+
+ 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
+
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) OUTPUT_FILES,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, external :: err_occurred
+
+! 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
+
+! 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_layer_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! arrays for BCAST
+ integer, dimension(40) :: bcast_integer
+ double precision, dimension(30) :: bcast_double_precision
+ logical, dimension(26) :: bcast_logical
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+ integer itpspl(maxcoe,maxhpa)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ character(len=80) hsplfl(maxhpa)
+ character(len=40) dskker(maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=80) refmdl
+ character(len=40) varstr(maxker)
+
+! this for the different corners of the slice (which are different if the superbrick is cut)
+! 1 : xi_min, eta_min
+! 2 : xi_max, eta_min
+! 3 : xi_max, eta_max
+! 4 : xi_min, eta_max
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+
+! 1 -> min, 2 -> max
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
+
+ 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 :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll,wxgll
+ double precision, dimension(NGLLY) :: yigll,wygll
+ double precision, dimension(NGLLZ) :: zigll,wzgll
+
+! 3D shape functions and their derivatives
+ double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
+ double precision, dimension(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ) :: dershape3D
+
+! 2D shape functions and their derivatives
+ double precision shape2D_x(NGNOD2D,NGLLY,NGLLZ)
+ double precision shape2D_y(NGNOD2D,NGLLX,NGLLZ)
+ double precision shape2D_bottom(NGNOD2D,NGLLX,NGLLY)
+ double precision shape2D_top(NGNOD2D,NGLLX,NGLLY)
+
+ double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ)
+ double precision dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
+ double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+ double precision dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: rhostore_local,kappavstore_local
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store
+
+ logical, dimension(6,NSPEC_CRUST_MANTLE) :: iboun
+
+! very large arrays used for the sorting routine
+ integer, dimension(NSPEC_CRUST_MANTLE * NGLLX * NGLLY * NGLLZ) :: locval
+ logical, dimension(NSPEC_CRUST_MANTLE * NGLLX * NGLLY * NGLLZ) :: ifseg
+ double precision, dimension(NSPEC_CRUST_MANTLE * NGLLX * NGLLY * NGLLZ) :: xp,yp,zp
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+
+ integer, dimension(NGLOB_CRUST_MANTLE) :: mask_ibool
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: copy_ibool_ori
+
+ logical, dimension(2,NSPEC_CRUST_MANTLE) :: iMPIcut_xi,iMPIcut_eta
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: rho_vp,rho_vs
+
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: Qmu_store
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: tau_e_store
+
+!!!!! DK DK for merged version, all the arrays below are allocated statically instead
+
+#ifdef USE_MPI
+ integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer npoin2D_faces_outer_core(NUMFACES_SHARED)
+ integer npoin2D_faces_inner_core(NUMFACES_SHARED)
+
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ npoin2D_xi_inner_core,npoin2D_eta_inner_core
+#endif
+
+! number of elements on the boundaries
+ integer :: nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle,nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
+ integer :: nspec2D_xmin_outer_core,nspec2D_xmax_outer_core,nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
+ integer :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: kappavstore_crust_mantle,muvstore_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: kappavstore_inner_core,muvstore_inner_core
+
+!! DK DK these arrays are useless in the solver and will therefore be allocated with a dummy size of 1
+ real(kind=CUSTOM_REAL), dimension(1,1,1,1) :: kappahstore_inner_core,muhstore_inner_core,eta_anisostore_inner_core
+ real(kind=CUSTOM_REAL), dimension(1,1,1,1) :: kappavstore_outer_core,muvstore_outer_core
+ real(kind=CUSTOM_REAL), dimension(1,1,1,1) :: kappahstore_outer_core,muhstore_outer_core,eta_anisostore_outer_core
+
+! 2-D jacobians and normals
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_IC) :: jacobian2D_xmin_inner_core,jacobian2D_xmax_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_IC) :: jacobian2D_ymin_inner_core,jacobian2D_ymax_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_IC) :: jacobian2D_bottom_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_IC) :: jacobian2D_top_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_IC) :: normal_xmin_inner_core,normal_xmax_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_IC) :: normal_ymin_inner_core,normal_ymax_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_IC) :: normal_bottom_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_IC) :: normal_top_inner_core
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
+ integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_CM) :: &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: jacobian2D_bottom_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: jacobian2D_top_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: normal_xmin_crust_mantle,normal_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2DMAX_YMIN_YMAX_CM) :: normal_ymin_crust_mantle,normal_ymax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: normal_bottom_crust_mantle
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+ integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: normal_xmin_outer_core,normal_xmax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: normal_ymin_outer_core,normal_ymax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
+ integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
+
+#ifdef USE_MPI
+ integer, dimension(NGLOB2DMAX_XY_VAL_CM,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_VAL_OC,NUMFACES_SHARED) :: iboolfaces_outer_core
+ integer, dimension(NGLOB2DMAX_XY_VAL_IC,NUMFACES_SHARED) :: iboolfaces_inner_core
+#endif
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
+
+!! DK DK this array is useless in the solver and is therefore allocated with a dummy size of 1
+ integer, dimension(1) :: idoubling_outer_core
+
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+
+#ifdef USE_MPI
+ integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
+ integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
+
+!---- arrays to assemble between chunks
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES_VAL) :: imsg_type,iprocfrom_faces,iprocto_faces
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+#endif
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! open main output file, only written to by process 0
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
+ open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_mesher.txt',status='unknown',action='write')
+
+! get MPI starting time
+#ifdef USE_MPI
+ time_start = MPI_WTIME()
+#else
+ time_start = 0
+ write(IMAIN,*)
+ write(IMAIN,*) '******************************************************************'
+ write(IMAIN,*) '*** This is a serial test run (MPI turned off)'
+ write(IMAIN,*) '*** that will not compute seismograms'
+ write(IMAIN,*) '*** but that will test the stability of the code in one mesh slice'
+ write(IMAIN,*) '******************************************************************'
+ write(IMAIN,*)
+#endif
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*) '*** Specfem3D MPI Mesher ***'
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*)
+ endif
+
+ if (myrank==0) then
+! 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,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,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_layer_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,ifirst_layer_aniso,ilast_layer_aniso,.false.)
+
+ if(err_occurred() /= 0) call exit_MPI(myrank,'an error occurred while reading the parameter file')
+
+! count the total number of sources in the CMTSOLUTION file
+ call count_number_of_sources(NSOURCES)
+
+ bcast_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,RMOHO_FICTITIOUS_IN_MESHER, &
+ 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,NPROC,NPROCTOT, &
+ NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,ifirst_layer_aniso,ilast_layer_aniso/)
+
+ bcast_logical = (/TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D,&
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,SAVE_ALL_SEISMOS_IN_ONE_FILE/)
+
+ 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, &
+ 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/)
+
+ endif
+
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(bcast_integer,40,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_double_precision,30,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_logical,25,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(MODEL,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(ner,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ratio_sampling_array,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(doubling_index,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(r_bottom,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(r_top,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmins,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(this_layer_has_a_doubling,MAX_NUMBER_OF_MESH_LAYERS,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(NSPEC,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_XI,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_ETA,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_BOTTOM,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_TOP,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(DIFF_NSPEC1D_RADIAL,NB_SQUARE_CORNERS*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(DIFF_NSPEC2D_ETA,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(DIFF_NSPEC2D_XI,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+#endif
+
+ if (myrank /=0) then
+
+ MIN_ATTENUATION_PERIOD = bcast_integer(1)
+ MAX_ATTENUATION_PERIOD = bcast_integer(2)
+ NER_CRUST = bcast_integer(3)
+ NER_80_MOHO = bcast_integer(4)
+ NER_220_80 = bcast_integer(5)
+ NER_400_220 = bcast_integer(6)
+ NER_600_400 = bcast_integer(7)
+ NER_670_600 = bcast_integer(8)
+ NER_771_670 = bcast_integer(9)
+ NER_TOPDDOUBLEPRIME_771 = bcast_integer(10)
+ NER_CMB_TOPDDOUBLEPRIME = bcast_integer(11)
+ NER_OUTER_CORE = bcast_integer(12)
+ NER_TOP_CENTRAL_CUBE_ICB = bcast_integer(13)
+ NEX_XI = bcast_integer(14)
+ NEX_ETA = bcast_integer(15)
+ RMOHO_FICTITIOUS_IN_MESHER = bcast_integer(16)
+ NPROC_XI = bcast_integer(17)
+ NPROC_ETA = bcast_integer(18)
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS = bcast_integer(19)
+ NTSTEP_BETWEEN_READ_ADJSRC = bcast_integer(20)
+ NSTEP = bcast_integer(21)
+ NSOURCES = bcast_integer(22)
+ NTSTEP_BETWEEN_FRAMES = bcast_integer(23)
+ NTSTEP_BETWEEN_OUTPUT_INFO = bcast_integer(24)
+ NUMBER_OF_RUNS = bcast_integer(25)
+ NUMBER_OF_THIS_RUN = bcast_integer(26)
+ NCHUNKS = bcast_integer(27)
+ SIMULATION_TYPE = bcast_integer(28)
+ REFERENCE_1D_MODEL = bcast_integer(29)
+ THREE_D_MODEL = bcast_integer(30)
+ NPROC = bcast_integer(31)
+ NPROCTOT = bcast_integer(32)
+ NEX_PER_PROC_XI = bcast_integer(33)
+ NEX_PER_PROC_ETA = bcast_integer(34)
+ ratio_divide_central_cube = bcast_integer(35)
+ MOVIE_VOLUME_TYPE = bcast_integer(36)
+ MOVIE_START = bcast_integer(37)
+ MOVIE_STOP = bcast_integer(38)
+ ifirst_layer_aniso = bcast_integer(39)
+ ilast_layer_aniso = bcast_integer(40)
+
+ TRANSVERSE_ISOTROPY = bcast_logical(1)
+ ANISOTROPIC_3D_MANTLE = bcast_logical(2)
+ ANISOTROPIC_INNER_CORE = bcast_logical(3)
+ CRUSTAL = bcast_logical(4)
+ ELLIPTICITY = bcast_logical(5)
+ GRAVITY = bcast_logical(6)
+ ONE_CRUST = bcast_logical(7)
+ ROTATION = bcast_logical(8)
+ ISOTROPIC_3D_MANTLE = bcast_logical(9)
+ TOPOGRAPHY = bcast_logical(10)
+ OCEANS = bcast_logical(11)
+ MOVIE_SURFACE = bcast_logical(12)
+ MOVIE_VOLUME = bcast_logical(13)
+ ATTENUATION_3D = bcast_logical(14)
+ RECEIVERS_CAN_BE_BURIED = bcast_logical(15)
+ PRINT_SOURCE_TIME_FUNCTION = bcast_logical(16)
+ SAVE_MESH_FILES = bcast_logical(17)
+ ATTENUATION = bcast_logical(18)
+ ABSORBING_CONDITIONS = bcast_logical(19)
+ INCLUDE_CENTRAL_CUBE = bcast_logical(20)
+ INFLATE_CENTRAL_CUBE = bcast_logical(21)
+ SAVE_FORWARD = bcast_logical(22)
+ CASE_3D = bcast_logical(23)
+ CUT_SUPERBRICK_XI = bcast_logical(24)
+ CUT_SUPERBRICK_ETA = bcast_logical(25)
+ SAVE_ALL_SEISMOS_IN_ONE_FILE = bcast_logical(26)
+
+ DT = bcast_double_precision(1)
+ ANGULAR_WIDTH_XI_IN_DEGREES = bcast_double_precision(2)
+ ANGULAR_WIDTH_ETA_IN_DEGREES = bcast_double_precision(3)
+ CENTER_LONGITUDE_IN_DEGREES = bcast_double_precision(4)
+ CENTER_LATITUDE_IN_DEGREES = bcast_double_precision(5)
+ GAMMA_ROTATION_AZIMUTH = bcast_double_precision(6)
+ ROCEAN = bcast_double_precision(7)
+ RMIDDLE_CRUST = bcast_double_precision(8)
+ RMOHO = bcast_double_precision(9)
+ R80 = bcast_double_precision(10)
+ R120 = bcast_double_precision(11)
+ R220 = bcast_double_precision(12)
+ R400 = bcast_double_precision(13)
+ R600 = bcast_double_precision(14)
+ R670 = bcast_double_precision(15)
+ R771 = bcast_double_precision(16)
+ RTOPDDOUBLEPRIME = bcast_double_precision(17)
+ RCMB = bcast_double_precision(18)
+ RICB = bcast_double_precision(19)
+ R_CENTRAL_CUBE = bcast_double_precision(20)
+ RHO_TOP_OC = bcast_double_precision(21)
+ RHO_BOTTOM_OC = bcast_double_precision(22)
+ RHO_OCEANS = bcast_double_precision(23)
+ HDUR_MOVIE = bcast_double_precision(24)
+ MOVIE_TOP = bcast_double_precision(25)
+ MOVIE_BOTTOM = bcast_double_precision(26)
+ MOVIE_WEST = bcast_double_precision(27)
+ MOVIE_EAST = bcast_double_precision(28)
+ MOVIE_NORTH = bcast_double_precision(29)
+ MOVIE_SOUTH = bcast_double_precision(30)
+
+ endif
+
+! check that the code is running with the requested number of processes
+ if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
+
+ addressing(:,:,:) = 0
+ ichunk_slice(:) = 0
+ iproc_xi_slice(:) = 0
+ iproc_eta_slice(:) = 0
+
+! loop on all the chunks to create global slice addressing for solver
+ if(myrank == 0) then
+ write(IMAIN,*) 'creating global slice addressing'
+ write(IMAIN,*)
+ endif
+ do ichunk = 1,NCHUNKS
+ do iproc_eta=0,NPROC_ETA-1
+ do iproc_xi=0,NPROC_XI-1
+ iprocnum = (ichunk-1)*NPROC + iproc_eta * NPROC_XI + iproc_xi
+ addressing(ichunk,iproc_xi,iproc_eta) = iprocnum
+ ichunk_slice(iprocnum) = ichunk
+ iproc_xi_slice(iprocnum) = iproc_xi
+ iproc_eta_slice(iprocnum) = iproc_eta
+ enddo
+ enddo
+ enddo
+
+! this for the different counters (which are now different if the superbrick is cut in the outer core)
+ do iregion=1,MAX_NUM_REGIONS
+ NSPEC1D_RADIAL_CORNER(iregion,:) = NSPEC1D_RADIAL(iregion)
+ NSPEC2D_XI_FACE(iregion,:) = NSPEC2D_XI(iregion)
+ NSPEC2D_ETA_FACE(iregion,:) = NSPEC2D_ETA(iregion)
+ NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
+ enddo
+
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_xi_slice(myrank),2) == 0) then
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ else
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,3)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,3)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,3)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,4)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,4)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,4)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (mod(iproc_xi_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ endif
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'This is process ',myrank
+ write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
+ write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
+ write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
+ write(IMAIN,*) 'There are ',NCHUNKS,' chunks in the global mesh'
+ write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in the global mesh'
+ write(IMAIN,*)
+ write(IMAIN,*) 'NGLLX = ',NGLLX
+ write(IMAIN,*) 'NGLLY = ',NGLLY
+ write(IMAIN,*) 'NGLLZ = ',NGLLZ
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Shape functions defined by NGNOD = ',NGNOD,' control nodes'
+ write(IMAIN,*) 'Surface shape functions defined by NGNOD2D = ',NGNOD2D,' control nodes'
+ write(IMAIN,*)
+ write(IMAIN,*)
+ endif
+
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ if(ELLIPTICITY) then
+ write(IMAIN,*) 'incorporating ellipticity'
+ else
+ write(IMAIN,*) 'no ellipticity'
+ endif
+
+ write(IMAIN,*)
+ if(TOPOGRAPHY) then
+ write(IMAIN,*) 'incorporating surface topography'
+ else
+ write(IMAIN,*) 'no surface topography'
+ endif
+
+ write(IMAIN,*)
+ if(ISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) 'incorporating 3-D lateral variations'
+ else
+ write(IMAIN,*) 'no 3-D lateral variations'
+ endif
+
+ write(IMAIN,*)
+ if(CRUSTAL) then
+ write(IMAIN,*) 'incorporating crustal variations'
+ else
+ write(IMAIN,*) 'no crustal variations'
+ endif
+
+ write(IMAIN,*)
+ if(ONE_CRUST) then
+ write(IMAIN,*) 'using one layer only in PREM crust'
+ else
+ write(IMAIN,*) 'using unmodified 1D crustal model with two layers'
+ endif
+
+ write(IMAIN,*)
+ if(GRAVITY) then
+ write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)'
+ else
+ write(IMAIN,*) 'no self-gravitation'
+ endif
+
+ write(IMAIN,*)
+ if(ROTATION) then
+ write(IMAIN,*) 'incorporating rotation'
+ else
+ write(IMAIN,*) 'no rotation'
+ endif
+
+ write(IMAIN,*)
+ if(TRANSVERSE_ISOTROPY) then
+ write(IMAIN,*) 'incorporating anisotropy'
+ else
+ write(IMAIN,*) 'no anisotropy'
+ endif
+
+ write(IMAIN,*)
+ if(ATTENUATION) then
+ write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
+ if(ATTENUATION_3D) write(IMAIN,*)'using 3D attenuation'
+ else
+ write(IMAIN,*) 'no attenuation'
+ endif
+
+ write(IMAIN,*)
+ if(OCEANS) then
+ write(IMAIN,*) 'incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) 'no oceans'
+ endif
+
+ write(IMAIN,*)
+
+ endif
+
+ if(ELLIPTICITY) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
+
+ if(ISOTROPIC_3D_MANTLE) then
+ if(THREE_D_MODEL /= 0) call read_smooth_moho
+ if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
+! the variables read are declared and stored in structure D3MM_V
+ if(myrank == 0) call read_mantle_model(D3MM_V)
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(D3MM_V%dvs_a,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%dvs_b,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%dvp_a,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%dvp_b,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%spknt,NK+1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%qq0,(NK+1)*(NK+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%qq,3*(NK+1)*(NK+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
+! the variables read are declared and stored in structure SEA99M_V and JP3DM_V
+ if(myrank == 0) then
+ call read_sea99_s_model(SEA99M_V)
+ call read_iso3d_dpzhao_model(JP3DM_V)
+ endif
+! broadcast the information read on the master to the nodes
+! SEA99M_V
+#ifdef USE_MPI
+ call MPI_BCAST(SEA99M_V%sea99_ndep,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_ddeg,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_vs,100*100*100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_depth,100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+! JP3DM_V
+ call MPI_BCAST(JP3DM_V%NPA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NPB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNA,MPA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNA,MRA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNA,MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNB,MPB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNB,MRB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNB,MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELAP,MPA*MRA*MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELBP,MPB*MRB*MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PN,51,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RRN,63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPA,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPB,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPC,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%WV,8,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%P,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%R,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VP,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VS,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
+! the variables read are declared and stored in structure SEA99M_V
+ if(myrank == 0) call read_sea99_s_model(SEA99M_V)
+! broadcast the information read on the master to the nodes
+! SEA99M_V
+#ifdef USE_MPI
+ call MPI_BCAST(SEA99M_V%sea99_ndep,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_ddeg,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_vs,100*100*100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_depth,100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+
+ elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+! the variables read are declared and stored in structure JP3DM_V
+ if(myrank == 0) call read_iso3d_dpzhao_model(JP3DM_V)
+! JP3DM_V
+#ifdef USE_MPI
+ call MPI_BCAST(JP3DM_V%NPA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NPB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNA,MPA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNA,MRA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNA,MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNB,MPB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNB,MRB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNB,MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELAP,MPA*MRA*MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELBP,MPB*MRB*MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PN,51,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RRN,63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPA,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPB,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPC,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%WV,8,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%P,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%R,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VP,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VS,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
+ .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then
+ if(myrank == 0) call read_model_s362ani(THREE_D_MODEL,THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
+ THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA, &
+ numker,numhpa,ihpa,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
+ xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
+#ifdef USE_MPI
+ call MPI_BCAST(numker,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(numhpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ihpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(lmxhpa,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(itypehpa,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ihpakern,maxker,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(numcoe,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ivarkern,maxker,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(itpspl,maxcoe*maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(xlaspl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(xlospl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(radspl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(coe,maxcoe*maxker,MPI_REAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(hsplfl,80*maxhpa,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(dskker,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(kerstr,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(refmdl,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(varstr,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+#endif
+
+ else
+ call exit_MPI(myrank,'3D model not defined')
+ endif
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE) then
+! the variables read are declared and stored in structure AMM_V
+ if(myrank == 0) call read_aniso_mantle_model(AMM_V)
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(AMM_V%npar1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AMM_V%beta,14*34*37*73,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AMM_V%pro,47,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+ endif
+
+ if(CRUSTAL) then
+! the variables read are declared and stored in structure CM_V
+ if(myrank == 0) call read_crustal_model(CM_V)
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(CM_V%thlr,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%velocp,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%velocs,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%dens,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%abbreviation,NCAP_CRUST*NCAP_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%code,2*NKEYS_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+#endif
+ endif
+
+ if(ANISOTROPIC_INNER_CORE) then
+ if(myrank == 0) call read_aniso_inner_core_model
+! one should add an MPI_BCAST here if one adds a read_aniso_inner_core_model subroutine
+ endif
+
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V)
+#ifdef USE_MPI
+ call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%max_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%QT_c_source, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%Qtau_s(1), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%Qtau_s(2), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%Qtau_s(3), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+#endif
+ endif
+
+ if(ATTENUATION .and. .not. ATTENUATION_3D) then
+ if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V)
+#ifdef USE_MPI
+ call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%max_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+#endif
+ call attenuation_model_setup(REFERENCE_1D_MODEL, RICB, RCMB, R670, R220, R80,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,AM_S,AS_V)
+ endif
+
+! read topography and bathymetry file
+ if(TOPOGRAPHY .or. OCEANS) then
+ if(myrank == 0) call read_topo_bathy_file(ibathy_topo)
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(ibathy_topo,NX_BATHY*NY_BATHY,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+#endif
+ endif
+
+! get addressing for this process
+ ichunk = ichunk_slice(myrank)
+ iproc_xi = iproc_xi_slice(myrank)
+ iproc_eta = iproc_eta_slice(myrank)
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
+ write(IMAIN,*)
+ write(IMAIN,*) 'Central cube is at a radius of ',R_CENTRAL_CUBE/1000.d0,' km'
+ endif
+
+! compute rotation matrix from Euler angles
+ ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * PI / 180.d0
+ ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * PI / 180.d0
+ if(NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
+
+! volume of the slice
+ volume_total = ZERO
+
+!! DK DK for the merged version
+ allocate(xelm_store_crust_mantle(NGNOD,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(yelm_store_crust_mantle(NGNOD,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(zelm_store_crust_mantle(NGNOD,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+
+ allocate(xelm_store_outer_core(NGNOD,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(yelm_store_outer_core(NGNOD,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(zelm_store_outer_core(NGNOD,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+
+ allocate(xelm_store_inner_core(NGNOD,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(yelm_store_inner_core(NGNOD,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(zelm_store_inner_core(NGNOD,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+
+!----
+!---- loop on all the regions of the mesh
+!----
+
+! number of regions in full Earth
+ do iregion_code = 1,MAX_NUM_REGIONS
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '*******************************************'
+ write(IMAIN,*) 'creating mesh in region ',iregion_code
+
+ select case(iregion_code)
+
+ case(IREGION_CRUST_MANTLE)
+ write(IMAIN,*) 'this region is the crust and mantle'
+
+ case(IREGION_OUTER_CORE)
+ write(IMAIN,*) 'this region is the outer core'
+
+ case(IREGION_INNER_CORE)
+ write(IMAIN,*) 'this region is the inner core'
+
+ case default
+ call exit_MPI(myrank,'incorrect region code')
+ end select
+ write(IMAIN,*) '*******************************************'
+ write(IMAIN,*)
+ endif
+
+! compute maximum number of points
+ npointot = NSPEC(iregion_code) * NGLLX * NGLLY * NGLLZ
+
+! create all the regions of the mesh
+
+!! DK DK for merged version
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+! crust_mantle
+ call create_regions_mesh(iregion_code,ibool_crust_mantle,idoubling_crust_mantle,xstore,ystore,zstore,rmins,rmaxs,iproc_xi, &
+ iproc_eta,ichunk,NSPEC(iregion_code),nspec_tiso,volume_local,area_local_bottom,area_local_top,nspl,rspl,espl,espl2, &
+ nglob(iregion_code),npointot,NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NSPEC2DMAX_XMIN_XMAX(iregion_code), &
+ NSPEC2DMAX_YMIN_YMAX(iregion_code),NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code),ELLIPTICITY,TOPOGRAPHY, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST,NPROC_XI,NPROC_ETA, &
+ myrank,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,ATTENUATION,ATTENUATION_3D,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL,R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,ner,ratio_sampling_array,doubling_index,r_bottom,r_top, &
+ this_layer_has_a_doubling,CASE_3D,AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2),nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle,ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle,ibelm_ymin_crust_mantle, &
+ ibelm_ymax_crust_mantle,ibelm_bottom_crust_mantle,ibelm_top_crust_mantle,jacobian2D_xmin_crust_mantle, &
+ jacobian2D_xmax_crust_mantle,jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle,jacobian2D_bottom_crust_mantle, &
+ jacobian2D_top_crust_mantle,normal_xmin_crust_mantle,normal_xmax_crust_mantle,normal_ymin_crust_mantle,normal_ymax_crust_mantle, &
+ normal_bottom_crust_mantle,normal_top_crust_mantle,kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle,rmass_crust_mantle,xelm_store_crust_mantle,yelm_store_crust_mantle, &
+ zelm_store_crust_mantle,xigll,wxgll,yigll,wygll,zigll,wzgll,shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top,rhostore_local,kappavstore_local,c11store,c12store,c13store,c14store, &
+ c15store,c16store,c22store,c23store,c24store,c25store,c26store,c33store,c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store,iboun,locval,ifseg,xp,yp,zp,rmass_ocean_load,mask_ibool,copy_ibool_ori,iMPIcut_xi,iMPIcut_eta, &
+#ifdef USE_MPI
+ maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)),NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+!! DK DK this below with index (1) will have to change to fully support David's code to cut the superbrick
+ NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM,npoin2D_xi_crust_mantle(1),npoin2D_eta_crust_mantle(1),iboolleft_xi_crust_mantle,&
+ iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle,ibool1D_leftxi_lefteta, &
+ ibool1D_rightxi_lefteta,ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,xread1D_leftxi_lefteta,xread1D_rightxi_lefteta, &
+ xread1D_leftxi_righteta,xread1D_rightxi_righteta,yread1D_leftxi_lefteta,yread1D_rightxi_lefteta,yread1D_leftxi_righteta, &
+ yread1D_rightxi_righteta,zread1D_leftxi_lefteta,zread1D_rightxi_lefteta,zread1D_leftxi_righteta,zread1D_rightxi_righteta, &
+#endif
+ rho_vp,rho_vs,Qmu_store,tau_e_store,ifirst_layer_aniso,ilast_layer_aniso)
+
+ else if(iregion_code == IREGION_OUTER_CORE) then
+! outer_core
+ call create_regions_mesh(iregion_code,ibool_outer_core,idoubling_outer_core,xstore,ystore,zstore,rmins,rmaxs,iproc_xi, &
+ iproc_eta,ichunk,NSPEC(iregion_code),nspec_tiso,volume_local,area_local_bottom,area_local_top,nspl,rspl,espl,espl2, &
+ nglob(iregion_code),npointot,NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NSPEC2DMAX_XMIN_XMAX(iregion_code), &
+ NSPEC2DMAX_YMIN_YMAX(iregion_code),NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code),ELLIPTICITY,TOPOGRAPHY, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST,NPROC_XI,NPROC_ETA, &
+ myrank,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,ATTENUATION,ATTENUATION_3D,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL,R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,ner,ratio_sampling_array,doubling_index,r_bottom,r_top, &
+ this_layer_has_a_doubling,CASE_3D,AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2),nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core,ibelm_xmin_outer_core,ibelm_xmax_outer_core,ibelm_ymin_outer_core, &
+ ibelm_ymax_outer_core,ibelm_bottom_outer_core,ibelm_top_outer_core,jacobian2D_xmin_outer_core, &
+ jacobian2D_xmax_outer_core,jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core,jacobian2D_bottom_outer_core, &
+ jacobian2D_top_outer_core,normal_xmin_outer_core,normal_xmax_outer_core,normal_ymin_outer_core,normal_ymax_outer_core, &
+ normal_bottom_outer_core,normal_top_outer_core,kappavstore_outer_core,kappahstore_outer_core,muvstore_outer_core, &
+ muhstore_outer_core,eta_anisostore_outer_core,rmass_outer_core,xelm_store_outer_core,yelm_store_outer_core, &
+ zelm_store_outer_core,xigll,wxgll,yigll,wygll,zigll,wzgll,shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top,rhostore_local,kappavstore_local,c11store,c12store,c13store,c14store, &
+ c15store,c16store,c22store,c23store,c24store,c25store,c26store,c33store,c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store,iboun,locval,ifseg,xp,yp,zp,rmass_ocean_load,mask_ibool,copy_ibool_ori,iMPIcut_xi,iMPIcut_eta, &
+#ifdef USE_MPI
+ maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)),NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+!! DK DK this below with index (1) will have to change to fully support David's code to cut the superbrick
+ NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC,npoin2D_xi_outer_core(1),npoin2D_eta_outer_core(1),iboolleft_xi_outer_core, &
+ iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core,ibool1D_leftxi_lefteta, &
+ ibool1D_rightxi_lefteta,ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,xread1D_leftxi_lefteta,xread1D_rightxi_lefteta, &
+ xread1D_leftxi_righteta,xread1D_rightxi_righteta,yread1D_leftxi_lefteta,yread1D_rightxi_lefteta,yread1D_leftxi_righteta, &
+ yread1D_rightxi_righteta,zread1D_leftxi_lefteta,zread1D_rightxi_lefteta,zread1D_leftxi_righteta,zread1D_rightxi_righteta, &
+#endif
+ rho_vp,rho_vs,Qmu_store,tau_e_store,ifirst_layer_aniso,ilast_layer_aniso)
+
+ else if(iregion_code == IREGION_INNER_CORE) then
+! inner_core
+ call create_regions_mesh(iregion_code,ibool_inner_core,idoubling_inner_core,xstore,ystore,zstore,rmins,rmaxs,iproc_xi, &
+ iproc_eta,ichunk,NSPEC(iregion_code),nspec_tiso,volume_local,area_local_bottom,area_local_top,nspl,rspl,espl,espl2, &
+ nglob(iregion_code),npointot,NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NSPEC2DMAX_XMIN_XMAX(iregion_code), &
+ NSPEC2DMAX_YMIN_YMAX(iregion_code),NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code),ELLIPTICITY,TOPOGRAPHY, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST,NPROC_XI,NPROC_ETA, &
+ myrank,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,ATTENUATION,ATTENUATION_3D,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL,R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,ner,ratio_sampling_array,doubling_index,r_bottom,r_top, &
+ this_layer_has_a_doubling,CASE_3D,AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2),nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
+ nspec2D_ymin_inner_core,nspec2D_ymax_inner_core,ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core, &
+ ibelm_ymax_inner_core,ibelm_bottom_inner_core,ibelm_top_inner_core,jacobian2D_xmin_inner_core, &
+ jacobian2D_xmax_inner_core,jacobian2D_ymin_inner_core,jacobian2D_ymax_inner_core,jacobian2D_bottom_inner_core, &
+ jacobian2D_top_inner_core,normal_xmin_inner_core,normal_xmax_inner_core,normal_ymin_inner_core,normal_ymax_inner_core, &
+ normal_bottom_inner_core,normal_top_inner_core,kappavstore_inner_core,kappahstore_inner_core,muvstore_inner_core, &
+ muhstore_inner_core,eta_anisostore_inner_core,rmass_inner_core,xelm_store_inner_core,yelm_store_inner_core, &
+ zelm_store_inner_core,xigll,wxgll,yigll,wygll,zigll,wzgll,shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top,rhostore_local,kappavstore_local,c11store,c12store,c13store,c14store, &
+ c15store,c16store,c22store,c23store,c24store,c25store,c26store,c33store,c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store,iboun,locval,ifseg,xp,yp,zp,rmass_ocean_load,mask_ibool,copy_ibool_ori,iMPIcut_xi,iMPIcut_eta, &
+#ifdef USE_MPI
+ maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)),NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+!! DK DK this below with index (1) will have to change to fully support David's code to cut the superbrick
+ NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC,npoin2D_xi_inner_core(1),npoin2D_eta_inner_core(1),iboolleft_xi_inner_core, &
+ iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core,ibool1D_leftxi_lefteta, &
+ ibool1D_rightxi_lefteta,ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,xread1D_leftxi_lefteta,xread1D_rightxi_lefteta, &
+ xread1D_leftxi_righteta,xread1D_rightxi_righteta,yread1D_leftxi_lefteta,yread1D_rightxi_lefteta,yread1D_leftxi_righteta, &
+ yread1D_rightxi_righteta,zread1D_leftxi_lefteta,zread1D_rightxi_lefteta,zread1D_leftxi_righteta,zread1D_rightxi_righteta, &
+#endif
+ rho_vp,rho_vs,Qmu_store,tau_e_store,ifirst_layer_aniso,ilast_layer_aniso)
+
+ else
+ stop 'DK DK incorrect region in merged code'
+ endif
+
+! store number of anisotropic elements found in the mantle
+ if(nspec_tiso /= 0 .and. iregion_code /= IREGION_CRUST_MANTLE) &
+ call exit_MPI(myrank,'found transversely isotropic elements outside of the mantle')
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. nspec_tiso == 0) &
+ call exit_MPI(myrank,'found no transversely isotropic elements in the mantle')
+
+! use MPI reduction to compute total area and volume
+!! DK DK suppressed for now in the merged version, for simplicity
+ volume_total_region = ZERO
+ area_total_bottom = ZERO
+ area_total_top = ZERO
+#ifdef USE_MPI
+ call MPI_REDUCE(area_local_bottom,area_total_bottom,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
+ MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(area_local_top,area_total_top,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
+ MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(volume_local,volume_total_region,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
+ MPI_COMM_WORLD,ier)
+#else
+ area_total_bottom = area_local_bottom
+ area_total_top = area_local_top
+ volume_total_region = volume_local
+#endif
+
+ if(myrank == 0) then
+! sum volume over all the regions
+ volume_total = volume_total + volume_total_region
+
+! check volume of chunk, and bottom and top area
+
+ write(IMAIN,*)
+ write(IMAIN,*) ' calculated top area: ',area_total_top
+
+! compare to exact theoretical value
+ if(NCHUNKS == 6 .and. .not. TOPOGRAPHY) then
+ select case(iregion_code)
+
+ case(IREGION_CRUST_MANTLE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*R_UNIT_SPHERE**2
+
+ case(IREGION_OUTER_CORE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RCMB/R_EARTH)**2
+
+ case(IREGION_INNER_CORE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RICB/R_EARTH)**2
+
+ case default
+ call exit_MPI(myrank,'incorrect region code')
+ end select
+ endif
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'calculated bottom area: ',area_total_bottom
+
+! compare to exact theoretical value
+ if(NCHUNKS == 6 .and. .not. TOPOGRAPHY) then
+
+ select case(iregion_code)
+
+ case(IREGION_CRUST_MANTLE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RCMB/R_EARTH)**2
+
+ case(IREGION_OUTER_CORE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RICB/R_EARTH)**2
+
+ case(IREGION_INNER_CORE)
+ write(IMAIN,*) ' exact area (central cube): ',dble(NCHUNKS)*(2.*(R_CENTRAL_CUBE / R_EARTH)/sqrt(3.))**2
+
+ case default
+ call exit_MPI(myrank,'incorrect region code')
+ end select
+ endif
+
+ endif
+
+!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+#ifdef USE_MPI
+
+! create chunk buffers if more than one chunk
+ if(NCHUNKS > 1) then
+
+!! DK DK added this for merged version
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+! crust_mantle
+ call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool_crust_mantle,idoubling_crust_mantle,xstore,ystore,zstore, &
+ nglob(iregion_code), &
+ NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
+ NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
+ NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
+ myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle,nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle,ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_crust_mantle,npoin2D_faces_crust_mantle,iboolcorner_crust_mantle,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_XY_VAL_CM)
+
+ else if(iregion_code == IREGION_OUTER_CORE) then
+! outer_core
+ call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool_outer_core,idoubling_outer_core,xstore,ystore,zstore, &
+ nglob(iregion_code), &
+ NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
+ NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
+ NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
+ myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core,nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core,ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_outer_core,npoin2D_faces_outer_core,iboolcorner_outer_core,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XY_VAL_OC)
+
+ else if(iregion_code == IREGION_INNER_CORE) then
+! inner_core
+ call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool_inner_core,idoubling_inner_core,xstore,ystore,zstore, &
+ nglob(iregion_code), &
+ NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
+ NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
+ NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
+ myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_inner_core,npoin2D_faces_inner_core,iboolcorner_inner_core,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
+ NGLOB2DMAX_XY_VAL_IC)
+
+ else
+ stop 'DK DK incorrect region in merged code'
+ endif
+
+ else
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'only one chunk, no need to create chunk buffers'
+ write(IMAIN,*)
+ endif
+ endif
+
+#endif
+
+! end of loop on all the regions
+ enddo
+
+ if(myrank == 0) then
+! check volume of chunk
+ write(IMAIN,*)
+ write(IMAIN,*) 'calculated volume: ',volume_total
+ if(.not. TOPOGRAPHY) then
+! take the central cube into account
+! it is counted 6 times because of the fictitious elements
+ if(INCLUDE_CENTRAL_CUBE) then
+ write(IMAIN,*) ' exact volume: ', &
+ dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)+5.*(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
+ else
+ write(IMAIN,*) ' exact volume: ', &
+ dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)-(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
+ endif
+ endif
+ endif
+
+!--- print number of points and elements in the mesh for each region
+
+ if(myrank == 0) then
+
+ numelem_crust_mantle = NSPEC(IREGION_CRUST_MANTLE)
+ numelem_outer_core = NSPEC(IREGION_OUTER_CORE)
+ numelem_inner_core = NSPEC(IREGION_INNER_CORE)
+
+ numelem_total = numelem_crust_mantle + numelem_outer_core + numelem_inner_core
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Repartition of elements in regions:'
+ write(IMAIN,*) '----------------------------------'
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of elements in each slice: ',numelem_total
+ write(IMAIN,*)
+ write(IMAIN,*) ' - crust and mantle: ',sngl(100.d0*dble(numelem_crust_mantle)/dble(numelem_total)),' %'
+ write(IMAIN,*) ' - outer core: ',sngl(100.d0*dble(numelem_outer_core)/dble(numelem_total)),' %'
+ write(IMAIN,*) ' - inner core: ',sngl(100.d0*dble(numelem_inner_core)/dble(numelem_total)),' %'
+ write(IMAIN,*)
+ write(IMAIN,*) 'for some mesh statistics, see comments in file OUTPUT_FILES/values_from_mesher.h'
+ write(IMAIN,*)
+
+! load balancing
+ write(IMAIN,*) 'Load balancing of the mesh = 100 % by definition'
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
+ write(IMAIN,*) 'value of a time step in the solver will be: ',DT
+ write(IMAIN,*)
+
+! write information about precision used for floating-point operations
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IMAIN,*) 'using single precision for the calculations'
+ else
+ write(IMAIN,*) 'using double precision for the calculations'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
+ write(IMAIN,*)
+
+ endif ! end of section executed by main process only
+
+! elapsed time since beginning of mesh generation
+ if(myrank == 0) then
+#ifdef USE_MPI
+ tCPU = MPI_WTIME() - time_start
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for mesh generation and buffer creation in seconds = ',tCPU
+ write(IMAIN,*) 'End of mesh generation'
+ write(IMAIN,*)
+#else
+ tCPU = 0
+#endif
+! close main output file
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN)
+ endif
+
+ end subroutine meshfem3D
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/meshfem3D.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,1547 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! 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.
-!
-!=====================================================================
-
-!=====================================================================!
-! meshfem3D produces a spectral element grid for the Earth. !
-! This is accomplished based upon a mapping of the face of a cube !
-! to a portion of the sphere (Ronchi et al., The Cubed Sphere). !
-! Grid density is decreased by a factor of two !
-! three times in the radial direction. !
-!=====================================================================!
-
-!! DK DK for the merged version
- include 'call_meshfem2.f90'
-
- use dyn_array
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
-!!!!!!!!!!! DK DK now in module dyn_array include "constants.h"
- include "precision.h"
-
-!! DK DK for the merged version
-! include values created by the mesher
- include "values_from_mesher.h"
-
-! aniso_mantle_model_variables
- type aniso_mantle_model_variables
- sequence
- double precision beta(14,34,37,73)
- double precision pro(47)
- integer npar1
- end type aniso_mantle_model_variables
-
- type (aniso_mantle_model_variables) AMM_V
-! aniso_mantle_model_variables
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: Qs ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
-! model_1066a_variables
- type model_1066a_variables
- sequence
- double precision, dimension(NR_1066A) :: radius_1066a
- double precision, dimension(NR_1066A) :: density_1066a
- double precision, dimension(NR_1066A) :: vp_1066a
- double precision, dimension(NR_1066A) :: vs_1066a
- double precision, dimension(NR_1066A) :: Qkappa_1066a
- double precision, dimension(NR_1066A) :: Qmu_1066a
- end type model_1066a_variables
-
- type (model_1066a_variables) M1066a_V
-! model_1066a_variables
-
-! model_ak135_variables
- type model_ak135_variables
- sequence
- double precision, dimension(NR_AK135) :: radius_ak135
- double precision, dimension(NR_AK135) :: density_ak135
- double precision, dimension(NR_AK135) :: vp_ak135
- double precision, dimension(NR_AK135) :: vs_ak135
- double precision, dimension(NR_AK135) :: Qkappa_ak135
- double precision, dimension(NR_AK135) :: Qmu_ak135
- end type model_ak135_variables
-
- type (model_ak135_variables) Mak135_V
-! model_ak135_variables
-
-! three_d_mantle_model_variables
- type three_d_mantle_model_variables
- sequence
- double precision dvs_a(0:NK,0:NS,0:NS)
- double precision dvs_b(0:NK,0:NS,0:NS)
- double precision dvp_a(0:NK,0:NS,0:NS)
- double precision dvp_b(0:NK,0:NS,0:NS)
- double precision spknt(NK+1)
- double precision qq0(NK+1,NK+1)
- double precision qq(3,NK+1,NK+1)
- end type three_d_mantle_model_variables
-
-! model_ref_variables
- type model_ref_variables
- sequence
- double precision, dimension(NR_REF) :: radius_ref
- double precision, dimension(NR_REF) :: density_ref
- double precision, dimension(NR_REF) :: vpv_ref
- double precision, dimension(NR_REF) :: vph_ref
- double precision, dimension(NR_REF) :: vsv_ref
- double precision, dimension(NR_REF) :: vsh_ref
- double precision, dimension(NR_REF) :: eta_ref
- double precision, dimension(NR_REF) :: Qkappa_ref
- double precision, dimension(NR_REF) :: Qmu_ref
- end type model_ref_variables
-
- type (model_ref_variables) Mref_V
-! model_ref_variables
-
- type (three_d_mantle_model_variables) D3MM_V
-! three_d_mantle_model_variables
-
-! sea1d_model_variables
- type sea1d_model_variables
- sequence
- double precision, dimension(NR_SEA1D) :: radius_sea1d
- double precision, dimension(NR_SEA1D) :: density_sea1d
- double precision, dimension(NR_SEA1D) :: vp_sea1d
- double precision, dimension(NR_SEA1D) :: vs_sea1d
- double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
- double precision, dimension(NR_SEA1D) :: Qmu_sea1d
- end type sea1d_model_variables
-
- type (sea1d_model_variables) SEA1DM_V
-! sea1d_model_variables
-
-! jp3d_model_variables
- type jp3d_model_variables
- sequence
-! vmod3d
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
-! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
-! locate
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
-! weight
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- double precision :: WV(8)
-! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
-! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- end type jp3d_model_variables
-
- type (jp3d_model_variables) JP3DM_V
-! jp3d_model_variables
-
-! sea99_s_model_variables
- type sea99_s_model_variables
- sequence
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
- double precision :: sea99_ddeg
- double precision :: alatmin
- double precision :: alatmax
- double precision :: alonmin
- double precision :: alonmax
- double precision :: sea99_vs(100,100,100)
- double precision :: sea99_depth(100)
- end type sea99_s_model_variables
-
- type (sea99_s_model_variables) SEA99M_V
-! sea99_s_model_variables
-
-! crustal_model_variables
- type crustal_model_variables
- sequence
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
- character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
- character(len=2) code(NKEYS_CRUST)
- end type crustal_model_variables
-
- type (crustal_model_variables) CM_V
-! crustal_model_variables
-
-! attenuation_model_storage
- type attenuation_model_storage
- sequence
- integer Q_resolution
- integer Q_max
- double precision, dimension(:,:), pointer :: tau_e_storage
- double precision, dimension(:), pointer :: Qmu_storage
- end type attenuation_model_storage
-
- type (attenuation_model_storage) AM_S
-! attenuation_model_storage
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- double precision Q ! Q = Desired Value of Attenuation or Q
- double precision iQ ! iQ = 1/Q
- double precision, dimension(:), pointer :: f
- ! f = Frequencies at which to evaluate the solution
- double precision, dimension(:), pointer :: tau_s
- ! tau_s = Tau_sigma defined by the frequency range and
- ! number of standard linear solids
- end type attenuation_simplex_variables
-
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
-! correct number of spectral elements in each block depending on chunk type
-
- integer nspec_tiso,npointot
-
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
-! use the size of the largest region (crust_mantle) and therefore largest possible array
-! arrays with the mesh in double precision
- double precision, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: xstore,ystore,zstore
-
-! proc numbers for MPI
- integer myrank,sizeprocs,ier
-
-! check area and volume of the final mesh
- double precision area_local_bottom,area_total_bottom
- double precision area_local_top,area_total_top
- double precision volume_local,volume_total,volume_total_region
-
- integer iprocnum
-
-! for loop on all the slices
- integer iregion_code,iregion
- integer iproc_xi,iproc_eta,ichunk
-
-!! DK DK for the merged version
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
-! use the size of the largest region (crust_mantle) and therefore largest possible array
- integer, dimension(NGLOB1D_RADIAL_CM) :: ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta
-
- double precision, dimension(NGLOB1D_RADIAL_CM) :: &
- xread1D_leftxi_lefteta,xread1D_rightxi_lefteta, &
- xread1D_leftxi_righteta,xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta,yread1D_rightxi_lefteta, &
- yread1D_leftxi_righteta,yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta,zread1D_rightxi_lefteta, &
- zread1D_leftxi_righteta,zread1D_rightxi_righteta
-
-! rotation matrix from Euler angles
- double precision, dimension(NDIM,NDIM) :: rotation_matrix
-
- double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
-
-! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
-! for some statistics for the mesh
- integer numelem_crust_mantle,numelem_outer_core,numelem_inner_core
- integer numelem_total
-
-! timer MPI
- double precision time_start,tCPU
-
-! addressing for all the slices
- integer, dimension(0:NPROCTOT_VAL-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
-
-! 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,RMOHO_FICTITIOUS_IN_MESHER, &
- 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, &
- ifirst_layer_aniso,ilast_layer_aniso
-
- 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
-
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
-
- character(len=150) OUTPUT_FILES,MODEL
-
-! parameters deduced from parameters read from file
- integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, external :: err_occurred
-
-! 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
-
-! 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_layer_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-! memory size of all the static arrays
-! double precision :: static_memory_size
-
-! arrays for BCAST
- integer, dimension(40) :: bcast_integer
- double precision, dimension(30) :: bcast_double_precision
- logical, dimension(26) :: bcast_logical
-
- integer, parameter :: maxker=200
- integer, parameter :: maxl=72
- integer, parameter :: maxcoe=2000
- integer, parameter :: maxver=1000
- integer, parameter :: maxhpa=2
-
- integer numker
- integer numhpa,numcof
- integer ihpa,lmax,nylm
- integer lmxhpa(maxhpa)
- integer itypehpa(maxhpa)
- integer ihpakern(maxker)
- integer numcoe(maxhpa)
- integer ivarkern(maxker)
- integer itpspl(maxcoe,maxhpa)
-
- integer nconpt(maxhpa),iver
- integer iconpt(maxver,maxhpa)
- real(kind=4) conpt(maxver,maxhpa)
-
- real(kind=4) xlaspl(maxcoe,maxhpa)
- real(kind=4) xlospl(maxcoe,maxhpa)
- real(kind=4) radspl(maxcoe,maxhpa)
- real(kind=4) coe(maxcoe,maxker)
- character(len=80) hsplfl(maxhpa)
- character(len=40) dskker(maxker)
- real(kind=4) vercof(maxker)
- real(kind=4) vercofd(maxker)
-
- real(kind=4) ylmcof((maxl+1)**2,maxhpa)
- real(kind=4) wk1(maxl+1)
- real(kind=4) wk2(maxl+1)
- real(kind=4) wk3(maxl+1)
-
- character(len=80) kerstr
- character(len=80) refmdl
- character(len=40) varstr(maxker)
-
-! this for the different corners of the slice (which are different if the superbrick is cut)
-! 1 : xi_min, eta_min
-! 2 : xi_max, eta_min
-! 3 : xi_max, eta_max
-! 4 : xi_min, eta_max
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
-
-! 1 -> min, 2 -> max
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
-
- 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 :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
-
-!! DK DK for the merged version
- include 'declarations_mesher.f90'
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! open main output file, only written to by process 0
- if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
- open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_mesher.txt',status='unknown',action='write')
-
-! get MPI starting time
- time_start = MPI_WTIME()
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '****************************'
- write(IMAIN,*) '*** Specfem3D MPI Mesher ***'
- write(IMAIN,*) '****************************'
- write(IMAIN,*)
- endif
-
- if (myrank==0) then
-! 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,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,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_layer_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,ifirst_layer_aniso,ilast_layer_aniso,.false.)
-
- if(err_occurred() /= 0) call exit_MPI(myrank,'an error occurred while reading the parameter file')
-
-! count the total number of sources in the CMTSOLUTION file
- call count_number_of_sources(NSOURCES)
-
- bcast_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,RMOHO_FICTITIOUS_IN_MESHER, &
- 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,NPROC,NPROCTOT, &
- NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,ifirst_layer_aniso,ilast_layer_aniso/)
-
- bcast_logical = (/TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D,&
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,SAVE_ALL_SEISMOS_IN_ONE_FILE/)
-
- 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, &
- 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/)
-
- endif
-
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(bcast_integer,40,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(bcast_double_precision,30,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(bcast_logical,25,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(MODEL,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(ner,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ratio_sampling_array,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(doubling_index,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(r_bottom,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(r_top,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(rmins,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(this_layer_has_a_doubling,MAX_NUMBER_OF_MESH_LAYERS,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(NSPEC,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2D_XI,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2D_ETA,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2D_BOTTOM,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2D_TOP,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NGLOB1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NGLOB2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NGLOB2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NGLOB,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(DIFF_NSPEC1D_RADIAL,NB_SQUARE_CORNERS*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(DIFF_NSPEC2D_ETA,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(DIFF_NSPEC2D_XI,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- if (myrank /=0) then
-
- MIN_ATTENUATION_PERIOD = bcast_integer(1)
- MAX_ATTENUATION_PERIOD = bcast_integer(2)
- NER_CRUST = bcast_integer(3)
- NER_80_MOHO = bcast_integer(4)
- NER_220_80 = bcast_integer(5)
- NER_400_220 = bcast_integer(6)
- NER_600_400 = bcast_integer(7)
- NER_670_600 = bcast_integer(8)
- NER_771_670 = bcast_integer(9)
- NER_TOPDDOUBLEPRIME_771 = bcast_integer(10)
- NER_CMB_TOPDDOUBLEPRIME = bcast_integer(11)
- NER_OUTER_CORE = bcast_integer(12)
- NER_TOP_CENTRAL_CUBE_ICB = bcast_integer(13)
- NEX_XI = bcast_integer(14)
- NEX_ETA = bcast_integer(15)
- RMOHO_FICTITIOUS_IN_MESHER = bcast_integer(16)
- NPROC_XI = bcast_integer(17)
- NPROC_ETA = bcast_integer(18)
- NTSTEP_BETWEEN_OUTPUT_SEISMOS = bcast_integer(19)
- NTSTEP_BETWEEN_READ_ADJSRC = bcast_integer(20)
- NSTEP = bcast_integer(21)
- NSOURCES = bcast_integer(22)
- NTSTEP_BETWEEN_FRAMES = bcast_integer(23)
- NTSTEP_BETWEEN_OUTPUT_INFO = bcast_integer(24)
- NUMBER_OF_RUNS = bcast_integer(25)
- NUMBER_OF_THIS_RUN = bcast_integer(26)
- NCHUNKS = bcast_integer(27)
- SIMULATION_TYPE = bcast_integer(28)
- REFERENCE_1D_MODEL = bcast_integer(29)
- THREE_D_MODEL = bcast_integer(30)
- NPROC = bcast_integer(31)
- NPROCTOT = bcast_integer(32)
- NEX_PER_PROC_XI = bcast_integer(33)
- NEX_PER_PROC_ETA = bcast_integer(34)
- ratio_divide_central_cube = bcast_integer(35)
- MOVIE_VOLUME_TYPE = bcast_integer(36)
- MOVIE_START = bcast_integer(37)
- MOVIE_STOP = bcast_integer(38)
- ifirst_layer_aniso = bcast_integer(39)
- ilast_layer_aniso = bcast_integer(40)
-
- TRANSVERSE_ISOTROPY = bcast_logical(1)
- ANISOTROPIC_3D_MANTLE = bcast_logical(2)
- ANISOTROPIC_INNER_CORE = bcast_logical(3)
- CRUSTAL = bcast_logical(4)
- ELLIPTICITY = bcast_logical(5)
- GRAVITY = bcast_logical(6)
- ONE_CRUST = bcast_logical(7)
- ROTATION = bcast_logical(8)
- ISOTROPIC_3D_MANTLE = bcast_logical(9)
- TOPOGRAPHY = bcast_logical(10)
- OCEANS = bcast_logical(11)
- MOVIE_SURFACE = bcast_logical(12)
- MOVIE_VOLUME = bcast_logical(13)
- ATTENUATION_3D = bcast_logical(14)
- RECEIVERS_CAN_BE_BURIED = bcast_logical(15)
- PRINT_SOURCE_TIME_FUNCTION = bcast_logical(16)
- SAVE_MESH_FILES = bcast_logical(17)
- ATTENUATION = bcast_logical(18)
- ABSORBING_CONDITIONS = bcast_logical(19)
- INCLUDE_CENTRAL_CUBE = bcast_logical(20)
- INFLATE_CENTRAL_CUBE = bcast_logical(21)
- SAVE_FORWARD = bcast_logical(22)
- CASE_3D = bcast_logical(23)
- CUT_SUPERBRICK_XI = bcast_logical(24)
- CUT_SUPERBRICK_ETA = bcast_logical(25)
- SAVE_ALL_SEISMOS_IN_ONE_FILE = bcast_logical(26)
-
- DT = bcast_double_precision(1)
- ANGULAR_WIDTH_XI_IN_DEGREES = bcast_double_precision(2)
- ANGULAR_WIDTH_ETA_IN_DEGREES = bcast_double_precision(3)
- CENTER_LONGITUDE_IN_DEGREES = bcast_double_precision(4)
- CENTER_LATITUDE_IN_DEGREES = bcast_double_precision(5)
- GAMMA_ROTATION_AZIMUTH = bcast_double_precision(6)
- ROCEAN = bcast_double_precision(7)
- RMIDDLE_CRUST = bcast_double_precision(8)
- RMOHO = bcast_double_precision(9)
- R80 = bcast_double_precision(10)
- R120 = bcast_double_precision(11)
- R220 = bcast_double_precision(12)
- R400 = bcast_double_precision(13)
- R600 = bcast_double_precision(14)
- R670 = bcast_double_precision(15)
- R771 = bcast_double_precision(16)
- RTOPDDOUBLEPRIME = bcast_double_precision(17)
- RCMB = bcast_double_precision(18)
- RICB = bcast_double_precision(19)
- R_CENTRAL_CUBE = bcast_double_precision(20)
- RHO_TOP_OC = bcast_double_precision(21)
- RHO_BOTTOM_OC = bcast_double_precision(22)
- RHO_OCEANS = bcast_double_precision(23)
- HDUR_MOVIE = bcast_double_precision(24)
- MOVIE_TOP = bcast_double_precision(25)
- MOVIE_BOTTOM = bcast_double_precision(26)
- MOVIE_WEST = bcast_double_precision(27)
- MOVIE_EAST = bcast_double_precision(28)
- MOVIE_NORTH = bcast_double_precision(29)
- MOVIE_SOUTH = bcast_double_precision(30)
-
- endif
-
-! check that the code is running with the requested number of processes
- if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
-
- addressing(:,:,:) = 0
- ichunk_slice(:) = 0
- iproc_xi_slice(:) = 0
- iproc_eta_slice(:) = 0
-
-! loop on all the chunks to create global slice addressing for solver
- if(myrank == 0) then
- write(IMAIN,*) 'creating global slice addressing'
- write(IMAIN,*)
- endif
- do ichunk = 1,NCHUNKS
- do iproc_eta=0,NPROC_ETA-1
- do iproc_xi=0,NPROC_XI-1
- iprocnum = (ichunk-1)*NPROC + iproc_eta * NPROC_XI + iproc_xi
- addressing(ichunk,iproc_xi,iproc_eta) = iprocnum
- ichunk_slice(iprocnum) = ichunk
- iproc_xi_slice(iprocnum) = iproc_xi
- iproc_eta_slice(iprocnum) = iproc_eta
- enddo
- enddo
- enddo
-
-! this for the different counters (which are now different if the superbrick is cut in the outer core)
- do iregion=1,MAX_NUM_REGIONS
- NSPEC1D_RADIAL_CORNER(iregion,:) = NSPEC1D_RADIAL(iregion)
- NSPEC2D_XI_FACE(iregion,:) = NSPEC2D_XI(iregion)
- NSPEC2D_ETA_FACE(iregion,:) = NSPEC2D_ETA(iregion)
- NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
- enddo
-
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_xi_slice(myrank),2) == 0) then
- if (mod(iproc_eta_slice(myrank),2) == 0) then
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- else
- if (mod(iproc_eta_slice(myrank),2) == 0) then
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,3)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,3)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,3)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
- else
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,4)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,4)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,4)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
- endif
- endif
- else
- if (mod(iproc_xi_slice(myrank),2) == 0) then
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_eta_slice(myrank),2) == 0) then
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- endif
-
- if(myrank == 0) then
- write(IMAIN,*) 'This is process ',myrank
- write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
- write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
- write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
- write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
- write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
- write(IMAIN,*) 'There are ',NCHUNKS,' chunks in the global mesh'
- write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in the global mesh'
- write(IMAIN,*)
- write(IMAIN,*) 'NGLLX = ',NGLLX
- write(IMAIN,*) 'NGLLY = ',NGLLY
- write(IMAIN,*) 'NGLLZ = ',NGLLZ
-
- write(IMAIN,*)
- write(IMAIN,*) 'Shape functions defined by NGNOD = ',NGNOD,' control nodes'
- write(IMAIN,*) 'Surface shape functions defined by NGNOD2D = ',NGNOD2D,' control nodes'
- write(IMAIN,*)
- write(IMAIN,*)
- endif
-
- if(myrank == 0) then
-
- write(IMAIN,*)
- if(ELLIPTICITY) then
- write(IMAIN,*) 'incorporating ellipticity'
- else
- write(IMAIN,*) 'no ellipticity'
- endif
-
- write(IMAIN,*)
- if(TOPOGRAPHY) then
- write(IMAIN,*) 'incorporating surface topography'
- else
- write(IMAIN,*) 'no surface topography'
- endif
-
- write(IMAIN,*)
- if(ISOTROPIC_3D_MANTLE) then
- write(IMAIN,*) 'incorporating 3-D lateral variations'
- else
- write(IMAIN,*) 'no 3-D lateral variations'
- endif
-
- write(IMAIN,*)
- if(CRUSTAL) then
- write(IMAIN,*) 'incorporating crustal variations'
- else
- write(IMAIN,*) 'no crustal variations'
- endif
-
- write(IMAIN,*)
- if(ONE_CRUST) then
- write(IMAIN,*) 'using one layer only in PREM crust'
- else
- write(IMAIN,*) 'using unmodified 1D crustal model with two layers'
- endif
-
- write(IMAIN,*)
- if(GRAVITY) then
- write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)'
- else
- write(IMAIN,*) 'no self-gravitation'
- endif
-
- write(IMAIN,*)
- if(ROTATION) then
- write(IMAIN,*) 'incorporating rotation'
- else
- write(IMAIN,*) 'no rotation'
- endif
-
- write(IMAIN,*)
- if(TRANSVERSE_ISOTROPY) then
- write(IMAIN,*) 'incorporating anisotropy'
- else
- write(IMAIN,*) 'no anisotropy'
- endif
-
- write(IMAIN,*)
- if(ATTENUATION) then
- write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
- if(ATTENUATION_3D) write(IMAIN,*)'using 3D attenuation'
- else
- write(IMAIN,*) 'no attenuation'
- endif
-
- write(IMAIN,*)
- if(OCEANS) then
- write(IMAIN,*) 'incorporating the oceans using equivalent load'
- else
- write(IMAIN,*) 'no oceans'
- endif
-
- write(IMAIN,*)
-
- endif
-
- if(ELLIPTICITY) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
-
- if(ISOTROPIC_3D_MANTLE) then
- if(THREE_D_MODEL /= 0) call read_smooth_moho
- if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
-! the variables read are declared and stored in structure D3MM_V
- if(myrank == 0) call read_mantle_model(D3MM_V)
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(D3MM_V%dvs_a,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(D3MM_V%dvs_b,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(D3MM_V%dvp_a,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(D3MM_V%dvp_b,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(D3MM_V%spknt,NK+1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(D3MM_V%qq0,(NK+1)*(NK+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(D3MM_V%qq,3*(NK+1)*(NK+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
-! the variables read are declared and stored in structure SEA99M_V and JP3DM_V
- if(myrank == 0) then
- call read_sea99_s_model(SEA99M_V)
- call read_iso3d_dpzhao_model(JP3DM_V)
- endif
-! broadcast the information read on the master to the nodes
-! SEA99M_V
- call MPI_BCAST(SEA99M_V%sea99_ndep,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%sea99_nlat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%sea99_nlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%sea99_ddeg,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%alatmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%alatmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%alonmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%alonmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%sea99_vs,100*100*100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%sea99_depth,100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-! JP3DM_V
- call MPI_BCAST(JP3DM_V%NPA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%NRA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%NHA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%NPB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%NRB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%NHB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PNA,MPA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RNA,MRA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HNA,MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PNB,MPB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RNB,MRB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HNB,MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%VELAP,MPA*MRA*MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%VELBP,MPB*MRB*MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PN,51,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RRN,63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%DEPA,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%DEPB,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%DEPC,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IPLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IRLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IHLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IPLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IRLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IHLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%JP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%KP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%JP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%KP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%WV,8,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%P,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%R,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%VP,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%VS,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
-! the variables read are declared and stored in structure SEA99M_V
- if(myrank == 0) call read_sea99_s_model(SEA99M_V)
-! broadcast the information read on the master to the nodes
-! SEA99M_V
- call MPI_BCAST(SEA99M_V%sea99_ndep,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%sea99_nlat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%sea99_nlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%sea99_ddeg,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%alatmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%alatmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%alonmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%alonmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%sea99_vs,100*100*100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(SEA99M_V%sea99_depth,100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
-! the variables read are declared and stored in structure JP3DM_V
- if(myrank == 0) call read_iso3d_dpzhao_model(JP3DM_V)
-! JP3DM_V
- call MPI_BCAST(JP3DM_V%NPA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%NRA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%NHA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%NPB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%NRB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%NHB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PNA,MPA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RNA,MRA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HNA,MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PNB,MPB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RNB,MRB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HNB,MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%VELAP,MPA*MRA*MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%VELBP,MPB*MRB*MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PN,51,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RRN,63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%DEPA,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%DEPB,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%DEPC,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IPLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IRLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IHLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IPLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IRLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IHLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%JP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%KP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%IP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%JP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%KP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%WV,8,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%P,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%R,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%PD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%HD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%VP,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%VS,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
- .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then
- if(myrank == 0) call read_model_s362ani(THREE_D_MODEL,THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
- THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA, &
- numker,numhpa,ihpa,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
- xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
- call MPI_BCAST(numker,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(numhpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ihpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(lmxhpa,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(itypehpa,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ihpakern,maxker,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(numcoe,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ivarkern,maxker,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(itpspl,maxcoe*maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(xlaspl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(xlospl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(radspl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(coe,maxcoe*maxker,MPI_REAL,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(hsplfl,80*maxhpa,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(dskker,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(kerstr,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(refmdl,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(varstr,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
-
- else
- call exit_MPI(myrank,'3D model not defined')
- endif
- endif
-
- if(ANISOTROPIC_3D_MANTLE) then
-! the variables read are declared and stored in structure AMM_V
- if(myrank == 0) call read_aniso_mantle_model(AMM_V)
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(AMM_V%npar1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(AMM_V%beta,14*34*37*73,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(AMM_V%pro,47,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- endif
-
- if(CRUSTAL) then
-! the variables read are declared and stored in structure CM_V
- if(myrank == 0) call read_crustal_model(CM_V)
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(CM_V%thlr,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(CM_V%velocp,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(CM_V%velocs,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(CM_V%dens,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(CM_V%abbreviation,NCAP_CRUST*NCAP_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(CM_V%code,2*NKEYS_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
- endif
-
- if(ANISOTROPIC_INNER_CORE) then
- if(myrank == 0) call read_aniso_inner_core_model
-! one should add an MPI_BCAST here if one adds a read_aniso_inner_core_model subroutine
- endif
-
- if(ATTENUATION .and. ATTENUATION_3D) then
- if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V)
-
- call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
- call MPI_BCAST(AM_V%max_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
- call MPI_BCAST(AM_V%QT_c_source, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
- call MPI_BCAST(AM_V%Qtau_s(1), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
- call MPI_BCAST(AM_V%Qtau_s(2), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
- call MPI_BCAST(AM_V%Qtau_s(3), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
- endif
-
- if(ATTENUATION .and. .not. ATTENUATION_3D) then
- if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V)
-
- call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
- call MPI_BCAST(AM_V%max_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
-
- call attenuation_model_setup(REFERENCE_1D_MODEL, RICB, RCMB, R670, R220, R80,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,AM_S,AS_V)
- endif
-
-! read topography and bathymetry file
- if(TOPOGRAPHY .or. OCEANS) then
- if(myrank == 0) call read_topo_bathy_file(ibathy_topo)
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(ibathy_topo,NX_BATHY*NY_BATHY,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- endif
-
-! get addressing for this process
- ichunk = ichunk_slice(myrank)
- iproc_xi = iproc_xi_slice(myrank)
- iproc_eta = iproc_eta_slice(myrank)
-
- if(myrank == 0) then
- write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
- write(IMAIN,*)
- write(IMAIN,*) 'Central cube is at a radius of ',R_CENTRAL_CUBE/1000.d0,' km'
- endif
-
-! compute rotation matrix from Euler angles
- ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * PI / 180.d0
- ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * PI / 180.d0
- if(NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
-
-! volume of the slice
- volume_total = ZERO
-
-!! DK DK for the merged version
- include 'allocate_before.f90'
-
-!----
-!---- loop on all the regions of the mesh
-!----
-
-! number of regions in full Earth
- do iregion_code = 1,MAX_NUM_REGIONS
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '*******************************************'
- write(IMAIN,*) 'creating mesh in region ',iregion_code
-
- select case(iregion_code)
-
- case(IREGION_CRUST_MANTLE)
- write(IMAIN,*) 'this region is the crust and mantle'
-
- case(IREGION_OUTER_CORE)
- write(IMAIN,*) 'this region is the outer core'
-
- case(IREGION_INNER_CORE)
- write(IMAIN,*) 'this region is the inner core'
-
- case default
- call exit_MPI(myrank,'incorrect region code')
- end select
- write(IMAIN,*) '*******************************************'
- write(IMAIN,*)
- endif
-
-! compute maximum number of points
- npointot = NSPEC(iregion_code) * NGLLX * NGLLY * NGLLZ
-
-! create all the regions of the mesh
-
-!! DK DK for merged version
- if(iregion_code == IREGION_CRUST_MANTLE) then
-! crust_mantle
- call create_regions_mesh(iregion_code,ibool_crust_mantle,idoubling_crust_mantle, &
- xstore,ystore,zstore,rmins,rmaxs,iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_tiso, &
- volume_local,area_local_bottom,area_local_top,nspl,rspl,espl,espl2,nglob(iregion_code),npointot, &
- NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
- NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code),ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
- NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
- myrank,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
- ATTENUATION,ATTENUATION_3D,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- ner,ratio_sampling_array,doubling_index,r_bottom, r_top,this_layer_has_a_doubling,CASE_3D, &
- AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, AM_S, AS_V, &
- numker,numhpa,numcof,ihpa,lmax,nylm,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ratio_divide_central_cube, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2), &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM, &
- ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle,nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle,ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- ibelm_bottom_crust_mantle, ibelm_top_crust_mantle, &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
- jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
- jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle,jacobian2D_bottom_crust_mantle,jacobian2D_top_crust_mantle, &
- normal_xmin_crust_mantle,normal_xmax_crust_mantle,normal_ymin_crust_mantle, &
- normal_ymax_crust_mantle,normal_bottom_crust_mantle,normal_top_crust_mantle, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- rmass_crust_mantle,xelm_store_crust_mantle,yelm_store_crust_mantle,zelm_store_crust_mantle, &
-!! DK DK this will have to change to fully support David's code to cut the superbrick
- npoin2D_xi_crust_mantle(1),npoin2D_eta_crust_mantle(1), &
- xigll,wxgll, yigll,wygll, zigll,wzgll, shape3D, dershape3D, shape2D_x, shape2D_y, shape2D_bottom, shape2D_top, &
- dershape2D_x, dershape2D_y, dershape2D_bottom, dershape2D_top, rhostore_local,kappavstore_local, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- iboun, locval, ifseg, xp,yp,zp, rmass_ocean_load, mask_ibool, copy_ibool_ori, iMPIcut_xi,iMPIcut_eta, &
- rho_vp,rho_vs, Qmu_store, tau_e_store,ifirst_layer_aniso,ilast_layer_aniso)
-
- else if(iregion_code == IREGION_OUTER_CORE) then
-! outer_core
- call create_regions_mesh(iregion_code,ibool_outer_core,idoubling_outer_core, &
- xstore,ystore,zstore,rmins,rmaxs,iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_tiso, &
- volume_local,area_local_bottom,area_local_top,nspl,rspl,espl,espl2,nglob(iregion_code),npointot, &
- NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NSPEC2DMAX_XMIN_XMAX(iregion_code), &
- NSPEC2DMAX_YMIN_YMAX(iregion_code),NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code), &
- ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
- NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
- myrank,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
- ATTENUATION,ATTENUATION_3D,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- ner,ratio_sampling_array,doubling_index,r_bottom, r_top,this_layer_has_a_doubling,CASE_3D, &
- AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, AM_S, AS_V, &
- numker,numhpa,numcof,ihpa,lmax,nylm,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ratio_divide_central_cube, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2), &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC, &
- ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core,nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core,ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- ibelm_bottom_outer_core, ibelm_top_outer_core, &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
- jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
- jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
- normal_xmin_outer_core,normal_xmax_outer_core,normal_ymin_outer_core, &
- normal_ymax_outer_core,normal_bottom_outer_core,normal_top_outer_core, &
- kappavstore_outer_core,kappahstore_outer_core,muvstore_outer_core,muhstore_outer_core,eta_anisostore_outer_core, &
- rmass_outer_core,xelm_store_outer_core,yelm_store_outer_core,zelm_store_outer_core, &
-!! DK DK this will have to change to fully support David's code to cut the superbrick
- npoin2D_xi_outer_core(1),npoin2D_eta_outer_core(1), &
- xigll,wxgll, yigll,wygll, zigll,wzgll, shape3D, dershape3D, shape2D_x, shape2D_y, shape2D_bottom, shape2D_top, &
- dershape2D_x, dershape2D_y, dershape2D_bottom, dershape2D_top, rhostore_local,kappavstore_local, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- iboun, locval, ifseg, xp,yp,zp, rmass_ocean_load, mask_ibool, copy_ibool_ori, iMPIcut_xi,iMPIcut_eta, &
- rho_vp,rho_vs, Qmu_store, tau_e_store,ifirst_layer_aniso,ilast_layer_aniso)
-
- else if(iregion_code == IREGION_INNER_CORE) then
-! inner_core
- call create_regions_mesh(iregion_code,ibool_inner_core,idoubling_inner_core, &
- xstore,ystore,zstore,rmins,rmaxs,iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_tiso, &
- volume_local,area_local_bottom,area_local_top,nspl,rspl,espl,espl2,nglob(iregion_code),npointot, &
- NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NSPEC2DMAX_XMIN_XMAX(iregion_code), &
- NSPEC2DMAX_YMIN_YMAX(iregion_code),NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code), &
- ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
- NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
- myrank,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
- ATTENUATION,ATTENUATION_3D,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- ner,ratio_sampling_array,doubling_index,r_bottom, r_top,this_layer_has_a_doubling,CASE_3D, &
- AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, AM_S, AS_V, &
- numker,numhpa,numcof,ihpa,lmax,nylm,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ratio_divide_central_cube, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2), &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC,ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
- ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core, &
- ibelm_bottom_inner_core, ibelm_top_inner_core, &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
- jacobian2D_xmin_inner_core,jacobian2D_xmax_inner_core, &
- jacobian2D_ymin_inner_core,jacobian2D_ymax_inner_core,jacobian2D_bottom_inner_core,jacobian2D_top_inner_core, &
- normal_xmin_inner_core,normal_xmax_inner_core,normal_ymin_inner_core, &
- normal_ymax_inner_core,normal_bottom_inner_core,normal_top_inner_core, &
- kappavstore_inner_core,kappahstore_inner_core,muvstore_inner_core,muhstore_inner_core,eta_anisostore_inner_core, &
- rmass_inner_core,xelm_store_inner_core,yelm_store_inner_core,zelm_store_inner_core, &
-!! DK DK this will have to change to fully support David's code to cut the superbrick
- npoin2D_xi_inner_core(1),npoin2D_eta_inner_core(1), &
- xigll,wxgll, yigll,wygll, zigll,wzgll, shape3D, dershape3D, shape2D_x, shape2D_y, shape2D_bottom, shape2D_top, &
- dershape2D_x, dershape2D_y, dershape2D_bottom, dershape2D_top, rhostore_local,kappavstore_local, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- iboun, locval, ifseg, xp,yp,zp, rmass_ocean_load, mask_ibool, copy_ibool_ori, iMPIcut_xi,iMPIcut_eta, &
- rho_vp,rho_vs, Qmu_store, tau_e_store,ifirst_layer_aniso,ilast_layer_aniso)
-
- else
- stop 'DK DK incorrect region in merged code'
- endif
-
-! store number of anisotropic elements found in the mantle
- if(nspec_tiso /= 0 .and. iregion_code /= IREGION_CRUST_MANTLE) &
- call exit_MPI(myrank,'found transversely isotropic elements outside of the mantle')
-
- if(iregion_code == IREGION_CRUST_MANTLE .and. nspec_tiso == 0) &
- call exit_MPI(myrank,'found no transversely isotropic elements in the mantle')
-
-! use MPI reduction to compute total area and volume
-!! DK DK suppressed for now in the merged version, for simplicity
- volume_total_region = ZERO
- area_total_bottom = ZERO
- area_total_top = ZERO
- call MPI_REDUCE(area_local_bottom,area_total_bottom,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
- MPI_COMM_WORLD,ier)
- call MPI_REDUCE(area_local_top,area_total_top,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
- MPI_COMM_WORLD,ier)
- call MPI_REDUCE(volume_local,volume_total_region,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
- MPI_COMM_WORLD,ier)
-
- if(myrank == 0) then
-! sum volume over all the regions
- volume_total = volume_total + volume_total_region
-
-! check volume of chunk, and bottom and top area
-
- write(IMAIN,*)
- write(IMAIN,*) ' calculated top area: ',area_total_top
-
-! compare to exact theoretical value
- if(NCHUNKS == 6 .and. .not. TOPOGRAPHY) then
- select case(iregion_code)
-
- case(IREGION_CRUST_MANTLE)
- write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*R_UNIT_SPHERE**2
-
- case(IREGION_OUTER_CORE)
- write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RCMB/R_EARTH)**2
-
- case(IREGION_INNER_CORE)
- write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RICB/R_EARTH)**2
-
- case default
- call exit_MPI(myrank,'incorrect region code')
- end select
- endif
-
- write(IMAIN,*)
- write(IMAIN,*) 'calculated bottom area: ',area_total_bottom
-
-! compare to exact theoretical value
- if(NCHUNKS == 6 .and. .not. TOPOGRAPHY) then
-
- select case(iregion_code)
-
- case(IREGION_CRUST_MANTLE)
- write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RCMB/R_EARTH)**2
-
- case(IREGION_OUTER_CORE)
- write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RICB/R_EARTH)**2
-
- case(IREGION_INNER_CORE)
- write(IMAIN,*) ' exact area (central cube): ',dble(NCHUNKS)*(2.*(R_CENTRAL_CUBE / R_EARTH)/sqrt(3.))**2
-
- case default
- call exit_MPI(myrank,'incorrect region code')
- end select
- endif
-
- endif
-
-!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
- ! create chunk buffers if more than one chunk
- if(NCHUNKS > 1) then
-
-!! DK DK added this for merged version
- if(iregion_code == IREGION_CRUST_MANTLE) then
-! crust_mantle
- call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool_crust_mantle,idoubling_crust_mantle,xstore,ystore,zstore, &
- nglob(iregion_code), &
- NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
- NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
- NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
- myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
- ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
- nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle,nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
- ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle,ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
- iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_crust_mantle,npoin2D_faces_crust_mantle,iboolcorner_crust_mantle,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XY_VAL_CM)
-
- else if(iregion_code == IREGION_OUTER_CORE) then
-! outer_core
- call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool_outer_core,idoubling_outer_core,xstore,ystore,zstore, &
- nglob(iregion_code), &
- NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
- NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
- NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
- myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
- ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
- nspec2D_xmin_outer_core,nspec2D_xmax_outer_core,nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
- ibelm_xmin_outer_core,ibelm_xmax_outer_core,ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
- iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_outer_core,npoin2D_faces_outer_core,iboolcorner_outer_core,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY_VAL_OC)
-
- else if(iregion_code == IREGION_INNER_CORE) then
-! inner_core
- call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool_inner_core,idoubling_inner_core,xstore,ystore,zstore, &
- nglob(iregion_code), &
- NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
- NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
- NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
- myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
- ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
- ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core, &
- xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
- yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
- zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
- iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_inner_core,npoin2D_faces_inner_core,iboolcorner_inner_core,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- NGLOB2DMAX_XY_VAL_IC)
-
- else
- stop 'DK DK incorrect region in merged code'
- endif
-
- else
- if(myrank == 0) then
-
- write(IMAIN,*)
- write(IMAIN,*) 'only one chunk, no need to create chunk buffers'
- write(IMAIN,*)
- endif
- endif
-
-! end of loop on all the regions
- enddo
-
- if(myrank == 0) then
-! check volume of chunk
- write(IMAIN,*)
- write(IMAIN,*) 'calculated volume: ',volume_total
- if(.not. TOPOGRAPHY) then
-! take the central cube into account
-! it is counted 6 times because of the fictitious elements
- if(INCLUDE_CENTRAL_CUBE) then
- write(IMAIN,*) ' exact volume: ', &
- dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)+5.*(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
- else
- write(IMAIN,*) ' exact volume: ', &
- dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)-(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
- endif
- endif
- endif
-
-!--- print number of points and elements in the mesh for each region
-
- if(myrank == 0) then
-
- numelem_crust_mantle = NSPEC(IREGION_CRUST_MANTLE)
- numelem_outer_core = NSPEC(IREGION_OUTER_CORE)
- numelem_inner_core = NSPEC(IREGION_INNER_CORE)
-
- numelem_total = numelem_crust_mantle + numelem_outer_core + numelem_inner_core
-
- write(IMAIN,*)
- write(IMAIN,*) 'Repartition of elements in regions:'
- write(IMAIN,*) '----------------------------------'
- write(IMAIN,*)
- write(IMAIN,*) 'total number of elements in each slice: ',numelem_total
- write(IMAIN,*)
- write(IMAIN,*) ' - crust and mantle: ',sngl(100.d0*dble(numelem_crust_mantle)/dble(numelem_total)),' %'
- write(IMAIN,*) ' - outer core: ',sngl(100.d0*dble(numelem_outer_core)/dble(numelem_total)),' %'
- write(IMAIN,*) ' - inner core: ',sngl(100.d0*dble(numelem_inner_core)/dble(numelem_total)),' %'
- write(IMAIN,*)
- write(IMAIN,*) 'for some mesh statistics, see comments in file OUTPUT_FILES/values_from_mesher.h'
- write(IMAIN,*)
-
-! load balancing
- write(IMAIN,*) 'Load balancing = 100 % by definition'
- write(IMAIN,*)
-
- write(IMAIN,*)
- write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
- write(IMAIN,*)
-
- write(IMAIN,*)
- write(IMAIN,*) 'time-stepping of the solver will be: ',DT
- write(IMAIN,*)
-
-! write information about precision used for floating-point operations
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IMAIN,*) 'using single precision for the calculations'
- else
- write(IMAIN,*) 'using double precision for the calculations'
- endif
- write(IMAIN,*)
- write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
- write(IMAIN,*)
-
- endif ! end of section executed by main process only
-
-! elapsed time since beginning of mesh generation
- if(myrank == 0) then
- tCPU = MPI_WTIME() - time_start
- write(IMAIN,*)
- write(IMAIN,*) 'Elapsed time for mesh generation and buffer creation in seconds = ',tCPU
- write(IMAIN,*) 'End of mesh generation'
- write(IMAIN,*)
-! close main output file
- close(IMAIN)
- endif
-
- end subroutine meshfem3D
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,2516 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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,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,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_layer_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,ifirst_layer_aniso,ilast_layer_aniso,EMULATE_ONLY)
+
+ 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,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,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read,ifirst_layer_aniso,ilast_layer_aniso
+
+ 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_KM,MOVIE_TOP,MOVIE_BOTTOM_KM,MOVIE_BOTTOM, &
+ MOVIE_EAST_DEG,MOVIE_EAST,MOVIE_WEST_DEG,MOVIE_WEST,MOVIE_NORTH_DEG,MOVIE_NORTH,MOVIE_SOUTH_DEG,MOVIE_SOUTH
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ 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,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,EMULATE_ONLY
+
+ character(len=150) OUTPUT_FILES,MODEL
+
+! local variables
+ integer NEX_MAX
+
+ double precision RECORD_LENGTH_IN_MINUTES,ELEMENT_WIDTH
+
+ integer, external :: err_occurred
+
+! parameters to be computed based upon parameters above read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ 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
+
+ integer nblocks_xi,nblocks_eta
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_layer_has_a_doubling
+
+ integer :: ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,elem_doubling_bottom_outer_core
+ double precision :: DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
+ DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval
+
+! honor PREM Moho or not
+! doing so drastically reduces the stability condition and therefore the time step
+ logical :: HONOR_1D_SPHERICAL_MOHO,CASE_3D
+
+ integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, padding, tmp_sum, tmp_sum_xi, tmp_sum_eta
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+ integer :: NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
+ nb_lay_sb, nspec_sb, nglob_vol, nglob_surf, nglob_edge
+
+ integer :: multiplication_factor
+
+! for the cut doublingbrick improvement
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer :: lastdoubling_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
+ 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 :: tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,nglob_edge_v,to_remove
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ call open_parameter_file
+
+ call read_value_integer(SIMULATION_TYPE, 'solver.SIMULATION_TYPE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(SAVE_FORWARD, 'solver.SAVE_FORWARD')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ if(SIMULATION_TYPE > 1) stop 'SIMULATION_TYPE > 1 not implemented in the reduced merged version yet'
+
+ if(SAVE_FORWARD) stop 'SAVE_FORWARD not implemented in the reduced merged version yet'
+
+ call read_value_integer(NCHUNKS, 'mesher.NCHUNKS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
+ stop 'NCHUNKS must be either 1, 2, 3 or 6'
+
+ call read_value_double_precision(ANGULAR_WIDTH_XI_IN_DEGREES, 'mesher.ANGULAR_WIDTH_XI_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(ANGULAR_WIDTH_ETA_IN_DEGREES, 'mesher.ANGULAR_WIDTH_ETA_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(CENTER_LATITUDE_IN_DEGREES, 'mesher.CENTER_LATITUDE_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(CENTER_LONGITUDE_IN_DEGREES, 'mesher.CENTER_LONGITUDE_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(GAMMA_ROTATION_AZIMUTH, 'mesher.GAMMA_ROTATION_AZIMUTH')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! this MUST be 90 degrees for two chunks or more to match geometrically
+ if(NCHUNKS > 1 .and. abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) > 0.00000001d0) &
+ stop 'ANGULAR_WIDTH_XI_IN_DEGREES must be 90 for more than one chunk'
+
+! this can be any value in the case of two chunks
+ if(NCHUNKS > 2 .and. abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) > 0.00000001d0) &
+ stop 'ANGULAR_WIDTH_ETA_IN_DEGREES must be 90 for more than two chunks'
+
+! include central cube or not
+! use regular cubed sphere instead of cube for large distances
+ if(NCHUNKS == 6) then
+ INCLUDE_CENTRAL_CUBE = .true.
+ INFLATE_CENTRAL_CUBE = .false.
+ else
+ INCLUDE_CENTRAL_CUBE = .false.
+ INFLATE_CENTRAL_CUBE = .true.
+ endif
+
+#ifndef USE_MPI
+!! DK DK always suppress the central cube if one runs a serial test in one slice
+ INCLUDE_CENTRAL_CUBE = .false.
+#endif
+
+! number of elements at the surface along the two sides of the first chunk
+ call read_value_integer(NEX_XI_read, 'mesher.NEX_XI')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NEX_ETA_read, 'mesher.NEX_ETA')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NPROC_XI_read, 'mesher.NPROC_XI')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NPROC_ETA_read, 'mesher.NPROC_ETA')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ if(.not. EMULATE_ONLY) then
+ NEX_XI = NEX_XI_read
+ NEX_ETA = NEX_ETA_read
+ NPROC_XI = NPROC_XI_read
+ NPROC_ETA = NPROC_ETA_read
+ else
+! this is used in UTILS/estimate_best_values_runs.f90 only, to estimate memory use
+ NEX_ETA = NEX_XI
+ NPROC_ETA = NPROC_XI
+ endif
+
+! support for only one slice per chunk has been discontinued when there is more than one chunk
+! because it induces topological problems, and we are not interested in using small meshes
+ if(NCHUNKS > 1 .and. (NPROC_XI == 1 .or. NPROC_ETA == 1)) stop 'support for only one slice per chunk has been discontinued'
+
+! define the velocity model
+ call read_value_string(MODEL, 'model.name')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! use PREM as the 1D reference model by default
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+
+! HONOR_1D_SPHERICAL_MOHO: honor PREM Moho or not: doing so drastically reduces
+! the stability condition and therefore the time step, resulting in expensive
+! calculations. If not, honor a fictitious Moho at the depth of 40 km
+! in order to have even radial sampling from the d220 to the Earth surface.
+
+! ONE_CRUST: in order to increase stability and therefore to allow cheaper
+! simulations (larger time step), 1D models can be run with just one average crustal
+! layer instead of two.
+
+! CASE_3D : this flag allows the stretching of the elements in the crustal
+! layers in the case of 3D models. The purpose of this stretching is to squeeze more
+! GLL points per km in the upper part of the crust than in the lower part.
+ HONOR_1D_SPHERICAL_MOHO = .false.
+ ONE_CRUST = .false.
+ CASE_3D = .false.
+
+! default is no 3D model
+ THREE_D_MODEL = 0
+
+ if(MODEL == '1D_isotropic_prem') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+
+ else if(MODEL == '1D_transversely_isotropic_prem') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+
+ else if(MODEL == '1D_iasp91' .or. MODEL == '1D_1066a' .or. &
+ MODEL == '1D_ak135' .or. MODEL == '1D_jp3d' .or. &
+ MODEL == '1D_sea99') then
+ if(MODEL == '1D_iasp91') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
+ else if(MODEL == '1D_1066a') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
+ else if(MODEL == '1D_ak135') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
+ else if(MODEL == '1D_jp3d') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
+ else if(MODEL == '1D_sea99') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ else
+ stop 'reference 1D Earth model unknown'
+ endif
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+
+ else if(MODEL == '1D_ref') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+
+ else if(MODEL == '1D_ref_iso') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+
+ else if(MODEL == '1D_isotropic_prem_onecrust') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL == '1D_transversely_isotropic_prem_onecrust') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL == '1D_iasp91_onecrust' .or. MODEL == '1D_1066a_onecrust' .or. MODEL == '1D_ak135_onecrust') then
+ if(MODEL == '1D_iasp91_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
+ else if(MODEL == '1D_1066a_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
+ else if(MODEL == '1D_ak135_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
+ else
+ stop 'reference 1D Earth model unknown'
+ endif
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL == 'transversely_isotropic_prem_plus_3D_crust_2.0') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+
+ else if(MODEL == 's20rts') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+ THREE_D_MODEL = THREE_D_MODEL_S20RTS
+
+ else if(MODEL == 'sea99_jp3d1994') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ THREE_D_MODEL = THREE_D_MODEL_SEA99_JP3D
+
+ else if(MODEL == 'sea99') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ THREE_D_MODEL = THREE_D_MODEL_SEA99
+
+
+ else if(MODEL == 'jp3d1994') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
+ THREE_D_MODEL = THREE_D_MODEL_JP3D
+
+ else if(MODEL == 's362ani') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+
+ else if(MODEL == 's362iso') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+
+ else if(MODEL == 's362wmani') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S362WMANI
+
+ else if(MODEL == 's362ani_prem') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI_PREM
+
+ else if(MODEL == 's29ea') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S29EA
+
+ else if(MODEL == '3D_attenuation') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .true.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+
+ else if(MODEL == '3D_anisotropic') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+
+ else
+ stop 'model not implemented, edit read_compute_parameters.f90 and recompile'
+ endif
+
+! set time step, radial distribution of elements, and attenuation period range
+! right distribution is determined based upon maximum value of NEX
+ NEX_MAX = max(NEX_XI,NEX_ETA)
+
+!----
+!---- case prem_onecrust by default
+!----
+ if (SUPPRESS_CRUSTAL_MESH) then
+ multiplication_factor=2
+ else
+ multiplication_factor=1
+ endif
+
+ ! element width = 0.5625000 degrees = 62.54715 km
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.252d0
+
+ MIN_ATTENUATION_PERIOD = 30
+ MAX_ATTENUATION_PERIOD = 1500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 2
+ NER_400_220 = 2
+ NER_600_400 = 2
+ NER_670_600 = 1
+ NER_771_670 = 1
+ NER_TOPDDOUBLEPRIME_771 = 15
+ NER_CMB_TOPDDOUBLEPRIME = 1
+ NER_OUTER_CORE = 16
+ NER_TOP_CENTRAL_CUBE_ICB = 2
+ R_CENTRAL_CUBE = 950000.d0
+
+ ! element width = 0.3515625 degrees = 39.09196 km
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.225d0
+
+ MIN_ATTENUATION_PERIOD = 20
+ MAX_ATTENUATION_PERIOD = 1000
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 2
+ NER_400_220 = 3
+ NER_600_400 = 3
+ NER_670_600 = 1
+ NER_771_670 = 1
+ NER_TOPDDOUBLEPRIME_771 = 22
+ NER_CMB_TOPDDOUBLEPRIME = 2
+ NER_OUTER_CORE = 24
+ NER_TOP_CENTRAL_CUBE_ICB = 3
+ R_CENTRAL_CUBE = 965000.d0
+
+ ! element width = 0.2812500 degrees = 31.27357 km
+ else if(NEX_MAX*multiplication_factor <= 320) then
+ DT = 0.16d0
+
+ MIN_ATTENUATION_PERIOD = 15
+ MAX_ATTENUATION_PERIOD = 750
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 3
+ NER_400_220 = 4
+ NER_600_400 = 4
+ NER_670_600 = 1
+ NER_771_670 = 2
+ NER_TOPDDOUBLEPRIME_771 = 29
+ NER_CMB_TOPDDOUBLEPRIME = 2
+ NER_OUTER_CORE = 32
+ NER_TOP_CENTRAL_CUBE_ICB = 4
+ R_CENTRAL_CUBE = 940000.d0
+
+ ! element width = 0.1875000 degrees = 20.84905 km
+ else if(NEX_MAX*multiplication_factor <= 480) then
+ DT = 0.11d0
+
+ MIN_ATTENUATION_PERIOD = 10
+ MAX_ATTENUATION_PERIOD = 500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 2
+ NER_220_80 = 4
+ NER_400_220 = 5
+ NER_600_400 = 6
+ NER_670_600 = 2
+ NER_771_670 = 2
+ NER_TOPDDOUBLEPRIME_771 = 44
+ NER_CMB_TOPDDOUBLEPRIME = 3
+ NER_OUTER_CORE = 48
+ NER_TOP_CENTRAL_CUBE_ICB = 5
+ R_CENTRAL_CUBE = 988000.d0
+
+ ! element width = 0.1757812 degrees = 19.54598 km
+ else if(NEX_MAX*multiplication_factor <= 512) then
+ DT = 0.1125d0
+
+ MIN_ATTENUATION_PERIOD = 9
+ MAX_ATTENUATION_PERIOD = 500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 2
+ NER_220_80 = 4
+ NER_400_220 = 6
+ NER_600_400 = 6
+ NER_670_600 = 2
+ NER_771_670 = 3
+ NER_TOPDDOUBLEPRIME_771 = 47
+ NER_CMB_TOPDDOUBLEPRIME = 3
+ NER_OUTER_CORE = 51
+ NER_TOP_CENTRAL_CUBE_ICB = 5
+ R_CENTRAL_CUBE = 1010000.d0
+
+ ! element width = 0.1406250 degrees = 15.63679 km
+ else if(NEX_MAX*multiplication_factor <= 640) then
+ DT = 0.09d0
+
+ MIN_ATTENUATION_PERIOD = 8
+ MAX_ATTENUATION_PERIOD = 400
+
+ NER_CRUST = 2
+ NER_80_MOHO = 3
+ NER_220_80 = 5
+ NER_400_220 = 7
+ NER_600_400 = 8
+ NER_670_600 = 3
+ NER_771_670 = 3
+ NER_TOPDDOUBLEPRIME_771 = 59
+ NER_CMB_TOPDDOUBLEPRIME = 4
+ NER_OUTER_CORE = 64
+ NER_TOP_CENTRAL_CUBE_ICB = 6
+ R_CENTRAL_CUBE = 1020000.d0
+
+ ! element width = 0.1041667 degrees = 11.58280 km
+ else if(NEX_MAX*multiplication_factor <= 864) then
+ DT = 0.0667d0
+
+ MIN_ATTENUATION_PERIOD = 6
+ MAX_ATTENUATION_PERIOD = 300
+
+ NER_CRUST = 2
+ NER_80_MOHO = 4
+ NER_220_80 = 6
+ NER_400_220 = 10
+ NER_600_400 = 10
+ NER_670_600 = 3
+ NER_771_670 = 4
+ NER_TOPDDOUBLEPRIME_771 = 79
+ NER_CMB_TOPDDOUBLEPRIME = 5
+ NER_OUTER_CORE = 86
+ NER_TOP_CENTRAL_CUBE_ICB = 9
+ R_CENTRAL_CUBE = 990000.d0
+
+ ! element width = 7.8125000E-02 degrees = 8.687103 km
+ else if(NEX_MAX*multiplication_factor <= 1152) then
+ DT = 0.05d0
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = 3
+ NER_80_MOHO = 6
+ NER_220_80 = 8
+ NER_400_220 = 13
+ NER_600_400 = 13
+ NER_670_600 = 4
+ NER_771_670 = 6
+ NER_TOPDDOUBLEPRIME_771 = 106
+ NER_CMB_TOPDDOUBLEPRIME = 7
+ NER_OUTER_CORE = 116
+ NER_TOP_CENTRAL_CUBE_ICB = 12
+ R_CENTRAL_CUBE = 985000.d0
+
+ ! element width = 7.2115384E-02 degrees = 8.018865 km
+ else if(NEX_MAX*multiplication_factor <= 1248) then
+ DT = 0.0462d0
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = 3
+ NER_80_MOHO = 6
+ NER_220_80 = 9
+ NER_400_220 = 14
+ NER_600_400 = 14
+ NER_670_600 = 5
+ NER_771_670 = 6
+ NER_TOPDDOUBLEPRIME_771 = 114
+ NER_CMB_TOPDDOUBLEPRIME = 8
+ NER_OUTER_CORE = 124
+ NER_TOP_CENTRAL_CUBE_ICB = 13
+ R_CENTRAL_CUBE = 985000.d0
+
+ else
+
+! scale with respect to 1248 if above that limit
+ DT = 0.0462d0 * 1248.d0 / (2.d0*NEX_MAX)
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = nint(3 * 2.d0*NEX_MAX / 1248.d0)
+ NER_80_MOHO = nint(6 * 2.d0*NEX_MAX / 1248.d0)
+ NER_220_80 = nint(9 * 2.d0*NEX_MAX / 1248.d0)
+ NER_400_220 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
+ NER_600_400 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
+ NER_670_600 = nint(5 * 2.d0*NEX_MAX / 1248.d0)
+ NER_771_670 = nint(6 * 2.d0*NEX_MAX / 1248.d0)
+ NER_TOPDDOUBLEPRIME_771 = nint(114 * 2.d0*NEX_MAX / 1248.d0)
+ NER_CMB_TOPDDOUBLEPRIME = nint(8 * 2.d0*NEX_MAX / 1248.d0)
+ NER_OUTER_CORE = nint(124 * 2.d0*NEX_MAX / 1248.d0)
+ NER_TOP_CENTRAL_CUBE_ICB = nint(13 * 2.d0*NEX_MAX / 1248.d0)
+ R_CENTRAL_CUBE = 985000.d0
+
+!! removed this limit else
+!! removed this limit stop 'problem with this value of NEX_MAX'
+ endif
+
+!----
+!---- change some values in the case of regular PREM with two crustal layers or of 3D models
+!----
+
+! case of regular PREM with two crustal layers: change the time step for small meshes
+! because of a different size of elements in the radial direction in the crust
+ if (HONOR_1D_SPHERICAL_MOHO) then
+ if (.not. ONE_CRUST) then
+ ! case 1D + two crustal layers
+ if (NER_CRUST<2) NER_CRUST=2
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.20d0
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.20d0
+ endif
+ endif
+ else
+ ! case 3D
+ if (NER_CRUST<2) NER_CRUST=2
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.15d0
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.17d0
+ else if(NEX_MAX*multiplication_factor <= 320) then
+ DT = 0.155d0
+ endif
+ endif
+
+ if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ DT = DT*0.20d0
+ endif
+
+
+ if( .not. ATTENUATION_RANGE_PREDEFINED ) then
+ call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
+ endif
+
+ if(ANGULAR_WIDTH_XI_IN_DEGREES < 90.0d0 .or. &
+ ANGULAR_WIDTH_ETA_IN_DEGREES < 90.0d0 .or. &
+ NEX_MAX > 1248) then
+
+ call auto_ner(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ NER_CRUST, NER_80_MOHO, NER_220_80, NER_400_220, NER_600_400, &
+ NER_670_600, NER_771_670, NER_TOPDDOUBLEPRIME_771, &
+ NER_CMB_TOPDDOUBLEPRIME, NER_OUTER_CORE, NER_TOP_CENTRAL_CUBE_ICB, &
+ R_CENTRAL_CUBE, CASE_3D)
+
+ call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
+
+ call auto_time_stepping(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, DT)
+
+ if (HONOR_1D_SPHERICAL_MOHO) then
+ if (.not. ONE_CRUST) then
+ ! case 1D + two crustal layers
+ if (NER_CRUST<2) NER_CRUST=2
+ endif
+ else
+ ! case 3D
+ if (NER_CRUST<2) NER_CRUST=2
+ endif
+ endif
+
+! take a 5% safety margin on the maximum stable time step
+! which was obtained by trial and error
+!!!!!!!!!!!!!!!!!! DT = DT * (1.d0 - 0.05d0)
+
+ call read_value_logical(OCEANS, 'model.OCEANS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ELLIPTICITY, 'model.ELLIPTICITY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(TOPOGRAPHY, 'model.TOPOGRAPHY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(GRAVITY, 'model.GRAVITY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ROTATION, 'model.ROTATION')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ATTENUATION, 'model.ATTENUATION')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ call read_value_logical(ABSORBING_CONDITIONS, 'solver.ABSORBING_CONDITIONS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS == 6) stop 'cannot have absorbing conditions in the full Earth'
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS == 3) stop 'absorbing conditions not supported for three chunks yet'
+
+ if(ATTENUATION_3D .and. .not. ATTENUATION) stop 'need ATTENUATION to use ATTENUATION_3D'
+
+ if(GRAVITY) stop 'GRAVITY not implemented in the reduced merged version yet because useless at high frequency'
+
+ if(ROTATION) stop 'ROTATION not implemented in the reduced merged version yet because useless at high frequency'
+
+ if(ABSORBING_CONDITIONS) stop 'ABSORBING_CONDITIONS not implemented in the reduced merged version yet'
+
+! radii in PREM or IASP91
+! and normalized density at fluid-solid interface on fluid size for coupling
+! ROCEAN: radius of the ocean (m)
+! RMIDDLE_CRUST: radius of the middle crust (m)
+! RMOHO: radius of the Moho (m)
+! R80: radius of 80 km discontinuity (m)
+! R120: radius of 120 km discontinuity (m) in IASP91
+! R220: radius of 220 km discontinuity (m)
+! R400: radius of 400 km discontinuity (m)
+! R600: radius of 600 km 2nd order discontinuity (m)
+! R670: radius of 670 km discontinuity (m)
+! R771: radius of 771 km 2nd order discontinuity (m)
+! RTOPDDOUBLEPRIME: radius of top of D" 2nd order discontinuity (m)
+! RCMB: radius of CMB (m)
+! RICB: radius of ICB (m)
+
+! by default there is no d120 discontinuity, except in IASP91, therefore set to fictitious value
+ R120 = -1.d0
+
+! value common to all models
+ RHO_OCEANS = 1020.0 / RHOAV
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+
+! IASP91
+ ROCEAN = 6371000.d0
+ RMIDDLE_CRUST = 6351000.d0
+ RMOHO = 6336000.d0
+ R80 = 6291000.d0
+ R120 = 6251000.d0
+ R220 = 6161000.d0
+ R400 = 5961000.d0
+! there is no d600 discontinuity in IASP91 therefore this value is useless
+! but it needs to be there for compatibility with other subroutines
+ R600 = R_EARTH - 600000.d0
+ R670 = 5711000.d0
+ R771 = 5611000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3482000.d0
+ RICB = 1217000.d0
+
+ RHO_TOP_OC = 9900.2379 / RHOAV
+ RHO_BOTTOM_OC = 12168.6383 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+
+! our implementation of AK135 has not been checked carefully yet
+! therefore let us doublecheck it carefully one day
+
+! values below corrected by Ying Zhou <yingz at gps.caltech.edu>
+
+! AK135 without the 300 meters of mud layer
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6361000.d0
+ RMOHO = 6353000.d0
+ R80 = 6291000.d0
+ R220 = 6161000.d0
+ R400 = 5961000.d0
+ R670 = 5711000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3479500.d0
+ RICB = 1217500.d0
+
+! values for AK135 that are not discontinuities
+ R600 = 5771000.d0
+ R771 = 5611000.d0
+
+ RHO_TOP_OC = 9914.5000 / RHOAV
+ RHO_BOTTOM_OC = 12139.1000 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+
+! values below corrected by Ying Zhou <yingz at gps.caltech.edu>
+
+! 1066A
+ RMOHO = 6360000.d0
+ R400 = 5950000.d0
+ R600 = 5781000.d0
+ R670 = 5700000.d0
+ RCMB = 3484300.d0
+ RICB = 1229480.d0
+
+! values for 1066A that are not discontinuities
+ RTOPDDOUBLEPRIME = 3631000.d0
+ R220 = 6161000.d0
+ R771 = 5611000.d0
+! RMIDDLE_CRUST used only for high resolution FFSW1C model, with 3 elements crust simulations
+! mid_crust = 10 km
+ RMIDDLE_CRUST = 6361000.d0
+ R80 = 6291000.d0
+
+! model 1066A has no oceans, therefore we use the radius of the Earth instead
+ ROCEAN = R_EARTH
+
+ RHO_TOP_OC = 9917.4500 / RHOAV
+ RHO_BOTTOM_OC = 12160.6500 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+
+! REF
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R220 = 6151000.d0
+ R400 = 5961000.d0
+ R600 = 5771000.d0
+ R670 = 5721000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3479958.d0
+ RICB = 1221491.d0
+
+ RHO_TOP_OC = 9903.48 / RHOAV
+ RHO_BOTTOM_OC = 12166.35 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+
+! values below corrected by Min Chen <mchen at gps.caltech.edu>
+
+! jp1d
+ ROCEAN = 6371000.d0
+ RMIDDLE_CRUST = 6359000.d0
+ RMOHO = 6345000.d0
+ R80 = 6291000.d0
+ R220 = 6161000.d0
+ R400 = 5949000.d0
+ R600 = 5781000.d0
+ R670 = 5711000.d0
+ R771 = 5611000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3482000.d0
+ RICB = 1217000.d0
+ RHO_TOP_OC = 9900.2379 / RHOAV
+ RHO_BOTTOM_OC = 12168.6383 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+
+! SEA1D without the 2 km of mud layer or the 3km water layer
+ ROCEAN = 6371000.d0
+ RMIDDLE_CRUST = 6361000.d0
+ RMOHO = 6346000.d0
+ R80 = 6291000.d0
+ R220 = 6161000.d0
+ R400 = 5961000.d0
+ R670 = 5711000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3485700.d0
+ RICB = 1217100.d0
+
+! values for SEA1D that are not discontinuities
+ R600 = 5771000.d0
+ R771 = 5611000.d0
+
+ RHO_TOP_OC = 9903.4384 / RHOAV
+ RHO_BOTTOM_OC = 12166.5885 / RHOAV
+
+ else
+
+! PREM
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R220 = 6151000.d0
+ R400 = 5971000.d0
+ R600 = 5771000.d0
+ R670 = 5701000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3480000.d0
+ RICB = 1221000.d0
+
+ RHO_TOP_OC = 9903.4384 / RHOAV
+ RHO_BOTTOM_OC = 12166.5885 / RHOAV
+
+ endif
+
+! honor the PREM Moho or define a fictitious Moho in order to have even radial sampling
+! from the d220 to the Earth surface
+ if(HONOR_1D_SPHERICAL_MOHO) then
+ RMOHO_FICTITIOUS_IN_MESHER = RMOHO
+ else
+ RMOHO_FICTITIOUS_IN_MESHER = (R80 + R_EARTH) / 2
+ endif
+
+ call read_value_double_precision(RECORD_LENGTH_IN_MINUTES, 'solver.RECORD_LENGTH_IN_MINUTES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! 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)
+
+ call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(MOVIE_COARSE,'solver.MOVIE_COARSE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_FRAMES, 'solver.NTSTEP_BETWEEN_FRAMES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(HDUR_MOVIE, 'solver.HDUR_MOVIE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! computes a default hdur_movie that creates nice looking movies.
+! Sets HDUR_MOVIE as the minimum period the mesh can resolve
+ if(HDUR_MOVIE <= TINYVAL) &
+ HDUR_MOVIE = 1.2d0*max(240.d0/NEX_XI*18.d0*ANGULAR_WIDTH_XI_IN_DEGREES/90.d0, &
+ 240.d0/NEX_ETA*18.d0*ANGULAR_WIDTH_ETA_IN_DEGREES/90.d0)
+
+ call read_value_integer(MOVIE_VOLUME_TYPE, 'solver.MOVIE_VOLUME_TYPE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_TOP_KM, 'solver.MOVIE_TOP_KM')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_BOTTOM_KM, 'solver.MOVIE_BOTTOM_KM')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_WEST_DEG, 'solver.MOVIE_WEST_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_EAST_DEG, 'solver.MOVIE_EAST_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_NORTH_DEG, 'solver.MOVIE_NORTH_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_SOUTH_DEG, 'solver.MOVIE_SOUTH_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(MOVIE_START, 'solver.MOVIE_START')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(MOVIE_STOP, 'solver.MOVIE_STOP')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ MOVIE_TOP = (R_EARTH_KM-MOVIE_TOP_KM)/R_EARTH_KM
+ MOVIE_BOTTOM = (R_EARTH_KM-MOVIE_BOTTOM_KM)/R_EARTH_KM
+ MOVIE_EAST = MOVIE_EAST_DEG * DEGREES_TO_RADIANS
+ MOVIE_WEST = MOVIE_WEST_DEG * DEGREES_TO_RADIANS
+ MOVIE_NORTH = (90.0d0 - MOVIE_NORTH_DEG) * DEGREES_TO_RADIANS ! converting from latitude to colatitude
+ MOVIE_SOUTH = (90.0d0 - MOVIE_SOUTH_DEG) * DEGREES_TO_RADIANS
+
+ call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NUMBER_OF_RUNS, 'solver.NUMBER_OF_RUNS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NUMBER_OF_THIS_RUN, 'solver.NUMBER_OF_THIS_RUN')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_OUTPUT_INFO, 'solver.NTSTEP_BETWEEN_OUTPUT_INFO')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_OUTPUT_SEISMOS, 'solver.NTSTEP_BETWEEN_OUTPUT_SEISMOS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_READ_ADJSRC, 'solver.NTSTEP_BETWEEN_READ_ADJSRC')
+ if(err_occurred() /= 0) return
+
+ call read_value_logical(OUTPUT_SEISMOS_ASCII_TEXT, 'solver.OUTPUT_SEISMOS_ASCII_TEXT')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(OUTPUT_SEISMOS_SAC_ALPHANUM, 'solver.OUTPUT_SEISMOS_SAC_ALPHANUM')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(OUTPUT_SEISMOS_SAC_BINARY, 'solver.OUTPUT_SEISMOS_SAC_BINARY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ROTATE_SEISMOGRAMS_RT, 'solver.ROTATE_SEISMOGRAMS_RT')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(WRITE_SEISMOGRAMS_BY_MASTER, 'solver.WRITE_SEISMOGRAMS_BY_MASTER')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(SAVE_ALL_SEISMOS_IN_ONE_FILE, 'solver.SAVE_ALL_SEISMOS_IN_ONE_FILE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(USE_BINARY_FOR_LARGE_FILE, 'solver.USE_BINARY_FOR_LARGE_FILE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ call read_value_logical(RECEIVERS_CAN_BE_BURIED, 'solver.RECEIVERS_CAN_BE_BURIED')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(PRINT_SOURCE_TIME_FUNCTION, 'solver.PRINT_SOURCE_TIME_FUNCTION')
+
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! close parameter file
+ call close_parameter_file
+!--- check that parameters make sense
+
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
+ stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5, check the Par_file'
+
+! subsets used to save seismograms must not be larger than the whole time series,
+! otherwise we waste memory
+ if(NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP) then
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
+ stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then modified NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5'
+ endif
+
+! check that reals are either 4 or 8 bytes
+ if(CUSTOM_REAL /= SIZE_REAL .and. CUSTOM_REAL /= SIZE_DOUBLE) stop 'wrong size of CUSTOM_REAL for reals'
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) stop 'number of control nodes must be 27'
+ if(NGNOD == 27 .and. NGNOD2D /= 9) stop 'elements with 27 points should have NGNOD2D = 9'
+
+! for the number of standard linear solids for attenuation
+ if(N_SLS /= 3) stop 'number of SLS must be 3'
+
+! check number of slices in each direction
+ if(NCHUNKS < 1) stop 'must have at least one chunk'
+ if(NPROC_XI < 1) stop 'NPROC_XI must be at least 1'
+ if(NPROC_ETA < 1) stop 'NPROC_ETA must be at least 1'
+
+! check number of chunks
+ if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
+ stop 'only one, two, three or six chunks can be meshed'
+
+! check that the central cube can be included
+ if(INCLUDE_CENTRAL_CUBE .and. NCHUNKS /= 6) stop 'need six chunks to include central cube'
+
+! check that sphere can be cut into slices without getting negative Jacobian
+ if(NEX_XI < 48) stop 'NEX_XI must be greater than 48 to cut the sphere into slices with positive Jacobian'
+ if(NEX_ETA < 48) stop 'NEX_ETA must be greater than 48 to cut the sphere into slices with positive Jacobian'
+
+! check that mesh can be coarsened in depth three or four times
+ CUT_SUPERBRICK_XI=.false.
+ CUT_SUPERBRICK_ETA=.false.
+
+ if (SUPPRESS_CRUSTAL_MESH .and. .not. ADD_4TH_DOUBLING) then
+ if(mod(NEX_XI,8) /= 0) stop 'NEX_XI must be a multiple of 8'
+ if(mod(NEX_ETA,8) /= 0) stop 'NEX_ETA must be a multiple of 8'
+ if(mod(NEX_XI/4,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 4*NPROC_XI'
+ if(mod(NEX_ETA/4,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 4*NPROC_ETA'
+ if(mod(NEX_XI/8,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/8,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+ elseif (SUPPRESS_CRUSTAL_MESH .or. .not. ADD_4TH_DOUBLING) then
+ if(mod(NEX_XI,16) /= 0) stop 'NEX_XI must be a multiple of 16'
+ if(mod(NEX_ETA,16) /= 0) stop 'NEX_ETA must be a multiple of 16'
+ if(mod(NEX_XI/8,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 8*NPROC_XI'
+ if(mod(NEX_ETA/8,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 8*NPROC_ETA'
+ if(mod(NEX_XI/16,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/16,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+!! DK DK added this because of temporary bug in David's code
+ if(mod(NEX_XI/16,NPROC_XI) /=0) &
+ stop 'NEX_XI multiple of 8*NPROC_XI but not of 16*NPROC_XI is currently unsafe'
+ if(mod(NEX_ETA/16,NPROC_ETA) /=0) &
+ stop 'NEX_ETA multiple of 8*NPROC_ETA but not of 16*NPROC_ETA is currently unsafe'
+!! DK DK added this because of temporary bug in David's code
+ else
+ if(mod(NEX_XI,32) /= 0) stop 'NEX_XI must be a multiple of 32'
+ if(mod(NEX_ETA,32) /= 0) stop 'NEX_ETA must be a multiple of 32'
+ if(mod(NEX_XI/16,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 16*NPROC_XI'
+ if(mod(NEX_ETA/16,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 16*NPROC_ETA'
+ if(mod(NEX_XI/32,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/32,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+ endif
+
+! check that topology is correct if more than two chunks
+ if(NCHUNKS > 2 .and. NEX_XI /= NEX_ETA) stop 'must have NEX_XI = NEX_ETA for more than two chunks'
+ if(NCHUNKS > 2 .and. NPROC_XI /= NPROC_ETA) stop 'must have NPROC_XI = NPROC_ETA for more than two chunks'
+
+! check that option to run one slice only per chunk has been activated
+! (it is deactivated by default because MPI buffers use more memory when it is on)
+ if((NPROC_XI == 1 .or. NPROC_ETA == 1) .and. (NUMFACES_SHARED /= 4 .or. NUMCORNERS_SHARED /= 4)) &
+ stop 'option to run one slice only per chunk is deactivated, edit constants.h and recompile'
+
+! check that IASP91, AK135, 1066A, JP1D or SEA1D is isotropic
+ if((REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91 .or. &
+ REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135 .or. &
+ REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A .or. &
+ REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D .or. &
+ REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) .and. TRANSVERSE_ISOTROPY) &
+ stop 'models IASP91, AK135, 1066A, JP1D and SEA1D are currently isotropic'
+
+ ELEMENT_WIDTH = ANGULAR_WIDTH_XI_IN_DEGREES/dble(NEX_MAX) * DEGREES_TO_RADIANS
+
+!
+!--- compute additional parameters
+!
+
+! number of elements horizontally in each slice (i.e. per processor)
+! these two values MUST be equal in all cases
+ NEX_PER_PROC_XI = NEX_XI / NPROC_XI
+ NEX_PER_PROC_ETA = NEX_ETA / NPROC_ETA
+
+! total number of processors in each of the six chunks
+ NPROC = NPROC_XI * NPROC_ETA
+
+! total number of processors in the full Earth composed of the six chunks
+ NPROCTOT = NCHUNKS * NPROC
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! definition of general mesh parameters below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! find element below top of which we should implement the second doubling in the mantle
+! locate element closest to optimal value
+ distance_min = HUGEVAL
+ do ielem = 2,NER_TOPDDOUBLEPRIME_771
+ zval = RTOPDDOUBLEPRIME + ielem * (R771 - RTOPDDOUBLEPRIME) / dble(NER_TOPDDOUBLEPRIME_771)
+ distance = abs(zval - (R_EARTH - DEPTH_SECOND_DOUBLING_OPTIMAL))
+ if(distance < distance_min) then
+ elem_doubling_mantle = ielem
+ distance_min = distance
+ DEPTH_SECOND_DOUBLING_REAL = R_EARTH - zval
+ endif
+ enddo
+
+! find element below top of which we should implement the third doubling in the middle of the outer core
+! locate element closest to optimal value
+ distance_min = HUGEVAL
+! start at element number 4 because we need at least two elements below for the fourth doubling
+! implemented at the bottom of the outer core
+ do ielem = 4,NER_OUTER_CORE
+ zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
+ distance = abs(zval - (R_EARTH - DEPTH_THIRD_DOUBLING_OPTIMAL))
+ if(distance < distance_min) then
+ elem_doubling_middle_outer_core = ielem
+ distance_min = distance
+ DEPTH_THIRD_DOUBLING_REAL = R_EARTH - zval
+ endif
+ enddo
+
+ if (ADD_4TH_DOUBLING) then
+! find element below top of which we should implement the fourth doubling in the middle of the outer core
+! locate element closest to optimal value
+ distance_min = HUGEVAL
+! end two elements before the top because we need at least two elements above for the third doubling
+! implemented in the middle of the outer core
+ do ielem = 2,NER_OUTER_CORE-2
+ zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
+ distance = abs(zval - (R_EARTH - DEPTH_FOURTH_DOUBLING_OPTIMAL))
+ if(distance < distance_min) then
+ elem_doubling_bottom_outer_core = ielem
+ distance_min = distance
+ DEPTH_FOURTH_DOUBLING_REAL = R_EARTH - zval
+ endif
+ enddo
+! make sure that the two doublings in the outer core are found in the right order
+ if(elem_doubling_bottom_outer_core >= elem_doubling_middle_outer_core) &
+ stop 'error in location of the two doublings in the outer core'
+ endif
+
+ ratio_sampling_array(15) = 0
+
+! define all the layers of the mesh
+ if (.not. ADD_4TH_DOUBLING) then
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+
+ ONE_CRUST = .false.
+ OCEANS= .false.
+ TOPOGRAPHY = .false.
+ CRUSTAL = .false.
+
+ NUMBER_OF_MESH_LAYERS = 14
+ layer_offset = 1
+
+ ! now only one region
+ ner( 1) = NER_CRUST + NER_80_MOHO
+ ner( 2) = 0
+ ner( 3) = 0
+
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core
+ ner(14) = NER_TOP_CENTRAL_CUBE_ICB
+
+! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
+ ifirst_layer_aniso = 1
+ ilast_layer_aniso = 4
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:9) = 1
+ ratio_sampling_array(10:12) = 2
+ ratio_sampling_array(13:14) = 4
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(14) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_layer_has_a_doubling(:) = .false.
+ this_layer_has_a_doubling(10) = .true.
+ this_layer_has_a_doubling(13) = .true.
+ lastdoubling_layer = 13
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = R80
+
+ r_top(2) = RMIDDLE_CRUST !!!! now fictitious
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+ r_bottom(3) = R80 !!!! now fictitious
+
+ r_top(4) = R80
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = RICB
+
+ r_top(14) = RICB
+ r_bottom(14) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = R80 / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+ rmins(3) = R80 / R_EARTH !!!! now fictitious
+
+ rmaxs(4) = R80 / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:13) = RCMB / R_EARTH
+ rmins(12:13) = RICB / R_EARTH
+
+ rmaxs(14) = RICB / R_EARTH
+ rmins(14) = R_CENTRAL_CUBE / R_EARTH
+
+ elseif (ONE_CRUST) then
+
+ NUMBER_OF_MESH_LAYERS = 13
+ layer_offset = 0
+
+ ner( 1) = NER_CRUST
+ ner( 2) = NER_80_MOHO
+ ner( 3) = NER_220_80
+ ner( 4) = NER_400_220
+ ner( 5) = NER_600_400
+ ner( 6) = NER_670_600
+ ner( 7) = NER_771_670
+ ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner( 9) = elem_doubling_mantle
+ ner(10) = NER_CMB_TOPDDOUBLEPRIME
+ ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(12) = elem_doubling_middle_outer_core
+ ner(13) = NER_TOP_CENTRAL_CUBE_ICB
+
+! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
+ ifirst_layer_aniso = 2
+ ilast_layer_aniso = 3
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1) = 1
+ ratio_sampling_array(2:8) = 2
+ ratio_sampling_array(9:11) = 4
+ ratio_sampling_array(12:13) = 8
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1) = IFLAG_CRUST
+ doubling_index(2) = IFLAG_80_MOHO
+ doubling_index(3) = IFLAG_220_80
+ doubling_index(4:6) = IFLAG_670_220
+ doubling_index(7:10) = IFLAG_MANTLE_NORMAL
+ doubling_index(11:12) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(13) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_layer_has_a_doubling(:) = .false.
+ this_layer_has_a_doubling(2) = .true.
+ this_layer_has_a_doubling(9) = .true.
+ this_layer_has_a_doubling(12) = .true.
+ lastdoubling_layer = 12
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
+ !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
+ !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
+ !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
+ !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
+ !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(2) = R80
+
+ r_top(3) = R80
+ r_bottom(3) = R220
+
+ r_top(4) = R220
+ r_bottom(4) = R400
+
+ r_top(5) = R400
+ r_bottom(5) = R600
+
+ r_top(6) = R600
+ r_bottom(6) = R670
+
+ r_top(7) = R670
+ r_bottom(7) = R771
+
+ r_top(8) = R771
+ r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(9) = RTOPDDOUBLEPRIME
+
+ r_top(10) = RTOPDDOUBLEPRIME
+ r_bottom(10) = RCMB
+
+ r_top(11) = RCMB
+ r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(12) = RICB
+
+ r_top(13) = RICB
+ r_bottom(13) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(2) = R80 / R_EARTH
+
+ rmaxs(3) = R80 / R_EARTH
+ rmins(3) = R220 / R_EARTH
+
+ rmaxs(4) = R220 / R_EARTH
+ rmins(4) = R400 / R_EARTH
+
+ rmaxs(5) = R400 / R_EARTH
+ rmins(5) = R600 / R_EARTH
+
+ rmaxs(6) = R600 / R_EARTH
+ rmins(6) = R670 / R_EARTH
+
+ rmaxs(7) = R670 / R_EARTH
+ rmins(7) = R771 / R_EARTH
+
+ rmaxs(8:9) = R771 / R_EARTH
+ rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(10) = RCMB / R_EARTH
+
+ rmaxs(11:12) = RCMB / R_EARTH
+ rmins(11:12) = RICB / R_EARTH
+
+ rmaxs(13) = RICB / R_EARTH
+ rmins(13) = R_CENTRAL_CUBE / R_EARTH
+
+ else
+
+ NUMBER_OF_MESH_LAYERS = 14
+ layer_offset = 1
+ if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
+ ner( 1) = ceiling (NER_CRUST / 2.d0)
+ ner( 2) = floor (NER_CRUST / 2.d0)
+ else
+ ner( 1) = floor (NER_CRUST / 2.d0)
+ ner( 2) = ceiling (NER_CRUST / 2.d0)
+ endif
+ ner( 3) = NER_80_MOHO
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core
+ ner(14) = NER_TOP_CENTRAL_CUBE_ICB
+
+! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
+ ifirst_layer_aniso = 3
+ ilast_layer_aniso = 4
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:2) = 1
+ ratio_sampling_array(3:9) = 2
+ ratio_sampling_array(10:12) = 4
+ ratio_sampling_array(13:14) = 8
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:2) = IFLAG_CRUST
+ doubling_index(3) = IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(14) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_layer_has_a_doubling(:) = .false.
+ this_layer_has_a_doubling(3) = .true.
+ this_layer_has_a_doubling(10) = .true.
+ this_layer_has_a_doubling(13) = .true.
+ this_layer_has_a_doubling(14) = .false.
+ lastdoubling_layer = 13
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMIDDLE_CRUST
+
+ r_top(2) = RMIDDLE_CRUST
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(3) = R80
+
+ r_top(4) = R80
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = RICB
+
+ r_top(14) = RICB
+ r_bottom(14) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMIDDLE_CRUST / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(3) = R80 / R_EARTH
+
+ rmaxs(4) = R80 / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:13) = RCMB / R_EARTH
+ rmins(12:13) = RICB / R_EARTH
+
+ rmaxs(14) = RICB / R_EARTH
+ rmins(14) = R_CENTRAL_CUBE / R_EARTH
+
+ endif
+ else
+ if (SUPPRESS_CRUSTAL_MESH) then
+
+ ONE_CRUST = .false.
+ OCEANS= .false.
+ TOPOGRAPHY = .false.
+ CRUSTAL = .false.
+
+ NUMBER_OF_MESH_LAYERS = 15
+ layer_offset = 1
+
+ ! now only one region
+ ner( 1) = NER_CRUST + NER_80_MOHO
+ ner( 2) = 0
+ ner( 3) = 0
+
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
+ ner(14) = elem_doubling_bottom_outer_core
+ ner(15) = NER_TOP_CENTRAL_CUBE_ICB
+
+! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
+ ifirst_layer_aniso = 1
+ ilast_layer_aniso = 4
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:9) = 1
+ ratio_sampling_array(10:12) = 2
+ ratio_sampling_array(13) = 4
+ ratio_sampling_array(14:15) = 8
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(15) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_layer_has_a_doubling(:) = .false.
+ this_layer_has_a_doubling(10) = .true.
+ this_layer_has_a_doubling(13) = .true.
+ this_layer_has_a_doubling(14) = .true.
+ lastdoubling_layer = 14
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = R80
+
+ r_top(2) = RMIDDLE_CRUST !!!! now fictitious
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+ r_bottom(3) = R80 !!!! now fictitious
+
+ r_top(4) = R80
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+
+ r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+ r_bottom(14) = RICB
+
+ r_top(15) = RICB
+ r_bottom(15) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = R80 / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+ rmins(3) = R80 / R_EARTH !!!! now fictitious
+
+ rmaxs(4) = R80 / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:14) = RCMB / R_EARTH
+ rmins(12:14) = RICB / R_EARTH
+
+ rmaxs(15) = RICB / R_EARTH
+ rmins(15) = R_CENTRAL_CUBE / R_EARTH
+
+ elseif (ONE_CRUST) then
+
+ NUMBER_OF_MESH_LAYERS = 14
+ layer_offset = 0
+
+ ner( 1) = NER_CRUST
+ ner( 2) = NER_80_MOHO
+ ner( 3) = NER_220_80
+ ner( 4) = NER_400_220
+ ner( 5) = NER_600_400
+ ner( 6) = NER_670_600
+ ner( 7) = NER_771_670
+ ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner( 9) = elem_doubling_mantle
+ ner(10) = NER_CMB_TOPDDOUBLEPRIME
+ ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(12) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
+ ner(13) = elem_doubling_bottom_outer_core
+ ner(14) = NER_TOP_CENTRAL_CUBE_ICB
+
+! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
+ ifirst_layer_aniso = 2
+ ilast_layer_aniso = 3
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1) = 1
+ ratio_sampling_array(2:8) = 2
+ ratio_sampling_array(9:11) = 4
+ ratio_sampling_array(12) = 8
+ ratio_sampling_array(13:14) = 16
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1) = IFLAG_CRUST
+ doubling_index(2) = IFLAG_80_MOHO
+ doubling_index(3) = IFLAG_220_80
+ doubling_index(4:6) = IFLAG_670_220
+ doubling_index(7:10) = IFLAG_MANTLE_NORMAL
+ doubling_index(11:13) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(14) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_layer_has_a_doubling(:) = .false.
+ this_layer_has_a_doubling(2) = .true.
+ this_layer_has_a_doubling(9) = .true.
+ this_layer_has_a_doubling(12) = .true.
+ this_layer_has_a_doubling(13) = .true.
+ lastdoubling_layer = 13
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
+ !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
+ !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
+ !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
+ !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
+ !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(2) = R80
+
+ r_top(3) = R80
+ r_bottom(3) = R220
+
+ r_top(4) = R220
+ r_bottom(4) = R400
+
+ r_top(5) = R400
+ r_bottom(5) = R600
+
+ r_top(6) = R600
+ r_bottom(6) = R670
+
+ r_top(7) = R670
+ r_bottom(7) = R771
+
+ r_top(8) = R771
+ r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(9) = RTOPDDOUBLEPRIME
+
+ r_top(10) = RTOPDDOUBLEPRIME
+ r_bottom(10) = RCMB
+
+ r_top(11) = RCMB
+ r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(12) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+ r_bottom(13) = RICB
+
+ r_top(14) = RICB
+ r_bottom(14) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(2) = R80 / R_EARTH
+
+ rmaxs(3) = R80 / R_EARTH
+ rmins(3) = R220 / R_EARTH
+
+ rmaxs(4) = R220 / R_EARTH
+ rmins(4) = R400 / R_EARTH
+
+ rmaxs(5) = R400 / R_EARTH
+ rmins(5) = R600 / R_EARTH
+
+ rmaxs(6) = R600 / R_EARTH
+ rmins(6) = R670 / R_EARTH
+
+ rmaxs(7) = R670 / R_EARTH
+ rmins(7) = R771 / R_EARTH
+
+ rmaxs(8:9) = R771 / R_EARTH
+ rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(10) = RCMB / R_EARTH
+
+ rmaxs(11:13) = RCMB / R_EARTH
+ rmins(11:13) = RICB / R_EARTH
+
+ rmaxs(14) = RICB / R_EARTH
+ rmins(14) = R_CENTRAL_CUBE / R_EARTH
+
+ else
+
+ NUMBER_OF_MESH_LAYERS = 15
+ layer_offset = 1
+ if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
+ ner( 1) = ceiling (NER_CRUST / 2.d0)
+ ner( 2) = floor (NER_CRUST / 2.d0)
+ else
+ ner( 1) = floor (NER_CRUST / 2.d0)
+ ner( 2) = ceiling (NER_CRUST / 2.d0)
+ endif
+ ner( 3) = NER_80_MOHO
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
+ ner(14) = elem_doubling_bottom_outer_core
+ ner(15) = NER_TOP_CENTRAL_CUBE_ICB
+
+! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
+ ifirst_layer_aniso = 3
+ ilast_layer_aniso = 4
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:2) = 1
+ ratio_sampling_array(3:9) = 2
+ ratio_sampling_array(10:12) = 4
+ ratio_sampling_array(13) = 8
+ ratio_sampling_array(14:15) = 16
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:2) = IFLAG_CRUST
+ doubling_index(3) = IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(15) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_layer_has_a_doubling(:) = .false.
+ this_layer_has_a_doubling(3) = .true.
+ this_layer_has_a_doubling(10) = .true.
+ this_layer_has_a_doubling(13) = .true.
+ this_layer_has_a_doubling(14) = .true.
+ lastdoubling_layer = 14
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMIDDLE_CRUST
+
+ r_top(2) = RMIDDLE_CRUST
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(3) = R80
+
+ r_top(4) = R80
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+
+ r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+ r_bottom(14) = RICB
+
+ r_top(15) = RICB
+ r_bottom(15) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMIDDLE_CRUST / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(3) = R80 / R_EARTH
+
+ rmaxs(4) = R80 / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:14) = RCMB / R_EARTH
+ rmins(12:14) = RICB / R_EARTH
+
+ rmaxs(15) = RICB / R_EARTH
+ rmins(15) = R_CENTRAL_CUBE / R_EARTH
+ endif
+ endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! calculation of number of elements (NSPEC) below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ratio_divide_central_cube = maxval(ratio_sampling_array)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 1D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+! theoretical number of spectral elements in radial direction
+do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else if(iter_region == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+ else
+ stop 'incorrect region code detected'
+ endif
+ NSPEC1D_RADIAL(iter_region) = sum(ner(ifirst_region:ilast_region))
+enddo
+
+! difference of radial number of element for outer core if the superbrick is cut
+ DIFF_NSPEC1D_RADIAL(:,:) = 0
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC1D_RADIAL(2,1) = 1
+ DIFF_NSPEC1D_RADIAL(3,1) = 2
+ DIFF_NSPEC1D_RADIAL(4,1) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,2) = 1
+ DIFF_NSPEC1D_RADIAL(2,2) = 2
+ DIFF_NSPEC1D_RADIAL(3,2) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,3) = 1
+ DIFF_NSPEC1D_RADIAL(3,3) = 1
+ DIFF_NSPEC1D_RADIAL(4,3) = 2
+
+ DIFF_NSPEC1D_RADIAL(1,4) = 2
+ DIFF_NSPEC1D_RADIAL(2,4) = 1
+ DIFF_NSPEC1D_RADIAL(4,4) = 1
+ else
+ DIFF_NSPEC1D_RADIAL(2,1) = 1
+ DIFF_NSPEC1D_RADIAL(3,1) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,2) = 1
+ DIFF_NSPEC1D_RADIAL(4,2) = 1
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC1D_RADIAL(3,1) = 1
+ DIFF_NSPEC1D_RADIAL(4,1) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,2) = 1
+ DIFF_NSPEC1D_RADIAL(2,2) = 1
+ endif
+ endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 2D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! exact number of surface elements for faces along XI and ETA
+
+do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else if(iter_region == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+ else
+ stop 'incorrect region code detected'
+ endif
+ tmp_sum_xi = 0
+ tmp_sum_eta = 0
+ tmp_sum_nglob2D_xi = 0
+ tmp_sum_nglob2D_eta = 0
+ do iter_layer = ifirst_region, ilast_region
+ if (this_layer_has_a_doubling(iter_layer)) then
+ if (iter_region == IREGION_OUTER_CORE .and. iter_layer == lastdoubling_layer) then
+ ! simple brick
+ divider = 1
+ nglob_surf = 6*NGLLX**2 - 7*NGLLX + 2
+ nglob_edges_h = 2*(NGLLX-1)+1 + NGLLX
+ ! minimum value to be safe
+ nglob_edge_v = NGLLX-2
+ nb_lay_sb = 2
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
+ else
+ ! double brick
+ divider = 2
+ if (ner(iter_layer) == 1) then
+ nglob_surf = 6*NGLLX**2 - 8*NGLLX + 3
+ nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
+ nglob_edge_v = NGLLX-2
+ nb_lay_sb = 1
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK_1L
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK_1L
+ else
+ nglob_surf = 8*NGLLX**2 - 11*NGLLX + 4
+ nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
+ nglob_edge_v = 2*(NGLLX-1)+1 -2
+ nb_lay_sb = 2
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
+ divider = 2
+ endif
+ endif
+ doubling = 1
+ to_remove = 1
+ else
+ if (iter_layer /= ifirst_region) then
+ to_remove = 0
+ else
+ to_remove = 1
+ endif
+! dummy values to avoid a warning
+ nglob_surf = 0
+ nglob_edges_h = 0
+ nglob_edge_v = 0
+ doubling = 0
+ nb_lay_sb = 0
+ nspec2D_xi_sb = 0
+ nspec2D_eta_sb = 0
+ divider = 1
+ endif
+
+ tmp_sum_xi = tmp_sum_xi + ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb)) + &
+ doubling * ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * (nspec2D_xi_sb/2))
+
+ tmp_sum_eta = tmp_sum_eta + ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb)) + &
+ doubling * ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * (nspec2D_eta_sb/2))
+
+ tmp_sum_nglob2D_xi = tmp_sum_nglob2D_xi + (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb))*NGLLX*NGLLX) - &
+ ((((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - doubling*nb_lay_sb)) + &
+ ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))*(ner(iter_layer) - to_remove - doubling*nb_lay_sb))*NGLLX) + &
+ (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
+ doubling * (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
+ ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
+
+ tmp_sum_nglob2D_eta = tmp_sum_nglob2D_eta + (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb))*NGLLX*NGLLX) - &
+ ((((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - doubling*nb_lay_sb)) + &
+ ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))* &
+ (ner(iter_layer) - to_remove - doubling*nb_lay_sb))*NGLLX) + &
+ (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
+ doubling * (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
+ ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
+ enddo
+ NSPEC2D_XI(iter_region) = tmp_sum_xi
+ NSPEC2D_ETA(iter_region) = tmp_sum_eta
+
+ NGLOB2DMAX_YMIN_YMAX(iter_region) = tmp_sum_nglob2D_xi
+ NGLOB2DMAX_XMIN_XMAX(iter_region) = tmp_sum_nglob2D_eta
+
+ if (iter_region == IREGION_INNER_CORE .and. INCLUDE_CENTRAL_CUBE) then
+ NSPEC2D_XI(iter_region) = NSPEC2D_XI(iter_region) + &
+ ((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
+ NSPEC2D_ETA(iter_region) = NSPEC2D_ETA(iter_region) + &
+ ((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
+
+ NGLOB2DMAX_YMIN_YMAX(iter_region) = NGLOB2DMAX_YMIN_YMAX(iter_region) + &
+ (((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
+
+ NGLOB2DMAX_XMIN_XMAX(iter_region) = NGLOB2DMAX_XMIN_XMAX(iter_region) + &
+ (((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
+ endif
+enddo
+
+! difference of number of surface elements along xi or eta for outer core if the superbrick is cut
+ DIFF_NSPEC2D_XI(:,:) = 0
+ DIFF_NSPEC2D_ETA(:,:) = 0
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC2D_XI(2,1) = 2
+ DIFF_NSPEC2D_XI(1,2) = 2
+ DIFF_NSPEC2D_XI(2,3) = 2
+ DIFF_NSPEC2D_XI(1,4) = 2
+
+ DIFF_NSPEC2D_ETA(2,1) = 1
+ DIFF_NSPEC2D_ETA(2,2) = 1
+ DIFF_NSPEC2D_ETA(1,3) = 1
+ DIFF_NSPEC2D_ETA(1,4) = 1
+ else
+ DIFF_NSPEC2D_ETA(2,1) = 1
+ DIFF_NSPEC2D_ETA(1,2) = 1
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC2D_XI(2,1) = 2
+ DIFF_NSPEC2D_XI(1,2) = 2
+ endif
+ endif
+ DIFF_NSPEC2D_XI(:,:) = DIFF_NSPEC2D_XI(:,:) * (NEX_PER_PROC_XI / ratio_divide_central_cube)
+ DIFF_NSPEC2D_ETA(:,:) = DIFF_NSPEC2D_ETA(:,:) * (NEX_PER_PROC_ETA / ratio_divide_central_cube)
+
+! exact number of surface elements on the bottom and top boundaries
+
+! in the crust and mantle
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(1))*(NEX_ETA/ratio_sampling_array(1))/NPROC
+ NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(10+layer_offset))*&
+ (NEX_ETA/ratio_sampling_array(10+layer_offset))/NPROC
+
+! in the outer core with mesh doubling
+ if (ADD_4TH_DOUBLING) then
+ NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/4))*(NEX_ETA/(ratio_divide_central_cube/4))/NPROC
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
+ else
+ NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/2))*(NEX_ETA/(ratio_divide_central_cube/2))/NPROC
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
+ endif
+
+! in the top of the inner core
+ NSPEC2D_TOP(IREGION_INNER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
+ NSPEC2D_BOTTOM(IREGION_INNER_CORE) = NSPEC2D_TOP(IREGION_INNER_CORE)
+
+! maximum number of surface elements on vertical boundaries of the slices
+ NSPEC2DMAX_XMIN_XMAX(:) = NSPEC2D_ETA(:)
+ NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_ETA(:,:))
+ NSPEC2DMAX_YMIN_YMAX(:) = NSPEC2D_XI(:)
+ NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_XI(:,:))
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 3D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! exact number of spectral elements in each region
+
+do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else if(iter_region == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+ else
+ stop 'incorrect region code detected'
+ endif
+ tmp_sum = 0;
+ do iter_layer = ifirst_region, ilast_region
+ if (this_layer_has_a_doubling(iter_layer)) then
+ if (ner(iter_layer) == 1) then
+ nb_lay_sb = 1
+ nspec_sb = NSPEC_SUPERBRICK_1L
+ else
+ nb_lay_sb = 2
+ nspec_sb = NSPEC_DOUBLING_SUPERBRICK
+ endif
+ doubling = 1
+ else
+ doubling = 0
+ nb_lay_sb = 0
+ nspec_sb = 0
+ endif
+ tmp_sum = tmp_sum + (((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb)) + &
+ doubling * ((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
+ (nspec_sb/4))) / NPROC
+ enddo
+ NSPEC(iter_region) = tmp_sum
+enddo
+
+ if(INCLUDE_CENTRAL_CUBE) NSPEC(IREGION_INNER_CORE) = NSPEC(IREGION_INNER_CORE) + &
+ (NEX_PER_PROC_XI / ratio_divide_central_cube) * &
+ (NEX_PER_PROC_ETA / ratio_divide_central_cube) * &
+ (NEX_XI / ratio_divide_central_cube)
+
+ if(minval(NSPEC) <= 0) stop 'negative NSPEC, there is a problem somewhere'
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! calculation of number of points (NGLOB) below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 1D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! theoretical number of Gauss-Lobatto points in radial direction
+ NGLOB1D_RADIAL(:) = NSPEC1D_RADIAL(:)*(NGLLZ-1)+1
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 2D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 2-D addressing and buffers for summation between slices
+! we add one to number of points because of the flag after the last point
+ NGLOB2DMAX_XMIN_XMAX(:) = NGLOB2DMAX_XMIN_XMAX(:) + 1
+ NGLOB2DMAX_YMIN_YMAX(:) = NGLOB2DMAX_YMIN_YMAX(:) + 1
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 3D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! exact number of global points in each region
+
+! initialize array
+ NGLOB(:) = 0
+
+! in the inner core (no doubling region + eventually central cube)
+ if(INCLUDE_CENTRAL_CUBE) then
+ NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
+ *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
+ *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB + NEX_XI / ratio_divide_central_cube)*(NGLLZ-1)+1)
+ else
+ NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
+ *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
+ *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB)*(NGLLZ-1)+1)
+ endif
+
+! in the crust-mantle and outercore
+ do iter_region = IREGION_CRUST_MANTLE,IREGION_OUTER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else
+ stop 'incorrect region code detected'
+ endif
+ tmp_sum = 0;
+ do iter_layer = ifirst_region, ilast_region
+ nglob_int_surf_eta=0
+ nglob_int_surf_xi=0
+ nglob_ext_surf = 0
+ nglob_center_edge = 0
+ nglob_corner_edge = 0
+ nglob_border_edge = 0
+ if (this_layer_has_a_doubling(iter_layer)) then
+ if (iter_region == IREGION_OUTER_CORE .and. iter_layer == lastdoubling_layer .and. &
+ (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
+ doubling = 1
+ normal_doubling = 0
+ cut_doubling = 1
+ nb_lay_sb = 2
+ nglob_edge = 0
+ nglob_surf = 0
+ nglob_vol = 8*NGLLX**3 - 12*NGLLX**2 + 6*NGLLX - 1
+ nglob_int_surf_eta = 6*NGLLX**2 - 7*NGLLX + 2
+ nglob_int_surf_xi = 5*NGLLX**2 - 5*NGLLX + 1
+ nglob_ext_surf = 4*NGLLX**2-4*NGLLX+1
+ nglob_center_edge = 4*(NGLLX-1)+1
+ nglob_corner_edge = 2*(NGLLX-1)+1
+ nglob_border_edge = 3*(NGLLX-1)+1
+ else
+ if (ner(iter_layer) == 1) then
+ nb_lay_sb = 1
+ nglob_vol = 28*NGLLX**3 - 62*NGLLX**2 + 47*NGLLX - 12
+ nglob_surf = 6*NGLLX**2-8*NGLLX+3
+ nglob_edge = NGLLX
+ else
+ nb_lay_sb = 2
+ nglob_vol = 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13
+ nglob_surf = 8*NGLLX**2-11*NGLLX+4
+ nglob_edge = 2*NGLLX-1
+ endif
+ doubling = 1
+ normal_doubling = 1
+ cut_doubling = 0
+ endif
+ padding = -1
+ else
+ doubling = 0
+ normal_doubling = 0
+ cut_doubling = 0
+ padding = 0
+ nb_lay_sb = 0
+ nglob_vol = 0
+ nglob_surf = 0
+ nglob_edge = 0
+ endif
+ if (iter_layer == ilast_region) padding = padding +1
+ nblocks_xi = NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)
+ nblocks_eta = NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)
+
+ tmp_sum = tmp_sum + &
+ ((nblocks_xi)*(NGLLX-1)+1) * ((nblocks_eta)*(NGLLX-1)+1) * ((ner(iter_layer) - doubling*nb_lay_sb)*(NGLLX-1)+padding)+&
+ normal_doubling * ((((nblocks_xi*nblocks_eta)/4)*nglob_vol) - &
+ (((nblocks_eta/2-1)*nblocks_xi/2+(nblocks_xi/2-1)*nblocks_eta/2)*nglob_surf) + &
+ ((nblocks_eta/2-1)*(nblocks_xi/2-1)*nglob_edge)) + &
+ cut_doubling*(nglob_vol*(nblocks_xi*nblocks_eta) - &
+ ( nblocks_eta*(int(nblocks_xi/2)*nglob_int_surf_xi + int((nblocks_xi-1)/2)*nglob_ext_surf) + &
+ nblocks_xi*(int(nblocks_eta/2)*nglob_int_surf_eta + int((nblocks_eta-1)/2)*nglob_ext_surf)&
+ ) + &
+ ( int(nblocks_xi/2)*int(nblocks_eta/2)*nglob_center_edge + &
+ int((nblocks_xi-1)/2)*int((nblocks_eta-1)/2)*nglob_corner_edge + &
+ ((int(nblocks_eta/2)*int((nblocks_xi-1)/2))+(int((nblocks_eta-1)/2)*int(nblocks_xi/2)))*nglob_border_edge&
+ ))
+ enddo
+ NGLOB(iter_region) = tmp_sum
+ enddo
+
+!!! example :
+!!! nblocks_xi/2=5
+!!! ____________________________________
+!!! I I I I I I
+!!! I I I I I I
+!!! I I I I I I
+!!! nblocks_eta/2=3 I______+______+______+______+______I
+!!! I I I I I I
+!!! I I I I I I
+!!! I I I I I I
+!!! I______+______+______+______+______I
+!!! I I I I I I
+!!! I I I I I I
+!!! I I I I I I
+!!! I______I______I______I______I______I
+!!!
+!!! NGLOB for this doubling layer = 3*5*Volume - ((3-1)*5+(5-1)*3)*Surface + (3-1)*(5-1)*Edge
+!!!
+!!! 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13 -> nb GLL points in a superbrick (Volume)
+!!! 8*NGLLX**2-11*NGLLX+4 -> nb GLL points on a superbrick side (Surface)
+!!! 2*NGLLX-1 -> nb GLL points on a corner edge of a superbrick (Edge)
+
+!!! for the one layer superbrick :
+!!! NGLOB = 28.NGLL^3 - 62.NGLL^2 + 47.NGLL - 12 (Volume)
+!!! NGLOB = 6.NGLL^2 - 8.NGLL + 3 (Surface)
+!!! NGLOB = NGLL (Edge)
+!!!
+!!! those results were obtained by using the script UTILS/doubling_brick/count_nglob_analytical.pl
+!!! with an opendx file of the superbrick's geometry
+
+!!! for the basic doubling bricks (two layers)
+!!! NGLOB = 8.NGLL^3 - 12.NGLL^2 + 6.NGLL - 1 (VOLUME)
+!!! NGLOB = 5.NGLL^2 - 5.NGLL + 1 (SURFACE 1)
+!!! NGLOB = 6.NGLL^2 - 7.NGLL + 2 (SURFACE 2)
+
+ end subroutine read_compute_parameters
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/read_compute_parameters.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,2511 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine 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,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,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_layer_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,ifirst_layer_aniso,ilast_layer_aniso,EMULATE_ONLY)
-
- 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,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,SIMULATION_TYPE, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read,ifirst_layer_aniso,ilast_layer_aniso
-
- 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_KM,MOVIE_TOP,MOVIE_BOTTOM_KM,MOVIE_BOTTOM, &
- MOVIE_EAST_DEG,MOVIE_EAST,MOVIE_WEST_DEG,MOVIE_WEST,MOVIE_NORTH_DEG,MOVIE_NORTH,MOVIE_SOUTH_DEG,MOVIE_SOUTH
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- 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,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,EMULATE_ONLY
-
- character(len=150) OUTPUT_FILES,MODEL
-
-! local variables
- integer NEX_MAX
-
- double precision RECORD_LENGTH_IN_MINUTES,ELEMENT_WIDTH
-
- integer, external :: err_occurred
-
-! parameters to be computed based upon parameters above read from file
- integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- 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
-
- integer nblocks_xi,nblocks_eta
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_layer_has_a_doubling
-
- integer :: ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,elem_doubling_bottom_outer_core
- double precision :: DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
- DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval
-
-! honor PREM Moho or not
-! doing so drastically reduces the stability condition and therefore the time step
- logical :: HONOR_1D_SPHERICAL_MOHO,CASE_3D
-
- integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, padding, tmp_sum, tmp_sum_xi, tmp_sum_eta
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
- integer :: NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
- nb_lay_sb, nspec_sb, nglob_vol, nglob_surf, nglob_edge
-
- integer :: multiplication_factor
-
-! for the cut doublingbrick improvement
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer :: lastdoubling_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
- 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 :: tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,nglob_edge_v,to_remove
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
- call open_parameter_file
-
- call read_value_integer(SIMULATION_TYPE, 'solver.SIMULATION_TYPE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(SAVE_FORWARD, 'solver.SAVE_FORWARD')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
- if(SIMULATION_TYPE > 1) stop 'SIMULATION_TYPE > 1 not implemented in the reduced merged version yet'
-
- if(SAVE_FORWARD) stop 'SAVE_FORWARD not implemented in the reduced merged version yet'
-
- call read_value_integer(NCHUNKS, 'mesher.NCHUNKS')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
- stop 'NCHUNKS must be either 1, 2, 3 or 6'
-
- call read_value_double_precision(ANGULAR_WIDTH_XI_IN_DEGREES, 'mesher.ANGULAR_WIDTH_XI_IN_DEGREES')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(ANGULAR_WIDTH_ETA_IN_DEGREES, 'mesher.ANGULAR_WIDTH_ETA_IN_DEGREES')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(CENTER_LATITUDE_IN_DEGREES, 'mesher.CENTER_LATITUDE_IN_DEGREES')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(CENTER_LONGITUDE_IN_DEGREES, 'mesher.CENTER_LONGITUDE_IN_DEGREES')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(GAMMA_ROTATION_AZIMUTH, 'mesher.GAMMA_ROTATION_AZIMUTH')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
-! this MUST be 90 degrees for two chunks or more to match geometrically
- if(NCHUNKS > 1 .and. abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) > 0.00000001d0) &
- stop 'ANGULAR_WIDTH_XI_IN_DEGREES must be 90 for more than one chunk'
-
-! this can be any value in the case of two chunks
- if(NCHUNKS > 2 .and. abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) > 0.00000001d0) &
- stop 'ANGULAR_WIDTH_ETA_IN_DEGREES must be 90 for more than two chunks'
-
-! include central cube or not
-! use regular cubed sphere instead of cube for large distances
- if(NCHUNKS == 6) then
- INCLUDE_CENTRAL_CUBE = .true.
- INFLATE_CENTRAL_CUBE = .false.
- else
- INCLUDE_CENTRAL_CUBE = .false.
- INFLATE_CENTRAL_CUBE = .true.
- endif
-
-! number of elements at the surface along the two sides of the first chunk
- call read_value_integer(NEX_XI_read, 'mesher.NEX_XI')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(NEX_ETA_read, 'mesher.NEX_ETA')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(NPROC_XI_read, 'mesher.NPROC_XI')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(NPROC_ETA_read, 'mesher.NPROC_ETA')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
- if(.not. EMULATE_ONLY) then
- NEX_XI = NEX_XI_read
- NEX_ETA = NEX_ETA_read
- NPROC_XI = NPROC_XI_read
- NPROC_ETA = NPROC_ETA_read
- else
-! this is used in UTILS/estimate_best_values_runs.f90 only, to estimate memory use
- NEX_ETA = NEX_XI
- NPROC_ETA = NPROC_XI
- endif
-
-! support for only one slice per chunk has been discontinued when there is more than one chunk
-! because it induces topological problems, and we are not interested in using small meshes
- if(NCHUNKS > 1 .and. (NPROC_XI == 1 .or. NPROC_ETA == 1)) stop 'support for only one slice per chunk has been discontinued'
-
-! define the velocity model
- call read_value_string(MODEL, 'model.name')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
-! use PREM as the 1D reference model by default
- REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
-
-! HONOR_1D_SPHERICAL_MOHO: honor PREM Moho or not: doing so drastically reduces
-! the stability condition and therefore the time step, resulting in expensive
-! calculations. If not, honor a fictitious Moho at the depth of 40 km
-! in order to have even radial sampling from the d220 to the Earth surface.
-
-! ONE_CRUST: in order to increase stability and therefore to allow cheaper
-! simulations (larger time step), 1D models can be run with just one average crustal
-! layer instead of two.
-
-! CASE_3D : this flag allows the stretching of the elements in the crustal
-! layers in the case of 3D models. The purpose of this stretching is to squeeze more
-! GLL points per km in the upper part of the crust than in the lower part.
- HONOR_1D_SPHERICAL_MOHO = .false.
- ONE_CRUST = .false.
- CASE_3D = .false.
-
-! default is no 3D model
- THREE_D_MODEL = 0
-
- if(MODEL == '1D_isotropic_prem') then
- TRANSVERSE_ISOTROPY = .false.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .false.
- ATTENUATION_3D = .false.
- HONOR_1D_SPHERICAL_MOHO = .true.
-
- else if(MODEL == '1D_transversely_isotropic_prem') then
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .false.
- ATTENUATION_3D = .false.
- HONOR_1D_SPHERICAL_MOHO = .true.
-
- else if(MODEL == '1D_iasp91' .or. MODEL == '1D_1066a' .or. &
- MODEL == '1D_ak135' .or. MODEL == '1D_jp3d' .or. &
- MODEL == '1D_sea99') then
- if(MODEL == '1D_iasp91') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
- else if(MODEL == '1D_1066a') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
- else if(MODEL == '1D_ak135') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
- else if(MODEL == '1D_jp3d') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
- else if(MODEL == '1D_sea99') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
- else
- stop 'reference 1D Earth model unknown'
- endif
- TRANSVERSE_ISOTROPY = .false.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .false.
- ATTENUATION_3D = .false.
- HONOR_1D_SPHERICAL_MOHO = .true.
-
- else if(MODEL == '1D_ref') then
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .false.
- ATTENUATION_3D = .false.
- HONOR_1D_SPHERICAL_MOHO = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
-
- else if(MODEL == '1D_ref_iso') then
- TRANSVERSE_ISOTROPY = .false.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .false.
- ATTENUATION_3D = .false.
- HONOR_1D_SPHERICAL_MOHO = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
-
- else if(MODEL == '1D_isotropic_prem_onecrust') then
- TRANSVERSE_ISOTROPY = .false.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .false.
- ATTENUATION_3D = .false.
- HONOR_1D_SPHERICAL_MOHO = .true.
- ONE_CRUST = .true.
-
- else if(MODEL == '1D_transversely_isotropic_prem_onecrust') then
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .false.
- ATTENUATION_3D = .false.
- HONOR_1D_SPHERICAL_MOHO = .true.
- ONE_CRUST = .true.
-
- else if(MODEL == '1D_iasp91_onecrust' .or. MODEL == '1D_1066a_onecrust' .or. MODEL == '1D_ak135_onecrust') then
- if(MODEL == '1D_iasp91_onecrust') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
- else if(MODEL == '1D_1066a_onecrust') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
- else if(MODEL == '1D_ak135_onecrust') then
- REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
- else
- stop 'reference 1D Earth model unknown'
- endif
- TRANSVERSE_ISOTROPY = .false.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .false.
- ATTENUATION_3D = .false.
- HONOR_1D_SPHERICAL_MOHO = .true.
- ONE_CRUST = .true.
-
- else if(MODEL == 'transversely_isotropic_prem_plus_3D_crust_2.0') then
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .true.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
-
- else if(MODEL == 's20rts') then
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .true.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
- THREE_D_MODEL = THREE_D_MODEL_S20RTS
-
- else if(MODEL == 'sea99_jp3d1994') then
- TRANSVERSE_ISOTROPY = .false.
- ISOTROPIC_3D_MANTLE = .true.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .true.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
- THREE_D_MODEL = THREE_D_MODEL_SEA99_JP3D
-
- else if(MODEL == 'sea99') then
- TRANSVERSE_ISOTROPY = .false.
- ISOTROPIC_3D_MANTLE = .true.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .true.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
- THREE_D_MODEL = THREE_D_MODEL_SEA99
-
-
- else if(MODEL == 'jp3d1994') then
- TRANSVERSE_ISOTROPY = .false.
- ISOTROPIC_3D_MANTLE = .true.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .true.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
- THREE_D_MODEL = THREE_D_MODEL_JP3D
-
- else if(MODEL == 's362ani') then
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .true.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
- THREE_D_MODEL = THREE_D_MODEL_S362ANI
-
- else if(MODEL == 's362iso') then
- TRANSVERSE_ISOTROPY = .false.
- ISOTROPIC_3D_MANTLE = .true.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .true.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
- THREE_D_MODEL = THREE_D_MODEL_S362ANI
-
- else if(MODEL == 's362wmani') then
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .true.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
- THREE_D_MODEL = THREE_D_MODEL_S362WMANI
-
- else if(MODEL == 's362ani_prem') then
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .true.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
- THREE_D_MODEL = THREE_D_MODEL_S362ANI_PREM
-
- else if(MODEL == 's29ea') then
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .true.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .true.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
- REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
- THREE_D_MODEL = THREE_D_MODEL_S29EA
-
- else if(MODEL == '3D_attenuation') then
- TRANSVERSE_ISOTROPY = .false.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .false.
- ATTENUATION_3D = .true.
- ONE_CRUST = .true.
- CASE_3D = .true.
-
- else if(MODEL == '3D_anisotropic') then
- TRANSVERSE_ISOTROPY = .true.
- ISOTROPIC_3D_MANTLE = .false.
- ANISOTROPIC_3D_MANTLE = .true.
- ANISOTROPIC_INNER_CORE = .false.
- CRUSTAL = .false.
- ATTENUATION_3D = .false.
- ONE_CRUST = .true.
- CASE_3D = .true.
-
- else
- stop 'model not implemented, edit read_compute_parameters.f90 and recompile'
- endif
-
-! set time step, radial distribution of elements, and attenuation period range
-! right distribution is determined based upon maximum value of NEX
- NEX_MAX = max(NEX_XI,NEX_ETA)
-
-!----
-!---- case prem_onecrust by default
-!----
- if (SUPPRESS_CRUSTAL_MESH) then
- multiplication_factor=2
- else
- multiplication_factor=1
- endif
-
- ! element width = 0.5625000 degrees = 62.54715 km
- if(NEX_MAX*multiplication_factor <= 160) then
- DT = 0.252d0
-
- MIN_ATTENUATION_PERIOD = 30
- MAX_ATTENUATION_PERIOD = 1500
-
- NER_CRUST = 1
- NER_80_MOHO = 1
- NER_220_80 = 2
- NER_400_220 = 2
- NER_600_400 = 2
- NER_670_600 = 1
- NER_771_670 = 1
- NER_TOPDDOUBLEPRIME_771 = 15
- NER_CMB_TOPDDOUBLEPRIME = 1
- NER_OUTER_CORE = 16
- NER_TOP_CENTRAL_CUBE_ICB = 2
- R_CENTRAL_CUBE = 950000.d0
-
- ! element width = 0.3515625 degrees = 39.09196 km
- else if(NEX_MAX*multiplication_factor <= 256) then
- DT = 0.225d0
-
- MIN_ATTENUATION_PERIOD = 20
- MAX_ATTENUATION_PERIOD = 1000
-
- NER_CRUST = 1
- NER_80_MOHO = 1
- NER_220_80 = 2
- NER_400_220 = 3
- NER_600_400 = 3
- NER_670_600 = 1
- NER_771_670 = 1
- NER_TOPDDOUBLEPRIME_771 = 22
- NER_CMB_TOPDDOUBLEPRIME = 2
- NER_OUTER_CORE = 24
- NER_TOP_CENTRAL_CUBE_ICB = 3
- R_CENTRAL_CUBE = 965000.d0
-
- ! element width = 0.2812500 degrees = 31.27357 km
- else if(NEX_MAX*multiplication_factor <= 320) then
- DT = 0.16d0
-
- MIN_ATTENUATION_PERIOD = 15
- MAX_ATTENUATION_PERIOD = 750
-
- NER_CRUST = 1
- NER_80_MOHO = 1
- NER_220_80 = 3
- NER_400_220 = 4
- NER_600_400 = 4
- NER_670_600 = 1
- NER_771_670 = 2
- NER_TOPDDOUBLEPRIME_771 = 29
- NER_CMB_TOPDDOUBLEPRIME = 2
- NER_OUTER_CORE = 32
- NER_TOP_CENTRAL_CUBE_ICB = 4
- R_CENTRAL_CUBE = 940000.d0
-
- ! element width = 0.1875000 degrees = 20.84905 km
- else if(NEX_MAX*multiplication_factor <= 480) then
- DT = 0.11d0
-
- MIN_ATTENUATION_PERIOD = 10
- MAX_ATTENUATION_PERIOD = 500
-
- NER_CRUST = 1
- NER_80_MOHO = 2
- NER_220_80 = 4
- NER_400_220 = 5
- NER_600_400 = 6
- NER_670_600 = 2
- NER_771_670 = 2
- NER_TOPDDOUBLEPRIME_771 = 44
- NER_CMB_TOPDDOUBLEPRIME = 3
- NER_OUTER_CORE = 48
- NER_TOP_CENTRAL_CUBE_ICB = 5
- R_CENTRAL_CUBE = 988000.d0
-
- ! element width = 0.1757812 degrees = 19.54598 km
- else if(NEX_MAX*multiplication_factor <= 512) then
- DT = 0.1125d0
-
- MIN_ATTENUATION_PERIOD = 9
- MAX_ATTENUATION_PERIOD = 500
-
- NER_CRUST = 1
- NER_80_MOHO = 2
- NER_220_80 = 4
- NER_400_220 = 6
- NER_600_400 = 6
- NER_670_600 = 2
- NER_771_670 = 3
- NER_TOPDDOUBLEPRIME_771 = 47
- NER_CMB_TOPDDOUBLEPRIME = 3
- NER_OUTER_CORE = 51
- NER_TOP_CENTRAL_CUBE_ICB = 5
- R_CENTRAL_CUBE = 1010000.d0
-
- ! element width = 0.1406250 degrees = 15.63679 km
- else if(NEX_MAX*multiplication_factor <= 640) then
- DT = 0.09d0
-
- MIN_ATTENUATION_PERIOD = 8
- MAX_ATTENUATION_PERIOD = 400
-
- NER_CRUST = 2
- NER_80_MOHO = 3
- NER_220_80 = 5
- NER_400_220 = 7
- NER_600_400 = 8
- NER_670_600 = 3
- NER_771_670 = 3
- NER_TOPDDOUBLEPRIME_771 = 59
- NER_CMB_TOPDDOUBLEPRIME = 4
- NER_OUTER_CORE = 64
- NER_TOP_CENTRAL_CUBE_ICB = 6
- R_CENTRAL_CUBE = 1020000.d0
-
- ! element width = 0.1041667 degrees = 11.58280 km
- else if(NEX_MAX*multiplication_factor <= 864) then
- DT = 0.0667d0
-
- MIN_ATTENUATION_PERIOD = 6
- MAX_ATTENUATION_PERIOD = 300
-
- NER_CRUST = 2
- NER_80_MOHO = 4
- NER_220_80 = 6
- NER_400_220 = 10
- NER_600_400 = 10
- NER_670_600 = 3
- NER_771_670 = 4
- NER_TOPDDOUBLEPRIME_771 = 79
- NER_CMB_TOPDDOUBLEPRIME = 5
- NER_OUTER_CORE = 86
- NER_TOP_CENTRAL_CUBE_ICB = 9
- R_CENTRAL_CUBE = 990000.d0
-
- ! element width = 7.8125000E-02 degrees = 8.687103 km
- else if(NEX_MAX*multiplication_factor <= 1152) then
- DT = 0.05d0
-
- MIN_ATTENUATION_PERIOD = 4
- MAX_ATTENUATION_PERIOD = 200
-
- NER_CRUST = 3
- NER_80_MOHO = 6
- NER_220_80 = 8
- NER_400_220 = 13
- NER_600_400 = 13
- NER_670_600 = 4
- NER_771_670 = 6
- NER_TOPDDOUBLEPRIME_771 = 106
- NER_CMB_TOPDDOUBLEPRIME = 7
- NER_OUTER_CORE = 116
- NER_TOP_CENTRAL_CUBE_ICB = 12
- R_CENTRAL_CUBE = 985000.d0
-
- ! element width = 7.2115384E-02 degrees = 8.018865 km
- else if(NEX_MAX*multiplication_factor <= 1248) then
- DT = 0.0462d0
-
- MIN_ATTENUATION_PERIOD = 4
- MAX_ATTENUATION_PERIOD = 200
-
- NER_CRUST = 3
- NER_80_MOHO = 6
- NER_220_80 = 9
- NER_400_220 = 14
- NER_600_400 = 14
- NER_670_600 = 5
- NER_771_670 = 6
- NER_TOPDDOUBLEPRIME_771 = 114
- NER_CMB_TOPDDOUBLEPRIME = 8
- NER_OUTER_CORE = 124
- NER_TOP_CENTRAL_CUBE_ICB = 13
- R_CENTRAL_CUBE = 985000.d0
-
- else
-
-! scale with respect to 1248 if above that limit
- DT = 0.0462d0 * 1248.d0 / (2.d0*NEX_MAX)
-
- MIN_ATTENUATION_PERIOD = 4
- MAX_ATTENUATION_PERIOD = 200
-
- NER_CRUST = nint(3 * 2.d0*NEX_MAX / 1248.d0)
- NER_80_MOHO = nint(6 * 2.d0*NEX_MAX / 1248.d0)
- NER_220_80 = nint(9 * 2.d0*NEX_MAX / 1248.d0)
- NER_400_220 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
- NER_600_400 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
- NER_670_600 = nint(5 * 2.d0*NEX_MAX / 1248.d0)
- NER_771_670 = nint(6 * 2.d0*NEX_MAX / 1248.d0)
- NER_TOPDDOUBLEPRIME_771 = nint(114 * 2.d0*NEX_MAX / 1248.d0)
- NER_CMB_TOPDDOUBLEPRIME = nint(8 * 2.d0*NEX_MAX / 1248.d0)
- NER_OUTER_CORE = nint(124 * 2.d0*NEX_MAX / 1248.d0)
- NER_TOP_CENTRAL_CUBE_ICB = nint(13 * 2.d0*NEX_MAX / 1248.d0)
- R_CENTRAL_CUBE = 985000.d0
-
-!! removed this limit else
-!! removed this limit stop 'problem with this value of NEX_MAX'
- endif
-
-!----
-!---- change some values in the case of regular PREM with two crustal layers or of 3D models
-!----
-
-! case of regular PREM with two crustal layers: change the time step for small meshes
-! because of a different size of elements in the radial direction in the crust
- if (HONOR_1D_SPHERICAL_MOHO) then
- if (.not. ONE_CRUST) then
- ! case 1D + two crustal layers
- if (NER_CRUST<2) NER_CRUST=2
- if(NEX_MAX*multiplication_factor <= 160) then
- DT = 0.20d0
- else if(NEX_MAX*multiplication_factor <= 256) then
- DT = 0.20d0
- endif
- endif
- else
- ! case 3D
- if (NER_CRUST<2) NER_CRUST=2
- if(NEX_MAX*multiplication_factor <= 160) then
- DT = 0.15d0
- else if(NEX_MAX*multiplication_factor <= 256) then
- DT = 0.17d0
- else if(NEX_MAX*multiplication_factor <= 320) then
- DT = 0.155d0
- endif
- endif
-
- if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
- DT = DT*0.20d0
- endif
-
-
- if( .not. ATTENUATION_RANGE_PREDEFINED ) then
- call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
- MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
- endif
-
- if(ANGULAR_WIDTH_XI_IN_DEGREES < 90.0d0 .or. &
- ANGULAR_WIDTH_ETA_IN_DEGREES < 90.0d0 .or. &
- NEX_MAX > 1248) then
-
- call auto_ner(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
- NER_CRUST, NER_80_MOHO, NER_220_80, NER_400_220, NER_600_400, &
- NER_670_600, NER_771_670, NER_TOPDDOUBLEPRIME_771, &
- NER_CMB_TOPDDOUBLEPRIME, NER_OUTER_CORE, NER_TOP_CENTRAL_CUBE_ICB, &
- R_CENTRAL_CUBE, CASE_3D)
-
- call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
- MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
-
- call auto_time_stepping(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, DT)
-
- if (HONOR_1D_SPHERICAL_MOHO) then
- if (.not. ONE_CRUST) then
- ! case 1D + two crustal layers
- if (NER_CRUST<2) NER_CRUST=2
- endif
- else
- ! case 3D
- if (NER_CRUST<2) NER_CRUST=2
- endif
- endif
-
-! take a 5% safety margin on the maximum stable time step
-! which was obtained by trial and error
-!!!!!!!!!!!!!!!!!! DT = DT * (1.d0 - 0.05d0)
-
- call read_value_logical(OCEANS, 'model.OCEANS')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(ELLIPTICITY, 'model.ELLIPTICITY')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(TOPOGRAPHY, 'model.TOPOGRAPHY')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(GRAVITY, 'model.GRAVITY')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(ROTATION, 'model.ROTATION')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(ATTENUATION, 'model.ATTENUATION')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
- call read_value_logical(ABSORBING_CONDITIONS, 'solver.ABSORBING_CONDITIONS')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
- if(ABSORBING_CONDITIONS .and. NCHUNKS == 6) stop 'cannot have absorbing conditions in the full Earth'
-
- if(ABSORBING_CONDITIONS .and. NCHUNKS == 3) stop 'absorbing conditions not supported for three chunks yet'
-
- if(ATTENUATION_3D .and. .not. ATTENUATION) stop 'need ATTENUATION to use ATTENUATION_3D'
-
- if(GRAVITY) stop 'GRAVITY not implemented in the reduced merged version yet because useless at high frequency'
-
- if(ROTATION) stop 'ROTATION not implemented in the reduced merged version yet because useless at high frequency'
-
- if(ABSORBING_CONDITIONS) stop 'ABSORBING_CONDITIONS not implemented in the reduced merged version yet'
-
-! radii in PREM or IASP91
-! and normalized density at fluid-solid interface on fluid size for coupling
-! ROCEAN: radius of the ocean (m)
-! RMIDDLE_CRUST: radius of the middle crust (m)
-! RMOHO: radius of the Moho (m)
-! R80: radius of 80 km discontinuity (m)
-! R120: radius of 120 km discontinuity (m) in IASP91
-! R220: radius of 220 km discontinuity (m)
-! R400: radius of 400 km discontinuity (m)
-! R600: radius of 600 km 2nd order discontinuity (m)
-! R670: radius of 670 km discontinuity (m)
-! R771: radius of 771 km 2nd order discontinuity (m)
-! RTOPDDOUBLEPRIME: radius of top of D" 2nd order discontinuity (m)
-! RCMB: radius of CMB (m)
-! RICB: radius of ICB (m)
-
-! by default there is no d120 discontinuity, except in IASP91, therefore set to fictitious value
- R120 = -1.d0
-
-! value common to all models
- RHO_OCEANS = 1020.0 / RHOAV
-
- if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
-
-! IASP91
- ROCEAN = 6371000.d0
- RMIDDLE_CRUST = 6351000.d0
- RMOHO = 6336000.d0
- R80 = 6291000.d0
- R120 = 6251000.d0
- R220 = 6161000.d0
- R400 = 5961000.d0
-! there is no d600 discontinuity in IASP91 therefore this value is useless
-! but it needs to be there for compatibility with other subroutines
- R600 = R_EARTH - 600000.d0
- R670 = 5711000.d0
- R771 = 5611000.d0
- RTOPDDOUBLEPRIME = 3631000.d0
- RCMB = 3482000.d0
- RICB = 1217000.d0
-
- RHO_TOP_OC = 9900.2379 / RHOAV
- RHO_BOTTOM_OC = 12168.6383 / RHOAV
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
-
-! our implementation of AK135 has not been checked carefully yet
-! therefore let us doublecheck it carefully one day
-
-! values below corrected by Ying Zhou <yingz at gps.caltech.edu>
-
-! AK135 without the 300 meters of mud layer
- ROCEAN = 6368000.d0
- RMIDDLE_CRUST = 6361000.d0
- RMOHO = 6353000.d0
- R80 = 6291000.d0
- R220 = 6161000.d0
- R400 = 5961000.d0
- R670 = 5711000.d0
- RTOPDDOUBLEPRIME = 3631000.d0
- RCMB = 3479500.d0
- RICB = 1217500.d0
-
-! values for AK135 that are not discontinuities
- R600 = 5771000.d0
- R771 = 5611000.d0
-
- RHO_TOP_OC = 9914.5000 / RHOAV
- RHO_BOTTOM_OC = 12139.1000 / RHOAV
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
-
-! values below corrected by Ying Zhou <yingz at gps.caltech.edu>
-
-! 1066A
- RMOHO = 6360000.d0
- R400 = 5950000.d0
- R600 = 5781000.d0
- R670 = 5700000.d0
- RCMB = 3484300.d0
- RICB = 1229480.d0
-
-! values for 1066A that are not discontinuities
- RTOPDDOUBLEPRIME = 3631000.d0
- R220 = 6161000.d0
- R771 = 5611000.d0
-! RMIDDLE_CRUST used only for high resolution FFSW1C model, with 3 elements crust simulations
-! mid_crust = 10 km
- RMIDDLE_CRUST = 6361000.d0
- R80 = 6291000.d0
-
-! model 1066A has no oceans, therefore we use the radius of the Earth instead
- ROCEAN = R_EARTH
-
- RHO_TOP_OC = 9917.4500 / RHOAV
- RHO_BOTTOM_OC = 12160.6500 / RHOAV
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
-
-! REF
- ROCEAN = 6368000.d0
- RMIDDLE_CRUST = 6356000.d0
- RMOHO = 6346600.d0
- R80 = 6291000.d0
- R220 = 6151000.d0
- R400 = 5961000.d0
- R600 = 5771000.d0
- R670 = 5721000.d0
- R771 = 5600000.d0
- RTOPDDOUBLEPRIME = 3630000.d0
- RCMB = 3479958.d0
- RICB = 1221491.d0
-
- RHO_TOP_OC = 9903.48 / RHOAV
- RHO_BOTTOM_OC = 12166.35 / RHOAV
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
-
-! values below corrected by Min Chen <mchen at gps.caltech.edu>
-
-! jp1d
- ROCEAN = 6371000.d0
- RMIDDLE_CRUST = 6359000.d0
- RMOHO = 6345000.d0
- R80 = 6291000.d0
- R220 = 6161000.d0
- R400 = 5949000.d0
- R600 = 5781000.d0
- R670 = 5711000.d0
- R771 = 5611000.d0
- RTOPDDOUBLEPRIME = 3631000.d0
- RCMB = 3482000.d0
- RICB = 1217000.d0
- RHO_TOP_OC = 9900.2379 / RHOAV
- RHO_BOTTOM_OC = 12168.6383 / RHOAV
-
- else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
-
-! SEA1D without the 2 km of mud layer or the 3km water layer
- ROCEAN = 6371000.d0
- RMIDDLE_CRUST = 6361000.d0
- RMOHO = 6346000.d0
- R80 = 6291000.d0
- R220 = 6161000.d0
- R400 = 5961000.d0
- R670 = 5711000.d0
- RTOPDDOUBLEPRIME = 3631000.d0
- RCMB = 3485700.d0
- RICB = 1217100.d0
-
-! values for SEA1D that are not discontinuities
- R600 = 5771000.d0
- R771 = 5611000.d0
-
- RHO_TOP_OC = 9903.4384 / RHOAV
- RHO_BOTTOM_OC = 12166.5885 / RHOAV
-
- else
-
-! PREM
- ROCEAN = 6368000.d0
- RMIDDLE_CRUST = 6356000.d0
- RMOHO = 6346600.d0
- R80 = 6291000.d0
- R220 = 6151000.d0
- R400 = 5971000.d0
- R600 = 5771000.d0
- R670 = 5701000.d0
- R771 = 5600000.d0
- RTOPDDOUBLEPRIME = 3630000.d0
- RCMB = 3480000.d0
- RICB = 1221000.d0
-
- RHO_TOP_OC = 9903.4384 / RHOAV
- RHO_BOTTOM_OC = 12166.5885 / RHOAV
-
- endif
-
-! honor the PREM Moho or define a fictitious Moho in order to have even radial sampling
-! from the d220 to the Earth surface
- if(HONOR_1D_SPHERICAL_MOHO) then
- RMOHO_FICTITIOUS_IN_MESHER = RMOHO
- else
- RMOHO_FICTITIOUS_IN_MESHER = (R80 + R_EARTH) / 2
- endif
-
- call read_value_double_precision(RECORD_LENGTH_IN_MINUTES, 'solver.RECORD_LENGTH_IN_MINUTES')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
-! 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)
-
- call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(MOVIE_COARSE,'solver.MOVIE_COARSE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(NTSTEP_BETWEEN_FRAMES, 'solver.NTSTEP_BETWEEN_FRAMES')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(HDUR_MOVIE, 'solver.HDUR_MOVIE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
-! computes a default hdur_movie that creates nice looking movies.
-! Sets HDUR_MOVIE as the minimum period the mesh can resolve
- if(HDUR_MOVIE <= TINYVAL) &
- HDUR_MOVIE = 1.2d0*max(240.d0/NEX_XI*18.d0*ANGULAR_WIDTH_XI_IN_DEGREES/90.d0, &
- 240.d0/NEX_ETA*18.d0*ANGULAR_WIDTH_ETA_IN_DEGREES/90.d0)
-
- call read_value_integer(MOVIE_VOLUME_TYPE, 'solver.MOVIE_VOLUME_TYPE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(MOVIE_TOP_KM, 'solver.MOVIE_TOP_KM')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(MOVIE_BOTTOM_KM, 'solver.MOVIE_BOTTOM_KM')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(MOVIE_WEST_DEG, 'solver.MOVIE_WEST_DEG')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(MOVIE_EAST_DEG, 'solver.MOVIE_EAST_DEG')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(MOVIE_NORTH_DEG, 'solver.MOVIE_NORTH_DEG')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_double_precision(MOVIE_SOUTH_DEG, 'solver.MOVIE_SOUTH_DEG')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(MOVIE_START, 'solver.MOVIE_START')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(MOVIE_STOP, 'solver.MOVIE_STOP')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- MOVIE_TOP = (R_EARTH_KM-MOVIE_TOP_KM)/R_EARTH_KM
- MOVIE_BOTTOM = (R_EARTH_KM-MOVIE_BOTTOM_KM)/R_EARTH_KM
- MOVIE_EAST = MOVIE_EAST_DEG * DEGREES_TO_RADIANS
- MOVIE_WEST = MOVIE_WEST_DEG * DEGREES_TO_RADIANS
- MOVIE_NORTH = (90.0d0 - MOVIE_NORTH_DEG) * DEGREES_TO_RADIANS ! converting from latitude to colatitude
- MOVIE_SOUTH = (90.0d0 - MOVIE_SOUTH_DEG) * DEGREES_TO_RADIANS
-
- call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(NUMBER_OF_RUNS, 'solver.NUMBER_OF_RUNS')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(NUMBER_OF_THIS_RUN, 'solver.NUMBER_OF_THIS_RUN')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(NTSTEP_BETWEEN_OUTPUT_INFO, 'solver.NTSTEP_BETWEEN_OUTPUT_INFO')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(NTSTEP_BETWEEN_OUTPUT_SEISMOS, 'solver.NTSTEP_BETWEEN_OUTPUT_SEISMOS')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_integer(NTSTEP_BETWEEN_READ_ADJSRC, 'solver.NTSTEP_BETWEEN_READ_ADJSRC')
- if(err_occurred() /= 0) return
-
- call read_value_logical(OUTPUT_SEISMOS_ASCII_TEXT, 'solver.OUTPUT_SEISMOS_ASCII_TEXT')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(OUTPUT_SEISMOS_SAC_ALPHANUM, 'solver.OUTPUT_SEISMOS_SAC_ALPHANUM')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(OUTPUT_SEISMOS_SAC_BINARY, 'solver.OUTPUT_SEISMOS_SAC_BINARY')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(ROTATE_SEISMOGRAMS_RT, 'solver.ROTATE_SEISMOGRAMS_RT')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(WRITE_SEISMOGRAMS_BY_MASTER, 'solver.WRITE_SEISMOGRAMS_BY_MASTER')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(SAVE_ALL_SEISMOS_IN_ONE_FILE, 'solver.SAVE_ALL_SEISMOS_IN_ONE_FILE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(USE_BINARY_FOR_LARGE_FILE, 'solver.USE_BINARY_FOR_LARGE_FILE')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
- call read_value_logical(RECEIVERS_CAN_BE_BURIED, 'solver.RECEIVERS_CAN_BE_BURIED')
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
- call read_value_logical(PRINT_SOURCE_TIME_FUNCTION, 'solver.PRINT_SOURCE_TIME_FUNCTION')
-
- if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
-
-! close parameter file
- call close_parameter_file
-!--- check that parameters make sense
-
- if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
- stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5, check the Par_file'
-
-! subsets used to save seismograms must not be larger than the whole time series,
-! otherwise we waste memory
- if(NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP) then
- NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP
- if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
- stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then modified NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5'
- endif
-
-! check that reals are either 4 or 8 bytes
- if(CUSTOM_REAL /= SIZE_REAL .and. CUSTOM_REAL /= SIZE_DOUBLE) stop 'wrong size of CUSTOM_REAL for reals'
-
-! check that the parameter file is correct
- if(NGNOD /= 27) stop 'number of control nodes must be 27'
- if(NGNOD == 27 .and. NGNOD2D /= 9) stop 'elements with 27 points should have NGNOD2D = 9'
-
-! for the number of standard linear solids for attenuation
- if(N_SLS /= 3) stop 'number of SLS must be 3'
-
-! check number of slices in each direction
- if(NCHUNKS < 1) stop 'must have at least one chunk'
- if(NPROC_XI < 1) stop 'NPROC_XI must be at least 1'
- if(NPROC_ETA < 1) stop 'NPROC_ETA must be at least 1'
-
-! check number of chunks
- if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
- stop 'only one, two, three or six chunks can be meshed'
-
-! check that the central cube can be included
- if(INCLUDE_CENTRAL_CUBE .and. NCHUNKS /= 6) stop 'need six chunks to include central cube'
-
-! check that sphere can be cut into slices without getting negative Jacobian
- if(NEX_XI < 48) stop 'NEX_XI must be greater than 48 to cut the sphere into slices with positive Jacobian'
- if(NEX_ETA < 48) stop 'NEX_ETA must be greater than 48 to cut the sphere into slices with positive Jacobian'
-
-! check that mesh can be coarsened in depth three or four times
- CUT_SUPERBRICK_XI=.false.
- CUT_SUPERBRICK_ETA=.false.
-
- if (SUPPRESS_CRUSTAL_MESH .and. .not. ADD_4TH_DOUBLING) then
- if(mod(NEX_XI,8) /= 0) stop 'NEX_XI must be a multiple of 8'
- if(mod(NEX_ETA,8) /= 0) stop 'NEX_ETA must be a multiple of 8'
- if(mod(NEX_XI/4,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 4*NPROC_XI'
- if(mod(NEX_ETA/4,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 4*NPROC_ETA'
- if(mod(NEX_XI/8,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
- if(mod(NEX_ETA/8,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
- elseif (SUPPRESS_CRUSTAL_MESH .or. .not. ADD_4TH_DOUBLING) then
- if(mod(NEX_XI,16) /= 0) stop 'NEX_XI must be a multiple of 16'
- if(mod(NEX_ETA,16) /= 0) stop 'NEX_ETA must be a multiple of 16'
- if(mod(NEX_XI/8,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 8*NPROC_XI'
- if(mod(NEX_ETA/8,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 8*NPROC_ETA'
- if(mod(NEX_XI/16,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
- if(mod(NEX_ETA/16,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
-!! DK DK added this because of temporary bug in David's code
- if(mod(NEX_XI/16,NPROC_XI) /=0) &
- stop 'NEX_XI multiple of 8*NPROC_XI but not of 16*NPROC_XI is currently unsafe'
- if(mod(NEX_ETA/16,NPROC_ETA) /=0) &
- stop 'NEX_ETA multiple of 8*NPROC_ETA but not of 16*NPROC_ETA is currently unsafe'
-!! DK DK added this because of temporary bug in David's code
- else
- if(mod(NEX_XI,32) /= 0) stop 'NEX_XI must be a multiple of 32'
- if(mod(NEX_ETA,32) /= 0) stop 'NEX_ETA must be a multiple of 32'
- if(mod(NEX_XI/16,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 16*NPROC_XI'
- if(mod(NEX_ETA/16,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 16*NPROC_ETA'
- if(mod(NEX_XI/32,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
- if(mod(NEX_ETA/32,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
- endif
-
-! check that topology is correct if more than two chunks
- if(NCHUNKS > 2 .and. NEX_XI /= NEX_ETA) stop 'must have NEX_XI = NEX_ETA for more than two chunks'
- if(NCHUNKS > 2 .and. NPROC_XI /= NPROC_ETA) stop 'must have NPROC_XI = NPROC_ETA for more than two chunks'
-
-! check that option to run one slice only per chunk has been activated
-! (it is deactivated by default because MPI buffers use more memory when it is on)
- if((NPROC_XI == 1 .or. NPROC_ETA == 1) .and. (NUMFACES_SHARED /= 4 .or. NUMCORNERS_SHARED /= 4)) &
- stop 'option to run one slice only per chunk is deactivated, edit constants.h and recompile'
-
-! check that IASP91, AK135, 1066A, JP1D or SEA1D is isotropic
- if((REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91 .or. &
- REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135 .or. &
- REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A .or. &
- REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D .or. &
- REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) .and. TRANSVERSE_ISOTROPY) &
- stop 'models IASP91, AK135, 1066A, JP1D and SEA1D are currently isotropic'
-
- ELEMENT_WIDTH = ANGULAR_WIDTH_XI_IN_DEGREES/dble(NEX_MAX) * DEGREES_TO_RADIANS
-
-!
-!--- compute additional parameters
-!
-
-! number of elements horizontally in each slice (i.e. per processor)
-! these two values MUST be equal in all cases
- NEX_PER_PROC_XI = NEX_XI / NPROC_XI
- NEX_PER_PROC_ETA = NEX_ETA / NPROC_ETA
-
-! total number of processors in each of the six chunks
- NPROC = NPROC_XI * NPROC_ETA
-
-! total number of processors in the full Earth composed of the six chunks
- NPROCTOT = NCHUNKS * NPROC
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! definition of general mesh parameters below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! find element below top of which we should implement the second doubling in the mantle
-! locate element closest to optimal value
- distance_min = HUGEVAL
- do ielem = 2,NER_TOPDDOUBLEPRIME_771
- zval = RTOPDDOUBLEPRIME + ielem * (R771 - RTOPDDOUBLEPRIME) / dble(NER_TOPDDOUBLEPRIME_771)
- distance = abs(zval - (R_EARTH - DEPTH_SECOND_DOUBLING_OPTIMAL))
- if(distance < distance_min) then
- elem_doubling_mantle = ielem
- distance_min = distance
- DEPTH_SECOND_DOUBLING_REAL = R_EARTH - zval
- endif
- enddo
-
-! find element below top of which we should implement the third doubling in the middle of the outer core
-! locate element closest to optimal value
- distance_min = HUGEVAL
-! start at element number 4 because we need at least two elements below for the fourth doubling
-! implemented at the bottom of the outer core
- do ielem = 4,NER_OUTER_CORE
- zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
- distance = abs(zval - (R_EARTH - DEPTH_THIRD_DOUBLING_OPTIMAL))
- if(distance < distance_min) then
- elem_doubling_middle_outer_core = ielem
- distance_min = distance
- DEPTH_THIRD_DOUBLING_REAL = R_EARTH - zval
- endif
- enddo
-
- if (ADD_4TH_DOUBLING) then
-! find element below top of which we should implement the fourth doubling in the middle of the outer core
-! locate element closest to optimal value
- distance_min = HUGEVAL
-! end two elements before the top because we need at least two elements above for the third doubling
-! implemented in the middle of the outer core
- do ielem = 2,NER_OUTER_CORE-2
- zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
- distance = abs(zval - (R_EARTH - DEPTH_FOURTH_DOUBLING_OPTIMAL))
- if(distance < distance_min) then
- elem_doubling_bottom_outer_core = ielem
- distance_min = distance
- DEPTH_FOURTH_DOUBLING_REAL = R_EARTH - zval
- endif
- enddo
-! make sure that the two doublings in the outer core are found in the right order
- if(elem_doubling_bottom_outer_core >= elem_doubling_middle_outer_core) &
- stop 'error in location of the two doublings in the outer core'
- endif
-
- ratio_sampling_array(15) = 0
-
-! define all the layers of the mesh
- if (.not. ADD_4TH_DOUBLING) then
-
- if (SUPPRESS_CRUSTAL_MESH) then
-
- ONE_CRUST = .false.
- OCEANS= .false.
- TOPOGRAPHY = .false.
- CRUSTAL = .false.
-
- NUMBER_OF_MESH_LAYERS = 14
- layer_offset = 1
-
- ! now only one region
- ner( 1) = NER_CRUST + NER_80_MOHO
- ner( 2) = 0
- ner( 3) = 0
-
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core
- ner(14) = NER_TOP_CENTRAL_CUBE_ICB
-
-! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
- ifirst_layer_aniso = 1
- ilast_layer_aniso = 4
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:9) = 1
- ratio_sampling_array(10:12) = 2
- ratio_sampling_array(13:14) = 4
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(14) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_layer_has_a_doubling(:) = .false.
- this_layer_has_a_doubling(10) = .true.
- this_layer_has_a_doubling(13) = .true.
- lastdoubling_layer = 13
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = R80
-
- r_top(2) = RMIDDLE_CRUST !!!! now fictitious
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
- r_bottom(3) = R80 !!!! now fictitious
-
- r_top(4) = R80
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = RICB
-
- r_top(14) = RICB
- r_bottom(14) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = R80 / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
- rmins(3) = R80 / R_EARTH !!!! now fictitious
-
- rmaxs(4) = R80 / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:13) = RCMB / R_EARTH
- rmins(12:13) = RICB / R_EARTH
-
- rmaxs(14) = RICB / R_EARTH
- rmins(14) = R_CENTRAL_CUBE / R_EARTH
-
- elseif (ONE_CRUST) then
-
- NUMBER_OF_MESH_LAYERS = 13
- layer_offset = 0
-
- ner( 1) = NER_CRUST
- ner( 2) = NER_80_MOHO
- ner( 3) = NER_220_80
- ner( 4) = NER_400_220
- ner( 5) = NER_600_400
- ner( 6) = NER_670_600
- ner( 7) = NER_771_670
- ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner( 9) = elem_doubling_mantle
- ner(10) = NER_CMB_TOPDDOUBLEPRIME
- ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(12) = elem_doubling_middle_outer_core
- ner(13) = NER_TOP_CENTRAL_CUBE_ICB
-
-! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
- ifirst_layer_aniso = 2
- ilast_layer_aniso = 3
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1) = 1
- ratio_sampling_array(2:8) = 2
- ratio_sampling_array(9:11) = 4
- ratio_sampling_array(12:13) = 8
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1) = IFLAG_CRUST
- doubling_index(2) = IFLAG_80_MOHO
- doubling_index(3) = IFLAG_220_80
- doubling_index(4:6) = IFLAG_670_220
- doubling_index(7:10) = IFLAG_MANTLE_NORMAL
- doubling_index(11:12) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(13) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_layer_has_a_doubling(:) = .false.
- this_layer_has_a_doubling(2) = .true.
- this_layer_has_a_doubling(9) = .true.
- this_layer_has_a_doubling(12) = .true.
- lastdoubling_layer = 12
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
- !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
- !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
- !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
- !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
- !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(2) = R80
-
- r_top(3) = R80
- r_bottom(3) = R220
-
- r_top(4) = R220
- r_bottom(4) = R400
-
- r_top(5) = R400
- r_bottom(5) = R600
-
- r_top(6) = R600
- r_bottom(6) = R670
-
- r_top(7) = R670
- r_bottom(7) = R771
-
- r_top(8) = R771
- r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(9) = RTOPDDOUBLEPRIME
-
- r_top(10) = RTOPDDOUBLEPRIME
- r_bottom(10) = RCMB
-
- r_top(11) = RCMB
- r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(12) = RICB
-
- r_top(13) = RICB
- r_bottom(13) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(2) = R80 / R_EARTH
-
- rmaxs(3) = R80 / R_EARTH
- rmins(3) = R220 / R_EARTH
-
- rmaxs(4) = R220 / R_EARTH
- rmins(4) = R400 / R_EARTH
-
- rmaxs(5) = R400 / R_EARTH
- rmins(5) = R600 / R_EARTH
-
- rmaxs(6) = R600 / R_EARTH
- rmins(6) = R670 / R_EARTH
-
- rmaxs(7) = R670 / R_EARTH
- rmins(7) = R771 / R_EARTH
-
- rmaxs(8:9) = R771 / R_EARTH
- rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(10) = RCMB / R_EARTH
-
- rmaxs(11:12) = RCMB / R_EARTH
- rmins(11:12) = RICB / R_EARTH
-
- rmaxs(13) = RICB / R_EARTH
- rmins(13) = R_CENTRAL_CUBE / R_EARTH
-
- else
-
- NUMBER_OF_MESH_LAYERS = 14
- layer_offset = 1
- if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
- ner( 1) = ceiling (NER_CRUST / 2.d0)
- ner( 2) = floor (NER_CRUST / 2.d0)
- else
- ner( 1) = floor (NER_CRUST / 2.d0)
- ner( 2) = ceiling (NER_CRUST / 2.d0)
- endif
- ner( 3) = NER_80_MOHO
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core
- ner(14) = NER_TOP_CENTRAL_CUBE_ICB
-
-! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
- ifirst_layer_aniso = 3
- ilast_layer_aniso = 4
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:2) = 1
- ratio_sampling_array(3:9) = 2
- ratio_sampling_array(10:12) = 4
- ratio_sampling_array(13:14) = 8
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:2) = IFLAG_CRUST
- doubling_index(3) = IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(14) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_layer_has_a_doubling(:) = .false.
- this_layer_has_a_doubling(3) = .true.
- this_layer_has_a_doubling(10) = .true.
- this_layer_has_a_doubling(13) = .true.
- this_layer_has_a_doubling(14) = .false.
- lastdoubling_layer = 13
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMIDDLE_CRUST
-
- r_top(2) = RMIDDLE_CRUST
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(3) = R80
-
- r_top(4) = R80
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = RICB
-
- r_top(14) = RICB
- r_bottom(14) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMIDDLE_CRUST / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(3) = R80 / R_EARTH
-
- rmaxs(4) = R80 / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:13) = RCMB / R_EARTH
- rmins(12:13) = RICB / R_EARTH
-
- rmaxs(14) = RICB / R_EARTH
- rmins(14) = R_CENTRAL_CUBE / R_EARTH
-
- endif
- else
- if (SUPPRESS_CRUSTAL_MESH) then
-
- ONE_CRUST = .false.
- OCEANS= .false.
- TOPOGRAPHY = .false.
- CRUSTAL = .false.
-
- NUMBER_OF_MESH_LAYERS = 15
- layer_offset = 1
-
- ! now only one region
- ner( 1) = NER_CRUST + NER_80_MOHO
- ner( 2) = 0
- ner( 3) = 0
-
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
- ner(14) = elem_doubling_bottom_outer_core
- ner(15) = NER_TOP_CENTRAL_CUBE_ICB
-
-! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
- ifirst_layer_aniso = 1
- ilast_layer_aniso = 4
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:9) = 1
- ratio_sampling_array(10:12) = 2
- ratio_sampling_array(13) = 4
- ratio_sampling_array(14:15) = 8
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(15) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_layer_has_a_doubling(:) = .false.
- this_layer_has_a_doubling(10) = .true.
- this_layer_has_a_doubling(13) = .true.
- this_layer_has_a_doubling(14) = .true.
- lastdoubling_layer = 14
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = R80
-
- r_top(2) = RMIDDLE_CRUST !!!! now fictitious
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
- r_bottom(3) = R80 !!!! now fictitious
-
- r_top(4) = R80
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
-
- r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
- r_bottom(14) = RICB
-
- r_top(15) = RICB
- r_bottom(15) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = R80 / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
- rmins(3) = R80 / R_EARTH !!!! now fictitious
-
- rmaxs(4) = R80 / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:14) = RCMB / R_EARTH
- rmins(12:14) = RICB / R_EARTH
-
- rmaxs(15) = RICB / R_EARTH
- rmins(15) = R_CENTRAL_CUBE / R_EARTH
-
- elseif (ONE_CRUST) then
-
- NUMBER_OF_MESH_LAYERS = 14
- layer_offset = 0
-
- ner( 1) = NER_CRUST
- ner( 2) = NER_80_MOHO
- ner( 3) = NER_220_80
- ner( 4) = NER_400_220
- ner( 5) = NER_600_400
- ner( 6) = NER_670_600
- ner( 7) = NER_771_670
- ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner( 9) = elem_doubling_mantle
- ner(10) = NER_CMB_TOPDDOUBLEPRIME
- ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(12) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
- ner(13) = elem_doubling_bottom_outer_core
- ner(14) = NER_TOP_CENTRAL_CUBE_ICB
-
-! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
- ifirst_layer_aniso = 2
- ilast_layer_aniso = 3
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1) = 1
- ratio_sampling_array(2:8) = 2
- ratio_sampling_array(9:11) = 4
- ratio_sampling_array(12) = 8
- ratio_sampling_array(13:14) = 16
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1) = IFLAG_CRUST
- doubling_index(2) = IFLAG_80_MOHO
- doubling_index(3) = IFLAG_220_80
- doubling_index(4:6) = IFLAG_670_220
- doubling_index(7:10) = IFLAG_MANTLE_NORMAL
- doubling_index(11:13) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(14) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_layer_has_a_doubling(:) = .false.
- this_layer_has_a_doubling(2) = .true.
- this_layer_has_a_doubling(9) = .true.
- this_layer_has_a_doubling(12) = .true.
- this_layer_has_a_doubling(13) = .true.
- lastdoubling_layer = 13
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
- !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
- !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
- !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
- !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
- !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(2) = R80
-
- r_top(3) = R80
- r_bottom(3) = R220
-
- r_top(4) = R220
- r_bottom(4) = R400
-
- r_top(5) = R400
- r_bottom(5) = R600
-
- r_top(6) = R600
- r_bottom(6) = R670
-
- r_top(7) = R670
- r_bottom(7) = R771
-
- r_top(8) = R771
- r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(9) = RTOPDDOUBLEPRIME
-
- r_top(10) = RTOPDDOUBLEPRIME
- r_bottom(10) = RCMB
-
- r_top(11) = RCMB
- r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(12) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
- r_bottom(13) = RICB
-
- r_top(14) = RICB
- r_bottom(14) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(2) = R80 / R_EARTH
-
- rmaxs(3) = R80 / R_EARTH
- rmins(3) = R220 / R_EARTH
-
- rmaxs(4) = R220 / R_EARTH
- rmins(4) = R400 / R_EARTH
-
- rmaxs(5) = R400 / R_EARTH
- rmins(5) = R600 / R_EARTH
-
- rmaxs(6) = R600 / R_EARTH
- rmins(6) = R670 / R_EARTH
-
- rmaxs(7) = R670 / R_EARTH
- rmins(7) = R771 / R_EARTH
-
- rmaxs(8:9) = R771 / R_EARTH
- rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(10) = RCMB / R_EARTH
-
- rmaxs(11:13) = RCMB / R_EARTH
- rmins(11:13) = RICB / R_EARTH
-
- rmaxs(14) = RICB / R_EARTH
- rmins(14) = R_CENTRAL_CUBE / R_EARTH
-
- else
-
- NUMBER_OF_MESH_LAYERS = 15
- layer_offset = 1
- if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
- ner( 1) = ceiling (NER_CRUST / 2.d0)
- ner( 2) = floor (NER_CRUST / 2.d0)
- else
- ner( 1) = floor (NER_CRUST / 2.d0)
- ner( 2) = ceiling (NER_CRUST / 2.d0)
- endif
- ner( 3) = NER_80_MOHO
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
- ner(14) = elem_doubling_bottom_outer_core
- ner(15) = NER_TOP_CENTRAL_CUBE_ICB
-
-! anisotropy in PREM only between 220 km and the Moho (bottom of the crust)
- ifirst_layer_aniso = 3
- ilast_layer_aniso = 4
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:2) = 1
- ratio_sampling_array(3:9) = 2
- ratio_sampling_array(10:12) = 4
- ratio_sampling_array(13) = 8
- ratio_sampling_array(14:15) = 16
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:2) = IFLAG_CRUST
- doubling_index(3) = IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(15) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_layer_has_a_doubling(:) = .false.
- this_layer_has_a_doubling(3) = .true.
- this_layer_has_a_doubling(10) = .true.
- this_layer_has_a_doubling(13) = .true.
- this_layer_has_a_doubling(14) = .true.
- lastdoubling_layer = 14
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMIDDLE_CRUST
-
- r_top(2) = RMIDDLE_CRUST
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(3) = R80
-
- r_top(4) = R80
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
-
- r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
- r_bottom(14) = RICB
-
- r_top(15) = RICB
- r_bottom(15) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMIDDLE_CRUST / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(3) = R80 / R_EARTH
-
- rmaxs(4) = R80 / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:14) = RCMB / R_EARTH
- rmins(12:14) = RICB / R_EARTH
-
- rmaxs(15) = RICB / R_EARTH
- rmins(15) = R_CENTRAL_CUBE / R_EARTH
- endif
- endif
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! calculation of number of elements (NSPEC) below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ratio_divide_central_cube = maxval(ratio_sampling_array)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 1D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-! theoretical number of spectral elements in radial direction
-do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else if(iter_region == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
- else
- stop 'incorrect region code detected'
- endif
- NSPEC1D_RADIAL(iter_region) = sum(ner(ifirst_region:ilast_region))
-enddo
-
-! difference of radial number of element for outer core if the superbrick is cut
- DIFF_NSPEC1D_RADIAL(:,:) = 0
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC1D_RADIAL(2,1) = 1
- DIFF_NSPEC1D_RADIAL(3,1) = 2
- DIFF_NSPEC1D_RADIAL(4,1) = 1
-
- DIFF_NSPEC1D_RADIAL(1,2) = 1
- DIFF_NSPEC1D_RADIAL(2,2) = 2
- DIFF_NSPEC1D_RADIAL(3,2) = 1
-
- DIFF_NSPEC1D_RADIAL(1,3) = 1
- DIFF_NSPEC1D_RADIAL(3,3) = 1
- DIFF_NSPEC1D_RADIAL(4,3) = 2
-
- DIFF_NSPEC1D_RADIAL(1,4) = 2
- DIFF_NSPEC1D_RADIAL(2,4) = 1
- DIFF_NSPEC1D_RADIAL(4,4) = 1
- else
- DIFF_NSPEC1D_RADIAL(2,1) = 1
- DIFF_NSPEC1D_RADIAL(3,1) = 1
-
- DIFF_NSPEC1D_RADIAL(1,2) = 1
- DIFF_NSPEC1D_RADIAL(4,2) = 1
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC1D_RADIAL(3,1) = 1
- DIFF_NSPEC1D_RADIAL(4,1) = 1
-
- DIFF_NSPEC1D_RADIAL(1,2) = 1
- DIFF_NSPEC1D_RADIAL(2,2) = 1
- endif
- endif
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 2D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! exact number of surface elements for faces along XI and ETA
-
-do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else if(iter_region == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
- else
- stop 'incorrect region code detected'
- endif
- tmp_sum_xi = 0
- tmp_sum_eta = 0
- tmp_sum_nglob2D_xi = 0
- tmp_sum_nglob2D_eta = 0
- do iter_layer = ifirst_region, ilast_region
- if (this_layer_has_a_doubling(iter_layer)) then
- if (iter_region == IREGION_OUTER_CORE .and. iter_layer == lastdoubling_layer) then
- ! simple brick
- divider = 1
- nglob_surf = 6*NGLLX**2 - 7*NGLLX + 2
- nglob_edges_h = 2*(NGLLX-1)+1 + NGLLX
- ! minimum value to be safe
- nglob_edge_v = NGLLX-2
- nb_lay_sb = 2
- nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
- nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
- else
- ! double brick
- divider = 2
- if (ner(iter_layer) == 1) then
- nglob_surf = 6*NGLLX**2 - 8*NGLLX + 3
- nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
- nglob_edge_v = NGLLX-2
- nb_lay_sb = 1
- nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK_1L
- nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK_1L
- else
- nglob_surf = 8*NGLLX**2 - 11*NGLLX + 4
- nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
- nglob_edge_v = 2*(NGLLX-1)+1 -2
- nb_lay_sb = 2
- nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
- nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
- divider = 2
- endif
- endif
- doubling = 1
- to_remove = 1
- else
- if (iter_layer /= ifirst_region) then
- to_remove = 0
- else
- to_remove = 1
- endif
-! dummy values to avoid a warning
- nglob_surf = 0
- nglob_edges_h = 0
- nglob_edge_v = 0
- doubling = 0
- nb_lay_sb = 0
- nspec2D_xi_sb = 0
- nspec2D_eta_sb = 0
- divider = 1
- endif
-
- tmp_sum_xi = tmp_sum_xi + ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb)) + &
- doubling * ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * (nspec2D_xi_sb/2))
-
- tmp_sum_eta = tmp_sum_eta + ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb)) + &
- doubling * ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * (nspec2D_eta_sb/2))
-
- tmp_sum_nglob2D_xi = tmp_sum_nglob2D_xi + (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb))*NGLLX*NGLLX) - &
- ((((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - doubling*nb_lay_sb)) + &
- ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))*(ner(iter_layer) - to_remove - doubling*nb_lay_sb))*NGLLX) + &
- (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
- doubling * (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
- ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
-
- tmp_sum_nglob2D_eta = tmp_sum_nglob2D_eta + (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb))*NGLLX*NGLLX) - &
- ((((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - doubling*nb_lay_sb)) + &
- ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))* &
- (ner(iter_layer) - to_remove - doubling*nb_lay_sb))*NGLLX) + &
- (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
- doubling * (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
- ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
- enddo
- NSPEC2D_XI(iter_region) = tmp_sum_xi
- NSPEC2D_ETA(iter_region) = tmp_sum_eta
-
- NGLOB2DMAX_YMIN_YMAX(iter_region) = tmp_sum_nglob2D_xi
- NGLOB2DMAX_XMIN_XMAX(iter_region) = tmp_sum_nglob2D_eta
-
- if (iter_region == IREGION_INNER_CORE .and. INCLUDE_CENTRAL_CUBE) then
- NSPEC2D_XI(iter_region) = NSPEC2D_XI(iter_region) + &
- ((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
- NSPEC2D_ETA(iter_region) = NSPEC2D_ETA(iter_region) + &
- ((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
-
- NGLOB2DMAX_YMIN_YMAX(iter_region) = NGLOB2DMAX_YMIN_YMAX(iter_region) + &
- (((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
-
- NGLOB2DMAX_XMIN_XMAX(iter_region) = NGLOB2DMAX_XMIN_XMAX(iter_region) + &
- (((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
- endif
-enddo
-
-! difference of number of surface elements along xi or eta for outer core if the superbrick is cut
- DIFF_NSPEC2D_XI(:,:) = 0
- DIFF_NSPEC2D_ETA(:,:) = 0
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC2D_XI(2,1) = 2
- DIFF_NSPEC2D_XI(1,2) = 2
- DIFF_NSPEC2D_XI(2,3) = 2
- DIFF_NSPEC2D_XI(1,4) = 2
-
- DIFF_NSPEC2D_ETA(2,1) = 1
- DIFF_NSPEC2D_ETA(2,2) = 1
- DIFF_NSPEC2D_ETA(1,3) = 1
- DIFF_NSPEC2D_ETA(1,4) = 1
- else
- DIFF_NSPEC2D_ETA(2,1) = 1
- DIFF_NSPEC2D_ETA(1,2) = 1
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC2D_XI(2,1) = 2
- DIFF_NSPEC2D_XI(1,2) = 2
- endif
- endif
- DIFF_NSPEC2D_XI(:,:) = DIFF_NSPEC2D_XI(:,:) * (NEX_PER_PROC_XI / ratio_divide_central_cube)
- DIFF_NSPEC2D_ETA(:,:) = DIFF_NSPEC2D_ETA(:,:) * (NEX_PER_PROC_ETA / ratio_divide_central_cube)
-
-! exact number of surface elements on the bottom and top boundaries
-
-! in the crust and mantle
- NSPEC2D_TOP(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(1))*(NEX_ETA/ratio_sampling_array(1))/NPROC
- NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(10+layer_offset))*&
- (NEX_ETA/ratio_sampling_array(10+layer_offset))/NPROC
-
-! in the outer core with mesh doubling
- if (ADD_4TH_DOUBLING) then
- NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/4))*(NEX_ETA/(ratio_divide_central_cube/4))/NPROC
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
- else
- NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/2))*(NEX_ETA/(ratio_divide_central_cube/2))/NPROC
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
- endif
-
-! in the top of the inner core
- NSPEC2D_TOP(IREGION_INNER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
- NSPEC2D_BOTTOM(IREGION_INNER_CORE) = NSPEC2D_TOP(IREGION_INNER_CORE)
-
-! maximum number of surface elements on vertical boundaries of the slices
- NSPEC2DMAX_XMIN_XMAX(:) = NSPEC2D_ETA(:)
- NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_ETA(:,:))
- NSPEC2DMAX_YMIN_YMAX(:) = NSPEC2D_XI(:)
- NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_XI(:,:))
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 3D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! exact number of spectral elements in each region
-
-do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else if(iter_region == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
- else
- stop 'incorrect region code detected'
- endif
- tmp_sum = 0;
- do iter_layer = ifirst_region, ilast_region
- if (this_layer_has_a_doubling(iter_layer)) then
- if (ner(iter_layer) == 1) then
- nb_lay_sb = 1
- nspec_sb = NSPEC_SUPERBRICK_1L
- else
- nb_lay_sb = 2
- nspec_sb = NSPEC_DOUBLING_SUPERBRICK
- endif
- doubling = 1
- else
- doubling = 0
- nb_lay_sb = 0
- nspec_sb = 0
- endif
- tmp_sum = tmp_sum + (((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb)) + &
- doubling * ((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
- (nspec_sb/4))) / NPROC
- enddo
- NSPEC(iter_region) = tmp_sum
-enddo
-
- if(INCLUDE_CENTRAL_CUBE) NSPEC(IREGION_INNER_CORE) = NSPEC(IREGION_INNER_CORE) + &
- (NEX_PER_PROC_XI / ratio_divide_central_cube) * &
- (NEX_PER_PROC_ETA / ratio_divide_central_cube) * &
- (NEX_XI / ratio_divide_central_cube)
-
- if(minval(NSPEC) <= 0) stop 'negative NSPEC, there is a problem somewhere'
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! calculation of number of points (NGLOB) below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 1D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! theoretical number of Gauss-Lobatto points in radial direction
- NGLOB1D_RADIAL(:) = NSPEC1D_RADIAL(:)*(NGLLZ-1)+1
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 2D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 2-D addressing and buffers for summation between slices
-! we add one to number of points because of the flag after the last point
- NGLOB2DMAX_XMIN_XMAX(:) = NGLOB2DMAX_XMIN_XMAX(:) + 1
- NGLOB2DMAX_YMIN_YMAX(:) = NGLOB2DMAX_YMIN_YMAX(:) + 1
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 3D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! exact number of global points in each region
-
-! initialize array
- NGLOB(:) = 0
-
-! in the inner core (no doubling region + eventually central cube)
- if(INCLUDE_CENTRAL_CUBE) then
- NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
- *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
- *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB + NEX_XI / ratio_divide_central_cube)*(NGLLZ-1)+1)
- else
- NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
- *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
- *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB)*(NGLLZ-1)+1)
- endif
-
-! in the crust-mantle and outercore
- do iter_region = IREGION_CRUST_MANTLE,IREGION_OUTER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else
- stop 'incorrect region code detected'
- endif
- tmp_sum = 0;
- do iter_layer = ifirst_region, ilast_region
- nglob_int_surf_eta=0
- nglob_int_surf_xi=0
- nglob_ext_surf = 0
- nglob_center_edge = 0
- nglob_corner_edge = 0
- nglob_border_edge = 0
- if (this_layer_has_a_doubling(iter_layer)) then
- if (iter_region == IREGION_OUTER_CORE .and. iter_layer == lastdoubling_layer .and. &
- (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
- doubling = 1
- normal_doubling = 0
- cut_doubling = 1
- nb_lay_sb = 2
- nglob_edge = 0
- nglob_surf = 0
- nglob_vol = 8*NGLLX**3 - 12*NGLLX**2 + 6*NGLLX - 1
- nglob_int_surf_eta = 6*NGLLX**2 - 7*NGLLX + 2
- nglob_int_surf_xi = 5*NGLLX**2 - 5*NGLLX + 1
- nglob_ext_surf = 4*NGLLX**2-4*NGLLX+1
- nglob_center_edge = 4*(NGLLX-1)+1
- nglob_corner_edge = 2*(NGLLX-1)+1
- nglob_border_edge = 3*(NGLLX-1)+1
- else
- if (ner(iter_layer) == 1) then
- nb_lay_sb = 1
- nglob_vol = 28*NGLLX**3 - 62*NGLLX**2 + 47*NGLLX - 12
- nglob_surf = 6*NGLLX**2-8*NGLLX+3
- nglob_edge = NGLLX
- else
- nb_lay_sb = 2
- nglob_vol = 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13
- nglob_surf = 8*NGLLX**2-11*NGLLX+4
- nglob_edge = 2*NGLLX-1
- endif
- doubling = 1
- normal_doubling = 1
- cut_doubling = 0
- endif
- padding = -1
- else
- doubling = 0
- normal_doubling = 0
- cut_doubling = 0
- padding = 0
- nb_lay_sb = 0
- nglob_vol = 0
- nglob_surf = 0
- nglob_edge = 0
- endif
- if (iter_layer == ilast_region) padding = padding +1
- nblocks_xi = NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)
- nblocks_eta = NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)
-
- tmp_sum = tmp_sum + &
- ((nblocks_xi)*(NGLLX-1)+1) * ((nblocks_eta)*(NGLLX-1)+1) * ((ner(iter_layer) - doubling*nb_lay_sb)*(NGLLX-1)+padding)+&
- normal_doubling * ((((nblocks_xi*nblocks_eta)/4)*nglob_vol) - &
- (((nblocks_eta/2-1)*nblocks_xi/2+(nblocks_xi/2-1)*nblocks_eta/2)*nglob_surf) + &
- ((nblocks_eta/2-1)*(nblocks_xi/2-1)*nglob_edge)) + &
- cut_doubling*(nglob_vol*(nblocks_xi*nblocks_eta) - &
- ( nblocks_eta*(int(nblocks_xi/2)*nglob_int_surf_xi + int((nblocks_xi-1)/2)*nglob_ext_surf) + &
- nblocks_xi*(int(nblocks_eta/2)*nglob_int_surf_eta + int((nblocks_eta-1)/2)*nglob_ext_surf)&
- ) + &
- ( int(nblocks_xi/2)*int(nblocks_eta/2)*nglob_center_edge + &
- int((nblocks_xi-1)/2)*int((nblocks_eta-1)/2)*nglob_corner_edge + &
- ((int(nblocks_eta/2)*int((nblocks_xi-1)/2))+(int((nblocks_eta-1)/2)*int(nblocks_xi/2)))*nglob_border_edge&
- ))
- enddo
- NGLOB(iter_region) = tmp_sum
- enddo
-
-!!! example :
-!!! nblocks_xi/2=5
-!!! ____________________________________
-!!! I I I I I I
-!!! I I I I I I
-!!! I I I I I I
-!!! nblocks_eta/2=3 I______+______+______+______+______I
-!!! I I I I I I
-!!! I I I I I I
-!!! I I I I I I
-!!! I______+______+______+______+______I
-!!! I I I I I I
-!!! I I I I I I
-!!! I I I I I I
-!!! I______I______I______I______I______I
-!!!
-!!! NGLOB for this doubling layer = 3*5*Volume - ((3-1)*5+(5-1)*3)*Surface + (3-1)*(5-1)*Edge
-!!!
-!!! 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13 -> nb GLL points in a superbrick (Volume)
-!!! 8*NGLLX**2-11*NGLLX+4 -> nb GLL points on a superbrick side (Surface)
-!!! 2*NGLLX-1 -> nb GLL points on a corner edge of a superbrick (Edge)
-
-!!! for the one layer superbrick :
-!!! NGLOB = 28.NGLL^3 - 62.NGLL^2 + 47.NGLL - 12 (Volume)
-!!! NGLOB = 6.NGLL^2 - 8.NGLL + 3 (Surface)
-!!! NGLOB = NGLL (Edge)
-!!!
-!!! those results were obtained by using the script UTILS/doubling_brick/count_nglob_analytical.pl
-!!! with an opendx file of the superbrick's geometry
-
-!!! for the basic doubling bricks (two layers)
-!!! NGLOB = 8.NGLL^3 - 12.NGLL^2 + 6.NGLL - 1 (VOLUME)
-!!! NGLOB = 5.NGLL^2 - 5.NGLL + 1 (SURFACE 1)
-!!! NGLOB = 6.NGLL^2 - 7.NGLL + 2 (SURFACE 2)
-
- end subroutine read_compute_parameters
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sea99_s_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sea99_s_model.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/sea99_s_model.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -34,9 +34,6 @@
! sea99_s_model_variables
type sea99_s_model_variables
sequence
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
double precision :: sea99_ddeg
double precision :: alatmin
double precision :: alatmax
@@ -44,6 +41,9 @@
double precision :: alonmax
double precision :: sea99_vs(100,100,100)
double precision :: sea99_depth(100)
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
end type sea99_s_model_variables
type (sea99_s_model_variables) SEA99M_V
@@ -91,9 +91,6 @@
! sea99_s_model_variables
type sea99_s_model_variables
sequence
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
double precision :: sea99_ddeg
double precision :: alatmin
double precision :: alatmax
@@ -101,6 +98,9 @@
double precision :: alonmax
double precision :: sea99_vs(100,100,100)
double precision :: sea99_depth(100)
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
end type sea99_s_model_variables
type (sea99_s_model_variables) SEA99M_V
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,2484 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! 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.
+!
+!=====================================================================
+
+!=======================================================================!
+! specfem3D is a 3-D spectral-element solver for the Earth. !
+! It uses a mesh generated by program meshfem3D !
+!=======================================================================!
+
+!! DK DK for the merged version
+ subroutine specfem3D(myrank,sizeprocs,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NSOURCES, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,ibool_crust_mantle,ibool_outer_core,ibool_inner_core, &
+ idoubling_crust_mantle,idoubling_inner_core,ibelm_bottom_crust_mantle, ibelm_bottom_outer_core, ibelm_top_outer_core, &
+ibelm_top_inner_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
+ normal_bottom_outer_core, normal_top_outer_core,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle,kappavstore_inner_core,muvstore_inner_core, &
+ rmass_crust_mantle,rmass_outer_core,rmass_inner_core,rmass_ocean_load, &
+#ifdef USE_MPI
+ NDIM_smaller_buffers,npoin2D_max_all,nrec,addressing,ibathy_topo, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
+iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core, iboolleft_eta_inner_core,iboolright_eta_inner_core,&
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core, &
+ iboolcorner_crust_mantle,iboolcorner_outer_core,iboolcorner_inner_core, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ normal_top_crust_mantle,ibelm_top_crust_mantle, &
+#endif
+ AM_V)
+
+ use dyn_array
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+
+!!!!!!!!!!! DK DK now in module dyn_array include "constants.h"
+ include "precision.h"
+#endif
+
+! include values created by the mesher
+ include "values_from_mesher.h"
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! memory variables and standard linear solids for attenuation
+ double precision, dimension(N_SLS) :: tau_sigma_dble
+ double precision, dimension(ATT1,ATT2,ATT3,ATT4) :: omsb_crust_mantle_dble, factor_scale_crust_mantle_dble
+ double precision, dimension(ATT1,ATT2,ATT3,ATT5) :: omsb_inner_core_dble, factor_scale_inner_core_dble
+ real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT4) :: one_minus_sum_beta_crust_mantle, factor_scale_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT5) :: one_minus_sum_beta_inner_core, factor_scale_inner_core
+
+ real(kind=CUSTOM_REAL) mul
+
+ double precision, dimension(N_SLS) :: alphaval_dble, betaval_dble, gammaval_dble
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval, betaval, gammaval
+ real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT4) :: factor_common_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core
+ double precision, dimension(N_SLS,ATT1,ATT2,ATT3,ATT4) :: factor_common_crust_mantle_dble
+ double precision, dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core_dble
+
+ double precision scale_factor,scale_factor_minus_one
+ real(kind=CUSTOM_REAL) dist_cr
+
+ 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
+
+! for matching with central cube in inner core
+#ifdef USE_MPI
+ integer, dimension(:), allocatable :: sender_from_slices_to_cube
+ integer, dimension(:,:), allocatable :: ibool_central_cube
+ double precision, dimension(:,:), allocatable :: buffer_slices,buffer_slices2
+ double precision, dimension(:,:,:), allocatable :: buffer_all_cube_from_slices
+ integer nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,receiver_cube_from_slices
+
+ integer nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core,ndim_assemble
+#endif
+
+! for crust/oceans coupling
+ integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
+#ifdef USE_MPI
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! additional mass matrix for ocean load
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+
+! flag to mask ocean-bottom degrees of freedom for ocean load
+ logical, dimension(NGLOB_CRUST_MANTLE_OCEANS) :: updated_dof_ocean_load
+
+ real(kind=CUSTOM_REAL) additional_term,force_normal_comp
+#endif
+
+! arrays to couple with the fluid regions by pointwise matching
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+ integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
+
+#ifdef USE_MPI
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
+#endif
+ integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
+
+! for matching between fluid and solid regions
+ integer :: ispec2D,k_corresp,ispec_selected
+ real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,nx,ny,nz,displ_n,weight,pressure
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+! for conversion from x y z to r theta phi
+ real(kind=CUSTOM_REAL) rval,thetaval,phival
+
+! ---- arrays to assemble between chunks
+
+#ifdef USE_MPI
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES_VAL) :: iprocfrom_faces,iprocto_faces,imsg_type
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+! indirect addressing for each message for faces and corners of the chunks
+! a given slice can belong to at most one corner and at most two faces
+ integer, dimension(NGLOB2DMAX_XY_VAL_CM,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_VAL_OC,NUMFACES_SHARED) :: iboolfaces_outer_core
+ integer, dimension(NGLOB2DMAX_XY_VAL_IC,NUMFACES_SHARED) :: iboolfaces_inner_core
+
+! buffers for send and receive between faces of the slices and the chunks
+! we use the same buffers to assemble scalars and vectors because vectors are
+! always three times bigger and therefore scalars can use the first part
+! of the vector buffer in memory even if it has an additional index here
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+ integer :: npoin2D_max_all,NDIM_smaller_buffers
+ real(kind=CUSTOM_REAL), dimension(NDIM_smaller_buffers,npoin2D_max_all) :: buffer_send_faces,buffer_received_faces
+
+#endif
+
+! -------- arrays specific to each region here -----------
+
+! ----------------- crust, mantle and oceans ---------------------
+
+! mesh parameters
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+
+! arrays for isotropic elements stored only where needed to save space
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
+ kappavstore_crust_mantle,muvstore_crust_mantle
+
+! arrays for anisotropic elements stored only where needed to save space
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
+
+! arrays for full anisotropy only when needed
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c33store_crust_mantle, &
+ c44store_crust_mantle,c55store_crust_mantle,c66store_crust_mantle
+
+! local to global mapping
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
+
+! displacement, velocity, acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
+
+! ----------------- outer core ---------------------
+
+! mesh parameters
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
+ xix_outer_core,xiy_outer_core,xiz_outer_core,&
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_core
+
+! velocity potential
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: displ_outer_core, &
+ veloc_outer_core,accel_outer_core
+
+! ----------------- inner core ---------------------
+
+! mesh parameters
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
+ xix_inner_core,xiy_inner_core,xiz_inner_core,&
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ kappavstore_inner_core,muvstore_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core
+
+! arrays for inner-core anisotropy only when needed
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core
+
+! local to global mapping
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
+
+! displacement, velocity, acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
+ displ_inner_core,veloc_inner_core,accel_inner_core
+
+! Newmark time scheme parameters and non-dimensionalization
+ real(kind=CUSTOM_REAL) time,deltat,deltatover2,deltatsqover2
+ double precision scale_t,scale_displ,scale_veloc
+
+#ifdef USE_MPI
+ integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer npoin2D_faces_outer_core(NUMFACES_SHARED)
+ integer npoin2D_faces_inner_core(NUMFACES_SHARED)
+#endif
+
+! parameters for the source
+ integer :: it
+#ifdef USE_MPI
+ integer :: isource
+ integer :: yr,jda,ho,mi
+ double precision :: sec
+#endif
+ real(kind=CUSTOM_REAL) stf_used
+ double precision :: stf
+ double precision :: t0
+ double precision, external :: comp_source_time_function
+
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+#ifdef USE_MPI
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
+ double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(NSOURCES) :: t_cmt,hdur,hdur_gaussian
+ double precision, dimension(NSOURCES) :: theta_source,phi_source
+ double precision, dimension(NDIM,NDIM,NSOURCES) :: nu_source
+#endif
+
+! receiver information
+#ifdef USE_MPI
+ integer :: nrec,nrec_local,nrec_tot_found,irec_local
+ double precision :: hlagrange
+ integer, dimension(:), allocatable :: number_receiver_global
+ character(len=150) :: STATIONS,rec_filename
+#endif
+
+! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
+#ifdef USE_MPI
+ integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+ double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
+ double precision, dimension(NDIM,NDIM,nrec) :: nu
+ double precision, dimension(nrec) :: stlat,stlon,stele
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+#endif
+
+! seismograms
+ integer :: it_begin,it_end
+ integer :: seismo_offset, seismo_current
+#ifdef USE_MPI
+ integer :: nit_written
+ double precision :: uxd, uyd, uzd
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms
+#endif
+
+ integer :: i,j,k,ispec,iglob,iglob_mantle,iglob_inner_core
+#ifdef USE_MPI
+ integer :: irec
+#endif
+
+! number of faces between chunks
+ integer NUM_FACES,NUMMSGS_FACES
+
+! number of corners between chunks
+ integer NCORNERSCHUNKS
+
+! number of message types
+ integer NUM_MSG_TYPES
+
+! indirect addressing for each corner of the chunks
+#ifdef USE_MPI
+ integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
+ integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+#endif
+
+! buffers for send and receive between corners of the chunks
+#ifdef USE_MPI
+ real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL_CM) :: buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB1D_RADIAL_CM + NGLOB1D_RADIAL_IC) :: &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector
+#endif
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll,wxgll
+ double precision, dimension(NGLLY) :: yigll,wygll
+ double precision, dimension(NGLLZ) :: zigll,wzgll
+
+! product of weights for gravity term
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+! Lagrange interpolators at receivers
+#ifdef USE_MPI
+ double precision, dimension(NGLLX) :: hxir,hpxir
+ double precision, dimension(NGLLY) :: hpetar,hetar
+ double precision, dimension(NGLLZ) :: hgammar,hpgammar
+ double precision, dimension(:,:), allocatable :: hxir_store,hetar_store,hgammar_store
+#endif
+
+! 2-D addressing and buffers for summation between slices
+#ifdef USE_MPI
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
+
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
+
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
+#endif
+
+! for addressing of the slices
+#ifdef USE_MPI
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+#endif
+ integer, dimension(0:NPROCTOT_VAL-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
+
+! proc numbers for MPI
+ integer :: myrank,sizeprocs
+#ifdef USE_MPI
+ integer :: ier,errorcode
+#endif
+
+#ifdef USE_MPI
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
+#endif
+
+ integer ichunk,iproc_xi,iproc_eta
+ integer NPROC_ONE_DIRECTION
+
+! maximum of the norm of the displacement and of the potential in the fluid
+ real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all,Ufluidnorm,Ufluidnorm_all
+
+! timer MPI
+ integer :: ihours,iminutes,iseconds,int_tCPU, &
+ ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
+ ihours_total,iminutes_total,iseconds_total,int_t_total
+
+ double precision :: time_start,tCPU,t_remain,t_total
+
+! to determine date and time at which the run will finish
+#ifdef USE_MPI
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ character(len=3), dimension(12) :: month_name
+ character(len=3), dimension(0:6) :: weekday_name
+ data month_name /'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/
+ data weekday_name /'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'/
+ integer :: year,mon,day,hr,minutes,timestamp,julian_day_number,day_of_week, &
+ timestamp_remote,year_remote,mon_remote,day_remote,hr_remote,minutes_remote,day_of_week_remote
+ integer, external :: idaywk
+#endif
+
+! 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,RMOHO_FICTITIOUS_IN_MESHER, &
+ 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, &
+ ifirst_layer_aniso,ilast_layer_aniso
+
+ 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
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ 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
+
+ character(len=150) OUTPUT_FILES,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, external :: err_occurred
+
+ logical COMPUTE_AND_STORE_STRAIN
+
+! for SAC headers for seismograms
+ integer NSOURCES_SAC,yr_SAC,jda_SAC,ho_SAC,mi_SAC
+ real mb_SAC
+ double precision t_cmt_SAC,elat_SAC,elon_SAC,depth_SAC,cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,sec_SAC
+ character(len=12) ename_SAC
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC_computed, &
+ 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_computed
+
+! lookup table every km for gravity
+ integer int_radius,idoubling
+ double precision radius,rho,drhodr,vp,vs,Qkappa,Qmu
+ double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
+
+! names of the data files for all the processors in MPI
+ character(len=150) outputname
+
+ integer iregion_selected
+
+! 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_layer_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+ logical :: CASE_3D
+
+! arrays for BCAST
+ integer, dimension(40) :: bcast_integer
+ double precision, dimension(30) :: bcast_double_precision
+ logical, dimension(33) :: bcast_logical
+
+ 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
+
+! allocate this automatic array in the memory stack to avoid memory fragmentation with "allocate()"
+#ifdef USE_MPI
+ real(kind=CUSTOM_REAL), dimension(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: one_seismogram
+#endif
+
+! ************** PROGRAM STARTS HERE **************
+
+! set up GLL points, weights and derivation matrices
+ call define_derivation_matrices(xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube)
+
+!! DK DK recompute arrays here for merged version
+ call recompute_missing_arrays(myrank, &
+ 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, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xelm_store_crust_mantle,yelm_store_crust_mantle,zelm_store_crust_mantle, &
+ ibool_crust_mantle,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
+ xigll,yigll,zigll)
+
+ call recompute_missing_arrays(myrank, &
+ 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, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xelm_store_outer_core,yelm_store_outer_core,zelm_store_outer_core, &
+ ibool_outer_core,NSPEC_OUTER_CORE,NGLOB_OUTER_CORE, &
+ xigll,yigll,zigll)
+
+ call recompute_missing_arrays(myrank, &
+ 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, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xelm_store_inner_core,yelm_store_inner_core,zelm_store_inner_core, &
+ ibool_inner_core,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
+ xigll,yigll,zigll)
+
+!! DK DK for merged version, deallocate arrays that have become useless
+ deallocate(xelm_store_crust_mantle)
+ deallocate(yelm_store_crust_mantle)
+ deallocate(zelm_store_crust_mantle)
+
+ deallocate(xelm_store_outer_core)
+ deallocate(yelm_store_outer_core)
+ deallocate(zelm_store_outer_core)
+
+ deallocate(xelm_store_inner_core)
+ deallocate(yelm_store_inner_core)
+ deallocate(zelm_store_inner_core)
+
+ if (myrank == 0) then
+
+! 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,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,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC_computed, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB_computed, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_layer_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,ifirst_layer_aniso,ilast_layer_aniso,.false.)
+
+ if(err_occurred() /= 0) call exit_MPI(myrank,'an error occurred while reading the parameter file')
+
+ bcast_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,RMOHO_FICTITIOUS_IN_MESHER, &
+ 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,NPROC,NPROCTOT, &
+ NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,ifirst_layer_aniso,ilast_layer_aniso/)
+
+ bcast_logical = (/TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE/)
+
+ 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, &
+ 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/)
+
+ endif
+
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(bcast_integer,40,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_double_precision,30,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_logical,33,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(MODEL,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(ner,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ratio_sampling_array,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(doubling_index,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(r_bottom,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(r_top,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmins,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(this_layer_has_a_doubling,MAX_NUMBER_OF_MESH_LAYERS,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(NSPEC_computed,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_XI,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_ETA,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_BOTTOM,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_TOP,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB_computed,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(DIFF_NSPEC1D_RADIAL,NB_SQUARE_CORNERS*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(DIFF_NSPEC2D_ETA,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(DIFF_NSPEC2D_XI,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+#endif
+
+ if (myrank /=0) then
+
+ MIN_ATTENUATION_PERIOD = bcast_integer(1)
+ MAX_ATTENUATION_PERIOD = bcast_integer(2)
+ NER_CRUST = bcast_integer(3)
+ NER_80_MOHO = bcast_integer(4)
+ NER_220_80 = bcast_integer(5)
+ NER_400_220 = bcast_integer(6)
+ NER_600_400 = bcast_integer(7)
+ NER_670_600 = bcast_integer(8)
+ NER_771_670 = bcast_integer(9)
+ NER_TOPDDOUBLEPRIME_771 = bcast_integer(10)
+ NER_CMB_TOPDDOUBLEPRIME = bcast_integer(11)
+ NER_OUTER_CORE = bcast_integer(12)
+ NER_TOP_CENTRAL_CUBE_ICB = bcast_integer(13)
+ NEX_XI = bcast_integer(14)
+ NEX_ETA = bcast_integer(15)
+ RMOHO_FICTITIOUS_IN_MESHER = bcast_integer(16)
+ NPROC_XI = bcast_integer(17)
+ NPROC_ETA = bcast_integer(18)
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS = bcast_integer(19)
+ NTSTEP_BETWEEN_READ_ADJSRC = bcast_integer(20)
+ NSTEP = bcast_integer(21)
+ NSOURCES = bcast_integer(22)
+ NTSTEP_BETWEEN_FRAMES = bcast_integer(23)
+ NTSTEP_BETWEEN_OUTPUT_INFO = bcast_integer(24)
+ NUMBER_OF_RUNS = bcast_integer(25)
+ NUMBER_OF_THIS_RUN = bcast_integer(26)
+ NCHUNKS = bcast_integer(27)
+ SIMULATION_TYPE = bcast_integer(28)
+ REFERENCE_1D_MODEL = bcast_integer(29)
+ THREE_D_MODEL = bcast_integer(30)
+ NPROC = bcast_integer(31)
+ NPROCTOT = bcast_integer(32)
+ NEX_PER_PROC_XI = bcast_integer(33)
+ NEX_PER_PROC_ETA = bcast_integer(34)
+ ratio_divide_central_cube = bcast_integer(35)
+ MOVIE_VOLUME_TYPE = bcast_integer(36)
+ MOVIE_START = bcast_integer(37)
+ MOVIE_STOP = bcast_integer(38)
+ ifirst_layer_aniso = bcast_integer(39)
+ ilast_layer_aniso = bcast_integer(40)
+
+ TRANSVERSE_ISOTROPY = bcast_logical(1)
+ ANISOTROPIC_3D_MANTLE = bcast_logical(2)
+ ANISOTROPIC_INNER_CORE = bcast_logical(3)
+ CRUSTAL = bcast_logical(4)
+ ELLIPTICITY = bcast_logical(5)
+ GRAVITY = bcast_logical(6)
+ ONE_CRUST = bcast_logical(7)
+ ROTATION = bcast_logical(8)
+ ISOTROPIC_3D_MANTLE = bcast_logical(9)
+ TOPOGRAPHY = bcast_logical(10)
+ OCEANS = bcast_logical(11)
+ MOVIE_SURFACE = bcast_logical(12)
+ MOVIE_VOLUME = bcast_logical(13)
+ MOVIE_COARSE = bcast_logical(14)
+ ATTENUATION_3D = bcast_logical(15)
+ RECEIVERS_CAN_BE_BURIED = bcast_logical(16)
+ PRINT_SOURCE_TIME_FUNCTION = bcast_logical(17)
+ SAVE_MESH_FILES = bcast_logical(18)
+ ATTENUATION = bcast_logical(19)
+ ABSORBING_CONDITIONS = bcast_logical(20)
+ INCLUDE_CENTRAL_CUBE = bcast_logical(21)
+ INFLATE_CENTRAL_CUBE = bcast_logical(22)
+ SAVE_FORWARD = bcast_logical(23)
+ CASE_3D = bcast_logical(24)
+ OUTPUT_SEISMOS_ASCII_TEXT = bcast_logical(25)
+ OUTPUT_SEISMOS_SAC_ALPHANUM = bcast_logical(26)
+ OUTPUT_SEISMOS_SAC_BINARY = bcast_logical(27)
+ ROTATE_SEISMOGRAMS_RT = bcast_logical(28)
+ CUT_SUPERBRICK_XI = bcast_logical(29)
+ CUT_SUPERBRICK_ETA = bcast_logical(30)
+ WRITE_SEISMOGRAMS_BY_MASTER = bcast_logical(31)
+ SAVE_ALL_SEISMOS_IN_ONE_FILE = bcast_logical(32)
+ USE_BINARY_FOR_LARGE_FILE = bcast_logical(33)
+
+ DT = bcast_double_precision(1)
+ ANGULAR_WIDTH_XI_IN_DEGREES = bcast_double_precision(2)
+ ANGULAR_WIDTH_ETA_IN_DEGREES = bcast_double_precision(3)
+ CENTER_LONGITUDE_IN_DEGREES = bcast_double_precision(4)
+ CENTER_LATITUDE_IN_DEGREES = bcast_double_precision(5)
+ GAMMA_ROTATION_AZIMUTH = bcast_double_precision(6)
+ ROCEAN = bcast_double_precision(7)
+ RMIDDLE_CRUST = bcast_double_precision(8)
+ RMOHO = bcast_double_precision(9)
+ R80 = bcast_double_precision(10)
+ R120 = bcast_double_precision(11)
+ R220 = bcast_double_precision(12)
+ R400 = bcast_double_precision(13)
+ R600 = bcast_double_precision(14)
+ R670 = bcast_double_precision(15)
+ R771 = bcast_double_precision(16)
+ RTOPDDOUBLEPRIME = bcast_double_precision(17)
+ RCMB = bcast_double_precision(18)
+ RICB = bcast_double_precision(19)
+ R_CENTRAL_CUBE = bcast_double_precision(20)
+ RHO_TOP_OC = bcast_double_precision(21)
+ RHO_BOTTOM_OC = bcast_double_precision(22)
+ RHO_OCEANS = bcast_double_precision(23)
+ HDUR_MOVIE = bcast_double_precision(24)
+ MOVIE_TOP = bcast_double_precision(25)
+ MOVIE_BOTTOM = bcast_double_precision(26)
+ MOVIE_WEST = bcast_double_precision(27)
+ MOVIE_EAST = bcast_double_precision(28)
+ MOVIE_NORTH = bcast_double_precision(29)
+ MOVIE_SOUTH = bcast_double_precision(30)
+
+ endif
+
+! check simulation pararmeters
+ if (SIMULATION_TYPE /= 1 .and. SIMULATION_TYPE /= 2 .and. SIMULATION_TYPE /= 3) &
+ call exit_MPI(myrank, 'SIMULATION_TYPE could be only 1, 2, or 3')
+
+ 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 (ATTENUATION_VAL .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
+ COMPUTE_AND_STORE_STRAIN = .true.
+ else
+ COMPUTE_AND_STORE_STRAIN = .false.
+ endif
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! open main output file, only written to by process 0
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
+ open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_solver.txt',status='unknown',action='write')
+
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ write(IMAIN,*) '******************************'
+ write(IMAIN,*) '**** Specfem3D MPI Solver ****'
+ write(IMAIN,*) '******************************'
+ write(IMAIN,*)
+ write(IMAIN,*)
+
+ if(FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field'
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
+ write(IMAIN,*)
+
+ write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
+ write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
+ write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
+ write(IMAIN,*) 'There are ',NCHUNKS,' chunks'
+ write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in all the chunks'
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'NDIM = ',NDIM
+ write(IMAIN,*)
+ write(IMAIN,*) 'NGLLX = ',NGLLX
+ write(IMAIN,*) 'NGLLY = ',NGLLY
+ write(IMAIN,*) 'NGLLZ = ',NGLLZ
+ write(IMAIN,*)
+
+! write information about precision used for floating-point operations
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IMAIN,*) 'using single precision for the calculations'
+ else
+ write(IMAIN,*) 'using double precision for the calculations'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
+ write(IMAIN,*)
+
+ endif
+
+! check that the code is running with the requested nb of processes
+ if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
+
+! check that the code has been compiled with the right values
+ if (NSPEC_computed(IREGION_CRUST_MANTLE) /= NSPEC_CRUST_MANTLE) then
+ write(IMAIN,*) NSPEC_computed(IREGION_CRUST_MANTLE),NSPEC_CRUST_MANTLE
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 1')
+ endif
+ if (NSPEC_computed(IREGION_OUTER_CORE) /= NSPEC_OUTER_CORE) then
+ write(IMAIN,*) NSPEC_computed(IREGION_OUTER_CORE),NSPEC_OUTER_CORE
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 2')
+ endif
+ if (NSPEC_computed(IREGION_INNER_CORE) /= NSPEC_INNER_CORE) then
+ write(IMAIN,*) NSPEC_computed(IREGION_INNER_CORE),NSPEC_INNER_CORE
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 3')
+ endif
+ if (ATTENUATION_3D .NEQV. ATTENUATION_3D_VAL) then
+ write(IMAIN,*) ATTENUATION_3D,ATTENUATION_3D_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 4')
+ endif
+ if (NCHUNKS /= NCHUNKS_VAL) then
+ write(IMAIN,*) NCHUNKS,NCHUNKS_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 6')
+ endif
+ if (GRAVITY .NEQV. GRAVITY_VAL) then
+ write(IMAIN,*) GRAVITY,GRAVITY_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 7')
+ endif
+ if (ROTATION .NEQV. ROTATION_VAL) then
+ write(IMAIN,*) ROTATION,ROTATION_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 8')
+ endif
+ if (ATTENUATION .NEQV. ATTENUATION_VAL) then
+ write(IMAIN,*) ATTENUATION,ATTENUATION_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 9')
+ endif
+ if (ELLIPTICITY .NEQV. ELLIPTICITY_VAL) then
+ write(IMAIN,*) ELLIPTICITY,ELLIPTICITY_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 10')
+ endif
+ if (NPROCTOT /= NPROCTOT_VAL) then
+ write(IMAIN,*) NPROCTOT,NPROCTOT_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 11')
+ endif
+ if (NEX_XI /= NEX_XI_VAL) then
+ write(IMAIN,*) NEX_XI,NEX_XI_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 12')
+ endif
+ if (NEX_ETA /= NEX_ETA_VAL) then
+ write(IMAIN,*) NEX_ETA,NEX_ETA_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 13')
+ endif
+ if (TRANSVERSE_ISOTROPY .NEQV. TRANSVERSE_ISOTROPY_VAL) then
+ write(IMAIN,*) TRANSVERSE_ISOTROPY,TRANSVERSE_ISOTROPY_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 14')
+ endif
+ if (ANISOTROPIC_3D_MANTLE .NEQV. ANISOTROPIC_3D_MANTLE_VAL) then
+ write(IMAIN,*) ANISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 15')
+ endif
+ if (ANISOTROPIC_INNER_CORE .NEQV. ANISOTROPIC_INNER_CORE_VAL) then
+ write(IMAIN,*) ANISOTROPIC_INNER_CORE,ANISOTROPIC_INNER_CORE_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 16')
+ endif
+
+! determine chunk number and local slice coordinates using addressing
+ ichunk = ichunk_slice(myrank)
+ iproc_xi = iproc_xi_slice(myrank)
+ iproc_eta = iproc_eta_slice(myrank)
+
+! make ellipticity
+ if(ELLIPTICITY_VAL) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
+
+! number of corners and faces shared between chunks and number of message types
+ if(NCHUNKS_VAL == 1 .or. NCHUNKS_VAL == 2) then
+ NCORNERSCHUNKS = 1
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 1
+ else if(NCHUNKS_VAL == 3) then
+ NCORNERSCHUNKS = 1
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 3
+ else if(NCHUNKS_VAL == 6) then
+ NCORNERSCHUNKS = 8
+ NUM_FACES = 4
+ NUM_MSG_TYPES = 3
+ else
+ call exit_MPI(myrank,'number of chunks must be either 1, 2, 3 or 6')
+ endif
+
+! if more than one chunk then same number of processors in each direction
+ NPROC_ONE_DIRECTION = NPROC_XI
+
+! total number of messages corresponding to these common faces
+ NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
+
+! check that the number of points in this slice is correct
+ if(minval(ibool_crust_mantle) /= 1 .or. maxval(ibool_crust_mantle) /= NGLOB_CRUST_MANTLE) &
+ call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in crust and mantle')
+
+ if(minval(ibool_outer_core) /= 1 .or. maxval(ibool_outer_core) /= NGLOB_OUTER_CORE) &
+ call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in outer core')
+
+ if(minval(ibool_inner_core) /= 1 .or. maxval(ibool_inner_core) /= NGLOB_INNER_CORE) &
+ call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in inner core')
+
+!! DK DK completely suppress sources and receivers for serial tests: a fictitious
+!! DK DK source will be used instead, and seismograms will not be recorded
+#ifdef USE_MPI
+
+! check that there is at least one receiver
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Total number of receivers = ', nrec
+ write(IMAIN,*)
+ endif
+ if(nrec < 1) call exit_MPI(myrank,'need at least one receiver')
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! locate sources in the mesh
+ call locate_sources(NSOURCES,myrank,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,ibool_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xigll,yigll,zigll,NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
+ sec,t_cmt,yr,jda,ho,mi,theta_source,phi_source, &
+ NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source, nu_source,&
+ rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION)
+
+ if(minval(t_cmt) /= 0.) call exit_MPI(myrank,'one t_cmt must be zero, others must be positive')
+
+! convert the half duration for triangle STF to the one for gaussian STF
+ hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
+
+! define t0 as the earliest start time
+ t0 = - 1.5d0*minval(t_cmt-hdur)
+
+! --------- receivers ---------------
+
+ rec_filename = 'DATA/STATIONS'
+ call get_value_string(STATIONS, 'solver.STATIONS', rec_filename)
+
+! locate receivers in the crust in the mesh
+ call locate_receivers(myrank,DT,NSTEP,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,ibool_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xigll,yigll,zigll,trim(rec_filename), &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ xi_receiver,eta_receiver,gamma_receiver,station_name,network_name,stlat,stlon,stele,nu, &
+ yr,jda,ho,mi,sec, &
+ NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
+ theta_source(1),phi_source(1),rspl,espl,espl2,nspl,ibathy_topo,RECEIVERS_CAN_BE_BURIED,NCHUNKS)
+
+!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+ do isource = 1,NSOURCES
+
+! check that the source slice number is okay
+ if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROCTOT-1) &
+ call exit_MPI(myrank,'something is wrong with the source slice number')
+
+! compute source arrays in source slice
+ if(myrank == islice_selected_source(isource)) then
+ call compute_arrays_source(ispec_selected_source(isource), &
+ xi_source(isource),eta_source(isource),gamma_source(isource),sourcearray, &
+ Mxx(isource),Myy(isource),Mzz(isource),Mxy(isource),Mxz(isource),Myz(isource), &
+ 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, &
+ xigll,yigll,zigll,NSPEC_CRUST_MANTLE)
+ sourcearrays(isource,:,:,:,:) = sourcearray(:,:,:,:)
+ endif
+ enddo
+
+!--- select local receivers
+
+! count number of receivers located in this slice
+ nrec_local = 0
+ do irec = 1,nrec
+ if(myrank == islice_selected_rec(irec)) nrec_local = nrec_local + 1
+ enddo
+
+ if (nrec_local > 0) then
+
+! allocate Lagrange interpolators for receivers
+ allocate(hxir_store(nrec_local,NGLLX),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(hetar_store(nrec_local,NGLLY),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(hgammar_store(nrec_local,NGLLZ),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! define local to global receiver numbering mapping
+ allocate(number_receiver_global(nrec_local),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ irec_local = 0
+ do irec = 1,nrec
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+ number_receiver_global(irec_local) = irec
+ endif
+ enddo
+
+! define and store Lagrange interpolators at all the receivers
+ do irec_local = 1,nrec_local
+ irec = number_receiver_global(irec_local)
+ call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_receiver(irec),NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
+ hxir_store(irec_local,:) = hxir(:)
+ hetar_store(irec_local,:) = hetar(:)
+ hgammar_store(irec_local,:) = hgammar(:)
+ enddo
+
+ endif ! nrec_local
+
+! check that the sum of the number of receivers in each slice is nrec
+ call MPI_REDUCE(nrec_local,nrec_tot_found,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'found a total of ',nrec_tot_found,' receivers in all the slices'
+ if(nrec_tot_found /= nrec) then
+ call exit_MPI(myrank,'problem when dispatching the receivers')
+ else
+ write(IMAIN,*) 'this total is okay'
+ endif
+ endif
+
+!! DK DK end of section with sources and receivers excluded in the serial case
+#else
+ t0 = 0.03d0
+#endif
+
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
+ write(IMAIN,*)
+
+ if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
+
+ write(IMAIN,*)
+ if(ELLIPTICITY_VAL) then
+ write(IMAIN,*) 'incorporating ellipticity'
+ else
+ write(IMAIN,*) 'no ellipticity'
+ endif
+
+ write(IMAIN,*)
+ if(TOPOGRAPHY) then
+ write(IMAIN,*) 'incorporating surface topography'
+ else
+ write(IMAIN,*) 'no surface topography'
+ endif
+
+ write(IMAIN,*)
+ if(ISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) 'incorporating 3-D lateral variations'
+ else
+ write(IMAIN,*) 'no 3-D lateral variations'
+ endif
+
+ write(IMAIN,*)
+ if(CRUSTAL) then
+ write(IMAIN,*) 'incorporating crustal variations'
+ else
+ write(IMAIN,*) 'no crustal variations'
+ endif
+
+ write(IMAIN,*)
+ if(ONE_CRUST) then
+ write(IMAIN,*) 'using one layer only in PREM crust'
+ else
+ write(IMAIN,*) 'using unmodified 1D crustal model with two layers'
+ endif
+
+ write(IMAIN,*)
+ if(GRAVITY_VAL) then
+ write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)'
+ else
+ write(IMAIN,*) 'no self-gravitation'
+ endif
+
+ write(IMAIN,*)
+ if(ROTATION_VAL) then
+ write(IMAIN,*) 'incorporating rotation'
+ else
+ write(IMAIN,*) 'no rotation'
+ endif
+
+ write(IMAIN,*)
+ if(TRANSVERSE_ISOTROPY_VAL) then
+ write(IMAIN,*) 'incorporating transverse isotropy'
+ else
+ write(IMAIN,*) 'no transverse isotropy'
+ endif
+
+ write(IMAIN,*)
+ if(ATTENUATION_VAL) then
+ write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
+ if(ATTENUATION_3D_VAL) write(IMAIN,*) 'using 3D attenuation'
+ else
+ write(IMAIN,*) 'no attenuation'
+ endif
+
+ write(IMAIN,*)
+ if(OCEANS) then
+ write(IMAIN,*) 'incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) 'no oceans'
+ endif
+
+ write(IMAIN,*)
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+ write(IMAIN,*) 'incorporating anisotropic inner core'
+ else
+ write(IMAIN,*) 'no inner-core anisotropy'
+ endif
+
+ write(IMAIN,*)
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+ write(IMAIN,*) 'incorporating anisotropic mantle'
+ else
+ write(IMAIN,*) 'no general mantle anisotropy'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*)
+ write(IMAIN,*)
+
+ endif
+
+#ifdef USE_MPI
+
+! the mass matrices need to be assembled with MPI here once and for all
+
+! ocean load
+ if (OCEANS) then
+ call assemble_MPI_scalar(myrank,rmass_ocean_load,NGLOB_CRUST_MANTLE, &
+ 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, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY_VAL_CM,NCHUNKS)
+ endif
+
+! crust and mantle
+ call assemble_MPI_scalar(myrank,rmass_crust_mantle,NGLOB_CRUST_MANTLE, &
+ 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, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY_VAL_CM,NCHUNKS)
+
+! outer core
+ call assemble_MPI_scalar(myrank,rmass_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,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY_VAL_OC,NCHUNKS)
+
+! inner core
+ call assemble_MPI_scalar(myrank,rmass_inner_core,NGLOB_INNER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ 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,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE),NGLOB2DMAX_XY_VAL_IC,NCHUNKS)
+
+ if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrices'
+
+!
+!--- handle the communications with the central cube if it was included in the mesh
+!
+ if(INCLUDE_CENTRAL_CUBE) then
+
+ if(myrank == 0) write(IMAIN,*) 'including central cube'
+
+! compute number of messages to expect in cube as well as their size
+ call comp_central_cube_buffer_size(iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM(IREGION_INNER_CORE), &
+ nb_msgs_theor_in_cube,npoin2D_cube_from_slices)
+
+! this value is used for dynamic memory allocation, therefore make sure it is never zero
+ if(nb_msgs_theor_in_cube > 0) then
+ non_zero_nb_msgs_theor_in_cube = nb_msgs_theor_in_cube
+ else
+ non_zero_nb_msgs_theor_in_cube = 1
+ endif
+
+! allocate buffers for cube and slices
+ allocate(sender_from_slices_to_cube(non_zero_nb_msgs_theor_in_cube),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(buffer_all_cube_from_slices(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ stop 'fatal error'
+ endif
+
+ allocate(buffer_slices(npoin2D_cube_from_slices,NDIM),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(buffer_slices2(npoin2D_cube_from_slices,NDIM),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(ibool_central_cube(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices),STAT=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! create buffers to assemble with the central cube
+ call create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
+ NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
+ NSPEC2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NSPEC2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
+ NSPEC2D_BOTTOM(IREGION_INNER_CORE), &
+ addressing,ibool_inner_core,idoubling_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
+ nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices, &
+ receiver_cube_from_slices,sender_from_slices_to_cube,ibool_central_cube, &
+ buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
+
+ if(myrank == 0) write(IMAIN,*) 'done including central cube'
+
+! the mass matrix to assemble is a scalar, not a vector
+ ndim_assemble = 1
+
+! use these buffers to assemble the inner core mass matrix with the central cube
+ 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, buffer_slices2, ibool_central_cube, &
+ receiver_cube_from_slices, ibool_inner_core, idoubling_inner_core, NSPEC_INNER_CORE, &
+ ibelm_bottom_inner_core, NSPEC2D_BOTTOM(IREGION_INNER_CORE),NGLOB_INNER_CORE,rmass_inner_core,ndim_assemble)
+
+! suppress fictitious mass matrix elements in central cube
+! because the slices do not compute all their spectral elements in the cube
+ where(rmass_inner_core(:) <= 0.) rmass_inner_core = 1.
+
+ endif ! end of handling the communications with the central cube
+
+#endif
+
+! check that all the mass matrices are positive
+ if(minval(rmass_crust_mantle) <= 0. .or. minval(rmass_inner_core) <= 0. .or. minval(rmass_outer_core) <= 0.) &
+ call exit_MPI(myrank,'negative mass matrix term for at least one region')
+
+ if(OCEANS) then
+ if(minval(rmass_ocean_load) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the oceans')
+ endif
+
+! for efficiency, invert final mass matrix once and for all on each slice
+ if(OCEANS) rmass_ocean_load = 1._CUSTOM_REAL / rmass_ocean_load
+ rmass_crust_mantle = 1._CUSTOM_REAL / rmass_crust_mantle
+ rmass_outer_core = 1._CUSTOM_REAL / rmass_outer_core
+ rmass_inner_core = 1._CUSTOM_REAL / rmass_inner_core
+
+! change x, y, z to r, theta and phi once and for all
+! IMPROVE dangerous: old name kept (xstore ystore zstore) for new values
+
+! convert in the crust and mantle
+ do iglob = 1,NGLOB_CRUST_MANTLE
+ call xyz_2_rthetaphi(xstore_crust_mantle(iglob), &
+ ystore_crust_mantle(iglob),zstore_crust_mantle(iglob),rval,thetaval,phival)
+ xstore_crust_mantle(iglob) = rval
+ ystore_crust_mantle(iglob) = thetaval
+ zstore_crust_mantle(iglob) = phival
+ enddo
+
+! convert in the outer core
+ do iglob = 1,NGLOB_OUTER_CORE
+ call xyz_2_rthetaphi(xstore_outer_core(iglob), &
+ ystore_outer_core(iglob),zstore_outer_core(iglob),rval,thetaval,phival)
+ xstore_outer_core(iglob) = rval
+ ystore_outer_core(iglob) = thetaval
+ zstore_outer_core(iglob) = phival
+ enddo
+
+! convert in the inner core
+ do iglob = 1,NGLOB_INNER_CORE
+ call xyz_2_rthetaphi(xstore_inner_core(iglob), &
+ ystore_inner_core(iglob),zstore_inner_core(iglob),rval,thetaval,phival)
+ xstore_inner_core(iglob) = rval
+ ystore_inner_core(iglob) = thetaval
+ zstore_inner_core(iglob) = phival
+ enddo
+
+ if(ATTENUATION_VAL) then
+
+! get and store PREM attenuation model
+
+ call get_attenuation_model_1D(myrank, IREGION_CRUST_MANTLE, tau_sigma_dble, &
+ omsb_crust_mantle_dble, factor_common_crust_mantle_dble, &
+ factor_scale_crust_mantle_dble, NRAD_ATTENUATION,1,1,1, AM_V)
+ omsb_inner_core_dble(:,:,:,1:min(ATT4,ATT5)) = omsb_crust_mantle_dble(:,:,:,1:min(ATT4,ATT5))
+ factor_scale_inner_core_dble(:,:,:,1:min(ATT4,ATT5)) = factor_scale_crust_mantle_dble(:,:,:,1:min(ATT4,ATT5))
+ factor_common_inner_core_dble(:,:,:,:,1:min(ATT4,ATT5)) = factor_common_crust_mantle_dble(:,:,:,:,1:min(ATT4,ATT5))
+ ! Tell the Attenuation Code about the IDOUBLING regions within the Mesh
+ call set_attenuation_regions_1D(RICB, RCMB, R670, R220, R80, AM_V)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ factor_scale_crust_mantle = sngl(factor_scale_crust_mantle_dble)
+ one_minus_sum_beta_crust_mantle = sngl(omsb_crust_mantle_dble)
+ factor_common_crust_mantle = sngl(factor_common_crust_mantle_dble)
+
+ factor_scale_inner_core = sngl(factor_scale_inner_core_dble)
+ one_minus_sum_beta_inner_core = sngl(omsb_inner_core_dble)
+ factor_common_inner_core = sngl(factor_common_inner_core_dble)
+ else
+ factor_scale_crust_mantle = factor_scale_crust_mantle_dble
+ one_minus_sum_beta_crust_mantle = omsb_crust_mantle_dble
+ factor_common_crust_mantle = factor_common_crust_mantle_dble
+
+ factor_scale_inner_core = factor_scale_inner_core_dble
+ one_minus_sum_beta_inner_core = omsb_inner_core_dble
+ factor_common_inner_core = factor_common_inner_core_dble
+ endif
+
+! if attenuation is on, shift PREM to right frequency
+! rescale mu in PREM to average frequency for attenuation
+! the formulas to implement the scaling can be found for instance in
+! Liu, H. P., Anderson, D. L. and Kanamori, H., Velocity dispersion due to
+! anelasticity: implications for seismology and mantle composition,
+! Geophys. J. R. Astron. Soc., vol. 47, pp. 41-58 (1976)
+! and in Aki, K. and Richards, P. G., Quantitative seismology, theory and methods,
+! W. H. Freeman, (1980), second edition, sections 5.5 and 5.5.2, eq. (5.81) p. 170
+
+! rescale in crust and mantle
+
+ do ispec = 1,NSPEC_CRUST_MANTLE
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+! ATTENUATION_3D get scale_factor
+ if(ATTENUATION_3D_VAL) then
+ ! tau_mu and tau_sigma need to reference a point in the mesh
+ scale_factor = factor_scale_crust_mantle(i,j,k,ispec)
+ else
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+ dist_cr = xstore_crust_mantle(iglob)
+ call get_attenuation_index(idoubling_crust_mantle(ispec), dble(dist_cr), iregion_selected, .FALSE., AM_V)
+ scale_factor = factor_scale_crust_mantle(1,1,1,iregion_selected)
+ endif ! ATTENUATION_3D
+
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+ scale_factor_minus_one = scale_factor - 1.
+ mul = c44store_crust_mantle(i,j,k,ispec)
+ c11store_crust_mantle(i,j,k,ispec) = c11store_crust_mantle(i,j,k,ispec) &
+ + FOUR_THIRDS * scale_factor_minus_one * mul
+ c12store_crust_mantle(i,j,k,ispec) = c12store_crust_mantle(i,j,k,ispec) &
+ - TWO_THIRDS * scale_factor_minus_one * mul
+ c13store_crust_mantle(i,j,k,ispec) = c13store_crust_mantle(i,j,k,ispec) &
+ - TWO_THIRDS * scale_factor_minus_one * mul
+ c22store_crust_mantle(i,j,k,ispec) = c22store_crust_mantle(i,j,k,ispec) &
+ + FOUR_THIRDS * scale_factor_minus_one * mul
+ c23store_crust_mantle(i,j,k,ispec) = c23store_crust_mantle(i,j,k,ispec) &
+ - TWO_THIRDS * scale_factor_minus_one * mul
+ c33store_crust_mantle(i,j,k,ispec) = c33store_crust_mantle(i,j,k,ispec) &
+ + FOUR_THIRDS * scale_factor_minus_one * mul
+ c44store_crust_mantle(i,j,k,ispec) = c44store_crust_mantle(i,j,k,ispec) &
+ + scale_factor_minus_one * mul
+ c55store_crust_mantle(i,j,k,ispec) = c55store_crust_mantle(i,j,k,ispec) &
+ + scale_factor_minus_one * mul
+ c66store_crust_mantle(i,j,k,ispec) = c66store_crust_mantle(i,j,k,ispec) &
+ + scale_factor_minus_one * mul
+ else
+ muvstore_crust_mantle(i,j,k,ispec) = muvstore_crust_mantle(i,j,k,ispec) * scale_factor
+ if(TRANSVERSE_ISOTROPY_VAL .and. (idoubling_crust_mantle(ispec) == IFLAG_220_80 &
+ .or. idoubling_crust_mantle(ispec) == IFLAG_80_MOHO)) &
+ muhstore_crust_mantle(i,j,k,ispec) = muhstore_crust_mantle(i,j,k,ispec) * scale_factor
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo ! END DO CRUST MANTLE
+
+! rescale in inner core
+
+ do ispec = 1,NSPEC_INNER_CORE
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ if(ATTENUATION_3D_VAL) then
+ scale_factor_minus_one = factor_scale_inner_core(i,j,k,ispec) - 1.0
+ else
+ iglob = ibool_inner_core(i,j,k,ispec)
+ dist_cr = xstore_inner_core(iglob)
+ call get_attenuation_index(idoubling_inner_core(ispec), dble(dist_cr), iregion_selected, .TRUE., AM_V)
+ scale_factor_minus_one = factor_scale_inner_core(1,1,1,iregion_selected) - 1.
+ endif
+
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+ mul = muvstore_inner_core(i,j,k,ispec)
+ c11store_inner_core(i,j,k,ispec) = c11store_inner_core(i,j,k,ispec) &
+ + FOUR_THIRDS * scale_factor_minus_one * mul
+ c12store_inner_core(i,j,k,ispec) = c12store_inner_core(i,j,k,ispec) &
+ - TWO_THIRDS * scale_factor_minus_one * mul
+ c13store_inner_core(i,j,k,ispec) = c13store_inner_core(i,j,k,ispec) &
+ - TWO_THIRDS * scale_factor_minus_one * mul
+ c33store_inner_core(i,j,k,ispec) = c33store_inner_core(i,j,k,ispec) &
+ + FOUR_THIRDS * scale_factor_minus_one * mul
+ c44store_inner_core(i,j,k,ispec) = c44store_inner_core(i,j,k,ispec) &
+ + scale_factor_minus_one * mul
+ endif
+
+ if(ATTENUATION_3D_VAL) then
+ muvstore_inner_core(i,j,k,ispec) = muvstore_inner_core(i,j,k,ispec) * factor_scale_inner_core(i,j,k,ispec)
+ else
+ muvstore_inner_core(i,j,k,ispec) = muvstore_inner_core(i,j,k,ispec) * factor_scale_inner_core(1,1,1,iregion_selected)
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo ! END DO INNER CORE
+
+ endif ! END IF(ATTENUATION)
+
+#ifdef USE_MPI
+! allocate seismogram array
+ if (nrec_local > 0) then
+ allocate(seismograms(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
+ if (ier /= 0 ) then
+ print *,"ABORTING can not allocate in specfem3D while allocating seismograms ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+! initialize seismograms
+ seismograms(:,:,:) = 0._CUSTOM_REAL
+ nit_written = 0
+ endif
+#endif
+
+! initialize arrays to zero
+
+ displ_crust_mantle(:,:) = 0._CUSTOM_REAL
+ veloc_crust_mantle(:,:) = 0._CUSTOM_REAL
+ accel_crust_mantle(:,:) = 0._CUSTOM_REAL
+
+ displ_outer_core(:) = 0._CUSTOM_REAL
+ veloc_outer_core(:) = 0._CUSTOM_REAL
+ accel_outer_core(:) = 0._CUSTOM_REAL
+
+ displ_inner_core(:,:) = 0._CUSTOM_REAL
+ veloc_inner_core(:,:) = 0._CUSTOM_REAL
+ accel_inner_core(:,:) = 0._CUSTOM_REAL
+
+! put negligible initial value to avoid very slow underflow trapping
+ if(FIX_UNDERFLOW_PROBLEM) then
+ displ_crust_mantle(:,:) = VERYSMALLVAL
+ displ_outer_core(:) = VERYSMALLVAL
+ displ_inner_core(:,:) = VERYSMALLVAL
+ endif
+
+! store g, rho and dg/dr=dg using normalized radius in lookup table every 100 m
+! get density and velocity from PREM model using dummy doubling flag
+! this assumes that the gravity perturbations are small and smooth
+! and that we can neglect the 3D model and use PREM every 100 m in all cases
+! this is probably a rather reasonable assumption
+
+ ! tabulate d ln(rho)/dr needed for the no gravity fluid potential
+ do int_radius = 1,NRAD_GRAVITY
+ radius = dble(int_radius) / (R_EARTH_KM * 10.d0)
+ idoubling = 0
+ call prem_iso(myrank,radius,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,.false., &
+ ONE_CRUST,.false.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+ d_ln_density_dr_table(int_radius) = drhodr/rho
+ enddo
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' time step: ',sngl(DT),' s'
+ write(IMAIN,*) 'number of time steps: ',NSTEP
+ write(IMAIN,*) 'total simulated time: ',sngl(((NSTEP-1)*DT-t0)/60.d0),' minutes'
+ write(IMAIN,*) 'start time:',sngl(-t0),' seconds'
+ write(IMAIN,*)
+ endif
+
+! define constants for the time integration
+! scaling to make displacement in meters and velocity in meters per second
+ scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
+ scale_displ = R_EARTH
+ scale_veloc = scale_displ / scale_t
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ deltat = sngl(DT/scale_t)
+ else
+ deltat = DT/scale_t
+ endif
+ deltatover2 = 0.5d0*deltat
+ deltatsqover2 = 0.5d0*deltat*deltat
+
+! precompute Runge-Kutta coefficients if attenuation
+ if(ATTENUATION_VAL) then
+ call attenuation_memory_values(tau_sigma_dble, deltat, alphaval_dble, betaval_dble, gammaval_dble)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ alphaval = sngl(alphaval_dble)
+ betaval = sngl(betaval_dble)
+ gammaval = sngl(gammaval_dble)
+ else
+ alphaval = alphaval_dble
+ betaval = betaval_dble
+ gammaval = gammaval_dble
+ endif
+ endif
+
+ if (COMPUTE_AND_STORE_STRAIN) then
+ epsilondev_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
+ epsilondev_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
+ if(FIX_UNDERFLOW_PROBLEM) then
+ epsilondev_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
+ epsilondev_inner_core(:,:,:,:,:) = VERYSMALLVAL
+ endif
+ endif
+
+! clear memory variables if attenuation
+ if(ATTENUATION_VAL) then
+ if (NSPEC_CRUST_MANTLE_ATTENUAT /= NSPEC_CRUST_MANTLE) &
+ call exit_MPI(myrank, 'NSPEC_CRUST_MANTLE_ATTENUAT /= NSPEC_CRUST_MANTLE, exit')
+ if (NSPEC_INNER_CORE_ATTENUATION /= NSPEC_INNER_CORE) &
+ call exit_MPI(myrank, 'NSPEC_INNER_CORE_ATTENUATION /= NSPEC_INNER_CORE, exit')
+
+ R_memory_crust_mantle(:,:,:,:,:,:) = 0._CUSTOM_REAL
+ R_memory_inner_core(:,:,:,:,:,:) = 0._CUSTOM_REAL
+ if(FIX_UNDERFLOW_PROBLEM) then
+ R_memory_crust_mantle(:,:,:,:,:,:) = VERYSMALLVAL
+ R_memory_inner_core(:,:,:,:,:,:) = VERYSMALLVAL
+ endif
+
+ endif
+
+! get information about event name and location for SAC seismograms
+ call get_event_info_parallel(myrank,yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,mb_SAC,ename_SAC,cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,NSOURCES_SAC)
+
+! define correct time steps if restart files
+ if(NUMBER_OF_RUNS < 1 .or. NUMBER_OF_RUNS > 3) stop 'number of restart runs can be 1, 2 or 3'
+ 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 = 1
+ it_end = NSTEP
+
+!
+! s t a r t t i m e i t e r a t i o n s
+!
+
+! synchronize all processes to make sure everybody is ready to start time loop
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+ if(myrank == 0) write(IMAIN,*) 'All processes are synchronized before the time loop'
+#endif
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Starting the time iteration loop...'
+ write(IMAIN,*)
+ endif
+
+! create an empty file to monitor the start of the simulation
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/starttimeloop.txt',status='unknown',action='write')
+ write(IOUT,*) 'hello, starting the time loop'
+ close(IOUT)
+ endif
+
+! get MPI starting time
+#ifdef USE_MPI
+ time_start = MPI_WTIME()
+#else
+ time_start = 0
+#endif
+
+! initialize variables for writing seismograms
+ seismo_offset = it_begin-1
+ seismo_current = 0
+
+! *********************************************************
+! ************* MAIN LOOP OVER THE TIME STEPS *************
+! *********************************************************
+
+ do it = it_begin,it_end
+
+! update position in seismograms
+ seismo_current = seismo_current + 1
+
+! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ displ_crust_mantle(:,i) = displ_crust_mantle(:,i) + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ 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)
+ 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)
+ enddo
+
+! 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 == 5 .or. it == NSTEP) then
+
+! compute maximum of norm of displacement in each slice
+ Usolidnorm = max( &
+ maxval(sqrt(displ_crust_mantle(1,:)**2 + &
+ displ_crust_mantle(2,:)**2 + displ_crust_mantle(3,:)**2)), &
+ maxval(sqrt(displ_inner_core(1,:)**2 + displ_inner_core(2,:)**2 + displ_inner_core(3,:)**2)))
+
+ Ufluidnorm = maxval(abs(displ_outer_core))
+
+! compute the maximum of the maxima for all the slices using an MPI reduction
+#ifdef USE_MPI
+ call MPI_REDUCE(Usolidnorm,Usolidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
+ MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(Ufluidnorm,Ufluidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
+ MPI_COMM_WORLD,ier)
+#else
+ Usolidnorm_all = Usolidnorm
+ Ufluidnorm_all = Ufluidnorm
+#endif
+
+ if(myrank == 0) then
+
+ write(IMAIN,*) 'Time step # ',it
+ write(IMAIN,*) 'Time: ',sngl(((it-1)*DT-t0)/60.d0),' minutes'
+
+! 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
+
+! elapsed time since beginning of the simulation
+#ifdef USE_MPI
+ tCPU = MPI_WTIME() - time_start
+#else
+ tCPU = 0
+#endif
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+#ifdef USE_MPI
+ write(IMAIN,*) 'Elapsed time in seconds = ',tCPU
+ write(IMAIN,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(IMAIN,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+#endif
+
+! compute estimated remaining simulation time
+ t_remain = (NSTEP - it) * (tCPU/dble(it))
+ int_t_remain = int(t_remain)
+ ihours_remain = int_t_remain / 3600
+ iminutes_remain = (int_t_remain - 3600*ihours_remain) / 60
+ iseconds_remain = int_t_remain - 3600*ihours_remain - 60*iminutes_remain
+ write(IMAIN,*) 'Time steps done = ',it,' out of ',NSTEP
+ write(IMAIN,*) 'Time steps remaining = ',NSTEP - it
+#ifdef USE_MPI
+ write(IMAIN,*) 'Estimated remaining time in seconds = ',t_remain
+ write(IMAIN,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_remain,iminutes_remain,iseconds_remain
+#endif
+
+! compute estimated total simulation time
+ t_total = t_remain + tCPU
+ int_t_total = int(t_total)
+ ihours_total = int_t_total / 3600
+ iminutes_total = (int_t_total - 3600*ihours_total) / 60
+ iseconds_total = int_t_total - 3600*ihours_total - 60*iminutes_total
+#ifdef USE_MPI
+ write(IMAIN,*) 'Estimated total run time in seconds = ',t_total
+ write(IMAIN,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_total,iminutes_total,iseconds_total
+#endif
+ write(IMAIN,*) 'We have done ',sngl(100.d0*dble(it)/dble(NSTEP)),'% of that'
+
+#ifdef USE_MPI
+ if(it < 100) then
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '**** BEWARE: the above time estimates are not reliable'
+ write(IMAIN,*) '**** because fewer than 100 iterations have been performed'
+ write(IMAIN,*) '************************************************************'
+ endif
+
+ if(it < NSTEP) then
+
+! get current date
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(1): year
+! time_values(2): month of the year
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+
+! compute date at which the run should finish; for simplicity only minutes
+! are considered, seconds are ignored; in any case the prediction is not
+! accurate down to seconds because of system and network fluctuations
+ year = time_values(1)
+ mon = time_values(2)
+ day = time_values(3)
+ hr = time_values(5)
+ minutes = time_values(6)
+
+! get timestamp in minutes of current date and time
+ call convtime(timestamp,year,mon,day,hr,minutes)
+
+! add remaining minutes
+ timestamp = timestamp + nint(t_remain / 60.d0)
+
+! get date and time of that future timestamp in minutes
+ call invtime(timestamp,year,mon,day,hr,minutes)
+
+! convert to Julian day to get day of the week
+ call calndr(day,mon,year,julian_day_number)
+ day_of_week = idaywk(julian_day_number)
+
+ write(IMAIN,"(' The run will finish approximately on (in local time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
+ weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
+
+! print date and time estimate of end of run in another country.
+! For instance: the code runs at Caltech in California but the person
+! running the code is connected remotely from France, which has 9 hours more
+ if(ADD_TIME_ESTIMATE_ELSEWHERE .and. HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE /= 0) then
+
+! add time difference with that remote location (can be negative)
+ timestamp_remote = timestamp + HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE
+
+! get date and time of that future timestamp in minutes
+ call invtime(timestamp_remote,year_remote,mon_remote,day_remote,hr_remote,minutes_remote)
+
+! convert to Julian day to get day of the week
+ call calndr(day_remote,mon_remote,year_remote,julian_day_number)
+ day_of_week_remote = idaywk(julian_day_number)
+
+ if(HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE > 0) then
+ write(IMAIN,*) 'Adding positive time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
+ else
+ write(IMAIN,*) 'Adding negative time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
+ endif
+ write(IMAIN,*) 'and ',abs(MINUTES_TIME_DIFFERENCE),' minutes to get estimate at a remote location'
+ write(IMAIN, &
+ "(' The run will finish approximately on: ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
+ weekday_name(day_of_week_remote),month_name(mon_remote),day_remote,year_remote,hr_remote,minutes_remote
+ endif
+
+ if(it < 100) then
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '**** BEWARE: the above time estimates are not reliable'
+ write(IMAIN,*) '**** because fewer than 100 iterations have been performed'
+ write(IMAIN,*) '************************************************************'
+ endif
+
+ endif
+#endif
+
+ write(IMAIN,*)
+
+! write time stamp file to give information about progression of simulation
+ write(outputname,"('/timestamp',i6.6)") it
+
+ 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
+ write(IOUT,*)
+
+#ifdef USE_MPI
+ 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)
+ write(IOUT,*)
+#endif
+
+ write(IOUT,*) 'Time steps done = ',it,' out of ',NSTEP
+ write(IOUT,*) 'Time steps remaining = ',NSTEP - it
+#ifdef USE_MPI
+ write(IOUT,*) 'Estimated remaining time in seconds = ',t_remain
+ write(IOUT,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_remain,iminutes_remain,iseconds_remain
+ write(IOUT,*)
+
+ write(IOUT,*) 'Estimated total run time in seconds = ',t_total
+ write(IOUT,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_total,iminutes_total,iseconds_total
+#endif
+ write(IOUT,*) 'We have done ',sngl(100.d0*dble(it)/dble(NSTEP)),'% of that'
+ write(IOUT,*)
+
+#ifdef USE_MPI
+ if(it < NSTEP) then
+
+ write(IOUT,"(' The run will finish approximately on (in local time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
+ weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
+
+! print date and time estimate of end of run in another country.
+! For instance: the code runs at Caltech in California but the person
+! running the code is connected remotely from France, which has 9 hours more
+ if(ADD_TIME_ESTIMATE_ELSEWHERE .and. HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE /= 0) then
+ if(HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE > 0) then
+ write(IOUT,*) 'Adding positive time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
+ else
+ write(IOUT,*) 'Adding negative time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
+ endif
+ write(IOUT,*) 'and ',abs(MINUTES_TIME_DIFFERENCE),' minutes to get estimate at a remote location'
+ write(IOUT, &
+ "(' The run will finish approximately on (in remote time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
+ weekday_name(day_of_week_remote),month_name(mon_remote),day_remote,year_remote,hr_remote,minutes_remote
+ endif
+
+ if(it < 100) then
+ write(IOUT,*)
+ write(IOUT,*) '************************************************************'
+ write(IOUT,*) '**** BEWARE: the above time estimates are not reliable'
+ write(IOUT,*) '**** because fewer than 100 iterations have been performed'
+ write(IOUT,*) '************************************************************'
+ endif
+
+ endif
+#endif
+
+ close(IOUT)
+
+! 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')
+ endif
+ 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)
+ else
+ time = (dble(it-1)*DT-t0)/scale_t
+ endif
+
+! accel_outer_core, div_displ_outer_core are initialized to zero in the following subroutine.
+ call compute_forces_outer_core(d_ln_density_dr_table, &
+ displ_outer_core,accel_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, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,ibool_outer_core)
+
+! ****************************************************
+! ********** 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
+
+! for surface elements exactly on the CMB
+ do ispec2D = 1,NSPEC2D_TOP(IREGION_OUTER_CORE)
+ ispec = ibelm_top_outer_core(ispec2D)
+
+! only for DOFs exactly on the CMB (top of these elements)
+ k = NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! get velocity on the solid side using pointwise matching
+ ispec_selected = ibelm_bottom_crust_mantle(ispec2D)
+
+! corresponding points are located at the bottom of the mantle
+ k_corresp = 1
+ iglob = ibool_crust_mantle(i,j,k_corresp,ispec_selected)
+
+ displ_x = displ_crust_mantle(1,iglob)
+ displ_y = displ_crust_mantle(2,iglob)
+ displ_z = displ_crust_mantle(3,iglob)
+
+! get global point number
+ iglob = ibool_outer_core(i,j,k,ispec)
+
+! get normal on the CMB
+ nx = normal_top_outer_core(1,i,j,ispec2D)
+ ny = normal_top_outer_core(2,i,j,ispec2D)
+ nz = normal_top_outer_core(3,i,j,ispec2D)
+
+! compute dot product
+ displ_n = displ_x*nx + displ_y*ny + displ_z*nz
+
+! formulation with generalized potential
+ weight = jacobian2D_top_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ accel_outer_core(iglob) = accel_outer_core(iglob) + weight*displ_n
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!---
+!--- couple with inner core at the bottom of the outer core
+!---
+
+ if(ACTUALLY_COUPLE_FLUID_ICB .and. NCHUNKS_VAL == 6) then
+
+! for surface elements exactly on the ICB
+ do ispec2D = 1,NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
+ ispec = ibelm_bottom_outer_core(ispec2D)
+
+! only for DOFs exactly on the ICB (bottom of these elements)
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! get velocity on the solid side using pointwise matching
+ ispec_selected = ibelm_top_inner_core(ispec2D)
+
+! corresponding points are located at the bottom of the mantle
+ k_corresp = NGLLZ
+ iglob = ibool_inner_core(i,j,k_corresp,ispec_selected)
+
+ displ_x = displ_inner_core(1,iglob)
+ displ_y = displ_inner_core(2,iglob)
+ displ_z = displ_inner_core(3,iglob)
+
+! get global point number
+ iglob = ibool_outer_core(i,j,k,ispec)
+
+! get normal on the ICB
+ nx = normal_bottom_outer_core(1,i,j,ispec2D)
+ ny = normal_bottom_outer_core(2,i,j,ispec2D)
+ nz = normal_bottom_outer_core(3,i,j,ispec2D)
+
+! compute dot product
+ displ_n = displ_x*nx + displ_y*ny + displ_z*nz
+
+! formulation with generalized potential
+ weight = jacobian2D_bottom_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ accel_outer_core(iglob) = accel_outer_core(iglob) - weight*displ_n
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+! assemble all the contributions between slices using MPI
+
+! outer core
+#ifdef USE_MPI
+ 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,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY_VAL_OC,NCHUNKS)
+#endif
+
+! 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
+
+! ****************************************************
+! 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
+
+ call compute_forces_crust_mantle(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, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_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),COMPUTE_AND_STORE_STRAIN,AM_V)
+
+ call compute_forces_inner_core(displ_inner_core,accel_inner_core,xstore_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,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ R_memory_inner_core,epsilondev_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),COMPUTE_AND_STORE_STRAIN,AM_V)
+
+#ifdef USE_MPI
+
+! add the sources
+ do isource = 1,NSOURCES
+
+! add only if this proc carries the source
+ if(myrank == islice_selected_source(isource)) then
+
+ stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec_selected_source(isource))
+ accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+#else
+!! DK DK use a fictitious source instead
+ stf = 1.d-6 * comp_source_time_function(dble(it-1)*DT-t0,10.d0)
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+ iglob = ibool_crust_mantle(2,2,2,2)
+ accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + stf_used
+#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
+
+! for surface elements exactly on the CMB
+ do ispec2D = 1,NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
+
+ ispec = ibelm_bottom_crust_mantle(ispec2D)
+
+! only for DOFs exactly on the CMB (bottom of these elements)
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! get velocity potential on the fluid side using pointwise matching
+ ispec_selected = ibelm_top_outer_core(ispec2D)
+ k_corresp = NGLLZ
+
+! get normal at the CMB
+ nx = normal_top_outer_core(1,i,j,ispec2D)
+ ny = normal_top_outer_core(2,i,j,ispec2D)
+ nz = normal_top_outer_core(3,i,j,ispec2D)
+
+! get global point number
+! corresponding points are located at the top of the outer core
+ iglob = ibool_outer_core(i,j,NGLLZ,ispec_selected)
+ iglob_mantle = ibool_crust_mantle(i,j,k,ispec)
+
+! compute pressure, taking gravity into account
+ pressure = - RHO_TOP_OC * accel_outer_core(iglob)
+
+! formulation with generalized potential
+ weight = jacobian2D_top_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ accel_crust_mantle(1,iglob_mantle) = accel_crust_mantle(1,iglob_mantle) + weight*nx*pressure
+ 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
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!---
+!--- couple with outer core at the top of the inner core
+!---
+
+ if(ACTUALLY_COUPLE_FLUID_ICB .and. NCHUNKS_VAL == 6) then
+
+! for surface elements exactly on the ICB
+ do ispec2D = 1,NSPEC2D_TOP(IREGION_INNER_CORE)
+
+ ispec = ibelm_top_inner_core(ispec2D)
+
+! only for DOFs exactly on the ICB (top of these elements)
+ k = NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! get velocity potential on the fluid side using pointwise matching
+ ispec_selected = ibelm_bottom_outer_core(ispec2D)
+ k_corresp = 1
+
+! get normal at the ICB
+ nx = normal_bottom_outer_core(1,i,j,ispec2D)
+ ny = normal_bottom_outer_core(2,i,j,ispec2D)
+ nz = normal_bottom_outer_core(3,i,j,ispec2D)
+
+! get global point number
+! corresponding points are located at the bottom of the outer core
+ iglob = ibool_outer_core(i,j,k_corresp,ispec_selected)
+ iglob_inner_core = ibool_inner_core(i,j,k,ispec)
+
+! compute pressure, taking gravity into account
+ pressure = - RHO_BOTTOM_OC * accel_outer_core(iglob)
+
+! formulation with generalized potential
+ weight = jacobian2D_bottom_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ accel_inner_core(1,iglob_inner_core) = accel_inner_core(1,iglob_inner_core) - weight*nx*pressure
+ 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
+
+ enddo
+ enddo
+ enddo
+
+ 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
+#ifdef USE_MPI
+ 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(1),npoin2D_eta_crust_mantle(1), &
+ 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(1),npoin2D_eta_inner_core(1), &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS,NDIM_smaller_buffers)
+#endif
+
+!---
+!--- use buffers to assemble forces with the central cube
+!---
+
+#ifdef USE_MPI
+ if(INCLUDE_CENTRAL_CUBE) then
+ 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, buffer_slices2, ibool_central_cube, &
+ receiver_cube_from_slices, ibool_inner_core, idoubling_inner_core, NSPEC_INNER_CORE, &
+ ibelm_bottom_inner_core, NSPEC2D_BOTTOM(IREGION_INNER_CORE),NGLOB_INNER_CORE,accel_inner_core,NDIM)
+ endif ! end of assembling forces with the central cube
+#endif
+
+ do i=1,NGLOB_CRUST_MANTLE
+ accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmass_crust_mantle(i)
+ accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmass_crust_mantle(i)
+ accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmass_crust_mantle(i)
+ enddo
+
+#ifdef USE_MPI
+!! DK DK turn off the oceans in the serial case because instabilities could arise
+ if(OCEANS) then
+
+! initialize the updates
+ updated_dof_ocean_load(:) = .false.
+
+! for surface elements exactly at the top of the crust (ocean bottom)
+ do ispec2D = 1,NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+
+ ispec = ibelm_top_crust_mantle(ispec2D)
+
+! only for DOFs exactly at the top of the crust (ocean bottom)
+ k = NGLLZ
+
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! get global point number
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+
+! only update once
+ if(.not. updated_dof_ocean_load(iglob)) then
+
+! get normal
+ nx = normal_top_crust_mantle(1,i,j,ispec2D)
+ ny = normal_top_crust_mantle(2,i,j,ispec2D)
+ nz = normal_top_crust_mantle(3,i,j,ispec2D)
+
+! make updated component of right-hand side
+! we divide by rmass_crust_mantle() which is 1 / M
+! we use the total force which includes the Coriolis term above
+ force_normal_comp = (accel_crust_mantle(1,iglob)*nx + &
+ accel_crust_mantle(2,iglob)*ny + &
+ accel_crust_mantle(3,iglob)*nz) / rmass_crust_mantle(iglob)
+
+ additional_term = (rmass_ocean_load(iglob) - rmass_crust_mantle(iglob)) * force_normal_comp
+
+ accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + additional_term * nx
+ accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + additional_term * ny
+ accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + additional_term * nz
+
+! done with this point
+ updated_dof_ocean_load(iglob) = .true.
+
+ endif
+
+ enddo
+ enddo
+ enddo
+ endif
+#else
+ if(mod(it,100) == 0) write(IMAIN,*) 'suppressing OCEANS from the serial test because they can be unstable on a small surface'
+#endif
+
+ do i=1,NGLOB_CRUST_MANTLE
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ enddo
+
+ do i=1,NGLOB_INNER_CORE
+ accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i)
+ accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(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
+#ifdef USE_MPI
+ if (nrec_local > 0) then
+
+ do irec_local = 1,nrec_local
+
+! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+! perform the general interpolation using Lagrange polynomials
+ uxd = ZERO
+ uyd = ZERO
+ uzd = ZERO
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec))
+
+ hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
+
+ uxd = uxd + dble(displ_crust_mantle(1,iglob))*hlagrange
+ uyd = uyd + dble(displ_crust_mantle(2,iglob))*hlagrange
+ uzd = uzd + dble(displ_crust_mantle(3,iglob))*hlagrange
+
+ enddo
+ enddo
+ enddo
+! store North, East and Vertical components
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ seismograms(:,irec_local,seismo_current) = sngl(scale_displ*(nu(:,1,irec)*uxd + &
+ nu(:,2,irec)*uyd + nu(:,3,irec)*uzd))
+ else
+ seismograms(:,irec_local,seismo_current) = scale_displ*(nu(:,1,irec)*uxd + &
+ nu(:,2,irec)*uyd + nu(:,3,irec)*uzd)
+ endif
+
+ enddo
+
+ endif ! nrec_local
+
+! write the current or final seismograms
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,nrec,nrec_local,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,mb_SAC,ename_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NSOURCES_SAC,NPROCTOT, &
+ 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,one_seismogram)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+#endif
+
+!---- end of time iteration loop
+!
+ enddo ! end of main time loop
+
+! close the main output file
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of the simulation'
+ write(IMAIN,*)
+ if(IMAIN /= ISTANDARD_OUTPUT) close(IMAIN)
+ endif
+
+ end subroutine specfem3D
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/specfem3D.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,2342 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! 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.
-!
-!=====================================================================
-
-!=======================================================================!
-! specfem3D is a 3-D spectral-element solver for the Earth. !
-! It uses a mesh generated by program meshfem3D !
-!=======================================================================!
-
-!! DK DK for the merged version
- include 'call_specfem2.f90'
-
- use dyn_array
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
-!!!!!!!!!!! DK DK now in module dyn_array include "constants.h"
- include "precision.h"
-
-! include values created by the mesher
- include "values_from_mesher.h"
-
-! attenuation_model_variables
- type attenuation_model_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(N_SLS) :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- integer, dimension(:), pointer :: interval_Q ! Steps
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer :: Qn ! Number of points
- end type attenuation_model_variables
-
- type (attenuation_model_variables) AM_V
-! attenuation_model_variables
-
-! memory variables and standard linear solids for attenuation
- double precision, dimension(N_SLS) :: tau_sigma_dble
- double precision, dimension(ATT1,ATT2,ATT3,ATT4) :: omsb_crust_mantle_dble, factor_scale_crust_mantle_dble
- double precision, dimension(ATT1,ATT2,ATT3,ATT5) :: omsb_inner_core_dble, factor_scale_inner_core_dble
- real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT4) :: one_minus_sum_beta_crust_mantle, factor_scale_crust_mantle
- real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT5) :: one_minus_sum_beta_inner_core, factor_scale_inner_core
-
- real(kind=CUSTOM_REAL) mul
-
- double precision, dimension(N_SLS) :: alphaval_dble, betaval_dble, gammaval_dble
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval, betaval, gammaval
- real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT4) :: factor_common_crust_mantle
- real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core
- double precision, dimension(N_SLS,ATT1,ATT2,ATT3,ATT4) :: factor_common_crust_mantle_dble
- double precision, dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core_dble
-
- double precision scale_factor,scale_factor_minus_one
- real(kind=CUSTOM_REAL) dist_cr
-
- 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
-
-! for matching with central cube in inner core
- integer, dimension(:), allocatable :: sender_from_slices_to_cube
- integer, dimension(:,:), allocatable :: ibool_central_cube
- double precision, dimension(:,:), allocatable :: buffer_slices,buffer_slices2
- double precision, dimension(:,:,:), allocatable :: buffer_all_cube_from_slices
- integer nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,receiver_cube_from_slices
-
- integer nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core,ndim_assemble
-
-! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
-! for crust/oceans coupling
- integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
-
-! additional mass matrix for ocean load
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
- integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
-
-! flag to mask ocean-bottom degrees of freedom for ocean load
- logical, dimension(NGLOB_CRUST_MANTLE_OCEANS) :: updated_dof_ocean_load
-
- real(kind=CUSTOM_REAL) additional_term,force_normal_comp
-
-! arrays to couple with the fluid regions by pointwise matching
- integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
- integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
-
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
- integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
- integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
-
-! for matching between fluid and solid regions
- integer :: ispec2D,k_corresp,ispec_selected
- real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,nx,ny,nz,displ_n,weight,pressure
-
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-
-! for conversion from x y z to r theta phi
- real(kind=CUSTOM_REAL) rval,thetaval,phival
-
-! ---- arrays to assemble between chunks
-
-! communication pattern for faces between chunks
- integer, dimension(NUMMSGS_FACES_VAL) :: iprocfrom_faces,iprocto_faces,imsg_type
-
-! communication pattern for corners between chunks
- integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
-! indirect addressing for each message for faces and corners of the chunks
-! a given slice can belong to at most one corner and at most two faces
- integer, dimension(NGLOB2DMAX_XY_VAL_CM,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL_OC,NUMFACES_SHARED) :: iboolfaces_outer_core
- integer, dimension(NGLOB2DMAX_XY_VAL_IC,NUMFACES_SHARED) :: iboolfaces_inner_core
-
-! buffers for send and receive between faces of the slices and the chunks
-! we use the same buffers to assemble scalars and vectors because vectors are
-! always three times bigger and therefore scalars can use the first part
-! of the vector buffer in memory even if it has an additional index here
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
- real(kind=CUSTOM_REAL), dimension(NDIM_smaller_buffers,npoin2D_max_all) :: buffer_send_faces,buffer_received_faces
-
-! -------- arrays specific to each region here -----------
-
-! ----------------- crust, mantle and oceans ---------------------
-
-! mesh parameters
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
- xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
- etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
- gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
-
-! arrays for isotropic elements stored only where needed to save space
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
- kappavstore_crust_mantle,muvstore_crust_mantle
-
-! arrays for anisotropic elements stored only where needed to save space
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
- kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
-
-! arrays for full anisotropy only when needed
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
- c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
- c22store_crust_mantle,c23store_crust_mantle,c33store_crust_mantle, &
- c44store_crust_mantle,c55store_crust_mantle,c66store_crust_mantle
-
-! local to global mapping
- integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
-
-! mass matrix
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
-
-! displacement, velocity, acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
- displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
-
-! ----------------- outer core ---------------------
-
-! mesh parameters
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
- xix_outer_core,xiy_outer_core,xiz_outer_core,&
- etax_outer_core,etay_outer_core,etaz_outer_core, &
- gammax_outer_core,gammay_outer_core,gammaz_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
- xstore_outer_core,ystore_outer_core,zstore_outer_core
-
-! mass matrix
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_core
-
-! velocity potential
- real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: displ_outer_core, &
- veloc_outer_core,accel_outer_core
-
-! ----------------- inner core ---------------------
-
-! mesh parameters
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
- xix_inner_core,xiy_inner_core,xiz_inner_core,&
- etax_inner_core,etay_inner_core,etaz_inner_core, &
- gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
- kappavstore_inner_core,muvstore_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: &
- xstore_inner_core,ystore_inner_core,zstore_inner_core
-
-! arrays for inner-core anisotropy only when needed
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
- c11store_inner_core,c33store_inner_core,c12store_inner_core, &
- c13store_inner_core,c44store_inner_core
-
-! local to global mapping
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
-
-! mass matrix
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
-
-! displacement, velocity, acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
- displ_inner_core,veloc_inner_core,accel_inner_core
-
-! Newmark time scheme parameters and non-dimensionalization
- real(kind=CUSTOM_REAL) time,deltat,deltatover2,deltatsqover2
- double precision scale_t,scale_displ,scale_veloc
-
- integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
- integer npoin2D_faces_outer_core(NUMFACES_SHARED)
- integer npoin2D_faces_inner_core(NUMFACES_SHARED)
-
-! parameters for the source
- integer it,isource
- integer yr,jda,ho,mi
- real(kind=CUSTOM_REAL) stf_used
- double precision sec,stf
- double precision t0
- double precision, external :: comp_source_time_function
-
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
- real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
- double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
- double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
- double precision, dimension(NSOURCES) :: t_cmt,hdur,hdur_gaussian
- double precision, dimension(NSOURCES) :: theta_source,phi_source
- double precision, dimension(NDIM,NDIM,NSOURCES) :: nu_source
-
-! receiver information
- integer :: nrec,nrec_local,nrec_tot_found,irec_local
- double precision :: hlagrange
- integer, dimension(:), allocatable :: number_receiver_global
- character(len=150) :: STATIONS,rec_filename
-
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
- integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
- double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
- double precision, dimension(NDIM,NDIM,nrec) :: nu
- double precision, dimension(nrec) :: stlat,stlon,stele
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
-! seismograms
- integer it_begin,it_end,nit_written
- double precision uxd, uyd, uzd
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms
- integer :: seismo_offset, seismo_current
-
- integer i,j,k,ispec,irec,iglob,iglob_mantle,iglob_inner_core
-
-! number of faces between chunks
- integer NUM_FACES,NUMMSGS_FACES
-
-! number of corners between chunks
- integer NCORNERSCHUNKS
-
-! number of message types
- integer NUM_MSG_TYPES
-
-! indirect addressing for each corner of the chunks
- integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
- integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
- integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
-
-! buffers for send and receive between corners of the chunks
- real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL_CM) :: buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar
-! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB1D_RADIAL_CM + NGLOB1D_RADIAL_IC) :: &
- buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector
-
-! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll,wxgll
- double precision, dimension(NGLLY) :: yigll,wygll
- double precision, dimension(NGLLZ) :: zigll,wzgll
-
-! product of weights for gravity term
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
-
-! array with derivatives of Lagrange polynomials and precalculated products
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
-! Lagrange interpolators at receivers
- double precision, dimension(NGLLX) :: hxir,hpxir
- double precision, dimension(NGLLY) :: hpetar,hetar
- double precision, dimension(NGLLZ) :: hgammar,hpgammar
- double precision, dimension(:,:), allocatable :: hxir_store,hetar_store,hgammar_store
-
-! 2-D addressing and buffers for summation between slices
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
-
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
-
- integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
- integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
-
-! for addressing of the slices
- integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
- integer, dimension(0:NPROCTOT_VAL-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
-
-! proc numbers for MPI
- integer myrank,sizeprocs,ier,errorcode
-
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
-
-!! DK DK added this to reduce the size of the buffers
- integer :: npoin2D_max_all,NDIM_smaller_buffers
-
- integer ichunk,iproc_xi,iproc_eta
- integer NPROC_ONE_DIRECTION
-
-! maximum of the norm of the displacement and of the potential in the fluid
- real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all,Ufluidnorm,Ufluidnorm_all
-
-! timer MPI
- integer :: ihours,iminutes,iseconds,int_tCPU, &
- ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
- ihours_total,iminutes_total,iseconds_total,int_t_total
-
- double precision :: time_start,tCPU,t_remain,t_total
-
-! to determine date and time at which the run will finish
- character(len=8) datein
- character(len=10) timein
- character(len=5) :: zone
- integer, dimension(8) :: time_values
- character(len=3), dimension(12) :: month_name
- character(len=3), dimension(0:6) :: weekday_name
- data month_name /'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/
- data weekday_name /'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'/
- integer :: year,mon,day,hr,minutes,timestamp,julian_day_number,day_of_week, &
- timestamp_remote,year_remote,mon_remote,day_remote,hr_remote,minutes_remote,day_of_week_remote
- integer, external :: idaywk
-
-! 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,RMOHO_FICTITIOUS_IN_MESHER, &
- 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, &
- ifirst_layer_aniso,ilast_layer_aniso
-
- 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
-
- logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- 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
-
- character(len=150) OUTPUT_FILES,MODEL
-
-! parameters deduced from parameters read from file
- integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, external :: err_occurred
-
- logical COMPUTE_AND_STORE_STRAIN
-
-! for SAC headers for seismograms
- integer NSOURCES_SAC,yr_SAC,jda_SAC,ho_SAC,mi_SAC
- real mb_SAC
- double precision t_cmt_SAC,elat_SAC,elon_SAC,depth_SAC,cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,sec_SAC
- character(len=12) ename_SAC
-
-! this for all the regions
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC_computed, &
- 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_computed
-
-! lookup table every km for gravity
- integer int_radius,idoubling
- double precision radius,rho,drhodr,vp,vs,Qkappa,Qmu
- double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
-
-! names of the data files for all the processors in MPI
- character(len=150) outputname
-
- integer iregion_selected
-
-! 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_layer_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
- logical :: CASE_3D
-
-! arrays for BCAST
- integer, dimension(40) :: bcast_integer
- double precision, dimension(30) :: bcast_double_precision
- logical, dimension(33) :: bcast_logical
-
- 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
-
-! allocate this automatic array in the memory stack to avoid memory fragmentation with "allocate()"
- real(kind=CUSTOM_REAL), dimension(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: one_seismogram
-
-! ************** PROGRAM STARTS HERE **************
-
-! set up GLL points, weights and derivation matrices
- call define_derivation_matrices(xigll,yigll,zigll,wxgll,wygll,wzgll, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube)
-
-!! DK DK recompute arrays here for merged version
- call recompute_missing_arrays(myrank, &
- 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, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xelm_store_crust_mantle,yelm_store_crust_mantle,zelm_store_crust_mantle, &
- ibool_crust_mantle,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
- xigll,yigll,zigll)
-
- call recompute_missing_arrays(myrank, &
- 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, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- xelm_store_outer_core,yelm_store_outer_core,zelm_store_outer_core, &
- ibool_outer_core,NSPEC_OUTER_CORE,NGLOB_OUTER_CORE, &
- xigll,yigll,zigll)
-
- call recompute_missing_arrays(myrank, &
- 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, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- xelm_store_inner_core,yelm_store_inner_core,zelm_store_inner_core, &
- ibool_inner_core,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- xigll,yigll,zigll)
-
-!! DK DK for merged version, deallocate arrays that have become useless
- deallocate(xelm_store_crust_mantle)
- deallocate(yelm_store_crust_mantle)
- deallocate(zelm_store_crust_mantle)
-
- deallocate(xelm_store_outer_core)
- deallocate(yelm_store_outer_core)
- deallocate(zelm_store_outer_core)
-
- deallocate(xelm_store_inner_core)
- deallocate(yelm_store_inner_core)
- deallocate(zelm_store_inner_core)
-
- if (myrank == 0) then
-
-! 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,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,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC_computed, &
- NSPEC2D_XI, &
- NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB_computed, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_layer_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,ifirst_layer_aniso,ilast_layer_aniso,.false.)
-
- if(err_occurred() /= 0) call exit_MPI(myrank,'an error occurred while reading the parameter file')
-
- bcast_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,RMOHO_FICTITIOUS_IN_MESHER, &
- 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,NPROC,NPROCTOT, &
- NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,ifirst_layer_aniso,ilast_layer_aniso/)
-
- bcast_logical = (/TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
- TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ATTENUATION, &
- ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE/)
-
- 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, &
- 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/)
-
- endif
-
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(bcast_integer,40,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(bcast_double_precision,30,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(bcast_logical,33,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(MODEL,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(ner,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(ratio_sampling_array,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(doubling_index,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(r_bottom,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(r_top,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(rmins,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(this_layer_has_a_doubling,MAX_NUMBER_OF_MESH_LAYERS,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(NSPEC_computed,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2D_XI,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2D_ETA,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2D_BOTTOM,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC2D_TOP,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NSPEC1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NGLOB1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NGLOB2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NGLOB2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(NGLOB_computed,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(DIFF_NSPEC1D_RADIAL,NB_SQUARE_CORNERS*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(DIFF_NSPEC2D_ETA,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(DIFF_NSPEC2D_XI,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- if (myrank /=0) then
-
- MIN_ATTENUATION_PERIOD = bcast_integer(1)
- MAX_ATTENUATION_PERIOD = bcast_integer(2)
- NER_CRUST = bcast_integer(3)
- NER_80_MOHO = bcast_integer(4)
- NER_220_80 = bcast_integer(5)
- NER_400_220 = bcast_integer(6)
- NER_600_400 = bcast_integer(7)
- NER_670_600 = bcast_integer(8)
- NER_771_670 = bcast_integer(9)
- NER_TOPDDOUBLEPRIME_771 = bcast_integer(10)
- NER_CMB_TOPDDOUBLEPRIME = bcast_integer(11)
- NER_OUTER_CORE = bcast_integer(12)
- NER_TOP_CENTRAL_CUBE_ICB = bcast_integer(13)
- NEX_XI = bcast_integer(14)
- NEX_ETA = bcast_integer(15)
- RMOHO_FICTITIOUS_IN_MESHER = bcast_integer(16)
- NPROC_XI = bcast_integer(17)
- NPROC_ETA = bcast_integer(18)
- NTSTEP_BETWEEN_OUTPUT_SEISMOS = bcast_integer(19)
- NTSTEP_BETWEEN_READ_ADJSRC = bcast_integer(20)
- NSTEP = bcast_integer(21)
- NSOURCES = bcast_integer(22)
- NTSTEP_BETWEEN_FRAMES = bcast_integer(23)
- NTSTEP_BETWEEN_OUTPUT_INFO = bcast_integer(24)
- NUMBER_OF_RUNS = bcast_integer(25)
- NUMBER_OF_THIS_RUN = bcast_integer(26)
- NCHUNKS = bcast_integer(27)
- SIMULATION_TYPE = bcast_integer(28)
- REFERENCE_1D_MODEL = bcast_integer(29)
- THREE_D_MODEL = bcast_integer(30)
- NPROC = bcast_integer(31)
- NPROCTOT = bcast_integer(32)
- NEX_PER_PROC_XI = bcast_integer(33)
- NEX_PER_PROC_ETA = bcast_integer(34)
- ratio_divide_central_cube = bcast_integer(35)
- MOVIE_VOLUME_TYPE = bcast_integer(36)
- MOVIE_START = bcast_integer(37)
- MOVIE_STOP = bcast_integer(38)
- ifirst_layer_aniso = bcast_integer(39)
- ilast_layer_aniso = bcast_integer(40)
-
- TRANSVERSE_ISOTROPY = bcast_logical(1)
- ANISOTROPIC_3D_MANTLE = bcast_logical(2)
- ANISOTROPIC_INNER_CORE = bcast_logical(3)
- CRUSTAL = bcast_logical(4)
- ELLIPTICITY = bcast_logical(5)
- GRAVITY = bcast_logical(6)
- ONE_CRUST = bcast_logical(7)
- ROTATION = bcast_logical(8)
- ISOTROPIC_3D_MANTLE = bcast_logical(9)
- TOPOGRAPHY = bcast_logical(10)
- OCEANS = bcast_logical(11)
- MOVIE_SURFACE = bcast_logical(12)
- MOVIE_VOLUME = bcast_logical(13)
- MOVIE_COARSE = bcast_logical(14)
- ATTENUATION_3D = bcast_logical(15)
- RECEIVERS_CAN_BE_BURIED = bcast_logical(16)
- PRINT_SOURCE_TIME_FUNCTION = bcast_logical(17)
- SAVE_MESH_FILES = bcast_logical(18)
- ATTENUATION = bcast_logical(19)
- ABSORBING_CONDITIONS = bcast_logical(20)
- INCLUDE_CENTRAL_CUBE = bcast_logical(21)
- INFLATE_CENTRAL_CUBE = bcast_logical(22)
- SAVE_FORWARD = bcast_logical(23)
- CASE_3D = bcast_logical(24)
- OUTPUT_SEISMOS_ASCII_TEXT = bcast_logical(25)
- OUTPUT_SEISMOS_SAC_ALPHANUM = bcast_logical(26)
- OUTPUT_SEISMOS_SAC_BINARY = bcast_logical(27)
- ROTATE_SEISMOGRAMS_RT = bcast_logical(28)
- CUT_SUPERBRICK_XI = bcast_logical(29)
- CUT_SUPERBRICK_ETA = bcast_logical(30)
- WRITE_SEISMOGRAMS_BY_MASTER = bcast_logical(31)
- SAVE_ALL_SEISMOS_IN_ONE_FILE = bcast_logical(32)
- USE_BINARY_FOR_LARGE_FILE = bcast_logical(33)
-
- DT = bcast_double_precision(1)
- ANGULAR_WIDTH_XI_IN_DEGREES = bcast_double_precision(2)
- ANGULAR_WIDTH_ETA_IN_DEGREES = bcast_double_precision(3)
- CENTER_LONGITUDE_IN_DEGREES = bcast_double_precision(4)
- CENTER_LATITUDE_IN_DEGREES = bcast_double_precision(5)
- GAMMA_ROTATION_AZIMUTH = bcast_double_precision(6)
- ROCEAN = bcast_double_precision(7)
- RMIDDLE_CRUST = bcast_double_precision(8)
- RMOHO = bcast_double_precision(9)
- R80 = bcast_double_precision(10)
- R120 = bcast_double_precision(11)
- R220 = bcast_double_precision(12)
- R400 = bcast_double_precision(13)
- R600 = bcast_double_precision(14)
- R670 = bcast_double_precision(15)
- R771 = bcast_double_precision(16)
- RTOPDDOUBLEPRIME = bcast_double_precision(17)
- RCMB = bcast_double_precision(18)
- RICB = bcast_double_precision(19)
- R_CENTRAL_CUBE = bcast_double_precision(20)
- RHO_TOP_OC = bcast_double_precision(21)
- RHO_BOTTOM_OC = bcast_double_precision(22)
- RHO_OCEANS = bcast_double_precision(23)
- HDUR_MOVIE = bcast_double_precision(24)
- MOVIE_TOP = bcast_double_precision(25)
- MOVIE_BOTTOM = bcast_double_precision(26)
- MOVIE_WEST = bcast_double_precision(27)
- MOVIE_EAST = bcast_double_precision(28)
- MOVIE_NORTH = bcast_double_precision(29)
- MOVIE_SOUTH = bcast_double_precision(30)
-
- endif
-
-! check simulation pararmeters
- if (SIMULATION_TYPE /= 1 .and. SIMULATION_TYPE /= 2 .and. SIMULATION_TYPE /= 3) &
- call exit_MPI(myrank, 'SIMULATION_TYPE could be only 1, 2, or 3')
-
- 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 (ATTENUATION_VAL .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
- COMPUTE_AND_STORE_STRAIN = .true.
- else
- COMPUTE_AND_STORE_STRAIN = .false.
- endif
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! open main output file, only written to by process 0
- if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
- open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_solver.txt',status='unknown',action='write')
-
- if(myrank == 0) then
-
- write(IMAIN,*)
- write(IMAIN,*) '******************************'
- write(IMAIN,*) '**** Specfem3D MPI Solver ****'
- write(IMAIN,*) '******************************'
- write(IMAIN,*)
- write(IMAIN,*)
-
- if(FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field'
-
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
- write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
- write(IMAIN,*)
-
- write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
- write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
- write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
- write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
- write(IMAIN,*) 'There are ',NCHUNKS,' chunks'
- write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in all the chunks'
-
- write(IMAIN,*)
- write(IMAIN,*) 'NDIM = ',NDIM
- write(IMAIN,*)
- write(IMAIN,*) 'NGLLX = ',NGLLX
- write(IMAIN,*) 'NGLLY = ',NGLLY
- write(IMAIN,*) 'NGLLZ = ',NGLLZ
- write(IMAIN,*)
-
-! write information about precision used for floating-point operations
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IMAIN,*) 'using single precision for the calculations'
- else
- write(IMAIN,*) 'using double precision for the calculations'
- endif
- write(IMAIN,*)
- write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
- write(IMAIN,*)
-
- endif
-
-! check that the code is running with the requested nb of processes
- if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
-
-! check that the code has been compiled with the right values
- if (NSPEC_computed(IREGION_CRUST_MANTLE) /= NSPEC_CRUST_MANTLE) then
- write(IMAIN,*) NSPEC_computed(IREGION_CRUST_MANTLE),NSPEC_CRUST_MANTLE
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 1')
- endif
- if (NSPEC_computed(IREGION_OUTER_CORE) /= NSPEC_OUTER_CORE) then
- write(IMAIN,*) NSPEC_computed(IREGION_OUTER_CORE),NSPEC_OUTER_CORE
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 2')
- endif
- if (NSPEC_computed(IREGION_INNER_CORE) /= NSPEC_INNER_CORE) then
- write(IMAIN,*) NSPEC_computed(IREGION_INNER_CORE),NSPEC_INNER_CORE
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 3')
- endif
- if (ATTENUATION_3D .NEQV. ATTENUATION_3D_VAL) then
- write(IMAIN,*) ATTENUATION_3D,ATTENUATION_3D_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 4')
- endif
- if (NCHUNKS /= NCHUNKS_VAL) then
- write(IMAIN,*) NCHUNKS,NCHUNKS_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 6')
- endif
- if (GRAVITY .NEQV. GRAVITY_VAL) then
- write(IMAIN,*) GRAVITY,GRAVITY_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 7')
- endif
- if (ROTATION .NEQV. ROTATION_VAL) then
- write(IMAIN,*) ROTATION,ROTATION_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 8')
- endif
- if (ATTENUATION .NEQV. ATTENUATION_VAL) then
- write(IMAIN,*) ATTENUATION,ATTENUATION_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 9')
- endif
- if (ELLIPTICITY .NEQV. ELLIPTICITY_VAL) then
- write(IMAIN,*) ELLIPTICITY,ELLIPTICITY_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 10')
- endif
- if (NPROCTOT /= NPROCTOT_VAL) then
- write(IMAIN,*) NPROCTOT,NPROCTOT_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 11')
- endif
- if (NEX_XI /= NEX_XI_VAL) then
- write(IMAIN,*) NEX_XI,NEX_XI_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 12')
- endif
- if (NEX_ETA /= NEX_ETA_VAL) then
- write(IMAIN,*) NEX_ETA,NEX_ETA_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 13')
- endif
- if (TRANSVERSE_ISOTROPY .NEQV. TRANSVERSE_ISOTROPY_VAL) then
- write(IMAIN,*) TRANSVERSE_ISOTROPY,TRANSVERSE_ISOTROPY_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 14')
- endif
- if (ANISOTROPIC_3D_MANTLE .NEQV. ANISOTROPIC_3D_MANTLE_VAL) then
- write(IMAIN,*) ANISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 15')
- endif
- if (ANISOTROPIC_INNER_CORE .NEQV. ANISOTROPIC_INNER_CORE_VAL) then
- write(IMAIN,*) ANISOTROPIC_INNER_CORE,ANISOTROPIC_INNER_CORE_VAL
- call exit_MPI(myrank,'error in compiled parameters, please recompile solver 16')
- endif
-
-! determine chunk number and local slice coordinates using addressing
- ichunk = ichunk_slice(myrank)
- iproc_xi = iproc_xi_slice(myrank)
- iproc_eta = iproc_eta_slice(myrank)
-
-! make ellipticity
- if(ELLIPTICITY_VAL) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
-
-! number of corners and faces shared between chunks and number of message types
- if(NCHUNKS_VAL == 1 .or. NCHUNKS_VAL == 2) then
- NCORNERSCHUNKS = 1
- NUM_FACES = 1
- NUM_MSG_TYPES = 1
- else if(NCHUNKS_VAL == 3) then
- NCORNERSCHUNKS = 1
- NUM_FACES = 1
- NUM_MSG_TYPES = 3
- else if(NCHUNKS_VAL == 6) then
- NCORNERSCHUNKS = 8
- NUM_FACES = 4
- NUM_MSG_TYPES = 3
- else
- call exit_MPI(myrank,'number of chunks must be either 1, 2, 3 or 6')
- endif
-
-! if more than one chunk then same number of processors in each direction
- NPROC_ONE_DIRECTION = NPROC_XI
-
-! total number of messages corresponding to these common faces
- NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
-
-! check that the number of points in this slice is correct
- if(minval(ibool_crust_mantle) /= 1 .or. maxval(ibool_crust_mantle) /= NGLOB_CRUST_MANTLE) &
- call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in crust and mantle')
-
- if(minval(ibool_outer_core) /= 1 .or. maxval(ibool_outer_core) /= NGLOB_OUTER_CORE) &
- call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in outer core')
-
- if(minval(ibool_inner_core) /= 1 .or. maxval(ibool_inner_core) /= NGLOB_INNER_CORE) &
- call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in inner core')
-
-! check that there is at least one receiver
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'Total number of receivers = ', nrec
- write(IMAIN,*)
- endif
- if(nrec < 1) call exit_MPI(myrank,'need at least one receiver')
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! locate sources in the mesh
- call locate_sources(NSOURCES,myrank,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,ibool_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xigll,yigll,zigll,NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
- sec,t_cmt,yr,jda,ho,mi,theta_source,phi_source, &
- NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- islice_selected_source,ispec_selected_source, &
- xi_source,eta_source,gamma_source, nu_source,&
- rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION)
-
- if(minval(t_cmt) /= 0.) call exit_MPI(myrank,'one t_cmt must be zero, others must be positive')
-
-! convert the half duration for triangle STF to the one for gaussian STF
- hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
-
-! define t0 as the earliest start time
- t0 = - 1.5d0*minval(t_cmt-hdur)
-
-! --------- receivers ---------------
-
- rec_filename = 'DATA/STATIONS'
- call get_value_string(STATIONS, 'solver.STATIONS', rec_filename)
-
-! locate receivers in the crust in the mesh
- call locate_receivers(myrank,DT,NSTEP,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,ibool_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- xigll,yigll,zigll,trim(rec_filename), &
- nrec,islice_selected_rec,ispec_selected_rec, &
- xi_receiver,eta_receiver,gamma_receiver,station_name,network_name,stlat,stlon,stele,nu, &
- yr,jda,ho,mi,sec, &
- NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
- theta_source(1),phi_source(1),rspl,espl,espl2,nspl,ibathy_topo,RECEIVERS_CAN_BE_BURIED,NCHUNKS)
-
-!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
- do isource = 1,NSOURCES
-
-! check that the source slice number is okay
- if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROCTOT-1) &
- call exit_MPI(myrank,'something is wrong with the source slice number')
-
-! compute source arrays in source slice
- if(myrank == islice_selected_source(isource)) then
- call compute_arrays_source(ispec_selected_source(isource), &
- xi_source(isource),eta_source(isource),gamma_source(isource),sourcearray, &
- Mxx(isource),Myy(isource),Mzz(isource),Mxy(isource),Mxz(isource),Myz(isource), &
- 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, &
- xigll,yigll,zigll,NSPEC_CRUST_MANTLE)
- sourcearrays(isource,:,:,:,:) = sourcearray(:,:,:,:)
- endif
- enddo
-
-!--- select local receivers
-
-! count number of receivers located in this slice
- nrec_local = 0
- do irec = 1,nrec
- if(myrank == islice_selected_rec(irec)) nrec_local = nrec_local + 1
- enddo
-
- if (nrec_local > 0) then
-
-! allocate Lagrange interpolators for receivers
- allocate(hxir_store(nrec_local,NGLLX),STAT=ier)
- if (ier /= 0 ) then
- print *,"ABORTING can not allocate in specfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(hetar_store(nrec_local,NGLLY),STAT=ier)
- if (ier /= 0 ) then
- print *,"ABORTING can not allocate in specfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(hgammar_store(nrec_local,NGLLZ),STAT=ier)
- if (ier /= 0 ) then
- print *,"ABORTING can not allocate in specfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-! define local to global receiver numbering mapping
- allocate(number_receiver_global(nrec_local),STAT=ier)
- if (ier /= 0 ) then
- print *,"ABORTING can not allocate in specfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- irec_local = 0
- do irec = 1,nrec
- if(myrank == islice_selected_rec(irec)) then
- irec_local = irec_local + 1
- number_receiver_global(irec_local) = irec
- endif
- enddo
-
-! define and store Lagrange interpolators at all the receivers
- do irec_local = 1,nrec_local
- irec = number_receiver_global(irec_local)
- call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
- call lagrange_any(eta_receiver(irec),NGLLY,yigll,hetar,hpetar)
- call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
- hxir_store(irec_local,:) = hxir(:)
- hetar_store(irec_local,:) = hetar(:)
- hgammar_store(irec_local,:) = hgammar(:)
- enddo
-
- endif ! nrec_local
-
-! check that the sum of the number of receivers in each slice is nrec
- call MPI_REDUCE(nrec_local,nrec_tot_found,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'found a total of ',nrec_tot_found,' receivers in all the slices'
- if(nrec_tot_found /= nrec) then
- call exit_MPI(myrank,'problem when dispatching the receivers')
- else
- write(IMAIN,*) 'this total is okay'
- endif
- endif
-
- if(myrank == 0) then
-
- write(IMAIN,*)
- write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP
- write(IMAIN,*)
-
- write(IMAIN,*)
- write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
- write(IMAIN,*)
-
- if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
-
- write(IMAIN,*)
- if(ELLIPTICITY_VAL) then
- write(IMAIN,*) 'incorporating ellipticity'
- else
- write(IMAIN,*) 'no ellipticity'
- endif
-
- write(IMAIN,*)
- if(TOPOGRAPHY) then
- write(IMAIN,*) 'incorporating surface topography'
- else
- write(IMAIN,*) 'no surface topography'
- endif
-
- write(IMAIN,*)
- if(ISOTROPIC_3D_MANTLE) then
- write(IMAIN,*) 'incorporating 3-D lateral variations'
- else
- write(IMAIN,*) 'no 3-D lateral variations'
- endif
-
- write(IMAIN,*)
- if(CRUSTAL) then
- write(IMAIN,*) 'incorporating crustal variations'
- else
- write(IMAIN,*) 'no crustal variations'
- endif
-
- write(IMAIN,*)
- if(ONE_CRUST) then
- write(IMAIN,*) 'using one layer only in PREM crust'
- else
- write(IMAIN,*) 'using unmodified 1D crustal model with two layers'
- endif
-
- write(IMAIN,*)
- if(GRAVITY_VAL) then
- write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)'
- else
- write(IMAIN,*) 'no self-gravitation'
- endif
-
- write(IMAIN,*)
- if(ROTATION_VAL) then
- write(IMAIN,*) 'incorporating rotation'
- else
- write(IMAIN,*) 'no rotation'
- endif
-
- write(IMAIN,*)
- if(TRANSVERSE_ISOTROPY_VAL) then
- write(IMAIN,*) 'incorporating transverse isotropy'
- else
- write(IMAIN,*) 'no transverse isotropy'
- endif
-
- write(IMAIN,*)
- if(ATTENUATION_VAL) then
- write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
- if(ATTENUATION_3D_VAL) write(IMAIN,*) 'using 3D attenuation'
- else
- write(IMAIN,*) 'no attenuation'
- endif
-
- write(IMAIN,*)
- if(OCEANS) then
- write(IMAIN,*) 'incorporating the oceans using equivalent load'
- else
- write(IMAIN,*) 'no oceans'
- endif
-
- write(IMAIN,*)
- if(ANISOTROPIC_INNER_CORE_VAL) then
- write(IMAIN,*) 'incorporating anisotropic inner core'
- else
- write(IMAIN,*) 'no inner-core anisotropy'
- endif
-
- write(IMAIN,*)
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- write(IMAIN,*) 'incorporating anisotropic mantle'
- else
- write(IMAIN,*) 'no general mantle anisotropy'
- endif
- write(IMAIN,*)
- write(IMAIN,*)
- write(IMAIN,*)
-
- endif
-
-! the mass matrix needs to be assembled with MPI here once and for all
-
-! ocean load
- if (OCEANS) then
- call assemble_MPI_scalar(myrank,rmass_ocean_load,NGLOB_CRUST_MANTLE, &
- 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, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
- buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY_VAL_CM,NCHUNKS)
- endif
-
-! crust and mantle
- call assemble_MPI_scalar(myrank,rmass_crust_mantle,NGLOB_CRUST_MANTLE, &
- 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, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
- buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY_VAL_CM,NCHUNKS)
-
-! outer core
- call assemble_MPI_scalar(myrank,rmass_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,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
- buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY_VAL_OC,NCHUNKS)
-
-! inner core
- call assemble_MPI_scalar(myrank,rmass_inner_core,NGLOB_INNER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- 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,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
- buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE),NGLOB2DMAX_XY_VAL_IC,NCHUNKS)
-
- if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix'
-
-!
-!--- handle the communications with the central cube if it was included in the mesh
-!
- if(INCLUDE_CENTRAL_CUBE) then
-
- if(myrank == 0) write(IMAIN,*) 'including central cube'
-
-! compute number of messages to expect in cube as well as their size
- call comp_central_cube_buffer_size(iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM(IREGION_INNER_CORE), &
- nb_msgs_theor_in_cube,npoin2D_cube_from_slices)
-
-! this value is used for dynamic memory allocation, therefore make sure it is never zero
- if(nb_msgs_theor_in_cube > 0) then
- non_zero_nb_msgs_theor_in_cube = nb_msgs_theor_in_cube
- else
- non_zero_nb_msgs_theor_in_cube = 1
- endif
-
-! allocate buffers for cube and slices
- allocate(sender_from_slices_to_cube(non_zero_nb_msgs_theor_in_cube),STAT=ier)
- if (ier /= 0 ) then
- print *,"ABORTING can not allocate in specfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(buffer_all_cube_from_slices(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM),STAT=ier)
- if (ier /= 0 ) then
- print *,"ABORTING can not allocate in specfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(buffer_slices(npoin2D_cube_from_slices,NDIM),STAT=ier)
- if (ier /= 0 ) then
- print *,"ABORTING can not allocate in specfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(buffer_slices2(npoin2D_cube_from_slices,NDIM),STAT=ier)
- if (ier /= 0 ) then
- print *,"ABORTING can not allocate in specfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
- allocate(ibool_central_cube(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices),STAT=ier)
- if (ier /= 0 ) then
- print *,"ABORTING can not allocate in specfem3D ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-
-! create buffers to assemble with the central cube
- call create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
- NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- NSPEC2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NSPEC2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
- NSPEC2D_BOTTOM(IREGION_INNER_CORE), &
- addressing,ibool_inner_core,idoubling_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
- ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
- nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices, &
- receiver_cube_from_slices,sender_from_slices_to_cube,ibool_central_cube, &
- buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
-
- if(myrank == 0) write(IMAIN,*) 'done including central cube'
-
-! the mass matrix to assemble is a scalar, not a vector
- ndim_assemble = 1
-
-! use these buffers to assemble the inner core mass matrix with the central cube
- 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, buffer_slices2, ibool_central_cube, &
- receiver_cube_from_slices, ibool_inner_core, idoubling_inner_core, NSPEC_INNER_CORE, &
- ibelm_bottom_inner_core, NSPEC2D_BOTTOM(IREGION_INNER_CORE),NGLOB_INNER_CORE,rmass_inner_core,ndim_assemble)
-
-! suppress fictitious mass matrix elements in central cube
-! because the slices do not compute all their spectral elements in the cube
- where(rmass_inner_core(:) <= 0.) rmass_inner_core = 1.
-
- endif ! end of handling the communications with the central cube
-
-! check that all the mass matrices are positive
- if(minval(rmass_crust_mantle) <= 0. .or. minval(rmass_inner_core) <= 0. .or. minval(rmass_outer_core) <= 0.) &
- call exit_MPI(myrank,'negative mass matrix term for at least one region')
-
- if(OCEANS) then
- if(minval(rmass_ocean_load) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the oceans')
- endif
-
-! for efficiency, invert final mass matrix once and for all on each slice
- if(OCEANS) rmass_ocean_load = 1._CUSTOM_REAL / rmass_ocean_load
- rmass_crust_mantle = 1._CUSTOM_REAL / rmass_crust_mantle
- rmass_outer_core = 1._CUSTOM_REAL / rmass_outer_core
- rmass_inner_core = 1._CUSTOM_REAL / rmass_inner_core
-
-! change x, y, z to r, theta and phi once and for all
-! IMPROVE dangerous: old name kept (xstore ystore zstore) for new values
-
-! convert in the crust and mantle
- do iglob = 1,NGLOB_CRUST_MANTLE
- call xyz_2_rthetaphi(xstore_crust_mantle(iglob), &
- ystore_crust_mantle(iglob),zstore_crust_mantle(iglob),rval,thetaval,phival)
- xstore_crust_mantle(iglob) = rval
- ystore_crust_mantle(iglob) = thetaval
- zstore_crust_mantle(iglob) = phival
- enddo
-
-! convert in the outer core
- do iglob = 1,NGLOB_OUTER_CORE
- call xyz_2_rthetaphi(xstore_outer_core(iglob), &
- ystore_outer_core(iglob),zstore_outer_core(iglob),rval,thetaval,phival)
- xstore_outer_core(iglob) = rval
- ystore_outer_core(iglob) = thetaval
- zstore_outer_core(iglob) = phival
- enddo
-
-! convert in the inner core
- do iglob = 1,NGLOB_INNER_CORE
- call xyz_2_rthetaphi(xstore_inner_core(iglob), &
- ystore_inner_core(iglob),zstore_inner_core(iglob),rval,thetaval,phival)
- xstore_inner_core(iglob) = rval
- ystore_inner_core(iglob) = thetaval
- zstore_inner_core(iglob) = phival
- enddo
-
- if(ATTENUATION_VAL) then
-
-! get and store PREM attenuation model
-
- call get_attenuation_model_1D(myrank, IREGION_CRUST_MANTLE, tau_sigma_dble, &
- omsb_crust_mantle_dble, factor_common_crust_mantle_dble, &
- factor_scale_crust_mantle_dble, NRAD_ATTENUATION,1,1,1, AM_V)
- omsb_inner_core_dble(:,:,:,1:min(ATT4,ATT5)) = omsb_crust_mantle_dble(:,:,:,1:min(ATT4,ATT5))
- factor_scale_inner_core_dble(:,:,:,1:min(ATT4,ATT5)) = factor_scale_crust_mantle_dble(:,:,:,1:min(ATT4,ATT5))
- factor_common_inner_core_dble(:,:,:,:,1:min(ATT4,ATT5)) = factor_common_crust_mantle_dble(:,:,:,:,1:min(ATT4,ATT5))
- ! Tell the Attenuation Code about the IDOUBLING regions within the Mesh
- call set_attenuation_regions_1D(RICB, RCMB, R670, R220, R80, AM_V)
-
- if(CUSTOM_REAL == SIZE_REAL) then
- factor_scale_crust_mantle = sngl(factor_scale_crust_mantle_dble)
- one_minus_sum_beta_crust_mantle = sngl(omsb_crust_mantle_dble)
- factor_common_crust_mantle = sngl(factor_common_crust_mantle_dble)
-
- factor_scale_inner_core = sngl(factor_scale_inner_core_dble)
- one_minus_sum_beta_inner_core = sngl(omsb_inner_core_dble)
- factor_common_inner_core = sngl(factor_common_inner_core_dble)
- else
- factor_scale_crust_mantle = factor_scale_crust_mantle_dble
- one_minus_sum_beta_crust_mantle = omsb_crust_mantle_dble
- factor_common_crust_mantle = factor_common_crust_mantle_dble
-
- factor_scale_inner_core = factor_scale_inner_core_dble
- one_minus_sum_beta_inner_core = omsb_inner_core_dble
- factor_common_inner_core = factor_common_inner_core_dble
- endif
-
-! if attenuation is on, shift PREM to right frequency
-! rescale mu in PREM to average frequency for attenuation
-! the formulas to implement the scaling can be found for instance in
-! Liu, H. P., Anderson, D. L. and Kanamori, H., Velocity dispersion due to
-! anelasticity: implications for seismology and mantle composition,
-! Geophys. J. R. Astron. Soc., vol. 47, pp. 41-58 (1976)
-! and in Aki, K. and Richards, P. G., Quantitative seismology, theory and methods,
-! W. H. Freeman, (1980), second edition, sections 5.5 and 5.5.2, eq. (5.81) p. 170
-
-! rescale in crust and mantle
-
- do ispec = 1,NSPEC_CRUST_MANTLE
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
-! ATTENUATION_3D get scale_factor
- if(ATTENUATION_3D_VAL) then
- ! tau_mu and tau_sigma need to reference a point in the mesh
- scale_factor = factor_scale_crust_mantle(i,j,k,ispec)
- else
- iglob = ibool_crust_mantle(i,j,k,ispec)
- dist_cr = xstore_crust_mantle(iglob)
- call get_attenuation_index(idoubling_crust_mantle(ispec), dble(dist_cr), iregion_selected, .FALSE., AM_V)
- scale_factor = factor_scale_crust_mantle(1,1,1,iregion_selected)
- endif ! ATTENUATION_3D
-
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- scale_factor_minus_one = scale_factor - 1.
- mul = c44store_crust_mantle(i,j,k,ispec)
- c11store_crust_mantle(i,j,k,ispec) = c11store_crust_mantle(i,j,k,ispec) &
- + FOUR_THIRDS * scale_factor_minus_one * mul
- c12store_crust_mantle(i,j,k,ispec) = c12store_crust_mantle(i,j,k,ispec) &
- - TWO_THIRDS * scale_factor_minus_one * mul
- c13store_crust_mantle(i,j,k,ispec) = c13store_crust_mantle(i,j,k,ispec) &
- - TWO_THIRDS * scale_factor_minus_one * mul
- c22store_crust_mantle(i,j,k,ispec) = c22store_crust_mantle(i,j,k,ispec) &
- + FOUR_THIRDS * scale_factor_minus_one * mul
- c23store_crust_mantle(i,j,k,ispec) = c23store_crust_mantle(i,j,k,ispec) &
- - TWO_THIRDS * scale_factor_minus_one * mul
- c33store_crust_mantle(i,j,k,ispec) = c33store_crust_mantle(i,j,k,ispec) &
- + FOUR_THIRDS * scale_factor_minus_one * mul
- c44store_crust_mantle(i,j,k,ispec) = c44store_crust_mantle(i,j,k,ispec) &
- + scale_factor_minus_one * mul
- c55store_crust_mantle(i,j,k,ispec) = c55store_crust_mantle(i,j,k,ispec) &
- + scale_factor_minus_one * mul
- c66store_crust_mantle(i,j,k,ispec) = c66store_crust_mantle(i,j,k,ispec) &
- + scale_factor_minus_one * mul
- else
- muvstore_crust_mantle(i,j,k,ispec) = muvstore_crust_mantle(i,j,k,ispec) * scale_factor
- if(TRANSVERSE_ISOTROPY_VAL .and. (idoubling_crust_mantle(ispec) == IFLAG_220_80 &
- .or. idoubling_crust_mantle(ispec) == IFLAG_80_MOHO)) &
- muhstore_crust_mantle(i,j,k,ispec) = muhstore_crust_mantle(i,j,k,ispec) * scale_factor
- endif
-
- enddo
- enddo
- enddo
- enddo ! END DO CRUST MANTLE
-
-! rescale in inner core
-
- do ispec = 1,NSPEC_INNER_CORE
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- if(ATTENUATION_3D_VAL) then
- scale_factor_minus_one = factor_scale_inner_core(i,j,k,ispec) - 1.0
- else
- iglob = ibool_inner_core(i,j,k,ispec)
- dist_cr = xstore_inner_core(iglob)
- call get_attenuation_index(idoubling_inner_core(ispec), dble(dist_cr), iregion_selected, .TRUE., AM_V)
- scale_factor_minus_one = factor_scale_inner_core(1,1,1,iregion_selected) - 1.
- endif
-
- if(ANISOTROPIC_INNER_CORE_VAL) then
- mul = muvstore_inner_core(i,j,k,ispec)
- c11store_inner_core(i,j,k,ispec) = c11store_inner_core(i,j,k,ispec) &
- + FOUR_THIRDS * scale_factor_minus_one * mul
- c12store_inner_core(i,j,k,ispec) = c12store_inner_core(i,j,k,ispec) &
- - TWO_THIRDS * scale_factor_minus_one * mul
- c13store_inner_core(i,j,k,ispec) = c13store_inner_core(i,j,k,ispec) &
- - TWO_THIRDS * scale_factor_minus_one * mul
- c33store_inner_core(i,j,k,ispec) = c33store_inner_core(i,j,k,ispec) &
- + FOUR_THIRDS * scale_factor_minus_one * mul
- c44store_inner_core(i,j,k,ispec) = c44store_inner_core(i,j,k,ispec) &
- + scale_factor_minus_one * mul
- endif
-
- if(ATTENUATION_3D_VAL) then
- muvstore_inner_core(i,j,k,ispec) = muvstore_inner_core(i,j,k,ispec) * factor_scale_inner_core(i,j,k,ispec)
- else
- muvstore_inner_core(i,j,k,ispec) = muvstore_inner_core(i,j,k,ispec) * factor_scale_inner_core(1,1,1,iregion_selected)
- endif
-
- enddo
- enddo
- enddo
- enddo ! END DO INNER CORE
-
- endif ! END IF(ATTENUATION)
-
-! allocate seismogram array
- if (nrec_local > 0) then
- allocate(seismograms(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
- if (ier /= 0 ) then
- print *,"ABORTING can not allocate in specfem3D while allocating seismograms ier=",ier
- call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
- endif
-! initialize seismograms
- seismograms(:,:,:) = 0._CUSTOM_REAL
- nit_written = 0
- endif
-
-! initialize arrays to zero
-
- displ_crust_mantle(:,:) = 0._CUSTOM_REAL
- veloc_crust_mantle(:,:) = 0._CUSTOM_REAL
- accel_crust_mantle(:,:) = 0._CUSTOM_REAL
-
- displ_outer_core(:) = 0._CUSTOM_REAL
- veloc_outer_core(:) = 0._CUSTOM_REAL
- accel_outer_core(:) = 0._CUSTOM_REAL
-
- displ_inner_core(:,:) = 0._CUSTOM_REAL
- veloc_inner_core(:,:) = 0._CUSTOM_REAL
- accel_inner_core(:,:) = 0._CUSTOM_REAL
-
-! put negligible initial value to avoid very slow underflow trapping
- if(FIX_UNDERFLOW_PROBLEM) then
- displ_crust_mantle(:,:) = VERYSMALLVAL
- displ_outer_core(:) = VERYSMALLVAL
- displ_inner_core(:,:) = VERYSMALLVAL
- endif
-
-! store g, rho and dg/dr=dg using normalized radius in lookup table every 100 m
-! get density and velocity from PREM model using dummy doubling flag
-! this assumes that the gravity perturbations are small and smooth
-! and that we can neglect the 3D model and use PREM every 100 m in all cases
-! this is probably a rather reasonable assumption
-
- ! tabulate d ln(rho)/dr needed for the no gravity fluid potential
- do int_radius = 1,NRAD_GRAVITY
- radius = dble(int_radius) / (R_EARTH_KM * 10.d0)
- idoubling = 0
- call prem_iso(myrank,radius,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,.false., &
- ONE_CRUST,.false.,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
- d_ln_density_dr_table(int_radius) = drhodr/rho
- enddo
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) ' time step: ',sngl(DT),' s'
- write(IMAIN,*) 'number of time steps: ',NSTEP
- write(IMAIN,*) 'total simulated time: ',sngl(((NSTEP-1)*DT-t0)/60.d0),' minutes'
- write(IMAIN,*) 'start time:',sngl(-t0),' seconds'
- write(IMAIN,*)
- endif
-
-! define constants for the time integration
-! scaling to make displacement in meters and velocity in meters per second
- scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
- scale_displ = R_EARTH
- scale_veloc = scale_displ / scale_t
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- deltat = sngl(DT/scale_t)
- else
- deltat = DT/scale_t
- endif
- deltatover2 = 0.5d0*deltat
- deltatsqover2 = 0.5d0*deltat*deltat
-
-! precompute Runge-Kutta coefficients if attenuation
- if(ATTENUATION_VAL) then
- call attenuation_memory_values(tau_sigma_dble, deltat, alphaval_dble, betaval_dble, gammaval_dble)
- if(CUSTOM_REAL == SIZE_REAL) then
- alphaval = sngl(alphaval_dble)
- betaval = sngl(betaval_dble)
- gammaval = sngl(gammaval_dble)
- else
- alphaval = alphaval_dble
- betaval = betaval_dble
- gammaval = gammaval_dble
- endif
- endif
-
- if (COMPUTE_AND_STORE_STRAIN) then
- epsilondev_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
- epsilondev_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
- if(FIX_UNDERFLOW_PROBLEM) then
- epsilondev_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
- epsilondev_inner_core(:,:,:,:,:) = VERYSMALLVAL
- endif
- endif
-
-! clear memory variables if attenuation
- if(ATTENUATION_VAL) then
- if (NSPEC_CRUST_MANTLE_ATTENUAT /= NSPEC_CRUST_MANTLE) &
- call exit_MPI(myrank, 'NSPEC_CRUST_MANTLE_ATTENUAT /= NSPEC_CRUST_MANTLE, exit')
- if (NSPEC_INNER_CORE_ATTENUATION /= NSPEC_INNER_CORE) &
- call exit_MPI(myrank, 'NSPEC_INNER_CORE_ATTENUATION /= NSPEC_INNER_CORE, exit')
-
- R_memory_crust_mantle(:,:,:,:,:,:) = 0._CUSTOM_REAL
- R_memory_inner_core(:,:,:,:,:,:) = 0._CUSTOM_REAL
- if(FIX_UNDERFLOW_PROBLEM) then
- R_memory_crust_mantle(:,:,:,:,:,:) = VERYSMALLVAL
- R_memory_inner_core(:,:,:,:,:,:) = VERYSMALLVAL
- endif
-
- endif
-
-! get information about event name and location for SAC seismograms
- call get_event_info_parallel(myrank,yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC, &
- elat_SAC,elon_SAC,depth_SAC,mb_SAC,ename_SAC,cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,NSOURCES_SAC)
-
-! define correct time steps if restart files
- if(NUMBER_OF_RUNS < 1 .or. NUMBER_OF_RUNS > 3) stop 'number of restart runs can be 1, 2 or 3'
- 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 = 1
- it_end = NSTEP
-
-!
-! s t a r t t i m e i t e r a t i o n s
-!
-
-! synchronize all processes to make sure everybody is ready to start time loop
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
- if(myrank == 0) write(IMAIN,*) 'All processes are synchronized before time loop'
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'Starting time iteration loop...'
- write(IMAIN,*)
- endif
-
-! create an empty file to monitor the start of the simulation
- if(myrank == 0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/starttimeloop.txt',status='unknown',action='write')
- write(IOUT,*) 'hello, starting time loop'
- close(IOUT)
- endif
-
-! get MPI starting time
- time_start = MPI_WTIME()
-
-! initialize variables for writing seismograms
- seismo_offset = it_begin-1
- seismo_current = 0
-
-! *********************************************************
-! ************* MAIN LOOP OVER THE TIME STEPS *************
-! *********************************************************
-
- do it = it_begin,it_end
-
-! update position in seismograms
- seismo_current = seismo_current + 1
-
-! mantle
- do i=1,NGLOB_CRUST_MANTLE
- displ_crust_mantle(:,i) = displ_crust_mantle(:,i) + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- 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)
- 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)
- enddo
-
-! 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 == 5 .or. it == NSTEP) then
-
-! compute maximum of norm of displacement in each slice
- Usolidnorm = max( &
- maxval(sqrt(displ_crust_mantle(1,:)**2 + &
- displ_crust_mantle(2,:)**2 + displ_crust_mantle(3,:)**2)), &
- maxval(sqrt(displ_inner_core(1,:)**2 + displ_inner_core(2,:)**2 + displ_inner_core(3,:)**2)))
-
- Ufluidnorm = maxval(abs(displ_outer_core))
-
-! compute the maximum of the maxima for all the slices using an MPI reduction
- call MPI_REDUCE(Usolidnorm,Usolidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
- MPI_COMM_WORLD,ier)
- call MPI_REDUCE(Ufluidnorm,Ufluidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
- MPI_COMM_WORLD,ier)
-
- if(myrank == 0) then
-
- write(IMAIN,*) 'Time step # ',it
- write(IMAIN,*) 'Time: ',sngl(((it-1)*DT-t0)/60.d0),' minutes'
-
-! 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
-
-! elapsed time since beginning of the simulation
- tCPU = MPI_WTIME() - time_start
- int_tCPU = int(tCPU)
- ihours = int_tCPU / 3600
- iminutes = (int_tCPU - 3600*ihours) / 60
- iseconds = int_tCPU - 3600*ihours - 60*iminutes
- write(IMAIN,*) 'Elapsed time in seconds = ',tCPU
- write(IMAIN,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
- write(IMAIN,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
-
-! compute estimated remaining simulation time
- t_remain = (NSTEP - it) * (tCPU/dble(it))
- int_t_remain = int(t_remain)
- ihours_remain = int_t_remain / 3600
- iminutes_remain = (int_t_remain - 3600*ihours_remain) / 60
- iseconds_remain = int_t_remain - 3600*ihours_remain - 60*iminutes_remain
- write(IMAIN,*) 'Time steps done = ',it,' out of ',NSTEP
- write(IMAIN,*) 'Time steps remaining = ',NSTEP - it
- write(IMAIN,*) 'Estimated remaining time in seconds = ',t_remain
- write(IMAIN,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- ihours_remain,iminutes_remain,iseconds_remain
-
-! compute estimated total simulation time
- t_total = t_remain + tCPU
- int_t_total = int(t_total)
- ihours_total = int_t_total / 3600
- iminutes_total = (int_t_total - 3600*ihours_total) / 60
- iseconds_total = int_t_total - 3600*ihours_total - 60*iminutes_total
- write(IMAIN,*) 'Estimated total run time in seconds = ',t_total
- write(IMAIN,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- ihours_total,iminutes_total,iseconds_total
- write(IMAIN,*) 'We have done ',sngl(100.d0*dble(it)/dble(NSTEP)),'% of that'
-
- if(it < 100) then
- write(IMAIN,*) '************************************************************'
- write(IMAIN,*) '**** BEWARE: the above time estimates are not reliable'
- write(IMAIN,*) '**** because fewer than 100 iterations have been performed'
- write(IMAIN,*) '************************************************************'
- endif
-
- if(it < NSTEP) then
-
-! get current date
- call date_and_time(datein,timein,zone,time_values)
-! time_values(1): year
-! time_values(2): month of the year
-! time_values(3): day of the month
-! time_values(5): hour of the day
-! time_values(6): minutes of the hour
-
-! compute date at which the run should finish; for simplicity only minutes
-! are considered, seconds are ignored; in any case the prediction is not
-! accurate down to seconds because of system and network fluctuations
- year = time_values(1)
- mon = time_values(2)
- day = time_values(3)
- hr = time_values(5)
- minutes = time_values(6)
-
-! get timestamp in minutes of current date and time
- call convtime(timestamp,year,mon,day,hr,minutes)
-
-! add remaining minutes
- timestamp = timestamp + nint(t_remain / 60.d0)
-
-! get date and time of that future timestamp in minutes
- call invtime(timestamp,year,mon,day,hr,minutes)
-
-! convert to Julian day to get day of the week
- call calndr(day,mon,year,julian_day_number)
- day_of_week = idaywk(julian_day_number)
-
- write(IMAIN,"(' The run will finish approximately on (in local time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
- weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
-
-! print date and time estimate of end of run in another country.
-! For instance: the code runs at Caltech in California but the person
-! running the code is connected remotely from France, which has 9 hours more
- if(ADD_TIME_ESTIMATE_ELSEWHERE .and. HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE /= 0) then
-
-! add time difference with that remote location (can be negative)
- timestamp_remote = timestamp + HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE
-
-! get date and time of that future timestamp in minutes
- call invtime(timestamp_remote,year_remote,mon_remote,day_remote,hr_remote,minutes_remote)
-
-! convert to Julian day to get day of the week
- call calndr(day_remote,mon_remote,year_remote,julian_day_number)
- day_of_week_remote = idaywk(julian_day_number)
-
- if(HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE > 0) then
- write(IMAIN,*) 'Adding positive time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
- else
- write(IMAIN,*) 'Adding negative time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
- endif
- write(IMAIN,*) 'and ',abs(MINUTES_TIME_DIFFERENCE),' minutes to get estimate at a remote location'
- write(IMAIN, &
- "(' The run will finish approximately on: ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
- weekday_name(day_of_week_remote),month_name(mon_remote),day_remote,year_remote,hr_remote,minutes_remote
- endif
-
- if(it < 100) then
- write(IMAIN,*) '************************************************************'
- write(IMAIN,*) '**** BEWARE: the above time estimates are not reliable'
- write(IMAIN,*) '**** because fewer than 100 iterations have been performed'
- write(IMAIN,*) '************************************************************'
- endif
-
- endif
-
- write(IMAIN,*)
-
-! write time stamp file to give information about progression of simulation
- write(outputname,"('/timestamp',i6.6)") it
-
- 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
- write(IOUT,*)
-
- 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)
- write(IOUT,*)
-
- write(IOUT,*) 'Time steps done = ',it,' out of ',NSTEP
- write(IOUT,*) 'Time steps remaining = ',NSTEP - it
- write(IOUT,*) 'Estimated remaining time in seconds = ',t_remain
- write(IOUT,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- ihours_remain,iminutes_remain,iseconds_remain
- write(IOUT,*)
-
- write(IOUT,*) 'Estimated total run time in seconds = ',t_total
- write(IOUT,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- ihours_total,iminutes_total,iseconds_total
- write(IOUT,*) 'We have done ',sngl(100.d0*dble(it)/dble(NSTEP)),'% of that'
- write(IOUT,*)
-
- if(it < NSTEP) then
-
- write(IOUT,"(' The run will finish approximately on (in local time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
- weekday_name(day_of_week),month_name(mon),day,year,hr,minutes
-
-! print date and time estimate of end of run in another country.
-! For instance: the code runs at Caltech in California but the person
-! running the code is connected remotely from France, which has 9 hours more
- if(ADD_TIME_ESTIMATE_ELSEWHERE .and. HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE /= 0) then
- if(HOURS_TIME_DIFFERENCE * 60 + MINUTES_TIME_DIFFERENCE > 0) then
- write(IOUT,*) 'Adding positive time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
- else
- write(IOUT,*) 'Adding negative time difference of ',abs(HOURS_TIME_DIFFERENCE),' hours'
- endif
- write(IOUT,*) 'and ',abs(MINUTES_TIME_DIFFERENCE),' minutes to get estimate at a remote location'
- write(IOUT, &
- "(' The run will finish approximately on (in remote time): ',a3,' ',a3,' ',i2.2,', ',i4.4,' ',i2.2,':',i2.2)") &
- weekday_name(day_of_week_remote),month_name(mon_remote),day_remote,year_remote,hr_remote,minutes_remote
- endif
-
- if(it < 100) then
- write(IOUT,*)
- write(IOUT,*) '************************************************************'
- write(IOUT,*) '**** BEWARE: the above time estimates are not reliable'
- write(IOUT,*) '**** because fewer than 100 iterations have been performed'
- write(IOUT,*) '************************************************************'
- endif
-
- endif
-
- close(IOUT)
-
-! 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')
- endif
- 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)
- else
- time = (dble(it-1)*DT-t0)/scale_t
- endif
-
-! accel_outer_core, div_displ_outer_core are initialized to zero in the following subroutine.
- call compute_forces_outer_core(d_ln_density_dr_table, &
- displ_outer_core,accel_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, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,ibool_outer_core)
-
-! ****************************************************
-! ********** 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
-
-! for surface elements exactly on the CMB
- do ispec2D = 1,NSPEC2D_TOP(IREGION_OUTER_CORE)
- ispec = ibelm_top_outer_core(ispec2D)
-
-! only for DOFs exactly on the CMB (top of these elements)
- k = NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
-! get velocity on the solid side using pointwise matching
- ispec_selected = ibelm_bottom_crust_mantle(ispec2D)
-
-! corresponding points are located at the bottom of the mantle
- k_corresp = 1
- iglob = ibool_crust_mantle(i,j,k_corresp,ispec_selected)
-
- displ_x = displ_crust_mantle(1,iglob)
- displ_y = displ_crust_mantle(2,iglob)
- displ_z = displ_crust_mantle(3,iglob)
-
-! get global point number
- iglob = ibool_outer_core(i,j,k,ispec)
-
-! get normal on the CMB
- nx = normal_top_outer_core(1,i,j,ispec2D)
- ny = normal_top_outer_core(2,i,j,ispec2D)
- nz = normal_top_outer_core(3,i,j,ispec2D)
-
-! compute dot product
- displ_n = displ_x*nx + displ_y*ny + displ_z*nz
-
-! formulation with generalized potential
- weight = jacobian2D_top_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
-
- accel_outer_core(iglob) = accel_outer_core(iglob) + weight*displ_n
-
- enddo
- enddo
- enddo
-
- endif
-
-!---
-!--- couple with inner core at the bottom of the outer core
-!---
-
- if(ACTUALLY_COUPLE_FLUID_ICB .and. NCHUNKS_VAL == 6) then
-
-! for surface elements exactly on the ICB
- do ispec2D = 1,NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
- ispec = ibelm_bottom_outer_core(ispec2D)
-
-! only for DOFs exactly on the ICB (bottom of these elements)
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
-
-! get velocity on the solid side using pointwise matching
- ispec_selected = ibelm_top_inner_core(ispec2D)
-
-! corresponding points are located at the bottom of the mantle
- k_corresp = NGLLZ
- iglob = ibool_inner_core(i,j,k_corresp,ispec_selected)
-
- displ_x = displ_inner_core(1,iglob)
- displ_y = displ_inner_core(2,iglob)
- displ_z = displ_inner_core(3,iglob)
-
-! get global point number
- iglob = ibool_outer_core(i,j,k,ispec)
-
-! get normal on the ICB
- nx = normal_bottom_outer_core(1,i,j,ispec2D)
- ny = normal_bottom_outer_core(2,i,j,ispec2D)
- nz = normal_bottom_outer_core(3,i,j,ispec2D)
-
-! compute dot product
- displ_n = displ_x*nx + displ_y*ny + displ_z*nz
-
-! formulation with generalized potential
- weight = jacobian2D_bottom_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
-
- accel_outer_core(iglob) = accel_outer_core(iglob) - weight*displ_n
-
- enddo
- enddo
- enddo
-
- endif
-
-! assemble all the contributions between slices using MPI
-
-! outer core
- 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,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
- buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY_VAL_OC,NCHUNKS)
-
-! 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
-
-! ****************************************************
-! 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
-
- call compute_forces_crust_mantle(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, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
- muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- ibool_crust_mantle,idoubling_crust_mantle, &
- R_memory_crust_mantle,epsilondev_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),COMPUTE_AND_STORE_STRAIN,AM_V)
-
- call compute_forces_inner_core(displ_inner_core,accel_inner_core,xstore_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,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
- R_memory_inner_core,epsilondev_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),COMPUTE_AND_STORE_STRAIN,AM_V)
-
-! add the sources
- do isource = 1,NSOURCES
-
-! add only if this proc carries the source
- if(myrank == islice_selected_source(isource)) then
-
- stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- stf_used = sngl(stf)
- else
- stf_used = stf
- endif
-
-! add source array
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool_crust_mantle(i,j,k,ispec_selected_source(isource))
- accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
- enddo
- enddo
- enddo
-
- endif
-
- enddo
-
-! ****************************************************
-! ********** 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
-
-! for surface elements exactly on the CMB
- do ispec2D = 1,NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
-
- ispec = ibelm_bottom_crust_mantle(ispec2D)
-
-! only for DOFs exactly on the CMB (bottom of these elements)
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
-
-! get velocity potential on the fluid side using pointwise matching
- ispec_selected = ibelm_top_outer_core(ispec2D)
- k_corresp = NGLLZ
-
-! get normal at the CMB
- nx = normal_top_outer_core(1,i,j,ispec2D)
- ny = normal_top_outer_core(2,i,j,ispec2D)
- nz = normal_top_outer_core(3,i,j,ispec2D)
-
-! get global point number
-! corresponding points are located at the top of the outer core
- iglob = ibool_outer_core(i,j,NGLLZ,ispec_selected)
- iglob_mantle = ibool_crust_mantle(i,j,k,ispec)
-
-! compute pressure, taking gravity into account
- pressure = - RHO_TOP_OC * accel_outer_core(iglob)
-
-! formulation with generalized potential
- weight = jacobian2D_top_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
-
- accel_crust_mantle(1,iglob_mantle) = accel_crust_mantle(1,iglob_mantle) + weight*nx*pressure
- 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
-
- enddo
- enddo
- enddo
-
- endif
-
-!---
-!--- couple with outer core at the top of the inner core
-!---
-
- if(ACTUALLY_COUPLE_FLUID_ICB .and. NCHUNKS_VAL == 6) then
-
-! for surface elements exactly on the ICB
- do ispec2D = 1,NSPEC2D_TOP(IREGION_INNER_CORE)
-
- ispec = ibelm_top_inner_core(ispec2D)
-
-! only for DOFs exactly on the ICB (top of these elements)
- k = NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
-! get velocity potential on the fluid side using pointwise matching
- ispec_selected = ibelm_bottom_outer_core(ispec2D)
- k_corresp = 1
-
-! get normal at the ICB
- nx = normal_bottom_outer_core(1,i,j,ispec2D)
- ny = normal_bottom_outer_core(2,i,j,ispec2D)
- nz = normal_bottom_outer_core(3,i,j,ispec2D)
-
-! get global point number
-! corresponding points are located at the bottom of the outer core
- iglob = ibool_outer_core(i,j,k_corresp,ispec_selected)
- iglob_inner_core = ibool_inner_core(i,j,k,ispec)
-
-! compute pressure, taking gravity into account
- pressure = - RHO_BOTTOM_OC * accel_outer_core(iglob)
-
-! formulation with generalized potential
- weight = jacobian2D_bottom_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
-
- accel_inner_core(1,iglob_inner_core) = accel_inner_core(1,iglob_inner_core) - weight*nx*pressure
- 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
-
- enddo
- enddo
- enddo
-
- 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
- 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(1),npoin2D_eta_crust_mantle(1), &
- 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(1),npoin2D_eta_inner_core(1), &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
- buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE),NCHUNKS,NDIM_smaller_buffers)
-
-!---
-!--- use buffers to assemble forces with the central cube
-!---
-
- if(INCLUDE_CENTRAL_CUBE) then
-
- 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, buffer_slices2, ibool_central_cube, &
- receiver_cube_from_slices, ibool_inner_core, idoubling_inner_core, NSPEC_INNER_CORE, &
- ibelm_bottom_inner_core, NSPEC2D_BOTTOM(IREGION_INNER_CORE),NGLOB_INNER_CORE,accel_inner_core,NDIM)
-
- endif ! end of assembling forces with the central cube
-
- do i=1,NGLOB_CRUST_MANTLE
- accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmass_crust_mantle(i)
- accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmass_crust_mantle(i)
- accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmass_crust_mantle(i)
- enddo
-
- if(OCEANS) then
-
-! initialize the updates
- updated_dof_ocean_load(:) = .false.
-
-! for surface elements exactly at the top of the crust (ocean bottom)
- do ispec2D = 1,NSPEC2D_TOP(IREGION_CRUST_MANTLE)
-
- ispec = ibelm_top_crust_mantle(ispec2D)
-
-! only for DOFs exactly at the top of the crust (ocean bottom)
- k = NGLLZ
-
- do j = 1,NGLLY
- do i = 1,NGLLX
-
-! get global point number
- iglob = ibool_crust_mantle(i,j,k,ispec)
-
-! only update once
- if(.not. updated_dof_ocean_load(iglob)) then
-
-! get normal
- nx = normal_top_crust_mantle(1,i,j,ispec2D)
- ny = normal_top_crust_mantle(2,i,j,ispec2D)
- nz = normal_top_crust_mantle(3,i,j,ispec2D)
-
-! make updated component of right-hand side
-! we divide by rmass_crust_mantle() which is 1 / M
-! we use the total force which includes the Coriolis term above
- force_normal_comp = (accel_crust_mantle(1,iglob)*nx + &
- accel_crust_mantle(2,iglob)*ny + &
- accel_crust_mantle(3,iglob)*nz) / rmass_crust_mantle(iglob)
-
- additional_term = (rmass_ocean_load(iglob) - rmass_crust_mantle(iglob)) * force_normal_comp
-
- accel_crust_mantle(1,iglob) = accel_crust_mantle(1,iglob) + additional_term * nx
- accel_crust_mantle(2,iglob) = accel_crust_mantle(2,iglob) + additional_term * ny
- accel_crust_mantle(3,iglob) = accel_crust_mantle(3,iglob) + additional_term * nz
-
-! done with this point
- updated_dof_ocean_load(iglob) = .true.
-
- endif
-
- enddo
- enddo
- enddo
- endif
-
- do i=1,NGLOB_CRUST_MANTLE
- veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
- enddo
-
- do i=1,NGLOB_INNER_CORE
- accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i)
- accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(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
-
- do irec_local = 1,nrec_local
-
-! get global number of that receiver
- irec = number_receiver_global(irec_local)
-
-! perform the general interpolation using Lagrange polynomials
- uxd = ZERO
- uyd = ZERO
- uzd = ZERO
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec))
-
- hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
-
- uxd = uxd + dble(displ_crust_mantle(1,iglob))*hlagrange
- uyd = uyd + dble(displ_crust_mantle(2,iglob))*hlagrange
- uzd = uzd + dble(displ_crust_mantle(3,iglob))*hlagrange
-
- enddo
- enddo
- enddo
-! store North, East and Vertical components
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- seismograms(:,irec_local,seismo_current) = sngl(scale_displ*(nu(:,1,irec)*uxd + &
- nu(:,2,irec)*uyd + nu(:,3,irec)*uzd))
- else
- seismograms(:,irec_local,seismo_current) = scale_displ*(nu(:,1,irec)*uxd + &
- nu(:,2,irec)*uyd + nu(:,3,irec)*uzd)
- endif
-
- enddo
-
- endif ! nrec_local
-
-! write the current or final seismograms
- if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
- call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,nrec,nrec_local,DT,t0,it_end, &
- yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC, &
- elat_SAC,elon_SAC,depth_SAC,mb_SAC,ename_SAC,cmt_lat_SAC,cmt_lon_SAC,&
- cmt_depth_SAC,cmt_hdur_SAC,NSOURCES_SAC,NPROCTOT, &
- 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,one_seismogram)
- if(myrank==0) then
- write(IMAIN,*)
- write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
- write(IMAIN,*)
- endif
- seismo_offset = seismo_offset + seismo_current
- seismo_current = 0
- endif
-
-!---- end of time iteration loop
-!
- enddo ! end of main time loop
-
-! close the main output file
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'End of the simulation'
- write(IMAIN,*)
- close(IMAIN)
- endif
-
- end subroutine specfem3D
-
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.F90 (from rev 12615, seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.F90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -0,0 +1,725 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! August 2008
+!
+! 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.
+!
+!=====================================================================
+
+! write seismograms to files
+ subroutine write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,nrec,nrec_local,DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,t_cmt, &
+ elat,elon,depth,mb,ename,cmt_lat,cmt_lon, &
+ cmt_depth,cmt_hdur,NSOURCES,NPROCTOT, &
+ 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,one_seismogram)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "precision.h"
+#endif
+
+! parameters
+ integer nrec,nrec_local,myrank,it_end,NPROCTOT,NSOURCES
+ character(len=256) sisname
+
+ integer :: seismo_offset, seismo_current, NTSTEP_BETWEEN_OUTPUT_SEISMOS
+ integer, dimension(nrec_local) :: number_receiver_global
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: seismograms
+ double precision hdur,DT
+
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+ double precision t_cmt,elat,elon,depth
+ double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
+ double precision, dimension(nrec) :: stlat,stlon,stele
+ integer yr,jda,ho,mi
+ double precision sec
+ real mb
+ character(12) ename
+
+! variables
+ integer :: iproc,sender,irec_local,irec,receiver,nrec_local_received,nrec_tot_found
+ integer :: total_seismos,total_seismos_local
+ double precision :: write_time_begin,write_time
+
+#ifdef USE_MPI
+ integer :: ier
+#endif
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: one_seismogram
+
+#ifdef USE_MPI
+ integer, dimension(MPI_STATUS_SIZE) :: msg_status
+#endif
+
+ character(len=150) OUTPUT_FILES
+
+! new flags to decide on seismogram type BS BS 06/2007
+ logical OUTPUT_SEISMOS_ASCII_TEXT, OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY
+! flag whether seismograms are ouput for North-East-Z component or Radial-Transverse-Z
+ logical ROTATE_SEISMOGRAMS_RT
+
+! flag to decide if seismograms are written by master proc only or
+! by all processes in parallel (doing the later may create problems on some
+! file systems)
+ logical WRITE_SEISMOGRAMS_BY_MASTER
+
+! save all seismograms in one large combined file instead of one file per seismogram
+! to avoid overloading shared non-local file systems such as GPFS for instance
+ logical SAVE_ALL_SEISMOS_IN_ONE_FILE
+ logical USE_BINARY_FOR_LARGE_FILE
+
+! check that the sum of the number of receivers in each slice is nrec
+#ifdef USE_MPI
+ call MPI_REDUCE(nrec_local,nrec_tot_found,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
+#else
+ nrec_tot_found = nrec_local
+#endif
+ if(myrank == 0 .and. nrec_tot_found /= nrec) &
+ call exit_MPI(myrank,'total number of receivers is incorrect')
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! all the processes write their local seismograms themselves
+ if(.not. WRITE_SEISMOGRAMS_BY_MASTER) then
+
+#ifdef USE_MPI
+ write_time_begin = MPI_WTIME()
+#else
+ write_time_begin = 0
+#endif
+
+ if(OUTPUT_SEISMOS_ASCII_TEXT .and. SAVE_ALL_SEISMOS_IN_ONE_FILE) then
+ write(sisname,'(A,I5.5)') '/all_seismograms_node_',myrank
+
+ if(USE_BINARY_FOR_LARGE_FILE) then
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='unknown',form='unformatted',action='write')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin', &
+ status='old',form='unformatted',position='append',action='write')
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted',action='write')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii', &
+ status='old',form='formatted',position='append',action='write')
+ endif
+ endif
+ endif
+
+ total_seismos_local = 0
+
+! loop on all the local receivers
+ do irec_local = 1,nrec_local
+
+! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+ total_seismos_local = total_seismos_local + 1
+
+ one_seismogram = seismograms(:,irec_local,:)
+
+! write this seismogram
+ call write_one_seismogram(one_seismogram,irec, &
+ station_name,network_name,stlat,stlon,stele,nrec, &
+ DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,ename,cmt_lat, &
+ cmt_lon,cmt_depth,cmt_hdur,NSOURCES,OUTPUT_FILES, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank)
+
+ enddo
+
+ if(total_seismos_local/= nrec_local) call exit_MPI(myrank,'incorrect total number of receivers saved')
+
+#ifdef USE_MPI
+ write_time = MPI_WTIME() - write_time_begin
+#else
+ write_time = 0
+#endif
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Writing the seismograms in parallel took ',write_time,' seconds'
+ write(IMAIN,*)
+ endif
+
+! now only the master process does the writing of seismograms and
+! collects the data from all other processes
+ else ! WRITE_SEISMOGRAMS_BY_MASTER
+
+#ifdef USE_MPI
+ write_time_begin = MPI_WTIME()
+#else
+ write_time_begin = 0
+#endif
+
+ if(myrank == 0) then ! on the master, gather all the seismograms
+
+ ! create one large file instead of one small file per station to avoid file system overload
+ if(OUTPUT_SEISMOS_ASCII_TEXT .and. SAVE_ALL_SEISMOS_IN_ONE_FILE) then
+ write(sisname,'(A)') '/all_seismograms'
+
+ if(USE_BINARY_FOR_LARGE_FILE) then
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='unknown',form='unformatted',action='write')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin', &
+ status='old',form='unformatted',position='append',action='write')
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted',action='write')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii', &
+ status='old',form='formatted',position='append',action='write')
+ endif
+ endif
+
+ endif
+
+ total_seismos = 0
+
+ ! loop on all the slices
+ do iproc = 0,NPROCTOT-1
+
+ ! receive except from proc 0, which is me and therefore I already have this value
+ sender = iproc
+ if(iproc /= 0) then
+#ifdef USE_MPI
+ call MPI_RECV(nrec_local_received,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+ if(nrec_local_received < 0) call exit_MPI(myrank,'error while receiving local number of receivers')
+ else
+ nrec_local_received = nrec_local
+ endif
+ if (nrec_local_received > 0) then
+ do irec_local = 1,nrec_local_received
+ ! receive except from proc 0, which is myself and therefore I already have these values
+ if(iproc == 0) then
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+ one_seismogram(:,:) = seismograms(:,irec_local,:)
+ else
+#ifdef USE_MPI
+ call MPI_RECV(irec,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+ if(irec < 1 .or. irec > nrec) call exit_MPI(myrank,'error while receiving global receiver number')
+#ifdef USE_MPI
+ call MPI_RECV(one_seismogram,NDIM*seismo_current,CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+#endif
+ endif
+
+ total_seismos = total_seismos + 1
+ ! write this seismogram
+ call write_one_seismogram(one_seismogram,irec, &
+ station_name,network_name,stlat,stlon,stele,nrec, &
+ DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,ename,cmt_lat, &
+ cmt_lon,cmt_depth,cmt_hdur,NSOURCES,OUTPUT_FILES, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank)
+ enddo
+ endif
+ enddo
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Total number of receivers saved is ',total_seismos,' out of ',nrec
+ write(IMAIN,*)
+
+ if(total_seismos /= nrec) call exit_MPI(myrank,'incorrect total number of receivers saved')
+
+ ! create one large file instead of one small file per station to avoid file system overload
+ if(SAVE_ALL_SEISMOS_IN_ONE_FILE) close(IOUT)
+
+ else ! on the nodes, send the seismograms to the master
+ receiver = 0
+#ifdef USE_MPI
+ call MPI_SEND(nrec_local,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+ if (nrec_local > 0) then
+ do irec_local = 1,nrec_local
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+#ifdef USE_MPI
+ call MPI_SEND(irec,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+ one_seismogram(:,:) = seismograms(:,irec_local,:)
+#ifdef USE_MPI
+ call MPI_SEND(one_seismogram,NDIM*seismo_current,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+#endif
+ enddo
+ endif
+ endif
+
+#ifdef USE_MPI
+ write_time = MPI_WTIME() - write_time_begin
+#else
+ write_time = 0
+#endif
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Writing the seismograms by master proc alone took ',write_time,' seconds'
+ write(IMAIN,*)
+ endif
+
+ endif ! WRITE_SEISMOGRAMS_BY_MASTER
+
+ end subroutine write_seismograms
+
+!
+!----
+!
+
+ subroutine write_one_seismogram(one_seismogram,irec, &
+ station_name,network_name,stlat,stlon,stele,nrec, &
+ DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,ename,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES, &
+ OUTPUT_FILES, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nrec,it_end
+
+ integer :: seismo_offset, seismo_current, NTSTEP_BETWEEN_OUTPUT_SEISMOS
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: one_seismogram
+
+ real(kind=CUSTOM_REAL), dimension(5,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: seismogram_tmp
+
+ integer myrank
+ double precision hdur,DT
+
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ integer irec,length_station_name,length_network_name
+ integer iorientation,isample
+ double precision value
+
+ character(len=4) chn
+ character(len=150) sisname,sisname_big_file
+ character(len=150) OUTPUT_FILES
+
+! section added for SAC
+ integer NSOURCES
+
+ double precision t_cmt,elat,elon,depth
+ double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
+
+ double precision, dimension(nrec) :: stlat,stlon,stele
+
+ character(len=256) sisname_2
+
+! variables for SAC header fields
+ integer yr,jda,ho,mi
+ double precision sec
+ real mb
+ character(12) ename
+
+ real DELTA
+ real DEPMIN
+ real DEPMAX
+ real SCALE_F
+ real ODELTA
+ real B,E,O,A
+ real STLA,STLO,STEL,STDP
+ real EVLA,EVLO,EVEL,EVDP
+ real MAG,DIST,AZ,BAZ,GCARC
+ real DEPMEN
+ real USER0,USER1,USER2,USER3
+ real CMPAZ,CMPINC
+
+ integer NZYEAR,NZJDAY,NZHOUR,NZMIN,NZSEC
+ integer NZMSEC,NVHDR,NORID,NEVID
+! NUMBER of POINTS:
+ integer NPTS
+ integer IFTYPE,IMAGTYP
+ integer IDEP
+ integer IZTYPE
+ integer IEVTYP
+ integer IQUAL
+ integer ISYNTH
+! permission flags:
+ integer LEVEN
+ integer LPSPOL
+ integer LOVROK
+ integer LCALDA
+
+ character(8) KSTNM
+ character(16) KEVNM
+ character(8) KCMPNM
+ character(8) KNETWK
+ character(8) KUSER0,KUSER1,KUSER2
+ character(8), parameter :: str_undef='-12345 '
+
+ real UNUSED ! header fields unused by SAC
+ real undef ! undefined values
+ real INTERNAL ! SAC internal variables, always leave undefined
+ real BYSAC
+! end SAC header variables
+
+! flags to determine seismogram type
+ logical OUTPUT_SEISMOS_ASCII_TEXT, OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY
+! flag whether seismograms are ouput for North-East-Z component or Radial-Transverse-Z
+ logical ROTATE_SEISMOGRAMS_RT
+
+! save all seismograms in one large combined file instead of one file per seismogram
+! to avoid overloading shared non-local file systems such as GPFS for instance
+ logical SAVE_ALL_SEISMOS_IN_ONE_FILE
+ logical USE_BINARY_FOR_LARGE_FILE
+
+! variables used for calculation of backazimuth and
+! rotation of components if ROTATE_SEISMOGRAMS=.true.
+
+ integer ior_start,ior_end
+ double precision backaz
+ real(kind=CUSTOM_REAL) phi,cphi,sphi
+!----------------------------------------------------------------
+
+ if (ROTATE_SEISMOGRAMS_RT) then ! iorientation 1=N,2=E,3=Z,4=R,5=T
+ ior_start=3 ! starting from Z
+ ior_end =5 ! ending with T => ZRT
+ else
+ ior_start=1 ! starting from N
+ ior_end =3 ! ending with Z => NEZ
+ endif
+
+ !do iorientation = 1,NDIM
+ !do iorientation = 1,5 ! BS BS changed from 3 (NEZ) to 5 (NEZRT) components
+ do iorientation = ior_start,ior_end ! BS BS changed according to ROTATE_SEISMOGRAMS_RT
+
+ if(iorientation == 1) then
+ chn = 'LHN'
+ else if(iorientation == 2) then
+ chn = 'LHE'
+ else if(iorientation == 3) then
+ chn = 'LHZ'
+ else if(iorientation == 4) then
+ chn = 'LHR'
+ else if(iorientation == 5) then
+ chn = 'LHT'
+ else
+ call exit_MPI(myrank,'incorrect channel value')
+ endif
+
+ if (iorientation == 4 .or. iorientation == 5) then ! LMU BS BS
+
+ ! BS BS calculate backazimuth needed to rotate East and North
+ ! components to Radial and Transverse components
+
+ if (backaz>180.) then
+ phi=backaz-180.
+ elseif (backaz<180.) then
+ phi=backaz+180.
+ elseif (backaz==180.) then
+ phi=backaz
+ endif
+
+ cphi=cos(phi*pi/180)
+ sphi=sin(phi*pi/180)
+
+ ! BS BS do the rotation of the components and put result in
+ ! new variable seismogram_tmp
+ if (iorientation == 4) then ! radial component
+ do isample = 1,seismo_current
+ seismogram_tmp(iorientation,isample) = &
+ cphi * one_seismogram(1,isample) + sphi * one_seismogram(2,isample)
+ enddo
+ elseif (iorientation == 5) then ! transverse component
+ do isample = 1,seismo_current
+ seismogram_tmp(iorientation,isample) = &
+ -1*sphi * one_seismogram(1,isample) + cphi * one_seismogram(2,isample)
+ enddo
+ endif
+
+ else ! keep NEZ components
+ do isample = 1,seismo_current
+ seismogram_tmp(iorientation,isample) = one_seismogram(iorientation,isample)
+ enddo
+
+ endif
+
+! create the name of the seismogram file for each slice
+! file name includes the name of the station and the network
+ length_station_name = len_trim(station_name(irec))
+ length_network_name = len_trim(network_name(irec))
+
+! check that length conforms to standard
+ if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) &
+ call exit_MPI(myrank,'wrong length of station name')
+
+ if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) &
+ call exit_MPI(myrank,'wrong length of network name')
+
+! create the name of the seismogram file using the station name and network name
+ write(sisname,"('/',a,'.',a,'.',a3,'.semd')") station_name(irec)(1:length_station_name), &
+ network_name(irec)(1:length_network_name),chn
+
+! create this name also for the text line added to the unique big seismogram file
+ write(sisname_big_file,"(a,'.',a,'.',a3,'.semd')") station_name(irec)(1:length_station_name), &
+ network_name(irec)(1:length_network_name),chn
+
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM .or. OUTPUT_SEISMOS_SAC_BINARY) then
+
+!######################## SAC Alphanumeric Seismos ############################
+!
+! written by Markus Treml and Bernhard Schuberth, Dept. for Earth and Environ-
+! mental Sciences, Ludwig-Maximilians-University Munich, Germany
+!
+! some words about SAC timing:
+!==============================
+!
+!NPTS,DELTA,B,E:
+! These define the timing of the seismogram. E is calculated by sac. So, say
+! you have 100 NPTS, a DELTA of 0.5, and set B to 0, E should be 50.
+! Likewise setting B to -50 gives an E of 0. Cutting basically cuts out points
+! between the two times you designate based on these values.
+!KZTIME and KZDATE:
+! Now things get funky. KZTIME defines the exact time that the trace begins
+! at. It has no affect on timing per se. You'll really notice its effect if
+! you read in two traces from different dates.
+
+! Reference markers, (e.g. the o-marker) are not defined relative to this time,
+! but rather to the begin time (B) of the seismo, so if you adjust B, you also
+! need to adjust KZTIME to match. l would suggest experimenting with this until
+! you understand it. It is a little non-intuitive until you see it for yourself.
+!
+!-----------------------------------------------------------------------------
+!
+! This file is essentially the alphanumeric equivalent of the SAC binary data
+! file. The header section is stored on the first 30 cards. This is followed
+! by one or two data sections. The data is in 5G15.7 format.
+!----------------------------------------------------------------------
+
+! define certain default values
+
+! unused or undefined values are set to '-12345.00'
+ UNUSED = -12345.00 ! header fields unused by SAC
+ undef = -12345.00 ! undefined values
+ INTERNAL = -12345.00 ! SAC internal variables, always left undefined
+ BYSAC = -12345.00 ! values calculated by SAC from other variables
+!
+ DELTA = DT ! [REQUIRED]
+ DEPMIN = BYSAC
+ DEPMAX = BYSAC
+ DEPMEN = BYSAC
+ SCALE_F= 1000000000 ! factor for y-value, set to 10e9, so that values are in nm
+ ODELTA = undef ! increment from delta
+
+ B = sngl((seismo_offset)*DT-hdur + t_cmt) ! [REQUIRED]
+ E = BYSAC ! [REQUIRED]
+ O = undef !###
+ A = undef !###
+!station values:
+ STLA = stlat(irec)
+ STLO = stlon(irec)
+ STEL = stele(irec)
+ STDP = undef !stdep(irec)
+!event values (hypocenter):
+ EVLA = elat
+ EVLO = elon
+ EVEL = undef !not defined
+ EVDP = depth
+
+!cmt location values (different from hypocenter location, usually):
+ USER0 = cmt_lat
+ USER1 = cmt_lon
+ USER2 = cmt_depth
+
+ USER3 = cmt_hdur !half duration from CMT if not changed to hdur=0.d0 (point source)
+
+ MAG = mb !
+ IMAGTYP= 52 ! 52 = Mb? 55 = Mw!
+
+ DIST = BYSAC ! cause
+ AZ = BYSAC ! LCALDA
+ BAZ = BYSAC ! is
+ GCARC = BYSAC ! TRUE
+
+! instrument orientation
+ if(iorientation == 1) then !N
+ CMPAZ = 0.00
+ CMPINC =90.00
+ else if(iorientation == 2) then !E
+ CMPAZ =90.00
+ CMPINC =90.00
+ else if(iorientation == 3) then !Z
+ CMPAZ = 0.00
+ CMPINC = 0.00
+ else if(iorientation == 4) then !R
+ CMPAZ = modulo(phi,360.) ! phi is calculated above (see call distaz())
+ CMPINC =90.00
+ else if(iorientation == 5) then !T
+ CMPAZ = modulo(phi+90.,360.) ! phi is calculated above (see call distaz())
+ CMPINC =90.00
+ endif
+!----------------end format G15.7--------
+
+! date and time:
+ NZYEAR =yr
+ NZJDAY =jda
+ NZHOUR =ho
+ NZMIN =mi
+ NZSEC =int(sec)
+ NZMSEC =int((sec-int(sec))*1000)
+
+ NVHDR=6 ! SAC header version number. Current is 6
+
+! CSS3.0 variables:
+ NORID =int(undef) !origin ID
+ NEVID =int(undef) !event ID
+!NWVID =undef !waveform ID
+
+! NUMBER of POINTS:
+ NPTS = it_end-seismo_offset ! [REQUIRED]
+! event type
+ IFTYPE = 1 ! 1=ITIME, i.e. seismogram [REQUIRED] # numbering system is
+ IDEP = 6 ! 6: displ/nm # quite strange, best
+
+ IZTYPE = 11 !=origint reference time equivalent ! # by chnhdr and write
+ IEVTYP = 40 !event type, 40: Earthquake # alpha and check
+ IQUAL = int(undef) ! quality
+ ISYNTH = int(undef) ! 1 real data, 2...n synth. flag
+! permission flags:
+ LEVEN =1 ! evenly spaced data [REQUIRED]
+ LPSPOL=1 ! ? pos. polarity of components (has to be TRUE for LCALDA=1)
+ LOVROK=1 ! 1: OK to overwrite file on disk
+ LCALDA=1 ! 1: calculate DIST, AZ, BAZ, and GCARC, 0: do nothing
+! ------------------end format 5I10---------
+!
+!----------------------------------
+ KSTNM = station_name(irec)(1:8) ! A8
+
+ if (NSOURCES == 1) then
+ KEVNM = ename(1:len_trim(ename))//'_syn'! A16
+ else
+ KEVNM = ename(1:len_trim(ename))//'_sFS'! A16
+ endif
+
+!----------------------------------
+ KCMPNM = chn(3:3) ! 3A8
+ KNETWK = network_name(irec) ! A6
+
+ KUSER0 = 'CMT_LAT_' ! A8
+ KUSER1 = 'CMT_LON_' ! A8
+ KUSER2 = 'CMTDEPTH' ! A8
+!----------------------------------
+
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM) then
+
+ endif ! OUTPUT_SEISMOS_SAC_ALPHANUM
+
+! For explaination on values set, see above (SAC ASCII)
+ if (OUTPUT_SEISMOS_SAC_BINARY) then
+
+ endif ! OUTPUT_SEISMOS_SAC_BINARY
+
+!#################### end SAC Alphanumeric Seismos ############################
+
+ endif ! OUTPUT_SEISMOS_SAC_ALPHANUM .or. OUTPUT_SEISMOS_SAC_BINARY
+
+ if(OUTPUT_SEISMOS_ASCII_TEXT) then
+
+! save seismograms in text format with no subsampling.
+! Because we do not subsample the output, this can result in large files
+! if the simulation uses many time steps. However, subsampling the output
+! here would result in a loss of accuracy when one later convolves
+! the results with the source time function
+
+! add .ascii extension to seismogram file name for ASCII seismograms
+ write(sisname_2,"('/',a,'.ascii')") trim(sisname)
+
+! create one large file instead of one small file per station to avoid file system overload
+ if(SAVE_ALL_SEISMOS_IN_ONE_FILE) then
+ if(USE_BINARY_FOR_LARGE_FILE) then
+ write(IOUT) sisname_big_file
+ else
+ write(IOUT,*) sisname_big_file(1:len_trim(sisname_big_file))
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2),status='unknown',action='write')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2),status='old',position='append',action='write')
+ endif
+
+ endif
+
+ ! subtract half duration of the source to make sure travel time is correct
+ do isample = 1,seismo_current
+ value = dble(seismogram_tmp(iorientation,isample))
+
+ if(SAVE_ALL_SEISMOS_IN_ONE_FILE .and. USE_BINARY_FOR_LARGE_FILE) then
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IOUT) sngl(dble(seismo_offset+isample-1)*DT - hdur),sngl(value)
+ else
+ write(IOUT) dble(seismo_offset+isample-1)*DT - hdur,value
+ endif
+ else
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IOUT,*) sngl(dble(seismo_offset+isample-1)*DT - hdur),' ',sngl(value)
+ else
+ write(IOUT,*) dble(seismo_offset+isample-1)*DT - hdur,' ',value
+ endif
+ endif
+
+ enddo
+
+ if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) close(IOUT)
+
+ endif ! OUTPUT_SEISMOS_ASCII_TEXT
+
+ enddo ! do iorientation
+
+ end subroutine write_one_seismogram
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.f90 2008-08-12 20:43:04 UTC (rev 12615)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/src/write_seismograms.f90 2008-08-12 21:42:28 UTC (rev 12616)
@@ -1,683 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 4 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Seismological Laboratory, California Institute of Technology, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) California Institute of Technology and University of Pau / CNRS / INRIA
-! August 2008
-!
-! 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.
-!
-!=====================================================================
-
-! write seismograms to files
- subroutine write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
- network_name,stlat,stlon,stele,nrec,nrec_local,DT,hdur,it_end, &
- yr,jda,ho,mi,sec,t_cmt, &
- elat,elon,depth,mb,ename,cmt_lat,cmt_lon, &
- cmt_depth,cmt_hdur,NSOURCES,NPROCTOT, &
- 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,one_seismogram)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
-! parameters
- integer nrec,nrec_local,myrank,it_end,NPROCTOT,NSOURCES
- character(len=256) sisname
-
- integer :: seismo_offset, seismo_current, NTSTEP_BETWEEN_OUTPUT_SEISMOS
- integer, dimension(nrec_local) :: number_receiver_global
-
- real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: seismograms
- double precision hdur,DT
-
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
- double precision t_cmt,elat,elon,depth
- double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
- double precision, dimension(nrec) :: stlat,stlon,stele
- integer yr,jda,ho,mi
- double precision sec
- real mb
- character(12) ename
-
-! variables
- integer :: iproc,sender,irec_local,irec,ier,receiver,nrec_local_received,nrec_tot_found
- integer :: total_seismos,total_seismos_local
- double precision :: write_time_begin,write_time
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: one_seismogram
-
- integer msg_status(MPI_STATUS_SIZE)
-
- character(len=150) OUTPUT_FILES
-
-! new flags to decide on seismogram type BS BS 06/2007
- logical OUTPUT_SEISMOS_ASCII_TEXT, OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY
-! flag whether seismograms are ouput for North-East-Z component or Radial-Transverse-Z
- logical ROTATE_SEISMOGRAMS_RT
-
-! flag to decide if seismograms are written by master proc only or
-! by all processes in parallel (doing the later may create problems on some
-! file systems)
- logical WRITE_SEISMOGRAMS_BY_MASTER
-
-! save all seismograms in one large combined file instead of one file per seismogram
-! to avoid overloading shared non-local file systems such as GPFS for instance
- logical SAVE_ALL_SEISMOS_IN_ONE_FILE
- logical USE_BINARY_FOR_LARGE_FILE
-
-! check that the sum of the number of receivers in each slice is nrec
- call MPI_REDUCE(nrec_local,nrec_tot_found,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
- if(myrank == 0 .and. nrec_tot_found /= nrec) &
- call exit_MPI(myrank,'total number of receivers is incorrect')
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! all the processes write their local seismograms themselves
- if(.not. WRITE_SEISMOGRAMS_BY_MASTER) then
-
- write_time_begin = MPI_WTIME()
-
- if(OUTPUT_SEISMOS_ASCII_TEXT .and. SAVE_ALL_SEISMOS_IN_ONE_FILE) then
- write(sisname,'(A,I5.5)') '/all_seismograms_node_',myrank
-
- if(USE_BINARY_FOR_LARGE_FILE) then
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='unknown',form='unformatted',action='write')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin', &
- status='old',form='unformatted',position='append',action='write')
- endif
- else
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted',action='write')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii', &
- status='old',form='formatted',position='append',action='write')
- endif
- endif
- endif
-
- total_seismos_local = 0
-
-! loop on all the local receivers
- do irec_local = 1,nrec_local
-
-! get global number of that receiver
- irec = number_receiver_global(irec_local)
-
- total_seismos_local = total_seismos_local + 1
-
- one_seismogram = seismograms(:,irec_local,:)
-
-! write this seismogram
- call write_one_seismogram(one_seismogram,irec, &
- station_name,network_name,stlat,stlon,stele,nrec, &
- DT,hdur,it_end, &
- yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,ename,cmt_lat, &
- cmt_lon,cmt_depth,cmt_hdur,NSOURCES,OUTPUT_FILES, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank)
-
- enddo
-
- if(total_seismos_local/= nrec_local) call exit_MPI(myrank,'incorrect total number of receivers saved')
-
- write_time = MPI_WTIME() - write_time_begin
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'Writing the seismograms in parallel took ',write_time,' seconds'
- write(IMAIN,*)
- endif
-
-! now only the master process does the writing of seismograms and
-! collects the data from all other processes
- else ! WRITE_SEISMOGRAMS_BY_MASTER
-
- write_time_begin = MPI_WTIME()
-
- if(myrank == 0) then ! on the master, gather all the seismograms
-
- ! create one large file instead of one small file per station to avoid file system overload
- if(OUTPUT_SEISMOS_ASCII_TEXT .and. SAVE_ALL_SEISMOS_IN_ONE_FILE) then
- write(sisname,'(A)') '/all_seismograms'
-
- if(USE_BINARY_FOR_LARGE_FILE) then
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='unknown',form='unformatted',action='write')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin', &
- status='old',form='unformatted',position='append',action='write')
- endif
- else
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted',action='write')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii', &
- status='old',form='formatted',position='append',action='write')
- endif
- endif
-
- endif
-
- total_seismos = 0
-
- ! loop on all the slices
- do iproc = 0,NPROCTOT-1
-
- ! receive except from proc 0, which is me and therefore I already have this value
- sender = iproc
- if(iproc /= 0) then
- call MPI_RECV(nrec_local_received,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- if(nrec_local_received < 0) call exit_MPI(myrank,'error while receiving local number of receivers')
- else
- nrec_local_received = nrec_local
- endif
- if (nrec_local_received > 0) then
- do irec_local = 1,nrec_local_received
- ! receive except from proc 0, which is myself and therefore I already have these values
- if(iproc == 0) then
- ! get global number of that receiver
- irec = number_receiver_global(irec_local)
- one_seismogram(:,:) = seismograms(:,irec_local,:)
- else
- call MPI_RECV(irec,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- if(irec < 1 .or. irec > nrec) call exit_MPI(myrank,'error while receiving global receiver number')
- call MPI_RECV(one_seismogram,NDIM*seismo_current,CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- endif
-
- total_seismos = total_seismos + 1
- ! write this seismogram
- call write_one_seismogram(one_seismogram,irec, &
- station_name,network_name,stlat,stlon,stele,nrec, &
- DT,hdur,it_end, &
- yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,ename,cmt_lat, &
- cmt_lon,cmt_depth,cmt_hdur,NSOURCES,OUTPUT_FILES, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank)
- enddo
- endif
- enddo
-
- write(IMAIN,*)
- write(IMAIN,*) 'Total number of receivers saved is ',total_seismos,' out of ',nrec
- write(IMAIN,*)
-
- if(total_seismos /= nrec) call exit_MPI(myrank,'incorrect total number of receivers saved')
-
- ! create one large file instead of one small file per station to avoid file system overload
- if(SAVE_ALL_SEISMOS_IN_ONE_FILE) close(IOUT)
-
- else ! on the nodes, send the seismograms to the master
- receiver = 0
- call MPI_SEND(nrec_local,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
- if (nrec_local > 0) then
- do irec_local = 1,nrec_local
- ! get global number of that receiver
- irec = number_receiver_global(irec_local)
- call MPI_SEND(irec,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
- one_seismogram(:,:) = seismograms(:,irec_local,:)
- call MPI_SEND(one_seismogram,NDIM*seismo_current,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
- enddo
- endif
- endif
-
- write_time = MPI_WTIME() - write_time_begin
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'Writing the seismograms by master proc alone took ',write_time,' seconds'
- write(IMAIN,*)
- endif
-
- endif ! WRITE_SEISMOGRAMS_BY_MASTER
-
- end subroutine write_seismograms
-
-!
-!----
-!
-
- subroutine write_one_seismogram(one_seismogram,irec, &
- station_name,network_name,stlat,stlon,stele,nrec, &
- DT,hdur,it_end, &
- yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,ename,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES, &
- OUTPUT_FILES, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT, &
- NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank)
-
- implicit none
-
- include "constants.h"
-
- integer nrec,it_end
-
- integer :: seismo_offset, seismo_current, NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: one_seismogram
-
- real(kind=CUSTOM_REAL), dimension(5,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: seismogram_tmp
-
- integer myrank
- double precision hdur,DT
-
- character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- integer irec,length_station_name,length_network_name
- integer iorientation,isample
- double precision value
-
- character(len=4) chn
- character(len=150) sisname,sisname_big_file
- character(len=150) OUTPUT_FILES
-
-! section added for SAC
- integer NSOURCES
-
- double precision t_cmt,elat,elon,depth
- double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
-
- double precision, dimension(nrec) :: stlat,stlon,stele
-
- character(len=256) sisname_2
-
-! variables for SAC header fields
- integer yr,jda,ho,mi
- double precision sec
- real mb
- character(12) ename
-
- real DELTA
- real DEPMIN
- real DEPMAX
- real SCALE_F
- real ODELTA
- real B,E,O,A
- real STLA,STLO,STEL,STDP
- real EVLA,EVLO,EVEL,EVDP
- real MAG,DIST,AZ,BAZ,GCARC
- real DEPMEN
- real USER0,USER1,USER2,USER3
- real CMPAZ,CMPINC
-
- integer NZYEAR,NZJDAY,NZHOUR,NZMIN,NZSEC
- integer NZMSEC,NVHDR,NORID,NEVID
-! NUMBER of POINTS:
- integer NPTS
- integer IFTYPE,IMAGTYP
- integer IDEP
- integer IZTYPE
- integer IEVTYP
- integer IQUAL
- integer ISYNTH
-! permission flags:
- integer LEVEN
- integer LPSPOL
- integer LOVROK
- integer LCALDA
-
- character(8) KSTNM
- character(16) KEVNM
- character(8) KCMPNM
- character(8) KNETWK
- character(8) KUSER0,KUSER1,KUSER2
- character(8), parameter :: str_undef='-12345 '
-
- real UNUSED ! header fields unused by SAC
- real undef ! undefined values
- real INTERNAL ! SAC internal variables, always leave undefined
- real BYSAC
-! end SAC header variables
-
-! flags to determine seismogram type
- logical OUTPUT_SEISMOS_ASCII_TEXT, OUTPUT_SEISMOS_SAC_ALPHANUM, &
- OUTPUT_SEISMOS_SAC_BINARY
-! flag whether seismograms are ouput for North-East-Z component or Radial-Transverse-Z
- logical ROTATE_SEISMOGRAMS_RT
-
-! save all seismograms in one large combined file instead of one file per seismogram
-! to avoid overloading shared non-local file systems such as GPFS for instance
- logical SAVE_ALL_SEISMOS_IN_ONE_FILE
- logical USE_BINARY_FOR_LARGE_FILE
-
-! variables used for calculation of backazimuth and
-! rotation of components if ROTATE_SEISMOGRAMS=.true.
-
- integer ior_start,ior_end
- double precision backaz
- real(kind=CUSTOM_REAL) phi,cphi,sphi
-!----------------------------------------------------------------
-
- if (ROTATE_SEISMOGRAMS_RT) then ! iorientation 1=N,2=E,3=Z,4=R,5=T
- ior_start=3 ! starting from Z
- ior_end =5 ! ending with T => ZRT
- else
- ior_start=1 ! starting from N
- ior_end =3 ! ending with Z => NEZ
- endif
-
- !do iorientation = 1,NDIM
- !do iorientation = 1,5 ! BS BS changed from 3 (NEZ) to 5 (NEZRT) components
- do iorientation = ior_start,ior_end ! BS BS changed according to ROTATE_SEISMOGRAMS_RT
-
- if(iorientation == 1) then
- chn = 'LHN'
- else if(iorientation == 2) then
- chn = 'LHE'
- else if(iorientation == 3) then
- chn = 'LHZ'
- else if(iorientation == 4) then
- chn = 'LHR'
- else if(iorientation == 5) then
- chn = 'LHT'
- else
- call exit_MPI(myrank,'incorrect channel value')
- endif
-
- if (iorientation == 4 .or. iorientation == 5) then ! LMU BS BS
-
- ! BS BS calculate backazimuth needed to rotate East and North
- ! components to Radial and Transverse components
-
- if (backaz>180.) then
- phi=backaz-180.
- elseif (backaz<180.) then
- phi=backaz+180.
- elseif (backaz==180.) then
- phi=backaz
- endif
-
- cphi=cos(phi*pi/180)
- sphi=sin(phi*pi/180)
-
- ! BS BS do the rotation of the components and put result in
- ! new variable seismogram_tmp
- if (iorientation == 4) then ! radial component
- do isample = 1,seismo_current
- seismogram_tmp(iorientation,isample) = &
- cphi * one_seismogram(1,isample) + sphi * one_seismogram(2,isample)
- enddo
- elseif (iorientation == 5) then ! transverse component
- do isample = 1,seismo_current
- seismogram_tmp(iorientation,isample) = &
- -1*sphi * one_seismogram(1,isample) + cphi * one_seismogram(2,isample)
- enddo
- endif
-
- else ! keep NEZ components
- do isample = 1,seismo_current
- seismogram_tmp(iorientation,isample) = one_seismogram(iorientation,isample)
- enddo
-
- endif
-
-! create the name of the seismogram file for each slice
-! file name includes the name of the station and the network
- length_station_name = len_trim(station_name(irec))
- length_network_name = len_trim(network_name(irec))
-
-! check that length conforms to standard
- if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) &
- call exit_MPI(myrank,'wrong length of station name')
-
- if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) &
- call exit_MPI(myrank,'wrong length of network name')
-
-! create the name of the seismogram file using the station name and network name
- write(sisname,"('/',a,'.',a,'.',a3,'.semd')") station_name(irec)(1:length_station_name), &
- network_name(irec)(1:length_network_name),chn
-
-! create this name also for the text line added to the unique big seismogram file
- write(sisname_big_file,"(a,'.',a,'.',a3,'.semd')") station_name(irec)(1:length_station_name), &
- network_name(irec)(1:length_network_name),chn
-
- if (OUTPUT_SEISMOS_SAC_ALPHANUM .or. OUTPUT_SEISMOS_SAC_BINARY) then
-
-!######################## SAC Alphanumeric Seismos ############################
-!
-! written by Markus Treml and Bernhard Schuberth, Dept. for Earth and Environ-
-! mental Sciences, Ludwig-Maximilians-University Munich, Germany
-!
-! some words about SAC timing:
-!==============================
-!
-!NPTS,DELTA,B,E:
-! These define the timing of the seismogram. E is calculated by sac. So, say
-! you have 100 NPTS, a DELTA of 0.5, and set B to 0, E should be 50.
-! Likewise setting B to -50 gives an E of 0. Cutting basically cuts out points
-! between the two times you designate based on these values.
-!KZTIME and KZDATE:
-! Now things get funky. KZTIME defines the exact time that the trace begins
-! at. It has no affect on timing per se. You'll really notice its effect if
-! you read in two traces from different dates.
-
-! Reference markers, (e.g. the o-marker) are not defined relative to this time,
-! but rather to the begin time (B) of the seismo, so if you adjust B, you also
-! need to adjust KZTIME to match. l would suggest experimenting with this until
-! you understand it. It is a little non-intuitive until you see it for yourself.
-!
-!-----------------------------------------------------------------------------
-!
-! This file is essentially the alphanumeric equivalent of the SAC binary data
-! file. The header section is stored on the first 30 cards. This is followed
-! by one or two data sections. The data is in 5G15.7 format.
-!----------------------------------------------------------------------
-
-! define certain default values
-
-! unused or undefined values are set to '-12345.00'
- UNUSED = -12345.00 ! header fields unused by SAC
- undef = -12345.00 ! undefined values
- INTERNAL = -12345.00 ! SAC internal variables, always left undefined
- BYSAC = -12345.00 ! values calculated by SAC from other variables
-!
- DELTA = DT ! [REQUIRED]
- DEPMIN = BYSAC
- DEPMAX = BYSAC
- DEPMEN = BYSAC
- SCALE_F= 1000000000 ! factor for y-value, set to 10e9, so that values are in nm
- ODELTA = undef ! increment from delta
-
- B = sngl((seismo_offset)*DT-hdur + t_cmt) ! [REQUIRED]
- E = BYSAC ! [REQUIRED]
- O = undef !###
- A = undef !###
-!station values:
- STLA = stlat(irec)
- STLO = stlon(irec)
- STEL = stele(irec)
- STDP = undef !stdep(irec)
-!event values (hypocenter):
- EVLA = elat
- EVLO = elon
- EVEL = undef !not defined
- EVDP = depth
-
-!cmt location values (different from hypocenter location, usually):
- USER0 = cmt_lat
- USER1 = cmt_lon
- USER2 = cmt_depth
-
- USER3 = cmt_hdur !half duration from CMT if not changed to hdur=0.d0 (point source)
-
- MAG = mb !
- IMAGTYP= 52 ! 52 = Mb? 55 = Mw!
-
- DIST = BYSAC ! cause
- AZ = BYSAC ! LCALDA
- BAZ = BYSAC ! is
- GCARC = BYSAC ! TRUE
-
-! instrument orientation
- if(iorientation == 1) then !N
- CMPAZ = 0.00
- CMPINC =90.00
- else if(iorientation == 2) then !E
- CMPAZ =90.00
- CMPINC =90.00
- else if(iorientation == 3) then !Z
- CMPAZ = 0.00
- CMPINC = 0.00
- else if(iorientation == 4) then !R
- CMPAZ = modulo(phi,360.) ! phi is calculated above (see call distaz())
- CMPINC =90.00
- else if(iorientation == 5) then !T
- CMPAZ = modulo(phi+90.,360.) ! phi is calculated above (see call distaz())
- CMPINC =90.00
- endif
-!----------------end format G15.7--------
-
-! date and time:
- NZYEAR =yr
- NZJDAY =jda
- NZHOUR =ho
- NZMIN =mi
- NZSEC =int(sec)
- NZMSEC =int((sec-int(sec))*1000)
-
- NVHDR=6 ! SAC header version number. Current is 6
-
-! CSS3.0 variables:
- NORID =int(undef) !origin ID
- NEVID =int(undef) !event ID
-!NWVID =undef !waveform ID
-
-! NUMBER of POINTS:
- NPTS = it_end-seismo_offset ! [REQUIRED]
-! event type
- IFTYPE = 1 ! 1=ITIME, i.e. seismogram [REQUIRED] # numbering system is
- IDEP = 6 ! 6: displ/nm # quite strange, best
-
- IZTYPE = 11 !=origint reference time equivalent ! # by chnhdr and write
- IEVTYP = 40 !event type, 40: Earthquake # alpha and check
- IQUAL = int(undef) ! quality
- ISYNTH = int(undef) ! 1 real data, 2...n synth. flag
-! permission flags:
- LEVEN =1 ! evenly spaced data [REQUIRED]
- LPSPOL=1 ! ? pos. polarity of components (has to be TRUE for LCALDA=1)
- LOVROK=1 ! 1: OK to overwrite file on disk
- LCALDA=1 ! 1: calculate DIST, AZ, BAZ, and GCARC, 0: do nothing
-! ------------------end format 5I10---------
-!
-!----------------------------------
- KSTNM = station_name(irec)(1:8) ! A8
-
- if (NSOURCES == 1) then
- KEVNM = ename(1:len_trim(ename))//'_syn'! A16
- else
- KEVNM = ename(1:len_trim(ename))//'_sFS'! A16
- endif
-
-!----------------------------------
- KCMPNM = chn(3:3) ! 3A8
- KNETWK = network_name(irec) ! A6
-
- KUSER0 = 'CMT_LAT_' ! A8
- KUSER1 = 'CMT_LON_' ! A8
- KUSER2 = 'CMTDEPTH' ! A8
-!----------------------------------
-
- if (OUTPUT_SEISMOS_SAC_ALPHANUM) then
-
- endif ! OUTPUT_SEISMOS_SAC_ALPHANUM
-
-! For explaination on values set, see above (SAC ASCII)
- if (OUTPUT_SEISMOS_SAC_BINARY) then
-
- endif ! OUTPUT_SEISMOS_SAC_BINARY
-
-!#################### end SAC Alphanumeric Seismos ############################
-
- endif ! OUTPUT_SEISMOS_SAC_ALPHANUM .or. OUTPUT_SEISMOS_SAC_BINARY
-
- if(OUTPUT_SEISMOS_ASCII_TEXT) then
-
-! save seismograms in text format with no subsampling.
-! Because we do not subsample the output, this can result in large files
-! if the simulation uses many time steps. However, subsampling the output
-! here would result in a loss of accuracy when one later convolves
-! the results with the source time function
-
-! add .ascii extension to seismogram file name for ASCII seismograms
- write(sisname_2,"('/',a,'.ascii')") trim(sisname)
-
-! create one large file instead of one small file per station to avoid file system overload
- if(SAVE_ALL_SEISMOS_IN_ONE_FILE) then
- if(USE_BINARY_FOR_LARGE_FILE) then
- write(IOUT) sisname_big_file
- else
- write(IOUT,*) sisname_big_file(1:len_trim(sisname_big_file))
- endif
- else
- if (seismo_offset==0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2),status='unknown',action='write')
- else
- open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2),status='old',position='append',action='write')
- endif
-
- endif
-
- ! subtract half duration of the source to make sure travel time is correct
- do isample = 1,seismo_current
- value = dble(seismogram_tmp(iorientation,isample))
-
- if(SAVE_ALL_SEISMOS_IN_ONE_FILE .and. USE_BINARY_FOR_LARGE_FILE) then
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IOUT) sngl(dble(seismo_offset+isample-1)*DT - hdur),sngl(value)
- else
- write(IOUT) dble(seismo_offset+isample-1)*DT - hdur,value
- endif
- else
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IOUT,*) sngl(dble(seismo_offset+isample-1)*DT - hdur),' ',sngl(value)
- else
- write(IOUT,*) dble(seismo_offset+isample-1)*DT - hdur,' ',value
- endif
- endif
-
- enddo
-
- if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) close(IOUT)
-
- endif ! OUTPUT_SEISMOS_ASCII_TEXT
-
- enddo ! do iorientation
-
- end subroutine write_one_seismogram
-
More information about the cig-commits
mailing list